summaryrefslogtreecommitdiff
path: root/module/rnrs
diff options
context:
space:
mode:
authorJulian Graham <julian.graham@aya.yale.edu>2010-03-26 20:57:52 -0400
committerJulian Graham <julian.graham@aya.yale.edu>2010-05-20 21:18:03 -0400
commitd1c83d388aa35977a612eceda4cf52ef891cab0b (patch)
tree098dd93df8df977303ab88e10073ddb1e1e82d5e /module/rnrs
parenta7ada161878d42b194660990473ccfbc86e59543 (diff)
downloadguile-d1c83d388aa35977a612eceda4cf52ef891cab0b.tar.gz
Add `guard' form and test cases to R6RS (rnrs exceptions) library.
* module/rnrs/6/exceptions.scm: (guard0, guard): New syntax. * module/rnrs/records/6/procedural.scm: (r6rs-raise-continuable): Can't use `raise' here because it's exported by (rnrs exceptions); use plain old `throw' instead. * test-suite/Makefile.am: Add tests/r6rs-exceptions.test to SCM_TESTS. * test-suite/tests/r6rs-exceptions.test: New file.
Diffstat (limited to 'module/rnrs')
-rw-r--r--module/rnrs/6/exceptions.scm23
-rw-r--r--module/rnrs/records/6/procedural.scm2
2 files changed, 23 insertions, 2 deletions
diff --git a/module/rnrs/6/exceptions.scm b/module/rnrs/6/exceptions.scm
index eeea9238b..87dfe70b9 100644
--- a/module/rnrs/6/exceptions.scm
+++ b/module/rnrs/6/exceptions.scm
@@ -18,10 +18,11 @@
(library (rnrs exceptions (6))
- (export with-exception-handler raise raise-continuable)
+ (export guard with-exception-handler raise raise-continuable)
(import (rnrs base (6))
(rnrs conditions (6))
(rnrs records procedural (6))
+ (rnrs syntax-case (6))
(only (guile) with-throw-handler))
(define raise (@@ (rnrs records procedural) r6rs-raise))
@@ -48,4 +49,24 @@
(continuation handler-return)
(raise (make-non-continuable-violation))))
*unspecified*))))
+
+ (define-syntax guard0
+ (lambda (stx)
+ (syntax-case stx ()
+ ((_ (variable cond-clause ...) body)
+ (syntax (call/cc (lambda (continuation)
+ (with-exception-handler
+ (lambda (variable)
+ (continuation (cond cond-clause ...)))
+ (lambda () body)))))))))
+
+ (define-syntax guard
+ (lambda (stx)
+ (syntax-case stx (else)
+ ((_ (variable cond-clause ... . ((else else-clause ...))) body)
+ (syntax (guard0 (variable cond-clause ... (else else-clause ...))
+ body)))
+ ((_ (variable cond-clause ...) body)
+ (syntax (guard0 (variable cond-clause ... (else (raise variable)))
+ body))))))
)
diff --git a/module/rnrs/records/6/procedural.scm b/module/rnrs/records/6/procedural.scm
index a14842e1c..da30fa407 100644
--- a/module/rnrs/records/6/procedural.scm
+++ b/module/rnrs/records/6/procedural.scm
@@ -273,6 +273,6 @@
(throw 'r6rs:exception (make-raise-object-wrapper obj #f)))
(define (r6rs-raise-continuable obj)
(define (r6rs-raise-continuable-internal continuation)
- (raise (make-raise-object-wrapper obj continuation)))
+ (throw 'r6rs:exception (make-raise-object-wrapper obj continuation)))
(call/cc r6rs-raise-continuable-internal))
)