diff options
Diffstat (limited to 'test-suite/tests/exceptions.test')
-rw-r--r-- | test-suite/tests/exceptions.test | 395 |
1 files changed, 395 insertions, 0 deletions
diff --git a/test-suite/tests/exceptions.test b/test-suite/tests/exceptions.test new file mode 100644 index 000000000..391a19dca --- /dev/null +++ b/test-suite/tests/exceptions.test @@ -0,0 +1,395 @@ +;;;; exceptions.test --- tests for Guile's exception handling -*- scheme -*- +;;;; Copyright (C) 2001, 2003, 2004, 2006, 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 + + +(define-module (test-suite exceptions) + #:use-module (test-suite lib)) + +(define-syntax-parameter push + (lambda (stx) + (syntax-violation 'push "push used outside of throw-test" stx))) + +(define-syntax-rule (throw-test title result expr ...) + (pass-if title + (equal? result + (let ((stack '())) + (syntax-parameterize ((push (syntax-rules () + ((push val) + (set! stack (cons val stack)))))) + expr ... + ;;(format #t "~a: ~s~%" title (reverse stack)) + (reverse stack)))))) + +(with-test-prefix "throw/catch" + + (with-test-prefix "wrong type argument" + + (pass-if-exception "(throw 1)" + exception:wrong-type-arg + (throw 1))) + + (with-test-prefix "wrong number of arguments" + + (pass-if-exception "(throw)" + exception:wrong-num-args + (throw)) + + (pass-if-exception "throw 1 / catch 0" + exception:wrong-num-args + (catch 'a + (lambda () (throw 'a)) + (lambda () #f))) + + (pass-if-exception "throw 2 / catch 1" + exception:wrong-num-args + (catch 'a + (lambda () (throw 'a 2)) + (lambda (x) #f))) + + (pass-if-exception "throw 1 / catch 2" + exception:wrong-num-args + (catch 'a + (lambda () (throw 'a)) + (lambda (x y) #f))) + + (pass-if-exception "throw 3 / catch 2" + exception:wrong-num-args + (catch 'a + (lambda () (throw 'a 2 3)) + (lambda (y x) #f))) + + (pass-if-exception "throw 1 / catch 2+" + exception:wrong-num-args + (catch 'a + (lambda () (throw 'a)) + (lambda (x y . rest) #f)))) + + (with-test-prefix "with pre-unwind handler" + + (pass-if "pre-unwind 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 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 "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 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 "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 "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 "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" + + (pass-if (false-if-exception #t)) + (pass-if (not (false-if-exception #f))) + (pass-if (not (false-if-exception (error "xxx")))) + + ;; Not yet working. + ;; + ;; (with-test-prefix "in empty environment" + ;; ;; an environment with no bindings at all + ;; (define empty-environment + ;; (make-module 1)) + ;; + ;; (pass-if "#t" + ;; (eval `(,false-if-exception #t) + ;; empty-environment)) + ;; (pass-if "#f" + ;; (not (eval `(,false-if-exception #f) + ;; empty-environment))) + ;; (pass-if "exception" + ;; (not (eval `(,false-if-exception (,error "xxx")) + ;; empty-environment)))) + ) + +(with-test-prefix "delimited exception handlers" + (define (catch* key thunk) + (let ((tag (make-prompt-tag))) + (call-with-prompt tag + (lambda () + (catch key + (lambda () + (abort-to-prompt tag) + (thunk)) + (lambda args args))) + (lambda (k) k)))) + (pass-if-equal '(foo) + (let ((thunk (catch* 'foo (lambda () (throw 'foo))))) + (thunk))) + (pass-if-equal '(foo) + (let* ((thunk1 (catch* 'foo (lambda () (throw 'foo)))) + (thunk2 (catch* 'bar (lambda () (thunk1))))) + (thunk1))) + (pass-if-equal '(foo) + (let* ((thunk1 (catch* 'foo (lambda () (throw 'foo)))) + (thunk2 (catch* 'bar (lambda () (thunk1))))) + (thunk2))) + (pass-if-equal '(bar) + (let* ((thunk1 (catch* 'foo (lambda () (throw 'bar)))) + (thunk2 (catch* 'bar (lambda () (thunk1))))) + (thunk2)))) |