X-Git-Url: http://git.kpe.io/?p=rt.git;a=blobdiff_plain;f=rt.lisp;h=3df87c4b246ab8d1d7f33d09a2606b22bfb0ffbe;hp=dabd075f4085dc5fbe39db0408c3b62cdf02334e;hb=2a18cdd52aa3da52e1010aae854d1866f92c483a;hpb=bd0b5d4dc2a326acdc63ed3b4dd19a37b4539aa9

diff --git a/rt.lisp b/rt.lisp
index dabd075..3df87c4 100644
--- a/rt.lisp
+++ b/rt.lisp
@@ -22,11 +22,11 @@
  |----------------------------------------------------------------------------|#
 
 (defpackage #:regression-test
-  (:nicknames #:rtest #-lispworks #:rt) 
+  (: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)
+           #: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
@@ -60,7 +60,7 @@
 
 (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)
 
@@ -70,7 +70,7 @@
 ;;; of the requirements.
 
 (defstruct note
-  name  
+  name
   contents
   disabled ;; When true, tests with this note are considered inactive
   )
@@ -84,22 +84,22 @@
 
 (defun entry-notes (entry)
   (let* ((props (props entry))
-	 (notes (getf props :notes)))
+         (notes (getf props :notes)))
     (if (listp notes)
-	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)))))
+          for note = (if (note-p n) n
+                       (gethash n *notes*))
+          thereis (and note (note-disabled note)))))
 
 (defun pending-tests ()
   (loop for entry in (cdr *entries*)
-	when (and (pend entry) (not (has-disabled-note entry)))
-	collect (name entry)))
+        when (and (pend entry) (not (has-disabled-note entry)))
+        collect (name entry)))
 
 (defun rem-all-tests ()
   (setq *entries* (list nil))
@@ -111,8 +111,8 @@
   (let ((pred (gethash name *entries-table*)))
     (when pred
       (if (null (cddr pred))
-	  (setq *entries-tail* pred)
-	(setf (gethash (name (caddr pred)) *entries-table*) pred))
+          (setq *entries-tail* pred)
+        (setf (gethash (name (caddr pred)) *entries-table*) pred))
       (setf (cdr pred) (cddr pred))
       (remhash name *entries-table*)
       name)))
@@ -122,30 +122,30 @@
 
 (defun get-entry (name)
   (let ((entry ;; (find name (the list (cdr *entries*))
-	       ;;     :key #'name :test #'equal)
-	 (cadr (gethash name *entries-table*))
-	 ))
+               ;;     :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 &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))
+         (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))))
+                            :name ',name
+                            :props ',properties
+                            :form ',form
+                            :vals ',vals))))
 
 (defun add-entry (entry)
   (setq entry (copy-entry entry))
@@ -166,17 +166,17 @@
   (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*))
   #-sbcl (do-entry (get-entry name))
   #+sbcl (handler-bind ((sb-ext:code-deletion-note #'muffle-warning))
-		       (do-entry (get-entry name))))
+                       (do-entry (get-entry name))))
 
 (defun my-aref (a &rest args)
   (apply #'aref a args))
@@ -191,98 +191,98 @@
    ((eq x y) t)
    ((consp x)
     (and (consp y)
-	 (equalp-with-case (car x) (car y))
-	 (equalp-with-case (cdr x) (cdr y))))
+         (equalp-with-case (car x) (car y))
+         (equalp-with-case (cdr x) (cdr y))))
    ((and (typep x 'array)
-	 (= (array-rank x) 0))
+         (= (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))))))
+         (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))))
+         (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))))))
+         (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)
-	   (aborted nil)
-	   r)
+           ;; (*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 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)
-	    (or aborted
-		(not (equalp-with-case r (vals 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~
+        (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))
-	  (handler-case
-	   (let ((st (format nil "Actual value~P: ~
+                  *test* (form entry)
+                  (length (vals entry))
+                  (vals entry))
+          (handler-case
+           (let ((st (format nil "Actual value~P: ~
                       ~{~S~^~%~15t~}.~%"
-			    (length r) r)))
-	     (format s "~A" st))
-	   (error () (format s "Actual value: #<error during printing>~%")
-		  ))
-	  (finish-output s)
-	  ))))
+                            (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)
@@ -294,31 +294,31 @@
      (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))))
+                              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)))))
+                              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)))))
+             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)))
+            (not (macro-function op))
+            (not (special-operator-p op)))
        (apply (symbol-function op)
-	      (mapcar #'eval (cdr form))))
+              (mapcar #'eval (cdr form))))
       (t (eval form))))))
 
 (defun continue-testing ()
@@ -327,83 +327,83 @@
       (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)
   (format s "~&Doing ~A pending test~:P ~
              of ~A tests total.~%"
           (count t (the list (cdr *entries*)) :key #'pend)
-	  (length (cdr *entries*)))
+          (length (cdr *entries*)))
   (finish-output s)
   (dolist (entry (cdr *entries*))
     (when (and (pend entry)
-	       (not (has-disabled-note 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)))
+        (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)))
+           (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 ~
+          (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: ~
+                  (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)))
-	  ))
+                    (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)))
+                       (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)))
+                            :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*)))))
+                (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*)))))
+                (setf n (gethash n *notes*)))))
     (unless note (error "~A is not a note or note name." n))
     (setf (note-disabled note) nil)
     note))