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,5 +1,5 @@
 ;;;; 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
@@ -17,12 +17,19 @@
 ;;;; 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
@@ -35,13 +42,11 @@
  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,7 +76,9 @@
 ;;;; environment.  All other exceptions thrown by THUNK are considered as
 ;;;; errors.
 ;;;;
-;;;; For convenience, the following macros are provided:
+;;;;
+;;;; 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
@@ -80,7 +87,24 @@
 ;;;; 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
@@ -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)
@@ -244,12 +278,42 @@
   (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
@@ -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