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:
parent
5827e220ab
commit
00f79aa4a0
2 changed files with 15 additions and 2 deletions
|
@ -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
|
||||||
|
|
|
@ -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)))))
|
||||||
|
|
Loading…
Add table
Add a link
Reference in a new issue