Add `guard' form and test cases to R6RS (rnrs exceptions) library.

[bpt/guile.git] / module / rnrs / 6 / exceptions.scm

diff --git a/module/rnrs/6/exceptions.scm b/module/rnrs/6/exceptions.scm
index eeea923..87dfe70 100644 (file)
--- a/module/rnrs/6/exceptions.scm
+++ b/module/rnrs/6/exceptions.scm
@@ -18,10 +18,11 @@
 \f
 
 (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))))))
 )