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/rnrs/base.scm | |
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/rnrs/base.scm')
-rw-r--r-- | module/rnrs/base.scm | 30 |
1 files changed, 24 insertions, 6 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)))))))) ) |