summaryrefslogtreecommitdiff
path: root/module/rnrs
diff options
context:
space:
mode:
authorJulian Graham <julian.graham@aya.yale.edu>2010-03-28 19:31:49 -0400
committerJulian Graham <julian.graham@aya.yale.edu>2010-05-20 21:18:03 -0400
commit2359a9a49ef4dd70e112d517b11b05840440b522 (patch)
treed0cef1c977b2adfeed6423e0d15e36bc89620657 /module/rnrs
parenta725e27bdaeef13c14006f46200130467a5571d5 (diff)
downloadguile-2359a9a49ef4dd70e112d517b11b05840440b522.tar.gz
Test suite and fixes for R6RS (rnrs conditions) and
(rnrs records procedural). * module/rnrs/6/conditions.scm: Fix export of make-implementation-restriction-violation; remove dependency on (rnrs syntax-case); remove redundant function compound-condition-components; rewrite define-condition-type using syntax-rules instead of syntax-case. * module/rnrs/records/6/procedural.scm: Remove serious-condition?, violation? and assertion-violation? predicates, since they're not true condition predicates. * test-suite/Makefile.am: Add tests/r6rs-conditions.test to SCM_TESTS. * test-suite/tests/r6rs-conditions.test: New file.
Diffstat (limited to 'module/rnrs')
-rw-r--r--module/rnrs/6/conditions.scm112
-rw-r--r--module/rnrs/records/6/procedural.scm3
2 files changed, 56 insertions, 59 deletions
diff --git a/module/rnrs/6/conditions.scm b/module/rnrs/6/conditions.scm
index b6630c88f..8ff2f347b 100644
--- a/module/rnrs/6/conditions.scm
+++ b/module/rnrs/6/conditions.scm
@@ -66,7 +66,7 @@
non-continuable-violation?
&implementation-restriction
- make-implementation-restriction
+ make-implementation-restriction-violation
implementation-restriction-violation?
&lexical
@@ -82,10 +82,11 @@
&undefined
make-undefined-violation
undefined-violation?)
- (import (rnrs base (6))
- (rnrs records procedural (6))
- (rnrs syntax-case (6)))
-
+ (import (only (guile) and=>)
+ (rnrs base (6))
+ (rnrs lists (6))
+ (rnrs records procedural (6)))
+
(define &compound-condition (make-record-type-descriptor
'&compound-condition #f #f #f #f
'#((immutable components))))
@@ -94,64 +95,64 @@
(define make-compound-condition
(record-constructor (make-record-constructor-descriptor
&compound-condition #f #f)))
- (define compound-condition-components (record-accessor &compound-condition 0))
+ (define simple-conditions (record-accessor &compound-condition 0))
- (define-syntax define-condition-type
- (lambda (stx)
- (syntax-case stx ()
- ((_ condition-type supertype constructor predicate
- (field accessor) ...)
- (let*
- ((fields (let* ((field-spec-syntax #'((field accessor) ...))
- (field-specs (syntax->datum field-spec-syntax)))
- (list->vector (map (lambda (field-spec)
- (cons 'immutable field-spec))
- field-specs))))
- (fields-syntax (datum->syntax stx fields)))
- #`(begin
- (define condition-type
- (make-record-type-descriptor
- #,(datum->syntax
- stx (list 'quote (syntax->datum #'condition-type)))
- supertype #f #f #f #,fields-syntax))
- (define constructor
- (record-constructor
- (make-record-constructor-descriptor condition-type #f #f)))
- (define predicate (record-predicate condition-type))
- #,@(let f ((accessors '())
- (counter 0))
- (if (>= counter (vector-length fields))
- accessors
- (f (cons #`(define #,(datum->syntax
- stx (caddr (vector-ref fields
- counter)))
- (record-accessor condition-type #,counter))
- accessors)
- (+ counter 1))))))))))
-
- (define &condition (@@ (rnrs records procedural) &condition))
- (define &condition-constructor-descriptor
- (make-record-constructor-descriptor &condition #f #f))
- (define condition-internal? (record-predicate &condition))
+ (define (condition? obj)
+ (or (compound-condition? obj) (condition-internal? obj)))
(define condition
(lambda conditions
(define (flatten cond)
- (if (compound-condition? cond)
- (fold append '() (map flatten (compound-condition-components cond)))
- cond))
+ (if (compound-condition? cond) (simple-conditions cond) (list cond)))
(or (for-all condition? conditions)
(raise (make-assertion-violation)))
- (make-compound-condition (flatten conditions))))
+ (if (or (null? conditions) (> (length conditions) 1))
+ (make-compound-condition (apply append (map flatten conditions)))
+ (car conditions))))
+
+ (define-syntax define-condition-type
+ (syntax-rules ()
+ ((_ condition-type supertype constructor predicate
+ (field accessor) ...)
+ (letrec-syntax
+ ((transform-fields
+ (syntax-rules ()
+ ((_ (f a) . rest)
+ (cons '(immutable f a) (transform-fields rest)))
+ ((_ ((f a))) '((immutable f a)))
+ ((_ ()) '())
+ ((_) '())))
+
+ (generate-accessors
+ (syntax-rules ()
+ ((_ counter (f a) . rest)
+ (begin (define a (record-accessor condition-type counter))
+ (generate-accessors (+ counter 1) rest)))
+ ((_ counter ((f a)))
+ (define a (record-accessor condition-type counter)))
+ ((_ counter ()) (begin))
+ ((_ counter) (begin)))))
+ (begin
+ (define condition-type
+ (make-record-type-descriptor
+ 'condition-type supertype #f #f #f
+ (list->vector (transform-fields (field accessor) ...))))
+ (define constructor
+ (record-constructor
+ (make-record-constructor-descriptor condition-type #f #f)))
+ (define predicate (condition-predicate condition-type))
+ (generate-accessors 0 (field accessor) ...))))))
+
+ (define &condition (@@ (rnrs records procedural) &condition))
+ (define &condition-constructor-descriptor
+ (make-record-constructor-descriptor &condition #f #f))
+ (define condition-internal? (record-predicate &condition))
- (define (simple-conditions condition) (record-accessor &compound-condition 0))
- (define (condition? obj)
- (or (compound-condition? obj) (condition-internal? obj)))
(define (condition-predicate rtd)
(let ((rtd-predicate (record-predicate rtd)))
(lambda (obj)
(cond ((compound-condition? obj)
- (find rtd-predicate (compound-condition-components obj)))
+ (exists rtd-predicate (simple-conditions obj)))
((condition-internal? obj) (rtd-predicate obj))
(else #f)))))
@@ -160,7 +161,7 @@
(lambda (obj)
(cond ((rtd-predicate obj) (proc obj))
((compound-condition? obj)
- (and=> (find rtd-predicate simple-conditions obj) proc))
+ (and=> (find rtd-predicate (simple-conditions obj)) proc))
(else #f)))))
(define-condition-type &message &condition
@@ -172,19 +173,18 @@
(define &serious (@@ (rnrs records procedural) &serious))
(define make-serious-condition
(@@ (rnrs records procedural) make-serious-condition))
- (define serious-condition? (@@ (rnrs records procedural) serious-condition?))
+ (define serious-condition? (condition-predicate &serious))
(define-condition-type &error &serious make-error error?)
(define &violation (@@ (rnrs records procedural) &violation))
(define make-violation (@@ (rnrs records procedural) make-violation))
- (define violation? (@@ (rnrs records procedural) violation?))
+ (define violation? (condition-predicate &violation))
(define &assertion (@@ (rnrs records procedural) &assertion))
(define make-assertion-violation
(@@ (rnrs records procedural) make-assertion-violation))
- (define assertion-violation?
- (@@ (rnrs records procedural) assertion-violation?))
+ (define assertion-violation? (condition-predicate &assertion))
(define-condition-type &irritants &condition
make-irritants-condition irritants-condition?
diff --git a/module/rnrs/records/6/procedural.scm b/module/rnrs/records/6/procedural.scm
index da30fa407..bd1d0d151 100644
--- a/module/rnrs/records/6/procedural.scm
+++ b/module/rnrs/records/6/procedural.scm
@@ -236,7 +236,6 @@
(define make-serious-condition
(record-constructor &serious-constructor-descriptor))
- (define serious-condition? (record-predicate &serious))
(define &violation (make-record-type-descriptor
'&violation &serious #f #f #f '#()))
@@ -244,7 +243,6 @@
(make-record-constructor-descriptor
&violation &serious-constructor-descriptor #f))
(define make-violation (record-constructor &violation-constructor-descriptor))
- (define violation? (record-predicate &violation))
(define &assertion (make-record-type-descriptor
'&assertion &violation #f #f #f '#()))
@@ -252,7 +250,6 @@
(record-constructor
(make-record-constructor-descriptor
&assertion &violation-constructor-descriptor #f)))
- (define assertion-violation? (record-predicate &assertion))
;; Exception wrapper type, along with a wrapping `throw' implementation.
;; These are used in the current library, and so they are defined here and not