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 *accept-files
* nil
)
23 (dolist (arg (cdr *posix-argv
*))
24 (cond ((string= arg
"--break-on-failure")
25 (setf *break-on-error
* t
)
26 (setf test-util
:*break-on-failure
* t
))
27 ((string= arg
"--break-on-expected-failure")
28 (setf test-util
:*break-on-expected-failure
* t
))
30 (push (truename (parse-namestring arg
)) *accept-files
*))))
31 (pure-runner (pure-load-files) #'load-test
)
32 (pure-runner (pure-cload-files) #'cload-test
)
33 (impure-runner (impure-load-files) #'load-test
)
34 (impure-runner (impure-cload-files) #'cload-test
)
35 #-win32
(impure-runner (sh-files) #'sh-test
)
37 (sb-ext:quit
:unix-status
(if (unexpected-failures)
43 (format t
"Finished running tests.~%")
45 (format t
"Status:~%")
46 (dolist (fail (reverse *all-failures
*))
47 (cond ((eq (car fail
) :unhandled-error
)
48 (format t
" ~20a ~a~%"
50 (enough-namestring (second fail
))))
51 ((eq (car fail
) :invalid-exit-status
)
52 (format t
" ~20a ~a~%"
53 "Invalid exit status:"
54 (enough-namestring (second fail
))))
56 (format t
" ~20a ~a / ~a~%"
58 (:expected-failure
"Expected failure:")
59 (:unexpected-failure
"Failure:")
60 (:unexpected-success
"Unexpected success:"))
61 (enough-namestring (second fail
))
64 (format t
"All tests succeeded~%"))))
66 (defun pure-runner (files test-fun
)
67 (format t
"// Running pure tests (~a)~%" test-fun
)
68 (let ((*package
* (find-package :cl-user
))
72 (when (accept-test-file file
)
73 (format t
"// Running ~a~%" file
)
75 (handler-bind ((error (make-error-handler file
)))
76 (eval (funcall test-fun file
)))
80 (defun run-in-child-sbcl (load-forms forms
)
81 ;; We used to fork() for POSIX platforms, and use this for Windows.
82 ;; However, it seems better to use the same solution everywhere.
87 (list "--core" SB-INT
:*CORE-STRING
*
91 (loop for form in
(append load-forms forms
)
93 collect
(write-to-string form
)))
94 :output sb-sys
:*stdout
*
95 :input sb-sys
:*stdin
*)))
97 (defun run-impure-in-child-sbcl (test-file test-code
)
101 (defpackage :run-tests
102 (:use
:cl
:test-util
:sb-ext
)))
104 `((in-package :cl-user
)
105 (use-package :test-util
)
106 (use-package :assertoid
)
107 (setf test-util
:*break-on-failure
* ,test-util
:*break-on-failure
*)
108 (setf test-util
:*break-on-expected-failure
*
109 ,test-util
:*break-on-expected-failure
*)
110 (let ((file ,test-file
)
111 (*break-on-error
* ,run-tests
::*break-on-error
*))
112 (format t
"// Running ~a~%" file
)
115 ((error (lambda (condition)
116 (push (list :unhandled-error file
)
117 test-util
::*failures
*)
118 (cond (*break-on-error
*
119 (test-util:really-invoke-debugger condition
))
121 (format *error-output
* "~&Unhandled ~a: ~a~%"
122 (type-of condition
) condition
)
123 (sb-debug:backtrace
)))
124 (invoke-restart 'skip-file
))))
127 (format t
">>>~a<<<~%" test-util
::*failures
*)))
128 (test-util:report-test-status
)
129 (sb-ext:quit
:unix-status
104)))))
131 (defun impure-runner (files test-fun
)
132 (format t
"// Running impure tests (~a)~%" test-fun
)
133 (let ((*package
* (find-package :cl-user
)))
136 (when (accept-test-file file
)
138 (let ((exit-code (run-impure-in-child-sbcl file
139 (funcall test-fun file
))))
140 (if (= exit-code
104)
141 (with-open-file (stream "test-status.lisp-expr"
143 :if-does-not-exist
:error
)
144 (append-failures (read stream
)))
145 (push (list :invalid-exit-status file
)
146 *all-failures
*)))))))
148 (defun make-error-handler (file)
150 (push (list :unhandled-error file
) *failures
*)
151 (cond (*break-on-error
*
152 (test-util:really-invoke-debugger condition
))
154 (format *error-output
* "~&Unhandled ~a: ~a~%"
155 (type-of condition
) condition
)
156 (sb-debug:backtrace
)))
157 (invoke-restart 'skip-file
)))
159 (defun append-failures (&optional
(failures *failures
*))
160 (setf *all-failures
* (append failures
*all-failures
*)))
162 (defun unexpected-failures ()
163 (remove-if (lambda (x)
164 (or (eq (car x
) :expected-failure
)
165 (eq (car x
) :unexpected-success
)))
168 (defun setup-cl-user ()
169 (use-package :test-util
)
170 (use-package :assertoid
))
172 (defun load-test (file)
175 (defun cload-test (file)
176 `(let ((compile-name (compile-file-pathname ,file
)))
182 (delete-file compile-name
)))))
184 (defun sh-test (file)
185 ;; What? No SB-POSIX:EXECV?
186 `(let ((process (sb-ext:run-program
"/bin/sh"
187 (list (native-namestring ,file
))
188 :output
*error-output
*)))
189 (sb-ext:quit
:unix-status
(process-exit-code process
))))
191 (defun accept-test-file (file)
193 (find (truename file
) *accept-files
* :test
#'equalp
)
196 (defun pure-load-files ()
197 (directory "*.pure.lisp"))
199 (defun pure-cload-files ()
200 (directory "*.pure-cload.lisp"))
202 (defun impure-load-files ()
203 (directory "*.impure.lisp"))
205 (defun impure-cload-files ()
206 (directory "*.impure-cload.lisp"))
209 (directory "*.test.sh"))