summaryrefslogtreecommitdiff
path: root/module/system
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
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')
-rw-r--r--module/system/repl/command.scm301
-rw-r--r--module/system/repl/common.scm19
-rw-r--r--module/system/repl/debug.scm177
-rw-r--r--module/system/repl/error-handling.scm114
-rw-r--r--module/system/repl/repl.scm125
5 files changed, 616 insertions, 120 deletions
diff --git a/module/system/repl/command.scm b/module/system/repl/command.scm
index 0c3d70715..7b092e634 100644
--- a/module/system/repl/command.scm
+++ b/module/system/repl/command.scm
@@ -24,6 +24,7 @@
#:use-module (system base pmatch)
#:use-module (system base compile)
#:use-module (system repl common)
+ #:use-module (system repl debug)
#:use-module (system vm objcode)
#:use-module (system vm program)
#:use-module (system vm vm)
@@ -35,6 +36,9 @@
#:use-module (ice-9 documentation)
#:use-module (ice-9 and-let-star)
#:use-module (ice-9 rdelim)
+ #:use-module (ice-9 control)
+ #:use-module ((ice-9 pretty-print) #:select ((pretty-print . pp)))
+ #:use-module ((system vm inspect) #:select ((inspect . %inspect)))
#:use-module (statprof)
#:export (meta-command))
@@ -44,14 +48,17 @@
;;;
(define *command-table*
- '((help (help h) (show s) (apropos a) (describe d) (option o) (quit q))
- (module (module m) (import i) (load l) (binding b))
+ '((help (help h) (show s) (apropos a) (describe d))
+ (module (module m) (import use) (load l) (binding b))
(language (language L))
(compile (compile c) (compile-file cc)
(disassemble x) (disassemble-file xx))
- (profile (time t) (profile pr))
- (debug (trace tr))
- (system (gc) (statistics stat))))
+ (profile (time t) (profile pr) (trace tr))
+ (debug (backtrace bt) (up) (down) (frame fr)
+ (procedure proc) (locals))
+ (inspect (inspect i) (pretty-print pp))
+ (system (gc) (statistics stat) (option o)
+ (quit q continue cont))))
(define *show-table*
'((show (warranty w) (copying c) (version v))))
@@ -61,7 +68,7 @@
(define *command-module* (current-module))
(define (command-name c) (car c))
-(define (command-abbrev c) (if (null? (cdr c)) #f (cadr c)))
+(define (command-abbrevs c) (cdr c))
(define (command-procedure c) (module-ref *command-module* (command-name c)))
(define (command-doc c) (procedure-documentation (command-procedure c)))
@@ -88,10 +95,10 @@
(else (loop groups (cdr commands))))))
(define* (display-group group #:optional (abbrev? #t))
- (format #t "~:(~A~) Commands [abbrev]:~2%" (group-name group))
+ (format #t "~:(~A~) Commands~:[~; [abbrev]~]:~2%" (group-name group) abbrev?)
(for-each (lambda (c)
(display-summary (command-usage c)
- (and abbrev? (command-abbrev c))
+ (if abbrev? (command-abbrevs c) '())
(command-summary c)))
(group-commands group))
(newline))
@@ -101,12 +108,37 @@
(display (command-doc command))
(newline))
-(define (display-summary usage abbrev summary)
- (let ((abbrev (if abbrev (format #f "[,~A]" abbrev) "")))
- (format #t " ,~24A ~8@A - ~A\n" usage abbrev summary)))
-
-(define (read-datum repl)
- (read (repl-inport repl)))
+(define (display-summary usage abbrevs summary)
+ (let* ((usage-len (string-length usage))
+ (abbrevs (if (pair? abbrevs)
+ (format #f "[,~A~{ ,~A~}]" (car abbrevs) (cdr abbrevs))
+ ""))
+ (abbrevs-len (string-length abbrevs)))
+ (format #t " ,~A~A~A - ~A\n"
+ usage
+ (cond
+ ((> abbrevs-len 32)
+ (error "abbrevs too long" abbrevs))
+ ((> (+ usage-len abbrevs-len) 32)
+ (format #f "~%~v_" (+ 2 (- 32 abbrevs-len))))
+ (else
+ (format #f "~v_" (- 32 abbrevs-len usage-len))))
+ abbrevs
+ summary)))
+
+(define (read-command repl)
+ (catch #t
+ (lambda () (read (pk (repl-inport repl))))
+ (lambda (key . args)
+ (pmatch args
+ ((,subr ,msg ,args . ,rest)
+ (format #t "Throw to key `~a' while reading command:\n" key)
+ (display-error #f (current-output-port) subr msg args rest))
+ (else
+ (format #t "Throw to key `~a' with args `~s' while reading command.\n"
+ key args)))
+ (force-output)
+ *unspecified*)))
(define read-line
(let ((orig-read-line read-line))
@@ -114,34 +146,57 @@
(orig-read-line (repl-inport repl)))))
(define (meta-command repl)
- (let ((command (read-datum repl)))
- (if (not (symbol? command))
- (user-error "Meta-command not a symbol: ~s" command))
- (let ((c (lookup-command command)))
- (if c
- ((command-procedure c) repl)
- (user-error "Unknown meta command: ~A" command)))))
+ (let ((command (read-command repl)))
+ (cond
+ ((eq? command *unspecified*)) ; read error, already signalled; pass.
+ ((not (symbol? command))
+ (format #t "Meta-command not a symbol: ~s~%" command))
+ ((lookup-command command)
+ => (lambda (c) ((command-procedure c) repl)))
+ (else
+ (format #t "Unknown meta command: ~A~%" command)))))
(define-syntax define-meta-command
(syntax-rules ()
((_ (name repl (expression0 ...) . datums) docstring b0 b1 ...)
(define (name repl)
docstring
- (let* ((expression0
- (repl-reader ""
- (lambda* (#:optional (port (repl-inport repl)))
- ((language-reader (repl-language repl))
- port (current-module)))))
- ...)
- (apply (lambda* datums
- (with-output-to-port (repl-outport repl)
- (lambda () b0 b1 ...)))
- (let ((port (open-input-string (read-line repl))))
- (let lp ((out '()))
- (let ((x (read port)))
- (if (eof-object? x)
- (reverse out)
- (lp (cons x out))))))))))
+ (define (handle-read-error form-name key args)
+ (pmatch args
+ ((,subr ,msg ,args . ,rest)
+ (format #t "Throw to key `~a' while reading ~@[argument `~A' of ~]command `~A':\n"
+ key form-name 'name)
+ (display-error #f (current-output-port) subr msg args rest))
+ (else
+ (format #t "Throw to key `~a' with args `~s' while reading ~@[ argument `~A' of ~]command `~A'.\n"
+ key args form-name 'name)))
+ (abort))
+
+ (% (let* ((expression0
+ (catch #t
+ (lambda ()
+ (repl-reader ""
+ (lambda* (#:optional (port (repl-inport repl)))
+ ((language-reader (repl-language repl))
+ port (current-module)))))
+ (lambda (k . args)
+ (handle-read-error 'expression0 k args))))
+ ...)
+ (apply (lambda* datums
+ (with-output-to-port (repl-outport repl)
+ (lambda () b0 b1 ...)))
+ (catch #t
+ (lambda ()
+ (let ((port (open-input-string (read-line repl))))
+ (let lp ((out '()))
+ (let ((x (read port)))
+ (if (eof-object? x)
+ (reverse out)
+ (lp (cons x out)))))))
+ (lambda (k . args)
+ (handle-read-error #f k args)))))
+ (lambda (k) #f)))) ; the abort handler
+
((_ (name repl . datums) docstring b0 b1 ...)
(define-meta-command (name repl () . datums)
docstring b0 b1 ...))))
@@ -153,11 +208,8 @@
;;;
(define-meta-command (help repl . args)
- "help
-help GROUP
-help [-c] COMMAND
-
-Gives help on the meta-commands available at the REPL.
+ "help [all | GROUP | [-c] COMMAND]
+Show help.
With one argument, tries to look up the argument as a group name, giving
help on that group if successful. Otherwise tries to look up the
@@ -191,16 +243,14 @@ are displayed."
((-c ,command) (guard (lookup-command command))
(display-command (lookup-command command)))
((,command)
- (user-error "Unknown command or group: ~A" command))
+ (format #t "Unknown command or group: ~A~%" command))
((-c ,command)
- (user-error "Unknown command: ~A" command))
+ (format #t "Unknown command: ~A~%" command))
(else
- (user-error "Bad arguments: ~A" args))))
+ (format #t "Bad arguments: ~A~%" args))))
(define-meta-command (show repl . args)
- "show
-show TOPIC
-
+ "show [TOPIC]
Gives information about Guile.
With one argument, tries to show a particular piece of information;
@@ -216,9 +266,9 @@ Without any argument, a list of topics is displayed."
((,topic) (guard (lookup-command topic *show-table*))
((command-procedure (lookup-command topic *show-table*)) repl))
((,command)
- (user-error "Unknown topic: ~A" command))
+ (format #t "Unknown topic: ~A~%" command))
(else
- (user-error "Bad arguments: ~A" args))))
+ (format #t "Bad arguments: ~A~%" args))))
(define (warranty repl)
"show warranty
@@ -291,7 +341,7 @@ Import modules / List those imported."
(let ((mod (resolve-interface name)))
(if mod
(module-use! (current-module) mod)
- (user-error "No such module: ~A" name))))
+ (format #t "No such module: ~A~%" name))))
(if (null? args)
(for-each puts (map module-name (module-uses (current-module))))
(for-each use args))))
@@ -333,7 +383,7 @@ Change languages."
;;;
(define-meta-command (compile repl (form))
- "compile FORM
+ "compile EXP
Generate compiled code."
(let ((x (repl-compile repl (repl-parse repl form))))
(cond ((objcode? x) (guile:disassemble x))
@@ -349,8 +399,8 @@ Compile a file."
((@ (language assembly disassemble) disassemble) x))
(define-meta-command (disassemble repl (form))
- "disassemble PROGRAM
-Disassemble a program."
+ "disassemble EXP
+Disassemble a compiled procedure."
(guile:disassemble (repl-eval repl (repl-parse repl form))))
(define-meta-command (disassemble-file repl file)
@@ -364,7 +414,7 @@ Disassemble a file."
;;;
(define-meta-command (time repl (form))
- "time FORM
+ "time EXP
Time execution."
(let* ((gc-start (gc-run-time))
(tms-start (times))
@@ -385,21 +435,15 @@ Time execution."
result))
(define-meta-command (profile repl (form) . opts)
- "profile FORM
+ "profile EXP
Profile execution."
;; FIXME opts
(apply statprof
(make-program (repl-compile repl (repl-parse repl form)))
opts))
-
-
-;;;
-;;; Debug commands
-;;;
-
(define-meta-command (trace repl (form) . opts)
- "trace FORM
+ "trace EXP
Trace execution."
;; FIXME: doc options, or somehow deal with them better
(apply vm-trace
@@ -407,6 +451,139 @@ Trace execution."
(make-program (repl-compile repl (repl-parse repl form)))
opts))
+
+;;;
+;;; Debug commands
+;;;
+
+(define-syntax define-stack-command
+ (lambda (x)
+ (syntax-case x ()
+ ((_ (name repl . args) docstring body body* ...)
+ #`(define-meta-command (name repl . args)
+ docstring
+ (let ((debug (repl-debug repl)))
+ (if debug
+ (letrec-syntax
+ ((#,(datum->syntax #'repl 'frames)
+ (identifier-syntax (debug-frames debug)))
+ (#,(datum->syntax #'repl 'index)
+ (identifier-syntax
+ (id (debug-index debug))
+ ((set! id exp) (set! (debug-index debug) exp))))
+ (#,(datum->syntax #'repl 'cur)
+ (identifier-syntax
+ (vector-ref #,(datum->syntax #'repl 'frames)
+ #,(datum->syntax #'repl 'index)))))
+ body body* ...)
+ (format #t "Nothing to debug.~%"))))))))
+
+(define-stack-command (backtrace repl #:optional count
+ #:key (width 72) full?)
+ "backtrace [COUNT] [#:width W] [#:full? F]
+Print a backtrace.
+
+Print a backtrace of all stack frames, or innermost COUNT frames.
+If COUNT is negative, the last COUNT frames will be shown."
+ (print-frames frames
+ #:count count
+ #:width width
+ #:full? full?))
+
+(define-stack-command (up repl #:optional (count 1))
+ "up [COUNT]
+Select a calling stack frame.
+
+Select and print stack frames that called this one.
+An argument says how many frames up to go."
+ (cond
+ ((or (not (integer? count)) (<= count 0))
+ (format #t "Invalid argument to `up': expected a positive integer for COUNT.~%"))
+ ((>= (+ count index) (vector-length frames))
+ (cond
+ ((= index (1- (vector-length frames)))
+ (format #t "Already at outermost frame.\n"))
+ (else
+ (set! index (1- (vector-length frames)))
+ (print-frame cur #:index index))))
+ (else
+ (set! index (+ count index))
+ (print-frame cur #:index index))))
+
+(define-stack-command (down repl #:optional (count 1))
+ "down [COUNT]
+Select a called stack frame.
+
+Select and print stack frames called by this one.
+An argument says how many frames down to go."
+ (cond
+ ((or (not (integer? count)) (<= count 0))
+ (format #t "Invalid argument to `down': expected a positive integer for COUNT.~%"))
+ ((< (- index count) 0)
+ (cond
+ ((zero? index)
+ (format #t "Already at innermost frame.\n"))
+ (else
+ (set! index 0)
+ (print-frame cur #:index index))))
+ (else
+ (set! index (- index count))
+ (print-frame cur #:index index))))
+
+(define-stack-command (frame repl #:optional idx)
+ "frame [IDX]
+Show a frame.
+
+Show the selected frame.
+With an argument, select a frame by index, then show it."
+ (cond
+ (idx
+ (cond
+ ((or (not (integer? idx)) (< idx 0))
+ (format #t "Invalid argument to `frame': expected a non-negative integer for IDX.~%"))
+ ((< idx (vector-length frames))
+ (set! index idx)
+ (print-frame cur #:index index))
+ (else
+ (format #t "No such frame.~%"))))
+ (else (print-frame cur #:index index))))
+
+(define-stack-command (procedure repl)
+ "procedure
+Print the procedure for the selected frame.
+
+Foo."
+ (repl-print repl (frame-procedure cur)))
+
+(define-stack-command (locals repl)
+ "locals
+Show local variables.
+
+Show locally-bound variables in the selected frame."
+ (print-locals cur))
+
+
+;;;
+;;; Inspection commands
+;;;
+
+(define-stack-command (inspect repl (form))
+ "inspect EXP
+Inspect the result(s) of evaluating EXP."
+ (call-with-values (make-program (repl-compile repl (repl-parse repl form)))
+ (lambda args
+ (for-each %inspect args))))
+
+(define-meta-command (pretty-print repl (form))
+ "pretty-print EXP
+Pretty-print the result(s) of evaluating EXP."
+ (call-with-values (make-program (repl-compile repl (repl-parse repl form)))
+ (lambda args
+ (for-each
+ (lambda (x)
+ (run-hook before-print-hook x)
+ (pp x))
+ args))))
;;;
diff --git a/module/system/repl/common.scm b/module/system/repl/common.scm
index 2d50d441f..9d71e9939 100644
--- a/module/system/repl/common.scm
+++ b/module/system/repl/common.scm
@@ -26,7 +26,8 @@
#:use-module (ice-9 control)
#:export (<repl> make-repl repl-language repl-options
repl-tm-stats repl-gc-stats repl-inport repl-outport repl-debug
- repl-welcome repl-prompt repl-read repl-compile repl-eval
+ repl-welcome repl-prompt
+ repl-read repl-compile repl-prepare-eval-thunk repl-eval
repl-parse repl-print repl-option-ref repl-option-set!
repl-default-option-set! repl-default-prompt-set!
puts ->string user-error
@@ -152,18 +153,22 @@ See <http://www.gnu.org/licenses/lgpl.html>, for more details.")
(let ((parser (language-parser (repl-language repl))))
(if parser (parser form) form)))
+(define (repl-prepare-eval-thunk repl form)
+ (let* ((eval (language-evaluator (repl-language repl))))
+ (if (and eval
+ (or (null? (language-compilers (repl-language repl)))
+ (assq-ref (repl-options repl) 'interp)))
+ (lambda () (eval form (current-module)))
+ (make-program (repl-compile repl form)))))
+
(define (repl-eval repl form)
- (let* ((eval (language-evaluator (repl-language repl)))
- (thunk (if (and eval
- (or (null? (language-compilers (repl-language repl)))
- (assq-ref (repl-options repl) 'interp)))
- (lambda () (eval form (current-module)))
- (make-program (repl-compile repl form)))))
+ (let ((thunk (repl-prepare-eval-thunk repl form)))
(% (thunk))))
(define (repl-print repl val)
(if (not (eq? val *unspecified*))
(begin
+ (run-hook before-print-hook val)
;; The result of an evaluation is representable in scheme, and
;; should be printed with the generic printer, `write'. The
;; language-printer is something else: it prints expressions of
diff --git a/module/system/repl/debug.scm b/module/system/repl/debug.scm
new file mode 100644
index 000000000..f9b6af280
--- /dev/null
+++ b/module/system/repl/debug.scm
@@ -0,0 +1,177 @@
+;;; Guile VM debugging facilities
+
+;;; Copyright (C) 2001, 2009, 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
+
+;;; Code:
+
+(define-module (system repl debug)
+ #:use-module (system base pmatch)
+ #:use-module (system base syntax)
+ #:use-module (system base language)
+ #:use-module (system vm vm)
+ #:use-module (system vm frame)
+ #:use-module (ice-9 rdelim)
+ #:use-module (ice-9 pretty-print)
+ #:use-module (ice-9 format)
+ #:use-module ((system vm inspect) #:select ((inspect . %inspect)))
+ #:use-module (system vm program)
+ #:export (<debug>
+ make-debug debug? debug-frames debug-index
+ print-locals print-frame print-frames frame->module
+ stack->vector narrow-stack->vector))
+
+;;; FIXME: add more repl meta-commands: continue, inspect, etc...
+
+;;;
+;;; Debugger
+;;;
+;;; The actual interaction loop of the debugger is run by the repl. This module
+;;; simply exports a data structure to hold the debugger state, along with its
+;;; accessors, and provides some helper functions.
+;;;
+
+(define-record <debug> frames index)
+
+
+
+(define (reverse-hashq h)
+ (let ((ret (make-hash-table)))
+ (hash-for-each
+ (lambda (k v)
+ (hashq-set! ret v (cons k (hashq-ref ret v '()))))
+ h)
+ ret))
+
+(define* (print-locals frame #:optional (port (current-output-port))
+ #:key (width 72) (per-line-prefix ""))
+ (let ((bindings (frame-bindings frame)))
+ (cond
+ ((null? bindings)
+ (format port "~aNo local variables.~%" per-line-prefix))
+ (else
+ (format port "~aLocal variables:~%" per-line-prefix)
+ (for-each
+ (lambda (binding)
+ (format port "~a~4d ~a~:[~; (boxed)~] = ~v:@y\n"
+ per-line-prefix
+ (binding:index binding)
+ (binding:name binding)
+ (binding:boxed? binding)
+ width
+ (let ((x (frame-local-ref frame (binding:index binding))))
+ (if (binding:boxed? binding)
+ (variable-ref x)
+ x))))
+ (frame-bindings frame))))))
+
+(define* (print-frame frame #:optional (port (current-output-port))
+ #:key index (width 72) (full? #f) (last-source #f))
+ (define (source:pretty-file source)
+ (if source
+ (or (source:file source) "current input")
+ "unknown file"))
+ (let* ((source (frame-source frame))
+ (file (source:pretty-file source))
+ (line (and=> source source:line)))
+ (if (and file (not (equal? file (source:pretty-file last-source))))
+ (format port "~&In ~a:~&" file))
+ (format port "~:[~*~6_~;~5d:~]~:[~*~3_~;~3d~] ~v:@y~%"
+ line line index index width (frame-call-representation frame))
+ (if full?
+ (print-locals frame #:width width
+ #:per-line-prefix " "))))
+
+(define* (print-frames frames
+ #:optional (port (current-output-port))
+ #:key (width 72) (full? #f) (forward? #f) count)
+ (let* ((len (vector-length frames))
+ (lower-idx (if (or (not count) (positive? count))
+ 0
+ (max 0 (+ len count))))
+ (upper-idx (if (and count (negative? count))
+ (1- len)
+ (1- (if count (min count len) len))))
+ (inc (if forward? 1 -1)))
+ (let lp ((i (if forward? lower-idx upper-idx))
+ (last-source #f))
+ (if (<= lower-idx i upper-idx)
+ (let* ((frame (vector-ref frames i)))
+ (print-frame frame port #:index i #:width width #:full? full?
+ #:last-source last-source)
+ (lp (+ i inc) (frame-source frame)))))))
+
+;; Ideally here we would have something much more syntactic, in that a set! to a
+;; local var that is not settable would raise an error, and export etc forms
+;; would modify the module in question: but alack, this is what we have now.
+;; Patches welcome!
+(define (frame->module frame)
+ (let ((proc (frame-procedure frame)))
+ (if (program? proc)
+ (let* ((mod (or (program-module proc) (current-module)))
+ (mod* (make-module)))
+ (module-use! mod* mod)
+ (for-each
+ (lambda (binding)
+ (let* ((x (frame-local-ref frame (binding:index binding)))
+ (var (if (binding:boxed? binding) x (make-variable x))))
+ (format #t
+ "~:[Read-only~;Mutable~] local variable ~a = ~70:@y\n"
+ (binding:boxed? binding)
+ (binding:name binding)
+ (if (variable-bound? var) (variable-ref var) var))
+ (module-add! mod* (binding:name binding) var)))
+ (frame-bindings frame))
+ mod*)
+ (current-module))))
+
+
+;; TODO:
+;;
+;; eval expression in context of frame
+;; set local variable in frame
+;; step until next instruction
+;; step until next function call/return
+;; step until return from frame
+;; step until different source line
+;; step until greater source line
+;; watch expression
+;; break on a function
+;; remove breakpoints
+;; set printing width
+;; display a truncated backtrace
+;; go to a frame by index
+;; (reuse gdb commands perhaps)
+;; disassemble a function
+;; disassemble the current function
+;; inspect any object
+;; hm, trace via reassigning global vars. tricksy.
+;; (state associated with vm ?)
+
+(define (stack->vector stack)
+ (let* ((len (stack-length stack))
+ (v (make-vector len)))
+ (if (positive? len)
+ (let lp ((i 0) (frame (stack-ref stack 0)))
+ (if (< i len)
+ (begin
+ (vector-set! v i frame)
+ (lp (1+ i) (frame-previous frame))))))
+ v))
+
+(define (narrow-stack->vector stack . args)
+ (stack->vector (apply make-stack (stack-ref stack 0) args)))
+
diff --git a/module/system/repl/error-handling.scm b/module/system/repl/error-handling.scm
new file mode 100644
index 000000000..d7d43bd71
--- /dev/null
+++ b/module/system/repl/error-handling.scm
@@ -0,0 +1,114 @@
+;;; Error handling in the REPL
+
+;; Copyright (C) 2001, 2009, 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
+
+;;; Code:
+
+(define-module (system repl error-handling)
+ #:use-module (system base pmatch)
+ #:use-module (system repl debug)
+ #:export (call-with-error-handling
+ with-error-handling))
+
+
+
+
+;;;
+;;; Error handling via repl debugging
+;;;
+
+(define* (call-with-error-handling thunk #:key
+ (on-error 'debug) (post-error 'catch)
+ (pass-keys '(quit)))
+ (let ((in (current-input-port))
+ (out (current-output-port))
+ (err (current-error-port)))
+ (define (with-saved-ports thunk)
+ (with-input-from-port in
+ (lambda ()
+ (with-output-to-port out
+ (lambda ()
+ (with-error-to-port err
+ thunk))))))
+
+ (catch #t
+ (lambda () (%start-stack #t thunk))
+
+ (case post-error
+ ((catch)
+ (lambda (key . args)
+ (if (memq key pass-keys)
+ (apply throw key args)
+ (begin
+ (pmatch args
+ ((,subr ,msg ,args . ,rest)
+ (with-saved-ports
+ (lambda ()
+ (run-hook before-error-hook)
+ (display-error #f err subr msg args rest)
+ (run-hook after-error-hook)
+ (force-output err))))
+ (else
+ (format err "\nERROR: uncaught throw to `~a', args: ~a\n"
+ key args)))
+ (if #f #f)))))
+ (else
+ (if (procedure? post-error)
+ post-error ; a handler proc
+ (error "Unknown post-error strategy" post-error))))
+
+ (case on-error
+ ((debug)
+ (lambda (key . args)
+ (let ((stack (make-stack #t)))
+ (with-saved-ports
+ (lambda ()
+ (pmatch args
+ ((,subr ,msg ,args . ,rest)
+ (format #t "Throw to key `~a':\n" key)
+ (display-error stack (current-output-port) subr msg args rest))
+ (else
+ (format #t "Throw to key `~a' with args `~s'." key args)))
+ (format #t "Entering a new prompt. Type `,bt' for a backtrace")
+ (format #t " or `,q' to return to the old prompt.\n")
+ (let ((debug
+ (make-debug
+ (narrow-stack->vector
+ stack
+ ;; Cut three frames from the top of the stack:
+ ;; make-stack, this one, and the throw handler.
+ 3
+ ;; Narrow the end of the stack to the most recent
+ ;; start-stack.
+ (and (pair? (fluid-ref %stacks))
+ (cdar (fluid-ref %stacks))))
+ 0)))
+ ((@ (system repl repl) start-repl) #:debug debug)))))))
+ ((pass)
+ (lambda (key . args)
+ ;; fall through to rethrow
+ #t))
+ (else
+ (if (procedure? on-error)
+ on-error ; pre-unwind handler
+ (error "Unknown on-error strategy" on-error)))))))
+
+(define-syntax with-error-handling
+ (syntax-rules ()
+ ((_ form)
+ (call-with-error-handling (lambda () form)))))
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?))