| blob | 111d470e18efab26fb3592a6a1315c205cb64a16 |
1 ;;;; test-suite/lib.scm --- generic support for testing
2 ;;;; Copyright (C) 1999, 2000, 2001, 2004, 2006, 2007 Free Software Foundation, Inc.
3 ;;;;
4 ;;;; 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
6 ;;;; the Free Software Foundation; either version 2, or (at your option)
7 ;;;; any later version.
8 ;;;;
9 ;;;; This program is distributed in the hope that it will be useful,
10 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
11 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
12 ;;;; GNU General Public License for more details.
13 ;;;;
14 ;;;; 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
16 ;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
17 ;;;; Boston, MA 02110-1301 USA
19 (define-module (test-suite lib)
20 :use-module (ice-9 stack-catch)
21 :use-module (ice-9 regex)
22 :export (
24 ;; Exceptions which are commonly being tested for.
25 exception:bad-variable
26 exception:missing-expression
27 exception:out-of-range exception:unbound-var
28 exception:used-before-defined
29 exception:wrong-num-args exception:wrong-type-arg
30 exception:numerical-overflow
31 exception:struct-set!-denied
32 exception:miscellaneous-error
33 exception:string-contains-nul
35 ;; Reporting passes and failures.
36 run-test
37 pass-if expect-fail
38 pass-if-exception expect-fail-exception
40 ;; Naming groups of tests in a regular fashion.
41 with-test-prefix with-test-prefix* current-test-prefix
42 format-test-name
44 ;; Reporting results in various ways.
45 register-reporter unregister-reporter reporter-registered?
46 make-count-reporter print-counts
47 make-log-reporter
48 full-reporter
49 user-reporter))
52 ;;;; If you're using Emacs's Scheme mode:
53 ;;;; (put 'with-test-prefix 'scheme-indent-function 1)
55 \f
56 ;;;; CORE FUNCTIONS
57 ;;;;
58 ;;;; The function (run-test name expected-result thunk) is the heart of the
59 ;;;; testing environment. The first parameter NAME is a unique name for the
60 ;;;; test to be executed (for an explanation of this parameter see below under
61 ;;;; TEST NAMES). The second parameter EXPECTED-RESULT is a boolean value
62 ;;;; that indicates whether the corresponding test is expected to pass. If
63 ;;;; EXPECTED-RESULT is #t the test is expected to pass, if EXPECTED-RESULT is
64 ;;;; #f the test is expected to fail. Finally, THUNK is the function that
65 ;;;; actually performs the test. For example:
66 ;;;;
67 ;;;; (run-test "integer addition" #t (lambda () (= 2 (+ 1 1))))
68 ;;;;
69 ;;;; To report success, THUNK should either return #t or throw 'pass. To
70 ;;;; report failure, THUNK should either return #f or throw 'fail. If THUNK
71 ;;;; returns a non boolean value or throws 'unresolved, this indicates that
72 ;;;; the test did not perform as expected. For example the property that was
73 ;;;; to be tested could not be tested because something else went wrong.
74 ;;;; THUNK may also throw 'untested to indicate that the test was deliberately
75 ;;;; not performed, for example because the test case is not complete yet.
76 ;;;; Finally, if THUNK throws 'unsupported, this indicates that this test
77 ;;;; requires some feature that is not available in the configured testing
78 ;;;; environment. All other exceptions thrown by THUNK are considered as
79 ;;;; errors.
80 ;;;;
81 ;;;;
82 ;;;; Convenience macros for tests expected to pass or fail
83 ;;;;
84 ;;;; * (pass-if name body) is a short form for
85 ;;;; (run-test name #t (lambda () body))
86 ;;;; * (expect-fail name body) is a short form for
87 ;;;; (run-test name #f (lambda () body))
88 ;;;;
89 ;;;; For example:
90 ;;;;
91 ;;;; (pass-if "integer addition" (= 2 (+ 1 1)))
92 ;;;;
93 ;;;;
94 ;;;; Convenience macros to test for exceptions
95 ;;;;
96 ;;;; The following macros take exception parameters which are pairs
97 ;;;; (type . message), where type is a symbol that denotes an exception type
98 ;;;; like 'wrong-type-arg or 'out-of-range, and message is a string holding a
99 ;;;; regular expression that describes the error message for the exception
100 ;;;; like "Argument .* out of range".
101 ;;;;
102 ;;;; * (pass-if-exception name exception body) will pass if the execution of
103 ;;;; body causes the given exception to be thrown. If no exception is
104 ;;;; thrown, the test fails. If some other exception is thrown, is is an
105 ;;;; error.
106 ;;;; * (expect-fail-exception name exception body) will pass unexpectedly if
107 ;;;; the execution of body causes the given exception to be thrown. If no
108 ;;;; exception is thrown, the test fails expectedly. If some other
109 ;;;; exception is thrown, it is an error.
111 \f
112 ;;;; TEST NAMES
113 ;;;;
114 ;;;; Every test in the test suite has a unique name, to help
115 ;;;; developers find tests that are failing (or unexpectedly passing),
116 ;;;; and to help gather statistics.
117 ;;;;
118 ;;;; A test name is a list of printable objects. For example:
119 ;;;; ("ports.scm" "file" "read and write back list of strings")
120 ;;;; ("ports.scm" "pipe" "read")
121 ;;;;
122 ;;;; Test names may contain arbitrary objects, but they always have
123 ;;;; the following properties:
124 ;;;; - Test names can be compared with EQUAL?.
125 ;;;; - Test names can be reliably stored and retrieved with the standard WRITE
126 ;;;; and READ procedures; doing so preserves their identity.
127 ;;;;
128 ;;;; For example:
129 ;;;;
130 ;;;; (pass-if "simple addition" (= 4 (+ 2 2)))
131 ;;;;
132 ;;;; In that case, the test name is the list ("simple addition").
133 ;;;;
134 ;;;; In the case of simple tests the expression that is tested would often
135 ;;;; suffice as a test name by itself. Therefore, the convenience macros
136 ;;;; pass-if and expect-fail provide a shorthand notation that allows to omit
137 ;;;; a test name in such cases.
138 ;;;;
139 ;;;; * (pass-if expression) is a short form for
140 ;;;; (run-test 'expression #t (lambda () expression))
141 ;;;; * (expect-fail expression) is a short form for
142 ;;;; (run-test 'expression #f (lambda () expression))
143 ;;;;
144 ;;;; For example:
145 ;;;;
146 ;;;; (pass-if (= 2 (+ 1 1)))
147 ;;;;
148 ;;;; The WITH-TEST-PREFIX syntax and WITH-TEST-PREFIX* procedure establish
149 ;;;; a prefix for the names of all tests whose results are reported
150 ;;;; within their dynamic scope. For example:
151 ;;;;
152 ;;;; (begin
153 ;;;; (with-test-prefix "basic arithmetic"
154 ;;;; (pass-if "addition" (= (+ 2 2) 4))
155 ;;;; (pass-if "subtraction" (= (- 4 2) 2)))
156 ;;;; (pass-if "multiplication" (= (* 2 2) 4)))
157 ;;;;
158 ;;;; In that example, the three test names are:
159 ;;;; ("basic arithmetic" "addition"),
160 ;;;; ("basic arithmetic" "subtraction"), and
161 ;;;; ("multiplication").
162 ;;;;
163 ;;;; WITH-TEST-PREFIX can be nested. Each WITH-TEST-PREFIX postpends
164 ;;;; a new element to the current prefix:
165 ;;;;
166 ;;;; (with-test-prefix "arithmetic"
167 ;;;; (with-test-prefix "addition"
168 ;;;; (pass-if "integer" (= (+ 2 2) 4))
169 ;;;; (pass-if "complex" (= (+ 2+3i 4+5i) 6+8i)))
170 ;;;; (with-test-prefix "subtraction"
171 ;;;; (pass-if "integer" (= (- 2 2) 0))
172 ;;;; (pass-if "complex" (= (- 2+3i 1+2i) 1+1i))))
173 ;;;;
174 ;;;; The four test names here are:
175 ;;;; ("arithmetic" "addition" "integer")
176 ;;;; ("arithmetic" "addition" "complex")
177 ;;;; ("arithmetic" "subtraction" "integer")
178 ;;;; ("arithmetic" "subtraction" "complex")
179 ;;;;
180 ;;;; To print a name for a human reader, we DISPLAY its elements,
181 ;;;; separated by ": ". So, the last set of test names would be
182 ;;;; reported as:
183 ;;;;
184 ;;;; arithmetic: addition: integer
185 ;;;; arithmetic: addition: complex
186 ;;;; arithmetic: subtraction: integer
187 ;;;; arithmetic: subtraction: complex
188 ;;;;
189 ;;;; The Guile benchmarks use with-test-prefix to include the name of
190 ;;;; the source file containing the test in the test name, to help
191 ;;;; developers to find failing tests, and to provide each file with its
192 ;;;; own namespace.
194 \f
195 ;;;; REPORTERS
196 ;;;;
197 ;;;; A reporter is a function which we apply to each test outcome.
198 ;;;; Reporters can log results, print interesting results to the
199 ;;;; standard output, collect statistics, etc.
200 ;;;;
201 ;;;; A reporter function takes two mandatory arguments, RESULT and TEST, and
202 ;;;; possibly additional arguments depending on RESULT; its return value
203 ;;;; is ignored. RESULT has one of the following forms:
204 ;;;;
205 ;;;; pass - The test named TEST passed.
206 ;;;; Additional arguments are ignored.
207 ;;;; upass - The test named TEST passed unexpectedly.
208 ;;;; Additional arguments are ignored.
209 ;;;; fail - The test named TEST failed.
210 ;;;; Additional arguments are ignored.
211 ;;;; xfail - The test named TEST failed, as expected.
212 ;;;; Additional arguments are ignored.
213 ;;;; unresolved - The test named TEST did not perform as expected, for
214 ;;;; example the property that was to be tested could not be
215 ;;;; tested because something else went wrong.
216 ;;;; Additional arguments are ignored.
217 ;;;; untested - The test named TEST was not actually performed, for
218 ;;;; example because the test case is not complete yet.
219 ;;;; Additional arguments are ignored.
220 ;;;; unsupported - The test named TEST requires some feature that is not
221 ;;;; available in the configured testing environment.
222 ;;;; Additional arguments are ignored.
223 ;;;; error - An error occurred while the test named TEST was
224 ;;;; performed. Since this result means that the system caught
225 ;;;; an exception it could not handle, the exception arguments
226 ;;;; are passed as additional arguments.
227 ;;;;
228 ;;;; This library provides some standard reporters for logging results
229 ;;;; to a file, reporting interesting results to the user, and
230 ;;;; collecting totals.
231 ;;;;
232 ;;;; You can use the REGISTER-REPORTER function and friends to add
233 ;;;; whatever reporting functions you like. If you don't register any
234 ;;;; reporters, the library uses FULL-REPORTER, which simply writes
235 ;;;; all results to the standard output.
237 \f
238 ;;;; MISCELLANEOUS
239 ;;;;
241 ;;; Define some exceptions which are commonly being tested for.
242 (define exception:bad-variable
243 (cons 'syntax-error "Bad variable"))
244 (define exception:missing-expression
245 (cons 'misc-error "^missing or extra expression"))
246 (define exception:out-of-range
247 (cons 'out-of-range "^.*out of range"))
248 (define exception:unbound-var
249 (cons 'unbound-variable "^Unbound variable"))
250 (define exception:used-before-defined
251 (cons 'unbound-variable "^Variable used before given a value"))
252 (define exception:wrong-num-args
253 (cons 'wrong-number-of-args "^Wrong number of arguments"))
254 (define exception:wrong-type-arg
255 (cons 'wrong-type-arg "^Wrong type"))
256 (define exception:numerical-overflow
257 (cons 'numerical-overflow "^Numerical overflow"))
258 (define exception:struct-set!-denied
259 (cons 'misc-error "^set! denied for field"))
260 (define exception:miscellaneous-error
261 (cons 'misc-error "^.*"))
263 ;; as per throw in scm_to_locale_stringn()
264 (define exception:string-contains-nul
265 (cons 'misc-error "^string contains #\\\\nul character"))
268 ;;; Display all parameters to the default output port, followed by a newline.
269 (define (display-line . objs)
270 (for-each display objs)
271 (newline))
273 ;;; Display all parameters to the given output port, followed by a newline.
274 (define (display-line-port port . objs)
275 (for-each (lambda (obj) (display obj port)) objs)
276 (newline port))
278 \f
279 ;;;; CORE FUNCTIONS
280 ;;;;
282 ;;; The central testing routine.
283 ;;; The idea is taken from Greg, the GNUstep regression test environment.
284 (define run-test #f)
285 (let ((test-running #f))
286 (define (local-run-test name expect-pass thunk)
287 (if test-running
288 (error "Nested calls to run-test are not permitted.")
289 (let ((test-name (full-name name)))
290 (set! test-running #t)
291 (catch #t
292 (lambda ()
293 (let ((result (thunk)))
294 (if (eq? result #t) (throw 'pass))
295 (if (eq? result #f) (throw 'fail))
296 (throw 'unresolved)))
297 (lambda (key . args)
298 (case key
299 ((pass)
300 (report (if expect-pass 'pass 'upass) test-name))
301 ((fail)
302 (report (if expect-pass 'fail 'xfail) test-name))
303 ((unresolved untested unsupported)
304 (report key test-name))
305 ((quit)
306 (report 'unresolved test-name)
307 (quit))
308 (else
309 (report 'error test-name (cons key args))))))
310 (set! test-running #f))))
311 (set! run-test local-run-test))
313 ;;; A short form for tests that are expected to pass, taken from Greg.
314 (defmacro pass-if (name . rest)
315 (if (and (null? rest) (pair? name))
316 ;; presume this is a simple test, i.e. (pass-if (even? 2))
317 ;; where the body should also be the name.
318 `(run-test ',name #t (lambda () ,name))
319 `(run-test ,name #t (lambda () ,@rest))))
321 ;;; A short form for tests that are expected to fail, taken from Greg.
322 (defmacro expect-fail (name . rest)
323 (if (and (null? rest) (pair? name))
324 ;; presume this is a simple test, i.e. (expect-fail (even? 2))
325 ;; where the body should also be the name.
326 `(run-test ',name #f (lambda () ,name))
327 `(run-test ,name #f (lambda () ,@rest))))
329 ;;; A helper function to implement the macros that test for exceptions.
330 (define (run-test-exception name exception expect-pass thunk)
331 (run-test name expect-pass
332 (lambda ()
333 (stack-catch (car exception)
334 (lambda () (thunk) #f)
335 (lambda (key proc message . rest)
336 (cond
337 ;; handle explicit key
338 ((string-match (cdr exception) message)
339 #t)
340 ;; handle `(error ...)' which uses `misc-error' for key and doesn't
341 ;; yet format the message and args (we have to do it here).
342 ((and (eq? 'misc-error (car exception))
343 (list? rest)
344 (string-match (cdr exception)
345 (apply simple-format #f message (car rest))))
346 #t)
347 ;; handle syntax errors which use `syntax-error' for key and don't
348 ;; yet format the message and args (we have to do it here).
349 ((and (eq? 'syntax-error (car exception))
350 (list? rest)
351 (string-match (cdr exception)
352 (apply simple-format #f message (car rest))))
353 #t)
354 ;; unhandled; throw again
355 (else
356 (apply throw key proc message rest))))))))
358 ;;; A short form for tests that expect a certain exception to be thrown.
359 (defmacro pass-if-exception (name exception body . rest)
360 `(,run-test-exception ,name ,exception #t (lambda () ,body ,@rest)))
362 ;;; A short form for tests expected to fail to throw a certain exception.
363 (defmacro expect-fail-exception (name exception body . rest)
364 `(,run-test-exception ,name ,exception #f (lambda () ,body ,@rest)))
366 \f
367 ;;;; TEST NAMES
368 ;;;;
370 ;;;; Turn a test name into a nice human-readable string.
371 (define (format-test-name name)
372 (call-with-output-string
373 (lambda (port)
374 (let loop ((name name)
375 (separator ""))
376 (if (pair? name)
377 (begin
378 (display separator port)
379 (display (car name) port)
380 (loop (cdr name) ": ")))))))
382 ;;;; For a given test-name, deliver the full name including all prefixes.
383 (define (full-name name)
384 (append (current-test-prefix) (list name)))
386 ;;; A fluid containing the current test prefix, as a list.
387 (define prefix-fluid (make-fluid))
388 (fluid-set! prefix-fluid '())
389 (define (current-test-prefix)
390 (fluid-ref prefix-fluid))
392 ;;; Postpend PREFIX to the current name prefix while evaluting THUNK.
393 ;;; The name prefix is only changed within the dynamic scope of the
394 ;;; call to with-test-prefix*. Return the value returned by THUNK.
395 (define (with-test-prefix* prefix thunk)
396 (with-fluids ((prefix-fluid
397 (append (fluid-ref prefix-fluid) (list prefix))))
398 (thunk)))
400 ;;; (with-test-prefix PREFIX BODY ...)
401 ;;; Postpend PREFIX to the current name prefix while evaluating BODY ...
402 ;;; The name prefix is only changed within the dynamic scope of the
403 ;;; with-test-prefix expression. Return the value returned by the last
404 ;;; BODY expression.
405 (defmacro with-test-prefix (prefix . body)
406 `(with-test-prefix* ,prefix (lambda () ,@body)))
408 \f
409 ;;;; REPORTERS
410 ;;;;
412 ;;; The global list of reporters.
413 (define reporters '())
415 ;;; The default reporter, to be used only if no others exist.
416 (define default-reporter #f)
418 ;;; Add the procedure REPORTER to the current set of reporter functions.
419 ;;; Signal an error if that reporter procedure object is already registered.
420 (define (register-reporter reporter)
421 (if (memq reporter reporters)
422 (error "register-reporter: reporter already registered: " reporter))
423 (set! reporters (cons reporter reporters)))
425 ;;; Remove the procedure REPORTER from the current set of reporter
426 ;;; functions. Signal an error if REPORTER is not currently registered.
427 (define (unregister-reporter reporter)
428 (if (memq reporter reporters)
429 (set! reporters (delq! reporter reporters))
430 (error "unregister-reporter: reporter not registered: " reporter)))
432 ;;; Return true iff REPORTER is in the current set of reporter functions.
433 (define (reporter-registered? reporter)
434 (if (memq reporter reporters) #t #f))
436 ;;; Send RESULT to all currently registered reporter functions.
437 (define (report . args)
438 (if (pair? reporters)
439 (for-each (lambda (reporter) (apply reporter args))
440 reporters)
441 (apply default-reporter args)))
443 \f
444 ;;;; Some useful standard reporters:
445 ;;;; Count reporters count the occurrence of each test result type.
446 ;;;; Log reporters write all test results to a given log file.
447 ;;;; Full reporters write all test results to the standard output.
448 ;;;; User reporters write interesting test results to the standard output.
450 ;;; The complete list of possible test results.
451 (define result-tags
452 '((pass "PASS" "passes: ")
453 (fail "FAIL" "failures: ")
454 (upass "UPASS" "unexpected passes: ")
455 (xfail "XFAIL" "expected failures: ")
456 (unresolved "UNRESOLVED" "unresolved test cases: ")
457 (untested "UNTESTED" "untested test cases: ")
458 (unsupported "UNSUPPORTED" "unsupported test cases: ")
459 (error "ERROR" "errors: ")))
461 ;;; The list of important test results.
462 (define important-result-tags
463 '(fail upass unresolved error))
465 ;;; Display a single test result in formatted form to the given port
466 (define (print-result port result name . args)
467 (let* ((tag (assq result result-tags))
468 (label (if tag (cadr tag) #f)))
469 (if label
470 (begin
471 (display label port)
472 (display ": " port)
473 (display (format-test-name name) port)
474 (if (pair? args)
475 (begin
476 (display " - arguments: " port)
477 (write args port)))
478 (newline port))
479 (error "(test-suite lib) FULL-REPORTER: unrecognized result: "
480 result))))
482 ;;; Return a list of the form (COUNTER RESULTS), where:
483 ;;; - COUNTER is a reporter procedure, and
484 ;;; - RESULTS is a procedure taking no arguments which returns the
485 ;;; results seen so far by COUNTER. The return value is an alist
486 ;;; mapping outcome symbols (`pass', `fail', etc.) onto counts.
487 (define (make-count-reporter)
488 (let ((counts (map (lambda (tag) (cons (car tag) 0)) result-tags)))
489 (list
490 (lambda (result name . args)
491 (let ((pair (assq result counts)))
492 (if pair
493 (set-cdr! pair (+ 1 (cdr pair)))
494 (error "count-reporter: unexpected test result: "
495 (cons result (cons name args))))))
496 (lambda ()
497 (append counts '())))))
499 ;;; Print a count reporter's results nicely. Pass this function the value
500 ;;; returned by a count reporter's RESULTS procedure.
501 (define (print-counts results . port?)
502 (let ((port (if (pair? port?)
503 (car port?)
504 (current-output-port))))
505 (newline port)
506 (display-line-port port "Totals for this test run:")
507 (for-each
508 (lambda (tag)
509 (let ((result (assq (car tag) results)))
510 (if result
511 (display-line-port port (caddr tag) (cdr result))
512 (display-line-port port
513 "Test suite bug: "
514 "no total available for `" (car tag) "'"))))
515 result-tags)
516 (newline port)))
518 ;;; Return a reporter procedure which prints all results to the file
519 ;;; FILE, in human-readable form. FILE may be a filename, or a port.
520 (define (make-log-reporter file)
521 (let ((port (if (output-port? file) file
522 (open-output-file file))))
523 (lambda args
524 (apply print-result port args)
525 (force-output port))))
527 ;;; A reporter that reports all results to the user.
528 (define (full-reporter . args)
529 (apply print-result (current-output-port) args))
531 ;;; A reporter procedure which shows interesting results (failures,
532 ;;; unexpected passes etc.) to the user.
533 (define (user-reporter result name . args)
534 (if (memq result important-result-tags)
535 (apply full-reporter result name args)))
537 (set! default-reporter full-reporter)