* [PATCH] Some tweaks to the R6RS support
@ 2010-10-26 22:53 Andreas Rottmann
2010-11-20 15:38 ` Andy Wingo
0 siblings, 1 reply; 4+ messages in thread
From: Andreas Rottmann @ 2010-10-26 22:53 UTC (permalink / raw)
To: Guile Development
[-- Attachment #1: Type: text/plain, Size: 882 bytes --]
* module/rnrs/base.scm (error, assert): Define -- they were missing.
(assertion-violation): Properly treat a #f `who' argument.
* module/rnrs/conditions.scm (condition): Use `assertion-violation'
instead of the undefined `raise'.
(define-condition-type): Fix for multiple fields.
* test-suite/tests/r6rs-conditions.test: Test accessors of a
multiple-field condition. Also import `(rnrs base)' to allow
stand-alone running of the tests; apparently the `@' references
scattered throughout the R6RS modules make the libraries sensitive to
their load order -- for instance, trying to load `(rnrs conditions)'
before `(rnrs base)' is loaded fails.
* module/rnrs/records/inspection.scm: Use `assertion-violation' instead
of an explicit `raise'.
* module/rnrs/records/syntactic.scm (process-fields): Use
`syntax-violation' instead of bogus invocations of `error'.
[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: rnrs-tweaks.diff --]
[-- Type: text/x-diff, Size: 10048 bytes --]
From: Andreas Rottmann <a.rottmann@gmx.at>
Subject: Some tweaks to the R6RS support
* module/rnrs/base.scm (error, assert): Define -- they were missing.
(assertion-violation): Properly treat a #f `who' argument.
* module/rnrs/conditions.scm (condition): Use `assertion-violation'
instead of the undefined `raise'.
(define-condition-type): Fix for multiple fields.
* test-suite/tests/r6rs-conditions.test: Test accessors of a
multiple-field condition. Also import `(rnrs base)' to allow
stand-alone running of the tests; apparently the `@' references
scattered throughout the R6RS modules make the libraries sensitive to
their load order -- for instance, trying to load `(rnrs conditions)'
before `(rnrs base)' is loaded fails.
* module/rnrs/records/inspection.scm: Use `assertion-violation' instead
of an explicit `raise'.
* module/rnrs/records/syntactic.scm (process-fields): Use
`syntax-violation' instead of bogus invocations of `error'.
---
module/rnrs/base.scm | 31 +++++++++++++++++++++++++------
module/rnrs/conditions.scm | 15 ++++-----------
module/rnrs/records/inspection.scm | 30 ++++++++++++++++--------------
module/rnrs/records/syntactic.scm | 10 ++++++----
test-suite/tests/r6rs-conditions.test | 14 +++++++++++++-
5 files changed, 64 insertions(+), 36 deletions(-)
diff --git a/module/rnrs/base.scm b/module/rnrs/base.scm
index 74fce31..2357032 100644
--- a/module/rnrs/base.scm
+++ b/module/rnrs/base.scm
@@ -71,7 +71,8 @@
let-syntax letrec-syntax
syntax-rules identifier-syntax)
- (import (rename (guile) (quotient div) (modulo mod))
+ (import (rename (except (guile) error raise)
+ (quotient div) (modulo mod))
(srfi srfi-11))
(define (vector-for-each proc . vecs)
@@ -98,6 +99,8 @@
(@ (rnrs exceptions) raise))
(define condition
(@ (rnrs conditions) condition))
+ (define make-error
+ (@ (rnrs conditions) make-error))
(define make-assertion-violation
(@ (rnrs conditions) make-assertion-violation))
(define make-who-condition
@@ -106,12 +109,28 @@
(@ (rnrs conditions) make-message-condition))
(define make-irritants-condition
(@ (rnrs conditions) make-irritants-condition))
+
+ (define (error who message . irritants)
+ (raise (apply condition
+ (append (list (make-error))
+ (if who (list (make-who-condition who)) '())
+ (list (make-message-condition message)
+ (make-irritants-condition irritants))))))
(define (assertion-violation who message . irritants)
- (raise (condition
- (make-assertion-violation)
- (make-who-condition who)
- (make-message-condition message)
- (make-irritants-condition irritants))))
+ (raise (apply condition
+ (append (list (make-assertion-violation))
+ (if who (list (make-who-condition who)) '())
+ (list (make-message-condition message)
+ (make-irritants-condition irritants))))))
+
+ (define-syntax assert
+ (syntax-rules ()
+ ((_ expression)
+ (if (not expression)
+ (raise (condition
+ (make-assertion-violation)
+ (make-message-condition
+ (format #f "assertion failed: ~s" 'expression))))))))
)
diff --git a/module/rnrs/conditions.scm b/module/rnrs/conditions.scm
index b897221..3fc1b85 100644
--- a/module/rnrs/conditions.scm
+++ b/module/rnrs/conditions.scm
@@ -115,7 +115,7 @@
(define (flatten cond)
(if (compound-condition? cond) (simple-conditions cond) (list cond)))
(or (for-all condition? conditions)
- (raise (make-assertion-violation)))
+ (assertion-violation 'condition "non-condition argument" conditions))
(if (or (null? conditions) (> (length conditions) 1))
(make-compound-condition (apply append (map flatten conditions)))
(car conditions))))
@@ -128,9 +128,7 @@
((transform-fields
(syntax-rules ()
((_ (f a) . rest)
- (cons '(immutable f a) (transform-fields rest)))
- ((_ ((f a))) '((immutable f a)))
- ((_ ()) '())
+ (cons '(immutable f a) (transform-fields . rest)))
((_) '())))
(generate-accessors
@@ -140,13 +138,8 @@
(condition-accessor
condition-type
(record-accessor condition-type counter)))
- (generate-accessors (+ counter 1) rest)))
- ((_ counter ((f a)))
- (define a
- (condition-accessor
- condition-type (record-accessor condition-type counter))))
- ((_ counter ()) (begin))
- ((_ counter) (begin)))))
+ (generate-accessors (+ counter 1) . rest)))
+ ((_ counter) (begin)))))
(begin
(define condition-type
(make-record-type-descriptor
diff --git a/module/rnrs/records/inspection.scm b/module/rnrs/records/inspection.scm
index 315ef0c..68b78a9 100644
--- a/module/rnrs/records/inspection.scm
+++ b/module/rnrs/records/inspection.scm
@@ -30,8 +30,6 @@
record-field-mutable?)
(import (rnrs arithmetic bitwise (6))
(rnrs base (6))
- (rnrs conditions (6))
- (rnrs exceptions (6))
(rnrs records procedural (6))
(only (guile) struct-ref struct-vtable vtable-index-layout @@))
@@ -55,25 +53,29 @@
(or (and (record-internal? record)
(let ((rtd (struct-vtable record)))
(and (not (struct-ref rtd rtd-index-opaque?)) rtd)))
- (raise (make-assertion-violation))))
+ (assertion-violation 'record-rtd "not a record" record)))
- (define (ensure-rtd rtd)
- (if (not (record-type-descriptor? rtd)) (raise (make-assertion-violation))))
+ (define (guarantee-rtd who rtd)
+ (if (record-type-descriptor? rtd)
+ rtd
+ (assertion-violation who "not a record type descriptor" rtd)))
(define (record-type-name rtd)
- (ensure-rtd rtd) (struct-ref rtd rtd-index-name))
+ (struct-ref (guarantee-rtd 'record-type-name rtd) rtd-index-name))
(define (record-type-parent rtd)
- (ensure-rtd rtd) (struct-ref rtd rtd-index-parent))
- (define (record-type-uid rtd) (ensure-rtd rtd) (struct-ref rtd rtd-index-uid))
+ (struct-ref (guarantee-rtd 'record-type-parent rtd) rtd-index-parent))
+ (define (record-type-uid rtd)
+ (struct-ref (guarantee-rtd 'record-type-uid rtd) rtd-index-uid))
(define (record-type-generative? rtd)
- (ensure-rtd rtd) (not (record-type-uid rtd)))
+ (not (record-type-uid (guarantee-rtd 'record-type-generative? rtd))))
(define (record-type-sealed? rtd)
- (ensure-rtd rtd) (struct-ref rtd rtd-index-sealed?))
+ (struct-ref (guarantee-rtd 'record-type-sealed? rtd) rtd-index-sealed?))
(define (record-type-opaque? rtd)
- (ensure-rtd rtd) (struct-ref rtd rtd-index-opaque?))
+ (struct-ref (guarantee-rtd 'record-type-opaque? rtd) rtd-index-opaque?))
(define (record-type-field-names rtd)
- (ensure-rtd rtd) (struct-ref rtd rtd-index-field-names))
+ (struct-ref (guarantee-rtd 'record-type-field-names rtd) rtd-index-field-names))
(define (record-field-mutable? rtd k)
- (ensure-rtd rtd)
- (bitwise-bit-set? (struct-ref rtd rtd-index-field-bit-field) k))
+ (bitwise-bit-set? (struct-ref (guarantee-rtd 'record-field-mutable? rtd)
+ rtd-index-field-bit-field)
+ k))
)
diff --git a/module/rnrs/records/syntactic.scm b/module/rnrs/records/syntactic.scm
index 5070212..6431fcf 100644
--- a/module/rnrs/records/syntactic.scm
+++ b/module/rnrs/records/syntactic.scm
@@ -85,14 +85,16 @@
record-name-str "-" (symbol->string field-name) "-set!")))
(define (f x)
+ (define (lose)
+ (syntax-violation 'define-record-type "invalid field specifier" x))
(cond ((symbol? x) (list 'immutable x (guess-accessor-name x) #f))
- ((not (list? x)) (error))
+ ((not (list? x)) (lose))
((eq? (car x) 'immutable)
(cons 'immutable
(case (length x)
((2) (list (cadr x) (guess-accessor-name (cadr x)) #f))
((3) (list (cadr x) (caddr x) #f))
- (else (error)))))
+ (else (lose)))))
((eq? (car x) 'mutable)
(cons 'mutable
(case (length x)
@@ -100,8 +102,8 @@
(guess-accessor-name (cadr x))
(guess-mutator-name (cadr x))))
((4) (cdr x))
- (else (error)))))
- (else (error))))
+ (else (lose)))))
+ (else (lose))))
(map f fields))
(define-syntax define-record-type0
diff --git a/test-suite/tests/r6rs-conditions.test b/test-suite/tests/r6rs-conditions.test
index 9432f37..7480b9c 100644
--- a/test-suite/tests/r6rs-conditions.test
+++ b/test-suite/tests/r6rs-conditions.test
@@ -18,11 +18,16 @@
\f
(define-module (test-suite test-rnrs-conditions)
+ :use-module ((rnrs base) :version (6))
: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))
+(define-condition-type &c &condition make-c-condition c-condition?
+ (baz c-baz)
+ (qux c-qux)
+ (frobotz c-frobotz))
(with-test-prefix "condition?"
(pass-if "condition? is #t for simple conditions"
@@ -96,4 +101,11 @@
(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)))))
+ (and (eq? (a-foo c) 'foo) (eq? (b-bar c) 'bar))))
+ (pass-if "define-condition-type works for multiple fields"
+ (let ((c (condition (make-a-condition 'foo)
+ (make-c-condition 1 2 3))))
+ (and (eq? (a-foo c) 'foo)
+ (= (c-baz c) 1)
+ (= (c-qux c) 2)
+ (= (c-frobotz c) 3)))))
--
tg: (fe15364..) t/rnrs-tweaks (depends on: master)
[-- Attachment #3: Type: text/plain, Size: 63 bytes --]
Regards, Rotty
--
Andreas Rottmann -- <http://rotty.yi.org/>
^ permalink raw reply related [flat|nested] 4+ messages in thread* Re: [PATCH] Some tweaks to the R6RS support
2010-10-26 22:53 [PATCH] Some tweaks to the R6RS support Andreas Rottmann
@ 2010-11-20 15:38 ` Andy Wingo
2010-11-20 18:09 ` Andreas Rottmann
0 siblings, 1 reply; 4+ messages in thread
From: Andy Wingo @ 2010-11-20 15:38 UTC (permalink / raw)
To: Andreas Rottmann; +Cc: Guile Development
Hi Andreas,
On Wed 27 Oct 2010 00:53, Andreas Rottmann <a.rottmann@gmx.at> writes:
> * module/rnrs/base.scm (error, assert): Define -- they were missing.
> (assertion-violation): Properly treat a #f `who' argument.
>
> * module/rnrs/conditions.scm (condition): Use `assertion-violation'
> instead of the undefined `raise'.
> (define-condition-type): Fix for multiple fields.
> * test-suite/tests/r6rs-conditions.test: Test accessors of a
> multiple-field condition. Also import `(rnrs base)' to allow
> stand-alone running of the tests; apparently the `@' references
> scattered throughout the R6RS modules make the libraries sensitive to
> their load order -- for instance, trying to load `(rnrs conditions)'
> before `(rnrs base)' is loaded fails.
>
> * module/rnrs/records/inspection.scm: Use `assertion-violation' instead
> of an explicit `raise'.
> * module/rnrs/records/syntactic.scm (process-fields): Use
> `syntax-violation' instead of bogus invocations of `error'.
This patch no longer applies. Apologies for the delay. Can you take a
look at which parts are still valid?
Thanks,
Andy
--
http://wingolog.org/
^ permalink raw reply [flat|nested] 4+ messages in thread
* Re: [PATCH] Some tweaks to the R6RS support
2010-11-20 15:38 ` Andy Wingo
@ 2010-11-20 18:09 ` Andreas Rottmann
2010-11-25 22:05 ` Andy Wingo
0 siblings, 1 reply; 4+ messages in thread
From: Andreas Rottmann @ 2010-11-20 18:09 UTC (permalink / raw)
To: Andy Wingo; +Cc: Guile Development
[-- Attachment #1: Type: text/plain, Size: 1273 bytes --]
Andy Wingo <wingo@pobox.com> writes:
> Hi Andreas,
>
> On Wed 27 Oct 2010 00:53, Andreas Rottmann <a.rottmann@gmx.at> writes:
>
>> * module/rnrs/base.scm (error, assert): Define -- they were missing.
>> (assertion-violation): Properly treat a #f `who' argument.
>>
>> * module/rnrs/conditions.scm (condition): Use `assertion-violation'
>> instead of the undefined `raise'.
>> (define-condition-type): Fix for multiple fields.
>> * test-suite/tests/r6rs-conditions.test: Test accessors of a
>> multiple-field condition. Also import `(rnrs base)' to allow
>> stand-alone running of the tests; apparently the `@' references
>> scattered throughout the R6RS modules make the libraries sensitive to
>> their load order -- for instance, trying to load `(rnrs conditions)'
>> before `(rnrs base)' is loaded fails.
>>
>> * module/rnrs/records/inspection.scm: Use `assertion-violation' instead
>> of an explicit `raise'.
>> * module/rnrs/records/syntactic.scm (process-fields): Use
>> `syntax-violation' instead of bogus invocations of `error'.
>
> This patch no longer applies. Apologies for the delay. Can you take a
> look at which parts are still valid?
>
It seems all of it is still relevant; I've attached a refreshed patch,
which should apply cleanly.
[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: rnrs-tweaks.diff --]
[-- Type: text/x-diff, Size: 10026 bytes --]
From: Andreas Rottmann <a.rottmann@gmx.at>
Subject: Some tweaks to the R6RS support
* module/rnrs/base.scm (error, assert): Define -- they were missing.
(assertion-violation): Properly treat a #f `who' argument.
* module/rnrs/conditions.scm (condition): Use `assertion-violation'
instead of the undefined `raise'.
(define-condition-type): Fix for multiple fields.
* test-suite/tests/r6rs-conditions.test: Test accessors of a
multiple-field condition. Also import `(rnrs base)' to allow
stand-alone running of the tests; apparently the `@' references
scattered throughout the R6RS modules make the libraries sensitive to
their load order -- for instance, trying to load `(rnrs conditions)'
before `(rnrs base)' is loaded fails.
* module/rnrs/records/inspection.scm: Use `assertion-violation' instead
of an explicit `raise'.
* module/rnrs/records/syntactic.scm (process-fields): Use
`syntax-violation' instead of bogus invocations of `error'.
---
module/rnrs/base.scm | 30 ++++++++++++++++++++++++------
module/rnrs/conditions.scm | 15 ++++-----------
module/rnrs/records/inspection.scm | 30 ++++++++++++++++--------------
module/rnrs/records/syntactic.scm | 10 ++++++----
test-suite/tests/r6rs-conditions.test | 14 +++++++++++++-
5 files changed, 63 insertions(+), 36 deletions(-)
diff --git a/module/rnrs/base.scm b/module/rnrs/base.scm
index 6320420..a6ae1b9 100644
--- a/module/rnrs/base.scm
+++ b/module/rnrs/base.scm
@@ -73,7 +73,7 @@
let-syntax letrec-syntax
syntax-rules identifier-syntax)
- (import (rename (guile)
+ (import (rename (except (guile) error raise)
(quotient div)
(modulo mod)
(exact->inexact inexact)
@@ -137,6 +137,8 @@
(@ (rnrs exceptions) raise))
(define condition
(@ (rnrs conditions) condition))
+ (define make-error
+ (@ (rnrs conditions) make-error))
(define make-assertion-violation
(@ (rnrs conditions) make-assertion-violation))
(define make-who-condition
@@ -145,12 +147,28 @@
(@ (rnrs conditions) make-message-condition))
(define make-irritants-condition
(@ (rnrs conditions) make-irritants-condition))
+
+ (define (error who message . irritants)
+ (raise (apply condition
+ (append (list (make-error))
+ (if who (list (make-who-condition who)) '())
+ (list (make-message-condition message)
+ (make-irritants-condition irritants))))))
(define (assertion-violation who message . irritants)
- (raise (condition
- (make-assertion-violation)
- (make-who-condition who)
- (make-message-condition message)
- (make-irritants-condition irritants))))
+ (raise (apply condition
+ (append (list (make-assertion-violation))
+ (if who (list (make-who-condition who)) '())
+ (list (make-message-condition message)
+ (make-irritants-condition irritants))))))
+
+ (define-syntax assert
+ (syntax-rules ()
+ ((_ expression)
+ (if (not expression)
+ (raise (condition
+ (make-assertion-violation)
+ (make-message-condition
+ (format #f "assertion failed: ~s" 'expression))))))))
)
diff --git a/module/rnrs/conditions.scm b/module/rnrs/conditions.scm
index b897221..3fc1b85 100644
--- a/module/rnrs/conditions.scm
+++ b/module/rnrs/conditions.scm
@@ -115,7 +115,7 @@
(define (flatten cond)
(if (compound-condition? cond) (simple-conditions cond) (list cond)))
(or (for-all condition? conditions)
- (raise (make-assertion-violation)))
+ (assertion-violation 'condition "non-condition argument" conditions))
(if (or (null? conditions) (> (length conditions) 1))
(make-compound-condition (apply append (map flatten conditions)))
(car conditions))))
@@ -128,9 +128,7 @@
((transform-fields
(syntax-rules ()
((_ (f a) . rest)
- (cons '(immutable f a) (transform-fields rest)))
- ((_ ((f a))) '((immutable f a)))
- ((_ ()) '())
+ (cons '(immutable f a) (transform-fields . rest)))
((_) '())))
(generate-accessors
@@ -140,13 +138,8 @@
(condition-accessor
condition-type
(record-accessor condition-type counter)))
- (generate-accessors (+ counter 1) rest)))
- ((_ counter ((f a)))
- (define a
- (condition-accessor
- condition-type (record-accessor condition-type counter))))
- ((_ counter ()) (begin))
- ((_ counter) (begin)))))
+ (generate-accessors (+ counter 1) . rest)))
+ ((_ counter) (begin)))))
(begin
(define condition-type
(make-record-type-descriptor
diff --git a/module/rnrs/records/inspection.scm b/module/rnrs/records/inspection.scm
index 315ef0c..68b78a9 100644
--- a/module/rnrs/records/inspection.scm
+++ b/module/rnrs/records/inspection.scm
@@ -30,8 +30,6 @@
record-field-mutable?)
(import (rnrs arithmetic bitwise (6))
(rnrs base (6))
- (rnrs conditions (6))
- (rnrs exceptions (6))
(rnrs records procedural (6))
(only (guile) struct-ref struct-vtable vtable-index-layout @@))
@@ -55,25 +53,29 @@
(or (and (record-internal? record)
(let ((rtd (struct-vtable record)))
(and (not (struct-ref rtd rtd-index-opaque?)) rtd)))
- (raise (make-assertion-violation))))
+ (assertion-violation 'record-rtd "not a record" record)))
- (define (ensure-rtd rtd)
- (if (not (record-type-descriptor? rtd)) (raise (make-assertion-violation))))
+ (define (guarantee-rtd who rtd)
+ (if (record-type-descriptor? rtd)
+ rtd
+ (assertion-violation who "not a record type descriptor" rtd)))
(define (record-type-name rtd)
- (ensure-rtd rtd) (struct-ref rtd rtd-index-name))
+ (struct-ref (guarantee-rtd 'record-type-name rtd) rtd-index-name))
(define (record-type-parent rtd)
- (ensure-rtd rtd) (struct-ref rtd rtd-index-parent))
- (define (record-type-uid rtd) (ensure-rtd rtd) (struct-ref rtd rtd-index-uid))
+ (struct-ref (guarantee-rtd 'record-type-parent rtd) rtd-index-parent))
+ (define (record-type-uid rtd)
+ (struct-ref (guarantee-rtd 'record-type-uid rtd) rtd-index-uid))
(define (record-type-generative? rtd)
- (ensure-rtd rtd) (not (record-type-uid rtd)))
+ (not (record-type-uid (guarantee-rtd 'record-type-generative? rtd))))
(define (record-type-sealed? rtd)
- (ensure-rtd rtd) (struct-ref rtd rtd-index-sealed?))
+ (struct-ref (guarantee-rtd 'record-type-sealed? rtd) rtd-index-sealed?))
(define (record-type-opaque? rtd)
- (ensure-rtd rtd) (struct-ref rtd rtd-index-opaque?))
+ (struct-ref (guarantee-rtd 'record-type-opaque? rtd) rtd-index-opaque?))
(define (record-type-field-names rtd)
- (ensure-rtd rtd) (struct-ref rtd rtd-index-field-names))
+ (struct-ref (guarantee-rtd 'record-type-field-names rtd) rtd-index-field-names))
(define (record-field-mutable? rtd k)
- (ensure-rtd rtd)
- (bitwise-bit-set? (struct-ref rtd rtd-index-field-bit-field) k))
+ (bitwise-bit-set? (struct-ref (guarantee-rtd 'record-field-mutable? rtd)
+ rtd-index-field-bit-field)
+ k))
)
diff --git a/module/rnrs/records/syntactic.scm b/module/rnrs/records/syntactic.scm
index 5070212..6431fcf 100644
--- a/module/rnrs/records/syntactic.scm
+++ b/module/rnrs/records/syntactic.scm
@@ -85,14 +85,16 @@
record-name-str "-" (symbol->string field-name) "-set!")))
(define (f x)
+ (define (lose)
+ (syntax-violation 'define-record-type "invalid field specifier" x))
(cond ((symbol? x) (list 'immutable x (guess-accessor-name x) #f))
- ((not (list? x)) (error))
+ ((not (list? x)) (lose))
((eq? (car x) 'immutable)
(cons 'immutable
(case (length x)
((2) (list (cadr x) (guess-accessor-name (cadr x)) #f))
((3) (list (cadr x) (caddr x) #f))
- (else (error)))))
+ (else (lose)))))
((eq? (car x) 'mutable)
(cons 'mutable
(case (length x)
@@ -100,8 +102,8 @@
(guess-accessor-name (cadr x))
(guess-mutator-name (cadr x))))
((4) (cdr x))
- (else (error)))))
- (else (error))))
+ (else (lose)))))
+ (else (lose))))
(map f fields))
(define-syntax define-record-type0
diff --git a/test-suite/tests/r6rs-conditions.test b/test-suite/tests/r6rs-conditions.test
index 9432f37..7480b9c 100644
--- a/test-suite/tests/r6rs-conditions.test
+++ b/test-suite/tests/r6rs-conditions.test
@@ -18,11 +18,16 @@
\f
(define-module (test-suite test-rnrs-conditions)
+ :use-module ((rnrs base) :version (6))
: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))
+(define-condition-type &c &condition make-c-condition c-condition?
+ (baz c-baz)
+ (qux c-qux)
+ (frobotz c-frobotz))
(with-test-prefix "condition?"
(pass-if "condition? is #t for simple conditions"
@@ -96,4 +101,11 @@
(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)))))
+ (and (eq? (a-foo c) 'foo) (eq? (b-bar c) 'bar))))
+ (pass-if "define-condition-type works for multiple fields"
+ (let ((c (condition (make-a-condition 'foo)
+ (make-c-condition 1 2 3))))
+ (and (eq? (a-foo c) 'foo)
+ (= (c-baz c) 1)
+ (= (c-qux c) 2)
+ (= (c-frobotz c) 3)))))
--
tg: (1c20cf1..) t/rnrs-tweaks (depends on: master)
[-- Attachment #3: Type: text/plain, Size: 62 bytes --]
Cheers, Rotty
--
Andreas Rottmann -- <http://rotty.yi.org/>
^ permalink raw reply related [flat|nested] 4+ messages in thread
end of thread, other threads:[~2010-11-25 22:05 UTC | newest]
Thread overview: 4+ messages (download: mbox.gz follow: Atom feed
-- links below jump to the message on this page --
2010-10-26 22:53 [PATCH] Some tweaks to the R6RS support Andreas Rottmann
2010-11-20 15:38 ` Andy Wingo
2010-11-20 18:09 ` Andreas Rottmann
2010-11-25 22:05 ` Andy Wingo
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).