diff options
author | Andreas Rottmann <a.rottmann@gmx.at> | 2010-11-25 23:03:12 +0100 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2010-11-25 23:04:12 +0100 |
commit | c0f6c1638bb920d5cf5ec3210d91bc9fb0c70319 (patch) | |
tree | 0643ebec6d4658c3c04306197f36ec56df46d2c9 /module | |
parent | 43ecaffc2f564dbb03af446671097a548378df82 (diff) | |
download | guile-c0f6c1638bb920d5cf5ec3210d91bc9fb0c70319.tar.gz |
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'.
Diffstat (limited to 'module')
-rw-r--r-- | module/rnrs/base.scm | 30 | ||||
-rw-r--r-- | module/rnrs/conditions.scm | 15 | ||||
-rw-r--r-- | module/rnrs/records/inspection.scm | 30 | ||||
-rw-r--r-- | module/rnrs/records/syntactic.scm | 10 |
4 files changed, 50 insertions, 35 deletions
diff --git a/module/rnrs/base.scm b/module/rnrs/base.scm index 63204208e..a6ae1b910 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 6885adaf6..959411b9e 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 315ef0cb6..68b78a916 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 507021262..6431fcff8 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 |