X-Git-Url: http://git.kpe.io/?p=rt.git;a=blobdiff_plain;f=rt.lisp;h=3df87c4b246ab8d1d7f33d09a2606b22bfb0ffbe;hp=b24ecf1adac7b3910cae70f0ee02e99b4a5a4228;hb=HEAD;hpb=17ebaf0bbb7e594f0397286aac4b89ae6ebe61d3

diff --git a/rt.lisp b/rt.lisp
index b24ecf1..3df87c4 100644
--- a/rt.lisp
+++ b/rt.lisp
@@ -21,147 +21,389 @@
  |  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)
+(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"))
+
+;;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 *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 *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.")
+
+(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.
 
-(defstruct (entry (:conc-name nil)
-		  (:type list))
-  pend name form)
+(defstruct note
+  name
+  contents
+  disabled ;; When true, tests with this note are considered inactive
+  )
 
-(defmacro vals (entry) `(cdddr ,entry))
+;; (defmacro vals (entry) `(cdddr ,entry))
 
-(defmacro defn (entry) `(cdr ,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))
+        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)))
+        "Redefining test ~:@(~S~)"
+        (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)))
 
 (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))))
-
+  (cond (*debug*
+         (apply #'format t args)
+         (if error? (throw '*debug* nil)))
+        (error? (apply #'error 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.
+   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 (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 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 (my-row-major-aref x i)
+                                          (my-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
+                      ()
+                      (cond
+                       (*compile-tests*
+                        (multiple-value-list
+                         (funcall (compile
+                                   nil
+                                   `(lambda ()
+                                      (declare
+                                       (optimize ,@*optimization-settings*))
+                                      ,(form entry))))))
+                       (*expanded-eval*
+                        (multiple-value-list
+                         (expanded-eval (form entry))))
+                       (t
+                        (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)
-	    (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))
+          (handler-case
+           (let ((st (format nil "Actual value~P: ~
                       ~{~S~^~%~15t~}.~%"
-		*test* (form entry)
-		(length (vals entry))
-		(vals entry)
-		(length r) r))))
-      (when (not (pend entry)) *test*))
+                            (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)
       (do-entries *standard-output*)))
-
+
 (defun do-tests (&optional
-		 (out *standard-output*))
+                 (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))))
+      (with-open-file
+          (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)
-	  (length (cdr *entries*)))
+          (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))))
-  (let ((pending (pending-tests)))
-    (if (null pending)
-	(format s "~&No tests failed.")
-	(format s "~&~A out of ~A ~
+              (do-entry entry s))
+      (finish-output 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))
-    (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)))
+          ))
+      (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))