rt: add deftask* and untabify sources
deftask* evaluates result agument. Signed-off-by: Daniel Kochmański <daniel@turtleware.eu>
This commit is contained in:
Daniel Kochmański
parent
18ee04ed2f
commit
563c362df3
1 changed files with 96 additions and 93 deletions
|
|
@ -23,8 +23,8 @@
|
||||||
(:nicknames :rt :regression-test :rtest)
|
(:nicknames :rt :regression-test :rtest)
|
||||||
(:use #:cl)
|
(:use #:cl)
|
||||||
(:export #:*do-tests-when-defined* #:*test* #:continue-testing
|
(:export #:*do-tests-when-defined* #:*test* #:continue-testing
|
||||||
#:deftest #:do-test #:do-tests #:get-test #:pending-tests
|
#:deftest #:deftest* #:do-test #:do-tests #:get-test
|
||||||
#:rem-all-tests #:rem-test)
|
#:pending-tests #:rem-all-tests #:rem-test)
|
||||||
(:documentation "The MIT regression tester"))
|
(:documentation "The MIT regression tester"))
|
||||||
|
|
||||||
(in-package :sb-rt)
|
(in-package :sb-rt)
|
||||||
|
|
@ -45,7 +45,7 @@
|
||||||
"A list of test names that are expected to fail.")
|
"A list of test names that are expected to fail.")
|
||||||
|
|
||||||
(defstruct (entry (:conc-name nil)
|
(defstruct (entry (:conc-name nil)
|
||||||
(:type list))
|
(:type list))
|
||||||
pend name form)
|
pend name form)
|
||||||
|
|
||||||
(defmacro vals (entry) `(cdddr ,entry))
|
(defmacro vals (entry) `(cdddr ,entry))
|
||||||
|
|
@ -75,25 +75,28 @@
|
||||||
|
|
||||||
(defun get-entry (name)
|
(defun get-entry (name)
|
||||||
(let ((entry (find name (cdr *entries*)
|
(let ((entry (find name (cdr *entries*)
|
||||||
:key #'name
|
:key #'name
|
||||||
:test #'equal)))
|
:test #'equal)))
|
||||||
(when (null entry)
|
(when (null entry)
|
||||||
(report-error t
|
(report-error t
|
||||||
"~%No test with name ~:@(~S~)."
|
"~%No test with name ~:@(~S~)."
|
||||||
name))
|
name))
|
||||||
entry))
|
entry))
|
||||||
|
|
||||||
(defmacro deftest (name form &rest values)
|
(defmacro deftest (name form &rest values)
|
||||||
`(add-entry '(t ,name ,form .,values)))
|
`(add-entry '(t ,name ,form .,values)))
|
||||||
|
|
||||||
|
(defmacro deftest* (name form result)
|
||||||
|
`(deftest ,name ,form ,@(eval result)))
|
||||||
|
|
||||||
(defun add-entry (entry)
|
(defun add-entry (entry)
|
||||||
(setq entry (copy-list entry))
|
(setq entry (copy-list entry))
|
||||||
(do ((l *entries* (cdr l))) (nil)
|
(do ((l *entries* (cdr l))) (nil)
|
||||||
(when (null (cdr l))
|
(when (null (cdr l))
|
||||||
(setf (cdr l) (list entry))
|
(setf (cdr l) (list entry))
|
||||||
(return nil))
|
(return nil))
|
||||||
(when (equal (name (cadr l))
|
(when (equal (name (cadr l))
|
||||||
(name entry))
|
(name entry))
|
||||||
(setf (cadr l) entry)
|
(setf (cadr l) entry)
|
||||||
(report-error nil
|
(report-error nil
|
||||||
"Redefining test ~:@(~S~)"
|
"Redefining test ~:@(~S~)"
|
||||||
|
|
@ -104,11 +107,11 @@
|
||||||
(setq *test* (name entry)))
|
(setq *test* (name entry)))
|
||||||
|
|
||||||
(defun report-error (error? &rest args)
|
(defun report-error (error? &rest args)
|
||||||
(cond (*debug*
|
(cond (*debug*
|
||||||
(apply #'format t args)
|
(apply #'format t args)
|
||||||
(if error? (throw '*debug* nil)))
|
(if error? (throw '*debug* nil)))
|
||||||
(error? (apply #'error args))
|
(error? (apply #'error args))
|
||||||
(t (apply #'warn args))))
|
(t (apply #'format t args))))
|
||||||
|
|
||||||
(defun do-test (&optional (name *test*))
|
(defun do-test (&optional (name *test*))
|
||||||
(do-entry (get-entry name)))
|
(do-entry (get-entry name)))
|
||||||
|
|
@ -119,88 +122,88 @@
|
||||||
((eq x y) t)
|
((eq x y) t)
|
||||||
((consp x)
|
((consp x)
|
||||||
(and (consp y)
|
(and (consp y)
|
||||||
(equalp-with-case (car x) (car y))
|
(equalp-with-case (car x) (car y))
|
||||||
(equalp-with-case (cdr x) (cdr y))))
|
(equalp-with-case (cdr x) (cdr y))))
|
||||||
((and (typep x 'array)
|
((and (typep x 'array)
|
||||||
(= (array-rank x) 0))
|
(= (array-rank x) 0))
|
||||||
(equalp-with-case (aref x) (aref y)))
|
(equalp-with-case (aref x) (aref y)))
|
||||||
((typep x 'vector)
|
((typep x 'vector)
|
||||||
(and (typep y 'vector)
|
(and (typep y 'vector)
|
||||||
(let ((x-len (length x))
|
(let ((x-len (length x))
|
||||||
(y-len (length y)))
|
(y-len (length y)))
|
||||||
(and (eql x-len y-len)
|
(and (eql x-len y-len)
|
||||||
(loop
|
(loop
|
||||||
for e1 across x
|
for e1 across x
|
||||||
for e2 across y
|
for e2 across y
|
||||||
always (equalp-with-case e1 e2))))))
|
always (equalp-with-case e1 e2))))))
|
||||||
((and (typep x 'array)
|
((and (typep x 'array)
|
||||||
(typep y 'array)
|
(typep y 'array)
|
||||||
(not (equal (array-dimensions x)
|
(not (equal (array-dimensions x)
|
||||||
(array-dimensions y))))
|
(array-dimensions y))))
|
||||||
nil)
|
nil)
|
||||||
((typep x 'array)
|
((typep x 'array)
|
||||||
(and (typep y 'array)
|
(and (typep y 'array)
|
||||||
(let ((size (array-total-size x)))
|
(let ((size (array-total-size x)))
|
||||||
(loop for i from 0 below size
|
(loop for i from 0 below size
|
||||||
always (equalp-with-case (row-major-aref x i)
|
always (equalp-with-case (row-major-aref x i)
|
||||||
(row-major-aref y i))))))
|
(row-major-aref y i))))))
|
||||||
(t (eql x y))))
|
(t (eql x y))))
|
||||||
|
|
||||||
(defun do-entry (entry &optional
|
(defun do-entry (entry &optional
|
||||||
(s *standard-output*))
|
(s *standard-output*))
|
||||||
(catch '*in-test*
|
(catch '*in-test*
|
||||||
(setq *test* (name entry))
|
(setq *test* (name entry))
|
||||||
(setf (pend entry) t)
|
(setf (pend entry) t)
|
||||||
(let* ((*in-test* t)
|
(let* ((*in-test* t)
|
||||||
;; (*break-on-warnings* t)
|
;; (*break-on-warnings* t)
|
||||||
(aborted nil)
|
(aborted nil)
|
||||||
r)
|
r)
|
||||||
;; (declare (special *break-on-warnings*))
|
;; (declare (special *break-on-warnings*))
|
||||||
|
|
||||||
(block aborted
|
(block aborted
|
||||||
(setf r
|
(setf r
|
||||||
(flet ((%do
|
(flet ((%do
|
||||||
()
|
()
|
||||||
(if *compile-tests*
|
(if *compile-tests*
|
||||||
(multiple-value-list
|
(multiple-value-list
|
||||||
(funcall (compile
|
(funcall (compile
|
||||||
nil
|
nil
|
||||||
`(lambda ()
|
`(lambda ()
|
||||||
(declare
|
(declare
|
||||||
(optimize ,@*optimization-settings*))
|
(optimize ,@*optimization-settings*))
|
||||||
,(form entry)))))
|
,(form entry)))))
|
||||||
(multiple-value-list
|
(multiple-value-list
|
||||||
(eval (form entry))))))
|
(eval (form entry))))))
|
||||||
(if *catch-errors*
|
(if *catch-errors*
|
||||||
(handler-bind
|
(handler-bind
|
||||||
((style-warning #'muffle-warning)
|
((style-warning #'muffle-warning)
|
||||||
(error #'(lambda (c)
|
(error #'(lambda (c)
|
||||||
(setf aborted t)
|
(setf aborted t)
|
||||||
(setf r (list c))
|
(setf r (list c))
|
||||||
(return-from aborted nil))))
|
(return-from aborted nil))))
|
||||||
(%do))
|
(%do))
|
||||||
(%do)))))
|
(%do)))))
|
||||||
|
|
||||||
(setf (pend entry)
|
(setf (pend entry)
|
||||||
(or aborted
|
(or aborted
|
||||||
(not (equalp-with-case r (vals entry)))))
|
(not (equalp-with-case r (vals entry)))))
|
||||||
|
|
||||||
(when (pend entry)
|
(when (pend entry)
|
||||||
(let ((*print-circle* *print-circle-on-failure*))
|
(let ((*print-circle* *print-circle-on-failure*))
|
||||||
(format s "~&Test ~:@(~S~) failed~
|
(format s "~&Test ~:@(~S~) failed~
|
||||||
~%Form: ~S~
|
~%Form: ~S~
|
||||||
~%Expected value~P: ~
|
~%Expected value~P: ~
|
||||||
~{~S~^~%~17t~}~%"
|
~{~S~^~%~17t~}~%"
|
||||||
*test* (form entry)
|
*test* (form entry)
|
||||||
(length (vals entry))
|
(length (vals entry))
|
||||||
(vals entry))
|
(vals entry))
|
||||||
(format s "Actual value~P: ~
|
(format s "Actual value~P: ~
|
||||||
~{~S~^~%~15t~}.~%"
|
~{~S~^~%~15t~}.~%"
|
||||||
(length r) r)
|
(length r) r)
|
||||||
(let ((x (first r)))
|
(let ((x (first r)))
|
||||||
(when (typep x 'condition)
|
(when (typep x 'condition)
|
||||||
(format s "~&Condition: ~A" x)))
|
(format s "~&Condition: ~A" x)))
|
||||||
))))
|
))))
|
||||||
(when (not (pend entry)) *test*))
|
(when (not (pend entry)) *test*))
|
||||||
|
|
||||||
(defun continue-testing ()
|
(defun continue-testing ()
|
||||||
|
|
@ -209,52 +212,52 @@
|
||||||
(do-entries *standard-output*)))
|
(do-entries *standard-output*)))
|
||||||
|
|
||||||
(defun do-tests (&optional
|
(defun do-tests (&optional
|
||||||
(out *standard-output*))
|
(out *standard-output*))
|
||||||
(dolist (entry (cdr *entries*))
|
(dolist (entry (cdr *entries*))
|
||||||
(setf (pend entry) t))
|
(setf (pend entry) t))
|
||||||
(if (streamp out)
|
(if (streamp out)
|
||||||
(do-entries out)
|
(do-entries out)
|
||||||
(with-open-file
|
(with-open-file
|
||||||
(stream out :direction :output)
|
(stream out :direction :output)
|
||||||
(do-entries stream))))
|
(do-entries stream))))
|
||||||
|
|
||||||
(defun do-entries (s)
|
(defun do-entries (s)
|
||||||
(format s "~&Doing ~A pending test~:P ~
|
(format s "~&Doing ~A pending test~:P ~
|
||||||
of ~A tests total.~%"
|
of ~A tests total.~%"
|
||||||
(count t (cdr *entries*)
|
(count t (cdr *entries*)
|
||||||
:key #'pend)
|
:key #'pend)
|
||||||
(length (cdr *entries*)))
|
(length (cdr *entries*)))
|
||||||
(dolist (entry (cdr *entries*))
|
(dolist (entry (cdr *entries*))
|
||||||
(when (pend entry)
|
(when (pend entry)
|
||||||
(format s "~@[~<~%~:; ~:@(~S~)~>~]"
|
(format s "~@[~<~%~:; ~:@(~S~)~>~]"
|
||||||
(do-entry entry s))))
|
(do-entry entry s))))
|
||||||
(let ((pending (pending-tests))
|
(let ((pending (pending-tests))
|
||||||
(expected-table (make-hash-table :test #'equal)))
|
(expected-table (make-hash-table :test #'equal)))
|
||||||
(dolist (ex *expected-failures*)
|
(dolist (ex *expected-failures*)
|
||||||
(setf (gethash ex expected-table) t))
|
(setf (gethash ex expected-table) t))
|
||||||
(let ((new-failures
|
(let ((new-failures
|
||||||
(loop for pend in pending
|
(loop for pend in pending
|
||||||
unless (gethash pend expected-table)
|
unless (gethash pend expected-table)
|
||||||
collect pend)))
|
collect pend)))
|
||||||
(if (null pending)
|
(if (null pending)
|
||||||
(format s "~&No tests failed.")
|
(format s "~&No tests failed.")
|
||||||
(progn
|
(progn
|
||||||
(format s "~&~A out of ~A ~
|
(format s "~&~A out of ~A ~
|
||||||
total tests failed: ~
|
total tests failed: ~
|
||||||
~:@(~{~<~% ~1:;~S~>~
|
~:@(~{~<~% ~1:;~S~>~
|
||||||
~^, ~}~)."
|
~^, ~}~)."
|
||||||
(length pending)
|
(length pending)
|
||||||
(length (cdr *entries*))
|
(length (cdr *entries*))
|
||||||
pending)
|
pending)
|
||||||
(if (null new-failures)
|
(if (null new-failures)
|
||||||
(format s "~&No unexpected failures.")
|
(format s "~&No unexpected failures.")
|
||||||
(when *expected-failures*
|
(when *expected-failures*
|
||||||
(format s "~&~A unexpected failures: ~
|
(format s "~&~A unexpected failures: ~
|
||||||
~:@(~{~<~% ~1:;~S~>~
|
~:@(~{~<~% ~1:;~S~>~
|
||||||
~^, ~}~)."
|
~^, ~}~)."
|
||||||
(length new-failures)
|
(length new-failures)
|
||||||
new-failures)))
|
new-failures)))
|
||||||
))
|
))
|
||||||
(finish-output s)
|
(finish-output s)
|
||||||
(null pending))))
|
(null pending))))
|
||||||
|
|
||||||
|
|
|
||||||
Loading…
Add table
Reference in a new issue