19 new test cases.

(throw-test): New macro for testing catches and throw handlers.

diff --git a/test-suite/ChangeLog b/test-suite/ChangeLog
index c095c6c..29ab92c 100644 (file)
--- a/test-suite/ChangeLog
+++ b/test-suite/ChangeLog
@@ -1,3 +1,8 @@
+2006-02-04  Neil Jerram  <neil@ossau.uklinux.net>
+
+       * tests/exceptions.test: 19 new test cases.
+       (throw-test): New macro for testing catches and throw handlers.
+
 2006-02-04  Kevin Ryde  <user42@zip.com.au>
 
        * standalone/test-list.c: New file.

diff --git a/test-suite/tests/exceptions.test b/test-suite/tests/exceptions.test
index db52126..565cc8f 100644 (file)
--- a/test-suite/tests/exceptions.test
+++ b/test-suite/tests/exceptions.test
@@ -18,6 +18,19 @@
 
 (use-modules (test-suite lib))
 
+(define-macro (throw-test title result . exprs)
+  `(pass-if ,title
+     (equal? ,result
+            (letrec ((stack '())
+                     (push (lambda (val)
+                             (set! stack (cons val stack)))))
+              (begin ,@exprs)
+              ;;(display ,title)
+              ;;(display ": ")
+              ;;(write (reverse stack))
+              ;;(newline)
+              (reverse stack)))))
+
 (with-test-prefix "throw/catch"
 
   (with-test-prefix "wrong type argument"
@@ -60,7 +73,385 @@
       exception:wrong-num-args
       (catch 'a
        (lambda () (throw 'a))
-       (lambda (x y . rest) #f)))))
+       (lambda (x y . rest) #f))))
+
+  (with-test-prefix "with lazy handler"
+
+    (pass-if "lazy fluid state"
+      (equal? '(inner outer arg)
+       (let ((fluid-parm (make-fluid))
+            (inner-val #f))
+        (fluid-set! fluid-parm 'outer)
+        (catch 'misc-exc
+          (lambda ()
+            (with-fluids ((fluid-parm 'inner))
+              (throw 'misc-exc 'arg)))
+          (lambda (key . args)
+            (list inner-val
+                  (fluid-ref fluid-parm)
+                  (car args)))
+          (lambda (key . args)
+            (set! inner-val (fluid-ref fluid-parm))))))))
+
+  (throw-test "normal catch"
+             '(1 2)
+             (catch 'a
+                    (lambda ()
+                      (push 1)
+                      (throw 'a))
+                    (lambda (key . args)
+                      (push 2))))
+
+  (throw-test "catch and lazy catch"
+             '(1 2 3 4)
+             (catch 'a
+                    (lambda ()
+                      (push 1)
+                      (lazy-catch 'a
+                                  (lambda ()
+                                    (push 2)
+                                    (throw 'a))
+                                  (lambda (key . args)
+                                    (push 3))))
+                    (lambda (key . args)
+                      (push 4))))
+
+  (throw-test "catch with rethrowing lazy catch handler"
+             '(1 2 3 4)
+             (catch 'a
+                    (lambda ()
+                      (push 1)
+                      (lazy-catch 'a
+                                  (lambda ()
+                                    (push 2)
+                                    (throw 'a))
+                                  (lambda (key . args)
+                                    (push 3)
+                                    (apply throw key args))))
+                    (lambda (key . args)
+                      (push 4))))
+
+  (throw-test "catch with pre-unwind handler"
+             '(1 3 2)
+             (catch 'a
+                    (lambda ()
+                      (push 1)
+                      (throw 'a))
+                    (lambda (key . args)
+                      (push 2))
+                    (lambda (key . args)
+                      (push 3))))
+
+  (throw-test "catch with rethrowing pre-unwind handler"
+             '(1 3 2)
+             (catch 'a
+                    (lambda ()
+                      (push 1)
+                      (throw 'a))
+                    (lambda (key . args)
+                      (push 2))
+                    (lambda (key . args)
+                      (push 3)
+                      (apply throw key args))))
+
+  (throw-test "catch with throw handler"
+             '(1 2 3 4)
+             (catch 'a
+                    (lambda ()
+                      (push 1)
+                      (with-throw-handler 'a
+                                          (lambda ()
+                                            (push 2)
+                                            (throw 'a))
+                                          (lambda (key . args)
+                                            (push 3))))
+                    (lambda (key . args)
+                      (push 4))))
+
+  (throw-test "catch with rethrowing throw handler"
+             '(1 2 3 4)
+             (catch 'a
+                    (lambda ()
+                      (push 1)
+                      (with-throw-handler 'a
+                                          (lambda ()
+                                            (push 2)
+                                            (throw 'a))
+                                          (lambda (key . args)
+                                            (push 3)
+                                            (apply throw key args))))
+                    (lambda (key . args)
+                      (push 4))))
+
+  (throw-test "effect of lazy-catch unwinding on throw to another key"
+             '(1 2 3 5 7)
+             (catch 'a
+                    (lambda ()
+                      (push 1)
+                      (lazy-catch 'b
+                                  (lambda ()
+                                    (push 2)
+                                    (catch 'a
+                                           (lambda ()
+                                             (push 3)
+                                             (throw 'b))
+                                           (lambda (key . args)
+                                             (push 4))))
+                                  (lambda (key . args)
+                                    (push 5)
+                                    (throw 'a)))
+                      (push 6))
+                    (lambda (key . args)
+                      (push 7))))
+
+  (throw-test "effect of with-throw-handler not-unwinding on throw to another key"
+             '(1 2 3 5 4 6)
+             (catch 'a
+                    (lambda ()
+                      (push 1)
+                      (with-throw-handler 'b
+                                  (lambda ()
+                                    (push 2)
+                                    (catch 'a
+                                           (lambda ()
+                                             (push 3)
+                                             (throw 'b))
+                                           (lambda (key . args)
+                                             (push 4))))
+                                  (lambda (key . args)
+                                    (push 5)
+                                    (throw 'a)))
+                      (push 6))
+                    (lambda (key . args)
+                      (push 7))))
+
+  (throw-test "lazy-catch chaining"
+             '(1 2 3 4 6 8)
+             (catch 'a
+               (lambda ()
+                 (push 1)
+                 (lazy-catch 'a
+                   (lambda ()
+                     (push 2)
+                     (lazy-catch 'a
+                        (lambda ()
+                         (push 3)
+                         (throw 'a))
+                       (lambda (key . args)
+                         (push 4)))
+                     (push 5))
+                   (lambda (key . args)
+                     (push 6)))
+                 (push 7))
+               (lambda (key . args)
+                 (push 8))))
+
+  (throw-test "with-throw-handler chaining"
+             '(1 2 3 4 6 8)
+             (catch 'a
+               (lambda ()
+                 (push 1)
+                 (with-throw-handler 'a
+                   (lambda ()
+                     (push 2)
+                     (with-throw-handler 'a
+                        (lambda ()
+                         (push 3)
+                         (throw 'a))
+                       (lambda (key . args)
+                         (push 4)))
+                     (push 5))
+                   (lambda (key . args)
+                     (push 6)))
+                 (push 7))
+               (lambda (key . args)
+                 (push 8))))
+
+  (throw-test "with-throw-handler inside lazy-catch"
+             '(1 2 3 4 6 8)
+             (catch 'a
+               (lambda ()
+                 (push 1)
+                 (lazy-catch 'a
+                   (lambda ()
+                     (push 2)
+                     (with-throw-handler 'a
+                        (lambda ()
+                         (push 3)
+                         (throw 'a))
+                       (lambda (key . args)
+                         (push 4)))
+                     (push 5))
+                   (lambda (key . args)
+                     (push 6)))
+                 (push 7))
+               (lambda (key . args)
+                 (push 8))))
+
+  (throw-test "lazy-catch inside with-throw-handler"
+             '(1 2 3 4 6 8)
+             (catch 'a
+               (lambda ()
+                 (push 1)
+                 (with-throw-handler 'a
+                   (lambda ()
+                     (push 2)
+                     (lazy-catch 'a
+                        (lambda ()
+                         (push 3)
+                         (throw 'a))
+                       (lambda (key . args)
+                         (push 4)))
+                     (push 5))
+                   (lambda (key . args)
+                     (push 6)))
+                 (push 7))
+               (lambda (key . args)
+                 (push 8))))
+
+  (throw-test "throw handlers throwing to each other recursively"
+             '(1 2 3 4 8 6 10 12)
+             (catch #t
+                (lambda ()
+                 (push 1)
+                 (with-throw-handler 'a
+                    (lambda ()
+                     (push 2)
+                     (with-throw-handler 'b
+                       (lambda ()
+                         (push 3)
+                         (with-throw-handler 'c
+                           (lambda ()
+                             (push 4)
+                             (throw 'b)
+                             (push 5))
+                           (lambda (key . args)
+                             (push 6)
+                             (throw 'a)))
+                         (push 7))
+                       (lambda (key . args)
+                         (push 8)
+                         (throw 'c)))
+                     (push 9))
+                   (lambda (key . args)
+                     (push 10)
+                     (throw 'b)))
+                 (push 11))
+               (lambda (key . args)
+                 (push 12))))
+
+  (throw-test "repeat of previous test but with lazy-catch"
+             '(1 2 3 4 8 12)
+             (catch #t
+                (lambda ()
+                 (push 1)
+                 (lazy-catch 'a
+                    (lambda ()
+                     (push 2)
+                     (lazy-catch 'b
+                       (lambda ()
+                         (push 3)
+                         (lazy-catch 'c
+                           (lambda ()
+                             (push 4)
+                             (throw 'b)
+                             (push 5))
+                           (lambda (key . args)
+                             (push 6)
+                             (throw 'a)))
+                         (push 7))
+                       (lambda (key . args)
+                         (push 8)
+                         (throw 'c)))
+                     (push 9))
+                   (lambda (key . args)
+                     (push 10)
+                     (throw 'b)))
+                 (push 11))
+               (lambda (key . args)
+                 (push 12))))
+
+  (throw-test "throw handler throwing to lexically inside catch"
+             '(1 2 7 5 4 6 9)
+             (with-throw-handler 'a
+                                 (lambda ()
+                                   (push 1)
+                                   (catch 'b
+                                          (lambda ()
+                                            (push 2)
+                                            (throw 'a)
+                                            (push 3))
+                                          (lambda (key . args)
+                                            (push 4))
+                                          (lambda (key . args)
+                                            (push 5)))
+                                   (push 6))
+                                 (lambda (key . args)
+                                   (push 7)
+                                   (throw 'b)
+                                   (push 8)))
+             (push 9))
+
+  (throw-test "reuse of same throw handler after lexically inside catch"
+             '(0 1 2 7 5 4 6 7 10)
+             (catch 'b
+               (lambda ()
+                 (push 0)
+                 (with-throw-handler 'a
+                   (lambda ()
+                     (push 1)
+                     (catch 'b
+                       (lambda ()
+                         (push 2)
+                         (throw 'a)
+                         (push 3))
+                       (lambda (key . args)
+                         (push 4))
+                       (lambda (key . args)
+                         (push 5)))
+                     (push 6)
+                     (throw 'a))
+                   (lambda (key . args)
+                     (push 7)
+                     (throw 'b)
+                     (push 8)))
+                 (push 9))
+               (lambda (key . args)
+                 (push 10))))
+
+  (throw-test "again but with two chained throw handlers"
+             '(0 1 11 2 13 7 5 4 12 13 7 10)
+             (catch 'b
+               (lambda ()
+                 (push 0)
+                 (with-throw-handler 'a
+                   (lambda ()
+                     (push 1)
+                     (with-throw-handler 'a
+                       (lambda ()
+                         (push 11)
+                         (catch 'b
+                           (lambda ()
+                             (push 2)
+                             (throw 'a)
+                             (push 3))
+                           (lambda (key . args)
+                             (push 4))
+                           (lambda (key . args)
+                             (push 5)))
+                         (push 12)
+                         (throw 'a))
+                       (lambda (key . args)
+                         (push 13)))
+                     (push 6))
+                   (lambda (key . args)
+                     (push 7)
+                     (throw 'b)))
+                 (push 9))
+               (lambda (key . args)
+                 (push 10))))
+
+  )
 
 (with-test-prefix "false-if-exception"