[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] GNU Guile branch, master, updated. release_1-9-15-58-g32
From: |
Andy Wingo |
Subject: |
[Guile-commits] GNU Guile branch, master, updated. release_1-9-15-58-g32b6312 |
Date: |
Fri, 11 Feb 2011 15:03:05 +0000 |
This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".
http://git.savannah.gnu.org/cgit/guile.git/commit/?id=32b63129529f267b8f6f3f97f020b7e8ae51b9c1
The branch, master has been updated
via 32b63129529f267b8f6f3f97f020b7e8ae51b9c1 (commit)
from 39d41afe18846ac9137d1190032994d66112e48b (commit)
Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.
- Log -----------------------------------------------------------------
commit 32b63129529f267b8f6f3f97f020b7e8ae51b9c1
Author: Andreas Rottmann <address@hidden>
Date: Fri Feb 11 16:07:14 2011 +0100
install r6rs exception printer
* module/rnrs/exceptions.scm: Install an exception printer for R6RS
exceptions.
-----------------------------------------------------------------------
Summary of changes:
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 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)
+
)
hooks/post-receive
--
GNU Guile
[Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, master, updated. release_1-9-15-58-g32b6312,
Andy Wingo <=