grovel-headers.c: Put win32 stuff into grovel-headers-win32.h.
[sbcl.git] / tests / run-tests.lisp
blobcce981d2b8f480e13708abeb560b899da8482ff5
1 (load "test-util.lisp")
3 (defpackage :run-tests
4 (:use :cl :test-util :sb-ext))
6 (load "assertoid.lisp")
8 (in-package run-tests)
10 (load "colorize.lisp")
12 (defvar *test-evaluator-mode* :compile)
13 (defvar *all-failures* nil)
14 (defvar *break-on-error* nil)
15 (defvar *report-skipped-tests* nil)
16 (defvar *explicit-test-files* nil)
18 (defun run-all ()
19 (loop :with remainder = (rest *posix-argv*)
20 :while remainder
21 :for arg = (pop remainder)
22 :do (cond
23 ((string= arg "--evaluator-mode")
24 (let ((mode (pop remainder)))
25 (cond
26 ((string= mode "interpret")
27 (setf *test-evaluator-mode* :interpret))
28 ((string= mode "compile")
29 (setf *test-evaluator-mode* :compile))
31 (error "~@<Invalid evaluator mode: ~A. Must be one ~
32 of interpret, compile.~@:>"
33 mode)))))
34 ((string= arg "--break-on-failure")
35 (setf *break-on-error* t)
36 (setf test-util:*break-on-failure* t))
37 ((string= arg "--break-on-expected-failure")
38 (setf test-util:*break-on-expected-failure* t))
39 ((string= arg "--report-skipped-tests")
40 (setf *report-skipped-tests* t))
41 ((string= arg "--no-color"))
43 (push (truename (parse-namestring arg)) *explicit-test-files*))))
44 (setf *explicit-test-files* (nreverse *explicit-test-files*))
45 (pure-runner (pure-load-files) #'load-test)
46 (pure-runner (pure-cload-files) #'cload-test)
47 (impure-runner (impure-load-files) #'load-test)
48 (impure-runner (impure-cload-files) #'cload-test)
49 #-win32 (impure-runner (sh-files) #'sh-test)
50 (report)
51 (sb-ext:exit :code (if (unexpected-failures)
53 104)))
55 (defun report ()
56 (terpri)
57 (format t "Finished running tests.~%")
58 (let ((skipcount 0)
59 (*print-pretty* nil))
60 (cond (*all-failures*
61 (format t "Status:~%")
62 (dolist (fail (reverse *all-failures*))
63 (cond ((eq (car fail) :unhandled-error)
64 (output-colored-text (car fail)
65 " Unhandled Error")
66 (format t " ~a~%"
67 (enough-namestring (second fail))))
68 ((eq (car fail) :invalid-exit-status)
69 (output-colored-text (car fail)
70 " Invalid exit status:")
71 (format t " ~a~%"
72 (enough-namestring (second fail))))
73 ((eq (car fail) :skipped-disabled)
74 (when *report-skipped-tests*
75 (format t " ~20a ~a / ~a~%"
76 "Skipped (irrelevant):"
77 (enough-namestring (second fail))
78 (third fail)))
79 (incf skipcount))
81 (output-colored-text
82 (first fail)
83 (ecase (first fail)
84 (:expected-failure " Expected failure:")
85 (:unexpected-failure " Failure:")
86 (:leftover-thread " Leftover thread (broken):")
87 (:unexpected-success " Unexpected success:")
88 (:skipped-broken " Skipped (broken):")
89 (:skipped-disabled " Skipped (irrelevant):")))
90 (format t " ~a / ~a~%"
91 (enough-namestring (second fail))
92 (third fail)))))
93 (when (> skipcount 0)
94 (format t " (~a tests skipped for this combination of platform and features)~%"
95 skipcount)))
97 (format t "All tests succeeded~%")))))
99 (defun pure-runner (files test-fun)
100 (when files
101 (format t "// Running pure tests (~a)~%" test-fun)
102 (let ((*package* (find-package :cl-user))
103 (*failures* nil))
104 (setup-cl-user)
105 (dolist (file files)
106 (format t "// Running ~a in ~a evaluator mode~%"
107 file *test-evaluator-mode*)
108 (restart-case
109 (handler-bind ((error (make-error-handler file)))
110 (let* ((sb-ext:*evaluator-mode* *test-evaluator-mode*)
111 (*features*
112 (if (eq sb-ext:*evaluator-mode* :interpret)
113 (cons :interpreter *features*)
114 *features*)))
115 (eval (funcall test-fun file))))
116 (skip-file ())))
117 (append-failures))))
119 (defun run-in-child-sbcl (load-forms forms)
120 ;; We used to fork() for POSIX platforms, and use this for Windows.
121 ;; However, it seems better to use the same solution everywhere.
122 (process-exit-code
123 (#-win32 with-open-file #-win32 (devnull "/dev/null") #+win32 progn
124 (sb-ext:run-program
125 (first *POSIX-ARGV*)
126 (append
127 (list "--core" SB-INT:*CORE-STRING*
128 "--noinform"
129 "--no-sysinit"
130 "--no-userinit"
131 "--noprint"
132 "--disable-debugger")
133 (loop for form in (append load-forms forms)
134 collect "--eval"
135 collect (write-to-string form)))
136 :output sb-sys:*stdout*
137 :input #-win32 devnull #+win32 sb-sys:*stdin*))))
139 (defun clear-test-status ()
140 (with-open-file (stream "test-status.lisp-expr"
141 :direction :output
142 :if-exists :supersede)
143 (write-line "NIL" stream)))
145 (defun run-impure-in-child-sbcl (test-file test-code)
146 (clear-test-status)
147 (run-in-child-sbcl
148 `((load "test-util")
149 (load "assertoid")
150 (defpackage :run-tests
151 (:use :cl :test-util :sb-ext)))
153 `((in-package :cl-user)
154 (use-package :test-util)
155 (use-package :assertoid)
156 (setf test-util:*break-on-failure* ,test-util:*break-on-failure*)
157 (setf test-util:*break-on-expected-failure*
158 ,test-util:*break-on-expected-failure*)
159 (let* ((file ,test-file)
160 (sb-ext:*evaluator-mode* ,*test-evaluator-mode*)
161 (*features*
162 (if (eq sb-ext:*evaluator-mode* :interpret)
163 (cons :interpreter *features*)
164 *features*))
165 (*break-on-error* ,run-tests::*break-on-error*))
166 (declare (special *break-on-error*))
167 (format t "// Running ~a in ~a evaluator mode~%"
168 file sb-ext:*evaluator-mode*)
169 (restart-case
170 (handler-bind
171 ((error (lambda (condition)
172 (push (list :unhandled-error file)
173 test-util::*failures*)
174 (cond (*break-on-error*
175 (test-util:really-invoke-debugger condition))
177 (format *error-output* "~&Unhandled ~a: ~a~%"
178 (type-of condition) condition)
179 (sb-debug:print-backtrace)))
180 (invoke-restart 'skip-file))))
181 ,test-code)
182 (skip-file ()
183 (format t ">>>~a<<<~%" test-util::*failures*)))
184 (test-util:report-test-status)
185 (sb-ext:exit :code 104)))))
187 (defun impure-runner (files test-fun)
188 (when files
189 (format t "// Running impure tests (~a)~%" test-fun)
190 (let ((*package* (find-package :cl-user)))
191 (setup-cl-user)
192 (dolist (file files)
193 (force-output)
194 (let ((exit-code (run-impure-in-child-sbcl file
195 (funcall test-fun file))))
196 (if (= exit-code 104)
197 (with-open-file (stream "test-status.lisp-expr"
198 :direction :input
199 :if-does-not-exist :error)
200 (append-failures (read stream)))
201 (push (list :invalid-exit-status file)
202 *all-failures*)))))))
204 (defun make-error-handler (file)
205 (lambda (condition)
206 (push (list :unhandled-error file) *failures*)
207 (cond (*break-on-error*
208 (test-util:really-invoke-debugger condition))
210 (format *error-output* "~&Unhandled ~a: ~a~%"
211 (type-of condition) condition)
212 (sb-debug:print-backtrace)))
213 (invoke-restart 'skip-file)))
215 (defun append-failures (&optional (failures *failures*))
216 (setf *all-failures* (append failures *all-failures*)))
218 (defun unexpected-failures ()
219 (remove-if (lambda (x)
220 (or (eq (car x) :expected-failure)
221 (eq (car x) :unexpected-success)
222 (eq (car x) :skipped-broken)
223 (eq (car x) :skipped-disabled)))
224 *all-failures*))
226 (defun setup-cl-user ()
227 (use-package :test-util)
228 (use-package :assertoid))
230 (defun load-test (file)
231 `(load ,file))
233 (defun cload-test (file)
234 `(let ((compile-name (compile-file-pathname ,file)))
235 (unwind-protect
236 (progn
237 (compile-file ,file)
238 (load compile-name))
239 (ignore-errors
240 (delete-file compile-name)))))
242 (defun sh-test (file)
243 ;; What? No SB-POSIX:EXECV?
244 (clear-test-status)
245 `(progn
246 (sb-posix:setenv "TEST_SBCL_EVALUATOR_MODE"
247 (string-downcase ,*test-evaluator-mode*)
249 (let ((process (sb-ext:run-program "/bin/sh"
250 (list (native-namestring ,file))
251 :output *error-output*)))
252 (let ((*failures* nil))
253 (test-util:report-test-status))
254 (sb-ext:exit :code (process-exit-code process)))))
256 (defun filter-test-files (wild-mask)
257 (if *explicit-test-files*
258 (loop for file in *explicit-test-files*
259 when (pathname-match-p file wild-mask)
260 collect file)
261 (directory wild-mask)))
263 (defun pure-load-files ()
264 (filter-test-files "*.pure.lisp"))
266 (defun pure-cload-files ()
267 (filter-test-files "*.pure-cload.lisp"))
269 (defun impure-load-files ()
270 (filter-test-files "*.impure.lisp"))
272 (defun impure-cload-files ()
273 (filter-test-files "*.impure-cload.lisp"))
275 (defun sh-files ()
276 (filter-test-files "*.test.sh"))