cl-ptester-2.1.2/ 0042755 0001750 0001750 00000000000 10003747026 012615 5 ustar kevin kevin cl-ptester-2.1.2/tester.html 0100644 0001750 0001750 00000027553 07726550605 015035 0 ustar kevin kevin The Allegro CL Test harnessThe Allegro CL Test harness
This document contains the following sections:
1.0 The tester module API
1.1 Test Harness Variables
1.2 Test Harness Macros
1.3 Examples
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.)
The test harness facility was added to Allegro CL in release 6.0. (It
was available as a patch for release 5.0.1).
To use the test harness, you must load the
tester.fasl module. Do this by evaluating
(require :tester)
All of the following symbols are exported from the
util.test package.
The test harness API includes the following variables, each described
fully on its own page and briefly here.
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:
(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 +)
Many more examples are given below.
with-tests wraps around
a collection of test or test-*
forms.
Note that many of the macros have fail-info and
known-failure keyword arguments.
- fail-info, 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".
- known-failure, 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."
Each macro is described briefly here and fully on its documentation page.
-
test
Arguments:
expected-value test-form
&key (test #'eql) multiple-values fail-info known-failure
Perform a single test and compare expected-value
with the value actually returned by test-form.
-
test-error
Arguments:
form
&key announce catch-breaks fail-info known-failure (condition-type 'simple-error) include-subtypes format-control format-arguments
Perform a single test to see whether
form signals an error.
-
test-no-error
Arguments:
form
&key announce catch-breaks fail-info known-failure
Perform a single test to see that
form does not signal an error.
-
test-warning
Arguments:
form
&key fail-info known-failure
Perform a single test to see that
form signals a warning.
-
test-no-warning
Arguments:
form
&key fail-info known-failure
Perform a single test to see that
form does not signal a warning.
-
with-tests
Arguments:
(&key (name "unnamed"))
&body body
Evaluates
body, which should be a list of test forms,
and reports on the results.
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.
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
Copyright (c) 1998-2001, Franz Inc. Berkeley, CA., USA. All rights reserved.
Documentation for Allegro CL version 6.1 update # 1. This page was not revised.
Created 2001.12.15.
cl-ptester-2.1.2/ptester.asd 0100644 0001750 0001750 00000001570 07726550605 015007 0 ustar kevin kevin ;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
;;;; *************************************************************************
;;;; FILE IDENTIFICATION
;;;;
;;;; Name: ptester.asd
;;;; Purpose: ASDF definition file for ptester
;;;; Programmer: Kevin M. Rosenberg
;;;; Date Started: Sep 2002
;;;;
;;;; $Id: ptester.asd 7061 2003-09-07 06:34:45Z kevin $
;;;;
;;;; *************************************************************************
(defpackage #:ptester-system (:use #:asdf #:cl))
(in-package #:ptester-system)
(defsystem ptester
:name "ptester"
:author "Kevin Layer, Franz, Inc / Kevin Rosenberg"
:maintainer "Kevin M. Rosenberg "
:licence "LLGPL"
:description "Portable test harness package"
:long-description "ptester is a portable testing framework based on Franz's tester module"
:components
((:file "src")))
cl-ptester-2.1.2/src.lisp 0100644 0001750 0001750 00000050373 07726550605 014315 0 ustar kevin kevin ;; ptester.lisp
;; A test harness based on Franz's tester module
;;
;; copyright (c) 1985-1986 Franz Inc, Alameda, CA
;; copyright (c) 1986-2002 Franz Inc, Berkeley, CA - All rights reserved.
;; copyright (c) 2001-2003 Kevin Rosenberg (portability changes)
;;
;; 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: src.lisp 7061 2003-09-07 06:34:45Z kevin $
(defpackage #:ptester
(:use #:cl)
(: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 #:ptester)
;; 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.
(eval-when (:compile-toplevel :load-toplevel :execute)
(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))))
(defgeneric conditionp (thing) )
(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
(defmacro errorset (form) ;subset of test-values-errorset
`(handler-case
(values-list (cons t (multiple-value-list ,form)))
(error (cond)
(format *error-output* "~&An error occurred: ~a~%" cond)
nil)))
(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))))
(failed (null (car results))))
(if failed
(progn
(setq predicate-failed t)
nil)
(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 (gc-print-state)))
(setf (gc-print-state) nil)
(format t "~&**********************************~%")
(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 (gc-print-state) state))))))
(defun gc-print-state ()
#+cmu ext:*gc-verbose*
#+allegro (sys:gsgc-switch :print)
)
(defun (setf gc-print-state) (state)
#+cmu (setf ext:*gc-verbose* state)
#+allegro (setf (sys:gsgc-switch :print) state)
)
(provide :tester #+module-versions 1.1)