-;;;; exceptions.test -*- scheme -*-
-;;;; Copyright (C) 2001 Free Software Foundation, Inc.
-;;;;
-;;;; This program is free software; you can redistribute it and/or modify
-;;;; it under the terms of the GNU General Public License as published by
-;;;; the Free Software Foundation; either version 2, or (at your option)
-;;;; any later version.
-;;;;
-;;;; This program 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 General Public License for more details.
-;;;;
-;;;; You should have received a copy of the GNU General Public License
-;;;; along with this software; see the file COPYING. If not, write to
-;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
-;;;; Boston, MA 02111-1307 USA
-;;;;
-;;;; As a special exception, the Free Software Foundation gives permission
-;;;; for additional uses of the text contained in its release of GUILE.
-;;;;
-;;;; The exception is that, if you link the GUILE library with other files
-;;;; to produce an executable, this does not by itself cause the
-;;;; resulting executable to be covered by the GNU General Public License.
-;;;; Your use of that executable is in no way restricted on account of
-;;;; linking the GUILE library code into it.
-;;;;
-;;;; This exception does not however invalidate any other reasons why
-;;;; the executable file might be covered by the GNU General Public License.
-;;;;
-;;;; This exception applies only to the code released by the
-;;;; Free Software Foundation under the name GUILE. If you copy
-;;;; code from other Free Software Foundation releases into a copy of
-;;;; GUILE, as the General Public License permits, the exception does
-;;;; not apply to the code that you add in this way. To avoid misleading
-;;;; anyone as to the status of such modified files, you must delete
-;;;; this exception notice from them.
-;;;;
-;;;; If you write modifications of your own for GUILE, it is your choice
-;;;; whether to permit this exception to apply to your modifications.
-;;;; If you do not wish that, delete this exception notice.
-
-;;;; Commentary:
-
-;;; All tests should use `expect-exception' (aliased to `goad' for
-;;; brevity). Tests that fail (i.e., do NOT cause exception should be
-;;; marked with a preceding line "no exception on DATE", where DATE is
-;;; when you found the failure. If guile is fixed so that the test
-;;; passes, do not delete the comment, but instead append "fixed on
-;;; DATE" w/ the fix date. If the test itself changes (due to a change
-;;; in the specification, for example), append "test amended on DATE"
-;;; and some explanatory text. You can delete comments (and move the
-;;; test up into the clump of uncommented tests) when the dates become
-;;; very old.
-
-;;;; Code:
-
-(use-modules (test-suite lib) (ice-9 regex) (ice-9 common-list))
-
-(defmacro expect-exception (name-snippet expression)
- `(pass-if (with-output-to-string
- (lambda ()
- (for-each display
- (list
- "`"
- (let ((x (symbol->string ',name-snippet)))
- (substring x 2 (string-length x)))
- "' expected but not thrown: "))
- (write ',expression)))
- (catch #t
- (lambda () ,expression #f) ; conniving falsehood!
- (lambda args
- ;; squeeze value to `#t'
- (not (notany (lambda (x)
- (and (string? x)
- (string-match ,name-snippet x)))
- args))))))
-
-(define goad expect-exception)
-
-;; Exception messages
-;; Ideally, we would mine these out of libguile/error.[hc], etc.
-;; (Someday, when guile is re-implemented in Scheme....)
-
-(define x:unbound-var "[Uu]nbound variable")
-(define x:bad-var "[Bb]ad variable")
-(define x:bad-formals "[Bb]ad formals")
-(define x:bad-bindings "[Bb]ad bindings")
-(define x:bad-body "[Bb]ad body")
-(define x:bad/missing-clauses "[Bb]ad or missing clauses")
-(define x:missing/extra-expr "[Mm]issing or extra expression")
-(define x:wrong-num-args "[Ww]rong number of arguments")
-(define x:wrong-type-arg "[Ww]rong type argument")
-
-;; This is to encourage people to write tests.
-
-(define x:hm "[Hh]m") ;-D
- (define x:bad "[Bb]ad") ;-D
- (define x:sick "[Ss]ick") ;-D
- (define x:wrong "[Ww]rong") ;-D
- (define x:stupid "[Ss]tupid") ;-D
- (define x:strange "[Ss]trange") ;-D
- (define x:unlikely "[Uu]nlikely") ;-D
- (define x:inelegant "[Ii]nelegant") ;-D
- (define x:suboptimal "[Ss]uboptimal") ;-D
- (define x:bletcherous "[Bb]letcherous") ;-D h a t - t h e - ?!?
-
-;; Tests
-
-(with-test-prefix "syntax"
- (with-test-prefix "let"
- (goad x:bad-body (let))
- (goad x:bad-body (let 1))
- (goad x:bad-body (let ()))
- (goad x:bad-body (let (x)))
- (goad x:bad-bindings (let (x) 1)) ; maybe these should go under bindings?
- (goad x:bad-bindings (let ((x)) 3))
- (goad x:bad-bindings (let ((x 1) y) x))
- (goad x:bad-body (let x ()))
- (goad x:bad-body (let x (y)))
-
- ;; no exception on 2001-02-22
- (goad x:bad-bindings (let ((x 1) (x 2)) x))
-
- ;; Add more (syntax let) exceptions here.
- )
- (with-test-prefix "cond"
- (goad x:bad/missing-clauses (cond))
- (goad x:bad/missing-clauses (cond #t))
- (goad x:bad/missing-clauses (cond 1))
- (goad x:bad/missing-clauses (cond 1 2))
- (goad x:bad/missing-clauses (cond 1 2 3))
- (goad x:bad/missing-clauses (cond 1 2 3 4))
- (goad x:bad/missing-clauses (cond ()))
- (goad x:bad/missing-clauses (cond () 1))
- (goad x:bad/missing-clauses (cond (1) 1))
- ;; Add more (syntax cond) exceptions here.
- )
- (with-test-prefix "if"
- (goad x:missing/extra-expr (if))
- (goad x:missing/extra-expr (if 1 2 3 4))
- ;; Add more (syntax if) exceptions here.
- )
- (with-test-prefix "define"
- (goad x:missing/extra-expr (define))
- ;; Add more (syntax define) exceptions here.
- )
- ;; Add more (syntax) exceptions here.
- )
-
-(with-test-prefix "bindings"
- (goad x:unbound-var unlikely-to-be-bound)
- (goad x:bad-var (set! "some-string" #t))
- (goad x:bad-var (set! 1 #t))
- (goad x:bad-var (set! #t #f))
- (goad x:bad-var (set! #f #t))
- (goad x:bad-var (set! #\space 'the-final-frontier))
- (goad x:wrong-type-arg (set! (symbol->string 'safe) 1))
- (goad x:wrong-type-arg (set! '"abc" 1)) ; from r5rs
- (goad x:bad-var (set! "abc" 1))
- (goad x:wrong-type-arg (set! '145932 1))
- (goad x:bad-var (set! 145932 1))
- (goad x:wrong-type-arg (set! '#t 1))
- (goad x:wrong-type-arg (set! '#f 1))
- (goad x:bad-body (let))
- (goad x:bad-var (let ((1 2)) 3))
-
- ;; no exception on 2001-02-22
- (goad x:bad-var (string-set! (symbol->string 'abc) 1 #\space))
- ;; no exception on 2001-02-22
- (goad x:bad-var (string-set! "abc" 1 #\space))
-
- ;; Add more (bindings) exceptions here.
- )
-
-(with-test-prefix "lambda"
-
- (goad x:bad-formals (lambda (x 1) 2))
- (goad x:bad-formals (lambda (1 x) 2))
- (goad x:bad-formals (lambda (x "a") 2))
- (goad x:bad-formals (lambda ("a" x) 2))
- (goad x:bad-formals (lambda (x x) 1))
- (goad x:bad-formals (lambda (x x x) 1))
-
- (with-test-prefix "cond-arrow-proc"
- (goad x:bad-formals (cond (1 => (lambda (x 1) 2))))
- ;; Add more (lambda cond-arrow-proc) exceptions here.
- )
-
- ;; Add more (lambda) exceptions here.
- )
-
-(with-test-prefix "application"
- (goad x:wrong-type-arg (+ 1 #f))
- (goad x:wrong-type-arg (+ "1" 2))
- (goad x:wrong-num-args (let ((x (lambda (a b) (+ a b)))) (x 3)))
- ;; Add more (application) exceptions here.
- )
-
-;;; exceptions.test ends here
+;;;; 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
+
+
+(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"
+
+ (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))))
+ )
HCoop / bpt / guile.git / blobdiff