# project-euler / project-euler / cybertigger-test.lisp

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