--- /dev/null
+;; tester.cl
+;; A test harness for Allegro CL.
+;;
+;; copyright (c) 1985-1986 Franz Inc, Alameda, CA
+;; copyright (c) 1986-2002 Franz Inc, Berkeley, CA - All rights reserved.
+;;
+;; This code is free software; you can redistribute it and/or
+;; modify it under the terms of the version 2.1 of
+;; the GNU Lesser General Public License as published by
+;; the Free Software Foundation, as clarified by the Franz
+;; preamble to the LGPL found in
+;; http://opensource.franz.com/preamble.html.
+;;
+;; This code 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
+;; Lesser General Public License for more details.
+;;
+;; Version 2.1 of the GNU Lesser General Public License can be
+;; found at http://opensource.franz.com/license.html.
+;; If it is not present, you can access it from
+;; http://www.gnu.org/copyleft/lesser.txt (until superseded by a newer
+;; version) or write to the Free Software Foundation, Inc., 59 Temple
+;; Place, Suite 330, Boston, MA 02111-1307 USA
+;;
+;;;; from the original ACL 6.1 sources:
+;; Id: tester.cl,v 2.2.12.1 2001/06/05 18:45:10 layer Exp
+
+;; $Id: tester.cl,v 1.1 2002/09/20 07:34:06 kevin Exp $
+
+(defpackage :util.test
+ (:use :common-lisp :excl)
+ (:shadow #:test)
+ (:export
+;;;; Control variables:
+ #:*break-on-test-failures*
+ #:*error-protect-tests*
+ #:*test-errors*
+ #:*test-successes*
+ #:*test-unexpected-failures*
+
+;;;; The test macros:
+ #:test
+ #:test-error
+ #:test-no-error
+ #:test-warning
+ #:test-no-warning
+
+ #:with-tests
+ ))
+
+(in-package :util.test)
+
+;; Added by Kevin Rosenberg
+
+(define-condition simple-break (error simple-condition) ())
+
+#+cmu
+(unless (find-class 'break nil)
+ (define-condition break (simple-condition) ()))
+
+;; the if* macro used in Allegro:
+;;
+;; This is in the public domain... please feel free to put this definition
+;; in your code or distribute it with your version of lisp.
+
+(defvar if*-keyword-list '("then" "thenret" "else" "elseif"))
+
+(defmacro if* (&rest args)
+ (do ((xx (reverse args) (cdr xx))
+ (state :init)
+ (elseseen nil)
+ (totalcol nil)
+ (lookat nil nil)
+ (col nil))
+ ((null xx)
+ (cond ((eq state :compl)
+ `(cond ,@totalcol))
+ (t (error "if*: illegal form ~s" args))))
+ (cond ((and (symbolp (car xx))
+ (member (symbol-name (car xx))
+ if*-keyword-list
+ :test #'string-equal))
+ (setq lookat (symbol-name (car xx)))))
+
+ (cond ((eq state :init)
+ (cond (lookat (cond ((string-equal lookat "thenret")
+ (setq col nil
+ state :then))
+ (t (error
+ "if*: bad keyword ~a" lookat))))
+ (t (setq state :col
+ col nil)
+ (push (car xx) col))))
+ ((eq state :col)
+ (cond (lookat
+ (cond ((string-equal lookat "else")
+ (cond (elseseen
+ (error
+ "if*: multiples elses")))
+ (setq elseseen t)
+ (setq state :init)
+ (push `(t ,@col) totalcol))
+ ((string-equal lookat "then")
+ (setq state :then))
+ (t (error "if*: bad keyword ~s"
+ lookat))))
+ (t (push (car xx) col))))
+ ((eq state :then)
+ (cond (lookat
+ (error
+ "if*: keyword ~s at the wrong place " (car xx)))
+ (t (setq state :compl)
+ (push `(,(car xx) ,@col) totalcol))))
+ ((eq state :compl)
+ (cond ((not (string-equal lookat "elseif"))
+ (error "if*: missing elseif clause ")))
+ (setq state :init)))))
+
+
+(defvar *break-on-test-failures* nil
+ "When a test failure occurs, common-lisp:break is called, allowing
+interactive debugging of the failure.")
+
+(defvar *test-errors* 0
+ "The value is the number of test errors which have occurred.")
+(defvar *test-successes* 0
+ "The value is the number of test successes which have occurred.")
+(defvar *test-unexpected-failures* 0
+ "The value is the number of unexpected test failures which have occurred.")
+
+(defvar *error-protect-tests* nil
+ "Protect each test from errors. If an error occurs, then that will be
+taken as a test failure unless test-error is being used.")
+
+(defmacro test-values-errorset (form &optional announce catch-breaks)
+ ;; internal macro
+ (let ((g-announce (gensym))
+ (g-catch-breaks (gensym)))
+ `(let* ((,g-announce ,announce)
+ (,g-catch-breaks ,catch-breaks))
+ (handler-case (cons t (multiple-value-list ,form))
+ (condition (condition)
+ (if* (and (null ,g-catch-breaks)
+ (typep condition 'simple-break))
+ then (break condition)
+ elseif ,g-announce
+ then (format *error-output* "~&Condition type: ~a~%"
+ (class-of condition))
+ (format *error-output* "~&Message: ~a~%" condition))
+ condition)))))
+
+(defmacro test-values (form &optional announce catch-breaks)
+ ;; internal macro
+ (if* *error-protect-tests*
+ then `(test-values-errorset ,form ,announce ,catch-breaks)
+ else `(cons t (multiple-value-list ,form))))
+
+(defmacro test (expected-value test-form
+ &key (test #'eql test-given)
+ (multiple-values nil multiple-values-given)
+ (fail-info nil fail-info-given)
+ (known-failure nil known-failure-given)
+
+;;;;;;;;;; internal, undocumented keywords:
+;;;; Note about these keywords: if they were documented, we'd have a
+;;;; problem, since they break the left-to-right order of evaluation.
+;;;; Specifically, errorset breaks it, and I don't see any way around
+;;;; that. `errorset' is used by the old test.cl module (eg,
+;;;; test-equal-errorset).
+ errorset
+ reported-form
+ (wanted-message nil wanted-message-given)
+ (got-message nil got-message-given))
+ "Perform a single test. `expected-value' is the reference value for the
+test. `test-form' is a form that will produce the value to be compared to
+the expected-value. If the values are not the same, then an error is
+logged, otherwise a success is logged.
+
+Normally the comparison of values is done with `eql'. The `test' keyword
+argument can be used to specify other comparison functions, such as eq,
+equal,equalp, string=, string-equal, etc.
+
+Normally, only the first return value from the test-form is considered,
+however if `multiple-values' is t, then all values returned from test-form
+are considered.
+
+`fail-info' allows more information to be printed with a test failure.
+
+`known-failure' marks the test as a known failure. This allows for
+programs that do regression analysis on the output from a test run to
+discriminate on new versus known failures."
+ `(test-check
+ :expected-result ,expected-value
+ :test-results
+ (,(if errorset 'test-values-errorset 'test-values) ,test-form t)
+ ,@(when test-given `(:predicate ,test))
+ ,@(when multiple-values-given `(:multiple-values ,multiple-values))
+ ,@(when fail-info-given `(:fail-info ,fail-info))
+ ,@(when known-failure-given `(:known-failure ,known-failure))
+ :test-form ',(if reported-form reported-form test-form)
+ ,@(when wanted-message-given `(:wanted-message ,wanted-message))
+ ,@(when got-message-given `(:got-message ,got-message))))
+
+(defmethod conditionp ((thing condition)) t)
+(defmethod conditionp ((thing t)) nil)
+
+(defmacro test-error (form &key announce
+ catch-breaks
+ (fail-info nil fail-info-given)
+ (known-failure nil known-failure-given)
+ (condition-type ''simple-error)
+ (include-subtypes nil include-subtypes-given)
+ (format-control nil format-control-given)
+ (format-arguments nil format-arguments-given))
+ "Test that `form' signals an error. The order of evaluation of the
+arguments is keywords first, then test form.
+
+If `announce' is non-nil, then cause the error message to be printed.
+
+The `catch-breaks' is non-nil then consider a call to common-lisp:break an
+`error'.
+
+`fail-info' allows more information to be printed with a test failure.
+
+`known-failure' marks the test as a known failure. This allows for
+programs that do regression analysis on the output from a test run to
+discriminate on new versus known failures.
+
+If `condition-type' is non-nil, it should be a symbol naming a condition
+type, which is used to check against the signalled condition type. The
+test will fail if they do not match.
+
+`include-subtypes', used with `condition-type', can be used to match a
+condition to an entire subclass of the condition type hierarchy.
+
+`format-control' and `format-arguments' can be used to check the error
+message itself."
+ (let ((g-announce (gensym))
+ (g-catch-breaks (gensym))
+ (g-fail-info (gensym))
+ (g-known-failure (gensym))
+ (g-condition-type (gensym))
+ (g-include-subtypes (gensym))
+ (g-format-control (gensym))
+ (g-format-arguments (gensym))
+ (g-c (gensym)))
+ `(let* ((,g-announce ,announce)
+ (,g-catch-breaks ,catch-breaks)
+ ,@(when fail-info-given `((,g-fail-info ,fail-info)))
+ ,@(when known-failure-given `((,g-known-failure ,known-failure)))
+ (,g-condition-type ,condition-type)
+ ,@(when include-subtypes-given
+ `((,g-include-subtypes ,include-subtypes)))
+ ,@(when format-control-given
+ `((,g-format-control ,format-control)))
+ ,@(when format-arguments-given
+ `((,g-format-arguments ,format-arguments)))
+ (,g-c (test-values-errorset ,form ,g-announce ,g-catch-breaks)))
+ (test-check
+ :predicate #'eq
+ :expected-result t
+ :test-results
+ (test-values (and (conditionp ,g-c)
+ ,@(if* include-subtypes-given
+ then `((if* ,g-include-subtypes
+ then (typep ,g-c ,g-condition-type)
+ else (eq (class-of ,g-c)
+ (find-class
+ ,g-condition-type))))
+ else `((eq (class-of ,g-c)
+ (find-class ,g-condition-type))))
+ ,@(when format-control-given
+ `((or
+ (null ,g-format-control)
+ (string=
+ (concatenate 'simple-string
+ "~1@<" ,g-format-control "~:@>")
+ (simple-condition-format-control ,g-c)))))
+ ,@(when format-arguments-given
+ `((or
+ (null ,g-format-arguments)
+ (equal
+ ,g-format-arguments
+ (simple-condition-format-arguments ,g-c))))))
+ t)
+ :test-form ',form
+ ,@(when fail-info-given `(:fail-info ,g-fail-info))
+ ,@(when known-failure-given `(:known-failure ,g-known-failure))
+ :condition-type ,g-condition-type
+ :condition ,g-c
+ ,@(when include-subtypes-given
+ `(:include-subtypes ,g-include-subtypes))
+ ,@(when format-control-given
+ `(:format-control ,g-format-control))
+ ,@(when format-arguments-given
+ `(:format-arguments ,g-format-arguments))))))
+
+(defmacro test-no-error (form &key announce
+ catch-breaks
+ (fail-info nil fail-info-given)
+ (known-failure nil known-failure-given))
+ "Test that `form' does not signal an error. The order of evaluation of
+the arguments is keywords first, then test form.
+
+If `announce' is non-nil, then cause the error message to be printed.
+
+The `catch-breaks' is non-nil then consider a call to common-lisp:break an
+`error'.
+
+`fail-info' allows more information to be printed with a test failure.
+
+`known-failure' marks the test as a known failure. This allows for
+programs that do regression analysis on the output from a test run to
+discriminate on new versus known failures."
+ (let ((g-announce (gensym))
+ (g-catch-breaks (gensym))
+ (g-fail-info (gensym))
+ (g-known-failure (gensym))
+ (g-c (gensym)))
+ `(let* ((,g-announce ,announce)
+ (,g-catch-breaks ,catch-breaks)
+ ,@(when fail-info-given `((,g-fail-info ,fail-info)))
+ ,@(when known-failure-given `((,g-known-failure ,known-failure)))
+ (,g-c (test-values-errorset ,form ,g-announce ,g-catch-breaks)))
+ (test-check
+ :predicate #'eq
+ :expected-result t
+ :test-results (test-values (not (conditionp ,g-c)))
+ :test-form ',form
+ :condition ,g-c
+ ,@(when fail-info-given `(:fail-info ,g-fail-info))
+ ,@(when known-failure-given `(:known-failure ,g-known-failure))))))
+
+(defvar *warn-cookie* (cons nil nil))
+
+(defmacro test-warning (form &key fail-info known-failure)
+ "Test that `form' signals a warning. The order of evaluation of
+the arguments is keywords first, then test form.
+
+`fail-info' allows more information to be printed with a test failure.
+
+`known-failure' marks the test as a known failure. This allows for
+programs that do regression analysis on the output from a test run to
+discriminate on new versus known failures."
+ (let ((g-fail-info (gensym))
+ (g-known-failure (gensym))
+ (g-value (gensym)))
+ `(let* ((,g-fail-info ,fail-info)
+ (,g-known-failure ,known-failure)
+ (,g-value (test-values-errorset ,form nil t)))
+ (test
+ *warn-cookie*
+ (if* (or (typep ,g-value 'simple-warning) (typep ,g-value 'warning))
+ then *warn-cookie*
+ else ;; test produced no warning
+ nil)
+ :test #'eq
+ :reported-form ,form ;; quoted by test macro
+ :wanted-message "a warning"
+ :got-message "no warning"
+ :fail-info ,g-fail-info
+ :known-failure ,g-known-failure))))
+
+(defmacro test-no-warning (form &key fail-info known-failure)
+ "Test that `form' does not signal a warning. The order of evaluation of
+the arguments is keywords first, then test form.
+
+`fail-info' allows more information to be printed with a test failure.
+
+`known-failure' marks the test as a known failure. This allows for
+programs that do regression analysis on the output from a test run to
+discriminate on new versus known failures."
+ (let ((g-fail-info (gensym))
+ (g-known-failure (gensym))
+ (g-value (gensym)))
+ `(let* ((,g-fail-info ,fail-info)
+ (,g-known-failure ,known-failure)
+ (,g-value (test-values-errorset ,form nil t)))
+ (test
+ *warn-cookie*
+ (if* (or (typep ,g-value 'simple-warning) (typep ,g-value 'warning))
+ then nil ;; test produced warning
+ else *warn-cookie*)
+ :test #'eq
+ :reported-form ',form
+ :wanted-message "no warning"
+ :got-message "a warning"
+ :fail-info ,g-fail-info
+ :known-failure ,g-known-failure))))
+
+(defvar *announce-test* nil) ;; if true announce each test that was done
+
+(defun test-check (&key (predicate #'eql)
+ expected-result test-results test-form
+ multiple-values fail-info known-failure
+ wanted-message got-message condition-type condition
+ include-subtypes format-control format-arguments
+ &aux fail predicate-failed got wanted)
+ ;; for debugging large/complex test sets:
+ (when *announce-test*
+ (format t "Just did test ~s~%" test-form)
+ (force-output))
+
+ ;; this is an internal function
+ (flet ((check (expected-result result)
+ (let* ((results
+ (multiple-value-list
+ (errorset (funcall predicate expected-result result) t)))
+ (failed (null (car results))))
+ (if* failed
+ then (setq predicate-failed t)
+ nil
+ else (cadr results)))))
+ (when (conditionp test-results)
+ (setq condition test-results)
+ (setq test-results nil))
+ (when (null (car test-results))
+ (setq fail t))
+ (if* (and (not fail) (not multiple-values))
+ then ;; should be a single result
+ ;; expected-result is the single result wanted
+ (when (not (and (cdr test-results)
+ (check expected-result (cadr test-results))))
+ (setq fail t))
+ (when (and (not fail) (cddr test-results))
+ (setq fail 'single-got-multiple))
+ else ;; multiple results wanted
+ ;; expected-result is a list of results, each of which
+ ;; should be checked against the corresponding test-results
+ ;; using the predicate
+ (do ((got (cdr test-results) (cdr got))
+ (want expected-result (cdr want)))
+ ((or (null got) (null want))
+ (when (not (and (null want) (null got)))
+ (setq fail t)))
+ (when (not (check (car got) (car want)))
+ (return (setq fail t)))))
+ (if* fail
+ then (when (not known-failure)
+ (format *error-output*
+ "~& * * * UNEXPECTED TEST FAILURE * * *~%")
+ (incf *test-unexpected-failures*))
+ (format *error-output* "~&Test failed: ~@[known failure: ~*~]~s~%"
+ known-failure test-form)
+ (if* (eq 'single-got-multiple fail)
+ then (format
+ *error-output*
+ "~
+Reason: additional value were returned from test form.~%")
+ elseif predicate-failed
+ then (format *error-output* "Reason: predicate error.~%")
+ elseif (null (car test-results))
+ then (format *error-output* "~
+Reason: an error~@[ (of type `~s')~] was detected.~%"
+ (when condition (class-of condition)))
+ elseif condition
+ then (if* (not (conditionp condition))
+ then (format *error-output* "~
+Reason: expected but did not detect an error of type `~s'.~%"
+ condition-type)
+ elseif (null condition-type)
+ then (format *error-output* "~
+Reason: detected an unexpected error of type `~s':
+ ~a.~%"
+ (class-of condition)
+ condition)
+ elseif (not (if* include-subtypes
+ then (typep condition condition-type)
+ else (eq (class-of condition)
+ (find-class condition-type))))
+ then (format *error-output* "~
+Reason: detected an incorrect condition type.~%")
+ (format *error-output*
+ " wanted: ~s~%" condition-type)
+ (format *error-output*
+ " got: ~s~%" (class-of condition))
+ elseif (and format-control
+ (not (string=
+ (setq got
+ (concatenate 'simple-string
+ "~1@<" format-control "~:@>"))
+ (setq wanted
+ (simple-condition-format-control
+ condition)))))
+ then ;; format control doesn't match
+ (format *error-output* "~
+Reason: the format-control was incorrect.~%")
+ (format *error-output* " wanted: ~s~%" wanted)
+ (format *error-output* " got: ~s~%" got)
+ elseif (and format-arguments
+ (not (equal
+ (setq got format-arguments)
+ (setq wanted
+ (simple-condition-format-arguments
+ condition)))))
+ then (format *error-output* "~
+Reason: the format-arguments were incorrect.~%")
+ (format *error-output* " wanted: ~s~%" wanted)
+ (format *error-output* " got: ~s~%" got)
+ else ;; what else????
+ (error "internal-error"))
+ else (let ((*print-length* 50)
+ (*print-level* 10))
+ (if* wanted-message
+ then (format *error-output*
+ " wanted: ~a~%" wanted-message)
+ else (if* (not multiple-values)
+ then (format *error-output*
+ " wanted: ~s~%"
+ expected-result)
+ else (format
+ *error-output*
+ " wanted values: ~{~s~^, ~}~%"
+ expected-result)))
+ (if* got-message
+ then (format *error-output*
+ " got: ~a~%" got-message)
+ else (if* (not multiple-values)
+ then (format *error-output* " got: ~s~%"
+ (second test-results))
+ else (format
+ *error-output*
+ " got values: ~{~s~^, ~}~%"
+ (cdr test-results))))))
+ (when fail-info
+ (format *error-output* "Additional info: ~a~%" fail-info))
+ (incf *test-errors*)
+ (when *break-on-test-failures*
+ (break "~a is non-nil." '*break-on-test-failures*))
+ else (when known-failure
+ (format *error-output*
+ "~&Expected test failure for ~s did not occur.~%"
+ test-form)
+ (when fail-info
+ (format *error-output* "Additional info: ~a~%" fail-info))
+ (setq fail t))
+ (incf *test-successes*))
+ (not fail)))
+
+(defmacro with-tests ((&key (name "unnamed")) &body body)
+ (let ((g-name (gensym)))
+ `(flet ((doit () ,@body))
+ (let ((,g-name ,name)
+ (*test-errors* 0)
+ (*test-successes* 0)
+ (*test-unexpected-failures* 0))
+ (format *error-output* "Begin ~a test~%" ,g-name)
+ (if* *break-on-test-failures*
+ then (doit)
+ else (handler-case (doit)
+ (error (c)
+ (format
+ *error-output*
+ "~
+~&Test ~a aborted by signalling an uncaught error:~%~a~%"
+ ,g-name c))))
+ (let ((state (sys:gsgc-switch :print)))
+ (setf (sys:gsgc-switch :print) nil)
+ (format t "~&**********************************~%" ,g-name)
+ (format t "End ~a test~%" ,g-name)
+ (format t "Errors detected in this test: ~s " *test-errors*)
+ (unless (zerop *test-unexpected-failures*)
+ (format t "UNEXPECTED: ~s" *test-unexpected-failures*))
+ (format t "~%Successes this test:~s~%" *test-successes*)
+ (setf (sys:gsgc-switch :print) state))))))
+
+(provide :tester #+module-versions 1.1)
--- /dev/null
+<html><head><title>The Allegro CL Test harness</title></head><body><table border="0" width="100%" cellpadding="1" cellspacing="0"><tr><td colspan="2" bgcolor="#00FFFF"><table border="0" cellpadding="5" cellspacing="3"><tr><td align="left" bgcolor="#00FFFF"><a href="contents.htm"><b>ToC</b></a></td><td align="left" bgcolor="#00FFFF"><a href="introduction.htm"><b>DocOverview</b></a></td><td align="left" bgcolor="#00FFFF"><a href="cgide.htm"><b>CGDoc</b></a></td><td align="left" bgcolor="#00FFFF"><a href="release-notes.htm"><b>RelNotes</b></a></td><td align="left" bgcolor="#00FFFF"><a href="index.htm"><b>Index</b></a></td><td align="left" bgcolor="#00FFFF"><a href="permuted-index.htm"><b>PermutedIndex</b></a></td></tr></table></td><td align="right"><b>Allegro CL version 6.1</b><br><small><a href="introduction.htm#updates-s">Unrevised</a></small></td></tr></table><h1>The Allegro CL Test harness</h1><p>This document contains the following sections:</p><a href="#tester-api-1">1.0 The tester module API</a><br> <a href="#tester-vars-2">1.1 Test Harness Variables</a><br> <a href="#tester-macros-2">1.2 Test Harness Macros</a><br> <a href="#tester-examples-2">1.3 Examples</a><br><p>
+ANSI Common Lisp contains no functionality designed specifically for
+testing applications. Because testing is an essential part of
+application development, Franz Inc. is making public the test harness
+used internally for testing Allegro CL itself. (A test harness is a
+collection of macros and variables associated with testing, along with
+templates for test forms.)
+</p><p>
+The test harness facility was added to Allegro CL in release 6.0. (It
+was available as a patch for release 5.0.1).
+</p><p>
+To use the test harness, you must load the
+<i>tester.fasl</i> module. Do this by evaluating
+</p><pre>
+(require :tester)
+</pre><hr><hr><h2><a name="tester-api-1">1.0 The tester module API</a></h2>
+
+<p>
+All of the following symbols are exported from the
+<code>util.test</code> package.
+</p>
+
+<hr><h2><a name="tester-vars-2">1.1 Test Harness Variables</a></h2>
+
+<p>
+The test harness API includes the following variables, each described
+fully on its own page and briefly here.
+</p>
+
+<ul>
+
+<li>
+<a href="pages/variables/util.test/s_break-on-test-failures_s.htm"><code>*break-on-test-failures*</code></a>:
+If true, <a href="../ansicl/dictentr/break.htm"><b>break</b></a> is called when
+a test fails.
+</li>
+
+<li>
+<a href="pages/variables/util.test/s_error-protect-tests_s.htm"><code>*error-protect-tests*</code></a>: If true, errors
+(other than in a test-error form) will be considered a failure and
+testing continues.
+</li>
+
+<li>
+<a href="pages/variables/util.test/s_test-errors_s.htm"><code>*test-errors*</code></a>:
+The value is the number of test errors which have occurred.
+</li>
+
+<li>
+<a href="pages/variables/util.test/s_test-successes_s.htm"><code>*test-successes*</code></a>:
+The value is the number of test successes which have occurred.
+</li>
+
+<li>
+<a href="pages/variables/util.test/s_test-unexpected-failures_s.htm"><code>*test-unexpected-failures*</code></a>:
+The value is the number of unexpected test failures which have occurred.
+</li>
+
+</ul>
+
+<hr><h2><a name="tester-macros-2">1.2 Test Harness Macros</a></h2>
+
+<p>
+These macros wrap around a form to be tested and supply the expected
+value (for the test macro) or the expected behavior, which is encoded
+in the macro name (e.g. test-error). For example:
+</p>
+
+<pre>
+(test 1 (+ 0 1)) ;; (testing that the result of (+ 0 1) is
+ ;; the fixnum 1)
+(test-error (+ 1 "2")) ;; (testing that an error is
+ ;; signaled when a string is
+ ;; passed as an argument to +)
+</pre>
+
+<p>
+Many more examples are given below.
+</p>
+
+<p>
+<a href="pages/operators/util.test/with-tests.htm"><b>with-tests</b></a> wraps around
+a collection of <strong>test</strong> or <strong>test-*</strong>
+forms.
+</p>
+
+<p>
+Note that many of the macros have <em>fail-info</em> and
+<em>known-failure</em> keyword arguments.
+</p>
+
+<ul>
+ <li><em>fail-info</em>, if non-nil, should be a string that will be printed if the test
+ fails. Typical strings provide information about what is being tested, such as "This
+ is bug2075".</li>
+ <li><em>known-failure</em>, if non-nil, affects what is printed when the test fails or
+ succeeds. Thus a failure is reported as "Test failed: known failure: ..." and a
+ success as "Expected test failure for [...] did not occur."</li>
+</ul>
+
+<p>
+Each macro is described briefly here and fully on its documentation page.
+</p>
+
+<ul>
+
+<li>
+<p>
+<a href="pages/operators/util.test/test.htm"><b>test</b></a>
+</p>
+<p><b>Arguments: </b><i>
+expected-value test-form
+</i>&key <i></i> (<i>test</i> #'eql)<i> multiple-values fail-info known-failure</i><i>
+</i></p>
+<p>
+Perform a single test and compare <i>expected-value</i>
+with the value actually returned by <i>test-form</i>.
+</p>
+</li>
+
+<li>
+<p>
+<a href="pages/operators/util.test/test-error.htm"><b>test-error</b></a>
+</p>
+<p><b>Arguments: </b><i>
+form
+</i>&key <i>announce catch-breaks fail-info known-failure</i> (<i>condition-type</i> 'simple-error)<i> include-subtypes format-control format-arguments</i><i>
+</i></p>
+<p>
+Perform a single test to see whether
+<i>form</i> signals an error.
+</p>
+</li>
+
+<li>
+<p>
+<a href="pages/operators/util.test/test-no-error.htm"><b>test-no-error</b></a>
+</p>
+<p><b>Arguments: </b><i>
+form
+</i>&key <i>announce catch-breaks fail-info known-failure</i><i>
+</i></p>
+<p>
+Perform a single test to see that
+<i>form</i> does not signal an error.
+</p>
+</li>
+
+<li>
+<p>
+<a href="pages/operators/util.test/test-warning.htm"><b>test-warning</b></a>
+</p>
+<p><b>Arguments: </b><i>
+form
+</i>&key <i>fail-info known-failure</i><i>
+</i></p>
+<p>
+Perform a single test to see that
+<i>form</i> signals a warning.
+</p>
+</li>
+
+<li>
+<p>
+<a href="pages/operators/util.test/test-no-warning.htm"><b>test-no-warning</b></a>
+</p>
+<p><b>Arguments: </b><i>
+form
+</i>&key <i>fail-info known-failure</i><i>
+</i></p>
+<p>
+Perform a single test to see that
+<i>form</i> does not signal a warning.
+</p>
+</li>
+
+<li>
+<p>
+<a href="pages/operators/util.test/with-tests.htm"><b>with-tests</b></a>
+</p>
+<p><b>Arguments: </b><i>
+(</i>&key <i></i> (<i>name</i> "unnamed")<i>)
+</i> &body <i>body</i><i>
+</i></p>
+<p>
+Evaluates
+<i>body</i>, which should be a list of test forms,
+and reports on the results.
+</p>
+</li>
+
+</ul>
+
+<hr><h2><a name="tester-examples-2">1.3 Examples</a></h2>
+
+<p>
+The following are simple examples using the test harness. The test
+forms themselves are trivial, and the purpose is to indicate the
+behavior of the test harness macros.
+</p>
+
+
+<pre>
+user(1): (require :tester)
+; Fasl loading .../tester.fasl
+t
+user(2): (use-package :util.test)
+t
+user(3): (test 1 1)
+t
+user(4): (test 1 2)
+ * * * UNEXPECTED TEST FAILURE * * *
+Test failed: 2
+ wanted: 1
+ got: 2
+nil
+user(5): (defun foo (x) x)
+foo
+user(6): (test 1 (foo 1))
+t
+user(7): (test 1 (foo 2))
+ * * * UNEXPECTED TEST FAILURE * * *
+Test failed: (foo 2)
+ wanted: 1
+ got: 2
+nil
+user(8): (setq *break-on-test-failures* t)
+t
+user(9): (test 1 (foo 2))
+ * * * UNEXPECTED TEST FAILURE * * *
+Test failed: (foo 2)
+ wanted: 1
+ got: 2
+Break: *break-on-test-failures* is non-nil.
+
+Restart actions (select using :continue):
+ 0: return from break.
+ 1: Return to Top Level (an "abort" restart)
+ 2: Abort #<process Initial Lisp Listener>
+[1c] user(10): :pop
+user(11): (setq *break-on-test-failures* nil)
+nil
+user(12): (test 1 (error "foo"))
+Error: foo
+
+Restart actions (select using :continue):
+ 0: Return to Top Level (an "abort" restart)
+ 1: Abort #<process Initial Lisp Listener>
+[1] user(13): :pop
+user(14): (setq *error-protect-tests* t)
+t
+user(15): (test 1 (error "foo"))
+Condition type: simple-error
+Message: foo
+ * * * UNEXPECTED TEST FAILURE * * *
+Test failed: (error "foo")
+Reason: an error (of type `simple-error') was detected.
+nil
+user(16): (setq *error-protect-tests* nil)
+nil
+user(17): *test-errors*
+4
+user(18): *test-successes*
+2
+user(19): (test 1 2 :known-failure t)
+Test failed: known failure: 2
+ wanted: 1
+ got: 2
+nil
+user(20): (test 1 (foo 1) :known-failure t)
+Expected test failure for (foo 1) did not occur.
+nil
+user(21): (test 1 (foo 1) :known-failure t :fail-info "This is bug666.")
+Expected test failure for (foo 1) did not occur.
+Additional info: This is bug666.
+nil
+user(22): (test-error (error "foo"))
+t
+user(23): (test-no-error (error "foo"))
+ * * * UNEXPECTED TEST FAILURE * * *
+Test failed: (error "foo")
+Reason: detected an unexpected error of type `simple-error'.
+nil
+user(24): (test-error (car '(10)))
+ * * * UNEXPECTED TEST FAILURE * * *
+Test failed: (car '(10))
+Reason: expected but did not detect an error of type `condition'.
+nil
+user(25): (test-no-error (car '(10)))
+t
+user(26): (test-warning (warn "foo"))
+t
+user(27): (test-no-warning (warn "foo"))
+ * * * UNEXPECTED TEST FAILURE * * *
+Test failed: (warn "foo")
+ wanted: no warning
+ got: a warning
+nil
+user(28): (test-warning (car '(10)))
+ * * * UNEXPECTED TEST FAILURE * * *
+Test failed: (car '(10))
+ wanted: a warning
+ got: no warning
+nil
+user(29): (test-no-warning (car '(10)))
+t
+user(30): (test-error (error "foo: ~a" 10))
+t
+user(31): (test-error (error "foo: ~a" 10) :format-control "foo: ~a")
+t
+user(32): (test-error (error "foo: ~a" 10) :format-control "foo: ~a"
+ :format-arguments '(10))
+t
+user(33): (test-error (error "foo: ~a" 10) :format-control "foo: ~a")
+ * * * UNEXPECTED TEST FAILURE * * *
+Test failed: (error "foo: ~a" 10)
+Reason: the format-control was incorrect.
+ wanted: "~1@<foo: ~a~:@>"
+ got: "~1@<foo: ~a~:@>"
+nil
+user(34): (test-error (error "foo: ~a" 10) :format-control "foo: ~a"
+ :format-arguments '(11))
+ * * * UNEXPECTED TEST FAILURE * * *
+Test failed: (error "foo: ~a" 10)
+Reason: the format-arguments were incorrect.
+ wanted: (10)
+ got: (11)
+nil
+user(35): (test-error (error "foo: ~a" 10) :condition-type 'condition
+ :include-subtypes t)
+t
+user(36): (test-error (error "foo: ~a" 10) :condition-type 'simple-break
+ :include-subtypes t)
+ * * * UNEXPECTED TEST FAILURE * * *
+Test failed: (error "foo: ~a" 10)
+Reason: detected an incorrect condition type.
+ wanted: simple-break
+ got: #<standard-class simple-error>
+nil
+user(37): (test-error (break "foo: ~a" 10) :condition-type 'simple-break
+ :include-subtypes t)
+Break: foo: 10
+ [condition type: simple-break]
+
+Restart actions (select using :continue):
+ 0: return from break.
+ 1: Return to Top Level (an "abort" restart)
+ 2: Abort #<process Initial Lisp Listener>
+[1c] user(38): :pop
+user(39): (test-error (break "foo: ~a" 10) :catch-breaks t
+ :condition-type 'simple-break :include-subtypes t)
+t
+</pre>
+
+</body><hr><p><small>Copyright (c) 1998-2001, Franz Inc. Berkeley, CA., USA. All rights reserved.</small><br><small>Documentation for Allegro CL version 6.1 update # 1. This page was not revised.</small><br><small>Created 2001.12.15.</small></p><table border="0" width="100%" cellpadding="1" cellspacing="0"><tr><td colspan="2" bgcolor="#00FFFF"><table border="0" cellpadding="5" cellspacing="3"><tr><td align="left" bgcolor="#00FFFF"><a href="contents.htm"><b>ToC</b></a></td><td align="left" bgcolor="#00FFFF"><a href="introduction.htm"><b>DocOverview</b></a></td><td align="left" bgcolor="#00FFFF"><a href="cgide.htm"><b>CGDoc</b></a></td><td align="left" bgcolor="#00FFFF"><a href="release-notes.htm"><b>RelNotes</b></a></td><td align="left" bgcolor="#00FFFF"><a href="index.htm"><b>Index</b></a></td><td align="left" bgcolor="#00FFFF"><a href="permuted-index.htm"><b>PermutedIndex</b></a></td></tr></table></td><td align="right"><b>Allegro CL version 6.1</b><br><small><a href="introduction.htm#updates-s">Unrevised</a></small></td></tr></table></html>
\ No newline at end of file
projects / ptester.git / commitdiff