1 ;;;; test-suite/lib.scm --- generic support for testing
2 ;;;; Copyright (C) 1999, 2000, 2001, 2004, 2006, 2007, 2009, 2010,
3 ;;;; 2011, 2012, 2013, 2014 Free Software Foundation, Inc.
5 ;;;; This program is free software; you can redistribute it and/or
6 ;;;; modify it under the terms of the GNU Lesser General Public
7 ;;;; License as published by the Free Software Foundation; either
8 ;;;; version 3, or (at your option) any later version.
10 ;;;; This program is distributed in the hope that it will be useful,
11 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
12 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
13 ;;;; GNU Lesser General Public License for more details.
15 ;;;; You should have received a copy of the GNU Lesser General Public
16 ;;;; License along with this software; see the file COPYING.LESSER.
17 ;;;; If not, write to the Free Software Foundation, Inc., 51 Franklin
18 ;;;; Street, Fifth Floor, Boston, MA 02110-1301 USA
20 (define-module (test-suite lib)
21 #:use-module (ice-9 regex)
22 #:use-module (ice-9 match)
23 #:autoload (srfi srfi-1) (append-map)
24 #:autoload (system base compile) (compile)
27 ;; Exceptions which are commonly being tested for.
28 exception:syntax-pattern-unmatched
29 exception:bad-variable
30 exception:missing-expression
31 exception:out-of-range exception:unbound-var
32 exception:used-before-defined
33 exception:wrong-num-args exception:wrong-type-arg
34 exception:numerical-overflow
35 exception:struct-set!-denied
36 exception:system-error
37 exception:encoding-error
38 exception:miscellaneous-error
39 exception:string-contains-nul
41 exception:null-pointer-error
44 ;; Reporting passes and failures.
48 pass-if-exception expect-fail-exception
50 ;; Naming groups of tests in a regular fashion.
57 ;; Using the debugging evaluator.
58 with-debugging-evaluator with-debugging-evaluator*
60 ;; Clearing stale references on the C stack for GC-sensitive tests.
61 clear-stale-stack-references
63 ;; Using a given locale
64 with-locale with-locale* with-latin1-locale with-latin1-locale*
69 ;; Reporting results in various ways.
70 register-reporter unregister-reporter reporter-registered?
71 make-count-reporter print-counts
77 ;;;; If you're using Emacs's Scheme mode:
78 ;;;; (put 'with-test-prefix 'scheme-indent-function 1)
83 ;;;; The function (run-test name expected-result thunk) is the heart of the
84 ;;;; testing environment. The first parameter NAME is a unique name for the
85 ;;;; test to be executed (for an explanation of this parameter see below under
86 ;;;; TEST NAMES). The second parameter EXPECTED-RESULT is a boolean value
87 ;;;; that indicates whether the corresponding test is expected to pass. If
88 ;;;; EXPECTED-RESULT is #t the test is expected to pass, if EXPECTED-RESULT is
89 ;;;; #f the test is expected to fail. Finally, THUNK is the function that
90 ;;;; actually performs the test. For example:
92 ;;;; (run-test "integer addition" #t (lambda () (= 2 (+ 1 1))))
94 ;;;; To report success, THUNK should either return #t or throw 'pass. To
95 ;;;; report failure, THUNK should either return #f or throw 'fail. If THUNK
96 ;;;; returns a non boolean value or throws 'unresolved, this indicates that
97 ;;;; the test did not perform as expected. For example the property that was
98 ;;;; to be tested could not be tested because something else went wrong.
99 ;;;; THUNK may also throw 'untested to indicate that the test was deliberately
100 ;;;; not performed, for example because the test case is not complete yet.
101 ;;;; Finally, if THUNK throws 'unsupported, this indicates that this test
102 ;;;; requires some feature that is not available in the configured testing
103 ;;;; environment. All other exceptions thrown by THUNK are considered as
107 ;;;; Convenience macros for tests expected to pass or fail
109 ;;;; * (pass-if name body) is a short form for
110 ;;;; (run-test name #t (lambda () body))
111 ;;;; * (expect-fail name body) is a short form for
112 ;;;; (run-test name #f (lambda () body))
116 ;;;; (pass-if "integer addition" (= 2 (+ 1 1)))
119 ;;;; Convenience macros to test for exceptions
121 ;;;; The following macros take exception parameters which are pairs
122 ;;;; (type . message), where type is a symbol that denotes an exception type
123 ;;;; like 'wrong-type-arg or 'out-of-range, and message is a string holding a
124 ;;;; regular expression that describes the error message for the exception
125 ;;;; like "Argument .* out of range".
127 ;;;; * (pass-if-exception name exception body) will pass if the execution of
128 ;;;; body causes the given exception to be thrown. If no exception is
129 ;;;; thrown, the test fails. If some other exception is thrown, it is an
131 ;;;; * (expect-fail-exception name exception body) will pass unexpectedly if
132 ;;;; the execution of body causes the given exception to be thrown. If no
133 ;;;; exception is thrown, the test fails expectedly. If some other
134 ;;;; exception is thrown, it is an error.
139 ;;;; Every test in the test suite has a unique name, to help
140 ;;;; developers find tests that are failing (or unexpectedly passing),
141 ;;;; and to help gather statistics.
143 ;;;; A test name is a list of printable objects. For example:
144 ;;;; ("ports.scm" "file" "read and write back list of strings")
145 ;;;; ("ports.scm" "pipe" "read")
147 ;;;; Test names may contain arbitrary objects, but they always have
148 ;;;; the following properties:
149 ;;;; - Test names can be compared with EQUAL?.
150 ;;;; - Test names can be reliably stored and retrieved with the standard WRITE
151 ;;;; and READ procedures; doing so preserves their identity.
155 ;;;; (pass-if "simple addition" (= 4 (+ 2 2)))
157 ;;;; In that case, the test name is the list ("simple addition").
159 ;;;; In the case of simple tests the expression that is tested would often
160 ;;;; suffice as a test name by itself. Therefore, the convenience macros
161 ;;;; pass-if and expect-fail provide a shorthand notation that allows to omit
162 ;;;; a test name in such cases.
164 ;;;; * (pass-if expression) is a short form for
165 ;;;; (run-test 'expression #t (lambda () expression))
166 ;;;; * (expect-fail expression) is a short form for
167 ;;;; (run-test 'expression #f (lambda () expression))
171 ;;;; (pass-if (= 2 (+ 1 1)))
173 ;;;; The WITH-TEST-PREFIX syntax and WITH-TEST-PREFIX* procedure establish
174 ;;;; a prefix for the names of all tests whose results are reported
175 ;;;; within their dynamic scope. For example:
178 ;;;; (with-test-prefix "basic arithmetic"
179 ;;;; (pass-if "addition" (= (+ 2 2) 4))
180 ;;;; (pass-if "subtraction" (= (- 4 2) 2)))
181 ;;;; (pass-if "multiplication" (= (* 2 2) 4)))
183 ;;;; In that example, the three test names are:
184 ;;;; ("basic arithmetic" "addition"),
185 ;;;; ("basic arithmetic" "subtraction"), and
186 ;;;; ("multiplication").
188 ;;;; WITH-TEST-PREFIX can be nested. Each WITH-TEST-PREFIX appends
189 ;;;; a new element to the current prefix:
191 ;;;; (with-test-prefix "arithmetic"
192 ;;;; (with-test-prefix "addition"
193 ;;;; (pass-if "integer" (= (+ 2 2) 4))
194 ;;;; (pass-if "complex" (= (+ 2+3i 4+5i) 6+8i)))
195 ;;;; (with-test-prefix "subtraction"
196 ;;;; (pass-if "integer" (= (- 2 2) 0))
197 ;;;; (pass-if "complex" (= (- 2+3i 1+2i) 1+1i))))
199 ;;;; The four test names here are:
200 ;;;; ("arithmetic" "addition" "integer")
201 ;;;; ("arithmetic" "addition" "complex")
202 ;;;; ("arithmetic" "subtraction" "integer")
203 ;;;; ("arithmetic" "subtraction" "complex")
205 ;;;; To print a name for a human reader, we DISPLAY its elements,
206 ;;;; separated by ": ". So, the last set of test names would be
209 ;;;; arithmetic: addition: integer
210 ;;;; arithmetic: addition: complex
211 ;;;; arithmetic: subtraction: integer
212 ;;;; arithmetic: subtraction: complex
214 ;;;; The Guile benchmarks use with-test-prefix to include the name of
215 ;;;; the source file containing the test in the test name, to help
216 ;;;; developers to find failing tests, and to provide each file with its
222 ;;;; A reporter is a function which we apply to each test outcome.
223 ;;;; Reporters can log results, print interesting results to the
224 ;;;; standard output, collect statistics, etc.
226 ;;;; A reporter function takes two mandatory arguments, RESULT and TEST, and
227 ;;;; possibly additional arguments depending on RESULT; its return value
228 ;;;; is ignored. RESULT has one of the following forms:
230 ;;;; pass - The test named TEST passed.
231 ;;;; Additional arguments are ignored.
232 ;;;; upass - The test named TEST passed unexpectedly.
233 ;;;; Additional arguments are ignored.
234 ;;;; fail - The test named TEST failed.
235 ;;;; Additional arguments are ignored.
236 ;;;; xfail - The test named TEST failed, as expected.
237 ;;;; Additional arguments are ignored.
238 ;;;; unresolved - The test named TEST did not perform as expected, for
239 ;;;; example the property that was to be tested could not be
240 ;;;; tested because something else went wrong.
241 ;;;; Additional arguments are ignored.
242 ;;;; untested - The test named TEST was not actually performed, for
243 ;;;; example because the test case is not complete yet.
244 ;;;; Additional arguments are ignored.
245 ;;;; unsupported - The test named TEST requires some feature that is not
246 ;;;; available in the configured testing environment.
247 ;;;; Additional arguments are ignored.
248 ;;;; error - An error occurred while the test named TEST was
249 ;;;; performed. Since this result means that the system caught
250 ;;;; an exception it could not handle, the exception arguments
251 ;;;; are passed as additional arguments.
253 ;;;; This library provides some standard reporters for logging results
254 ;;;; to a file, reporting interesting results to the user, and
255 ;;;; collecting totals.
257 ;;;; You can use the REGISTER-REPORTER function and friends to add
258 ;;;; whatever reporting functions you like. If you don't register any
259 ;;;; reporters, the library uses FULL-REPORTER, which simply writes
260 ;;;; all results to the standard output.
266 ;;; Define some exceptions which are commonly being tested for.
267 (define exception:syntax-pattern-unmatched
268 (cons 'syntax-error "source expression failed to match any pattern"))
269 (define exception:bad-variable
270 (cons 'syntax-error "Bad variable"))
271 (define exception:missing-expression
272 (cons 'misc-error "^missing or extra expression"))
273 (define exception:out-of-range
274 (cons 'out-of-range "^.*out of range"))
275 (define exception:unbound-var
276 (cons 'unbound-variable "^Unbound variable"))
277 (define exception:used-before-defined
278 (cons 'unbound-variable "^Variable used before given a value"))
279 (define exception:wrong-num-args
280 (cons 'wrong-number-of-args "^Wrong number of arguments"))
281 (define exception:wrong-type-arg
282 (cons 'wrong-type-arg "^Wrong type"))
283 (define exception:numerical-overflow
284 (cons 'numerical-overflow "^Numerical overflow"))
285 (define exception:struct-set!-denied
286 (cons 'misc-error "^set! denied for field"))
287 (define exception:system-error
288 (cons 'system-error ".*"))
289 (define exception:encoding-error
290 (cons 'encoding-error "(cannot convert.* to output locale|input (locale conversion|decoding) error)"))
291 (define exception:miscellaneous-error
292 (cons 'misc-error "^.*"))
293 (define exception:read-error
294 (cons 'read-error "^.*$"))
295 (define exception:null-pointer-error
296 (cons 'null-pointer-error "^.*$"))
297 (define exception:vm-error
298 (cons 'vm-error "^.*$"))
300 ;; as per throw in scm_to_locale_stringn()
301 (define exception:string-contains-nul
302 (cons 'misc-error "^string contains #\\\\nul character"))
305 ;;; Display all parameters to the default output port, followed by a newline.
306 (define (display-line . objs)
307 (for-each display objs)
310 ;;; Display all parameters to the given output port, followed by a newline.
311 (define (display-line-port port . objs)
312 (for-each (lambda (obj) (display obj port)) objs)
319 ;;; The central testing routine.
320 ;;; The idea is taken from Greg, the GNUstep regression test environment.
322 (let ((test-running #f))
323 (lambda (name expect-pass thunk)
325 (error "Nested calls to run-test are not permitted."))
326 (let ((test-name (full-name name)))
327 (set! test-running #t)
330 (let ((result (thunk)))
331 (if (eq? result #t) (throw 'pass))
332 (if (eq? result #f) (throw 'fail))
333 (throw 'unresolved)))
337 (report (if expect-pass 'pass 'upass) test-name))
339 ;; ARGS may contain extra info about the failure,
340 ;; such as the expected and actual value.
341 (apply report (if expect-pass 'fail 'xfail)
344 ((unresolved untested unsupported)
345 (report key test-name))
347 (report 'unresolved test-name)
350 (report 'error test-name (cons key args))))))
351 (set! test-running #f)))))
353 ;;; A short form for tests that are expected to pass, taken from Greg.
354 (define-syntax pass-if
357 ;; presume this is a simple test, i.e. (pass-if (even? 2))
358 ;; where the body should also be the name.
359 (run-test 'name #t (lambda () name)))
361 (run-test name #t (lambda () rest ...)))))
363 (define-syntax pass-if-equal
365 "Succeed if and only if BODY's return value is equal? to EXPECTED."
367 (pass-if-equal 'body expected body))
368 ((_ name expected body ...)
371 (let ((result (begin body ...)))
372 (or (equal? expected result)
374 'expected-value expected
375 'actual-value result))))))))
377 ;;; A short form for tests that are expected to fail, taken from Greg.
378 (define-syntax expect-fail
381 ;; presume this is a simple test, i.e. (expect-fail (even? 2))
382 ;; where the body should also be the name.
383 (run-test 'name #f (lambda () name)))
385 (run-test name #f (lambda () rest ...)))))
387 ;;; A helper function to implement the macros that test for exceptions.
388 (define (run-test-exception name exception expect-pass thunk)
390 ((expected-key . expected-pattern)
396 (lambda () (thunk) #f)
397 (lambda (key proc message . rest)
398 ;; Match the message against the expected pattern. If that
399 ;; doesn't work, in the case of `misc-error' and
400 ;; `syntax-error' we treat the message as a format string,
401 ;; and format it. This is pretty terrible but it's
403 (or (and (string-match expected-pattern message) #t)
404 (and (memq expected-key '(misc-error syntax-error))
406 (let ((out (apply simple-format #f message (car rest))))
407 (and (string-match expected-pattern out) #t)))
408 (apply throw key proc message rest)))))))))
410 ;;; A short form for tests that expect a certain exception to be thrown.
411 (define-syntax pass-if-exception
413 ((_ name exception body rest ...)
414 (run-test-exception name exception #t (lambda () body rest ...)))))
416 ;;; A short form for tests expected to fail to throw a certain exception.
417 (define-syntax expect-fail-exception
419 ((_ name exception body rest ...)
420 (run-test-exception name exception #f (lambda () body rest ...)))))
426 ;;;; Turn a test name into a nice human-readable string.
427 (define (format-test-name name)
428 (call-with-output-string
430 (let loop ((name name)
434 (display separator port)
435 (display (car name) port)
436 (loop (cdr name) ": ")))))))
438 ;;;; For a given test-name, deliver the full name including all prefixes.
439 (define (full-name name)
440 (append (current-test-prefix) (list name)))
442 ;;; A fluid containing the current test prefix, as a list.
443 (define prefix-fluid (make-fluid '()))
444 (define (current-test-prefix)
445 (fluid-ref prefix-fluid))
447 ;;; Postpend PREFIX to the current name prefix while evaluting THUNK.
448 ;;; The name prefix is only changed within the dynamic scope of the
449 ;;; call to with-test-prefix*. Return the value returned by THUNK.
450 (define (with-test-prefix* prefix thunk)
451 (with-fluids ((prefix-fluid
452 (append (fluid-ref prefix-fluid) (list prefix))))
455 ;;; (with-test-prefix PREFIX BODY ...)
456 ;;; Postpend PREFIX to the current name prefix while evaluating BODY ...
457 ;;; The name prefix is only changed within the dynamic scope of the
458 ;;; with-test-prefix expression. Return the value returned by the last
460 (define-syntax with-test-prefix
463 (with-test-prefix* prefix (lambda () body ...)))))
466 (syntax-rules (pass-if pass-if-equal pass-if-exception)
467 "Run the given tests both with the evaluator and the compiler/VM."
469 (c&e (pass-if "[unnamed test]" exp)))
470 ((_ (pass-if test-name exp))
471 (begin (pass-if (string-append test-name " (eval)")
472 (primitive-eval 'exp))
473 (pass-if (string-append test-name " (compile)")
474 (compile 'exp #:to 'value #:env (current-module)))))
475 ((_ (pass-if-equal test-name val exp))
476 (begin (pass-if-equal (string-append test-name " (eval)") val
477 (primitive-eval 'exp))
478 (pass-if-equal (string-append test-name " (compile)") val
479 (compile 'exp #:to 'value #:env (current-module)))))
480 ((_ (pass-if-exception test-name exc exp))
481 (begin (pass-if-exception (string-append test-name " (eval)")
482 exc (primitive-eval 'exp))
483 (pass-if-exception (string-append test-name " (compile)")
484 exc (compile 'exp #:to 'value
485 #:env (current-module)))))))
487 ;;; (with-test-prefix/c&e PREFIX BODY ...)
488 ;;; Same as `with-test-prefix', but the enclosed tests are run both with
489 ;;; the compiler/VM and the evaluator.
490 (define-syntax with-test-prefix/c&e
492 ((_ section-name exp ...)
493 (with-test-prefix section-name (c&e exp) ...))))
495 ;;; Call THUNK using the debugging evaluator.
496 (define (with-debugging-evaluator* thunk)
500 (set! dopts (debug-options)))
503 (debug-options dopts)))))
505 ;;; Evaluate BODY... using the debugging evaluator.
506 (define-macro (with-debugging-evaluator . body)
507 `(with-debugging-evaluator* (lambda () ,@body)))
509 ;; Recurse through a C function that should clear any values that might
510 ;; have spilled on the stack temporarily. (The salient feature of
511 ;; with-continuation-barrier is that currently it is implemented as a C
512 ;; function that recursively calls the VM.)
514 (define* (clear-stale-stack-references #:optional (n 10))
516 (with-continuation-barrier
518 (clear-stale-stack-references (1- n))))))
520 ;;; Call THUNK with a given locale
521 (define (with-locale* nloc thunk)
525 (if (defined? 'setlocale)
527 (set! loc (false-if-exception (setlocale LC_ALL)))
529 (not (false-if-exception (setlocale LC_ALL nloc))))
530 (throw 'unresolved)))
531 (throw 'unresolved)))
534 (if (and (defined? 'setlocale) loc)
535 (setlocale LC_ALL loc))))))
537 ;;; Evaluate BODY... using the given locale.
538 (define-syntax with-locale
541 (with-locale* loc (lambda () body ...)))))
543 ;;; Try out several ISO-8859-1 locales and run THUNK under the one that works
545 (define (with-latin1-locale* thunk)
547 (append-map (lambda (name)
548 (list (string-append name ".ISO-8859-1")
549 (string-append name ".iso88591")
550 (string-append name ".ISO8859-1")))
551 '("ca_ES" "da_DK" "de_DE" "es_ES" "es_MX" "en_GB" "en_US"
552 "fr_FR" "pt_PT" "nl_NL" "sv_SE")))
554 (let loop ((locales %locales))
559 (with-locale* (car locales) thunk))
561 (loop (cdr locales)))))))
563 ;;; Evaluate BODY... using an ISO-8859-1 locale or throw `unresolved' if none
565 (define-syntax with-latin1-locale
568 (with-latin1-locale* (lambda () body ...)))))
571 ;; On Windows (MinGW), /dev/null does not exist and we must instead
572 ;; use NUL. Note that file system procedures automatically translate
573 ;; /dev/null, so this variable is only useful for shell snippets.
575 ;; Test for Windowsness by checking whether the current directory name
576 ;; starts with a drive letter.
577 (if (string-match "^[a-zA-Z]:[/\\]" (getcwd))
585 ;;; The global list of reporters.
586 (define reporters '())
588 ;;; The default reporter, to be used only if no others exist.
589 (define default-reporter #f)
591 ;;; Add the procedure REPORTER to the current set of reporter functions.
592 ;;; Signal an error if that reporter procedure object is already registered.
593 (define (register-reporter reporter)
594 (if (memq reporter reporters)
595 (error "register-reporter: reporter already registered: " reporter))
596 (set! reporters (cons reporter reporters)))
598 ;;; Remove the procedure REPORTER from the current set of reporter
599 ;;; functions. Signal an error if REPORTER is not currently registered.
600 (define (unregister-reporter reporter)
601 (if (memq reporter reporters)
602 (set! reporters (delq! reporter reporters))
603 (error "unregister-reporter: reporter not registered: " reporter)))
605 ;;; Return true iff REPORTER is in the current set of reporter functions.
606 (define (reporter-registered? reporter)
607 (if (memq reporter reporters) #t #f))
609 ;;; Send RESULT to all currently registered reporter functions.
610 (define (report . args)
611 (if (pair? reporters)
612 (for-each (lambda (reporter) (apply reporter args))
614 (apply default-reporter args)))
617 ;;;; Some useful standard reporters:
618 ;;;; Count reporters count the occurrence of each test result type.
619 ;;;; Log reporters write all test results to a given log file.
620 ;;;; Full reporters write all test results to the standard output.
621 ;;;; User reporters write interesting test results to the standard output.
623 ;;; The complete list of possible test results.
625 '((pass "PASS" "passes: ")
626 (fail "FAIL" "failures: ")
627 (upass "UPASS" "unexpected passes: ")
628 (xfail "XFAIL" "expected failures: ")
629 (unresolved "UNRESOLVED" "unresolved test cases: ")
630 (untested "UNTESTED" "untested test cases: ")
631 (unsupported "UNSUPPORTED" "unsupported test cases: ")
632 (error "ERROR" "errors: ")))
634 ;;; The list of important test results.
635 (define important-result-tags
636 '(fail upass unresolved error))
638 ;;; Display a single test result in formatted form to the given port
639 (define (print-result port result name . args)
640 (let* ((tag (assq result result-tags))
641 (label (if tag (cadr tag) #f)))
646 (display (format-test-name name) port)
649 (display " - arguments: " port)
652 (error "(test-suite lib) FULL-REPORTER: unrecognized result: "
655 ;;; Return a list of the form (COUNTER RESULTS), where:
656 ;;; - COUNTER is a reporter procedure, and
657 ;;; - RESULTS is a procedure taking no arguments which returns the
658 ;;; results seen so far by COUNTER. The return value is an alist
659 ;;; mapping outcome symbols (`pass', `fail', etc.) onto counts.
660 (define (make-count-reporter)
661 (let ((counts (map (lambda (tag) (cons (car tag) 0)) result-tags)))
663 (lambda (result name . args)
664 (let ((pair (assq result counts)))
666 (set-cdr! pair (+ 1 (cdr pair)))
667 (error "count-reporter: unexpected test result: "
668 (cons result (cons name args))))))
670 (append counts '())))))
672 ;;; Print a count reporter's results nicely. Pass this function the value
673 ;;; returned by a count reporter's RESULTS procedure.
674 (define (print-counts results . port?)
675 (let ((port (if (pair? port?)
677 (current-output-port))))
679 (display-line-port port "Totals for this test run:")
682 (let ((result (assq (car tag) results)))
684 (display-line-port port (caddr tag) (cdr result))
685 (display-line-port port
687 "no total available for `" (car tag) "'"))))
691 ;;; Return a reporter procedure which prints all results to the file
692 ;;; FILE, in human-readable form. FILE may be a filename, or a port.
693 (define (make-log-reporter file)
694 (let ((port (if (output-port? file) file
695 (open-output-file file))))
697 (apply print-result port args)
698 (force-output port))))
700 ;;; A reporter that reports all results to the user.
701 (define (full-reporter . args)
702 (apply print-result (current-output-port) args))
704 ;;; A reporter procedure which shows interesting results (failures,
705 ;;; unexpected passes etc.) to the user.
706 (define (user-reporter result name . args)
707 (if (memq result important-result-tags)
708 (apply full-reporter result name args)))
710 (set! default-reporter full-reporter)