summaryrefslogtreecommitdiff
path: root/module
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
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')
-rw-r--r--module/rnrs/base.scm30
-rw-r--r--module/rnrs/conditions.scm15
-rw-r--r--module/rnrs/records/inspection.scm30
-rw-r--r--module/rnrs/records/syntactic.scm10
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