diff options
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)) ) |