From: Andreas Rottmann 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 @@ (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)