summaryrefslogtreecommitdiff
path: root/module/rnrs/6/exceptions.scm
diff options
context:
space:
mode:
Diffstat (limited to 'module/rnrs/6/exceptions.scm')
-rw-r--r--module/rnrs/6/exceptions.scm23
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))))))
)