[bpt/guile.git] / module / ice-9 / debugger / command-loop.scm

;;;; Guile Debugger command loop

;;; Copyright (C) 1999, 2001, 2002, 2003, 2006, 2010 Free Software Foundation, Inc.
;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;; 
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;;; Lesser General Public License for more details.
;;;; 
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA

(define-module (ice-9 debugger command-loop)
  #:use-module ((ice-9 debugger commands) :prefix debugger:)
  #:use-module (ice-9 debugger)
  #:use-module (ice-9 debugger state)
  #:use-module (ice-9 debugging traps)
  #:use-module (ice-9 save-stack)
  #:export (debugger-command-loop
	    debugger-command-loop-error
	    debugger-command-loop-quit)
  #:no-backtrace)

;;; {Interface used by (ice-9 debugger).}

(define (debugger-command-loop state)
  (read-and-dispatch-commands state (current-input-port)))

(define (debugger-command-loop-error message)
  (user-error message))

(define (debugger-command-loop-quit)
  (throw 'exit-debugger))

;;; {Implementation.}
  
(define debugger-prompt "debug> ")

(define (debugger-handler key . args)
  (case key
    ((exit-debugger) #f)
    ((signal)
     (apply display-error #f (current-error-port) args))
    (else
     (display "Internal debugger error:\n")
     (save-stack debugger-handler)
     (apply throw key args)))
  (throw 'exit-debugger))		;Pop the stack

(define (read-and-dispatch-commands state port)
  (catch 'exit-debugger
    (lambda ()
      (lazy-catch #t
        (lambda ()
	  (with-fluids ((last-command #f))
	    (let loop ()
	      (read-and-dispatch-command state port)
	      (loop))))
	debugger-handler))
    (lambda args
      *unspecified*)))

(define set-readline-prompt! #f)

(define (read-and-dispatch-command state port)
  (if (using-readline?)
      (begin
	;; Import set-readline-prompt! if we haven't already.
	(or set-readline-prompt!
	    (set! set-readline-prompt!
		  (module-ref (resolve-module '(ice-9 readline))
			      'set-readline-prompt!)))
	(set-readline-prompt! debugger-prompt debugger-prompt))
      (display debugger-prompt))
  (force-output)			;This should not be necessary...
  (let ((token (read-token port)))
    (cond ((eof-object? token)
	   (throw 'exit-debugger))
	  ((not token)
	   (discard-rest-of-line port)
	   (catch-user-errors port (lambda () (run-last-command state))))
	  (else
	   (catch-user-errors port
	     (lambda ()
	       (dispatch-command token command-table state port)))))))

(define (run-last-command state)
  (let ((procedure (fluid-ref last-command)))
    (if procedure
	(procedure state))))

(define (catch-user-errors port thunk)
  (catch 'debugger-user-error
	 thunk
	 (lambda (key . objects)
	   (apply user-warning objects)
	   (discard-rest-of-line port))))

(define last-command (make-fluid))

(define (user-warning . objects)
  (for-each (lambda (object)
	      (display object))
	    objects)
  (newline))

(define (user-error . objects)
  (apply throw 'debugger-user-error objects))
\f
;;;; Command dispatch

(define (dispatch-command string table state port)
  (let ((value (command-table-value table string)))
    (if value
	(dispatch-command/value value state port)
	(user-error "Unknown command: " string))))

(define (dispatch-command/value value state port)
  (cond ((command? value)
	 (dispatch-command/command value state port))
	((command-table? value)
	 (dispatch-command/table value state port))
	((list? value)
	 (dispatch-command/name value state port))
	(else
	 (error "Unrecognized command-table value: " value))))

(define (dispatch-command/command command state port)
  (let ((procedure (command-procedure command))
	(arguments ((command-parser command) port)))
    (let ((procedure (lambda (state) (apply procedure state arguments))))
      (warn-about-extra-args port)
      (fluid-set! last-command procedure)
      (procedure state))))

(define (warn-about-extra-args port)
  ;; **** modify this to show the arguments.
  (let ((char (skip-whitespace port)))
    (cond ((eof-object? char) #f)
	  ((char=? #\newline char) (read-char port))
	  (else
	   (user-warning "Extra arguments at end of line: "
			 (read-rest-of-line port))))))

(define (dispatch-command/table table state port)
  (let ((token (read-token port)))
    (if (or (eof-object? token)
	    (not token))
	(user-error "Command name too short.")
	(dispatch-command token table state port))))

(define (dispatch-command/name name state port)
  (let ((value (lookup-command name)))
    (cond ((not value)
	   (apply user-error "Unknown command name: " name))
	  ((command-table? value)
	   (apply user-error "Partial command name: " name))
	  (else
	   (dispatch-command/value value state port)))))
\f
;;;; Command definition

(define (define-command name argument-template procedure)
  (let ((name (canonicalize-command-name name)))
    (add-command name
		 (make-command name
			       (argument-template->parser argument-template)
			       (procedure-documentation procedure)
			       procedure)
		 command-table)
    name))

(define (define-command-alias name1 name2)
  (let ((name1 (canonicalize-command-name name1)))
    (add-command name1 (canonicalize-command-name name2) command-table)
    name1))
\f
(define (argument-template->parser template)
  ;; Deliberately handles only cases that occur in "commands.scm".
  (cond ((eq? 'tokens template)
	 (lambda (port)
	   (let loop ((tokens '()))
	     (let ((token (read-token port)))
	       (if (or (eof-object? token)
		       (not token))
		   (list (reverse! tokens))
		   (loop (cons token tokens)))))))
	((null? template)
	 (lambda (port)
	   '()))
	((and (pair? template)
	      (null? (cdr template))
	      (eq? 'object (car template)))
	 (lambda (port)
	   (list (read port))))
	((and (pair? template)
	      (equal? ''optional (car template))
	      (pair? (cdr template))
	      (null? (cddr template)))
	 (case (cadr template)
	   ((token)
	    (lambda (port)
	      (let ((token (read-token port)))
		(if (or (eof-object? token)
			(not token))
		    (list #f)
		    (list token)))))
	   ((exact-integer)
	    (lambda (port)
	      (list (parse-optional-exact-integer port))))
	   ((exact-nonnegative-integer)
	    (lambda (port)
	      (list (parse-optional-exact-nonnegative-integer port))))
	   ((object)
	    (lambda (port)
	      (list (parse-optional-object port))))
	   (else
	    (error "Malformed argument template: " template))))
	(else
	 (error "Malformed argument template: " template))))

(define (parse-optional-exact-integer port)
  (let ((object (parse-optional-object port)))
    (if (or (not object)
	    (and (integer? object)
		 (exact? object)))
	object
	(user-error "Argument not an exact integer: " object))))

(define (parse-optional-exact-nonnegative-integer port)
  (let ((object (parse-optional-object port)))
    (if (or (not object)
	    (and (integer? object)
		 (exact? object)
		 (not (negative? object))))
	object
	(user-error "Argument not an exact non-negative integer: " object))))

(define (parse-optional-object port)
  (let ((terminator (skip-whitespace port)))
    (if (or (eof-object? terminator)
	    (eq? #\newline terminator))
	#f
	(let ((object (read port)))
	  (if (eof-object? object)
	      #f
	      object)))))
\f
;;;; Command tables

(define (lookup-command name)
  (let loop ((table command-table) (strings name))
    (let ((value (command-table-value table (car strings))))
      (cond ((or (not value) (null? (cdr strings))) value)
	    ((command-table? value) (loop value (cdr strings)))
	    (else #f)))))

(define (command-table-value table string)
  (let ((entry (command-table-entry table string)))
    (and entry
	 (caddr entry))))

(define (command-table-entry table string)
  (let loop ((entries (command-table-entries table)))
    (and (not (null? entries))
	 (let ((entry (car entries)))
	   (if (and (<= (cadr entry)
			(string-length string)
			(string-length (car entry)))
		    (= (string-length string)
		       (match-strings (car entry) string)))
	       entry
	       (loop (cdr entries)))))))

(define (match-strings s1 s2)
  (let ((n (min (string-length s1) (string-length s2))))
    (let loop ((i 0))
      (cond ((= i n) i)
	    ((char=? (string-ref s1 i) (string-ref s2 i)) (loop (+ i 1)))
	    (else i)))))

(define (write-command-name name)
  (display (car name))
  (for-each (lambda (string)
	      (write-char #\space)
	      (display string))
	    (cdr name)))
\f
(define (add-command name value table)
  (let loop ((strings name) (table table))
    (let ((entry
	   (or (let loop ((entries (command-table-entries table)))
		 (and (not (null? entries))
		      (if (string=? (car strings) (caar entries))
			  (car entries)
			  (loop (cdr entries)))))
	       (let ((entry (list (car strings) #f #f)))
		 (let ((entries
			(let ((entries (command-table-entries table)))
			  (if (or (null? entries)
				  (string<? (car strings) (caar entries)))
			      (cons entry entries)
			      (begin
				(let loop ((prev entries) (this (cdr entries)))
				  (if (or (null? this)
					  (string<? (car strings) (caar this)))
				      (set-cdr! prev (cons entry this))
				      (loop this (cdr this))))
				entries)))))
		   (compute-string-abbreviations! entries)
		   (set-command-table-entries! table entries))
		 entry))))
      (if (null? (cdr strings))
	  (set-car! (cddr entry) value)
	  (loop (cdr strings)
		(if (command-table? (caddr entry))
		    (caddr entry)
		    (let ((table (make-command-table '())))
		      (set-car! (cddr entry) table)
		      table)))))))

(define (canonicalize-command-name name)
  (cond ((and (string? name)
	      (not (string-null? name)))
	 (list name))
	((let loop ((name name))
	   (and (pair? name)
		(string? (car name))
		(not (string-null? (car name)))
		(or (null? (cdr name))
		    (loop (cdr name)))))
	 name)
	(else
	 (error "Illegal command name: " name))))

(define (compute-string-abbreviations! entries)
  (let loop ((entries entries) (index 0))
    (let ((groups '()))
      (for-each
       (lambda (entry)
	 (let* ((char (string-ref (car entry) index))
		(group (assv char groups)))
	   (if group
	       (set-cdr! group (cons entry (cdr group)))
	       (set! groups
		     (cons (list char entry)
			   groups)))))
       entries)
      (for-each
       (lambda (group)
	 (let ((index (+ index 1)))
	   (if (null? (cddr group))
	       (set-car! (cdadr group) index)
	       (loop (let ((entry
			    (let loop ((entries (cdr group)))
			      (and (not (null? entries))
				   (if (= index (string-length (caar entries)))
				       (car entries)
				       (loop (cdr entries)))))))
		       (if entry
			   (begin
			     (set-car! (cdr entry) index)
			     (delq entry (cdr group)))
			   (cdr group)))
		     index))))
       groups))))
\f
;;;; Data structures

(define command-table-rtd (make-record-type "command-table" '(entries)))
(define make-command-table (record-constructor command-table-rtd '(entries)))
(define command-table? (record-predicate command-table-rtd))
(define command-table-entries (record-accessor command-table-rtd 'entries))
(define set-command-table-entries!
  (record-modifier command-table-rtd 'entries))

(define command-rtd
  (make-record-type "command"
		    '(name parser documentation procedure)))

(define make-command
  (record-constructor command-rtd
		      '(name parser documentation procedure)))

(define command? (record-predicate command-rtd))
(define command-name (record-accessor command-rtd 'name))
(define command-parser (record-accessor command-rtd 'parser))
(define command-documentation (record-accessor command-rtd 'documentation))
(define command-procedure (record-accessor command-rtd 'procedure))
\f
;;;; Character parsing

(define (read-token port)
  (letrec
      ((loop
	(lambda (chars)
	  (let ((char (peek-char port)))
	    (cond ((eof-object? char)
		   (do-eof char chars))
		  ((char=? #\newline char)
		   (do-eot chars))
		  ((char-whitespace? char)
		   (do-eot chars))
		  ((char=? #\# char)
		   (read-char port)
		   (let ((terminator (skip-comment port)))
		     (if (eof-object? char)
			 (do-eof char chars)
			 (do-eot chars))))
		  (else
		   (read-char port)
		   (loop (cons char chars)))))))
       (do-eof
	(lambda (eof chars)
	  (if (null? chars)
	      eof
	      (do-eot chars))))
       (do-eot
	(lambda (chars)
	  (if (null? chars)
	      #f
	      (list->string (reverse! chars))))))
    (skip-whitespace port)
    (loop '())))

(define (skip-whitespace port)
  (let ((char (peek-char port)))
    (cond ((or (eof-object? char)
	       (char=? #\newline char))
	   char)
	  ((char-whitespace? char)
	   (read-char port)
	   (skip-whitespace port))
	  ((char=? #\# char)
	   (read-char port)
	   (skip-comment port))
	  (else char))))

(define (skip-comment port)
  (let ((char (peek-char port)))
    (if (or (eof-object? char)
	    (char=? #\newline char))
	char
	(begin
	  (read-char port)
	  (skip-comment port)))))

(define (read-rest-of-line port)
  (let loop ((chars '()))
    (let ((char (read-char port)))
      (if (or (eof-object? char)
	      (char=? #\newline char))
	  (list->string (reverse! chars))
	  (loop (cons char chars))))))

(define (discard-rest-of-line port)
  (let loop ()
    (if (not (let ((char (read-char port)))
	       (or (eof-object? char)
		   (char=? #\newline char))))
	(loop))))
\f
;;;; Commands

(define command-table (make-command-table '()))

(define-command "help" 'tokens
  (lambda (state tokens)
    "Type \"help\" followed by a command name for full documentation."
    (let loop ((name (if (null? tokens) '("help") tokens)))
      (let ((value (lookup-command name)))
	(cond ((not value)
	       (write-command-name name)
	       (display " is not a known command name.")
	       (newline))
	      ((command? value)
	       (display (command-documentation value))
	       (newline)
	       (if (equal? '("help") (command-name value))
		   (begin
		     (display "Available commands are:")
		     (newline)
		     (for-each (lambda (entry)
				 (if (not (list? (caddr entry)))
				     (begin
				       (display "  ")
				       (display (car entry))
				       (newline))))
			       (command-table-entries command-table)))))
	      ((command-table? value)
	       (display "The \"")
	       (write-command-name name)
	       (display "\" command requires a subcommand.")
	       (newline)
	       (display "Available subcommands are:")
	       (newline)
	       (for-each (lambda (entry)
			   (if (not (list? (caddr entry)))
			       (begin
				 (display "  ")
				 (write-command-name name)
				 (write-char #\space)
				 (display (car entry))
				 (newline))))
			 (command-table-entries value)))
	      ((list? value)
	       (loop value))
	      (else
	       (error "Unknown value from lookup-command:" value)))))
    state))

(define-command "frame" '('optional exact-nonnegative-integer) debugger:frame)

(define-command "position" '() debugger:position)

(define-command "up" '('optional exact-integer) debugger:up)

(define-command "down" '('optional exact-integer) debugger:down)
\f
(define-command "backtrace" '('optional exact-integer) debugger:backtrace)

(define-command "evaluate" '(object) debugger:evaluate)

(define-command '("info" "args") '() debugger:info-args)

(define-command '("info" "frame") '() debugger:info-frame)

(define-command "quit" '()
  (lambda (state)
    "Exit the debugger."
    (debugger-command-loop-quit)))

(define-command-alias "f" "frame")
(define-command-alias '("info" "f") '("info" "frame"))
(define-command-alias "bt" "backtrace")
(define-command-alias "where" "backtrace")
(define-command-alias "p" "evaluate")
(define-command-alias '("info" "stack") "backtrace")

(define-command "continue" '() debugger:continue)

(define-command "finish" '() debugger:finish)

(define-command "step" '('optional exact-integer) debugger:step)

(define-command "next" '('optional exact-integer) debugger:next)
Commit	Line	Data
8ee7506b NJ	1	;;;; Guile Debugger command loop
8ee7506b NJ	2
48201a94	3	;;; Copyright (C) 1999, 2001, 2002, 2003, 2006, 2010 Free Software Foundation, Inc.
8ee7506b	4	;;;
53befeb7 NJ	5	;;;; This library is free software; you can redistribute it and/or
	6	;;;; modify it under the terms of the GNU Lesser General Public
	7	;;;; License as published by the Free Software Foundation; either
	8	;;;; version 3 of the License, or (at your option) any later version.
	9	;;;;
	10	;;;; This library is distributed in the hope that it will be useful,
	11	;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
	12	;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
	13	;;;; Lesser General Public License for more details.
	14	;;;;
	15	;;;; You should have received a copy of the GNU Lesser General Public
	16	;;;; License along with this library; if not, write to the Free Software
	17	;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
8ee7506b NJ	18
8ee7506b NJ	19	(define-module (ice-9 debugger command-loop)
c614a00b	20	#:use-module ((ice-9 debugger commands) :prefix debugger:)
ba5f8bf4 NJ	21	#:use-module (ice-9 debugger)
	22	#:use-module (ice-9 debugger state)
	23	#:use-module (ice-9 debugging traps)
d8158b83	24	#:use-module (ice-9 save-stack)
8ee7506b NJ	25	#:export (debugger-command-loop
	26	debugger-command-loop-error
	27	debugger-command-loop-quit)
	28	#:no-backtrace)
	29
8ee7506b NJ	30	;;; {Interface used by (ice-9 debugger).}
	31
	32	(define (debugger-command-loop state)
	33	(read-and-dispatch-commands state (current-input-port)))
	34
	35	(define (debugger-command-loop-error message)
	36	(user-error message))
	37
	38	(define (debugger-command-loop-quit)
	39	(throw 'exit-debugger))
	40
	41	;;; {Implementation.}
	42
	43	(define debugger-prompt "debug> ")
	44
	45	(define (debugger-handler key . args)
	46	(case key
	47	((exit-debugger) #f)
	48	((signal)
8ee7506b NJ	49	(apply display-error #f (current-error-port) args))
	50	(else
	51	(display "Internal debugger error:\n")
	52	(save-stack debugger-handler)
	53	(apply throw key args)))
	54	(throw 'exit-debugger)) ;Pop the stack
	55
	56	(define (read-and-dispatch-commands state port)
	57	(catch 'exit-debugger
	58	(lambda ()
	59	(lazy-catch #t
	60	(lambda ()
	61	(with-fluids ((last-command #f))
	62	(let loop ()
	63	(read-and-dispatch-command state port)
	64	(loop))))
	65	debugger-handler))
	66	(lambda args
	67	unspecified)))
	68
9124ba8d NJ	69	(define set-readline-prompt! #f)
9124ba8d NJ	70
8ee7506b NJ	71	(define (read-and-dispatch-command state port)
8ee7506b NJ	72	(if (using-readline?)
9124ba8d NJ	73	(begin
	74	;; Import set-readline-prompt! if we haven't already.
	75	(or set-readline-prompt!
	76	(set! set-readline-prompt!
	77	(module-ref (resolve-module '(ice-9 readline))
	78	'set-readline-prompt!)))
	79	(set-readline-prompt! debugger-prompt debugger-prompt))
8ee7506b NJ	80	(display debugger-prompt))
	81	(force-output) ;This should not be necessary...
	82	(let ((token (read-token port)))
	83	(cond ((eof-object? token)
	84	(throw 'exit-debugger))
	85	((not token)
	86	(discard-rest-of-line port)
	87	(catch-user-errors port (lambda () (run-last-command state))))
	88	(else
	89	(catch-user-errors port
	90	(lambda ()
	91	(dispatch-command token command-table state port)))))))
	92
	93	(define (run-last-command state)
	94	(let ((procedure (fluid-ref last-command)))
	95	(if procedure
	96	(procedure state))))
	97
	98	(define (catch-user-errors port thunk)
	99	(catch 'debugger-user-error
	100	thunk
	101	(lambda (key . objects)
	102	(apply user-warning objects)
	103	(discard-rest-of-line port))))
	104
	105	(define last-command (make-fluid))
	106
	107	(define (user-warning . objects)
	108	(for-each (lambda (object)
	109	(display object))
	110	objects)
	111	(newline))
	112
	113	(define (user-error . objects)
	114	(apply throw 'debugger-user-error objects))
	115	\f
	116	;;;; Command dispatch
	117
	118	(define (dispatch-command string table state port)
	119	(let ((value (command-table-value table string)))
	120	(if value
	121	(dispatch-command/value value state port)
	122	(user-error "Unknown command: " string))))
	123
	124	(define (dispatch-command/value value state port)
	125	(cond ((command? value)
	126	(dispatch-command/command value state port))
	127	((command-table? value)
	128	(dispatch-command/table value state port))
	129	((list? value)
	130	(dispatch-command/name value state port))
	131	(else
	132	(error "Unrecognized command-table value: " value))))
	133
	134	(define (dispatch-command/command command state port)
	135	(let ((procedure (command-procedure command))
	136	(arguments ((command-parser command) port)))
	137	(let ((procedure (lambda (state) (apply procedure state arguments))))
	138	(warn-about-extra-args port)
	139	(fluid-set! last-command procedure)
	140	(procedure state))))
	141
	142	(define (warn-about-extra-args port)
	143	;; **** modify this to show the arguments.
144	(let ((char (skip-whitespace port)))
145	(cond ((eof-object? char) #f)
146	((char=? #\newline char) (read-char port))
147	(else
148	(user-warning "Extra arguments at end of line: "
149	(read-rest-of-line port))))))
150
151	(define (dispatch-command/table table state port)
152	(let ((token (read-token port)))
153	(if (or (eof-object? token)
154	(not token))
155	(user-error "Command name too short.")
156	(dispatch-command token table state port))))
157
158	(define (dispatch-command/name name state port)
159	(let ((value (lookup-command name)))
160	(cond ((not value)
161	(apply user-error "Unknown command name: " name))
162	((command-table? value)
163	(apply user-error "Partial command name: " name))
164	(else
165	(dispatch-command/value value state port)))))
166	\f
167	;;;; Command definition
168
169	(define (define-command name argument-template procedure)
170	(let ((name (canonicalize-command-name name)))
171	(add-command name
172	(make-command name
173	(argument-template->parser argument-template)
174	(procedure-documentation procedure)
175	procedure)
176	command-table)
177	name))
178
179	(define (define-command-alias name1 name2)
180	(let ((name1 (canonicalize-command-name name1)))
181	(add-command name1 (canonicalize-command-name name2) command-table)
182	name1))
183	\f
184	(define (argument-template->parser template)
185	;; Deliberately handles only cases that occur in "commands.scm".
186	(cond ((eq? 'tokens template)
187	(lambda (port)
188	(let loop ((tokens '()))
189	(let ((token (read-token port)))
190	(if (or (eof-object? token)
191	(not token))
192	(list (reverse! tokens))
193	(loop (cons token tokens)))))))
194	((null? template)
195	(lambda (port)
196	'()))
197	((and (pair? template)
198	(null? (cdr template))
199	(eq? 'object (car template)))
200	(lambda (port)
201	(list (read port))))
202	((and (pair? template)
203	(equal? ''optional (car template))
204	(pair? (cdr template))
205	(null? (cddr template)))
206	(case (cadr template)
207	((token)
208	(lambda (port)
209	(let ((token (read-token port)))
210	(if (or (eof-object? token)
211	(not token))
212	(list #f)
213	(list token)))))
214	((exact-integer)
215	(lambda (port)
216	(list (parse-optional-exact-integer port))))
217	((exact-nonnegative-integer)
218	(lambda (port)
219	(list (parse-optional-exact-nonnegative-integer port))))
220	((object)
221	(lambda (port)
222	(list (parse-optional-object port))))
223	(else
224	(error "Malformed argument template: " template))))
225	(else
226	(error "Malformed argument template: " template))))
227
228	(define (parse-optional-exact-integer port)
229	(let ((object (parse-optional-object port)))
230	(if (or (not object)
231	(and (integer? object)
232	(exact? object)))
233	object
234	(user-error "Argument not an exact integer: " object))))
235
236	(define (parse-optional-exact-nonnegative-integer port)
237	(let ((object (parse-optional-object port)))
238	(if (or (not object)
239	(and (integer? object)
240	(exact? object)
241	(not (negative? object))))
242	object
243	(user-error "Argument not an exact non-negative integer: " object))))
244
245	(define (parse-optional-object port)
246	(let ((terminator (skip-whitespace port)))
247	(if (or (eof-object? terminator)
248	(eq? #\newline terminator))
249	#f
250	(let ((object (read port)))
251	(if (eof-object? object)
252	#f
253	object)))))
254	\f
255	;;;; Command tables
256
257	(define (lookup-command name)
258	(let loop ((table command-table) (strings name))
259	(let ((value (command-table-value table (car strings))))
260	(cond ((or (not value) (null? (cdr strings))) value)
261	((command-table? value) (loop value (cdr strings)))
262	(else #f)))))
263
264	(define (command-table-value table string)
265	(let ((entry (command-table-entry table string)))
266	(and entry
267	(caddr entry))))
268
269	(define (command-table-entry table string)
270	(let loop ((entries (command-table-entries table)))
271	(and (not (null? entries))
272	(let ((entry (car entries)))
273	(if (and (<= (cadr entry)
274	(string-length string)
275	(string-length (car entry)))
276	(= (string-length string)
277	(match-strings (car entry) string)))
278	entry
279	(loop (cdr entries)))))))
280
281	(define (match-strings s1 s2)
282	(let ((n (min (string-length s1) (string-length s2))))
283	(let loop ((i 0))
284	(cond ((= i n) i)
285	((char=? (string-ref s1 i) (string-ref s2 i)) (loop (+ i 1)))
286	(else i)))))
287
288	(define (write-command-name name)
289	(display (car name))
290	(for-each (lambda (string)
291	(write-char #\space)
292	(display string))
293	(cdr name)))
294	\f
295	(define (add-command name value table)
296	(let loop ((strings name) (table table))
297	(let ((entry
298	(or (let loop ((entries (command-table-entries table)))
299	(and (not (null? entries))
300	(if (string=? (car strings) (caar entries))
301	(car entries)
302	(loop (cdr entries)))))
303	(let ((entry (list (car strings) #f #f)))
304	(let ((entries
305	(let ((entries (command-table-entries table)))
306	(if (or (null? entries)
307	(string<? (car strings) (caar entries)))
308	(cons entry entries)
309	(begin
310	(let loop ((prev entries) (this (cdr entries)))
311	(if (or (null? this)
312	(string<? (car strings) (caar this)))
313	(set-cdr! prev (cons entry this))
314	(loop this (cdr this))))
315	entries)))))
316	(compute-string-abbreviations! entries)
317	(set-command-table-entries! table entries))
318	entry))))
319	(if (null? (cdr strings))
320	(set-car! (cddr entry) value)
321	(loop (cdr strings)
322	(if (command-table? (caddr entry))
323	(caddr entry)
324	(let ((table (make-command-table '())))
325	(set-car! (cddr entry) table)
326	table)))))))
327
328	(define (canonicalize-command-name name)
329	(cond ((and (string? name)
330	(not (string-null? name)))
331	(list name))
332	((let loop ((name name))
333	(and (pair? name)
334	(string? (car name))
335	(not (string-null? (car name)))
336	(or (null? (cdr name))
337	(loop (cdr name)))))
338	name)
339	(else
340	(error "Illegal command name: " name))))
341
342	(define (compute-string-abbreviations! entries)
343	(let loop ((entries entries) (index 0))
344	(let ((groups '()))
345	(for-each
346	(lambda (entry)
347	(let* ((char (string-ref (car entry) index))
348	(group (assv char groups)))
349	(if group
350	(set-cdr! group (cons entry (cdr group)))
351	(set! groups
352	(cons (list char entry)
353	groups)))))
354	entries)
355	(for-each
356	(lambda (group)
357	(let ((index (+ index 1)))
358	(if (null? (cddr group))
359	(set-car! (cdadr group) index)
360	(loop (let ((entry
361	(let loop ((entries (cdr group)))
362	(and (not (null? entries))
363	(if (= index (string-length (caar entries)))
364	(car entries)
365	(loop (cdr entries)))))))
366	(if entry
367	(begin
368	(set-car! (cdr entry) index)
369	(delq entry (cdr group)))
370	(cdr group)))
371	index))))
372	groups))))
373	\f
374	;;;; Data structures
375
376	(define command-table-rtd (make-record-type "command-table" '(entries)))
377	(define make-command-table (record-constructor command-table-rtd '(entries)))
378	(define command-table? (record-predicate command-table-rtd))
379	(define command-table-entries (record-accessor command-table-rtd 'entries))
380	(define set-command-table-entries!
381	(record-modifier command-table-rtd 'entries))
382
383	(define command-rtd
384	(make-record-type "command"
385	'(name parser documentation procedure)))
386
387	(define make-command
388	(record-constructor command-rtd
389	'(name parser documentation procedure)))
390
391	(define command? (record-predicate command-rtd))
392	(define command-name (record-accessor command-rtd 'name))
393	(define command-parser (record-accessor command-rtd 'parser))
394	(define command-documentation (record-accessor command-rtd 'documentation))
395	(define command-procedure (record-accessor command-rtd 'procedure))
396	\f
397	;;;; Character parsing
398
399	(define (read-token port)
400	(letrec
401	((loop
402	(lambda (chars)
403	(let ((char (peek-char port)))
404	(cond ((eof-object? char)
405	(do-eof char chars))
406	((char=? #\newline char)
407	(do-eot chars))
408	((char-whitespace? char)
409	(do-eot chars))
410	((char=? #\# char)
411	(read-char port)
412	(let ((terminator (skip-comment port)))
413	(if (eof-object? char)
414	(do-eof char chars)
415	(do-eot chars))))
416	(else
417	(read-char port)
418	(loop (cons char chars)))))))
419	(do-eof
420	(lambda (eof chars)
421	(if (null? chars)
422	eof
423	(do-eot chars))))
424	(do-eot
425	(lambda (chars)
426	(if (null? chars)
427	#f
428	(list->string (reverse! chars))))))
429	(skip-whitespace port)
430	(loop '())))
431
432	(define (skip-whitespace port)
433	(let ((char (peek-char port)))
434	(cond ((or (eof-object? char)
435	(char=? #\newline char))
436	char)
437	((char-whitespace? char)
438	(read-char port)
439	(skip-whitespace port))
440	((char=? #\# char)
441	(read-char port)
442	(skip-comment port))
443	(else char))))
444
445	(define (skip-comment port)
446	(let ((char (peek-char port)))
447	(if (or (eof-object? char)
448	(char=? #\newline char))
449	char
450	(begin
451	(read-char port)
452	(skip-comment port)))))
453
454	(define (read-rest-of-line port)
455	(let loop ((chars '()))
456	(let ((char (read-char port)))
457	(if (or (eof-object? char)
458	(char=? #\newline char))
459	(list->string (reverse! chars))
460	(loop (cons char chars))))))
461
462	(define (discard-rest-of-line port)
463	(let loop ()
464	(if (not (let ((char (read-char port)))
465	(or (eof-object? char)
466	(char=? #\newline char))))
467	(loop))))
468	\f
469	;;;; Commands
470
471	(define command-table (make-command-table '()))
472
473	(define-command "help" 'tokens
474	(lambda (state tokens)
475	"Type \"help\" followed by a command name for full documentation."
476	(let loop ((name (if (null? tokens) '("help") tokens)))
477	(let ((value (lookup-command name)))
478	(cond ((not value)
479	(write-command-name name)
480	(display " is not a known command name.")
481	(newline))
482	((command? value)
483	(display (command-documentation value))
484	(newline)
485	(if (equal? '("help") (command-name value))
486	(begin
487	(display "Available commands are:")
488	(newline)
489	(for-each (lambda (entry)
490	(if (not (list? (caddr entry)))
491	(begin
492	(display " ")
493	(display (car entry))
494	(newline))))
495	(command-table-entries command-table)))))
496	((command-table? value)
497	(display "The \"")
498	(write-command-name name)
499	(display "\" command requires a subcommand.")
500	(newline)
501	(display "Available subcommands are:")
502	(newline)
503	(for-each (lambda (entry)
504	(if (not (list? (caddr entry)))
505	(begin
506	(display " ")
507	(write-command-name name)
508	(write-char #\space)
509	(display (car entry))
510	(newline))))
511	(command-table-entries value)))
512	((list? value)
513	(loop value))
514	(else
515	(error "Unknown value from lookup-command:" value)))))
516	state))
517
c614a00b	518	(define-command "frame" '('optional exact-nonnegative-integer) debugger:frame)
8ee7506b	519
c614a00b	520	(define-command "position" '() debugger:position)
8ee7506b	521
c614a00b	522	(define-command "up" '('optional exact-integer) debugger:up)
8ee7506b	523
c614a00b	524	(define-command "down" '('optional exact-integer) debugger:down)
8ee7506b	525	\f
c614a00b	526	(define-command "backtrace" '('optional exact-integer) debugger:backtrace)
8ee7506b	527
c614a00b	528	(define-command "evaluate" '(object) debugger:evaluate)
8ee7506b	529
c614a00b	530	(define-command '("info" "args") '() debugger:info-args)
8ee7506b	531
c614a00b	532	(define-command '("info" "frame") '() debugger:info-frame)
8ee7506b NJ	533
	534	(define-command "quit" '()
	535	(lambda (state)
	536	"Exit the debugger."
	537	(debugger-command-loop-quit)))
	538
	539	(define-command-alias "f" "frame")
	540	(define-command-alias '("info" "f") '("info" "frame"))
	541	(define-command-alias "bt" "backtrace")
	542	(define-command-alias "where" "backtrace")
	543	(define-command-alias "p" "evaluate")
	544	(define-command-alias '("info" "stack") "backtrace")
ba5f8bf4 NJ	545
	546	(define-command "continue" '() debugger:continue)
	547
	548	(define-command "finish" '() debugger:finish)
	549
	550	(define-command "step" '('optional exact-integer) debugger:step)
	551
	552	(define-command "next" '('optional exact-integer) debugger:next)