diff options
author | Julian Graham <julian.graham@aya.yale.edu> | 2010-06-18 09:49:30 -0400 |
---|---|---|
committer | Julian Graham <julian.graham@aya.yale.edu> | 2010-06-18 09:49:30 -0400 |
commit | 00f79aa4a0953f2f7348aa20f09b34fda257df32 (patch) | |
tree | c7ed50479d8cc10f1dd020ec1ee0331967c2622e | |
parent | 5827e220abac373645e637ece99a9c6550c96bf0 (diff) | |
download | guile-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.scm | 9 | ||||
-rw-r--r-- | test-suite/tests/r6rs-conditions.test | 8 |
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))))) |