From: Kevin M. Rosenberg Date: Mon, 28 Apr 2003 17:31:00 +0000 (+0000) Subject: r4661: Auto commit for Debian build X-Git-Url: http://git.kpe.io/?p=rt.git;a=commitdiff_plain;h=566de2a39e19a50335b11b66d5c63865a1315665 r4661: Auto commit for Debian build --- diff --git a/debian/changelog b/debian/changelog index d949a40..8ce55d5 100644 --- a/debian/changelog +++ b/debian/changelog @@ -1,3 +1,10 @@ +cl-rt (2003.04.28-1) unstable; urgency=low + + * Update with Paul Dietz's modifications (same as used by + SBCL's sb-rt package) + + -- Kevin M. Rosenberg Mon, 28 Apr 2003 11:30:36 -0600 + cl-rt (19901219.1-1) unstable; urgency=low * Add examples file and documentation file (closes: 170890) diff --git a/rt-original.lisp b/rt-original.lisp new file mode 100644 index 0000000..b24ecf1 --- /dev/null +++ b/rt-original.lisp @@ -0,0 +1,167 @@ +;-*-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/rt.lisp b/rt.lisp index b24ecf1..58b25c4 100644 --- a/rt.lisp +++ b/rt.lisp @@ -1,5 +1,3 @@ -;-*-syntax:COMMON-LISP;Package:(RT :use "COMMON-LISP" :colon-mode :external)-*- - #|----------------------------------------------------------------------------| | Copyright 1990 by the Massachusetts Institute of Technology, Cambridge MA. | | | @@ -21,20 +19,29 @@ | 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*)) +(defpackage :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 :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)) @@ -61,7 +68,7 @@ (when (equal (name (cadr l)) name) (setf (cdr l) (cddr l)) (return name)))) - + (defun get-test (&optional (name *test*)) (defn (get-entry name))) @@ -88,7 +95,7 @@ (name entry)) (setf (cadr l) entry) (report-error nil - "Redefining test ~@:(~S~)" + "Redefining test ~:@(~S~)" (name entry)) (return nil))) (when *do-tests-when-defined* @@ -101,39 +108,101 @@ (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*)) + (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))))) + ;; (*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) - (not (equal r (vals entry)))) + (or aborted + (not (equalp-with-case r (vals entry))))) + (when (pend entry) - (format s "~&Test ~:@(~S~) failed~ + (let ((*print-circle* *print-circle-on-failure*)) + (format s "~&Test ~:@(~S~) failed~ ~%Form: ~S~ ~%Expected value~P: ~ - ~{~S~^~%~17t~}~ - ~%Actual value~P: ~ + ~{~S~^~%~17t~}~%" + *test* (form entry) + (length (vals entry)) + (vals entry)) + (format s "Actual value~P: ~ ~{~S~^~%~15t~}.~%" - *test* (form entry) - (length (vals entry)) - (vals entry) - (length r) r)))) - (when (not (pend entry)) *test*)) + (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*)) @@ -154,14 +223,31 @@ (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 ~ + (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)) - (null pending))) + (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))))