guile-commits
[Top][All Lists]
Advanced

[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



reply via email to

[Prev in Thread] Current Thread [Next in Thread]