guile/test-suite/tests/exceptions.test

;;;; 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-equal title 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))))