From 65a01dae3d437a48e8dd0d051a446245f9e29929 Mon Sep 17 00:00:00 2001 From: Christophe Rhodes Date: Tue, 22 Apr 2003 15:23:09 +0000 Subject: [PATCH] 0.pre8.92: Add SB-RT (a regression tester framework) as a contrib ... not with a great fanfare, though, as philosophically it's for contrib use, not general public use; ... make sb-aclrepl and sb-bsd-sockets use sb-rt, not their own local copies of rt. --- contrib/sb-aclrepl/aclrepl-tests.lisp | 9 +- contrib/sb-aclrepl/rt.lisp | 283 ----------------------------- contrib/sb-aclrepl/sb-aclrepl.asd | 1 + contrib/sb-bsd-sockets/rt.lisp | 167 ----------------- contrib/sb-bsd-sockets/sb-bsd-sockets.asd | 8 +- contrib/sb-bsd-sockets/tests.lisp | 2 +- contrib/sb-rt/sb-rt.asd | 13 ++ contrib/sb-rt/sb-rt.lisp | 253 ++++++++++++++++++++++++++ version.lisp-expr | 2 +- 9 files changed, 278 insertions(+), 460 deletions(-) delete mode 100644 contrib/sb-aclrepl/rt.lisp delete mode 100644 contrib/sb-bsd-sockets/rt.lisp create mode 100644 contrib/sb-rt/sb-rt.asd create mode 100644 contrib/sb-rt/sb-rt.lisp diff --git a/contrib/sb-aclrepl/aclrepl-tests.lisp b/contrib/sb-aclrepl/aclrepl-tests.lisp index 2b8bb7e..473b518 100644 --- a/contrib/sb-aclrepl/aclrepl-tests.lisp +++ b/contrib/sb-aclrepl/aclrepl-tests.lisp @@ -19,10 +19,11 @@ )) (eval-when (:compile-toplevel :load-toplevel :execute) - (unless (find-package 'regression-test) - (load (sb-aclrepl::compile-file-as-needed "rt.lisp")))) -(use-package :regression-test) -(setf regression-test::*catch-errors* nil) + (unless (find-package :sb-rt) + (error "SB-RT package not found"))) + +(use-package :sb-rt) +(setf sb-rt::*catch-errors* nil) (rem-all-tests) diff --git a/contrib/sb-aclrepl/rt.lisp b/contrib/sb-aclrepl/rt.lisp deleted file mode 100644 index 430e2ef..0000000 --- a/contrib/sb-aclrepl/rt.lisp +++ /dev/null @@ -1,283 +0,0 @@ -;-*- Mode: Lisp -*- -;;;; Paul Dietz's version of rt from ansi-tests - -(defpackage :regression-test - (:use #:cl) - (:nicknames :rtest #-lispworks :rt) - (:export - #:*do-tests-when-defined* - #:*test* - #:continue-testing - #:deftest - #:do-test - #:do-tests - #:get-test - #:pending-tests - #:rem-all-tests - #:rem-test - )) - -(in-package :regression-test) -;-*-syntax:COMMON-LISP;Package:(RT :use "COMMON-LISP" :colon-mode :external)-*- - -#|----------------------------------------------------------------------------| - | 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. | - |----------------------------------------------------------------------------|# - -;This is the December 19, 1990 version of the regression tester. - -(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. - Currently doesn't work on arrays of dimension > 2." - (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) - #| - ((and (typep x 'array) - (= (array-rank x) 2)) - (let ((dim (array-dimensions x))) - (loop for i from 0 below (first dim) - always (loop for j from 0 below (second dim) - always (equalp-with-case (aref x i j) - (aref y i j)))))) - |# - - ((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 - (#-ecl (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)))) diff --git a/contrib/sb-aclrepl/sb-aclrepl.asd b/contrib/sb-aclrepl/sb-aclrepl.asd index 410ff07..9cfaa2c 100644 --- a/contrib/sb-aclrepl/sb-aclrepl.asd +++ b/contrib/sb-aclrepl/sb-aclrepl.asd @@ -7,6 +7,7 @@ :version "0.6" :author "Kevin Rosenberg " :description "An AllegroCL compatible REPL" + :depends-on (sb-rt) :components ((:file "repl") (:file "inspect" :depends-on ("repl")) (:file "debug" :depends-on ("repl")))) diff --git a/contrib/sb-bsd-sockets/rt.lisp b/contrib/sb-bsd-sockets/rt.lisp deleted file mode 100644 index ab7a79c..0000000 --- a/contrib/sb-bsd-sockets/rt.lisp +++ /dev/null @@ -1,167 +0,0 @@ -;-*-syntax:COMMON-LISP;Package:(RT :use "COMMON-LISP" :colon-mode :external)-*- - -#|----------------------------------------------------------------------------| - | 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. | - |----------------------------------------------------------------------------|# - -;This is the December 19, 1990 version of the regression tester. - -(defpackage "RT" - (:use "COMMON-LISP") - (:export deftest get-test do-test rem-test - rem-all-tests do-tests pending-tests - continue-testing *test* - *do-tests-when-defined*)) -(in-package :rt) -(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") - -(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 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) - (r (multiple-value-list - (eval (form entry))))) - (setf (pend entry) - (not (equal r (vals entry)))) - (when (pend entry) - (format s "~&Test ~:@(~S~) failed~ - ~%Form: ~S~ - ~%Expected value~P: ~ - ~{~S~^~%~17t~}~ - ~%Actual value~P: ~ - ~{~S~^~%~15t~}.~%" - *test* (form entry) - (length (vals entry)) - (vals entry) - (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))) - (if (null pending) - (format s "~&No tests failed.") - (format s "~&~A out of ~A ~ - total tests failed: ~ - ~:@(~{~<~% ~1:;~S~>~ - ~^, ~}~)." - (length pending) - (length (cdr *entries*)) - pending)) - (null pending))) diff --git a/contrib/sb-bsd-sockets/sb-bsd-sockets.asd b/contrib/sb-bsd-sockets/sb-bsd-sockets.asd index bf946c3..6cc6b22 100644 --- a/contrib/sb-bsd-sockets/sb-bsd-sockets.asd +++ b/contrib/sb-bsd-sockets/sb-bsd-sockets.asd @@ -94,7 +94,8 @@ (defsystem sb-bsd-sockets :version "0.58" - :components ((:file "defpackage" :depends-on ("rt")) + :depends-on (sb-rt) + :components ((:file "defpackage") (:file "split" :depends-on ("defpackage")) (:file "array-data" :depends-on ("defpackage")) (:unix-dso "alien" @@ -115,9 +116,8 @@ (:file "name-service" :depends-on ("sockets" "constants" "alien")) (:file "misc" :depends-on ("sockets" "constants")) - (:file "rt") (:file "def-to-lisp") - (:file "tests" :depends-on ("inet" "sockopt" "rt")) + (:file "tests" :depends-on ("inet" "sockopt")) (:static-file "NEWS") ;; (:static-file "INSTALL") @@ -127,6 +127,6 @@ (:static-file "TODO"))) (defmethod perform ((o test-op) (c (eql (find-system :sb-bsd-sockets)))) - (or (funcall (intern "DO-TESTS" (find-package "RT"))) + (or (funcall (intern "DO-TESTS" (find-package "SB-RT"))) (error "test-op failed"))) diff --git a/contrib/sb-bsd-sockets/tests.lisp b/contrib/sb-bsd-sockets/tests.lisp index 804fe5b..0d6f3fc 100644 --- a/contrib/sb-bsd-sockets/tests.lisp +++ b/contrib/sb-bsd-sockets/tests.lisp @@ -1,5 +1,5 @@ (defpackage "SB-BSD-SOCKETS-TEST" - (:use "CL" "SB-BSD-SOCKETS" "RT")) + (:use "CL" "SB-BSD-SOCKETS" "SB-RT")) #|| diff --git a/contrib/sb-rt/sb-rt.asd b/contrib/sb-rt/sb-rt.asd new file mode 100644 index 0000000..1fee8e8 --- /dev/null +++ b/contrib/sb-rt/sb-rt.asd @@ -0,0 +1,13 @@ +;;; -*- Lisp -*- + +(cl:defpackage #:sb-rt-system + (:use #:asdf #:cl)) +(cl:in-package #:sb-rt-system) + +(defsystem sb-rt + :version "0.1.7" ; our version "0", GCL CVS version "1.7" + :components ((:file "sb-rt"))) + +(defmethod perform ((o test-op) (c (eql (find-system :sb-rt)))) + ;; FIXME: Maybe also import rt-tests.lisp? + t) \ No newline at end of file diff --git a/contrib/sb-rt/sb-rt.lisp b/contrib/sb-rt/sb-rt.lisp new file mode 100644 index 0000000..6622760 --- /dev/null +++ b/contrib/sb-rt/sb-rt.lisp @@ -0,0 +1,253 @@ +#|----------------------------------------------------------------------------| + | 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 :sb-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")) + +(in-package :sb-rt) + +(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)))) diff --git a/version.lisp-expr b/version.lisp-expr index 0369f62..dd4d9e6 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"0.pre8.91" +"0.pre8.92" -- 1.7.10.4