From 5570bfb40d868c2e3ee2837e1a53221db27f9ace Mon Sep 17 00:00:00 2001 From: Thien-Thi Nguyen Date: Sat, 9 Feb 2002 23:10:56 +0000 Subject: [PATCH] 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 | 163 ++++++++++++++++++++++++++++++--------------- 1 file changed, 108 insertions(+), 55 deletions(-) diff --git a/test-suite/lib.scm b/test-suite/lib.scm index c69b18ba6..430c2c22d 100644 --- a/test-suite/lib.scm +++ b/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