diff options
author | Julian Graham <julian.graham@aya.yale.edu> | 2010-03-26 20:57:52 -0400 |
---|---|---|
committer | Julian Graham <julian.graham@aya.yale.edu> | 2010-05-20 21:18:03 -0400 |
commit | d1c83d388aa35977a612eceda4cf52ef891cab0b (patch) | |
tree | 098dd93df8df977303ab88e10073ddb1e1e82d5e /module | |
parent | a7ada161878d42b194660990473ccfbc86e59543 (diff) | |
download | guile-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')
-rw-r--r-- | module/rnrs/6/exceptions.scm | 23 | ||||
-rw-r--r-- | module/rnrs/records/6/procedural.scm | 2 |
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)) ) |