dcf2f2c9d2c6c8fb652a1cd4716d224d798c9b0c
[sbcl.git] / run-tests.lisp
1 #+#.(cl:if (cl:find-package "ASDF") '(or) '(and))
2 (load (merge-pathnames "../contrib/asdf/asdf.fasl"))
3
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))
8
9 (load "test-util.lisp")
10
11 (defpackage :run-tests
12     (:use :cl :test-util :sb-ext))
13
14 (load "assertoid.lisp")
15
16 (in-package run-tests)
17
18 (defvar *all-failures* nil)
19 (defvar *break-on-error* nil)
20 (defvar *report-skipped-tests* nil)
21 (defvar *accept-files* nil)
22
23 (defun run-all ()
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))
32           (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)
39   (report)
40   (sb-ext:exit :code (if (unexpected-failures)
41                          1
42                          104)))
43
44 (defun report ()
45   (terpri)
46   (format t "Finished running tests.~%")
47   (let ((skipcount 0)
48         (*print-pretty* nil))
49     (cond (*all-failures*
50            (format t "Status:~%")
51            (dolist (fail (reverse *all-failures*))
52              (cond ((eq (car fail) :unhandled-error)
53                     (format t " ~20a ~a~%"
54                             "Unhandled error"
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))
65                               (third fail)))
66                     (incf skipcount))
67                    (t
68                     (format t " ~20a ~a / ~a~%"
69                             (ecase (first fail)
70                               (:expected-failure "Expected failure:")
71                               (:unexpected-failure "Failure:")
72                               (:unexpected-success "Unexpected success:")
73                               (:skipped-broken "Skipped (broken):")
74                               (:skipped-disabled "Skipped (irrelevant):"))
75                             (enough-namestring (second fail))
76                             (third fail)))))
77            (when (> skipcount 0)
78              (format t " (~a tests skipped for this combination of platform and features)~%"
79                      skipcount)))
80           (t
81            (format t "All tests succeeded~%")))))
82
83 (defun pure-runner (files test-fun)
84   (format t "// Running pure tests (~a)~%" test-fun)
85   (let ((*package* (find-package :cl-user))
86         (*failures* nil))
87     (setup-cl-user)
88     (dolist (file files)
89       (when (accept-test-file file)
90         (format t "// Running ~a~%" file)
91         (restart-case
92             (handler-bind ((error (make-error-handler file)))
93               (eval (funcall test-fun file)))
94           (skip-file ()))))
95     (append-failures)))
96
97 (defun run-in-child-sbcl (load-forms forms)
98   ;; We used to fork() for POSIX platforms, and use this for Windows.
99   ;; However, it seems better to use the same solution everywhere.
100   (process-exit-code
101    (#-win32 with-open-file #-win32 (devnull "/dev/null") #+win32 progn
102      (sb-ext:run-program
103       (first *POSIX-ARGV*)
104       (append
105        (list "--core" SB-INT:*CORE-STRING*
106              "--noinform"
107              "--no-sysinit"
108              "--no-userinit"
109              "--noprint"
110              "--disable-debugger")
111        (loop for form in (append load-forms forms)
112              collect "--eval"
113              collect (write-to-string form)))
114       :output sb-sys:*stdout*
115       :input #-win32 devnull #+win32 sb-sys:*stdin*))))
116
117 (defun run-impure-in-child-sbcl (test-file test-code)
118   (run-in-child-sbcl
119     `((load "test-util")
120       (load "assertoid")
121       (defpackage :run-tests
122         (:use :cl :test-util :sb-ext)))
123
124     `((in-package :cl-user)
125       (use-package :test-util)
126       (use-package :assertoid)
127       (setf test-util:*break-on-failure* ,test-util:*break-on-failure*)
128       (setf test-util:*break-on-expected-failure*
129             ,test-util:*break-on-expected-failure*)
130       (let ((file ,test-file)
131             (*break-on-error* ,run-tests::*break-on-error*))
132         (declare (special *break-on-error*))
133         (format t "// Running ~a~%" file)
134         (restart-case
135             (handler-bind
136                 ((error (lambda (condition)
137                           (push (list :unhandled-error file)
138                                 test-util::*failures*)
139                           (cond (*break-on-error*
140                                  (test-util:really-invoke-debugger condition))
141                                 (t
142                                  (format *error-output* "~&Unhandled ~a: ~a~%"
143                                          (type-of condition) condition)
144                                  (sb-debug:backtrace)))
145                           (invoke-restart 'skip-file))))
146               ,test-code)
147           (skip-file ()
148             (format t ">>>~a<<<~%" test-util::*failures*)))
149         (test-util:report-test-status)
150         (sb-ext:exit :code 104)))))
151
152 (defun impure-runner (files test-fun)
153   (format t "// Running impure tests (~a)~%" test-fun)
154   (let ((*package* (find-package :cl-user)))
155     (setup-cl-user)
156     (dolist (file files)
157       (when (accept-test-file file)
158         (force-output)
159         (let ((exit-code (run-impure-in-child-sbcl file
160                                                    (funcall test-fun file))))
161           (if (= exit-code 104)
162               (with-open-file (stream "test-status.lisp-expr"
163                                       :direction :input
164                                       :if-does-not-exist :error)
165                 (append-failures (read stream)))
166               (push (list :invalid-exit-status file)
167                     *all-failures*)))))))
168
169 (defun make-error-handler (file)
170   (lambda (condition)
171     (push (list :unhandled-error file) *failures*)
172     (cond (*break-on-error*
173            (test-util:really-invoke-debugger condition))
174           (t
175            (format *error-output* "~&Unhandled ~a: ~a~%"
176                    (type-of condition) condition)
177            (sb-debug:backtrace)))
178     (invoke-restart 'skip-file)))
179
180 (defun append-failures (&optional (failures *failures*))
181   (setf *all-failures* (append failures *all-failures*)))
182
183 (defun unexpected-failures ()
184   (remove-if (lambda (x)
185                (or (eq (car x) :expected-failure)
186                    (eq (car x) :unexpected-success)
187                    (eq (car x) :skipped-broken)
188                    (eq (car x) :skipped-disabled)))
189              *all-failures*))
190
191 (defun setup-cl-user ()
192   (use-package :test-util)
193   (use-package :assertoid))
194
195 (defun load-test (file)
196   `(load ,file))
197
198 (defun cload-test (file)
199   `(let ((compile-name (compile-file-pathname ,file)))
200      (unwind-protect
201           (progn
202             (compile-file ,file)
203             (load compile-name))
204        (ignore-errors
205          (delete-file compile-name)))))
206
207 (defun sh-test (file)
208   ;; What? No SB-POSIX:EXECV?
209   `(let ((process (sb-ext:run-program "/bin/sh"
210                                       (list (native-namestring ,file))
211                                       :environment (test-util::test-env)
212                                       :output *error-output*)))
213      (let ((*failures* nil))
214        (test-util:report-test-status))
215      (sb-ext:exit :code (process-exit-code process))))
216
217 (defun accept-test-file (file)
218   (if *accept-files*
219       (find (truename file) *accept-files* :test #'equalp)
220       t))
221
222 (defun pure-load-files ()
223   (directory "*.pure.lisp"))
224
225 (defun pure-cload-files ()
226   (directory "*.pure-cload.lisp"))
227
228 (defun impure-load-files ()
229   (directory "*.impure.lisp"))
230
231 (defun impure-cload-files ()
232   (directory "*.impure-cload.lisp"))
233
234 (defun sh-files ()
235   (directory "*.test.sh"))