summaryrefslogtreecommitdiff
path: root/module/rnrs
diff options
context:
space:
mode:
authorAndreas Rottmann <a.rottmann@gmx.at>2010-08-28 10:16:30 -0700
committerAndy Wingo <wingo@pobox.com>2010-08-28 10:16:30 -0700
commit23988e8c50e62355689f5bcb34ca65c45fb35fc7 (patch)
treec60dd81bd9006b0fc947c00367036ae758d9e513 /module/rnrs
parent7d0e17389c6856883a87f914d0d7c916620832d5 (diff)
downloadguile-23988e8c50e62355689f5bcb34ca65c45fb35fc7.tar.gz
Several fixes to R6RS libraries
* module/rnrs/arithmetic/fixnums.scm (fixnum-width): Make this return an an exact integer instead of an inexact number. * module/rnrs/base.scm (assertion-violation): Implement. * module/rnrs/conditions.scm (simple-conditions): Allow also simple conditions as argument. * module/rnrs/enums.scm (define-enumeration): Properly construct empty enumeration sets. * module/rnrs/exceptions.scm (guard): Don't restrict the body to a single expression. * module/rnrs/records/syntactic.scm (define-record-type0): Expand into a series of definitions only.
Diffstat (limited to 'module/rnrs')
-rw-r--r--module/rnrs/arithmetic/fixnums.scm2
-rw-r--r--module/rnrs/base.scm20
-rw-r--r--module/rnrs/conditions.scm12
-rw-r--r--module/rnrs/enums.scm1
-rw-r--r--module/rnrs/exceptions.scm12
-rw-r--r--module/rnrs/records/syntactic.scm11
6 files changed, 45 insertions, 13 deletions
diff --git a/module/rnrs/arithmetic/fixnums.scm b/module/rnrs/arithmetic/fixnums.scm
index cda19331d..c1f3571ea 100644
--- a/module/rnrs/arithmetic/fixnums.scm
+++ b/module/rnrs/arithmetic/fixnums.scm
@@ -93,7 +93,7 @@
(rnrs lists (6)))
(define fixnum-width
- (let ((w (round (/ (log (+ most-positive-fixnum 1)) (log 2)))))
+ (let ((w (inexact->exact (round (/ (log (+ most-positive-fixnum 1)) (log 2))))))
(lambda () w)))
(define (greatest-fixnum) most-positive-fixnum)
diff --git a/module/rnrs/base.scm b/module/rnrs/base.scm
index e92089e1d..74fce31dc 100644
--- a/module/rnrs/base.scm
+++ b/module/rnrs/base.scm
@@ -94,4 +94,24 @@
((negative? y) (values (- q 1) (+ r y)))
(else (values (+ q 1) (+ r y)))))))
+ (define raise
+ (@ (rnrs exceptions) raise))
+ (define condition
+ (@ (rnrs conditions) condition))
+ (define make-assertion-violation
+ (@ (rnrs conditions) make-assertion-violation))
+ (define make-who-condition
+ (@ (rnrs conditions) make-who-condition))
+ (define make-message-condition
+ (@ (rnrs conditions) make-message-condition))
+ (define make-irritants-condition
+ (@ (rnrs conditions) make-irritants-condition))
+
+ (define (assertion-violation who message . irritants)
+ (raise (condition
+ (make-assertion-violation)
+ (make-who-condition who)
+ (make-message-condition message)
+ (make-irritants-condition irritants))))
+
)
diff --git a/module/rnrs/conditions.scm b/module/rnrs/conditions.scm
index 53d4d0f6c..b89722184 100644
--- a/module/rnrs/conditions.scm
+++ b/module/rnrs/conditions.scm
@@ -95,7 +95,17 @@
(define make-compound-condition
(record-constructor (make-record-constructor-descriptor
&compound-condition #f #f)))
- (define simple-conditions (record-accessor &compound-condition 0))
+ (define simple-conditions
+ (let ((compound-ref (record-accessor &compound-condition 0)))
+ (lambda (condition)
+ (cond ((compound-condition? condition)
+ (compound-ref condition))
+ ((condition-internal? condition)
+ (list condition))
+ (else
+ (assertion-violation 'simple-conditions
+ "not a condition"
+ condition))))))
(define (condition? obj)
(or (compound-condition? obj) (condition-internal? obj)))
diff --git a/module/rnrs/enums.scm b/module/rnrs/enums.scm
index cd7e346ba..79d341746 100644
--- a/module/rnrs/enums.scm
+++ b/module/rnrs/enums.scm
@@ -137,7 +137,6 @@
(define-syntax constructor-syntax
(lambda (s)
(syntax-case s ()
- ((_) (syntax #f))
((_ sym (... ...))
(let* ((universe '(symbol ...))
(syms (syntax->datum #'(sym (... ...))))
diff --git a/module/rnrs/exceptions.scm b/module/rnrs/exceptions.scm
index cd5bacf42..ff4049ba0 100644
--- a/module/rnrs/exceptions.scm
+++ b/module/rnrs/exceptions.scm
@@ -51,17 +51,17 @@
(define-syntax guard0
(syntax-rules ()
- ((_ (variable cond-clause ...) body)
+ ((_ (variable cond-clause ...) . body)
(call/cc (lambda (continuation)
(with-exception-handler
(lambda (variable)
(continuation (cond cond-clause ...)))
- (lambda () body)))))))
+ (lambda () . body)))))))
(define-syntax guard
(syntax-rules (else)
- ((_ (variable cond-clause ... . ((else else-clause ...))) body)
- (guard0 (variable cond-clause ... (else else-clause ...)) body))
- ((_ (variable cond-clause ...) body)
- (guard0 (variable cond-clause ... (else (raise variable))) body))))
+ ((_ (variable cond-clause ... . ((else else-clause ...))) . body)
+ (guard0 (variable cond-clause ... (else else-clause ...)) . body))
+ ((_ (variable cond-clause ...) . body)
+ (guard0 (variable cond-clause ... (else (raise variable))) . body))))
)
diff --git a/module/rnrs/records/syntactic.scm b/module/rnrs/records/syntactic.scm
index d46efbc29..507021262 100644
--- a/module/rnrs/records/syntactic.scm
+++ b/module/rnrs/records/syntactic.scm
@@ -177,10 +177,13 @@
(record-constructor
(make-record-constructor-descriptor
record-name #,parent-cd #,protocol)))
- (register-record-type
- #,record-name-sym
- record-name (make-record-constructor-descriptor
- record-name #,parent-cd #,protocol))
+ (define dummy
+ (let ()
+ (register-record-type
+ #,record-name-sym
+ record-name (make-record-constructor-descriptor
+ record-name #,parent-cd #,protocol))
+ 'dummy))
(define predicate-name (record-predicate record-name))
#,@field-accessors
#,@field-mutators))