2 ;;; $Header: /home/gene/library/website/docsrc/lut/RCS/test.lisp,v 395.1 2008/04/20 17:25:47 gene Exp $
4 ;;; Copyright (c) 2005 Gene Michael Stover. All rights reserved.
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.
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.
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
22 (defpackage "CYBERTIGGYR-TEST"
24 (:export
"*EXCLUDED-PACKAGES*"
37 (in-package "CYBERTIGGYR-TEST")
40 ;;; unexported helper functions & stoof
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
))))
50 (defun symbol-bigname (symbol)
51 "Return, as a string, the package name of the symbol & the name
53 (format nil
"~A::~A" (package-name (symbol-package symbol
)) symbol
))
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
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
))
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
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.
77 (defvar *prefix
* "TEST" "String prefix of test function names.")
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
85 (defun test-function-p (symbol)
86 "Return true if & only if SYMBOL is bound to a test function."
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
)
94 (defun test-functions ()
95 "Return a list of symbols bound to test functions in any package."
97 (do-all-symbols (symbol)
98 (when (test-function-p symbol
) (push symbol lst
)))
99 (remove-duplicates (sort lst
#'string-lessp
:key
#'symbol-bigname
))))
101 (setf (get 'test-functions
'disposition
) 'not-a-unit-test
)
103 (defun run (&optional
(strm *standard-output
*))
104 "Run all unit tests. Print results to STRM. Return true if & only
108 ;; Search for a test function which fails...
109 (make-failed-test-p (length (test-functions)) strm
)
110 ;; ...from the suite of test functions.
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
))))
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
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
))
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}")
157 (defmacro check
(expression)
162 (format t
"~&Failure: ~S" ',expression
)
165 ;;; --- end of file ---