3 (:export #:with-test #:report-test-status #:*failures*
4 #:really-invoke-debugger
5 #:*break-on-failure* #:*break-on-expected-failure*
6 #:make-kill-thread #:make-join-thread))
8 (in-package :test-util)
10 (defvar *test-count* 0)
11 (defvar *test-file* nil)
12 (defvar *failures* nil)
13 (defvar *break-on-failure* nil)
14 (defvar *break-on-expected-failure* nil)
16 (defvar *threads-to-kill*)
17 (defvar *threads-to-join*)
20 (defun make-kill-thread (&rest args)
21 (let ((thread (apply #'sb-thread:make-thread args)))
22 (when (boundp '*threads-to-kill*)
23 (push thread *threads-to-kill*))
27 (defun make-join-thread (&rest args)
28 (let ((thread (apply #'sb-thread:make-thread args)))
29 (when (boundp '*threads-to-join*)
30 (push thread *threads-to-join*))
33 (defun log-msg (&rest args)
34 (format *trace-output* "~&::: ")
35 (apply #'format *trace-output* args)
36 (terpri *trace-output*)
37 (force-output *trace-output*))
39 (defmacro with-test ((&key fails-on broken-on skipped-on name)
41 (let ((block-name (gensym))
42 (threads (gensym "THREADS")))
46 ((broken-p ,broken-on)
47 (fail-test :skipped-broken ',name "Test broken on this platform"))
48 ((skipped-p ,skipped-on)
49 (fail-test :skipped-disabled ',name "Test disabled for this combination of platform and features"))
51 (let (#+sb-thread (,threads (sb-thread:list-all-threads))
52 (*threads-to-join* nil)
53 (*threads-to-kill* nil))
55 (handler-bind ((error (lambda (error)
56 (if (expected-failure-p ,fails-on)
57 (fail-test :expected-failure ',name error)
58 (fail-test :unexpected-failure ',name error))
59 (return-from ,block-name))))
61 (log-msg "Running ~S" ',name)
64 (let ((any-leftover nil))
65 (dolist (thread *threads-to-join*)
66 (ignore-errors (sb-thread:join-thread thread)))
67 (dolist (thread *threads-to-kill*)
68 (ignore-errors (sb-thread:terminate-thread thread)))
69 (setf ,threads (union (union *threads-to-kill*
72 (dolist (thread (sb-thread:list-all-threads))
73 (unless (or (not (sb-thread:thread-alive-p thread))
74 (eql thread sb-thread:*current-thread*)
75 (member thread ,threads))
76 (setf any-leftover thread)
77 (ignore-errors (sb-thread:terminate-thread thread))))
79 (fail-test :leftover-thread ',name any-leftover)
80 (return-from ,block-name)))
81 (if (expected-failure-p ,fails-on)
82 (fail-test :unexpected-success ',name nil)
83 (log-msg "Success ~S" ',name)))))))))))
85 (defun report-test-status ()
86 (with-standard-io-syntax
87 (with-open-file (stream "test-status.lisp-expr"
89 :if-exists :supersede)
90 (format stream "~s~%" *failures*))))
93 (unless (eq *test-file* *load-pathname*)
94 (setf *test-file* *load-pathname*)
95 (setf *test-count* 0))
98 (defun really-invoke-debugger (condition)
99 (with-simple-restart (continue "Continue")
100 (let ((*invoke-debugger-hook* *invoke-debugger-hook*))
102 (invoke-debugger condition))))
104 (defun fail-test (type test-name condition)
105 (if (stringp condition)
106 (log-msg "~@<~A ~S ~:_~A~:>"
107 type test-name condition)
108 (log-msg "~@<~A ~S ~:_due to ~S: ~4I~:_\"~A\"~:>"
109 type test-name condition condition))
110 (push (list type *test-file* (or test-name *test-count*))
112 (unless (stringp condition)
113 (when (or (and *break-on-failure*
114 (not (eq type :expected-failure)))
115 *break-on-expected-failure*)
116 (really-invoke-debugger condition))))
118 (defun expected-failure-p (fails-on)
119 (sb-impl::featurep fails-on))
121 (defun broken-p (broken-on)
122 (sb-impl::featurep broken-on))
124 (defun skipped-p (skipped-on)
125 (sb-impl::featurep skipped-on))
128 (cons (format nil "SBCL_MACHINE_TYPE=~A" (machine-type))
129 (cons (format nil "SBCL_SOFTWARE_TYPE=~A" (software-type))