Andy Wingo <wi...@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:
From: Andreas Rottmann <a.rottm...@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)))))
+
;;; {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)
--
Andreas Rottmann -- <http://rotty.yi.org/>
