diff options
author | Andy Wingo <wingo@pobox.com> | 2010-07-09 17:04:34 +0200 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2010-07-09 17:05:25 +0200 |
commit | 33df2ec719d281c70a5c7595dceee9f47770e910 (patch) | |
tree | 6d0fc69ef15d3243f13985eb85c1f01628f1f1df /module/system/repl/repl.scm | |
parent | ddfb5e2bb02e167c734af5091d40d7db4ffeffa1 (diff) | |
download | guile-33df2ec719d281c70a5c7595dceee9f47770e910.tar.gz |
integrate the debugger into the repl
* module/system/repl/debug.scm: New file, defines a data type to hold
state for a debugger stack, and some helper procedures to print the
stack or print a frame. Most pieces are from (system vm debug).
* module/system/repl/error-handling.scm: New file, implements
call-with-error-handling and with-error-handling, and instead of going
into a debugger, we go into a recursive repl that happens to have
debugging information. Will be removing the old debugger from (system
vm debug) shortly.
* module/Makefile.am (SYSTEM_SOURCES): Add error-handling and debug scm
files.
* module/system/repl/repl.scm (prompting-meta-read): Better error
handling -- we don't want to go into a debugger when reading a
command.
(start-repl): Add #:debug keyword argument, and just dispatch to
run-repl.
(run-repl): New function, with the guts of the old start-repl. Added a
prompt, to which a throw to 'quit will abort.
* module/system/repl/common.scm (repl-prepare-eval-thunk): New
helper. In the future we will use this to not enter the debugger on
errors that happen at compile time.
(repl-eval): Use repl-prepare-eval-thunk.
(repl-print): Run the before-print-hook when printing a value.
* module/system/repl/command.scm (*command-table*): Move `option' to the
`system' group. Move `trace' to the `profile' group. Add `debug' and
`inspect' groups.
(command-abbrevs): Rename from command-abbrev, and allow multiple
abbreviations.
(display-group): Fix the case where abbrev? was #f.
(display-summary): Fix alignment of the command and
abbreviations. Allow multiple abbreviations.
(read-command): Rename from read-datum, and have better error
handling.
(meta-command): Better error handling.
(define-meta-command): Better error handling.
(help, show, import, compile, disassemble, time, profile, trace): Fix
docstrings and error messages.
(define-stack-command): New helper, for commands that operate on a
saved stack.
(backtrace, up, down, frame, procedure, locals): New debugger
commands, in the REPL now.
(inspect, pretty-print): New "inspect" commands.
Diffstat (limited to 'module/system/repl/repl.scm')
-rw-r--r-- | module/system/repl/repl.scm | 125 |
1 files changed, 74 insertions, 51 deletions
diff --git a/module/system/repl/repl.scm b/module/system/repl/repl.scm index 48c6eb0f8..ce309a9b9 100644 --- a/module/system/repl/repl.scm +++ b/module/system/repl/repl.scm @@ -24,12 +24,18 @@ #:use-module (system base pmatch) #:use-module (system base compile) #:use-module (system base language) + #:use-module (system vm vm) + #:use-module (system repl error-handling) #:use-module (system repl common) #:use-module (system repl command) - #:use-module (system vm vm) - #:use-module (system vm debug) #:export (start-repl)) + + +;;; +;;; Meta commands +;;; + (define meta-command-token (cons 'meta 'command)) (define (meta-reader read env) @@ -53,12 +59,25 @@ ;; ;; Catches read errors, returning *unspecified* in that case. (define (prompting-meta-read repl) - (call-with-error-handling - (lambda () - (repl-reader (lambda () (repl-prompt repl)) - (meta-reader (language-reader (repl-language repl)) - (current-module)))) - #:on-error 'pass)) + (catch #t + (lambda () + (repl-reader (lambda () (repl-prompt repl)) + (meta-reader (language-reader (repl-language repl)) + (current-module)))) + (lambda (key . args) + (case key + ((quit) + (apply throw key args)) + (else + (pmatch args + ((,subr ,msg ,args . ,rest) + (format #t "Throw to key `~a' while reading expression:\n" key) + (display-error #f (current-output-port) subr msg args rest)) + (else + (format #t "Throw to key `~a' with args `~s' while reading expression.\n" + key args))) + (force-output) + *unspecified*))))) @@ -66,49 +85,53 @@ ;;; The repl ;;; -(define* (start-repl #:optional (lang (current-language))) - (let ((repl (make-repl lang)) - (status #f)) - (with-fluids ((*repl-stack* (cons repl - (or (fluid-ref *repl-stack*) '()))) - (*debug-input-port* - (or (fluid-ref *debug-input-port*) (current-input-port))) - (*debug-output-port* - (or (fluid-ref *debug-output-port*) (current-output-port)))) - (if (null? (cdr (fluid-ref *repl-stack*))) - (repl-welcome repl)) - (let prompt-loop () - (let ((exp (prompting-meta-read repl))) - (cond - ((eqv? exp (if #f #f))) ; read error, pass - ((eq? exp meta-command-token) - (with-error-handling (meta-command repl))) - ((eof-object? exp) - (newline) - (set! status '())) - (else - ;; since the input port is line-buffered, consume up to the - ;; newline - (flush-to-newline) - (with-error-handling - (catch 'quit - (lambda () - (call-with-values - (lambda () - (run-hook before-eval-hook exp) - (start-stack #t - (repl-eval repl (repl-parse repl exp)))) - (lambda l - (for-each (lambda (v) - (run-hook before-print-hook v) - (repl-print repl v)) - l)))) - (lambda (k . args) - (set! status args)))))) - (or status - (begin - (next-char #f) ;; consume trailing whitespace - (prompt-loop)))))))) +(define* (start-repl #:optional (lang (current-language)) #:key debug) + (run-repl (make-repl lang debug))) + +(define (run-repl repl) + (let ((tag (make-prompt-tag "repl "))) + (call-with-prompt + tag + (lambda () + (with-fluids ((*repl-stack* + (cons repl (or (fluid-ref *repl-stack*) '())))) + (if (null? (cdr (fluid-ref *repl-stack*))) + (repl-welcome repl)) + (let prompt-loop () + (let ((exp (prompting-meta-read repl))) + (cond + ((eqv? exp *unspecified*)) ; read error, pass + ((eq? exp meta-command-token) + (catch 'quit + (lambda () (meta-command repl)) + (lambda (k . args) + (abort-to-prompt tag args)))) + ((eof-object? exp) + (newline) + (abort-to-prompt tag '())) + (else + ;; since the input port is line-buffered, consume up to the + ;; newline + (flush-to-newline) + (call-with-error-handling + (lambda () + (catch 'quit + (lambda () + (call-with-values + (lambda () + (run-hook before-eval-hook exp) + (start-stack #t + (repl-eval repl (repl-parse repl exp)))) + (lambda l + (for-each (lambda (v) + (repl-print repl v)) + l)))) + (lambda (k . args) + (abort-to-prompt tag args))))))) + (next-char #f) ;; consume trailing whitespace + (prompt-loop))))) + (lambda (k status) + status)))) (define (next-char wait) (if (or wait (char-ready?)) |