Avoid forward references to PARSE-mumble-TYPE condition classes.
[sbcl.git] / tests / run-tests.lisp
blob4085476aee36402bf9cc3cad5d1bc0fbf28e3468
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 *all-failures* nil)
13 (defvar *break-on-error* nil)
14 (defvar *report-skipped-tests* nil)
15 (defvar *explicit-test-files* nil)
17 (defun run-all ()
18 (dolist (arg (cdr *posix-argv*))
19 (cond ((string= arg "--break-on-failure")
20 (setf *break-on-error* t)
21 (setf test-util:*break-on-failure* t))
22 ((string= arg "--break-on-expected-failure")
23 (setf test-util:*break-on-expected-failure* t))
24 ((string= arg "--report-skipped-tests")
25 (setf *report-skipped-tests* t))
26 ((string= arg "--no-color"))
28 (push (truename (parse-namestring arg)) *explicit-test-files*))))
29 (setf *explicit-test-files* (nreverse *explicit-test-files*))
30 (pure-runner (pure-load-files) #'load-test)
31 (pure-runner (pure-cload-files) #'cload-test)
32 (impure-runner (impure-load-files) #'load-test)
33 (impure-runner (impure-cload-files) #'cload-test)
34 #-win32 (impure-runner (sh-files) #'sh-test)
35 (report)
36 (sb-ext:exit :code (if (unexpected-failures)
38 104)))
40 (defun report ()
41 (terpri)
42 (format t "Finished running tests.~%")
43 (let ((skipcount 0)
44 (*print-pretty* nil))
45 (cond (*all-failures*
46 (format t "Status:~%")
47 (dolist (fail (reverse *all-failures*))
48 (cond ((eq (car fail) :unhandled-error)
49 (output-colored-text (car fail)
50 " Unhandled Error")
51 (format t " ~a~%"
52 (enough-namestring (second fail))))
53 ((eq (car fail) :invalid-exit-status)
54 (output-colored-text (car fail)
55 " Invalid exit status:")
56 (format t " ~a~%"
57 (enough-namestring (second fail))))
58 ((eq (car fail) :skipped-disabled)
59 (when *report-skipped-tests*
60 (format t " ~20a ~a / ~a~%"
61 "Skipped (irrelevant):"
62 (enough-namestring (second fail))
63 (third fail)))
64 (incf skipcount))
66 (output-colored-text
67 (first fail)
68 (ecase (first fail)
69 (:expected-failure " Expected failure:")
70 (:unexpected-failure " Failure:")
71 (:leftover-thread " Leftover thread (broken):")
72 (:unexpected-success " Unexpected success:")
73 (:skipped-broken " Skipped (broken):")
74 (:skipped-disabled " Skipped (irrelevant):")))
75 (format t " ~a / ~a~%"
76 (enough-namestring (second fail))
77 (third fail)))))
78 (when (> skipcount 0)
79 (format t " (~a tests skipped for this combination of platform and features)~%"
80 skipcount)))
82 (format t "All tests succeeded~%")))))
84 (defun pure-runner (files test-fun)
85 (when files
86 (format t "// Running pure tests (~a)~%" test-fun)
87 (let ((*package* (find-package :cl-user))
88 (*failures* nil))
89 (setup-cl-user)
90 (dolist (file files)
91 (format t "// Running ~a~%" file)
92 (restart-case
93 (handler-bind ((error (make-error-handler file)))
94 (eval (funcall test-fun file)))
95 (skip-file ())))
96 (append-failures))))
98 (defun run-in-child-sbcl (load-forms forms)
99 ;; We used to fork() for POSIX platforms, and use this for Windows.
100 ;; However, it seems better to use the same solution everywhere.
101 (process-exit-code
102 (#-win32 with-open-file #-win32 (devnull "/dev/null") #+win32 progn
103 (sb-ext:run-program
104 (first *POSIX-ARGV*)
105 (append
106 (list "--core" SB-INT:*CORE-STRING*
107 "--noinform"
108 "--no-sysinit"
109 "--no-userinit"
110 "--noprint"
111 "--disable-debugger")
112 (loop for form in (append load-forms forms)
113 collect "--eval"
114 collect (write-to-string form)))
115 :output sb-sys:*stdout*
116 :input #-win32 devnull #+win32 sb-sys:*stdin*))))
118 (defun clear-test-status ()
119 (with-open-file (stream "test-status.lisp-expr"
120 :direction :output
121 :if-exists :supersede)
122 (write-line "NIL" stream)))
124 (defun run-impure-in-child-sbcl (test-file test-code)
125 (clear-test-status)
126 (run-in-child-sbcl
127 `((load "test-util")
128 (load "assertoid")
129 (defpackage :run-tests
130 (:use :cl :test-util :sb-ext)))
132 `((in-package :cl-user)
133 (use-package :test-util)
134 (use-package :assertoid)
135 (setf test-util:*break-on-failure* ,test-util:*break-on-failure*)
136 (setf test-util:*break-on-expected-failure*
137 ,test-util:*break-on-expected-failure*)
138 (let ((file ,test-file)
139 (*break-on-error* ,run-tests::*break-on-error*))
140 (declare (special *break-on-error*))
141 (format t "// Running ~a~%" file)
142 (restart-case
143 (handler-bind
144 ((error (lambda (condition)
145 (push (list :unhandled-error file)
146 test-util::*failures*)
147 (cond (*break-on-error*
148 (test-util:really-invoke-debugger condition))
150 (format *error-output* "~&Unhandled ~a: ~a~%"
151 (type-of condition) condition)
152 (sb-debug:print-backtrace)))
153 (invoke-restart 'skip-file))))
154 ,test-code)
155 (skip-file ()
156 (format t ">>>~a<<<~%" test-util::*failures*)))
157 (test-util:report-test-status)
158 (sb-ext:exit :code 104)))))
160 (defun impure-runner (files test-fun)
161 (when files
162 (format t "// Running impure tests (~a)~%" test-fun)
163 (let ((*package* (find-package :cl-user)))
164 (setup-cl-user)
165 (dolist (file files)
166 (force-output)
167 (let ((exit-code (run-impure-in-child-sbcl file
168 (funcall test-fun file))))
169 (if (= exit-code 104)
170 (with-open-file (stream "test-status.lisp-expr"
171 :direction :input
172 :if-does-not-exist :error)
173 (append-failures (read stream)))
174 (push (list :invalid-exit-status file)
175 *all-failures*)))))))
177 (defun make-error-handler (file)
178 (lambda (condition)
179 (push (list :unhandled-error file) *failures*)
180 (cond (*break-on-error*
181 (test-util:really-invoke-debugger condition))
183 (format *error-output* "~&Unhandled ~a: ~a~%"
184 (type-of condition) condition)
185 (sb-debug:print-backtrace)))
186 (invoke-restart 'skip-file)))
188 (defun append-failures (&optional (failures *failures*))
189 (setf *all-failures* (append failures *all-failures*)))
191 (defun unexpected-failures ()
192 (remove-if (lambda (x)
193 (or (eq (car x) :expected-failure)
194 (eq (car x) :unexpected-success)
195 (eq (car x) :skipped-broken)
196 (eq (car x) :skipped-disabled)))
197 *all-failures*))
199 (defun setup-cl-user ()
200 (use-package :test-util)
201 (use-package :assertoid))
203 (defun load-test (file)
204 ;; KLUDGE: while it may be the case that all test files should be opened
205 ;; as UTF-8, the 'reader' test file is particularly strange because it
206 ;; contains non-UTF-8 bytes, but the character decoding warning was not
207 ;; an intended test. It was happenstance that makes one think
208 ;; "great! there _is_ a test for character decoding errors
209 ;; in the file I would expect to find such a test in"
210 ;; except it isn't. A true test would assert something useful,
211 ;; AND not make scary meta-noise, or at least preface it with
212 ;; ";; Expect warnings from the following test"
213 `(load ,file
214 ,@(if (search "reader.impure" (namestring file))
215 '(:external-format :latin-1))))
218 (defun cload-test (file)
219 `(let ((compile-name (compile-file-pathname ,file)))
220 (unwind-protect
221 (progn
222 (compile-file ,file)
223 (load compile-name))
224 (ignore-errors
225 (delete-file compile-name)))))
227 (defun sh-test (file)
228 ;; What? No SB-POSIX:EXECV?
229 (clear-test-status)
230 `(let ((process (sb-ext:run-program "/bin/sh"
231 (list (native-namestring ,file))
232 :output *error-output*)))
233 (let ((*failures* nil))
234 (test-util:report-test-status))
235 (sb-ext:exit :code (process-exit-code process))))
237 (defun filter-test-files (wild-mask)
238 (if *explicit-test-files*
239 (loop for file in *explicit-test-files*
240 when (pathname-match-p file wild-mask)
241 collect file)
242 (directory wild-mask)))
244 (defun pure-load-files ()
245 (filter-test-files "*.pure.lisp"))
247 (defun pure-cload-files ()
248 (filter-test-files "*.pure-cload.lisp"))
250 (defun impure-load-files ()
251 (filter-test-files "*.impure.lisp"))
253 (defun impure-cload-files ()
254 (filter-test-files "*.impure-cload.lisp"))
256 (defun sh-files ()
257 (filter-test-files "*.test.sh"))