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 (sb-thread:thread-emphemeral-p thread))
77 (setf any-leftover thread)
78 (ignore-errors (sb-thread:terminate-thread thread))))
80 (fail-test :leftover-thread ',name any-leftover)
81 (return-from ,block-name)))
82 (if (expected-failure-p ,fails-on)
83 (fail-test :unexpected-success ',name nil)
84 (log-msg "Success ~S" ',name)))))))))))
86 (defun report-test-status ()
87 (with-standard-io-syntax
88 (with-open-file (stream "test-status.lisp-expr"
90 :if-exists :supersede)
91 (format stream "~s~%" *failures*))))
94 (unless (eq *test-file* *load-pathname*)
95 (setf *test-file* *load-pathname*)
96 (setf *test-count* 0))
99 (defun really-invoke-debugger (condition)
100 (with-simple-restart (continue "Continue")
101 (let ((*invoke-debugger-hook* *invoke-debugger-hook*))
103 (invoke-debugger condition))))
105 (defun fail-test (type test-name condition)
106 (if (stringp condition)
107 (log-msg "~@<~A ~S ~:_~A~:>"
108 type test-name condition)
109 (log-msg "~@<~A ~S ~:_due to ~S: ~4I~:_\"~A\"~:>"
110 type test-name condition condition))
111 (push (list type *test-file* (or test-name *test-count*))
113 (unless (stringp condition)
114 (when (or (and *break-on-failure*
115 (not (eq type :expected-failure)))
116 *break-on-expected-failure*)
117 (really-invoke-debugger condition))))
119 (defun expected-failure-p (fails-on)
120 (sb-impl::featurep fails-on))
122 (defun broken-p (broken-on)
123 (sb-impl::featurep broken-on))
125 (defun skipped-p (skipped-on)
126 (sb-impl::featurep skipped-on))
129 (cons (format nil "SBCL_MACHINE_TYPE=~A" (machine-type))
130 (cons (format nil "SBCL_SOFTWARE_TYPE=~A" (software-type))