1 #+#.(cl:if (cl:find-package "ASDF") '(or) '(and))
2 (load (merge-pathnames "../contrib/asdf/asdf.fasl"))
4 #+#.(cl:if (cl:find-package "SB-POSIX") '(or) '(and))
5 (let ((asdf:*central-registry*
6 (cons "../contrib/systems/" asdf:*central-registry*)))
7 (asdf:oos 'asdf:load-op 'sb-posix))
9 (load "test-util.lisp")
11 (defpackage :run-tests
12 (:use :cl :test-util :sb-ext))
14 (load "assertoid.lisp")
16 (in-package run-tests)
18 (defvar *all-failures* nil)
19 (defvar *break-on-error* nil)
20 (defvar *report-skipped-tests* nil)
21 (defvar *accept-files* nil)
24 (dolist (arg (cdr *posix-argv*))
25 (cond ((string= arg "--break-on-failure")
26 (setf *break-on-error* t)
27 (setf test-util:*break-on-failure* t))
28 ((string= arg "--break-on-expected-failure")
29 (setf test-util:*break-on-expected-failure* t))
30 ((string= arg "--report-skipped-tests")
31 (setf *report-skipped-tests* t))
33 (push (truename (parse-namestring arg)) *accept-files*))))
34 (pure-runner (pure-load-files) #'load-test)
35 (pure-runner (pure-cload-files) #'cload-test)
36 (impure-runner (impure-load-files) #'load-test)
37 (impure-runner (impure-cload-files) #'cload-test)
38 #-win32 (impure-runner (sh-files) #'sh-test)
40 (sb-ext:exit :code (if (unexpected-failures)
46 (format t "Finished running tests.~%")
50 (format t "Status:~%")
51 (dolist (fail (reverse *all-failures*))
52 (cond ((eq (car fail) :unhandled-error)
53 (format t " ~20a ~a~%"
55 (enough-namestring (second fail))))
56 ((eq (car fail) :invalid-exit-status)
57 (format t " ~20a ~a~%"
58 "Invalid exit status:"
59 (enough-namestring (second fail))))
60 ((eq (car fail) :skipped-disabled)
61 (when *report-skipped-tests*
62 (format t " ~20a ~a / ~a~%"
63 "Skipped (irrelevant):"
64 (enough-namestring (second fail))
68 (format t " ~20a ~a / ~a~%"
70 (:expected-failure "Expected failure:")
71 (:unexpected-failure "Failure:")
72 (:leftover-thread "Leftover thread (broken):")
73 (:unexpected-success "Unexpected success:")
74 (:skipped-broken "Skipped (broken):")
75 (:skipped-disabled "Skipped (irrelevant):"))
76 (enough-namestring (second fail))
79 (format t " (~a tests skipped for this combination of platform and features)~%"
82 (format t "All tests succeeded~%")))))
84 (defun pure-runner (files test-fun)
85 (format t "// Running pure tests (~a)~%" test-fun)
86 (let ((*package* (find-package :cl-user))
90 (when (accept-test-file file)
91 (format t "// Running ~a~%" file)
93 (handler-bind ((error (make-error-handler file)))
94 (eval (funcall test-fun file)))
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.
102 (#-win32 with-open-file #-win32 (devnull "/dev/null") #+win32 progn
106 (list "--core" SB-INT:*CORE-STRING*
111 "--disable-debugger")
112 (loop for form in (append load-forms forms)
114 collect (write-to-string form)))
115 :output sb-sys:*stdout*
116 :input #-win32 devnull #+win32 sb-sys:*stdin*))))
118 (defun run-impure-in-child-sbcl (test-file test-code)
122 (defpackage :run-tests
123 (:use :cl :test-util :sb-ext)))
125 `((in-package :cl-user)
126 (use-package :test-util)
127 (use-package :assertoid)
128 (setf test-util:*break-on-failure* ,test-util:*break-on-failure*)
129 (setf test-util:*break-on-expected-failure*
130 ,test-util:*break-on-expected-failure*)
131 (let ((file ,test-file)
132 (*break-on-error* ,run-tests::*break-on-error*))
133 (declare (special *break-on-error*))
134 (format t "// Running ~a~%" file)
137 ((error (lambda (condition)
138 (push (list :unhandled-error file)
139 test-util::*failures*)
140 (cond (*break-on-error*
141 (test-util:really-invoke-debugger condition))
143 (format *error-output* "~&Unhandled ~a: ~a~%"
144 (type-of condition) condition)
145 (sb-debug:backtrace)))
146 (invoke-restart 'skip-file))))
149 (format t ">>>~a<<<~%" test-util::*failures*)))
150 (test-util:report-test-status)
151 (sb-ext:exit :code 104)))))
153 (defun impure-runner (files test-fun)
154 (format t "// Running impure tests (~a)~%" test-fun)
155 (let ((*package* (find-package :cl-user)))
158 (when (accept-test-file file)
160 (let ((exit-code (run-impure-in-child-sbcl file
161 (funcall test-fun file))))
162 (if (= exit-code 104)
163 (with-open-file (stream "test-status.lisp-expr"
165 :if-does-not-exist :error)
166 (append-failures (read stream)))
167 (push (list :invalid-exit-status file)
168 *all-failures*)))))))
170 (defun make-error-handler (file)
172 (push (list :unhandled-error file) *failures*)
173 (cond (*break-on-error*
174 (test-util:really-invoke-debugger condition))
176 (format *error-output* "~&Unhandled ~a: ~a~%"
177 (type-of condition) condition)
178 (sb-debug:backtrace)))
179 (invoke-restart 'skip-file)))
181 (defun append-failures (&optional (failures *failures*))
182 (setf *all-failures* (append failures *all-failures*)))
184 (defun unexpected-failures ()
185 (remove-if (lambda (x)
186 (or (eq (car x) :expected-failure)
187 (eq (car x) :unexpected-success)
188 (eq (car x) :skipped-broken)
189 (eq (car x) :skipped-disabled)))
192 (defun setup-cl-user ()
193 (use-package :test-util)
194 (use-package :assertoid))
196 (defun load-test (file)
199 (defun cload-test (file)
200 `(let ((compile-name (compile-file-pathname ,file)))
206 (delete-file compile-name)))))
208 (defun sh-test (file)
209 ;; What? No SB-POSIX:EXECV?
210 `(let ((process (sb-ext:run-program "/bin/sh"
211 (list (native-namestring ,file))
212 :environment (test-util::test-env)
213 :output *error-output*)))
214 (let ((*failures* nil))
215 (test-util:report-test-status))
216 (sb-ext:exit :code (process-exit-code process))))
218 (defun accept-test-file (file)
220 (find (truename file) *accept-files* :test #'equalp)
223 (defun pure-load-files ()
224 (directory "*.pure.lisp"))
226 (defun pure-cload-files ()
227 (directory "*.pure-cload.lisp"))
229 (defun impure-load-files ()
230 (directory "*.impure.lisp"))
232 (defun impure-cload-files ()
233 (directory "*.impure-cload.lisp"))
236 (directory "*.test.sh"))