* Re: R6RS exception printing -- take #2
2011-02-01 20:06 ` Andy Wingo
@ 2011-02-06 18:09 ` Andreas Rottmann
2011-02-11 15:08 ` Andy Wingo
2011-02-07 12:07 ` [PATCH] " Andreas Rottmann
1 sibling, 1 reply; 6+ messages in thread
From: Andreas Rottmann @ 2011-02-06 18:09 UTC (permalink / raw)
To: Andy Wingo; +Cc: Guile Development
Andy Wingo <wingo@pobox.com> writes:
> Heya Andreas,
>
Hi! I've attached an updated patch; see below for some points that are
still to be discussed. If this patch is deemed OK, I'll work on
converting all relevant sites in the REPL to use `print-exception'.
> You proposed a choice between two options:
>
> On Tue 01 Feb 2011 01:19, Andreas Rottmann <a.rottmann@gmx.at> writes:
>
>> exception-printer := port key args exception-printer -> nothing
>> exception-printer := port args thunk
>
> The `key' argument is necessary, at least if you want one printer to
> handle multiple keys (as the default printer might). I prefer the
> first, FWIW.
>
OK, I've now done this:
exception-printer := port key args thunk -> nothing
The rationale of passing in a thunk instead of an exception printer is
that, to invoke the exception printer passed as last argument, the
procedure would have to pass a fallback printer to *that* printer, which
it can't do, as it doesn't know what that should be. Additionally, the
fallback printer has to be a closure anyway, as it needs access to the
`frame' argument passed to `print-exception' (see below).
>> This exception registry would be used in the REPL error-handling code
>> primarily, via a `print-exception' procedure querying the registry and
>> invoking the matching printer (or the default one, if no printer is
>> matching).
>
> There are other cases that it would be nice to use it: in the catch-all
> in throw.c, and in general when printing exceptions from C.
>
I'll defer looking into that; I'll first make a follow-up patch dealing
with the call sites inside the REPL code.
>> Another open issue is the potential `frame' argument; it seems this is
>> only used at one place in `(system repl error-handling)', inside
>> `call-with-error-handling' (I did a quick grep for "display-error" and
>> "Throw to" to identify the sites where I'd plug in the exception
>> registry via the `print-exception' procedure).
>>
>> If we decide that `frame' should not be part of the exception-printer
>> arguments, we'd lose source information in the exception printout in
>> this case.
>
> Let's keep the frame out of the exception-printer functions, but still
> pass it to the procedure that does the exception printing dispatch
> (perhaps called print-exception or something). That way we can print
> source information, then let exception printers do their thing.
>
The source info printing is now done only in the fallback printer, and
only on "regular match" exceptions (i.e. those that have the
conventional `args' structure). This is the same behavior as without
the patch. However, I think it would be more consistent to always print
source information if available; this would entail:
- Duplicating the source-information-printing logic of `display-error' in
`print-exception'.
- Always call `display-error' with #f as `frame', or perhaps stop
calling `display-error' and just print the exception ourselves.
What do you think?
>> [ Just a thought: it looks like it /might/ make sense to contemplate
>> deprecating passing the frame information to `display-error' and
>> untangle displaying the exception object and displaying a backtrace
>> completely. ]
>
> There are certainly some tangles here. If you find The Right Thing, let
> us know...
>
If we decide to do the source-information printing inside
`print-exception' (as proposed above), we might think about deprecating
`display-error' in favor of `print-exception'. Unfortunatly,
`display-error' cannot be implemented in terms of `print-exception', as
the former is missing the `key' argument that the latter requires.
Regards, Rotty
--
Andreas Rottmann -- <http://rotty.yi.org/>
^ permalink raw reply [flat|nested] 6+ messages in thread
* [PATCH] R6RS exception printing -- take #2
2011-02-01 20:06 ` Andy Wingo
2011-02-06 18:09 ` Andreas Rottmann
@ 2011-02-07 12:07 ` Andreas Rottmann
1 sibling, 0 replies; 6+ messages in thread
From: Andreas Rottmann @ 2011-02-07 12:07 UTC (permalink / raw)
To: Andy Wingo; +Cc: Guile Development
[-- Attachment #1: Type: text/plain, Size: 169 bytes --]
Andy Wingo <wingo@pobox.com> writes:
> Heya Andreas,
>
> You proposed a choice between two options:
>
[...]
I forgot to attach the patch in my last mail, here it is:
[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: r6rs-exception-print.diff --]
[-- Type: text/x-diff, Size: 9581 bytes --]
From: Andreas Rottmann <a.rottmann@gmx.at>
Subject: Show R6RS exceptions in a reasonable way in the debugger
* module/ice-9/boot-9.scm (exception-printer, set-exception-printer!):
New procedures, implementing the exception printer registry.
* module/system/repl/error-handling.scm (error-string): Replaced with
`print-exception' procedure which makes use of the exception printer
registry. Call sites adjusted.
* module/rnrs/exceptions.scm (exception-printer, format-condition,
format-simple-condition): New procedures implementing an exception
printer for R6RS exceptions. Register the exception printer for the
`r6rs:exception' key.
---
module/ice-9/boot-9.scm | 15 ++++++
module/rnrs/exceptions.scm | 83 ++++++++++++++++++++++++++++++++-
module/system/repl/error-handling.scm | 50 +++++++++++---------
3 files changed, 123 insertions(+), 25 deletions(-)
diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm
index 29e2cd7..23b3123 100644
--- a/module/ice-9/boot-9.scm
+++ b/module/ice-9/boot-9.scm
@@ -197,6 +197,21 @@ If there is no handler at all, Guile prints an error and then exits."
(apply (exception-handler) key args)))))
+;; Procedures for looking up and registering exception printers. Hide
+;; the shared state in a lexical contour. Note that this is a
+;; Guile-internal API, and should not be used outside of Guile itself.
+
+(define exception-printer #f)
+(define set-exception-printer! #f)
+
+(let ((exception-printers '()))
+ (set! exception-printer
+ (lambda (key)
+ (assq-ref exception-printers key)))
+ (set! set-exception-printer!
+ (lambda (key proc)
+ (set! exception-printers (acons key proc exception-printers)))))
+
\f
;;; {R4RS compliance}
diff --git a/module/rnrs/exceptions.scm b/module/rnrs/exceptions.scm
index ff4049b..95d01df 100644
--- a/module/rnrs/exceptions.scm
+++ b/module/rnrs/exceptions.scm
@@ -1,6 +1,6 @@
;;; exceptions.scm --- The R6RS exceptions library
-;; Copyright (C) 2010 Free Software Foundation, Inc.
+;; Copyright (C) 2010, 2011 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
@@ -20,9 +20,19 @@
(library (rnrs exceptions (6))
(export guard with-exception-handler raise raise-continuable)
(import (rnrs base (6))
+ (rnrs control (6))
(rnrs conditions (6))
(rnrs records procedural (6))
- (only (guile) with-throw-handler *unspecified* @@))
+ (rnrs records inspection (6))
+ (only (guile)
+ format
+ newline
+ display
+ filter
+ set-exception-printer!
+ with-throw-handler
+ *unspecified*
+ @@))
(define raise (@@ (rnrs records procedural) r6rs-raise))
(define raise-continuable
@@ -64,4 +74,73 @@
(guard0 (variable cond-clause ... (else else-clause ...)) . body))
((_ (variable cond-clause ...) . body)
(guard0 (variable cond-clause ... (else (raise variable))) . body))))
+
+ ;;; Exception printing
+
+ (define (exception-printer port key args punt)
+ (cond ((and (= 1 (length args))
+ (raise-object-wrapper? (car args)))
+ (let ((obj (raise-object-wrapper-obj (car args))))
+ (cond ((condition? obj)
+ (display "ERROR: R6RS exception:\n" port)
+ (format-condition port obj))
+ (else
+ (format port "ERROR: R6RS exception: `~s'" obj)))))
+ (else
+ (punt))))
+
+ (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)))))))))))))
+
+ (set-exception-printer! 'r6rs:exception exception-printer)
+
)
diff --git a/module/system/repl/error-handling.scm b/module/system/repl/error-handling.scm
index 7d30bf0..a875496 100644
--- a/module/system/repl/error-handling.scm
+++ b/module/system/repl/error-handling.scm
@@ -1,6 +1,6 @@
;;; Error handling in the REPL
-;; Copyright (C) 2001, 2009, 2010 Free Software Foundation, Inc.
+;; Copyright (C) 2001, 2009, 2010, 2011 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
@@ -33,16 +33,18 @@
;;; Error handling via repl debugging
;;;
-(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))))
- (else
- (format #f "Throw to key `~a' with args `~s'." key args))))
+(define (print-exception port frame key args)
+ (define (print-default)
+ (pmatch args
+ ((,subr ,msg ,args . ,rest)
+ (display-error frame port subr msg args rest))
+ (else
+ (format port "ERROR: Throw to key `~a' with args `~s'." key args))))
+ (cond ((exception-printer key)
+ => (lambda (printer)
+ (printer port key args print-default)))
+ (else
+ (print-default))))
(define* (call-with-error-handling thunk #:key
(on-error 'debug) (post-error 'catch)
@@ -107,17 +109,12 @@
(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)))
+ (with-saved-ports
+ (lambda ()
+ (run-hook before-error-hook)
+ (print-exception err #f key args)
+ (run-hook after-error-hook)
+ (force-output err)))
(if #f #f)))))
((catch)
(lambda (key . args)
@@ -145,7 +142,14 @@
;; And one more frame, because %start-stack invoking
;; the start-stack thunk has its own frame too.
0 (and tag 1)))
- (error-msg (error-string stack key args))
+ (error-msg
+ (call-with-output-string
+ (lambda (port)
+ (print-exception port
+ (and (< 0 (vector-length stack))
+ (vector-ref stack 0))
+ key
+ args))))
(debug (make-debug stack 0 error-msg #f)))
(with-saved-ports
(lambda ()
--
tg: (9d427b2..) t/r6rs-exception-print (depends on: master)
[-- Attachment #3: Type: text/plain, Size: 48 bytes --]
--
Andreas Rottmann -- <http://rotty.yi.org/>
^ permalink raw reply related [flat|nested] 6+ messages in thread