summaryrefslogtreecommitdiff
path: root/module/ice-9/debugger/command-loop.scm
diff options
context:
space:
mode:
Diffstat (limited to 'module/ice-9/debugger/command-loop.scm')
-rw-r--r--module/ice-9/debugger/command-loop.scm552
1 files changed, 0 insertions, 552 deletions
diff --git a/module/ice-9/debugger/command-loop.scm b/module/ice-9/debugger/command-loop.scm
deleted file mode 100644
index b58952dcd..000000000
--- a/module/ice-9/debugger/command-loop.scm
+++ /dev/null
@@ -1,552 +0,0 @@
-;;;; 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))
-
-;;;; 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)))))
-
-;;;; 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))
-
-(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)))))
-
-;;;; 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)))
-
-(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))))
-
-;;;; 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))
-
-;;;; 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))))
-
-;;;; 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)
-
-(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)