cl-rt-20040621/0002755000175000017500000000000010065651507013254 5ustar kevinkevin00000000000000cl-rt-20040621/rt-doc.txt0000644000175000017500000002077307726550605015223 0ustar kevinkevin00000000000000 #|----------------------------------------------------------------------------| | Copyright 1990 by the Massachusetts Institute of Technology, Cambridge MA. | | | | Permission to use, copy, modify, and distribute this software and its | | documentation for any purpose and without fee is hereby granted, provided | | that this copyright and permission notice appear in all copies and | | supporting documentation, and that the name of M.I.T. not be used in | | advertising or publicity pertaining to distribution of the software | | without specific, written prior permission. M.I.T. makes no | | representations about the suitability of this software for any purpose. | | It is provided "as is" without express or implied warranty. | | | | M.I.T. DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING | | ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, IN NO EVENT SHALL | | M.I.T. BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR | | ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, | | WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, | | ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS | | SOFTWARE. | |----------------------------------------------------------------------------|# (This is the December 19, 1990 version of brief documentation for the RT regression tester. A more complete discussion can be found in the article in Lisp Pointers.) The functions, macros, and variables that make up the RT regression tester are in a package called "RT". The ten exported symbols are documented below. If you want to refer to these symbols without a package prefix, you have to `use' the package. The basic unit of concern of RT is the test. Each test has an identifying name and a body that specifies the action of the test. Functions are provided for defining, redefining, removing, and performing individual tests and the test suite as a whole. In addition, information is maintained about which tests have succeeded and which have failed. <> deftest NAME FORM &rest VALUES Individual tests are defined using the macro DEFTEST. The identifying NAME is typically a number or symbol, but can be any Lisp form. If the test suite already contains a test with the same (EQUAL) NAME, then this test is redefined and a warning message printed. (This warning is important to alert the user when a test suite definition file contains two tests with the same name.) When the test is a new one, it is added to the end of the suite. In either case, NAME is returned as the value of DEFTEST and stored in the variable *TEST*. (deftest t-1 (floor 15/7) 2 1/7) => t-1 (deftest (t 2) (list 1) (1)) => (t 2) (deftest bad (1+ 1) 1) => bad (deftest good (1+ 1) 2) => good The FORM can be any kind of Lisp form. The zero or more VALUES can be any kind of Lisp objects. The test is performed by evaluating FORM and comparing the results with the VALUES. The test succeeds if and only if FORM produces the correct number of results and each one is EQUAL to the corresponding VALUE. <> *test* NAME-OF-CURRENT-TEST The variable *TEST* contains the name of the test most recently defined or performed. It is set by DEFTEST and DO-TEST. <> do-test &optional (NAME *TEST*) The function DO-TEST performs the test identified by NAME, which defaults to *TEST*. Before running the test, DO-TEST stores NAME in the variable *TEST*. If the test succeeds, DO-TEST returns NAME as its value. If the test fails, DO-TEST returns NIL, after printing an error report on *STANDARD-OUTPUT*. The following examples show the results of performing two of the tests defined above. (do-test '(t 2)) => (t 2) (do-test 'bad) => nil ; after printing: Test BAD failed Form: (1+ 1) Expected value: 1 Actual value: 2. <> *do-tests-when-defined* default value NIL If the value of this variable is non-null, each test is performed at the moment that it is defined. This is helpful when interactively constructing a suite of tests. However, when loading a test suite for later use, performing tests as they are defined is not liable to be helpful. <> get-test &optional (NAME *TEST*) This function returns the NAME, FORM, and VALUES of the specified test. (get-test '(t 2)) => ((t 2) (list 1) (1)) <> rem-test &optional (NAME *TEST*) If the indicated test is in the test suite, this function removes it and returns NAME. Otherwise, NIL is returned. <> rem-all-tests This function reinitializes RT by removing every test from the test suite and returns NIL. Generally, it is advisable for the whole test suite to apply to some one system. When switching from testing one system to testing another, it is wise to remove all the old tests before beginning to define new ones. <> do-tests &optional (OUT *STANDARD-OUTPUT*) This function uses DO-TEST to run each of the tests in the test suite and prints a report of the results on OUT, which can either be an output stream or the name of a file. If OUT is omitted, it defaults to *STANDARD-OUTPUT*. DO-TESTS returns T if every test succeeded and NIL if any test failed. As illustrated below, the first line of the report produced by DO-TEST shows how many tests need to be performed. The last line shows how many tests failed and lists their names. While the tests are being performed, DO-TESTS prints the names of the successful tests and the error reports from the unsuccessful tests. (do-tests "report.txt") => nil ; the file "report.txt" contains: Doing 4 pending tests of 4 tests total. T-1 (T 2) Test BAD failed Form: (1+ 1) Expected value: 1 Actual value: 2. GOOD 1 out of 4 total tests failed: BAD. It is best if the individual tests in the suite are totally independent of each other. However, should the need arise for some interdependence, you can rely on the fact that DO-TESTS will run tests in the order they were originally defined. <> pending-tests When a test is defined or redefined, it is marked as pending. In addition, DO-TEST marks the test to be run as pending before running it and DO-TESTS marks every test as pending before running any of them. The only time a test is marked as not pending is when it completes successfully. The function PENDING-TESTS returns a list of the names of the currently pending tests. (pending-tests) => (bad) <> continue-testing This function is identical to DO-TESTS except that it only runs the tests that are pending and always writes its output on *STANDARD-OUTPUT*. (continue-testing) => nil ; after printing: Doing 1 pending test out of 4 total tests. Test BAD failed Form: (1+ 1) Expected value: 1 Actual value: 2. 1 out of 4 total tests failed: BAD. CONTINUE-TESTING has a special meaning if called at a breakpoint generated while a test is being performed. The failure of a test to return the correct value does not trigger an error break. However, there are many kinds of things that can go wrong while a test is being performed (e.g., dividing by zero) that will cause breaks. If CONTINUE-TESTING is evaluated in a break generated during testing, it aborts the current test (which remains pending) and forces the processing of tests to continue. Note that in such a breakpoint, *TEST* is bound to the name of the test being performed and (GET-TEST) can be used to look at the test. When building a system, it is advisable to start constructing a test suite for it as soon as possible. Since individual tests are rather weak, a comprehensive test suite requires large numbers of tests. However, these can be accumulated over time. In particular, whenever a bug is found by some means other than testing, it is wise to add a test that would have found the bug and therefore will ensure that the bug will not reappear. Every time the system is changed, the entire test suite should be run to make sure that no unintended changes have occurred. Typically, some tests will fail. Sometimes, this merely means that tests have to be changed to reflect changes in the system's specification. Other times, it indicates bugs that have to be tracked down and fixed. During this phase, CONTINUE-TESTING is useful for focusing on the tests that are failing. However, for safety sake, it is always wise to reinitialize RT, redefine the entire test suite, and run DO-TESTS one more time after you think all of the tests are working. cl-rt-20040621/rt-test.lisp0000644000175000017500000001542307726550605015561 0ustar kevinkevin00000000000000;-*-syntax:COMMON-LISP-*- #|----------------------------------------------------------------------------| | Copyright 1990 by the Massachusetts Institute of Technology, Cambridge MA. | | | | Permission to use, copy, modify, and distribute this software and its | | documentation for any purpose and without fee is hereby granted, provided | | that this copyright and permission notice appear in all copies and | | supporting documentation, and that the name of M.I.T. not be used in | | advertising or publicity pertaining to distribution of the software | | without specific, written prior permission. M.I.T. makes no | | representations about the suitability of this software for any purpose. | | It is provided "as is" without express or implied warranty. | | | | M.I.T. DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING | | ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, IN NO EVENT SHALL | | M.I.T. BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR | | ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, | | WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, | | ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS | | SOFTWARE. | |----------------------------------------------------------------------------|# ;This is the December 19, 1990 version of a set of tests that use the ;RT regression tester to test itself. See the documentation of RT for ;a discusion of how to use this file. (in-package :cl-user) (require :rt) (use-package :rt) (defmacro setup (&rest body) `(do-setup '(progn ., body))) (defun do-setup (form) (let ((*test* nil) (*do-tests-when-defined* nil) (rt::*entries* (list nil)) (rt::*in-test* nil) (rt::*debug* t) result) (deftest t1 4 4) (deftest (t 2) 4 3) (values-list (cons (normalize (with-output-to-string (*standard-output*) (setq result (multiple-value-list (catch 'rt::*debug* (eval form)))))) result)))) (defun normalize (string) (with-input-from-string (s string) (normalize-stream s))) (defvar *file-name* nil) (defun get-file-name () (loop (if *file-name* (return *file-name*)) (format *error-output* "~%Type a string representing naming of a scratch disk file: ") (setq *file-name* (read)) (if (not (stringp *file-name*)) (setq *file-name* nil)))) (get-file-name) (defmacro with-temporary-file (f &body forms) `(let ((,f *file-name*)) ,@ forms (get-file-output ,f))) (defun get-file-output (f) (prog1 (with-open-file (in f) (normalize-stream in)) (delete-file f))) (defun normalize-stream (s) (let ((l nil)) (loop (push (read-line s nil s) l) (when (eq (car l) s) (setq l (nreverse (cdr l))) (return nil))) (delete "" l :test #'equal))) (rem-all-tests) (deftest deftest-1 (setup (deftest t1 3 3) (values (get-test 't1) *test* (pending-tests))) ("Redefining test T1") (t1 3 3) t1 (t1 (t 2))) (deftest deftest-2 (setup (deftest (t 2) 3 3) (get-test '(t 2))) ("Redefining test (T 2)") ((t 2) 3 3)) (deftest deftest-3 (setup (deftest 2 3 3) (values (get-test 2) *test* (pending-tests))) () (2 3 3) 2 (t1 (t 2) 2)) (deftest deftest-4 (setup (let ((*do-tests-when-defined* t)) (deftest (temp) 4 3))) ("Test (TEMP) failed" "Form: 4" "Expected value: 3" "Actual value: 4.") (temp)) (deftest do-test-1 (setup (values (do-test 't1) *test* (pending-tests))) () t1 t1 ((t 2))) (deftest do-test-2 (setup (values (do-test '(t 2)) (pending-tests))) ("Test (T 2) failed" "Form: 4" "Expected value: 3" "Actual value: 4.") nil (t1 (t 2))) (deftest do-test-3 (setup (let ((*test* 't1)) (do-test))) () t1) (deftest get-test-1 (setup (values (get-test 't1) *test*)) () (t1 4 4) (t 2)) (deftest get-test-2 (setup (get-test '(t 2))) () ((t 2) 4 3)) (deftest get-test-3 (setup (let ((*test* 't1)) (get-test))) () (t1 4 4)) (deftest get-test-4 (setup (deftest t3 1 1) (get-test)) () (t3 1 1)) (deftest get-test-5 (setup (get-test 't0)) ("No test with name T0.") nil) (deftest rem-test-1 (setup (values (rem-test 't1) (pending-tests))) () t1 ((t 2))) (deftest rem-test-2 (setup (values (rem-test '(t 2)) (pending-tests))) () (t 2) (t1)) (deftest rem-test-3 (setup (let ((*test* '(t 2))) (rem-test)) (pending-tests)) () (t1)) (deftest rem-test-4 (setup (values (rem-test 't0) (pending-tests))) () nil (t1 (t 2))) (deftest rem-test-5 (setup (rem-all-tests) (rem-test 't0) (pending-tests)) () ()) (deftest rem-all-tests-1 (setup (values (rem-all-tests) (pending-tests))) () nil nil) (deftest rem-all-tests-2 (setup (rem-all-tests) (rem-all-tests) (pending-tests)) () nil) (deftest do-tests-1 (setup (let ((*print-case* :downcase)) (values (do-tests) (continue-testing) (do-tests)))) ("Doing 2 pending tests of 2 tests total." " T1" "Test (T 2) failed" "Form: 4" "Expected value: 3" "Actual value: 4." "1 out of 2 total tests failed: (T 2)." "Doing 1 pending test of 2 tests total." "Test (T 2) failed" "Form: 4" "Expected value: 3" "Actual value: 4." "1 out of 2 total tests failed: (T 2)." "Doing 2 pending tests of 2 tests total." " T1" "Test (T 2) failed" "Form: 4" "Expected value: 3" "Actual value: 4." "1 out of 2 total tests failed: (T 2).") nil nil nil) (deftest do-tests-2 (setup (rem-test '(t 2)) (deftest (t 2) 3 3) (values (do-tests) (continue-testing) (do-tests))) ("Doing 2 pending tests of 2 tests total." " T1 (T 2)" "No tests failed." "Doing 0 pending tests of 2 tests total." "No tests failed." "Doing 2 pending tests of 2 tests total." " T1 (T 2)" "No tests failed.") t t t) (deftest do-tests-3 (setup (rem-all-tests) (values (do-tests) (continue-testing))) ("Doing 0 pending tests of 0 tests total." "No tests failed." "Doing 0 pending tests of 0 tests total." "No tests failed.") t t) (deftest do-tests-4 (setup (normalize (with-output-to-string (s) (do-tests s)))) () ("Doing 2 pending tests of 2 tests total." " T1" "Test (T 2) failed" "Form: 4" "Expected value: 3" "Actual value: 4." "1 out of 2 total tests failed: (T 2).")) (deftest do-tests-5 (setup (with-temporary-file s (do-tests s))) () ("Doing 2 pending tests of 2 tests total." " T1" "Test (T 2) failed" "Form: 4" "Expected value: 3" "Actual value: 4." "1 out of 2 total tests failed: (T 2).")) (deftest continue-testing-1 (setup (deftest temp (continue-testing) 5) (do-test 'temp) (pending-tests)) () (t1 (t 2) temp)) cl-rt-20040621/rt.lisp0000644000175000017500000003137210065651263014575 0ustar kevinkevin00000000000000;-*-syntax:COMMON-LISP;Package:(RT :use "COMMON-LISP" :colon-mode :external)-*- #|----------------------------------------------------------------------------| | Copyright 1990 by the Massachusetts Institute of Technology, Cambridge MA. | | | | Permission to use, copy, modify, and distribute this software and its | | documentation for any purpose and without fee is hereby granted, provided | | that this copyright and permission notice appear in all copies and | | supporting documentation, and that the name of M.I.T. not be used in | | advertising or publicity pertaining to distribution of the software | | without specific, written prior permission. M.I.T. makes no | | representations about the suitability of this software for any purpose. | | It is provided "as is" without express or implied warranty. | | | | M.I.T. DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING | | ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, IN NO EVENT SHALL | | M.I.T. BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR | | ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, | | WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, | | ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS | | SOFTWARE. | |----------------------------------------------------------------------------|# (defpackage #:regression-test (: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) (:documentation "The MIT regression tester with pfdietz's modifications")) ;;This was the December 19, 1990 version of the regression tester, but ;;has since been modified. (in-package :regression-test) (declaim (ftype (function (t) t) get-entry expanded-eval do-entries)) (declaim (type list *entries*)) (declaim (ftype (function (t &rest t) t) report-error)) (declaim (ftype (function (t &optional t) t) do-entry)) (defvar *test* nil "Current test name") (defvar *do-tests-when-defined* nil) (defvar *entries* '(nil) "Test database. Has a leading dummy cell that does not contain an entry.") (defvar *entries-tail* *entries* "Tail of the *entries* list") (defvar *entries-table* (make-hash-table :test #'equal) "Map the names of entries to the cons cell in *entries* that precedes the one whose car is the entry.") (defvar *in-test* nil "Used by TEST") (defvar *debug* nil "For debugging") (defvar *catch-errors* t "When true, causes errors in a test to be caught.") (defvar *print-circle-on-failure* nil "Failure reports are printed with *PRINT-CIRCLE* bound to this value.") (defvar *compile-tests* nil "When true, compile the tests before running them.") (defvar *expanded-eval* nil "When true, convert the tests into a form that is less likely to have compiler optimizations.") (defvar *optimization-settings* '((safety 3))) (defvar *expected-failures* nil "A list of test names that are expected to fail.") (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) ;;; Note objects are used to attach information to tests. ;;; A typical use is to mark tests that depend on a particular ;;; part of a set of requirements, or a particular interpretation ;;; of the requirements. (defstruct note name contents disabled ;; When true, tests with this note are considered inactive ) ;; (defmacro vals (entry) `(cdddr ,entry)) (defmacro defn (entry) (let ((var (gensym))) `(let ((,var ,entry)) (list* (name ,var) (form ,var) (vals ,var))))) (defun entry-notes (entry) (let* ((props (props entry)) (notes (getf props :notes))) (if (listp 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))))) (defun pending-tests () (loop for entry in (cdr *entries*) when (and (pend entry) (not (has-disabled-note entry))) collect (name entry))) (defun rem-all-tests () (setq *entries* (list nil)) (setq *entries-tail* *entries*) (clrhash *entries-table*) nil) (defun rem-test (&optional (name *test*)) (let ((pred (gethash name *entries-table*))) (when pred (if (null (cddr pred)) (setq *entries-tail* pred) (setf (gethash (name (caddr pred)) *entries-table*) pred)) (setf (cdr pred) (cddr pred)) (remhash name *entries-table*) name))) (defun get-test (&optional (name *test*)) (defn (get-entry name))) (defun get-entry (name) (let ((entry ;; (find name (the list (cdr *entries*)) ;; :key #'name :test #'equal) (cadr (gethash name *entries-table*)) )) (when (null entry) (report-error t "~%No test with name ~:@(~S~)." 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)) `(add-entry (make-entry :pend t :name ',name :props ',properties :form ',form :vals ',vals)))) (defun add-entry (entry) (setq entry (copy-entry entry)) (let* ((pred (gethash (name entry) *entries-table*))) (cond (pred (setf (cadr pred) entry) (report-error nil "Redefining test ~:@(~S~)" (name entry))) (t (setf (gethash (name entry) *entries-table*) *entries-tail*) (setf (cdr *entries-tail*) (cons entry nil)) (setf *entries-tail* (cdr *entries-tail*)) ))) (when *do-tests-when-defined* (do-entry entry)) (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))) 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)))) (defun my-aref (a &rest args) (apply #'aref a args)) (defun my-row-major-aref (a index) (row-major-aref a index)) (defun equalp-with-case (x y) "Like EQUALP, but doesn't do case conversion of characters. Currently doesn't work on arrays of dimension > 2." (cond ((eq x y) t) ((consp x) (and (consp y) (equalp-with-case (car x) (car y)) (equalp-with-case (cdr x) (cdr y)))) ((and (typep x 'array) (= (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)))))) ((and (typep x 'array) (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)))))) (t (eql x y)))) (defun do-entry (entry &optional (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) ;; (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 (pend 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~ ~%Form: ~S~ ~%Expected value~P: ~ ~{~S~^~%~17t~}~%" *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: #~%") )) (finish-output s) )))) (when (not (pend entry)) *test*)) (defun expanded-eval (form) "Split off top level of a form and eval separately. This reduces the chance that compiler optimizations will fold away runtime computation." (if (not (consp form)) (eval form) (let ((op (car form))) (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)))) ((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))))) ((eq op 'progn) (loop for e on (cdr form) 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))) (apply (symbol-function op) (mapcar #'eval (cdr form)))) (t (eval form)))))) (defun continue-testing () (if *in-test* (throw '*in-test* nil) (do-entries *standard-output*))) (defun do-tests (&optional (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)))) (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*))) (finish-output s) (dolist (entry (cdr *entries*)) (when (and (pend entry) (not (has-disabled-note entry))) (format s "~@[~<~%~:; ~:@(~S~)~>~]" (do-entry entry s)) (finish-output s) )) (let ((pending (pending-tests)) (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))) (if (null pending) (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: ~ ~:@(~{~<~% ~1:;~S~>~ ~^, ~}~)." (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))) ;;; 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))) (setf (gethash (note-name note) *notes*) note) note))) (defun disable-note (n) (let ((note (if (note-p n) n (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*))))) (unless note (error "~A is not a note or note name." n)) (setf (note-disabled note) nil) note)) cl-rt-20040621/rt.asd0000644000175000017500000000210507726550605014375 0ustar kevinkevin00000000000000;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- ;;;; ************************************************************************* ;;;; FILE IDENTIFICATION ;;;; ;;;; Name: rt.asd ;;;; Purpose: ASDF definition file for Rt ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Sep 2002 ;;;; ;;;; $Id: rt.asd 7061 2003-09-07 06:34:45Z kevin $ ;;;; ;;;; This file, part of cl-rt, is Copyright (c) 2002 by Kevin M. Rosenberg ;;;; ;;;; cl-rt users are granted the rights to distribute and use this software ;;;; as governed by the terms of the GNU Lesser General Public License ;;;; (http://www.gnu.org/licenses/lgpl.html) ;;;; ************************************************************************* (in-package :asdf) (defsystem :rt :name "cl-rt" :version "1990.12.19" :maintainer "Kevin M. Rosenberg " :licence "MIT" :description "MIT Regression Tester" :long-description "RT provides a framework for writing regression test suites" :perform (load-op :after (op rt) (pushnew :rt cl:*features*)) :components ((:file "rt")))