* 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'.
let-syntax letrec-syntax
syntax-rules identifier-syntax)
- (import (rename (guile)
+ (import (rename (except (guile) error raise)
(quotient div)
(modulo mod)
(exact->inexact inexact)
(@ (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
(@ (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))))))))
)
(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))))
((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
(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
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 @@))
(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))
)
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)
(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
\f
(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"
(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)))))
HCoop / bpt / guile.git / commitdiff