diff options
author | Julian Graham <julian.graham@aya.yale.edu> | 2010-03-28 19:31:49 -0400 |
---|---|---|
committer | Julian Graham <julian.graham@aya.yale.edu> | 2010-05-20 21:18:03 -0400 |
commit | 2359a9a49ef4dd70e112d517b11b05840440b522 (patch) | |
tree | d0cef1c977b2adfeed6423e0d15e36bc89620657 /module/rnrs | |
parent | a725e27bdaeef13c14006f46200130467a5571d5 (diff) | |
download | guile-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.scm | 112 | ||||
-rw-r--r-- | module/rnrs/records/6/procedural.scm | 3 |
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 |