1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-08 22:42:26 +02:00

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.
This commit is contained in:
Julian Graham 2010-06-18 09:49:30 -04:00
parent 5827e220ab
commit 00f79aa4a0
2 changed files with 15 additions and 2 deletions

View file

@ -126,10 +126,15 @@
(generate-accessors (generate-accessors
(syntax-rules () (syntax-rules ()
((_ counter (f a) . rest) ((_ 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))) (generate-accessors (+ counter 1) rest)))
((_ counter ((f a))) ((_ 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))
((_ counter) (begin))))) ((_ counter) (begin)))))
(begin (begin

View file

@ -21,6 +21,9 @@
:use-module ((rnrs conditions) :version (6)) :use-module ((rnrs conditions) :version (6))
:use-module (test-suite lib)) :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?" (with-test-prefix "condition?"
(pass-if "condition? is #t for simple conditions" (pass-if "condition? is #t for simple conditions"
(condition? (make-error))) (condition? (make-error)))
@ -89,3 +92,8 @@
(vc (make-violation)) (vc (make-violation))
(c (condition vc mc))) (c (condition vc mc)))
(equal? (ma c) "foo")))) (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)))))