From: Kevin M. Rosenberg Date: Sun, 20 Jul 2003 18:34:58 +0000 (+0000) Subject: r5344: *** empty log message *** X-Git-Tag: v3.8.6~816 X-Git-Url: http://git.kpe.io/?p=clsql.git;a=commitdiff_plain;h=6197056cf10e596c0e1fd8d76a5202c1a673b37f r5344: *** empty log message *** --- diff --git a/tests/ptester.lisp b/tests/ptester.lisp deleted file mode 100644 index 7a2cc77..0000000 --- a/tests/ptester.lisp +++ /dev/null @@ -1,588 +0,0 @@ -;; 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) diff --git a/tests/rt.lisp b/tests/rt.lisp deleted file mode 100644 index d4dd2ae..0000000 --- a/tests/rt.lisp +++ /dev/null @@ -1,254 +0,0 @@ -#|----------------------------------------------------------------------------| - | 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))))