From 54d9a994b1b71024aad3d1f586de7a81bb873dbf Mon Sep 17 00:00:00 2001 From: "Jose A. Ortega Ruiz" Date: Mon, 30 Aug 2010 06:37:24 +0200 Subject: [PATCH] Add new debug meta-command ,error-message * module/system/repl/error-handling.scm: use the error string to construct the instance. * module/system/repl/command.scm: new debug command `error-message' that extracts the new field, available to stack commands as `message'. * doc/ref/scheme-using.texi: documentation for new command. * module/system/repl/debug.scm: stores the error string in a new field. --- doc/ref/scheme-using.texi | 8 ++++++++ module/system/repl/command.scm | 28 ++++++++++++++++++--------- module/system/repl/debug.scm | 4 ++-- module/system/repl/error-handling.scm | 26 +++++++++++++++---------- 4 files changed, 45 insertions(+), 21 deletions(-) diff --git a/doc/ref/scheme-using.texi b/doc/ref/scheme-using.texi index e07b1481a..f6c2136e7 100644 --- a/doc/ref/scheme-using.texi +++ b/doc/ref/scheme-using.texi @@ -311,6 +311,14 @@ Show local variables. Show locally-bound variables in the selected frame. @end deffn +@deffn {REPL Command} error-message +@deffnx {REPL Command} error +Show error message. + +Display the message associated with the error that started the current +debugging REPL. +@end deffn + @c FIXME: whenever we regain support for stepping, here are the docs.. @c The commands in this subsection all apply only when the stack is diff --git a/module/system/repl/command.scm b/module/system/repl/command.scm index 8a62a1612..c98d328bc 100644 --- a/module/system/repl/command.scm +++ b/module/system/repl/command.scm @@ -6,12 +6,12 @@ ;; 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 @@ -55,7 +55,7 @@ (disassemble x) (disassemble-file xx)) (profile (time t) (profile pr) (trace tr)) (debug (backtrace bt) (up) (down) (frame fr) - (procedure proc) (locals)) + (procedure proc) (locals) (error-message error)) (inspect (inspect i) (pretty-print pp)) (system (gc) (statistics stat) (option o) (quit q continue cont)))) @@ -171,7 +171,7 @@ (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 () @@ -463,6 +463,8 @@ Trace execution." (letrec-syntax ((#,(datum->syntax #'repl 'frames) (identifier-syntax (debug-frames debug))) + (#,(datum->syntax #'repl 'message) + (identifier-syntax (debug-error-message debug))) (#,(datum->syntax #'repl 'index) (identifier-syntax (id (debug-index debug)) @@ -474,6 +476,14 @@ Trace execution." body body* ...) (format #t "Nothing to debug.~%")))))))) +(define-stack-command (error-message repl) + "error-message +Show error message. + +Display the message associated with the error that started the current +debugging REPL." + (format #t "~a~%" (if (string? message) message "No error message"))) + (define-stack-command (backtrace repl #:optional count #:key (width 72) full?) "backtrace [COUNT] [#:width W] [#:full? F] @@ -481,11 +491,11 @@ 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 + (print-frames frames #:count count #:width width #:full? full?)) - + (define-stack-command (up repl #:optional (count 1)) "up [COUNT] Select a calling stack frame. @@ -548,14 +558,14 @@ With an argument, select a frame by index, then show it." "procedure Print the procedure for the selected frame." (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 @@ -581,7 +591,7 @@ Pretty-print the result(s) of evaluating EXP." ;;; -;;; System commands +;;; System commands ;;; (define guile:gc gc) diff --git a/module/system/repl/debug.scm b/module/system/repl/debug.scm index 293b790fa..1876d315e 100644 --- a/module/system/repl/debug.scm +++ b/module/system/repl/debug.scm @@ -30,7 +30,7 @@ #:use-module ((system vm inspect) #:select ((inspect . %inspect))) #:use-module (system vm program) #:export ( - make-debug debug? debug-frames debug-index + make-debug debug? debug-frames debug-index debug-error-message print-locals print-frame print-frames frame->module stack->vector narrow-stack->vector)) @@ -66,7 +66,7 @@ ;;; accessors, and provides some helper functions. ;;; -(define-record frames index) +(define-record frames index error-message) diff --git a/module/system/repl/error-handling.scm b/module/system/repl/error-handling.scm index db0beeb78..e77ea96f4 100644 --- a/module/system/repl/error-handling.scm +++ b/module/system/repl/error-handling.scm @@ -32,6 +32,16 @@ ;;; Error handling via repl debugging ;;; +(define (error-string stack key args) + (with-output-to-string + (lambda () + (pmatch args + ((,subr ,msg ,args . ,rest) + (display-error (vector-ref stack 0) (current-output-port) + subr msg args rest)) + (else + (format #t "Throw to key `~a' with args `~s'." key args)))))) + (define* (call-with-error-handling thunk #:key (on-error 'debug) (post-error 'catch) (pass-keys '(quit))) @@ -45,7 +55,7 @@ (lambda () (with-error-to-port err thunk)))))) - + (catch #t (lambda () (%start-stack #t thunk)) @@ -75,7 +85,7 @@ (if (procedure? post-error) post-error ; a handler proc (error "Unknown post-error strategy" post-error)))) - + (case on-error ((debug) (lambda (key . args) @@ -85,22 +95,18 @@ (make-stack #t) ;; Cut three frames from the top of the stack: ;; make-stack, this one, and the throw handler. - 3 + 3 ;; Narrow the end of the stack to the most recent ;; start-stack. tag ;; And one more frame, because %start-stack invoking ;; the start-stack thunk has its own frame too. 0 (and tag 1))) - (debug (make-debug stack 0))) + (error-msg (error-string stack key args)) + (debug (make-debug stack 0 error-msg))) (with-saved-ports (lambda () - (pmatch args - ((,subr ,msg ,args . ,rest) - (display-error (vector-ref stack 0) (current-output-port) - subr msg args rest)) - (else - (format #t "Throw to key `~a' with args `~s'." key args))) + (format #t error-msg) (format #t "Entering a new prompt. ") (format #t "Type `,bt' for a backtrace or `,q' to continue.\n") ((@ (system repl repl) start-repl) #:debug debug))))))