+++ /dev/null
-;; 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: ptester.lisp,v 1.1 2003/07/20 18:31:22 kevin Exp $
-
-(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))))
-
-(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))))
- #+allegro
- (let ((state (sys:gsgc-switch :print)))
- (setf (sys:gsgc-switch :print) 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 (sys:gsgc-switch :print) state))
- #-allegro
- (progn
- (format t "~&**********************************~%")
- (format t "End ~a test~%" ,g-name)
- (format t "Errors detected in this test: ~D " *test-errors*)
- (unless (zerop *test-unexpected-failures*)
- (format t "UNEXPECTED: ~D" *test-unexpected-failures*))
- (format t "~%Successes this test:~D~%" *test-successes*))))))
-
-(provide :tester #+module-versions 1.1)
+++ /dev/null
-#|----------------------------------------------------------------------------|
- | Copyright 1990 by the Massachusetts Institute of Technology, Cambridge MA. |
- | |
- | Permission to use, copy, modify, and distribute this software and its |
- | documentation for any purpose and without fee is hereby granted, provided |
- | that this copyright and permission notice appear in all copies and |
- | supporting documentation, and that the name of M.I.T. not be used in |
- | advertising or publicity pertaining to distribution of the software |
- | without specific, written prior permission. M.I.T. makes no |
- | representations about the suitability of this software for any purpose. |
- | It is provided "as is" without express or implied warranty. |
- | |
- | M.I.T. DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING |
- | ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, IN NO EVENT SHALL |
- | M.I.T. BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR |
- | ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, |
- | WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, |
- | ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS |
- | SOFTWARE. |
- |----------------------------------------------------------------------------|#
-
-(defpackage #:regression-test
- (:nicknames #:rtest #-lispworks #:rt)
- (:use #:cl)
- (:export #:*do-tests-when-defined* #:*test* #:continue-testing
- #:deftest #:do-test #:do-tests #:get-test #:pending-tests
- #:rem-all-tests #:rem-test)
- (:documentation "The MIT regression tester with pfdietz's modifications"))
-
-(in-package :regression-test)
-
-(defvar *test* nil "Current test name")
-(defvar *do-tests-when-defined* nil)
-(defvar *entries* '(nil) "Test database")
-(defvar *in-test* nil "Used by TEST")
-(defvar *debug* nil "For debugging")
-(defvar *catch-errors* t
- "When true, causes errors in a test to be caught.")
-(defvar *print-circle-on-failure* nil
- "Failure reports are printed with *PRINT-CIRCLE* bound to this value.")
-(defvar *compile-tests* nil
- "When true, compile the tests before running them.")
-(defvar *optimization-settings* '((safety 3)))
-(defvar *expected-failures* nil
- "A list of test names that are expected to fail.")
-
-(defstruct (entry (:conc-name nil)
- (:type list))
- pend name form)
-
-(defmacro vals (entry) `(cdddr ,entry))
-
-(defmacro defn (entry) `(cdr ,entry))
-
-(defun pending-tests ()
- (do ((l (cdr *entries*) (cdr l))
- (r nil))
- ((null l) (nreverse r))
- (when (pend (car l))
- (push (name (car l)) r))))
-
-(defun rem-all-tests ()
- (setq *entries* (list nil))
- nil)
-
-(defun rem-test (&optional (name *test*))
- (do ((l *entries* (cdr l)))
- ((null (cdr l)) nil)
- (when (equal (name (cadr l)) name)
- (setf (cdr l) (cddr l))
- (return name))))
-
-(defun get-test (&optional (name *test*))
- (defn (get-entry name)))
-
-(defun get-entry (name)
- (let ((entry (find name (cdr *entries*)
- :key #'name
- :test #'equal)))
- (when (null entry)
- (report-error t
- "~%No test with name ~:@(~S~)."
- name))
- entry))
-
-(defmacro deftest (name form &rest values)
- `(add-entry '(t ,name ,form .,values)))
-
-(defun add-entry (entry)
- (setq entry (copy-list entry))
- (do ((l *entries* (cdr l))) (nil)
- (when (null (cdr l))
- (setf (cdr l) (list entry))
- (return nil))
- (when (equal (name (cadr l))
- (name entry))
- (setf (cadr l) entry)
- (report-error nil
- "Redefining test ~:@(~S~)"
- (name entry))
- (return nil)))
- (when *do-tests-when-defined*
- (do-entry entry))
- (setq *test* (name entry)))
-
-(defun report-error (error? &rest args)
- (cond (*debug*
- (apply #'format t args)
- (if error? (throw '*debug* nil)))
- (error? (apply #'error args))
- (t (apply #'warn args))))
-
-(defun do-test (&optional (name *test*))
- (do-entry (get-entry name)))
-
-(defun equalp-with-case (x y)
- "Like EQUALP, but doesn't do case conversion of characters."
- (cond
- ((eq x y) t)
- ((consp x)
- (and (consp y)
- (equalp-with-case (car x) (car y))
- (equalp-with-case (cdr x) (cdr y))))
- ((and (typep x 'array)
- (= (array-rank x) 0))
- (equalp-with-case (aref x) (aref y)))
- ((typep x 'vector)
- (and (typep y 'vector)
- (let ((x-len (length x))
- (y-len (length y)))
- (and (eql x-len y-len)
- (loop
- for e1 across x
- for e2 across y
- always (equalp-with-case e1 e2))))))
- ((and (typep x 'array)
- (typep y 'array)
- (not (equal (array-dimensions x)
- (array-dimensions y))))
- nil)
- ((typep x 'array)
- (and (typep y 'array)
- (let ((size (array-total-size x)))
- (loop for i from 0 below size
- always (equalp-with-case (row-major-aref x i)
- (row-major-aref y i))))))
- (t (eql x y))))
-
-(defun do-entry (entry &optional
- (s *standard-output*))
- (catch '*in-test*
- (setq *test* (name entry))
- (setf (pend entry) t)
- (let* ((*in-test* t)
- ;; (*break-on-warnings* t)
- (aborted nil)
- r)
- ;; (declare (special *break-on-warnings*))
-
- (block aborted
- (setf r
- (flet ((%do
- ()
- (if *compile-tests*
- (multiple-value-list
- (funcall (compile
- nil
- `(lambda ()
- (declare
- (optimize ,@*optimization-settings*))
- ,(form entry)))))
- (multiple-value-list
- (eval (form entry))))))
- (if *catch-errors*
- (handler-bind
- ((style-warning #'muffle-warning)
- (error #'(lambda (c)
- (setf aborted t)
- (setf r (list c))
- (return-from aborted nil))))
- (%do))
- (%do)))))
-
- (setf (pend entry)
- (or aborted
- (not (equalp-with-case r (vals entry)))))
-
- (when (pend entry)
- (let ((*print-circle* *print-circle-on-failure*))
- (format s "~&Test ~:@(~S~) failed~
- ~%Form: ~S~
- ~%Expected value~P: ~
- ~{~S~^~%~17t~}~%"
- *test* (form entry)
- (length (vals entry))
- (vals entry))
- (format s "Actual value~P: ~
- ~{~S~^~%~15t~}.~%"
- (length r) r)))))
- (when (not (pend entry)) *test*))
-
-(defun continue-testing ()
- (if *in-test*
- (throw '*in-test* nil)
- (do-entries *standard-output*)))
-
-(defun do-tests (&optional
- (out *standard-output*))
- (dolist (entry (cdr *entries*))
- (setf (pend entry) t))
- (if (streamp out)
- (do-entries out)
- (with-open-file
- (stream out :direction :output)
- (do-entries stream))))
-
-(defun do-entries (s)
- (format s "~&Doing ~A pending test~:P ~
- of ~A tests total.~%"
- (count t (cdr *entries*)
- :key #'pend)
- (length (cdr *entries*)))
- (dolist (entry (cdr *entries*))
- (when (pend entry)
- (format s "~@[~<~%~:; ~:@(~S~)~>~]"
- (do-entry entry s))))
- (let ((pending (pending-tests))
- (expected-table (make-hash-table :test #'equal)))
- (dolist (ex *expected-failures*)
- (setf (gethash ex expected-table) t))
- (let ((new-failures
- (loop for pend in pending
- unless (gethash pend expected-table)
- collect pend)))
- (if (null pending)
- (format s "~&No tests failed.")
- (progn
- (format s "~&~A out of ~A ~
- total tests failed: ~
- ~:@(~{~<~% ~1:;~S~>~
- ~^, ~}~)."
- (length pending)
- (length (cdr *entries*))
- pending)
- (if (null new-failures)
- (format s "~&No unexpected failures.")
- (when *expected-failures*
- (format s "~&~A unexpected failures: ~
- ~:@(~{~<~% ~1:;~S~>~
- ~^, ~}~)."
- (length new-failures)
- new-failures)))
- ))
- (null pending))))
projects / clsql.git / commitdiff