summaryrefslogtreecommitdiff
path: root/module/rnrs
diff options
context:
space:
mode:
authorAndreas Rottmann <a.rottmann@gmx.at>2011-02-11 16:07:14 +0100
committerAndy Wingo <wingo@pobox.com>2011-02-11 16:07:44 +0100
commit32b63129529f267b8f6f3f97f020b7e8ae51b9c1 (patch)
treeb831f1d5d6fc251b958bb505833a2c4a874a5400 /module/rnrs
parent39d41afe18846ac9137d1190032994d66112e48b (diff)
downloadguile-32b63129529f267b8f6f3f97f020b7e8ae51b9c1.tar.gz
install r6rs exception printer
* module/rnrs/exceptions.scm: Install an exception printer for R6RS exceptions.
Diffstat (limited to 'module/rnrs')
-rw-r--r--module/rnrs/exceptions.scm83
1 files changed, 81 insertions, 2 deletions
diff --git a/module/rnrs/exceptions.scm b/module/rnrs/exceptions.scm
index ff4049ba0..95d01dfdc 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)
+
)