summaryrefslogtreecommitdiff
path: root/module/rnrs/base.scm
diff options
context:
space:
mode:
authorAndreas Rottmann <a.rottmann@gmx.at>2010-11-25 23:03:12 +0100
committerAndy Wingo <wingo@pobox.com>2010-11-25 23:04:12 +0100
commitc0f6c1638bb920d5cf5ec3210d91bc9fb0c70319 (patch)
tree0643ebec6d4658c3c04306197f36ec56df46d2c9 /module/rnrs/base.scm
parent43ecaffc2f564dbb03af446671097a548378df82 (diff)
downloadguile-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.scm30
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))))))))
)