1 |
;;;; test-suite/lib.scm --- generic support for testing |
;;;; test-suite/lib.scm --- generic support for testing |
2 |
;;;; Copyright (C) 1999, 2000 Free Software Foundation, Inc. |
;;;; Copyright (C) 1999, 2000, 2001 Free Software Foundation, Inc. |
3 |
;;;; |
;;;; |
4 |
;;;; This program is free software; you can redistribute it and/or modify |
;;;; This program is free software; you can redistribute it and/or modify |
5 |
;;;; it under the terms of the GNU General Public License as published by |
;;;; it under the terms of the GNU General Public License as published by |
6 |
;;;; the Free Software Foundation; either version 2, or (at your option) |
;;;; the Free Software Foundation; either version 2, or (at your option) |
7 |
;;;; any later version. |
;;;; any later version. |
8 |
;;;; |
;;;; |
9 |
;;;; This program is distributed in the hope that it will be useful, |
;;;; This program is distributed in the hope that it will be useful, |
10 |
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of |
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of |
11 |
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
12 |
;;;; GNU General Public License for more details. |
;;;; GNU General Public License for more details. |
13 |
;;;; |
;;;; |
14 |
;;;; You should have received a copy of the GNU General Public License |
;;;; You should have received a copy of the GNU General Public License |
15 |
;;;; along with this software; see the file COPYING. If not, write to |
;;;; along with this software; see the file COPYING. If not, write to |
16 |
;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, |
;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, |
17 |
;;;; Boston, MA 02111-1307 USA |
;;;; Boston, MA 02111-1307 USA |
18 |
|
|
19 |
(define-module (test-suite lib) |
(define-module (test-suite lib) |
20 |
#:use-module (test-suite paths)) |
;;:use-module (ice-9 stack-catch) |
21 |
|
:use-module (ice-9 regex)) |
22 |
|
|
23 |
(export |
(export |
24 |
|
|
25 |
|
;; Exceptions which are commonly being tested for. |
26 |
|
exception:out-of-range exception:unbound-var |
27 |
|
exception:wrong-num-args exception:wrong-type-arg |
28 |
|
|
29 |
;; Reporting passes and failures. |
;; Reporting passes and failures. |
30 |
run-test pass-if expect-fail |
run-test |
31 |
|
pass-if expect-fail |
32 |
|
pass-if-exception expect-fail-exception |
33 |
|
|
34 |
;; Naming groups of tests in a regular fashion. |
;; Naming groups of tests in a regular fashion. |
35 |
with-test-prefix with-test-prefix* current-test-prefix |
with-test-prefix with-test-prefix* current-test-prefix |
37 |
;; Reporting results in various ways. |
;; Reporting results in various ways. |
38 |
register-reporter unregister-reporter reporter-registered? |
register-reporter unregister-reporter reporter-registered? |
39 |
make-count-reporter print-counts |
make-count-reporter print-counts |
40 |
make-log-reporter |
make-log-reporter |
41 |
full-reporter |
full-reporter |
42 |
user-reporter |
user-reporter |
43 |
format-test-name |
format-test-name |
44 |
|
|
45 |
;; Finding test input files. |
;; The more modern way to check exceptions is to use `run-test-exception', |
46 |
data-file |
;; but that uses (ice-9 stack-catch), which is not available yet, so we use |
47 |
|
;; these two. We also prevent `run-test-exception' definition below. |
|
;; Noticing whether an error occurs. |
|
48 |
signals-error? signals-error?*) |
signals-error? signals-error?*) |
49 |
|
|
|
|
|
50 |
;;;; If you're using Emacs's Scheme mode: |
;;;; If you're using Emacs's Scheme mode: |
51 |
;;;; (put 'with-test-prefix 'scheme-indent-function 1) |
;;;; (put 'with-test-prefix 'scheme-indent-function 1) |
52 |
|
|
76 |
;;;; environment. All other exceptions thrown by THUNK are considered as |
;;;; environment. All other exceptions thrown by THUNK are considered as |
77 |
;;;; errors. |
;;;; errors. |
78 |
;;;; |
;;;; |
79 |
;;;; For convenience, the following macros are provided: |
;;;; |
80 |
;;;; * (pass-if name body) is a short form for |
;;;; Convenience macros for tests expected to pass or fail |
81 |
|
;;;; |
82 |
|
;;;; * (pass-if name body) is a short form for |
83 |
;;;; (run-test name #t (lambda () body)) |
;;;; (run-test name #t (lambda () body)) |
84 |
;;;; * (expect-fail name body) is a short form for |
;;;; * (expect-fail name body) is a short form for |
85 |
;;;; (run-test name #f (lambda () body)) |
;;;; (run-test name #f (lambda () body)) |
86 |
;;;; |
;;;; |
87 |
;;;; For example: |
;;;; For example: |
88 |
;;;; |
;;;; |
89 |
;;;; (pass-if "integer addition" (= 2 (+ 1 1))) |
;;;; (pass-if "integer addition" (= 2 (+ 1 1))) |
90 |
|
;;;; |
91 |
|
;;;; |
92 |
|
;;;; Convenience macros to test for exceptions |
93 |
|
;;;; |
94 |
|
;;;; The following macros take exception parameters which are pairs |
95 |
|
;;;; (type . message), where type is a symbol that denotes an exception type |
96 |
|
;;;; like 'wrong-type-arg or 'out-of-range, and message is a string holding a |
97 |
|
;;;; regular expression that describes the error message for the exception |
98 |
|
;;;; like "Argument .* out of range". |
99 |
|
;;;; |
100 |
|
;;;; * (pass-if-exception name exception body) will pass if the execution of |
101 |
|
;;;; body causes the given exception to be thrown. If no exception is |
102 |
|
;;;; thrown, the test fails. If some other exception is thrown, is is an |
103 |
|
;;;; error. |
104 |
|
;;;; * (expect-fail-exception name exception body) will pass unexpectedly if |
105 |
|
;;;; the execution of body causes the given exception to be thrown. If no |
106 |
|
;;;; exception is thrown, the test fails expectedly. If some other |
107 |
|
;;;; exception is thrown, it is an error. |
108 |
|
|
109 |
|
|
110 |
;;;; TEST NAMES |
;;;; TEST NAMES |
122 |
;;;; - Test names can be compared with EQUAL?. |
;;;; - Test names can be compared with EQUAL?. |
123 |
;;;; - Test names can be reliably stored and retrieved with the standard WRITE |
;;;; - Test names can be reliably stored and retrieved with the standard WRITE |
124 |
;;;; and READ procedures; doing so preserves their identity. |
;;;; and READ procedures; doing so preserves their identity. |
125 |
;;;; |
;;;; |
126 |
;;;; For example: |
;;;; For example: |
127 |
;;;; |
;;;; |
128 |
;;;; (pass-if "simple addition" (= 4 (+ 2 2))) |
;;;; (pass-if "simple addition" (= 4 (+ 2 2))) |
129 |
;;;; |
;;;; |
130 |
;;;; In that case, the test name is the list ("simple addition"). |
;;;; In that case, the test name is the list ("simple addition"). |
131 |
;;;; |
;;;; |
132 |
;;;; The WITH-TEST-PREFIX syntax and WITH-TEST-PREFIX* procedure establish |
;;;; The WITH-TEST-PREFIX syntax and WITH-TEST-PREFIX* procedure establish |
133 |
;;;; a prefix for the names of all tests whose results are reported |
;;;; a prefix for the names of all tests whose results are reported |
134 |
;;;; within their dynamic scope. For example: |
;;;; within their dynamic scope. For example: |
135 |
;;;; |
;;;; |
136 |
;;;; (begin |
;;;; (begin |
137 |
;;;; (with-test-prefix "basic arithmetic" |
;;;; (with-test-prefix "basic arithmetic" |
138 |
;;;; (pass-if "addition" (= (+ 2 2) 4)) |
;;;; (pass-if "addition" (= (+ 2 2) 4)) |
139 |
;;;; (pass-if "subtraction" (= (- 4 2) 2))) |
;;;; (pass-if "subtraction" (= (- 4 2) 2))) |
140 |
;;;; (pass-if "multiplication" (= (* 2 2) 4))) |
;;;; (pass-if "multiplication" (= (* 2 2) 4))) |
141 |
;;;; |
;;;; |
142 |
;;;; In that example, the three test names are: |
;;;; In that example, the three test names are: |
143 |
;;;; ("basic arithmetic" "addition"), |
;;;; ("basic arithmetic" "addition"), |
144 |
;;;; ("basic arithmetic" "subtraction"), and |
;;;; ("basic arithmetic" "subtraction"), and |
146 |
;;;; |
;;;; |
147 |
;;;; WITH-TEST-PREFIX can be nested. Each WITH-TEST-PREFIX postpends |
;;;; WITH-TEST-PREFIX can be nested. Each WITH-TEST-PREFIX postpends |
148 |
;;;; a new element to the current prefix: |
;;;; a new element to the current prefix: |
149 |
;;;; |
;;;; |
150 |
;;;; (with-test-prefix "arithmetic" |
;;;; (with-test-prefix "arithmetic" |
151 |
;;;; (with-test-prefix "addition" |
;;;; (with-test-prefix "addition" |
152 |
;;;; (pass-if "integer" (= (+ 2 2) 4)) |
;;;; (pass-if "integer" (= (+ 2 2) 4)) |
154 |
;;;; (with-test-prefix "subtraction" |
;;;; (with-test-prefix "subtraction" |
155 |
;;;; (pass-if "integer" (= (- 2 2) 0)) |
;;;; (pass-if "integer" (= (- 2 2) 0)) |
156 |
;;;; (pass-if "complex" (= (- 2+3i 1+2i) 1+1i)))) |
;;;; (pass-if "complex" (= (- 2+3i 1+2i) 1+1i)))) |
157 |
;;;; |
;;;; |
158 |
;;;; The four test names here are: |
;;;; The four test names here are: |
159 |
;;;; ("arithmetic" "addition" "integer") |
;;;; ("arithmetic" "addition" "integer") |
160 |
;;;; ("arithmetic" "addition" "complex") |
;;;; ("arithmetic" "addition" "complex") |
164 |
;;;; To print a name for a human reader, we DISPLAY its elements, |
;;;; To print a name for a human reader, we DISPLAY its elements, |
165 |
;;;; separated by ": ". So, the last set of test names would be |
;;;; separated by ": ". So, the last set of test names would be |
166 |
;;;; reported as: |
;;;; reported as: |
167 |
;;;; |
;;;; |
168 |
;;;; arithmetic: addition: integer |
;;;; arithmetic: addition: integer |
169 |
;;;; arithmetic: addition: complex |
;;;; arithmetic: addition: complex |
170 |
;;;; arithmetic: subtraction: integer |
;;;; arithmetic: subtraction: integer |
177 |
|
|
178 |
|
|
179 |
;;;; REPORTERS |
;;;; REPORTERS |
180 |
;;;; |
;;;; |
181 |
;;;; A reporter is a function which we apply to each test outcome. |
;;;; A reporter is a function which we apply to each test outcome. |
182 |
;;;; Reporters can log results, print interesting results to the |
;;;; Reporters can log results, print interesting results to the |
183 |
;;;; standard output, collect statistics, etc. |
;;;; standard output, collect statistics, etc. |
184 |
;;;; |
;;;; |
185 |
;;;; A reporter function takes two mandatory arguments, RESULT and TEST, and |
;;;; A reporter function takes two mandatory arguments, RESULT and TEST, and |
186 |
;;;; possibly additional arguments depending on RESULT; its return value |
;;;; possibly additional arguments depending on RESULT; its return value |
187 |
;;;; is ignored. RESULT has one of the following forms: |
;;;; is ignored. RESULT has one of the following forms: |
188 |
;;;; |
;;;; |
189 |
;;;; pass - The test named TEST passed. |
;;;; pass - The test named TEST passed. |
190 |
;;;; Additional arguments are ignored. |
;;;; Additional arguments are ignored. |
191 |
;;;; upass - The test named TEST passed unexpectedly. |
;;;; upass - The test named TEST passed unexpectedly. |
192 |
;;;; Additional arguments are ignored. |
;;;; Additional arguments are ignored. |
199 |
;;;; tested because something else went wrong. |
;;;; tested because something else went wrong. |
200 |
;;;; Additional arguments are ignored. |
;;;; Additional arguments are ignored. |
201 |
;;;; untested - The test named TEST was not actually performed, for |
;;;; untested - The test named TEST was not actually performed, for |
202 |
;;;; example because the test case is not complete yet. |
;;;; example because the test case is not complete yet. |
203 |
;;;; Additional arguments are ignored. |
;;;; Additional arguments are ignored. |
204 |
;;;; unsupported - The test named TEST requires some feature that is not |
;;;; unsupported - The test named TEST requires some feature that is not |
205 |
;;;; available in the configured testing environment. |
;;;; available in the configured testing environment. |
222 |
;;;; MISCELLANEOUS |
;;;; MISCELLANEOUS |
223 |
;;;; |
;;;; |
224 |
|
|
225 |
|
;;; Define some exceptions which are commonly being tested for. |
226 |
|
(define exception:out-of-range |
227 |
|
(cons 'out-of-range "^Argument .*out of range")) |
228 |
|
(define exception:unbound-var |
229 |
|
(cons 'unbound-variable "^Unbound variable")) |
230 |
|
(define exception:wrong-num-args |
231 |
|
(cons 'wrong-number-of-args "^Wrong number of arguments")) |
232 |
|
(define exception:wrong-type-arg |
233 |
|
(cons 'wrong-type-arg "^Wrong type argument")) |
234 |
|
|
235 |
;;; Display all parameters to the default output port, followed by a newline. |
;;; Display all parameters to the default output port, followed by a newline. |
236 |
(define (display-line . objs) |
(define (display-line . objs) |
237 |
(for-each display objs) |
(for-each display objs) |
263 |
(throw 'unresolved))) |
(throw 'unresolved))) |
264 |
(lambda (key . args) |
(lambda (key . args) |
265 |
(case key |
(case key |
266 |
((pass) |
((pass) |
267 |
(report (if expect-pass 'pass 'upass) test-name)) |
(report (if expect-pass 'pass 'upass) test-name)) |
268 |
((fail) |
((fail) |
269 |
(report (if expect-pass 'fail 'xfail) test-name)) |
(report (if expect-pass 'fail 'xfail) test-name)) |
270 |
((unresolved untested unsupported) |
((unresolved untested unsupported) |
271 |
(report key test-name)) |
(report key test-name)) |
272 |
((quit) |
((quit) |
273 |
(report 'unresolved test-name) |
(report 'unresolved test-name) |
274 |
(quit)) |
(quit)) |
275 |
(else |
(else |
276 |
(report 'error test-name (cons key args)))))) |
(report 'error test-name (cons key args)))))) |
277 |
(set! test-running #f)))) |
(set! test-running #f)))) |
278 |
(set! run-test local-run-test)) |
(set! run-test local-run-test)) |
279 |
|
|
280 |
;;; A short form for tests that are expected to pass, taken from Greg. |
;;; A short form for tests that are expected to pass, taken from Greg. |
281 |
(defmacro pass-if (name body) |
(defmacro pass-if (name body . rest) |
282 |
`(run-test ,name #t (lambda () (not (not (begin ,body)))))) |
`(run-test ,name #t (lambda () ,body ,@rest))) |
283 |
|
|
284 |
;;; A short form for tests that are expected to fail, taken from Greg. |
;;; A short form for tests that are expected to fail, taken from Greg. |
285 |
(defmacro expect-fail (name body) |
(defmacro expect-fail (name body . rest) |
286 |
`(run-test ,name #f (lambda () ,body))) |
`(run-test ,name #f (lambda () ,body ,@rest))) |
287 |
|
|
288 |
|
;;; A helper function to implement the macros that test for exceptions. |
289 |
|
'(define (run-test-exception name exception expect-pass thunk) |
290 |
|
(run-test name expect-pass |
291 |
|
(lambda () |
292 |
|
(stack-catch (car exception) |
293 |
|
(lambda () (thunk) #f) |
294 |
|
(lambda (key proc message . rest) |
295 |
|
(cond |
296 |
|
;; handle explicit key |
297 |
|
((string-match (cdr exception) message) |
298 |
|
#t) |
299 |
|
;; handle `(error ...)' which uses `misc-error' for key and doesn't |
300 |
|
;; yet format the message and args (we have to do it here). |
301 |
|
((and (eq? 'misc-error (car exception)) |
302 |
|
(list? rest) |
303 |
|
(string-match (cdr exception) |
304 |
|
(apply simple-format #f message (car rest)))) |
305 |
|
#t) |
306 |
|
;; unhandled; throw again |
307 |
|
(else |
308 |
|
(apply throw key proc message rest)))))))) |
309 |
|
|
310 |
|
;;; A short form for tests that expect a certain exception to be thrown. |
311 |
|
(defmacro pass-if-exception (name exception body . rest) |
312 |
|
`(,run-test-exception ,name ,exception #t (lambda () ,body ,@rest))) |
313 |
|
|
314 |
|
;;; A short form for tests expected to fail to throw a certain exception. |
315 |
|
(defmacro expect-fail-exception (name exception body . rest) |
316 |
|
`(,run-test-exception ,name ,exception #f (lambda () ,body ,@rest))) |
317 |
|
|
318 |
|
|
319 |
;;;; TEST NAMES |
;;;; TEST NAMES |
359 |
|
|
360 |
|
|
361 |
;;;; REPORTERS |
;;;; REPORTERS |
362 |
;;;; |
;;;; |
363 |
|
|
364 |
;;; The global list of reporters. |
;;; The global list of reporters. |
365 |
(define reporters '()) |
(define reporters '()) |
400 |
;;;; User reporters write interesting test results to the standard output. |
;;;; User reporters write interesting test results to the standard output. |
401 |
|
|
402 |
;;; The complete list of possible test results. |
;;; The complete list of possible test results. |
403 |
(define result-tags |
(define result-tags |
404 |
'((pass "PASS" "passes: ") |
'((pass "PASS" "passes: ") |
405 |
(fail "FAIL" "failures: ") |
(fail "FAIL" "failures: ") |
406 |
(upass "UPASS" "unexpected passes: ") |
(upass "UPASS" "unexpected passes: ") |
411 |
(error "ERROR" "errors: "))) |
(error "ERROR" "errors: "))) |
412 |
|
|
413 |
;;; The list of important test results. |
;;; The list of important test results. |
414 |
(define important-result-tags |
(define important-result-tags |
415 |
'(fail upass unresolved error)) |
'(fail upass unresolved error)) |
416 |
|
|
417 |
;;; Display a single test result in formatted form to the given port |
;;; Display a single test result in formatted form to the given port |
441 |
(list |
(list |
442 |
(lambda (result name . args) |
(lambda (result name . args) |
443 |
(let ((pair (assq result counts))) |
(let ((pair (assq result counts))) |
444 |
(if pair |
(if pair |
445 |
(set-cdr! pair (+ 1 (cdr pair))) |
(set-cdr! pair (+ 1 (cdr pair))) |
446 |
(error "count-reporter: unexpected test result: " |
(error "count-reporter: unexpected test result: " |
447 |
(cons result (cons name args)))))) |
(cons result (cons name args)))))) |
448 |
(lambda () |
(lambda () |
449 |
(append counts '()))))) |
(append counts '()))))) |
451 |
;;; Print a count reporter's results nicely. Pass this function the value |
;;; Print a count reporter's results nicely. Pass this function the value |
452 |
;;; returned by a count reporter's RESULTS procedure. |
;;; returned by a count reporter's RESULTS procedure. |
453 |
(define (print-counts results . port?) |
(define (print-counts results . port?) |
454 |
(let ((port (if (pair? port?) |
(let ((port (if (pair? port?) |
455 |
(car port?) |
(car port?) |
456 |
(current-output-port)))) |
(current-output-port)))) |
457 |
(newline port) |
(newline port) |
489 |
(set! default-reporter full-reporter) |
(set! default-reporter full-reporter) |
490 |
|
|
491 |
|
|
|
;;;; 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)) |
|
|
|
|
|
|
|
492 |
;;;; Detecting whether errors occur |
;;;; Detecting whether errors occur |
493 |
|
|
494 |
;;; (signals-error? KEY BODY ...) |
;;; (signals-error? KEY BODY ...) |