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.

module/Makefile.am

@@ -319,9 +319,11 @@ SYSTEM_SOURCES =				\
   system/vm/vm.scm				\
   system/foreign.scm				\
   system/xref.scm				\
-  system/repl/repl.scm				\
+  system/repl/debug.scm				\
+  system/repl/error-handling.scm		\
   system/repl/common.scm			\
-  system/repl/command.scm
+  system/repl/command.scm			\
+  system/repl/repl.scm
 
 LIB_SOURCES =					\
   statprof.scm					\

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))
+  '((help     (help h) (show s) (apropos a) (describe d))
-    (module   (module m) (import i) (load l) (binding b))
+    (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))
+    (profile  (time t) (profile pr) (trace tr))
-    (debug    (trace tr))
+    (debug    (backtrace bt) (up) (down) (frame fr)
-    (system   (gc) (statistics stat))))
+              (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)
+(define (display-summary usage abbrevs summary)
-  (let ((abbrev (if abbrev (format #f "[,~A]" abbrev) "")))
+  (let* ((usage-len (string-length usage))
-    (format #t " ,~24A ~8@A - ~A\n" usage abbrev summary)))
+         (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-datum repl)
+(define (read-command repl)
-  (read (repl-inport 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)))
+  (let ((command (read-command repl)))
-    (if (not (symbol? command))
+    (cond
-        (user-error "Meta-command not a symbol: ~s" command))
+     ((eq? command *unspecified*)) ; read error, already signalled; pass.
-    (let ((c (lookup-command command)))
+     ((not (symbol? command))
-      (if c
+      (format #t "Meta-command not a symbol: ~s~%" command))
-          ((command-procedure c) repl)
+     ((lookup-command command)
-          (user-error "Unknown meta command: ~A" 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
+       (define (handle-read-error form-name key args)
-               (repl-reader ""
+         (pmatch args
-                            (lambda* (#:optional (port (repl-inport repl)))
+           ((,subr ,msg ,args . ,rest)
-                              ((language-reader (repl-language repl))
+            (format #t "Throw to key `~a' while reading ~@[argument `~A' of ~]command `~A':\n"
-                               port (current-module)))))
+                    key form-name 'name)
-              ...)
+            (display-error #f (current-output-port) subr msg args rest))
-         (apply (lambda* datums
+           (else
-                  (with-output-to-port (repl-outport repl)
+            (format #t "Throw to key `~a' with args `~s' while reading ~@[ argument `~A' of ~]command `~A'.\n"
-                    (lambda () b0 b1 ...)))
+                    key args form-name 'name)))
-                (let ((port (open-input-string (read-line repl))))
+         (abort))
-                  (let lp ((out '()))
+       
-                    (let ((x (read port)))
+       (% (let* ((expression0
-                      (if (eof-object? x)
+                  (catch #t
-                          (reverse out)
+                    (lambda ()
-                          (lp (cons x out))))))))))
+                      (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 [all | GROUP | [-c] COMMAND]
-help GROUP
+Show help.
-help [-c] COMMAND
-
-Gives help on the meta-commands available at the REPL.
 
 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 EXP
-Disassemble a program."
+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))))
 
 
 ;;;

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)))
+  (let ((thunk (repl-prepare-eval-thunk repl form)))
-         (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)))))
     (% (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

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)))
+

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)))))

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
+  (catch #t
-   (lambda ()
+    (lambda ()
-     (repl-reader (lambda () (repl-prompt repl))
+      (repl-reader (lambda () (repl-prompt repl))
-                  (meta-reader (language-reader (repl-language repl))
+                   (meta-reader (language-reader (repl-language repl))
-                               (current-module))))
+                                (current-module))))
-   #:on-error 'pass))
+    (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)))
+(define* (start-repl #:optional (lang (current-language)) #:key debug)
-  (let ((repl (make-repl lang))
+  (run-repl (make-repl lang debug)))
-        (status #f))
+
-    (with-fluids ((*repl-stack* (cons repl
+(define (run-repl repl)
-                                      (or (fluid-ref *repl-stack*) '())))
+  (let ((tag (make-prompt-tag "repl ")))
-                  (*debug-input-port*
+    (call-with-prompt
-                   (or (fluid-ref *debug-input-port*) (current-input-port)))
+     tag
-                  (*debug-output-port*
+     (lambda ()
-                   (or (fluid-ref *debug-output-port*) (current-output-port))))
+       (with-fluids ((*repl-stack*
-      (if (null? (cdr (fluid-ref *repl-stack*)))
+                      (cons repl (or (fluid-ref *repl-stack*) '()))))
-          (repl-welcome repl))
+         (if (null? (cdr (fluid-ref *repl-stack*)))
-      (let prompt-loop ()
+             (repl-welcome repl))
-        (let ((exp (prompting-meta-read repl)))
+         (let prompt-loop ()
-          (cond
+           (let ((exp (prompting-meta-read repl)))
-           ((eqv? exp (if #f #f)))      ; read error, pass
+             (cond
-           ((eq? exp meta-command-token)
+              ((eqv? exp *unspecified*))   ; read error, pass
-            (with-error-handling (meta-command repl)))
+              ((eq? exp meta-command-token)
-           ((eof-object? exp)
+               (catch 'quit
-            (newline)
+                 (lambda () (meta-command repl))
-            (set! status '()))
+                 (lambda (k . args)
-           (else
+                   (abort-to-prompt tag args))))
-            ;; since the input port is line-buffered, consume up to the
+              ((eof-object? exp)
-            ;; newline
+               (newline)
-            (flush-to-newline)
+               (abort-to-prompt tag '()))
-            (with-error-handling
+              (else
-             (catch 'quit
+               ;; since the input port is line-buffered, consume up to the
-               (lambda ()
+               ;; newline
-                 (call-with-values
+               (flush-to-newline)
-                     (lambda ()
+               (call-with-error-handling
-                       (run-hook before-eval-hook exp)
+                (lambda ()
-                       (start-stack #t
+                  (catch 'quit
-                                    (repl-eval repl (repl-parse repl exp))))
+                    (lambda ()
-                   (lambda l
+                      (call-with-values
-                     (for-each (lambda (v)
+                          (lambda ()
-                                 (run-hook before-print-hook v)
+                            (run-hook before-eval-hook exp)
-                                 (repl-print repl v))
+                            (start-stack #t
-                               l))))
+                                         (repl-eval repl (repl-parse repl exp))))
-               (lambda (k . args)
+                        (lambda l
-                 (set! status args))))))
+                          (for-each (lambda (v)
-          (or status
+                                      (repl-print repl v))
-              (begin
+                                    l))))
-                (next-char #f) ;; consume trailing whitespace
+                    (lambda (k . args)
-                (prompt-loop))))))))
+                      (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?))