unofficial mirror of guile-devel@gnu.org 
 help / color / mirror / Atom feed
* R6RS exception printing at the REPL
@ 2010-10-24 21:46 Andreas Rottmann
  2010-11-20 15:23 ` Andy Wingo
  0 siblings, 1 reply; 13+ messages in thread
From: Andreas Rottmann @ 2010-10-24 21:46 UTC (permalink / raw)
  To: Guile Development

[-- Attachment #1: Type: text/plain, Size: 695 bytes --]

Hi!

Attached is a patch that improves the way R6RS exceptions are printed at
the REPL; previously:

scheme@(guile-user)> (import (rnrs))
scheme@(guile-user)> (assertion-violation 'foo "hey!" 1 2 3)
Throw to key `r6rs:exception' with args `(#<r6rs:record:&raise-object-wrapper>)'.
Entering a new prompt.  Type `,bt' for a backtrace or `,q' to continue.
scheme@(guile-user) [1]> 

With the patch:

scheme@(guile-user)> (import (rnrs))
scheme@(guile-user)> (assertion-violation 'foo "hey!" 1 2 3)
ERROR: R6RS exception:
  1. &assertion
  2. &who: foo
  3. &message: "hey!"
  4. &irritants: (1 2 3)

Entering a new prompt.  Type `,bt' for a backtrace or `,q' to continue.
scheme@(guile-user) [1]>


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: r6rs-exception-print.diff --]
[-- Type: text/x-diff, Size: 7000 bytes --]

From: Andreas Rottmann <a.rottmann@gmx.at>
Subject: Show R6RS exceptions in a reasonable way in the debugger

* module/system/repl/error-handling/r6rs.scm: New module, containing a
  formatter for R6RS exception.
* module/system/repl/error-handling.scm (error-string): Treat throws to
  `r6rs:exception' specially, calling out to `display-exception' from
  the above module.  Use `module-ref' and `resolve-module' for
  referring to that procedure to make this a runtime-only dependency.
* module/Makefile.am (SYSTEM_SOURCES): Add
  module/system/repl/error-handling/r6rs.scm.

---
 module/Makefile.am                         |    1 +
 module/system/repl/error-handling.scm      |   25 +++++---
 module/system/repl/error-handling/r6rs.scm |   93 ++++++++++++++++++++++++++++
 3 files changed, 111 insertions(+), 8 deletions(-)

diff --git a/module/Makefile.am b/module/Makefile.am
index 8086d82..3112760 100644
--- a/module/Makefile.am
+++ b/module/Makefile.am
@@ -323,6 +323,7 @@ SYSTEM_SOURCES =				\
   system/xref.scm				\
   system/repl/debug.scm				\
   system/repl/error-handling.scm		\
+  system/repl/error-handling/r6rs.scm		\
   system/repl/common.scm			\
   system/repl/command.scm			\
   system/repl/repl.scm				\
diff --git a/module/system/repl/error-handling.scm b/module/system/repl/error-handling.scm
index 737eadf..619601f 100644
--- a/module/system/repl/error-handling.scm
+++ b/module/system/repl/error-handling.scm
@@ -34,15 +34,24 @@
 ;;;
 
 (define (error-string stack key args)
-  (pmatch args
-    ((,subr ,msg ,args . ,rest)
-     (guard (> (vector-length stack) 0))
-     (with-output-to-string
-       (lambda ()
-         (display-error (vector-ref stack 0) (current-output-port)
-                        subr msg args rest))))
+  (case key
+    ((r6rs:exception)
+     (let ((display-exception
+            (module-ref (resolve-module '(system repl error-handling r6rs))
+                        'display-exception)))
+       (call-with-output-string
+         (lambda (port)
+           (display-exception stack port (car args))))))
     (else
-     (format #f "Throw to key `~a' with args `~s'." key args))))
+     (pmatch args
+       ((,subr ,msg ,args . ,rest)
+        (guard (> (vector-length stack) 0))
+        (with-output-to-string
+          (lambda ()
+            (display-error (vector-ref stack 0) (current-output-port)
+                           subr msg args rest))))
+       (else
+        (format #f "Throw to key `~a' with args `~s'." key args))))))
 
 (define* (call-with-error-handling thunk #:key
                                    (on-error 'debug) (post-error 'catch)
diff --git a/module/system/repl/error-handling/r6rs.scm b/module/system/repl/error-handling/r6rs.scm
new file mode 100644
index 0000000..200fead
--- /dev/null
+++ b/module/system/repl/error-handling/r6rs.scm
@@ -0,0 +1,93 @@
+;;; REPL error handling support for R6RS
+
+;; Copyright (C) 2010 Free Software Foundation, Inc.
+
+;; This program 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 program 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 General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Code:
+
+(define-module (system repl error-handling r6rs)
+  #:export (display-exception)
+  #:use-module ((rnrs control) #:select (when unless))
+  #:use-module (rnrs records procedural)
+  #:use-module (rnrs records inspection)
+  #:use-module (rnrs conditions))
+
+(define raise-object-wrapper-obj
+    (@@ (rnrs records procedural) raise-object-wrapper-obj))
+
+(define (display-exception stack port wrapper)
+  (let ((obj (raise-object-wrapper-obj wrapper))
+        (frame (and (< 0 (vector-length stack)) (vector-ref stack 0))))
+    (cond ((condition? obj)
+           (display-error frame port #f
+                          "R6RS exception:\n~a"
+                          (list (call-with-output-string
+                                  (lambda (port)
+                                    (format-condition port obj))))
+                          '()))
+          (else
+           (display-error frame port #f
+                          "R6RS exception: `~s'" (list obj) '())))))
+
+(define (format-condition port condition)
+  (let ((components (simple-conditions condition)))
+    (if (null? components)
+        (format port "Empty condition object")
+        (let loop ((i 1) (components components))
+          (cond ((pair? components)
+                 (format port "  ~a. " i)
+                 (format-simple-condition port (car components))
+                 (when (pair? (cdr components))
+                   (newline port))
+                 (loop (+ i 1) (cdr components))))))))
+
+(define (format-simple-condition port condition)
+  (define (print-rtd-fields rtd field-names)
+    (let ((n-fields (vector-length field-names)))
+      (do ((i 0 (+ i 1)))
+          ((>= i n-fields))
+        (format port "      ~a: ~s"
+                (vector-ref field-names i)
+                ((record-accessor rtd i) condition))
+        (unless (= i (- n-fields 1))
+          (newline port)))))
+  (let ((condition-name (record-type-name (record-rtd condition))))
+    (let loop ((rtd (record-rtd condition)) (rtd.fields-list '()) (n-fields 0))
+      (cond (rtd
+             (let ((field-names (record-type-field-names rtd)))
+               (loop (record-type-parent rtd)
+                     (cons (cons rtd field-names) rtd.fields-list)
+                     (+ n-fields (vector-length field-names)))))
+            (else
+             (let ((rtd.fields-list
+                    (filter (lambda (rtd.fields)
+                              (not (zero? (vector-length (cdr rtd.fields)))))
+                            (reverse rtd.fields-list))))
+               (case n-fields
+                 ((0) (format port "~a" condition-name))
+                 ((1) (format port "~a: ~s"
+                              condition-name
+                              ((record-accessor (caar rtd.fields-list) 0)
+                               condition)))
+                 (else
+                  (format port "~a:\n" condition-name)
+                  (let loop ((lst rtd.fields-list))
+                    (when (pair? lst)
+                      (let ((rtd.fields (car lst)))
+                        (print-rtd-fields (car rtd.fields) (cdr rtd.fields))
+                        (when (pair? (cdr lst))
+                          (newline port))
+                        (loop (cdr lst)))))))))))))
+
-- 
tg: (fe15364..) t/r6rs-exception-print (depends on: master)

[-- Attachment #3: Type: text/plain, Size: 63 bytes --]


Regards, Rotty
-- 
Andreas Rottmann -- <http://rotty.yi.org/>

^ permalink raw reply related	[flat|nested] 13+ messages in thread

end of thread, other threads:[~2010-12-13 16:49 UTC | newest]

Thread overview: 13+ messages (download: mbox.gz follow: Atom feed
-- links below jump to the message on this page --
2010-10-24 21:46 R6RS exception printing at the REPL Andreas Rottmann
2010-11-20 15:23 ` Andy Wingo
2010-11-20 18:18   ` Andreas Rottmann
2010-11-20 20:19     ` Andy Wingo
2010-11-27  0:08       ` Andreas Rottmann
2010-11-29 20:15         ` @ and @@ in r6rs libs [Was: R6RS exception printing at the REPL] Andy Wingo
2010-11-29 22:35           ` Andreas Rottmann
2010-11-29 20:34         ` R6RS exception printing at the REPL Andy Wingo
2010-11-29 23:20           ` Andreas Rottmann
2010-12-01 23:16             ` Ludovic Courtès
2010-12-01 23:13           ` Ludovic Courtès
2010-12-02 20:21             ` Andreas Rottmann
2010-12-13 16:49               ` Ludovic Courtès

This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).