From: Andreas Rottmann <a.rottmann@gmx.at>
To: Guile Development <guile-devel@gnu.org>
Subject: R6RS exception printing at the REPL
Date: Sun, 24 Oct 2010 23:46:17 +0200 [thread overview]
Message-ID: <87sjzvnu1i.fsf@delenn.lan> (raw)
[-- 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/>
next reply other threads:[~2010-10-24 21:46 UTC|newest]
Thread overview: 13+ messages / expand[flat|nested] mbox.gz Atom feed top
2010-10-24 21:46 Andreas Rottmann [this message]
2010-11-20 15:23 ` R6RS exception printing at the REPL 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
Reply instructions:
You may reply publicly to this message via plain-text email
using any one of the following methods:
* Save the following mbox file, import it into your mail client,
and reply-to-all from there: mbox
Avoid top-posting and favor interleaved quoting:
https://en.wikipedia.org/wiki/Posting_style#Interleaved_style
List information: https://www.gnu.org/software/guile/
* Reply using the --to, --cc, and --in-reply-to
switches of git-send-email(1):
git send-email \
--in-reply-to=87sjzvnu1i.fsf@delenn.lan \
--to=a.rottmann@gmx.at \
--cc=guile-devel@gnu.org \
/path/to/YOUR_REPLY
https://kernel.org/pub/software/scm/git/docs/git-send-email.html
* If your mail client supports setting the In-Reply-To header
via mailto: links, try the mailto: link
Be sure your reply has a Subject: header at the top and a blank line
before the message body.
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).