Back port from 1.20, with these exceptions:

do not remove `signals-error?' and `signals-error?*', and do not
include (ice-9 stack-catch), which is not available yet.

test-suite/lib.scm

@@ -1,28 +1,35 @@
 ;;;; test-suite/lib.scm --- generic support for testing
-;;;; Copyright (C) 1999, 2000 Free Software Foundation, Inc.
-;;;; 
+;;;; Copyright (C) 1999, 2000, 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
 
 (define-module (test-suite lib)
-  #:use-module (test-suite paths))
+  ;;:use-module (ice-9 stack-catch)
+  :use-module (ice-9 regex))
 
 (export
 
+ ;; Exceptions which are commonly being tested for.
+ exception:out-of-range exception:unbound-var
+ exception:wrong-num-args exception:wrong-type-arg
+
  ;; Reporting passes and failures.
- run-test pass-if expect-fail
+ run-test
+ pass-if expect-fail
+ pass-if-exception expect-fail-exception
 
  ;; Naming groups of tests in a regular fashion.
  with-test-prefix with-test-prefix* current-test-prefix
@@ -30,18 +37,16 @@
  ;; Reporting results in various ways.
  register-reporter unregister-reporter reporter-registered?
  make-count-reporter print-counts
- make-log-reporter 
+ make-log-reporter
  full-reporter
  user-reporter
  format-test-name
 
- ;; Finding test input files.
- data-file
-
- ;; Noticing whether an error occurs.
+ ;; The more modern way to check exceptions is to use `run-test-exception',
+ ;; but that uses (ice-9 stack-catch), which is not available yet, so we use
+ ;; these two.  We also prevent `run-test-exception' definition below.
  signals-error? signals-error?*)
 
-
 ;;;; If you're using Emacs's Scheme mode:
 ;;;;   (put 'with-test-prefix 'scheme-indent-function 1)
 
@@ -71,16 +76,35 @@
 ;;;; environment.  All other exceptions thrown by THUNK are considered as
 ;;;; errors.
 ;;;;
-;;;; For convenience, the following macros are provided:
-;;;; * (pass-if name body) is a short form for 
+;;;;
+;;;; Convenience macros for tests expected to pass or fail
+;;;;
+;;;; * (pass-if name body) is a short form for
 ;;;;   (run-test name #t (lambda () body))
-;;;; * (expect-fail name body) is a short form for 
+;;;; * (expect-fail name body) is a short form for
 ;;;;   (run-test name #f (lambda () body))
 ;;;;
-;;;; For example:  
+;;;; For example:
 ;;;;
 ;;;;    (pass-if "integer addition" (= 2 (+ 1 1)))
-
+;;;;
+;;;;
+;;;; Convenience macros to test for exceptions
+;;;;
+;;;; The following macros take exception parameters which are pairs
+;;;; (type . message), where type is a symbol that denotes an exception type
+;;;; like 'wrong-type-arg or 'out-of-range, and message is a string holding a
+;;;; regular expression that describes the error message for the exception
+;;;; like "Argument .* out of range".
+;;;;
+;;;; * (pass-if-exception name exception body) will pass if the execution of
+;;;;   body causes the given exception to be thrown.  If no exception is
+;;;;   thrown, the test fails.  If some other exception is thrown, is is an
+;;;;   error.
+;;;; * (expect-fail-exception name exception body) will pass unexpectedly if
+;;;;   the execution of body causes the given exception to be thrown.  If no
+;;;;   exception is thrown, the test fails expectedly.  If some other
+;;;;   exception is thrown, it is an error.
 
 
 ;;;; TEST NAMES
@@ -98,23 +122,23 @@
 ;;;; - Test names can be compared with EQUAL?.
 ;;;; - Test names can be reliably stored and retrieved with the standard WRITE
 ;;;;   and READ procedures; doing so preserves their identity.
-;;;; 
+;;;;
 ;;;; For example:
-;;;; 
+;;;;
 ;;;;    (pass-if "simple addition" (= 4 (+ 2 2)))
-;;;; 
+;;;;
 ;;;; In that case, the test name is the list ("simple addition").
 ;;;;
 ;;;; The WITH-TEST-PREFIX syntax and WITH-TEST-PREFIX* procedure establish
 ;;;; a prefix for the names of all tests whose results are reported
 ;;;; within their dynamic scope.  For example:
-;;;; 
+;;;;
 ;;;; (begin
 ;;;;   (with-test-prefix "basic arithmetic"
 ;;;;     (pass-if "addition" (= (+ 2 2) 4))
 ;;;;     (pass-if "subtraction" (= (- 4 2) 2)))
 ;;;;   (pass-if "multiplication" (= (* 2 2) 4)))
-;;;; 
+;;;;
 ;;;; In that example, the three test names are:
 ;;;;   ("basic arithmetic" "addition"),
 ;;;;   ("basic arithmetic" "subtraction"), and
@@ -122,7 +146,7 @@
 ;;;;
 ;;;; WITH-TEST-PREFIX can be nested.  Each WITH-TEST-PREFIX postpends
 ;;;; a new element to the current prefix:
-;;;; 
+;;;;
 ;;;; (with-test-prefix "arithmetic"
 ;;;;   (with-test-prefix "addition"
 ;;;;     (pass-if "integer" (= (+ 2 2) 4))
@@ -130,7 +154,7 @@
 ;;;;   (with-test-prefix "subtraction"
 ;;;;     (pass-if "integer" (= (- 2 2) 0))
 ;;;;     (pass-if "complex" (= (- 2+3i 1+2i) 1+1i))))
-;;;; 
+;;;;
 ;;;; The four test names here are:
 ;;;;   ("arithmetic" "addition" "integer")
 ;;;;   ("arithmetic" "addition" "complex")
@@ -140,7 +164,7 @@
 ;;;; To print a name for a human reader, we DISPLAY its elements,
 ;;;; separated by ": ".  So, the last set of test names would be
 ;;;; reported as:
-;;;; 
+;;;;
 ;;;;   arithmetic: addition: integer
 ;;;;   arithmetic: addition: complex
 ;;;;   arithmetic: subtraction: integer
@@ -153,16 +177,16 @@
 
 
 ;;;; REPORTERS
-;;;; 
+;;;;
 ;;;; A reporter is a function which we apply to each test outcome.
 ;;;; Reporters can log results, print interesting results to the
 ;;;; standard output, collect statistics, etc.
-;;;; 
+;;;;
 ;;;; A reporter function takes two mandatory arguments, RESULT and TEST, and
 ;;;; possibly additional arguments depending on RESULT; its return value
 ;;;; is ignored.  RESULT has one of the following forms:
 ;;;;
-;;;; pass         - The test named TEST passed.  
+;;;; pass         - The test named TEST passed.
 ;;;;                Additional arguments are ignored.
 ;;;; upass        - The test named TEST passed unexpectedly.
 ;;;;                Additional arguments are ignored.
@@ -175,7 +199,7 @@
 ;;;;                tested because something else went wrong.
 ;;;;                Additional arguments are ignored.
 ;;;; untested     - The test named TEST was not actually performed, for
-;;;;                example because the test case is not complete yet. 
+;;;;                example because the test case is not complete yet.
 ;;;;                Additional arguments are ignored.
 ;;;; unsupported  - The test named TEST requires some feature that is not
 ;;;;                available in the configured testing environment.
@@ -198,6 +222,16 @@
 ;;;; MISCELLANEOUS
 ;;;;
 
+;;; Define some exceptions which are commonly being tested for.
+(define exception:out-of-range
+  (cons 'out-of-range "^Argument .*out of range"))
+(define exception:unbound-var
+  (cons 'unbound-variable "^Unbound variable"))
+(define exception:wrong-num-args
+  (cons 'wrong-number-of-args "^Wrong number of arguments"))
+(define exception:wrong-type-arg
+  (cons 'wrong-type-arg "^Wrong type argument"))
+
 ;;; Display all parameters to the default output port, followed by a newline.
 (define (display-line . objs)
   (for-each display objs)
@@ -229,27 +263,57 @@
 		(throw 'unresolved)))
 	    (lambda (key . args)
 	      (case key
-		((pass) 
+		((pass)
 		 (report (if expect-pass 'pass 'upass) test-name))
-		((fail) 
+		((fail)
 		 (report (if expect-pass 'fail 'xfail) test-name))
-		((unresolved untested unsupported) 
+		((unresolved untested unsupported)
 		 (report key test-name))
-		((quit) 
+		((quit)
 		 (report 'unresolved test-name)
 		 (quit))
-		(else 
+		(else
 		 (report 'error test-name (cons key args))))))
 	  (set! test-running #f))))
   (set! run-test local-run-test))
 
 ;;; A short form for tests that are expected to pass, taken from Greg.
-(defmacro pass-if (name body)
-  `(run-test ,name #t (lambda () (not (not (begin ,body))))))
+(defmacro pass-if (name body . rest)
+  `(run-test ,name #t (lambda () ,body ,@rest)))
 
 ;;; A short form for tests that are expected to fail, taken from Greg.
-(defmacro expect-fail (name body)
-  `(run-test ,name #f (lambda () ,body)))
+(defmacro expect-fail (name body . rest)
+  `(run-test ,name #f (lambda () ,body ,@rest)))
+
+;;; A helper function to implement the macros that test for exceptions.
+'(define (run-test-exception name exception expect-pass thunk)
+  (run-test name expect-pass
+    (lambda ()
+      (stack-catch (car exception)
+	(lambda () (thunk) #f)
+	(lambda (key proc message . rest)
+	  (cond
+           ;; handle explicit key
+           ((string-match (cdr exception) message)
+            #t)
+           ;; handle `(error ...)' which uses `misc-error' for key and doesn't
+           ;; yet format the message and args (we have to do it here).
+           ((and (eq? 'misc-error (car exception))
+                 (list? rest)
+                 (string-match (cdr exception)
+                               (apply simple-format #f message (car rest))))
+            #t)
+           ;; unhandled; throw again
+           (else
+            (apply throw key proc message rest))))))))
+
+;;; A short form for tests that expect a certain exception to be thrown.
+(defmacro pass-if-exception (name exception body . rest)
+  `(,run-test-exception ,name ,exception #t (lambda () ,body ,@rest)))
+
+;;; A short form for tests expected to fail to throw a certain exception.
+(defmacro expect-fail-exception (name exception body . rest)
+  `(,run-test-exception ,name ,exception #f (lambda () ,body ,@rest)))
 
 
 ;;;; TEST NAMES
@@ -295,7 +359,7 @@
 
 
 ;;;; REPORTERS
-;;;; 
+;;;;
 
 ;;; The global list of reporters.
 (define reporters '())
@@ -336,7 +400,7 @@
 ;;;; User reporters write interesting test results to the standard output.
 
 ;;; The complete list of possible test results.
-(define result-tags 
+(define result-tags
   '((pass        "PASS"        "passes:                 ")
     (fail        "FAIL"        "failures:               ")
     (upass       "UPASS"       "unexpected passes:      ")
@@ -347,7 +411,7 @@
     (error       "ERROR"       "errors:                 ")))
 
 ;;; The list of important test results.
-(define important-result-tags 
+(define important-result-tags
   '(fail upass unresolved error))
 
 ;;; Display a single test result in formatted form to the given port
@@ -377,9 +441,9 @@
     (list
      (lambda (result name . args)
        (let ((pair (assq result counts)))
-	 (if pair 
+	 (if pair
 	     (set-cdr! pair (+ 1 (cdr pair)))
-	     (error "count-reporter: unexpected test result: " 
+	     (error "count-reporter: unexpected test result: "
 		    (cons result (cons name args))))))
      (lambda ()
        (append counts '())))))
@@ -387,7 +451,7 @@
 ;;; Print a count reporter's results nicely.  Pass this function the value
 ;;; returned by a count reporter's RESULTS procedure.
 (define (print-counts results . port?)
-  (let ((port (if (pair? port?) 
+  (let ((port (if (pair? port?)
 		  (car port?)
 		  (current-output-port))))
     (newline port)
@@ -424,17 +488,6 @@
 
 (set! default-reporter full-reporter)
 
-
-;;;; Helping test cases find their files
-
-;;; Returns FILENAME, relative to the directory the test suite data
-;;; files were installed in, and makes sure the file exists.
-(define (data-file filename)
-  (let ((f (in-vicinity datadir filename)))
-    (or (file-exists? f)
-	(error "Test suite data file does not exist: " f))
-    f))
-
 
 ;;;; Detecting whether errors occur