From: Julian Graham <julian.graham@aya.yale.edu>
Date: Fri, 18 Jun 2010 13:49:30 +0000 (-0400)
Subject: Fix `define-condition-type' to use condition-accessors, not record
X-Git-Url: https://git.hcoop.net/bpt/guile.git/commitdiff_plain/00f79aa4a0953f2f7348aa20f09b34fda257df32

Fix `define-condition-type' to use condition-accessors, not record
accessors.

* module/rnrs/conditions.scm (define-condition-type): The generated
  accessors should be condition accessors, which know how to unpack a
  compound condition; these can then delegate to the appropriate record
  accessors.
* test-suite/tests/r6rs-conditions.test: New test case to verify above.
---

diff --git a/module/rnrs/conditions.scm b/module/rnrs/conditions.scm
index 9c6539fef..53d4d0f6c 100644
--- a/module/rnrs/conditions.scm
+++ b/module/rnrs/conditions.scm
@@ -126,10 +126,15 @@
 	    (generate-accessors
 	     (syntax-rules ()
 	       ((_ counter (f a) . rest)
-		(begin (define a (record-accessor condition-type counter))
+		(begin (define a 
+                         (condition-accessor 
+                          condition-type
+                          (record-accessor condition-type counter)))
 		       (generate-accessors (+ counter 1) rest)))
 	       ((_ counter ((f a)))
-		(define a (record-accessor condition-type counter)))
+		(define a 
+                  (condition-accessor 
+                   condition-type (record-accessor condition-type counter))))
 	       ((_ counter ()) (begin))
 	       ((_ counter) (begin)))))	 
 	 (begin
diff --git a/test-suite/tests/r6rs-conditions.test b/test-suite/tests/r6rs-conditions.test
index 5883131ca..9432f378f 100644
--- a/test-suite/tests/r6rs-conditions.test
+++ b/test-suite/tests/r6rs-conditions.test
@@ -21,6 +21,9 @@
   :use-module ((rnrs conditions) :version (6))
   :use-module (test-suite lib))
 
+(define-condition-type &a &condition make-a-condition a-condition? (foo a-foo))
+(define-condition-type &b &condition make-b-condition b-condition? (bar b-bar))
+
 (with-test-prefix "condition?"
   (pass-if "condition? is #t for simple conditions"
     (condition? (make-error)))
@@ -89,3 +92,8 @@
 	   (vc (make-violation))
 	   (c (condition vc mc)))
       (equal? (ma c) "foo"))))
+
+(with-test-prefix "define-condition-type"
+  (pass-if "define-condition-type produces proper accessors"
+    (let ((c (condition (make-a-condition 'foo) (make-b-condition 'bar))))
+      (and (eq? (a-foo c) 'foo) (eq? (b-bar c) 'bar)))))