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