2 ;; A test harness for Allegro CL.
4 ;; copyright (c) 1985-1986 Franz Inc, Alameda, CA
5 ;; copyright (c) 1986-2002 Franz Inc, Berkeley, CA - All rights reserved.
7 ;; This code is free software; you can redistribute it and/or
8 ;; modify it under the terms of the version 2.1 of
9 ;; the GNU Lesser General Public License as published by
10 ;; the Free Software Foundation, as clarified by the Franz
11 ;; preamble to the LGPL found in
12 ;; http://opensource.franz.com/preamble.html.
14 ;; This code is distributed in the hope that it will be useful,
15 ;; but without any warranty; without even the implied warranty of
16 ;; merchantability or fitness for a particular purpose. See the GNU
17 ;; Lesser General Public License for more details.
19 ;; Version 2.1 of the GNU Lesser General Public License can be
20 ;; found at http://opensource.franz.com/license.html.
21 ;; If it is not present, you can access it from
22 ;; http://www.gnu.org/copyleft/lesser.txt (until superseded by a newer
23 ;; version) or write to the Free Software Foundation, Inc., 59 Temple
24 ;; Place, Suite 330, Boston, MA 02111-1307 USA
26 ;;;; from the original ACL 6.1 sources:
27 ;; Id: tester.cl,v 2.2.12.1 2001/06/05 18:45:10 layer Exp
29 ;; $Id: tester.lisp,v 1.2 2003/02/23 06:10:02 kevin Exp $
31 (defpackage :util.test
35 ;;;; Control variables:
36 #:*break-on-test-failures*
37 #:*error-protect-tests*
40 #:*test-unexpected-failures*
52 (in-package :util.test)
54 ;; Added by Kevin Rosenberg
56 (define-condition simple-break (error simple-condition) ())
59 (unless (find-class 'break nil)
60 (define-condition break (simple-condition) ()))
62 ;; the if* macro used in Allegro:
64 ;; This is in the public domain... please feel free to put this definition
65 ;; in your code or distribute it with your version of lisp.
67 (eval-when (:compile-toplevel :load-toplevel :execute)
68 (defvar if*-keyword-list '("then" "thenret" "else" "elseif")))
70 (defmacro if* (&rest args)
71 (do ((xx (reverse args) (cdr xx))
78 (cond ((eq state :compl)
80 (t (error "if*: illegal form ~s" args))))
81 (cond ((and (symbolp (car xx))
82 (member (symbol-name (car xx))
84 :test #'string-equal))
85 (setq lookat (symbol-name (car xx)))))
87 (cond ((eq state :init)
88 (cond (lookat (cond ((string-equal lookat "thenret")
92 "if*: bad keyword ~a" lookat))))
95 (push (car xx) col))))
98 (cond ((string-equal lookat "else")
101 "if*: multiples elses")))
104 (push `(t ,@col) totalcol))
105 ((string-equal lookat "then")
107 (t (error "if*: bad keyword ~s"
109 (t (push (car xx) col))))
113 "if*: keyword ~s at the wrong place " (car xx)))
114 (t (setq state :compl)
115 (push `(,(car xx) ,@col) totalcol))))
117 (cond ((not (string-equal lookat "elseif"))
118 (error "if*: missing elseif clause ")))
119 (setq state :init)))))
122 (defvar *break-on-test-failures* nil
123 "When a test failure occurs, common-lisp:break is called, allowing
124 interactive debugging of the failure.")
126 (defvar *test-errors* 0
127 "The value is the number of test errors which have occurred.")
128 (defvar *test-successes* 0
129 "The value is the number of test successes which have occurred.")
130 (defvar *test-unexpected-failures* 0
131 "The value is the number of unexpected test failures which have occurred.")
133 (defvar *error-protect-tests* nil
134 "Protect each test from errors. If an error occurs, then that will be
135 taken as a test failure unless test-error is being used.")
137 (defmacro test-values-errorset (form &optional announce catch-breaks)
139 (let ((g-announce (gensym))
140 (g-catch-breaks (gensym)))
141 `(let* ((,g-announce ,announce)
142 (,g-catch-breaks ,catch-breaks))
143 (handler-case (cons t (multiple-value-list ,form))
144 (condition (condition)
145 (if* (and (null ,g-catch-breaks)
146 (typep condition 'simple-break))
147 then (break condition)
149 then (format *error-output* "~&Condition type: ~a~%"
150 (class-of condition))
151 (format *error-output* "~&Message: ~a~%" condition))
154 (defmacro test-values (form &optional announce catch-breaks)
156 (if* *error-protect-tests*
157 then `(test-values-errorset ,form ,announce ,catch-breaks)
158 else `(cons t (multiple-value-list ,form))))
160 (defmacro test (expected-value test-form
161 &key (test #'eql test-given)
162 (multiple-values nil multiple-values-given)
163 (fail-info nil fail-info-given)
164 (known-failure nil known-failure-given)
166 ;;;;;;;;;; internal, undocumented keywords:
167 ;;;; Note about these keywords: if they were documented, we'd have a
168 ;;;; problem, since they break the left-to-right order of evaluation.
169 ;;;; Specifically, errorset breaks it, and I don't see any way around
170 ;;;; that. `errorset' is used by the old test.cl module (eg,
171 ;;;; test-equal-errorset).
174 (wanted-message nil wanted-message-given)
175 (got-message nil got-message-given))
176 "Perform a single test. `expected-value' is the reference value for the
177 test. `test-form' is a form that will produce the value to be compared to
178 the expected-value. If the values are not the same, then an error is
179 logged, otherwise a success is logged.
181 Normally the comparison of values is done with `eql'. The `test' keyword
182 argument can be used to specify other comparison functions, such as eq,
183 equal,equalp, string=, string-equal, etc.
185 Normally, only the first return value from the test-form is considered,
186 however if `multiple-values' is t, then all values returned from test-form
189 `fail-info' allows more information to be printed with a test failure.
191 `known-failure' marks the test as a known failure. This allows for
192 programs that do regression analysis on the output from a test run to
193 discriminate on new versus known failures."
195 :expected-result ,expected-value
197 (,(if errorset 'test-values-errorset 'test-values) ,test-form t)
198 ,@(when test-given `(:predicate ,test))
199 ,@(when multiple-values-given `(:multiple-values ,multiple-values))
200 ,@(when fail-info-given `(:fail-info ,fail-info))
201 ,@(when known-failure-given `(:known-failure ,known-failure))
202 :test-form ',(if reported-form reported-form test-form)
203 ,@(when wanted-message-given `(:wanted-message ,wanted-message))
204 ,@(when got-message-given `(:got-message ,got-message))))
206 (defmethod conditionp ((thing condition)) t)
207 (defmethod conditionp ((thing t)) nil)
209 (defmacro test-error (form &key announce
211 (fail-info nil fail-info-given)
212 (known-failure nil known-failure-given)
213 (condition-type ''simple-error)
214 (include-subtypes nil include-subtypes-given)
215 (format-control nil format-control-given)
216 (format-arguments nil format-arguments-given))
217 "Test that `form' signals an error. The order of evaluation of the
218 arguments is keywords first, then test form.
220 If `announce' is non-nil, then cause the error message to be printed.
222 The `catch-breaks' is non-nil then consider a call to common-lisp:break an
225 `fail-info' allows more information to be printed with a test failure.
227 `known-failure' marks the test as a known failure. This allows for
228 programs that do regression analysis on the output from a test run to
229 discriminate on new versus known failures.
231 If `condition-type' is non-nil, it should be a symbol naming a condition
232 type, which is used to check against the signalled condition type. The
233 test will fail if they do not match.
235 `include-subtypes', used with `condition-type', can be used to match a
236 condition to an entire subclass of the condition type hierarchy.
238 `format-control' and `format-arguments' can be used to check the error
240 (let ((g-announce (gensym))
241 (g-catch-breaks (gensym))
242 (g-fail-info (gensym))
243 (g-known-failure (gensym))
244 (g-condition-type (gensym))
245 (g-include-subtypes (gensym))
246 (g-format-control (gensym))
247 (g-format-arguments (gensym))
249 `(let* ((,g-announce ,announce)
250 (,g-catch-breaks ,catch-breaks)
251 ,@(when fail-info-given `((,g-fail-info ,fail-info)))
252 ,@(when known-failure-given `((,g-known-failure ,known-failure)))
253 (,g-condition-type ,condition-type)
254 ,@(when include-subtypes-given
255 `((,g-include-subtypes ,include-subtypes)))
256 ,@(when format-control-given
257 `((,g-format-control ,format-control)))
258 ,@(when format-arguments-given
259 `((,g-format-arguments ,format-arguments)))
260 (,g-c (test-values-errorset ,form ,g-announce ,g-catch-breaks)))
265 (test-values (and (conditionp ,g-c)
266 ,@(if* include-subtypes-given
267 then `((if* ,g-include-subtypes
268 then (typep ,g-c ,g-condition-type)
269 else (eq (class-of ,g-c)
271 ,g-condition-type))))
272 else `((eq (class-of ,g-c)
273 (find-class ,g-condition-type))))
274 ,@(when format-control-given
276 (null ,g-format-control)
278 (concatenate 'simple-string
279 "~1@<" ,g-format-control "~:@>")
280 (simple-condition-format-control ,g-c)))))
281 ,@(when format-arguments-given
283 (null ,g-format-arguments)
286 (simple-condition-format-arguments ,g-c))))))
289 ,@(when fail-info-given `(:fail-info ,g-fail-info))
290 ,@(when known-failure-given `(:known-failure ,g-known-failure))
291 :condition-type ,g-condition-type
293 ,@(when include-subtypes-given
294 `(:include-subtypes ,g-include-subtypes))
295 ,@(when format-control-given
296 `(:format-control ,g-format-control))
297 ,@(when format-arguments-given
298 `(:format-arguments ,g-format-arguments))))))
300 (defmacro test-no-error (form &key announce
302 (fail-info nil fail-info-given)
303 (known-failure nil known-failure-given))
304 "Test that `form' does not signal an error. The order of evaluation of
305 the arguments is keywords first, then test form.
307 If `announce' is non-nil, then cause the error message to be printed.
309 The `catch-breaks' is non-nil then consider a call to common-lisp:break an
312 `fail-info' allows more information to be printed with a test failure.
314 `known-failure' marks the test as a known failure. This allows for
315 programs that do regression analysis on the output from a test run to
316 discriminate on new versus known failures."
317 (let ((g-announce (gensym))
318 (g-catch-breaks (gensym))
319 (g-fail-info (gensym))
320 (g-known-failure (gensym))
322 `(let* ((,g-announce ,announce)
323 (,g-catch-breaks ,catch-breaks)
324 ,@(when fail-info-given `((,g-fail-info ,fail-info)))
325 ,@(when known-failure-given `((,g-known-failure ,known-failure)))
326 (,g-c (test-values-errorset ,form ,g-announce ,g-catch-breaks)))
330 :test-results (test-values (not (conditionp ,g-c)))
333 ,@(when fail-info-given `(:fail-info ,g-fail-info))
334 ,@(when known-failure-given `(:known-failure ,g-known-failure))))))
336 (defvar *warn-cookie* (cons nil nil))
338 (defmacro test-warning (form &key fail-info known-failure)
339 "Test that `form' signals a warning. The order of evaluation of
340 the arguments is keywords first, then test form.
342 `fail-info' allows more information to be printed with a test failure.
344 `known-failure' marks the test as a known failure. This allows for
345 programs that do regression analysis on the output from a test run to
346 discriminate on new versus known failures."
347 (let ((g-fail-info (gensym))
348 (g-known-failure (gensym))
350 `(let* ((,g-fail-info ,fail-info)
351 (,g-known-failure ,known-failure)
352 (,g-value (test-values-errorset ,form nil t)))
355 (if* (or (typep ,g-value 'simple-warning) (typep ,g-value 'warning))
357 else ;; test produced no warning
360 :reported-form ,form ;; quoted by test macro
361 :wanted-message "a warning"
362 :got-message "no warning"
363 :fail-info ,g-fail-info
364 :known-failure ,g-known-failure))))
366 (defmacro test-no-warning (form &key fail-info known-failure)
367 "Test that `form' does not signal a warning. The order of evaluation of
368 the arguments is keywords first, then test form.
370 `fail-info' allows more information to be printed with a test failure.
372 `known-failure' marks the test as a known failure. This allows for
373 programs that do regression analysis on the output from a test run to
374 discriminate on new versus known failures."
375 (let ((g-fail-info (gensym))
376 (g-known-failure (gensym))
378 `(let* ((,g-fail-info ,fail-info)
379 (,g-known-failure ,known-failure)
380 (,g-value (test-values-errorset ,form nil t)))
383 (if* (or (typep ,g-value 'simple-warning) (typep ,g-value 'warning))
384 then nil ;; test produced warning
387 :reported-form ',form
388 :wanted-message "no warning"
389 :got-message "a warning"
390 :fail-info ,g-fail-info
391 :known-failure ,g-known-failure))))
393 (defvar *announce-test* nil) ;; if true announce each test that was done
395 (defmacro errorset (form)
396 `(handler-case (cons t (multiple-value-list ,form))
398 (format *error-output* "~&An error occurred: ~a~%" cond)
401 (defun test-check (&key (predicate #'eql)
402 expected-result test-results test-form
403 multiple-values fail-info known-failure
404 wanted-message got-message condition-type condition
405 include-subtypes format-control format-arguments
406 &aux fail predicate-failed got wanted)
407 ;; for debugging large/complex test sets:
408 (when *announce-test*
409 (format t "Just did test ~s~%" test-form)
412 ;; this is an internal function
413 (flet ((check (expected-result result)
416 (errorset (funcall predicate expected-result result))))
417 (failed (null (car results))))
419 then (setq predicate-failed t)
421 else (cadr results)))))
422 (when (conditionp test-results)
423 (setq condition test-results)
424 (setq test-results nil))
425 (when (null (car test-results))
427 (if* (and (not fail) (not multiple-values))
428 then ;; should be a single result
429 ;; expected-result is the single result wanted
430 (when (not (and (cdr test-results)
431 (check expected-result (cadr test-results))))
433 (when (and (not fail) (cddr test-results))
434 (setq fail 'single-got-multiple))
435 else ;; multiple results wanted
436 ;; expected-result is a list of results, each of which
437 ;; should be checked against the corresponding test-results
438 ;; using the predicate
439 (do ((got (cdr test-results) (cdr got))
440 (want expected-result (cdr want)))
441 ((or (null got) (null want))
442 (when (not (and (null want) (null got)))
444 (when (not (check (car got) (car want)))
445 (return (setq fail t)))))
447 then (when (not known-failure)
448 (format *error-output*
449 "~& * * * UNEXPECTED TEST FAILURE * * *~%")
450 (incf *test-unexpected-failures*))
451 (format *error-output* "~&Test failed: ~@[known failure: ~*~]~s~%"
452 known-failure test-form)
453 (if* (eq 'single-got-multiple fail)
457 Reason: additional value were returned from test form.~%")
458 elseif predicate-failed
459 then (format *error-output* "Reason: predicate error.~%")
460 elseif (null (car test-results))
461 then (format *error-output* "~
462 Reason: an error~@[ (of type `~s')~] was detected.~%"
463 (when condition (class-of condition)))
465 then (if* (not (conditionp condition))
466 then (format *error-output* "~
467 Reason: expected but did not detect an error of type `~s'.~%"
469 elseif (null condition-type)
470 then (format *error-output* "~
471 Reason: detected an unexpected error of type `~s':
475 elseif (not (if* include-subtypes
476 then (typep condition condition-type)
477 else (eq (class-of condition)
478 (find-class condition-type))))
479 then (format *error-output* "~
480 Reason: detected an incorrect condition type.~%")
481 (format *error-output*
482 " wanted: ~s~%" condition-type)
483 (format *error-output*
484 " got: ~s~%" (class-of condition))
485 elseif (and format-control
488 (concatenate 'simple-string
489 "~1@<" format-control "~:@>"))
491 (simple-condition-format-control
493 then ;; format control doesn't match
494 (format *error-output* "~
495 Reason: the format-control was incorrect.~%")
496 (format *error-output* " wanted: ~s~%" wanted)
497 (format *error-output* " got: ~s~%" got)
498 elseif (and format-arguments
500 (setq got format-arguments)
502 (simple-condition-format-arguments
504 then (format *error-output* "~
505 Reason: the format-arguments were incorrect.~%")
506 (format *error-output* " wanted: ~s~%" wanted)
507 (format *error-output* " got: ~s~%" got)
508 else ;; what else????
509 (error "internal-error"))
510 else (let ((*print-length* 50)
513 then (format *error-output*
514 " wanted: ~a~%" wanted-message)
515 else (if* (not multiple-values)
516 then (format *error-output*
521 " wanted values: ~{~s~^, ~}~%"
524 then (format *error-output*
525 " got: ~a~%" got-message)
526 else (if* (not multiple-values)
527 then (format *error-output* " got: ~s~%"
528 (second test-results))
531 " got values: ~{~s~^, ~}~%"
532 (cdr test-results))))))
534 (format *error-output* "Additional info: ~a~%" fail-info))
536 (when *break-on-test-failures*
537 (break "~a is non-nil." '*break-on-test-failures*))
538 else (when known-failure
539 (format *error-output*
540 "~&Expected test failure for ~s did not occur.~%"
543 (format *error-output* "Additional info: ~a~%" fail-info))
545 (incf *test-successes*))
548 (defmacro with-tests ((&key (name "unnamed")) &body body)
549 (let ((g-name (gensym)))
550 `(flet ((doit () ,@body))
551 (let ((,g-name ,name)
554 (*test-unexpected-failures* 0))
555 (format *error-output* "Begin ~a test~%" ,g-name)
556 (if* *break-on-test-failures*
558 else (handler-case (doit)
563 ~&Test ~a aborted by signalling an uncaught error:~%~a~%"
566 (let ((state (sys:gsgc-switch :print)))
567 (setf (sys:gsgc-switch :print) nil)
568 (format t "~&**********************************~%" ,g-name)
569 (format t "End ~a test~%" ,g-name)
570 (format t "Errors detected in this test: ~s " *test-errors*)
571 (unless (zerop *test-unexpected-failures*)
572 (format t "UNEXPECTED: ~s" *test-unexpected-failures*))
573 (format t "~%Successes this test:~s~%" *test-successes*)
574 (setf (sys:gsgc-switch :print) state))
577 (format t "~&**********************************~%" ,g-name)
578 (format t "End ~a test~%" ,g-name)
579 (format t "Errors detected in this test: ~s " *test-errors*)
580 (unless (zerop *test-unexpected-failures*)
581 (format t "UNEXPECTED: ~s" *test-unexpected-failures*))
582 (format t "~%Successes this test:~s~%" *test-successes*))))))
584 (provide :tester #+module-versions 1.1)