[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[PATCH] Some R6RS fixes
From: |
Andreas Rottmann |
Subject: |
[PATCH] Some R6RS fixes |
Date: |
Sat, 14 Aug 2010 18:12:13 +0200 |
User-agent: |
Gnus/5.13 (Gnus v5.13) Emacs/23.2 (gnu/linux) |
Some smallish fixes to the (rnrs ...) modules.
From: Andreas Rottmann <address@hidden>
Subject: 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.
---
module/rnrs/arithmetic/fixnums.scm | 2 +-
module/rnrs/base.scm | 20 ++++++++++++++++++++
module/rnrs/conditions.scm | 12 +++++++++++-
module/rnrs/enums.scm | 1 -
module/rnrs/exceptions.scm | 12 ++++++------
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 cda1933..c1f3571 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 e92089e..74fce31 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 53d4d0f..b897221 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 cd7e346..79d3417 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 cd5bacf..ff4049b 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 d46efbc..5070212 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))
--
tg: (802b47b..) t/rnrs-fixes (depends on: master)
Cheers, Rotty
--
Andreas Rottmann -- <http://rotty.yi.org/>
- [PATCH] Some R6RS fixes,
Andreas Rottmann <=