module:         devel-dbg-ui
synopsis:       A parser for debugger commands and debugger expressions
author:         Paul Howard
Copyright:    Original Code is Copyright (c) 1995-2004 Functional Objects, Inc.
              All rights reserved.
License:      See License.txt in this distribution for details.
Warranty:     Distributed WITHOUT WARRANTY OF ANY KIND

/*
///// <PARSE-ERROR>
//    The error that is signalled when a token does not match any allowed
//    token.

define class <parse-error> (<error>)
end class;
*/

// The token sequence is a thread-unsafe resource. We must not enter
// the parser concurrently.

define constant $parsing-lock = make(<recursive-lock>);


///// PARSE-ERROR-HANDLER
//    Is called when a bad token is encountered. The argument is a vector
//    of codes of expected tokens. This allows us to do some reasonably
//    intelligent error checking/correcting at some stage of the game.

define method parse-error-handler
    (allowable-set :: <vector>) => ()
  debugger-message("Error: Unexpected token %s found.", current-lexeme());
//  signal(make(<parse-error>));
end method;


///// *CURRENT-PARSE-SEQUENCE*
//    Holds the current sequence of tokens being parsed.

define variable *current-parse-sequence* = make(<stretchy-vector>, size: 0);


///// *CURRENT-PARSE-INDEX*
//    Holds the index of the lookahead token in the current parse sequence.

define variable *current-parse-index* = 0;


///// SET-PARSE-SEQUENCE
//    Prepares the debugger for building a new command from a sequence of
//    tokens generated by TOKENIZE

define method set-parse-sequence (seq :: <sequence>) => ()
  *current-parse-sequence* := seq;
  *current-parse-index* := 0;
end method;


///// ACCEPT
//    Consumes the lookahead token if its code matches the supplied code,
//    otherwise calls PARSE-ERROR-HANDLER 

define method accept (token-code :: <integer>) => ()
  if (token-code == *current-parse-sequence*[*current-parse-index*].code)
    if (token-code ~== $tokenTerminator)
      *current-parse-index* := *current-parse-index* + 1;
    end if;
  else
    parse-error-handler(vector(token-code));
  end if;
end method;


///// ACCEPT-ANYTHING
//    Consumes the lookahead token. No warnings, no errors.

define method accept-anything () => ()
  let token-code = *current-parse-sequence*[*current-parse-index*].code;
  *current-parse-index* := *current-parse-index* + 1;
end method;


///// TOKEN-IS
//    Returns #t and consumes the lookahead token if its code matches the
//    supplied code. Otherwise, does not consume the token and returns
//    #f.

define method token-is (token-code :: <integer>) => (answer :: <boolean>)
  if (token-code == *current-parse-sequence*[*current-parse-index*].code)
    if (token-code ~== $tokenTerminator)
      *current-parse-index* := *current-parse-index* + 1;
    end if;
    #t;
  else
    #f;
  end if;
end method;


///// TOKEN-WILL-BE
//    Returns #t if the lookahead token matches the given code, otherwise
//    returns #f. Does NOT consume the lookahead token in any case.

define method token-will-be (token-code :: <integer>) => (answer :: <boolean>)
  if (token-code == *current-parse-sequence*[*current-parse-index*].code)
    #t;
  else
    #f;
  end if;
end method;


///// CURRENT-LEXEME
//    Returns the string representation of the lookahead token.

define method current-lexeme () => (lex :: <string>)
  *current-parse-sequence*[*current-parse-index*].representation;
end method;


///// CURRENT-TOKEN
//    Just returns the lookahead token

define method current-token () => (tok :: <token>)
  *current-parse-sequence*[*current-parse-index*]
end method;


///// $DEFAULT-NAME-CONTEXT

define constant $default-name-context = make(<dylan-name-context>);


///// CURRENT-NAME-CONTEXT
//    Returns $default-name-context if there is no open application,
//    otherwise returns the current name context.

define method current-name-context () => (ctx :: <dylan-name-context>)
  if (*open-application*)
    *open-application*.default-name-context
  else
    $default-name-context
  end if
end method;


///// OBTAIN-COMPONENT-NAME (Method on debugger-manager GF)

define method obtain-component-name
    (application :: <application>, libname :: <string>)
  => (component-name :: <string>)
  if (as-uppercase(libname) = "DYLAN")
    *current-debugger-options*.name-of-dylan-component
  else
    libname
  end if
end method;


///// CORE-NAME-TO-LIBRARY
//    Returns a <remote-library> object, if one exists whose core name
//    matches the supplied name.

define method core-name-to-library
    (application :: <application>, core-name :: <string>)
       => (maybe-lib :: false-or(<remote-library>))
  block (found)
    do-libraries
      (method (l :: <remote-library>)
         if (as-uppercase(core-name) = as-uppercase(l.library-core-name))
           found(l);
        end if;
      end method,
      application.debug-target-access-path);
  end block
   | find-library-called
       (application,
        obtain-component-name(application, core-name))
end method;


///// BUILD-DEBUGGER-COMMAND
//    Returns a <debugger-command>

define method build-debugger-command () => (command :: <debugger-command>)

  local method find-connection-on(host :: <string>) =>
                      (maybe-connection :: false-or(<debugger-connection>))
          block(return)
            do-open-debugger-connections
              (method (dc :: <debugger-connection>) => ()
                 if (instance?(dc, <remote-debugger-connection>) &
                     (dc.connection-hostname = host))
                   return(dc)
                 end if
               end method);
            return(#f);
          end block;
        end;

  let command = make(<bad-command>);
  with-lock($parsing-lock)
    if (token-is($tokenConnect))
      if (token-will-be($tokenString))
        let net-addr = generate-actual-string(current-token());
        accept($tokenString);
        if (token-will-be($tokenString))
          let password = generate-actual-string(current-token());
          accept($tokenString);
          command := make(<attempt-connection-command>,
                          network-address: net-addr,
                          password: password);
        end if;
      else
        command := make(<enumerate-open-connections-command>);
      end if;
      accept($tokenTerminator);
    elseif (token-is($tokenList))
      let connection = 
        if (token-is($tokenOn))
          let maybe-connection = find-connection-on(current-lexeme());
          accept($tokenDylanSymbol);
          maybe-connection |
          begin
            debugger-message("*** ERROR: No such connection. Using local.");
            host-machine();
          end
        else
          host-machine();
        end if;
      command := make(<enumerate-processes-command>,
                      connection: connection);
      accept($tokenTerminator);
    elseif (token-is($tokenOpen))
      let connection = 
        if (token-is($tokenOn))
          let maybe-connection = find-connection-on(current-lexeme());
          accept($tokenDylanSymbol);
          maybe-connection |
          begin
            debugger-message("*** ERROR: No such connection. Using local.");
            host-machine();
          end
        else
          host-machine();
        end if;
      if (token-will-be($tokenString))
        let filename = generate-actual-string(current-token());
        let arguments = "";
        accept($tokenString);
        if (token-will-be($tokenString))
          arguments := generate-actual-string(current-token());
          accept($tokenString);
        end if;
        accept($tokenTerminator);
        command := make(<open-application-command>,
                        filename: filename,
                        arguments: arguments,
                        connection: connection);
      else
        let process-id = current-lexeme();
        command := make(<attach-application-command>,
                        id: process-id,
                        connection: connection);
      end if;
/*  // Not supported anymore.
    // users should use -interact command option instead.

    elseif (token-is($tokenIopen))
      if (token-will-be($tokenString))
        let filename = generate-actual-string(current-token());
        let arguments = "";
        let lib = "dylan";
        let mod = "dylan";
        accept($tokenString);
        if (token-will-be($tokenString))
          arguments := generate-actual-string(current-token());
          accept($tokenString);
        end if;
        if (token-will-be($tokenModuleQualifiedSymbol))
          let (the-lib, the-mod) = generate-namespace(current-token());
          lib := the-lib;
          mod := the-mod;
          accept($tokenModuleQualifiedSymbol);
        end if;
        accept($tokenTerminator);
        command := make(<open-and-interact-command>,
                        filename: filename,
                        arguments: arguments,
                        library: lib,
                        module: mod);
      else
        parse-error-handler(#[])
      end if;
*/
    elseif (token-will-be($tokenFrom) | token-will-be($tokenDownload))
      let object-file-path = "";
      if (token-is($tokenFrom))
        object-file-path := generate-actual-string(current-token());
        accept($tokenString);
      end if;
      accept($tokenDownload);
      let file-set = make(<stretchy-vector>, size: 0);
      let object-file-name = generate-actual-string(current-token());
      accept($tokenString);
      add!(file-set, concatenate(object-file-path, object-file-name));
      while (token-is($tokenComma))
        object-file-name := generate-actual-string(current-token());
        accept($tokenString);
        add!(file-set, concatenate(object-file-path, object-file-name));
      end while;
      accept($tokenTerminator);
      command := make(<download-object-files-command>,
                      filenames: file-set);

    elseif (token-is($tokenProfile))   /// Arrrrgh! Hairy syntax!!!
      if (token-will-be($tokenString))
        let filename = generate-actual-string(current-token());
        let arguments = "";
        accept($tokenString);
        if (token-will-be($tokenString))
          arguments := generate-actual-string(current-token());
          accept($tokenString);
        end if;
        accept($tokenTerminator);
        command := make(<profile-application-command>,
                        filename: filename,
                        arguments: arguments);

      elseif (token-is($tokenDebug))
	accept($tokenTerminator);
	command := make(<profile-debug-command>);

      elseif (token-is($tokenHeight))
	let argument
	  = if (token-will-be($tokenLiteralInteger))
	      let r = decimal-string-to-integer(current-lexeme());
	      accept($tokenLiteralInteger);
	      r
	    end if;
	accept($tokenTerminator);
	command := make(<profile-height-command>, argument: argument);

      elseif (token-is($tokenLimit))
	command := parse-profile-limit-command(<profile-limit-command>);

      elseif (token-is($tokenLimit0))
	command := parse-profile-limit-command(<profile-limit-0-command>);

      elseif (token-is($tokenLimit1))
	command := parse-profile-limit-command(<profile-limit-1-command>);

      elseif (token-is($tokenLimit2))
	command := parse-profile-limit-command(<profile-limit-2-command>);

      elseif (token-is($tokenTopN))
	command := parse-profile-top-n-command(<profile-top-n-command>);

      elseif (token-is($tokenTopN0))
	command := parse-profile-top-n-command(<profile-top-n-0-command>);

      elseif (token-is($tokenTopN1))
	command := parse-profile-top-n-command(<profile-top-n-1-command>);

      elseif (token-is($tokenTopN2))
	command := parse-profile-top-n-command(<profile-top-n-2-command>);

      elseif (token-is($tokenFilter))
        block (blow) 
          command := parse-profile-filter-command(<profile-filter-command>, blow);
        end block;

      elseif (token-is($tokenFilter1))
        block (blow) 
          command := parse-profile-filter-command(<profile-filter-1-command>, blow);
        end block;

      elseif (token-is($tokenFilter2))
        block (blow) 
          command := parse-profile-filter-command(<profile-filter-2-command>, blow);
        end block;

      elseif (token-is($tokenAggregates))
        block (blow) 
          command := parse-profile-aggregates-command(<profile-aggregates-command>, blow);
        end block;

      elseif (token-is($tokenAggregates1))
        block (blow) 
          command := parse-profile-aggregates-command(<profile-aggregates-1-command>, blow);
        end block;

      elseif (token-is($tokenAggregates2))
        block (blow) 
          command := parse-profile-aggregates-command(<profile-aggregates-2-command>, blow);
        end block;

      elseif (token-is($tokenSet))
        block (blow)
	  let (name, set) =
	    if (token-will-be($tokenDylanSymbol))
	      let name = as(<symbol>, current-lexeme());
	      accept($tokenDylanSymbol);
	      values(name, build-profile-set(blow))
	    else
	      parse-error-handler(vector($tokenDylanSymbol));
	      blow();
	    end if;
	  command := make(<profile-set-command>, name: name, set: set);
	  accept($tokenTerminator);
	end block;

      elseif (token-is($tokenShow))
        if (token-is($tokenAggregates))
          command := make(<profile-show-aggregates-command>, 
	                  argument: build-simple-expression());
          accept($tokenTerminator);
        else
          parse-error-handler(vector($tokenAggregates));
        end if;

      elseif (token-is($tokenSets))
	command := make(<profile-sets-command>);
        accept($tokenTerminator);

      elseif (token-is($tokenResults))
        accept($tokenTerminator);
        command := make(<stop-profiling-open-application-command>);

      elseif (token-is($tokenHotspots))
        accept($tokenTerminator);
        command := make(<stop-profiling-and-show-hotspots-command>);

      elseif (token-is($tokenOff))
        accept($tokenTerminator);
        command := make(<stop-profiling-and-ignore-results-command>);


      elseif (token-is($tokenInclusive))
	let argument =
	  case 
	    token-is($tokenYes) => #t;
	    token-is($tokenNo)  => #f;
	    otherwise =>           #"unknown";
	  end case;
        accept($tokenTerminator);
        command := make(<profile-inclusive-command>, argument: argument);


      elseif (token-is($tokenExclusive))
	let argument =
	  case 
	    token-is($tokenYes) => #t;
	    token-is($tokenNo)  => #f;
	    otherwise =>           #"unknown";
	  end case;
        accept($tokenTerminator);
        command := make(<profile-exclusive-command>, argument: argument);


      elseif (token-will-be($tokenThreads)       |
              token-will-be($tokenAllocation)    |
              token-will-be($tokenClass)         |
              token-will-be($tokenFaults)        |
              token-will-be($tokenWallClockTime) |
              token-will-be($tokenAt)            |
              token-will-be($tokenDepth)         |
              token-will-be($tokenIn)            |
              token-will-be($tokenTerminator))
        let threads = make(<stretchy-vector>);
        let depth = #f;
        let asking = #f;
        let interval = $default-profiling-interval;
        let expression = #f;
        let style
	  = case
	      token-is($tokenAllocation)    => #"allocation";
	      token-is($tokenClass)         => #"class-allocation";
	      token-is($tokenFaults)        => #"page-faults";
              token-is($tokenWallClockTime) => #"wall-clock-time";
	      otherwise                     => #"cpu-time";
	    end case;
        if (token-is($tokenThreads))
          if (token-will-be($tokenLiteralInteger))
	    add!(threads, decimal-string-to-integer(current-lexeme()));
            accept($tokenLiteralInteger);
            while (token-is($tokenComma))
              add!(threads, decimal-string-to-integer(current-lexeme()));
              accept($tokenLiteralInteger);
            end while;
          elseif (token-is($tokenAll))
	    if (*open-application*)
	      for (thread in all-threads(*open-application*))
		add!(threads, thread);
	      end for;
	    end if;
          end if;
          if (token-is($tokenAsk))
            asking := #t;
          end if;
        end if;
        if (token-is($tokenAt))
          interval := decimal-string-to-integer(current-lexeme());
          accept($tokenLiteralInteger);
        end if;
        if (token-is($tokenDepth))
          depth := decimal-string-to-integer(current-lexeme());
          accept($tokenLiteralInteger);
        end if;
        if (token-is($tokenIn))
          expression := build-simple-expression();
        end if;
        accept($tokenTerminator);
	let options
	  = make(<profiler-options>,
		 style: style,
		 depth: depth,
		 threads: threads,
		 interval: interval,
		 asking-for-threads?: asking);
        if (expression)
          command := make(<profile-within-invocation-command>,
			  options: options,
			  function: expression);
        else
          command := make(<start-profiling-open-application-command>,
			  options: options);
        end if;
      else
        parse-error-handler(#[])
      end if;

    elseif (token-is($tokenRestart))
      accept($tokenTerminator);
      command := make(<restart-command>);

    elseif (token-is($tokenContinue))
      if (token-is($tokenTerminator))
        command := make(<continue-command>);
      else
        let index = decimal-string-to-integer(current-lexeme());
        accept($tokenLiteralInteger);
        accept($tokenTerminator);
        command := make(<continue-via-restart-command>, index: index);
      end if;

    elseif (token-is($tokenOptions))
      accept($tokenTerminator);
      command := make(<enumerate-restarts-command>);

/*
    elseif (token-will-be($tokenFilter) | token-will-be($tokenReveal))
      let filter =
        if (token-is($tokenFilter))
          #t
        else
          accept($tokenReveal);
          #f;
        end if;
      if (token-is($tokenCleanups))
        accept($tokenTerminator);
        command := make(<filter-cleanups-command>, filtering?: filter);
      elseif (token-is($tokenForeign))
        accept($tokenTerminator);
        command := make(<filter-foreign-command>, filtering?: filter);
      elseif (token-is($tokenPrimitives))
        accept($tokenTerminator);
        command := make(<filter-primitives-command>, filtering?: filter);
      elseif (token-is($tokenContext))
        let (modname, libname) = generate-namespace(current-token());
        accept($tokenModuleQualifiedSymbol);
        accept($tokenTerminator);
        command := make(<filter-context-command>,
                        filtering?: filter,
                        module: as-lowercase(modname),
                        library: as-lowercase(libname));
      elseif (token-is($tokenLibrary))
        let dll-name = current-lexeme();
        let dll-object =
          if (*open-application*)
            core-name-to-library(*open-application*, dll-name);
          else
            #f;
          end if;
        if (dll-object)
          accept($tokenDylanSymbol);
          accept($tokenTerminator);
          command := make(<filter-dll-command>, dll: dll-object);
        else
          debugger-message("WARNING: Couldn't find a library called %s",
                           as-uppercase(dll-name));
          parse-error-handler(#[]);
        end if;
      else
        parse-error-handler(#[]);
      end if;
*/
    elseif (token-is($tokenDirective))
      let class-name = current-lexeme();
      accept($tokenDylanSymbol);
      accept($tokenIn);
      let module-name = current-lexeme();
      accept($tokenDylanSymbol);
      accept($tokenPrint);
      let instructions = make(<stretchy-vector>, size: 0);
      while (~token-is($tokenTerminator))
        if (token-will-be($tokenString))
          add!(instructions, 
               pair(#"string", generate-actual-string(current-token())));
          accept($tokenString);
        elseif (token-will-be($tokenDylanSymbol))
          let slot-name = current-lexeme();
          accept($tokenDylanSymbol);
          if (token-will-be($tokenComma))
            let slots = make(<stretchy-vector>, size: 0);
            add!(slots, slot-name);
            while (token-is($tokenComma))
              let next-slot = current-lexeme();
              accept($tokenDylanSymbol);
              add!(slots, next-slot);
            end while;
            add!(instructions, pair(#"indirect-slot", slots));
          else
            add!(instructions, pair(#"slot", slot-name));
          end if;
        else
          debugger-message("WARNING: Ignoring unexpected token %s",
                           current-lexeme());
          accept-anything();
	end if;
      end while;
      let directive = make(<debugger-print-directive>,
                           print-class-name: class-name,
                           print-module-name: module-name,
                           print-instructions: instructions);
      command := make(<add-print-directive-command>,
                      new-directive: directive);

    elseif (token-is($tokenSuspend))
      if (token-will-be($tokenLiteralInteger))
        let index = decimal-string-to-integer(current-lexeme());
        accept($tokenLiteralInteger);
        accept($tokenTerminator);
        command := make(<suspend-command>, thread-number: index);
      else
        parse-error-handler(#[]);
      end if;

    elseif (token-is($tokenResume))
      if (token-will-be($tokenLiteralInteger))
        let index = decimal-string-to-integer(current-lexeme());
        accept($tokenLiteralInteger);
        accept($tokenTerminator);
        command := make(<resume-command>, thread-number: index);
      else
        parse-error-handler(#[]);
      end if;

    elseif (token-is($tokenEnable))
      let cookie = decimal-string-to-integer(current-lexeme());
      accept($tokenLiteralInteger);
      accept($tokenTerminator);
      command := make(<enable-breakpoint-command>, cookie: cookie);

    elseif (token-is($tokenDisable))
      let cookie = decimal-string-to-integer(current-lexeme());
      accept($tokenLiteralInteger);
      accept($tokenTerminator);
      command := make(<disable-breakpoint-command>, cookie: cookie);

    elseif (token-is($tokenIgnore))
      let cookie = decimal-string-to-integer(current-lexeme());
      accept($tokenLiteralInteger);
      if (token-is($tokenFor))
        let count = decimal-string-to-integer(current-lexeme());
        accept($tokenLiteralInteger);
        command := make(<counted-ignore-command>,
                        cookie: cookie, count: count);
      else
        command := make(<blanket-ignore-command>, cookie: cookie);
      end if;
      accept($tokenTerminator);

    elseif (token-is($tokenKill))
      accept($tokenTerminator);
      command := make(<kill-command>)

    elseif (token-is($tokenQuit))
      accept($tokenTerminator);
      command := make(<exit-debugger-command>);

    elseif (token-is($tokenDW))
      accept($tokenTerminator);
      command := make(<drop-into-compiler-command>);

    elseif (token-is($tokenInteract))
      accept($tokenTerminator);
      command := make(<execute-source-command>);

    elseif (token-is($tokenBacktrace))
      let ver = #f;
      if (token-is($tokenVerbose))
        ver := #t
      end if;
      if (token-will-be($tokenLiteralInteger))
        let limit = decimal-string-to-integer(current-lexeme());
        accept($tokenLiteralInteger);
        accept($tokenTerminator);
        command := make(<limited-backtrace-command>, limit: limit,
                        verbose?: ver);
      else
        accept($tokenTerminator);
        command := make(<backtrace-command>, verbose?: ver);
      end if;

    elseif (token-is($tokenFrame))
      if (token-will-be($tokenLiteralInteger))
        let index = decimal-string-to-integer(current-lexeme());
        accept($tokenLiteralInteger);
        command := make(<into-frame-command>, index: index);
      else
        command := make(<frame-command>);
      end if;
      accept($tokenTerminator);

    elseif (token-is($tokenTop))
      accept($tokenTerminator);
      command := make(<top-command>);

    elseif (token-is($tokenBottom))
      accept($tokenTerminator);
      command := make(<bottom-command>);

    elseif (token-is($tokenUp))
      accept($tokenTerminator);
      command := make(<up-command>);

    elseif (token-is($tokenDown))
      accept($tokenTerminator);
      command := make(<down-command>);

    elseif (token-is($tokenStep))
      if (token-is($tokenOver))
        command := make(<step-over-command>);
      elseif (token-is($tokenOut))
        command := make(<step-out-command>);
      elseif (token-is($tokenInto))
        command := make(<step-into-command>);
      else
        command := make(<step-over-command>);
      end if;
      accept($tokenTerminator);

    elseif (token-is($tokenWhere))
      accept($tokenTerminator);
      command := make(<where-command>);

    elseif (token-is($tokenHelp))
      accept($tokenTerminator);
      command := make(<cry-in-the-dark-command>);

    elseif (token-is($tokenShutUp))
      accept($tokenTerminator);
      command := make(<shutup-command>);

    elseif (token-is($tokenExceptions))
      accept($tokenTerminator);
      command := make(<exceptions-command>);

    elseif (token-is($tokenBug))
      accept($tokenTerminator);
      command := make(<bug-report-command>);

    elseif (token-is($tokenShow))
      if (token-is($tokenThreads))
        command := make(<enumerate-threads-command>);
      elseif (token-is($tokenLibraries))
        command := make(<enumerate-libraries-command>);
      elseif (token-is($tokenRegisters))
        command := make(<enumerate-registers-command>);
      else
        parse-error-handler(#[])
      end if;
      accept($tokenTerminator);

    elseif (token-is($tokenIn))
      if (token-is($tokenThread))
        if (token-will-be($tokenLiteralInteger))
          let index = decimal-string-to-integer(current-lexeme());
          accept($tokenLiteralInteger);
          command := make(<change-thread-command>, to: index);
        else
          parse-error-handler(#[]);
        end if;
      elseif (token-is($tokenLibrary))
        let new-library = current-lexeme();
        accept($tokenDylanSymbol);
        command := make(<change-library-command>, to: new-library);
      elseif (token-is($tokenModule))
        let new-module = current-lexeme();
        accept($tokenDylanSymbol);
        command := make(<change-module-command>, to: new-module);
      else
        parse-error-handler(#[]);
      end if;
      accept($tokenTerminator);

    elseif (token-is($tokenBreak))
      if (token-is($tokenLine))
        let dll =
          if (*open-application*)
            *open-application*.default-name-context.context-library
	  else
            "dylan"
	  end if;
        let linenumber = decimal-string-to-integer(current-lexeme());
        accept($tokenLiteralInteger);
        let colnumber = 0;
        if (token-is($tokenColumn))
          colnumber := decimal-string-to-integer(current-lexeme());
          accept($tokenLiteralInteger);
        end if;
        accept($tokenOf);
        let sourcename = generate-actual-string(current-token());
        accept($tokenString);
        if (token-is($tokenIn))
          dll := current-lexeme();
          accept($tokenDylanSymbol);
	end if;
        accept($tokenTerminator);
        command := make(<break-source-command>,
                        line: linenumber,
                        column: colnumber,
                        file: sourcename,
                        dll: dll);
      elseif (token-is($tokenClass))
        let expression = build-simple-expression();
        accept($tokenTerminator);
        command := make(<break-class-command>, address: expression);
      else
        let expression = build-simple-expression();
        accept($tokenTerminator);
        command := make(<break-command>, address: expression);
      end if;

    elseif (token-is($tokenSet))
      let lhs = build-simple-expression();
      let rhs = build-simple-expression();
      command := make(<set-command>,
                      lhs-expression: lhs,
                      rhs-expression: rhs);
      accept($tokenTerminator);

    elseif (token-is($tokenTrace))
      let expression = build-simple-expression();
      accept($tokenTerminator);
      command := make(<trace-command>, address: expression);

    elseif (token-is($tokenNearto))
      let expression = build-simple-expression();
      accept($tokenTerminator);
      command := make(<nearto-command>, target: expression);

    elseif (token-is($tokenClear))
      if (token-is($tokenTerminator))
        command := make(<clear-command>);
      else
        if (token-is($tokenLine))
          let linenumber = decimal-string-to-integer(current-lexeme());
          accept($tokenLiteralInteger);
          let colnumber = 0;
          if (token-is($tokenColumn))
            colnumber := decimal-string-to-integer(current-lexeme());
            accept($tokenLiteralInteger);
          end if;
          accept($tokenOf);
          let sourcename = generate-actual-string(current-token());
          accept($tokenString);
          accept($tokenTerminator);
          command := make(<clear-source-command>,
                          line: linenumber,
                          column: colnumber,
                          file: sourcename);
        elseif (token-will-be($tokenLiteralInteger))
          let cookie = decimal-string-to-integer(current-lexeme());
          accept($tokenLiteralInteger);
          command := make(<clear-cookie-breakpoint-command>, cookie: cookie);
          accept($tokenTerminator);
	elseif (token-is($tokenClass))
          if (token-is($tokenAll))
	    accept($tokenTerminator);
	    command := make(<clear-all-class-command>);
	  else
	    let expression = build-simple-expression();
	    accept($tokenTerminator);
	    command := make(<clear-class-command>, address: expression);
	  end;
        else
          let expression = build-simple-expression();
          accept($tokenTerminator);
          command := make(<clear-specific-command>, address: expression);
        end if;
      end if;

    elseif (token-is($tokenUntrace))
      if (token-is($tokenTerminator))
        command := make(<untrace-command>);
      else
        let expression = build-simple-expression();
        accept($tokenTerminator);
        command := make(<untrace-specific-command>, address: expression);
      end if;

    elseif (token-is($tokenBreakpoints))
      accept($tokenTerminator);
      command := make(<breakpoints-command>);

    elseif (token-is($tokenMV))
      accept($tokenTerminator);
      command := make(<view-multiple-values-command>);

    elseif (token-is($tokenPrint))
      let expression = build-simple-expression();
      accept($tokenTerminator);
      command := make(<print-command>, object: expression);

    elseif (token-is($tokenDescribe))
      let expression = build-simple-expression();
      accept($tokenTerminator);
      command := make(<describe-command>, object: expression);

    elseif (token-is($tokenWalk))
      let expression = build-simple-expression();
      let classes = #[];
      let modules = #[];
      let class-status = #"trace-everything";
      let module-status = #"trace-everything";
      if (token-will-be($tokenInclude) | token-will-be($tokenExclude))
        if (token-is($tokenInclude))
          class-status := #"include"
	else
          class-status := #"exclude";
          accept($tokenExclude)
	end if;
        classes := build-name-list();
      end if;
      if (token-is($tokenModule))
        if (token-is($tokenInclude))
          module-status := #"include"
	else
          module-status := #"exclude";
          accept($tokenExclude)
	end if;
        modules := build-name-list();
      end if;
      accept($tokenTerminator);
      command := make(<walk-command>, 
                      object: expression,
                      classes: classes,
                      modules: modules,
                      class-status: class-status,
                      module-status: module-status);

    elseif (token-is($tokenExplode))
      let expression = build-simple-expression();
      accept($tokenTerminator);
      command := make(<explode-command>, object: expression);

    elseif (token-is($tokenEvaluate))
      if (token-is($tokenTerminator))
        // "eval" by itself switches between listener modes
        command := make(<switch-listener-modes-command>);
      else
        let expression = build-debugger-expression();
        accept($tokenTerminator);
        command := make(<evaluate-expression-command>, expression: expression);
      end if;

    elseif (token-is($tokenDisplay))
      let starting-expression = build-simple-expression();
      let display-format = #"word";
      let lines = 8;
      if (token-is($tokenLines))
        lines := decimal-string-to-integer(current-lexeme());
        accept($tokenLiteralInteger);
      end if;
      if (token-is($tokenAscii))
        display-format := #"ascii";
      elseif (token-is($tokenDisassembly))
        display-format := #"disassembly";
      elseif (token-is($tokenBytes))
        display-format := #"byte";
      else
        display-format := #"word";
      end if;
      command := make(<display-from-command>,
                      from: starting-expression,
                      as: display-format,
                      lines: lines);
      accept($tokenTerminator);

    elseif (token-is($tokenTerminator))
      command := make(<null-command>);

    else
      parse-error-handler(#[]);
    end if;
  end with-lock;
  command
end method;

define method parse-profile-top-n-command 
    (command-class :: <class>) => (command)
  let argument
    = if (token-will-be($tokenLiteralInteger))
	let r = decimal-string-to-integer(current-lexeme());
	accept($tokenLiteralInteger);
	r
      end if;
  accept($tokenTerminator);
  make(command-class, argument: argument);
end method;

define method parse-profile-limit-command 
    (command-class :: <class>) => (command)
  let argument
    = if (token-will-be($tokenLiteralInteger))
	let r = decimal-string-to-integer(current-lexeme()) / 100.0;
	accept($tokenLiteralInteger);
	r
      end if;
  accept($tokenTerminator);
  make(command-class, argument: argument);
end method;

define method parse-profile-filter-command 
    (command-class :: <class>, blow :: <function>) => (command)
  let profile-set =
    unless (token-will-be($tokenTerminator))
      build-profile-set(blow);
    end unless;
  accept($tokenTerminator);
  make(command-class, argument: profile-set)
end method;

define method parse-profile-aggregates-command 
    (command-class :: <class>, blow :: <function>) => (command)
  let lump-names =
    collecting ()
      until (token-will-be($tokenTerminator))
	if (token-will-be($tokenDylanSymbol))
	  collect(as(<symbol>, current-lexeme()));
	  accept($tokenDylanSymbol);
	elseif (token-is($tokenLibraries))
          collect($tokenLibraries);
        else
	  parse-error-handler(vector($tokenDylanSymbol));
	  blow();
	end if;
      end until;
      accept($tokenTerminator);
    end collecting;
  make(command-class, arguments: lump-names);
end method;

///// BUILD-DEBUGGER-EXPRESSION
//    Returns a <debugger-expression>

define method build-debugger-expression () => (expr :: <debugger-expression>)
  let simple-part = build-simple-expression();
  if (token-is($tokenOpenBracket))
    let arglist = make(<stretchy-vector>, size: 0);
    unless (token-will-be($tokenCloseBracket))
      let (keyword-part, argument) = build-argument();
      if (keyword-part)
        add!(arglist, keyword-part);
      end if;
      add!(arglist, argument);
      while (token-is($tokenComma))
        let (keyword-part, argument) = build-argument();
        if (keyword-part)
          add!(arglist, keyword-part);
        end if;
        add!(arglist, argument);
      end while;
    end unless;
    accept($tokenCloseBracket);
    make(<function-expression>,
         function: simple-part,
         arguments: arglist);
  else
    simple-part;
  end if
end method;


///// BUILD-NAME-LIST
//    Returns a sequence of <string>s.

define method build-name-list () => (seq :: <sequence>)
  let seq = make(<stretchy-vector>, size: 1);
  seq[0] := as-uppercase(current-lexeme());
  accept($tokenDylanSymbol);
  while (token-is($tokenComma))
    add!(seq, as-uppercase(current-lexeme()));
    accept($tokenDylanSymbol);
  end while;
  seq;
end method;


///// BUILD-PROFILE-SET
//    Returns a <profile-set>

define method application-lookup-named-set
    (name :: <symbol>) => (res :: false-or(<profile-set>))
  *open-application* &
    element(application-profile-sets(*open-application*), name, default: #f)
end method;

define method build-profile-set (blow :: <function>) => (res :: <profile-set>)
  local method next-token (token-type, generate :: <function>)
	  if (token-will-be(token-type))
            let result = generate();
	    accept(token-type);
            result
	  else
	    parse-error-handler(vector(token-type));
	    blow();
	  end if;
	end method,
        method next-name ()
          next-token($tokenDylanSymbol, method () as(<symbol>, current-lexeme()) end)
        end method,
        method next-string ()
          next-token($tokenString, 
		     method () as(<symbol>, generate-actual-string(current-token())) end)
        end method;
  case 
    token-is($tokenEmpty) => 
      make(<profile-set-empty>);
    token-is($tokenFull) => 
      make(<profile-set-full>);
    token-is($tokenSet) => 
      application-lookup-named-set(next-name());
    token-is($tokenContains) => 
      make(<profile-set-contains>, contains: next-string());
    token-is($tokenLibrary) => 
      make(<profile-set-library>, library: next-name());
    token-is($tokenDll) => 
      make(<profile-set-dll>, dll: next-name());
    token-is($tokenModule) => 
      make(<profile-set-module>, module: next-name());
    token-is($tokenFile) => 
      make(<profile-set-file>, file: next-string());
    token-is($tokenNot) => 
      make(<profile-set-complement>, complementee: build-profile-set(blow));
    token-is($tokenUnion) => 
      make(<profile-set-union>, 
	   unionees: vector(build-profile-set(blow), build-profile-set(blow)));
    token-is($tokenIntersection) => 
      make(<profile-set-intersection>, 
	   intersectees: vector(build-profile-set(blow), build-profile-set(blow)));
    otherwise =>
      compute-profile-set-functions(*open-application*, build-simple-expression())
  end case;
end method;

define method compute-profile-set-functions-from-targets
    (app :: <application>, targets :: <sequence>) => (res :: <profile-set>)
  local method set-function-from-target
	    (target) => (res :: <profile-set>)
	  let (closest, offset) 
	    = symbol-table-symbol-relative-address
	        (debug-target-symbol-table(app), target);
	  if (closest)
 	    make(<profile-set-function>, function: as(<symbol>, remote-symbol-name(closest)))
          else
            debugger-message("Couldn't find function @ %=", target);
	    make(<profile-set-empty>)
          end if
	end method;
  select (size(targets))
    0 =>         make(<profile-set-empty>);
    1 =>         set-function-from-target(targets[0]);
    otherwise => make(<profile-set-union>, 
		      unionees: map(set-function-from-target, targets));
  end select;
end method;

define method compute-profile-set-functions 
    (app :: <application>, expression :: <simple-expression>) 
 => (res :: <profile-set>)
  let targets = compute-function-breakpoint-targets(app, expression);
  compute-profile-set-functions-from-targets(app, targets)
end method;

define method compute-profile-set-functions 
    (app :: <application>, name :: <byte-string>) 
 => (res :: <profile-set>)
  let symbol = symbol-table-find-symbol(app.debug-target-symbol-table, name);
  if (symbol)
    let targets = compute-general-breakpoint-targets (app, remote-symbol-address(symbol));
    compute-profile-set-functions-from-targets(app, targets)
  else
    make(<profile-set-empty>)
  end if
end method;

///// BUILD-SIMPLE-EXPRESSION
//    Returns a <simple-debugger-expression>

define method build-simple-expression () => (expr :: <simple-expression>)
  let ex = make(<illegal-simple-expression>);
  if (token-is($tokenVectorOpener))
    let expression-set = make(<stretchy-vector>, size: 0);
    unless (token-will-be($tokenVectorCloser))
      add!(expression-set, build-simple-expression());
      while (token-is($tokenComma))
        add!(expression-set, build-simple-expression());
      end while;
    end unless;
    accept($tokenVectorCloser);
    ex := make(<downloaded-vector-expression>, elements: expression-set);
  elseif (token-is($tokenListOpener))
    let expression-set = make(<stretchy-vector>, size: 0);
    unless (token-will-be($tokenListCloser))
      add!(expression-set, build-simple-expression());
      while (token-is($tokenComma))
        add!(expression-set, build-simple-expression());
      end while;
    end unless;
    accept($tokenListCloser);
    ex := make(<downloaded-list-expression>, elements: expression-set);
  elseif (token-will-be($tokenDylanSymbol))
    let (name, context) = 
      generate-name-and-context(current-token(), current-name-context());
    ex := make(<dylan-symbolic-name-expression>,
               symbol: name, dll-context: current-token().token-dll-context,
               context: context, lookup-in-stack?: #t);
    accept($tokenDylanSymbol);
  elseif (token-will-be($tokenLiteralAddress))
    ex := make(<address-literal-expression>, token: current-token());
    accept($tokenLiteralAddress);
  elseif (token-will-be($tokenRegisterName))
    ex := make(<register-literal-expression>, token: current-token());
    accept($tokenRegisterName);
  elseif (token-will-be($tokenLiteralInteger))
    ex := make(<integer-literal-expression>, token: current-token());
    accept($tokenLiteralInteger);
  elseif (token-will-be($tokenLiteralCharacter))
    ex := make(<character-literal-expression>, token: current-token());
    accept($tokenLiteralCharacter);
  elseif (token-will-be($tokenLiteralTrue))
    ex := make(<boolean-true-expression>, token: current-token());
    accept($tokenLiteralTrue);
  elseif (token-will-be($tokenLiteralFalse))
    ex := make(<boolean-false-expression>, token: current-token());
    accept($tokenLiteralFalse);
  elseif (token-will-be($tokenLiteralEmptyList))
    ex := make(<empty-list-literal-expression>, token: current-token());
    accept($tokenLiteralEmptyList);
  elseif (token-will-be($tokenHistoryVariable))
    ex := make(<history-variable-expression>, token: current-token());
    accept($tokenHistoryVariable);
  elseif (token-will-be($tokenCSymbol))
    ex := make(<symbolic-name-expression>, symbol: current-lexeme(),
               dll-context: current-token().token-dll-context,
               lookup-in-stack?: #t);
    accept($tokenCSymbol);
  elseif (token-will-be($tokenString))
    ex := make(<downloaded-string-expression>,
               string: translate-escapes-in-string
                         (generate-actual-string(current-token())));
    accept($tokenString);
  elseif (token-will-be($tokenRawString))
    ex := make(<downloaded-raw-string-expression>,
               string: translate-escapes-in-string
                         (generate-actual-string(current-token())));
    accept($tokenRawString);
  elseif (token-will-be($tokenDylanKeyword))
    ex := make(<dylan-keyword-literal-expression>, token: current-token());
    accept($tokenDylanKeyword);
  elseif (token-will-be($tokenModuleQualifiedSymbol))
    let (name, context) = 
      generate-name-and-context(current-token(), current-name-context());
    ex := make(<dylan-symbolic-name-expression>,
               symbol: name, dll-context: current-token().token-dll-context,
               context: context);
    accept($tokenModuleQualifiedSymbol);
  elseif (token-will-be($tokenLibraryQualifiedSymbol))
    let (name, context) = 
      generate-name-and-context(current-token(), current-name-context());
    ex := make(<dylan-symbolic-name-expression>,
               symbol: name, dll-context: current-token().token-dll-context,
               context: context);
    accept($tokenLibraryQualifiedSymbol);
  else
    unless(token-will-be($tokenTerminator))
      let name = current-lexeme();
      ex := make(<dylan-symbolic-name-expression>,
                 symbol: name, dll-context: current-token().token-dll-context,
                 context: current-name-context(), lookup-in-stack?: #t);
      accept-anything();
    end unless;
  end if;
  ex;
end method;


///// BUILD-ARGUMENT
//    An argument can be an expression or a keyword followed by an expression.

define method build-argument ()
    => (keyword-part :: false-or(<dylan-keyword-literal-expression>),
        argument :: <simple-expression>)
  let keyword-part = #f;
  let argument = #f;
  if (token-will-be($tokenDylanKeyword))
    keyword-part := make(<dylan-keyword-literal-expression>,
                         token: current-token());
    accept($tokenDylanKeyword);
    if ((token-will-be($tokenComma)) | (token-will-be($tokenCloseBracket)))
       argument := keyword-part;
       keyword-part := #f;
    else
       argument := build-simple-expression();
    end if;
  else
    keyword-part := #f;
    argument := build-simple-expression();
  end if;
  values(keyword-part, argument);
end method;
