Changes from arch/CVS synchronization

diff --git a/srfi/ChangeLog b/srfi/ChangeLog
index 551c2fc..9f0e412 100644 (file)
--- a/srfi/ChangeLog
+++ b/srfi/ChangeLog
@@ -1,3 +1,10 @@
+2007-09-10  Ludovic Courtès  <ludo@gnu.org>
+
+       * srfi-35.scm (make-compound-condition-type): When PARENTS
+       contains only one element, return its car.  This improves the
+       output of `print-condition' for non-compound conditions returned
+       by `make-compound-condition'.
+
 2007-08-11  Ludovic Courtès  <ludo@gnu.org>
 
        * srfi-35.scm: New file.

diff --git a/srfi/srfi-35.scm b/srfi/srfi-35.scm
index 655344b..c9e25ce 100644 (file)
--- a/srfi/srfi-35.scm
+++ b/srfi/srfi-35.scm
@@ -115,16 +115,22 @@ supertypes."
   ;; Return a compound condition type made of the types listed in PARENTS.
   ;; All fields from PARENTS are kept, even same-named ones, since they are
   ;; needed by `extract-condition'.
-  (let* ((all-fields (append-map condition-type-all-fields
-                                parents))
-        (layout     (struct-layout-for-condition all-fields)))
-    (make-struct %condition-type-vtable 0
-                (make-struct-layout layout) ;; layout
-                print-condition             ;; printer
-                id
-                parents                     ;; list of parents!
-                all-fields
-                all-fields)))
+  (cond ((null? parents)
+         (error "`make-compound-condition-type' passed empty parent list"
+                id))
+        ((null? (cdr parents))
+         (car parents))
+        (else
+         (let* ((all-fields (append-map condition-type-all-fields
+                                        parents))
+                (layout     (struct-layout-for-condition all-fields)))
+           (make-struct %condition-type-vtable 0
+                        (make-struct-layout layout) ;; layout
+                        print-condition             ;; printer
+                        id
+                        parents                     ;; list of parents!
+                        all-fields
+                        all-fields)))))
 
 \f
 ;;;