+;-*-syntax:COMMON-LISP;Package:(RT :use "COMMON-LISP" :colon-mode :external)-*-
+
#|----------------------------------------------------------------------------|
| Copyright 1990 by the Massachusetts Institute of Technology, Cambridge MA. |
| |
#: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)))
(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)
(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
(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)
*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: #<error during printing>~%")
+ ))
+ (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)
(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*)
(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))
projects / rt.git / blobdiff