rt.lsp 11.6 KB
Newer Older
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
;-*-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.                                                                 |
 |----------------------------------------------------------------------------|#

;This is the December 19, 1990 version of the regression tester.
25

26
(in-package :regression-test)
27

28
29
30
31
32
(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))

33
34
35
36
37
38
(defvar *test* nil "Current test name")
(defvar *do-tests-when-defined* nil)
(defvar *entries* '(nil) "Test database")
(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.")
39
40
(defvar *print-circle-on-failure* nil
  "Failure reports are printed with *PRINT-CIRCLE* bound to this value.")
41

42
43
(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.")
44
45
(defvar *optimization-settings* '((safety 3)))

46
47
48
(defvar *expected-failures* nil
  "A list of test names that are expected to fail.")

49
50
51
(defvar *notes* (make-hash-table :test 'equal)
  "A mapping from names of notes to note objects.")
  
52
53
(defstruct (entry (:conc-name nil))
  pend name props form vals)
54

55
56
57
58
59
60
61
62
63
64
65
;;; 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
  )

66
;; (defmacro vals (entry) `(cdddr ,entry))
67

68
69
70
71
(defmacro defn (entry)
  (let ((var (gensym)))
    `(let ((,var ,entry))
       (list* (name ,var) (form ,var) (vals ,var)))))
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89

(defun pending-tests ()
  (do ((l (cdr *entries*) (cdr l))
       (r nil))
      ((null l) (nreverse r))
    (when (pend (car l))
      (push (name (car l)) r))))

(defun rem-all-tests ()
  (setq *entries* (list nil))
  nil)

(defun rem-test (&optional (name *test*))
  (do ((l *entries* (cdr l)))
      ((null (cdr l)) nil)
    (when (equal (name (cadr l)) name)
      (setf (cdr l) (cddr l))
      (return name))))
90

91
92
93
94
(defun get-test (&optional (name *test*))
  (defn (get-entry name)))

(defun get-entry (name)
95
  (let ((entry (find name (the list (cdr *entries*))
96
97
98
99
100
101
102
103
		     :key #'name
		     :test #'equal)))
    (when (null entry)
      (report-error t
        "~%No test with name ~:@(~S~)."
	name))
    entry))

104
105
106
107
108
109
110
111
112
113
114
115
116
117
(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)))))

118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
(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))))
133
134

(defun add-entry (entry)
135
  (setq entry (copy-entry entry))
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
  (do ((l *entries* (cdr l))) (nil)
    (when (null (cdr l))
      (setf (cdr l) (list entry))
      (return nil))
    (when (equal (name (cadr l)) 
		 (name entry))
      (setf (cadr l) entry)
      (report-error nil
        "Redefining test ~:@(~S~)"
        (name entry))
      (return nil)))
  (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))
156
157
	(t (apply #'warn args)))
  nil)
158

159
(defun do-test (&optional (name *test*))
160
161
162
  #-sbcl (do-entry (get-entry name))
  #+sbcl (handler-bind ((sb-ext:code-deletion-note #'muffle-warning))
		       (do-entry (get-entry name))))
163

164
165
166
167
168
169
(defun my-aref (a &rest args)
  (apply #'aref a args))

(defun my-row-major-aref (a index)
  (row-major-aref a index))

170
(defun equalp-with-case (x y)
171
  "Like EQUALP, but doesn't do case conversion of characters.
172
   Currently doesn't work on arrays of dimension > 2."
173
  (cond
174
   ((eq x y) t)
175
176
177
178
   ((consp x)
    (and (consp y)
	 (equalp-with-case (car x) (car y))
	 (equalp-with-case (cdr x) (cdr y))))
179
   ((and (typep x 'array)
180
	 (= (array-rank x) 0))
181
    (equalp-with-case (my-aref x) (my-aref y)))
182
183
184
185
186
187
   ((typep x 'vector)
    (and (typep y 'vector)
	 (let ((x-len (length x))
	       (y-len (length y)))
	   (and (eql x-len y-len)
		(loop
188
189
190
		 for i from 0 below x-len
		 for e1 = (my-aref x i)
		 for e2 = (my-aref y i)
191
		 always (equalp-with-case e1 e2))))))
192
   ((and (typep x 'array)
193
194
195
196
	 (typep y 'array)
	 (not (equal (array-dimensions x)
		     (array-dimensions y))))
    nil)
197
198

   ((typep x 'array)
199
200
201
    (and (typep y 'array)
	 (let ((size (array-total-size x)))
	   (loop for i from 0 below size
202
203
		 always (equalp-with-case (my-row-major-aref x i)
					  (my-row-major-aref y i))))))
204

205
206
   (t (eql x y))))

207
208
209
210
211
212
(defun do-entry (entry &optional
		       (s *standard-output*))
  (catch '*in-test*
    (setq *test* (name entry))
    (setf (pend entry) t)
    (let* ((*in-test* t)
pfdietz's avatar
pfdietz committed
213
	   ;; (*break-on-warnings* t)
214
	   (aborted nil)
215
216
217
	   r)
      ;; (declare (special *break-on-warnings*))

218
219
220
221
      (block aborted
	(setf r
	      (flet ((%do
		      ()
222
223
		      (cond
		       (*compile-tests*
224
			(multiple-value-list
225
226
227
228
229
230
231
232
233
234
235
236
			 (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)))))))
237
238
239
240
241
242
243
244
245
246
		(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)))))

247
248
      (setf (pend entry)
	    (or aborted
249
		(not (equalp-with-case r (vals entry)))))
250
      
251
      (when (pend entry)
252
253
	(let ((*print-circle* *print-circle-on-failure*))
	  (format s "~&Test ~:@(~S~) failed~
254
255
256
                   ~%Form: ~S~
                   ~%Expected value~P: ~
                      ~{~S~^~%~17t~}~%"
257
258
259
260
		  *test* (form entry)
		  (length (vals entry))
		  (vals entry))
	  (format s "Actual value~P: ~
261
                      ~{~S~^~%~15t~}.~%"
262
263
		  (length r) r)))))
  (when (not (pend entry)) *test*))
264

265
266
267
268
269
270
271
272
273
274
275
276
277
(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
278
279
	  (the function
	    (eval `(lambda ,vars ,@(cddr form))))
280
281
282
283
284
285
286
	  (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
287
288
	  (the function
	    (eval `(lambda (,(car vars) &aux ,@(cdr bindings)) ,@(cddr form))))
289
290
291
292
293
294
295
296
297
298
299
300
	  (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))))))

301
302
303
304
(defun continue-testing ()
  (if *in-test*
      (throw '*in-test* nil)
      (do-entries *standard-output*)))
305

306
307
308
309
310
311
312
313
314
315
316
(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)
317
318
319
320
321
  #-sbcl (do-entries* s)
  #+sbcl (handler-bind ((sb-ext:code-deletion-note #'muffle-warning))
		       (do-entries* s)))

(defun do-entries* (s)
322
323
  (format s "~&Doing ~A pending test~:P ~
             of ~A tests total.~%"
324
          (count t (the list (cdr *entries*)) :key #'pend)
325
326
	  (length (cdr *entries*)))
  (dolist (entry (cdr *entries*))
327
328
    (when (and (pend entry)
	       (not (has-disabled-note entry)))
329
330
      (format s "~@[~<~%~:; ~:@(~S~)~>~]"
	      (do-entry entry s))))
331
332
333
334
335
336
337
338
339
340
341
342
  (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 ~
343
344
345
                   total tests failed: ~
                   ~:@(~{~<~%   ~1:;~S~>~
                         ~^, ~}~)."
346
347
348
349
350
351
352
353
354
355
356
357
358
		  (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)))
	  ))
      (null pending))))
359
360
361

;;; Note handling functions and macros

362
(defmacro defnote (name contents &optional disabled)
363
  `(eval-when (:load-toplevel :execute)
364
365
366
     (let ((note (make-note :name ',name
			    :contents ',contents
			    :disabled ',disabled)))
367
       (setf (gethash (note-name note) *notes*) note)
368
369
       note)))

370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
(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))