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.

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

diff --git a/module/rnrs/records/6/procedural.scm b/module/rnrs/records/6/procedural.scm
index a14842e..da30fa4 100644 (file)
--- 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))
 )

diff --git a/test-suite/Makefile.am b/test-suite/Makefile.am
index 3a7e676..b08233f 100644 (file)
--- a/test-suite/Makefile.am
+++ b/test-suite/Makefile.am
@@ -78,6 +78,7 @@ SCM_TESTS = tests/00-initial-env.test         \
            tests/r5rs_pitfall.test             \
            tests/r6rs-arithmetic-bitwise.test  \
            tests/r6rs-control.test             \
+           tests/r6rs-exceptions.test          \
            tests/r6rs-files.test               \
            tests/r6rs-hashtables.test          \
            tests/r6rs-ports.test               \

diff --git a/test-suite/tests/r6rs-exceptions.test b/test-suite/tests/r6rs-exceptions.test
new file mode 100644 (file)
index 0000000..54a4ddb
--- /dev/null
+++ b/test-suite/tests/r6rs-exceptions.test
@@ -0,0 +1,98 @@
+;;; r6rs-exceptions.test --- Test suite for R6RS (rnrs exceptions)
+
+;;      Copyright (C) 2010 Free Software Foundation, Inc.
+;;
+;; This library is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU Lesser General Public
+;; License as published by the Free Software Foundation; either
+;; version 3 of the License, or (at your option) any later version.
+;; 
+;; This library is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;; Lesser General Public License for more details.
+;; 
+;; You should have received a copy of the GNU Lesser General Public
+;; License along with this library; if not, write to the Free Software
+;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+\f
+
+(define-module (test-suite test-rnrs-exceptions)
+  :use-module ((rnrs conditions) :version (6))
+  :use-module ((rnrs exceptions) :version (6))
+  :use-module (test-suite lib))
+
+(with-test-prefix "with-exception-handler"
+  (pass-if "handler invoked on raise"
+    (let ((success #f))
+      (call/cc
+       (lambda (continuation)
+        (with-exception-handler 
+         (lambda (condition) (set! success #t) (continuation))
+         (lambda () (raise (make-violation))))))
+      success))
+
+  (pass-if "handler not invoked unless raise"
+    (let ((success #f))
+      (call/cc 
+       (lambda (continuation)
+        (with-exception-handler
+         (lambda (condition) (continuation))
+         (lambda () (set! success #t)))))
+      success)))
+
+(with-test-prefix "raise"
+  (pass-if "raise causes &non-continuable after handler"
+    (let ((success #f))
+      (call/cc 
+       (lambda (continuation)
+        (with-exception-handler
+         (lambda (condition)
+           (set! success (non-continuable-violation? condition))
+           (continuation))
+         (lambda ()
+           (with-exception-handler
+            (lambda (condition) #f)
+            (lambda () (raise (make-violation))))))))
+      success)))
+
+(with-test-prefix "raise-continuable"
+  (pass-if "raise-continuable invokes continuation after handler"
+    (let ((handled #f)
+         (continued #f))
+      (call/cc
+       (lambda (continuation)
+        (with-exception-handler
+         (lambda (condition) (set! handled #t))
+         (lambda ()
+           (raise-continuable (make-violation))
+           (set! continued #t)))))
+      (and handled continued))))
+
+(with-test-prefix "guard"
+  (pass-if "guard with matching cond without else"
+    (let ((success #f))
+      (guard (condition ((error? condition) (set! success #t)))
+            (raise (make-error)))
+      success))
+
+  (pass-if "guard without matching cond without else"
+    (let ((success #f))
+      (call/cc 
+       (lambda (continuation)
+        (with-exception-handler
+         (lambda (condition) (set! success (error? condition)) (continuation))
+         (lambda ()
+           (guard (condition ((irritants-condition? condition) #f))
+                  (raise (make-error)))))))
+      success))
+           
+  (pass-if "guard with else and without matching cond"
+    (let ((success #f))
+      (guard (condition ((irritants-condition? condition) #f)
+                       (else (set! success #t)))
+            (raise (make-error)))
+      success))
+
+  (pass-if "guard with cond => syntax"
+    (guard (condition (condition => error?)) (raise (make-error)))))