summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorNeil Jerram <neil@ossau.uklinux.net>2006-02-04 14:36:43 +0000
committerNeil Jerram <neil@ossau.uklinux.net>2006-02-04 14:36:43 +0000
commit26beee1e746303f49d0f70673fe2327a8fed6bb7 (patch)
treed7546ed3350ae8efec575799ee0c4b0682dc5556
parent43e01b1ee350c823505d1397a306c8e1bfa31469 (diff)
downloadguile-26beee1e746303f49d0f70673fe2327a8fed6bb7.tar.gz
19 new test cases.
(throw-test): New macro for testing catches and throw handlers.
-rw-r--r--test-suite/ChangeLog5
-rw-r--r--test-suite/tests/exceptions.test393
2 files changed, 397 insertions, 1 deletions
diff --git a/test-suite/ChangeLog b/test-suite/ChangeLog
index c095c6c5f..29ab92c83 100644
--- 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 db52126b6..565cc8fea 100644
--- 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"