diff options
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 |