[PATCH] Some R6RS fixes

[Andreas Rottmann <a.rottmann@gmx.at>]

[-- Attachment #1: Type: text/plain, Size: 49 bytes --]


Some smallish fixes to the (rnrs ...) modules.


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: rnrs-fixes.diff --]
[-- Type: text/x-diff, Size: 5935 bytes --]

From: Andreas Rottmann <a.rottmann@gmx.at>
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)

[-- Attachment #3: Type: text/plain, Size: 62 bytes --]


Cheers, Rotty
-- 
Andreas Rottmann -- <http://rotty.yi.org/>