From 2a5eb83576baa32fc19fa60e33d7bc898e10dc63 Mon Sep 17 00:00:00 2001 From: "Kevin M. Rosenberg" Date: Mon, 21 Jun 2004 21:29:34 +0000 Subject: [PATCH] r9661: update from Paul Dietz's latest ansi-test version --- debian/changelog | 6 + rt-original.lisp | 167 --------------------------- rt.lisp | 285 ++++++++++++++++++++++++++++++++++++----------- 3 files changed, 226 insertions(+), 232 deletions(-) delete mode 100644 rt-original.lisp diff --git a/debian/changelog b/debian/changelog index f2ca802..0310811 100644 --- a/debian/changelog +++ b/debian/changelog @@ -1,3 +1,9 @@ +cl-rt (20040621-1) unstable; urgency=low + + * New upstream from Paul Dietz's ansi-tests + + -- Kevin M. Rosenberg Mon, 21 Jun 2004 15:27:33 -0600 + cl-rt (20030428b-1) unstable; urgency=low * Fix dos line endings diff --git a/rt-original.lisp b/rt-original.lisp deleted file mode 100644 index b24ecf1..0000000 --- a/rt-original.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/rt.lisp b/rt.lisp index d4dd2ae..dabd075 100644 --- a/rt.lisp +++ b/rt.lisp @@ -1,3 +1,5 @@ +;-*-syntax:COMMON-LISP;Package:(RT :use "COMMON-LISP" :colon-mode :external)-*- + #|----------------------------------------------------------------------------| | Copyright 1990 by the Massachusetts Institute of Technology, Cambridge MA. | | | @@ -27,78 +29,138 @@ #:rem-all-tests #:rem-test) (:documentation "The MIT regression tester with pfdietz's modifications")) +;;This was the December 19, 1990 version of the regression tester, but +;;has since been modified. + (in-package :regression-test) +(declaim (ftype (function (t) t) get-entry expanded-eval do-entries)) +(declaim (type list *entries*)) +(declaim (ftype (function (t &rest t) t) report-error)) +(declaim (ftype (function (t &optional t) t) do-entry)) + (defvar *test* nil "Current test name") (defvar *do-tests-when-defined* nil) -(defvar *entries* '(nil) "Test database") +(defvar *entries* '(nil) "Test database. Has a leading dummy cell that does not contain an entry.") +(defvar *entries-tail* *entries* "Tail of the *entries* list") +(defvar *entries-table* (make-hash-table :test #'equal) + "Map the names of entries to the cons cell in *entries* that precedes the one whose car is the entry.") (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 *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 *compile-tests* nil "When true, compile the tests before running them.") +(defvar *expanded-eval* nil "When true, convert the tests into a form that is less likely to have compiler optimizations.") (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) +(defvar *notes* (make-hash-table :test 'equal) + "A mapping from names of notes to note objects.") + +(defstruct (entry (:conc-name nil)) + pend name props form vals) + +;;; Note objects are used to attach information to tests. +;;; A typical use is to mark tests that depend on a particular +;;; part of a set of requirements, or a particular interpretation +;;; of the requirements. -(defmacro vals (entry) `(cdddr ,entry)) +(defstruct note + name + contents + disabled ;; When true, tests with this note are considered inactive + ) -(defmacro defn (entry) `(cdr ,entry)) +;; (defmacro vals (entry) `(cdddr ,entry)) + +(defmacro defn (entry) + (let ((var (gensym))) + `(let ((,var ,entry)) + (list* (name ,var) (form ,var) (vals ,var))))) + +(defun entry-notes (entry) + (let* ((props (props entry)) + (notes (getf props :notes))) + (if (listp notes) + notes + (list notes)))) + +(defun has-disabled-note (entry) + (let ((notes (entry-notes entry))) + (loop for n in notes + for note = (if (note-p n) n + (gethash n *notes*)) + thereis (and note (note-disabled note))))) (defun pending-tests () - (do ((l (cdr *entries*) (cdr l)) - (r nil)) - ((null l) (nreverse r)) - (when (pend (car l)) - (push (name (car l)) r)))) + (loop for entry in (cdr *entries*) + when (and (pend entry) (not (has-disabled-note entry))) + collect (name entry))) (defun rem-all-tests () (setq *entries* (list nil)) + (setq *entries-tail* *entries*) + (clrhash *entries-table*) 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)))) + (let ((pred (gethash name *entries-table*))) + (when pred + (if (null (cddr pred)) + (setq *entries-tail* pred) + (setf (gethash (name (caddr pred)) *entries-table*) pred)) + (setf (cdr pred) (cddr pred)) + (remhash name *entries-table*) + 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))) + (let ((entry ;; (find name (the list (cdr *entries*)) + ;; :key #'name :test #'equal) + (cadr (gethash name *entries-table*)) + )) (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))) +(defmacro deftest (name &rest body) + (let* ((p body) + (properties + (loop while (keywordp (first p)) + unless (cadr p) + do (error "Poorly formed deftest: ~A~%" + (list* 'deftest name body)) + append (list (pop p) (pop p)))) + (form (pop p)) + (vals p)) + `(add-entry (make-entry :pend t + :name ',name + :props ',properties + :form ',form + :vals ',vals)))) (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) + (setq entry (copy-entry entry)) + (let* ((pred (gethash (name entry) *entries-table*))) + (cond + (pred + (setf (cadr pred) entry) (report-error nil "Redefining test ~:@(~S~)" - (name entry)) - (return nil))) + (name entry))) + (t + (setf (gethash (name entry) *entries-table*) *entries-tail*) + (setf (cdr *entries-tail*) (cons entry nil)) + (setf *entries-tail* (cdr *entries-tail*)) + ))) (when *do-tests-when-defined* (do-entry entry)) (setq *test* (name entry))) @@ -108,13 +170,23 @@ (apply #'format t args) (if error? (throw '*debug* nil))) (error? (apply #'error args)) - (t (apply #'warn args)))) + (t (apply #'warn args))) + nil) (defun do-test (&optional (name *test*)) - (do-entry (get-entry name))) + #-sbcl (do-entry (get-entry name)) + #+sbcl (handler-bind ((sb-ext:code-deletion-note #'muffle-warning)) + (do-entry (get-entry name)))) + +(defun my-aref (a &rest args) + (apply #'aref a args)) + +(defun my-row-major-aref (a index) + (row-major-aref a index)) (defun equalp-with-case (x y) - "Like EQUALP, but doesn't do case conversion of characters." + "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) @@ -123,27 +195,30 @@ (equalp-with-case (cdr x) (cdr y)))) ((and (typep x 'array) (= (array-rank x) 0)) - (equalp-with-case (aref x) (aref y))) + (equalp-with-case (my-aref x) (my-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 + for i from 0 below x-len + for e1 = (my-aref x i) + for e2 = (my-aref y i) 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)))))) + always (equalp-with-case (my-row-major-aref x i) + (my-row-major-aref y i)))))) + (t (eql x y)))) (defun do-entry (entry &optional @@ -161,24 +236,29 @@ (setf r (flet ((%do () - (if *compile-tests* - (multiple-value-list - (funcall (compile - nil - `(lambda () - (declare - (optimize ,@*optimization-settings*)) - ,(form entry))))) + (cond + (*compile-tests* + (multiple-value-list + (funcall (compile + nil + `(lambda () + (declare + (optimize ,@*optimization-settings*)) + ,(form entry)))))) + (*expanded-eval* (multiple-value-list - (eval (form entry)))))) + (expanded-eval (form entry)))) + (t + (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)) + (#-ecl (style-warning #'muffle-warning) + (error #'(lambda (c) + (setf aborted t) + (setf r (list c)) + (return-from aborted nil)))) + (%do)) (%do))))) (setf (pend entry) @@ -194,11 +274,53 @@ *test* (form entry) (length (vals entry)) (vals entry)) - (format s "Actual value~P: ~ + (handler-case + (let ((st (format nil "Actual value~P: ~ ~{~S~^~%~15t~}.~%" - (length r) r))))) + (length r) r))) + (format s "~A" st)) + (error () (format s "Actual value: #~%") + )) + (finish-output s) + )))) (when (not (pend entry)) *test*)) +(defun expanded-eval (form) + "Split off top level of a form and eval separately. This reduces the chance that + compiler optimizations will fold away runtime computation." + (if (not (consp form)) + (eval form) + (let ((op (car form))) + (cond + ((eq op 'let) + (let* ((bindings (loop for b in (cadr form) + collect (if (consp b) b (list b nil)))) + (vars (mapcar #'car bindings)) + (binding-forms (mapcar #'cadr bindings))) + (apply + (the function + (eval `(lambda ,vars ,@(cddr form)))) + (mapcar #'eval binding-forms)))) + ((and (eq op 'let*) (cadr form)) + (let* ((bindings (loop for b in (cadr form) + collect (if (consp b) b (list b nil)))) + (vars (mapcar #'car bindings)) + (binding-forms (mapcar #'cadr bindings))) + (funcall + (the function + (eval `(lambda (,(car vars) &aux ,@(cdr bindings)) ,@(cddr form)))) + (eval (car binding-forms))))) + ((eq op 'progn) + (loop for e on (cdr form) + do (if (null (cdr e)) (return (eval (car e))) + (eval (car e))))) + ((and (symbolp op) (fboundp op) + (not (macro-function op)) + (not (special-operator-p op))) + (apply (symbol-function op) + (mapcar #'eval (cdr form)))) + (t (eval form)))))) + (defun continue-testing () (if *in-test* (throw '*in-test* nil) @@ -214,16 +336,19 @@ (stream out :direction :output) (do-entries stream)))) -(defun do-entries (s) +(defun do-entries* (s) (format s "~&Doing ~A pending test~:P ~ of ~A tests total.~%" - (count t (cdr *entries*) - :key #'pend) + (count t (the list (cdr *entries*)) :key #'pend) (length (cdr *entries*))) + (finish-output s) (dolist (entry (cdr *entries*)) - (when (pend entry) + (when (and (pend entry) + (not (has-disabled-note entry))) (format s "~@[~<~%~:; ~:@(~S~)~>~]" - (do-entry entry s)))) + (do-entry entry s)) + (finish-output s) + )) (let ((pending (pending-tests)) (expected-table (make-hash-table :test #'equal))) (dolist (ex *expected-failures*) @@ -251,4 +376,34 @@ (length new-failures) new-failures))) )) + (finish-output s) (null pending)))) + +(defun do-entries (s) + #-sbcl (do-entries* s) + #+sbcl (handler-bind ((sb-ext:code-deletion-note #'muffle-warning)) + (do-entries* s))) + +;;; Note handling functions and macros + +(defmacro defnote (name contents &optional disabled) + `(eval-when (:load-toplevel :execute) + (let ((note (make-note :name ',name + :contents ',contents + :disabled ',disabled))) + (setf (gethash (note-name note) *notes*) note) + note))) + +(defun disable-note (n) + (let ((note (if (note-p n) n + (setf n (gethash n *notes*))))) + (unless note (error "~A is not a note or note name." n)) + (setf (note-disabled note) t) + note)) + +(defun enable-note (n) + (let ((note (if (note-p n) n + (setf n (gethash n *notes*))))) + (unless note (error "~A is not a note or note name." n)) + (setf (note-disabled note) nil) + note)) -- 2.34.1