contrib/bsd-sockets/rt.lisp

   1 ;-*-syntax:COMMON-LISP;Package:(RT :use "COMMON-LISP" :colon-mode :external)-*-
   2
   3 #|----------------------------------------------------------------------------|
   4  | Copyright 1990 by the Massachusetts Institute of Technology, Cambridge MA. |
   5  |                                                                            |
   6  | Permission  to  use,  copy, modify, and distribute this software  and  its |
   7  | documentation for any purpose  and without fee is hereby granted, provided |
   8  | that this copyright  and  permission  notice  appear  in  all  copies  and |
   9  | supporting  documentation,  and  that  the  name  of M.I.T. not be used in |
  10  | advertising or  publicity  pertaining  to  distribution  of  the  software |
  11  | without   specific,   written   prior   permission.      M.I.T.  makes  no |
  12  | representations  about  the  suitability of this software for any purpose. |
  13  | It is provided "as is" without express or implied warranty.                |
  14  |                                                                            |
  15  |  M.I.T. DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE,  INCLUDING  |
  16  |  ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, IN NO EVENT SHALL  |
  17  |  M.I.T. BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL  DAMAGES  OR  |
  18  |  ANY  DAMAGES  WHATSOEVER  RESULTING  FROM  LOSS OF USE, DATA OR PROFITS,  |
  19  |  WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER  TORTIOUS  ACTION,  |
  20  |  ARISING  OUT  OF  OR  IN  CONNECTION WITH THE USE OR PERFORMANCE OF THIS  |
  21  |  SOFTWARE.                                                                 |
  22  |----------------------------------------------------------------------------|#
  23
  24 ;This is the December 19, 1990 version of the regression tester.
  25 \f
  26 (defpackage "RT"
  27   (:use "COMMON-LISP")
  28   (:export deftest get-test do-test rem-test
  29            rem-all-tests do-tests pending-tests
  30            continue-testing *test*
  31            *do-tests-when-defined*))
  32 (in-package :rt)
  33 (defvar *test* nil "Current test name")
  34 (defvar *do-tests-when-defined* nil)
  35 (defvar *entries* '(nil) "Test database")
  36 (defvar *in-test* nil "Used by TEST")
  37 (defvar *debug* nil "For debugging")
  38
  39 (defstruct (entry (:conc-name nil)
  40                   (:type list))
  41   pend name form)
  42
  43 (defmacro vals (entry) `(cdddr ,entry))
  44
  45 (defmacro defn (entry) `(cdr ,entry))
  46
  47 (defun pending-tests ()
  48   (do ((l (cdr *entries*) (cdr l))
  49        (r nil))
  50       ((null l) (nreverse r))
  51     (when (pend (car l))
  52       (push (name (car l)) r))))
  53
  54 (defun rem-all-tests ()
  55   (setq *entries* (list nil))
  56   nil)
  57
  58 (defun rem-test (&optional (name *test*))
  59   (do ((l *entries* (cdr l)))
  60       ((null (cdr l)) nil)
  61     (when (equal (name (cadr l)) name)
  62       (setf (cdr l) (cddr l))
  63       (return name))))
  64 \f
  65 (defun get-test (&optional (name *test*))
  66   (defn (get-entry name)))
  67
  68 (defun get-entry (name)
  69   (let ((entry (find name (cdr *entries*)
  70                      :key #'name
  71                      :test #'equal)))
  72     (when (null entry)
  73       (report-error t
  74         "~%No test with name ~:@(~S~)."
  75         name))
  76     entry))
  77
  78 (defmacro deftest (name form &rest values)
  79   `(add-entry '(t ,name ,form .,values)))
  80
  81 (defun add-entry (entry)
  82   (setq entry (copy-list entry))
  83   (do ((l *entries* (cdr l))) (nil)
  84     (when (null (cdr l))
  85       (setf (cdr l) (list entry))
  86       (return nil))
  87     (when (equal (name (cadr l))
  88                  (name entry))
  89       (setf (cadr l) entry)
  90       (report-error nil
  91         "Redefining test ~@:(~S~)"
  92         (name entry))
  93       (return nil)))
  94   (when *do-tests-when-defined*
  95     (do-entry entry))
  96   (setq *test* (name entry)))
  97
  98 (defun report-error (error? &rest args)
  99   (cond (*debug*
 100          (apply #'format t args)
 101          (if error? (throw '*debug* nil)))
 102         (error? (apply #'error args))
 103         (t (apply #'warn args))))
 104 \f
 105 (defun do-test (&optional (name *test*))
 106   (do-entry (get-entry name)))
 107
 108 (defun do-entry (entry &optional
 109                  (s *standard-output*))
 110   (catch '*in-test*
 111     (setq *test* (name entry))
 112     (setf (pend entry) t)
 113     (let* ((*in-test* t)
 114            (*break-on-warnings* t)
 115            (r (multiple-value-list
 116                 (eval (form entry)))))
 117       (setf (pend entry)
 118             (not (equal r (vals entry))))
 119       (when (pend entry)
 120         (format s "~&Test ~:@(~S~) failed~
 121                    ~%Form: ~S~
 122                    ~%Expected value~P: ~
 123                       ~{~S~^~%~17t~}~
 124                    ~%Actual value~P: ~
 125                       ~{~S~^~%~15t~}.~%"
 126                 *test* (form entry)
 127                 (length (vals entry))
 128                 (vals entry)
 129                 (length r) r))))
 130       (when (not (pend entry)) *test*))
 131
 132 (defun continue-testing ()
 133   (if *in-test*
 134       (throw '*in-test* nil)
 135       (do-entries *standard-output*)))
 136 \f
 137 (defun do-tests (&optional
 138                  (out *standard-output*))
 139   (dolist (entry (cdr *entries*))
 140     (setf (pend entry) t))
 141   (if (streamp out)
 142       (do-entries out)
 143       (with-open-file
 144           (stream out :direction :output)
 145         (do-entries stream))))
 146
 147 (defun do-entries (s)
 148   (format s "~&Doing ~A pending test~:P ~
 149              of ~A tests total.~%"
 150           (count t (cdr *entries*)
 151                  :key #'pend)
 152           (length (cdr *entries*)))
 153   (dolist (entry (cdr *entries*))
 154     (when (pend entry)
 155       (format s "~@[~<~%~:; ~:@(~S~)~>~]"
 156               (do-entry entry s))))
 157   (let ((pending (pending-tests)))
 158     (if (null pending)
 159         (format s "~&No tests failed.")
 160         (format s "~&~A out of ~A ~
 161                    total tests failed: ~
 162                    ~:@(~{~<~%   ~1:;~S~>~
 163                          ~^, ~}~)."
 164                 (length pending)
 165                 (length (cdr *entries*))
 166                 pending))
 167     (null pending)))