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/rnrs/6/exceptions.scm | |
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/rnrs/6/exceptions.scm')
-rw-r--r-- | module/rnrs/6/exceptions.scm | 23 |
1 files changed, 22 insertions, 1 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)))))) ) |