diff options
author | Andreas Rottmann <a.rottmann@gmx.at> | 2010-08-28 10:16:30 -0700 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2010-08-28 10:16:30 -0700 |
commit | 23988e8c50e62355689f5bcb34ca65c45fb35fc7 (patch) | |
tree | c60dd81bd9006b0fc947c00367036ae758d9e513 /module/rnrs | |
parent | 7d0e17389c6856883a87f914d0d7c916620832d5 (diff) | |
download | guile-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.scm | 2 | ||||
-rw-r--r-- | module/rnrs/base.scm | 20 | ||||
-rw-r--r-- | module/rnrs/conditions.scm | 12 | ||||
-rw-r--r-- | module/rnrs/enums.scm | 1 | ||||
-rw-r--r-- | module/rnrs/exceptions.scm | 12 | ||||
-rw-r--r-- | module/rnrs/records/syntactic.scm | 11 |
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)) |