mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-30 03:40:34 +02:00
Code Activity

19 new test cases.

Browse source 
(throw-test): New macro for testing catches and throw handlers.
This commit is contained in:
Neil Jerram 2006-02-04 14:36:43 +00:00
parent 43e01b1ee3
commit 26beee1e74
2 changed files with 397 additions and 1 deletions
Download patch file Download diff file Expand all files Collapse all files

5
test-suite/ChangeLog
View file

@ -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.

393
test-suite/tests/exceptions.test
View file

@ -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"