src/data/test-cybertiggyr.lisp

   1 ;;;
   2 ;;; $Header: /home/gene/library/website/docsrc/lut/RCS/test.lisp,v 395.1 2008/04/20 17:25:47 gene Exp $
   3 ;;;
   4 ;;; Copyright (c) 2005 Gene Michael Stover.  All rights reserved.
   5 ;;;
   6 ;;; This program is free software; you can redistribute it and/or modify
   7 ;;; it under the terms of the GNU Lesser General Public License as
   8 ;;; published by the Free Software Foundation; either version 2 of the
   9 ;;; License, or (at your option) any later version.
  10 ;;;
  11 ;;; This program is distributed in the hope that it will be useful,
  12 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  13 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 ;;; GNU Lesser General Public License for more details.
  15 ;;;
  16 ;;; You should have received a copy of the GNU Lesser General Public
  17 ;;; License along with this program; if not, write to the Free Software
  18 ;;; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301
  19 ;;; USA
  20 ;;;
  21
  22 (defpackage "CYBERTIGGYR-TEST"
  23   (:use "COMMON-LISP")
  24   (:export "*EXCLUDED-PACKAGES*"
  25            "*PREFIX*"
  26            "CHECK"
  27            "DEFTEST"
  28            "DISPOSITION"
  29            "IS-A-UNIT-TEST"
  30            "NOT-A-UNIT-TEST"
  31            "RATE"
  32            "RATETABLE"
  33            "RUN"
  34            "TEST-FUNCTION-P"
  35            "TEST-FUNCTIONS"))
  36
  37 (in-package "CYBERTIGGYR-TEST")
  38
  39 ;;;
  40 ;;; unexported helper functions & stoof
  41 ;;;
  42
  43 (defun symbol-name-starts-with (symbol starts-with)
  44   "Return true if & only if the name of the symbol begins with
  45 the string bound to STARTS-WITH."
  46   (let ((len (length starts-with)))
  47     (and (>= (length (symbol-name symbol)) len)
  48          (equal (subseq (symbol-name symbol) 0 len) starts-with))))
  49
  50 (defun symbol-bigname (symbol)
  51   "Return, as a string, the package name of the symbol & the name
  52 of the symbol."
  53   (format nil "~A::~A" (package-name (symbol-package symbol)) symbol))
  54
  55 (defun make-failed-test-p (max strm)
  56   "Return a predicate which runs a test & tells whether it failed.
  57 The predicate also prints a status to the character output stream
  58 STRM."
  59   (let ((i 0))
  60     #'(lambda (test)
  61         ;; Show which test we're about to run & what percentage
  62         ;; of the test suit has been run.
  63         (format strm "~&~3D% ~A =>" (round (* (/ (incf i) max) 100))
  64                 (symbol-bigname test))
  65         (finish-output strm)
  66         (let ((is-good (funcall test))) ; run the test
  67           ;; Show the test's result.
  68           (format strm " ~A" (if is-good "good" "FAILED"))
  69           (not is-good)))))             ; compliment the result
  70
  71 ;;;
  72 ;;; You could alter these values to fine-tune the behaviour of
  73 ;;; TEST-FUNCTION-P.  Adding packages to *EXCLUDED-PACKAGES* is
  74 ;;; safe, but altering *PREFIX* could be trouble.
  75 ;;;
  76
  77 (defvar *prefix* "TEST" "String prefix of test function names.")
  78
  79 (defvar *excluded-packages*
  80   (remove (find-package "COMMON-LISP-USER") (list-all-packages))
  81   "Packages whose functions are not eligible to be test functions.
  82 Defaults to the packages that were loaded before this package, less
  83 COMMON-LISP-USER.")
  84
  85 (defun test-function-p (symbol)
  86   "Return true if & only if SYMBOL is bound to a test function."
  87   (and (fboundp symbol)
  88        (not (eq (get symbol 'disposition) 'not-a-unit-test))
  89        (not (member (symbol-package symbol) *excluded-packages*))
  90        (or (eq (get symbol 'disposition) 'is-a-unit-test)
  91            (symbol-name-starts-with symbol *prefix*))))
  92 (setf (get 'test-function-p 'disposition) 'not-a-unit-test)
  93
  94 (defun test-functions ()
  95   "Return a list of symbols bound to test functions in any package."
  96   (let ((lst ()))
  97     (do-all-symbols (symbol)
  98       (when (test-function-p symbol) (push symbol lst)))
  99     (remove-duplicates (sort lst #'string-lessp :key #'symbol-bigname))))
 100
 101 (setf (get 'test-functions 'disposition) 'not-a-unit-test)
 102
 103 (defun run (&optional (strm *standard-output*))
 104   "Run all unit tests.  Print results to STRM.  Return true if & only
 105 if all tests pass."
 106   (null
 107    (find-if
 108     ;; Search for a test function which fails...
 109     (make-failed-test-p (length (test-functions)) strm)
 110     ;; ...from the suite of test functions.
 111     (test-functions))))
 112
 113 (defmacro deftest (name &rest body)
 114   "Declare a unit test function.  For now, maps to DEFUN, but could
 115 be implemented differently in the future."
 116   (if (symbol-name-starts-with name *prefix*)
 117       `(defun ,name ,@body)
 118     ;; else, We'll need to set DISPOSITION
 119     `(progn (setf (get ',name 'cybertiggyr-test:disposition)
 120                   'cybertiggyr-test:is-a-unit-test)
 121             (defun ,name ,@body))))
 122
 123 (defun rate (fn)
 124   "Run function FN at least 3 times & at least 3 seconds.
 125 Return triple whose FIRST is calls/second, SECOND is number
 126 of calls, & THIRD is number of seconds.  All three numbers
 127 will be positive.  They may be integers, ratios, or floating-
 128 point, depending on details of the lisp system.  Time are
 129 measured with GET-INTERNAL-REAL-TIME, but they are reported in
 130 seconds."
 131   (declare (type function fn))
 132   (do ((start-time (get-internal-real-time))
 133        (seconds 0 (/ (- (get-internal-real-time) start-time)
 134                       internal-time-units-per-second))
 135        (count 0 (1+ count)))
 136       ((and (>= count 3) (>= seconds 3))
 137        (list (/ count seconds) count seconds))
 138       (funcall fn)))
 139
 140 (defun ratetable (names-and-fns strm)
 141   "Run RATE on a bunch of functios & return a LaTeX table in a
 142 string which shows the results of all of them.  Each element
 143 in NAMES-AND-FNS is a list whose FIRST is the name of the function
 144 in a string & whose SECOND is a function of no arguments whose
 145 performance is to be tested."
 146   (format strm "\\begin{tabular}{|r|r|r|r|} \\hline")
 147   (format strm "~%{\\bf function} & {\\bf count} &")
 148   (format strm " {\\bf seconds} & {\\bf rate}")
 149   (format strm " \\\\ \\hline")
 150   (dolist (lst names-and-fns)
 151     (destructuring-bind (rate count seconds) (rate (second lst))
 152       (format strm "~%~A & ~D & ~,2E & ~,2E \\\\ \\hline"
 153               (first lst) count seconds rate)))
 154   (format strm "~%\\end{tabular}")
 155   strm)
 156
 157 (defmacro check (expression)
 158   `(if ,expression
 159        t
 160      ;; else
 161      (progn
 162        (format t "~&Failure: ~S" ',expression)
 163        nil)))
 164
 165 ;;; --- end of file ---