diff options
author | Andreas Rottmann <a.rottmann@gmx.at> | 2011-02-11 16:07:14 +0100 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2011-02-11 16:07:44 +0100 |
commit | 32b63129529f267b8f6f3f97f020b7e8ae51b9c1 (patch) | |
tree | b831f1d5d6fc251b958bb505833a2c4a874a5400 /module/rnrs | |
parent | 39d41afe18846ac9137d1190032994d66112e48b (diff) | |
download | guile-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.scm | 83 |
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) + ) |