[Guile-commits] GNU Guile branch, master, updated. release_1-9-11-297-g54d9a99

[Jose A. Ortega Ruiz]

This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".

http://git.savannah.gnu.org/cgit/guile.git/commit/?id=54d9a994b1b71024aad3d1f586de7a81bb873dbf

The branch, master has been updated
       via  54d9a994b1b71024aad3d1f586de7a81bb873dbf (commit)
      from  5cc987760bc148a8c753ec2a498ed5ee783f14ec (commit)

Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.

- Log -----------------------------------------------------------------
commit 54d9a994b1b71024aad3d1f586de7a81bb873dbf
Author: Jose A. Ortega Ruiz <address@hidden>
Date:   Mon Aug 30 06:37:24 2010 +0200

    Add new debug meta-command ,error-message
    
    * module/system/repl/error-handling.scm: use the error string to
      construct the <debug> instance.
    
    * module/system/repl/command.scm: new debug command `error-message'
      that extracts the new <debug> field, available to stack commands as
      `message'.
    
    * doc/ref/scheme-using.texi: documentation for new command.
    
    * module/system/repl/debug.scm: <debug> stores the error string in a
      new field.

-----------------------------------------------------------------------

Summary of changes:
 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 e07b148..f6c2136 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
 
address@hidden {REPL Command} error-message
address@hidden {REPL Command} error
+Show error message.
+
+Display the message associated with the error that started the current
+debugging REPL.
address@hidden 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 8a62a16..c98d328 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 
address@hidden 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 293b790..1876d31 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 (<debug>
-            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 <debug> frames index)
+(define-record <debug> frames index error-message)
 
 
 
diff --git a/module/system/repl/error-handling.scm 
b/module/system/repl/error-handling.scm
index db0beeb..e77ea96 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))))))


hooks/post-receive
-- 
GNU Guile