summaryrefslogtreecommitdiff
path: root/module/system/repl/repl.scm
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2010-07-09 17:04:34 +0200
committerAndy Wingo <wingo@pobox.com>2010-07-09 17:05:25 +0200
commit33df2ec719d281c70a5c7595dceee9f47770e910 (patch)
tree6d0fc69ef15d3243f13985eb85c1f01628f1f1df /module/system/repl/repl.scm
parentddfb5e2bb02e167c734af5091d40d7db4ffeffa1 (diff)
downloadguile-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.scm125
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?))