summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorJulian Graham <julian.graham@aya.yale.edu>2010-06-18 09:49:30 -0400
committerJulian Graham <julian.graham@aya.yale.edu>2010-06-18 09:49:30 -0400
commit00f79aa4a0953f2f7348aa20f09b34fda257df32 (patch)
treec7ed50479d8cc10f1dd020ec1ee0331967c2622e
parent5827e220abac373645e637ece99a9c6550c96bf0 (diff)
downloadguile-00f79aa4a0953f2f7348aa20f09b34fda257df32.tar.gz
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.
-rw-r--r--module/rnrs/conditions.scm9
-rw-r--r--test-suite/tests/r6rs-conditions.test8
2 files changed, 15 insertions, 2 deletions
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)))))