X-Git-Url: http://git.hcoop.net/bpt/guile.git/blobdiff_plain/9bc915bb075c1a72a45cbd8a5dc52a36d945834a..0d96acac33b867f45203e0a0c7b6e87a3a09cdad:/test-suite/tests/exceptions.test diff --git a/test-suite/tests/exceptions.test b/test-suite/tests/exceptions.test index 05f464563..a839b68de 100644 --- a/test-suite/tests/exceptions.test +++ b/test-suite/tests/exceptions.test @@ -1,10 +1,10 @@ ;;;; exceptions.test --- tests for Guile's exception handling -*- scheme -*- -;;;; Copyright (C) 2001, 2003, 2004 Free Software Foundation, Inc. +;;;; 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 2.1 of the License, or (at your option) any later version. +;;;; 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 @@ -13,11 +13,26 @@ ;;;; ;;;; 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., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA (use-modules (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" @@ -60,25 +75,293 @@ exception:wrong-num-args (catch 'a (lambda () (throw 'a)) - (lambda (x y . rest) #f))))) + (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")))) - - (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))))) + + ;; 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)))) + )