* [PATCH] Some R6RS fixes
@ 2010-08-14 16:12 Andreas Rottmann
2010-08-28 17:22 ` Andy Wingo
0 siblings, 1 reply; 2+ messages in thread
From: Andreas Rottmann @ 2010-08-14 16:12 UTC (permalink / raw)
To: Guile Development
[-- 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/>
^ permalink raw reply related [flat|nested] 2+ messages in thread
* Re: [PATCH] Some R6RS fixes
2010-08-14 16:12 [PATCH] Some R6RS fixes Andreas Rottmann
@ 2010-08-28 17:22 ` Andy Wingo
0 siblings, 0 replies; 2+ messages in thread
From: Andy Wingo @ 2010-08-28 17:22 UTC (permalink / raw)
To: Andreas Rottmann; +Cc: Guile Development
On Sat 14 Aug 2010 09:12, Andreas Rottmann <a.rottmann@gmx.at> writes:
> Some smallish fixes to the (rnrs ...) modules.
Applied, thanks.
Andy
--
http://wingolog.org/
^ permalink raw reply [flat|nested] 2+ messages in thread
end of thread, other threads:[~2010-08-28 17:22 UTC | newest]
Thread overview: 2+ messages (download: mbox.gz follow: Atom feed
-- links below jump to the message on this page --
2010-08-14 16:12 [PATCH] Some R6RS fixes Andreas Rottmann
2010-08-28 17:22 ` Andy Wingo
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).