summaryrefslogtreecommitdiff
path: root/module/system/repl/error-handling.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/error-handling.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/error-handling.scm')
-rw-r--r--module/system/repl/error-handling.scm114
1 files changed, 114 insertions, 0 deletions
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)))))