3 (:export
#:with-test
#:report-test-status
#:*failures
*
4 #:really-invoke-debugger
5 #:*break-on-failure
* #:*break-on-expected-failure
*))
7 (in-package :test-util
)
9 (defvar *test-count
* 0)
10 (defvar *test-file
* nil
)
11 (defvar *failures
* nil
)
12 (defvar *break-on-failure
* nil
)
13 (defvar *break-on-expected-failure
* nil
)
15 (defun log-msg (&rest args
)
16 (format *trace-output
* "~&::: ")
17 (apply #'format
*trace-output
* args
)
18 (terpri *trace-output
*)
19 (force-output *trace-output
*))
21 (defmacro with-test
((&key fails-on broken-on skipped-on name
) &body body
)
22 (let ((block-name (gensym)))
26 ((broken-p ,broken-on
)
27 (fail-test :skipped-broken
',name
"Test broken on this platform"))
28 ((skipped-p ,skipped-on
)
29 (fail-test :skipped-disabled
',name
"Test disabled for this combination of platform and features"))
32 (handler-bind ((error (lambda (error)
33 (if (expected-failure-p ,fails-on
)
34 (fail-test :expected-failure
',name error
)
35 (fail-test :unexpected-failure
',name error
))
36 (return-from ,block-name
))))
38 (log-msg "Running ~S" ',name
)
40 (if (expected-failure-p ,fails-on
)
41 (fail-test :unexpected-success
',name nil
)
42 (log-msg "Success ~S" ',name
))))))))))
44 (defun report-test-status ()
45 (with-standard-io-syntax
46 (with-open-file (stream "test-status.lisp-expr"
48 :if-exists
:supersede
)
49 (format stream
"~s~%" *failures
*))))
52 (unless (eq *test-file
* *load-pathname
*)
53 (setf *test-file
* *load-pathname
*)
54 (setf *test-count
* 0))
57 (defun really-invoke-debugger (condition)
58 (with-simple-restart (continue "Continue")
59 (let ((*invoke-debugger-hook
* *invoke-debugger-hook
*))
61 (invoke-debugger condition
))))
63 (defun fail-test (type test-name condition
)
64 (if (stringp condition
)
65 (log-msg "~@<~A ~S ~:_~A~:>"
66 type test-name condition
)
67 (log-msg "~@<~A ~S ~:_due to ~S: ~4I~:_\"~A\"~:>"
68 type test-name condition condition
))
69 (push (list type
*test-file
* (or test-name
*test-count
*))
71 (unless (stringp condition
)
72 (when (or (and *break-on-failure
*
73 (not (eq type
:expected-failure
)))
74 *break-on-expected-failure
*)
75 (really-invoke-debugger condition
))))
77 (defun expected-failure-p (fails-on)
78 (sb-impl::featurep fails-on
))
80 (defun broken-p (broken-on)
81 (sb-impl::featurep broken-on
))
83 (defun skipped-p (skipped-on)
84 (sb-impl::featurep skipped-on
))
87 (cons (format nil
"SBCL_MACHINE_TYPE=~A" (machine-type))
88 (cons (format nil
"SBCL_SOFTWARE_TYPE=~A" (software-type))