X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Frun-tests.lisp;h=0069333a3a4d2f7dcc56dac2c83d1f5f99a2946a;hb=f7a78dd3554bd977b006e5da349a11d4e8463bb5;hp=3f2bd7738273f23d42da1790deaae9a98d3406aa;hpb=2a44956e41c9d6dcec57eb5719b9a211c9b7c56f;p=sbcl.git diff --git a/tests/run-tests.lisp b/tests/run-tests.lisp index 3f2bd77..0069333 100644 --- a/tests/run-tests.lisp +++ b/tests/run-tests.lisp @@ -41,27 +41,35 @@ (defun report () (terpri) (format t "Finished running tests.~%") - (cond (*all-failures* - (format t "Status:~%") - (dolist (fail (reverse *all-failures*)) - (cond ((eq (car fail) :unhandled-error) - (format t " ~20a ~a~%" - "Unhandled error" - (enough-namestring (second fail)))) - ((eq (car fail) :invalid-exit-status) - (format t " ~20a ~a~%" - "Invalid exit status:" - (enough-namestring (second fail)))) - (t - (format t " ~20a ~a / ~a~%" - (ecase (first fail) - (:expected-failure "Expected failure:") - (:unexpected-failure "Failure:") - (:unexpected-success "Unexpected success:")) - (enough-namestring (second fail)) - (third fail)))))) - (t - (format t "All tests succeeded~%")))) + (let ((skipcount 0)) + (cond (*all-failures* + (format t "Status:~%") + (dolist (fail (reverse *all-failures*)) + (cond ((eq (car fail) :unhandled-error) + (format t " ~20a ~a~%" + "Unhandled error" + (enough-namestring (second fail)))) + ((eq (car fail) :invalid-exit-status) + (format t " ~20a ~a~%" + "Invalid exit status:" + (enough-namestring (second fail)))) + ((eq (car fail) :skipped-disabled) + (incf skipcount)) + (t + (format t " ~20a ~a / ~a~%" + (ecase (first fail) + (:expected-failure "Expected failure:") + (:unexpected-failure "Failure:") + (:unexpected-success "Unexpected success:") + (:skipped-broken "Skipped (broken):") + (:skipped-disabled "Skipped (irrelevant):")) + (enough-namestring (second fail)) + (third fail))))) + (when (> skipcount 0) + (format t " (~a tests skipped for this combination of platform and features)~%" + skipcount))) + (t + (format t "All tests succeeded~%"))))) (defun pure-runner (files test-fun) (format t "// Running pure tests (~a)~%" test-fun) @@ -78,32 +86,24 @@ (append-failures))) (defun run-in-child-sbcl (load-forms forms) - (declare (ignorable load-forms)) - #-win32 - (let ((pid (sb-posix:fork))) - (cond ((= pid 0) - (dolist (form forms) - (eval form))) - (t - (let ((status (make-array 1 :element-type '(signed-byte 32)))) - (sb-posix:waitpid pid 0 status) - (if (sb-posix:wifexited (aref status 0)) - (sb-posix:wexitstatus (aref status 0)) - 1))))) - #+win32 + ;; We used to fork() for POSIX platforms, and use this for Windows. + ;; However, it seems better to use the same solution everywhere. (process-exit-code - (sb-ext:run-program - (first *POSIX-ARGV*) - (append - (list "--core" SB-INT:*CORE-STRING* - "--noinform" - "--no-sysinit" - "--no-userinit") - (loop for form in (append load-forms forms) - collect "--eval" - collect (write-to-string form))) - :output sb-sys:*stdout* - :input sb-sys:*stdin*))) + (#-win32 with-open-file #-win32 (devnull "/dev/null") #+win32 progn + (sb-ext:run-program + (first *POSIX-ARGV*) + (append + (list "--core" SB-INT:*CORE-STRING* + "--noinform" + "--no-sysinit" + "--no-userinit" + "--noprint" + "--disable-debugger") + (loop for form in (append load-forms forms) + collect "--eval" + collect (write-to-string form))) + :output sb-sys:*stdout* + :input #-win32 devnull #+win32 sb-sys:*stdin*)))) (defun run-impure-in-child-sbcl (test-file test-code) (run-in-child-sbcl @@ -123,18 +123,19 @@ (format t "// Running ~a~%" file) (restart-case (handler-bind - ((error (lambda (condition) - (push (list :unhandled-error cl-user::file) test-util::*failures*) - (cond (*break-on-error* - (test-util:really-invoke-debugger condition)) - (t - (format *error-output* "~&Unhandled ~a: ~a~%" - (type-of condition) condition) - (funcall (symbol-function (intern "BACKTRACE" :sb-debug))))) - (invoke-restart 'skip-file)))) + ((error (lambda (condition) + (push (list :unhandled-error file) + test-util::*failures*) + (cond (*break-on-error* + (test-util:really-invoke-debugger condition)) + (t + (format *error-output* "~&Unhandled ~a: ~a~%" + (type-of condition) condition) + (sb-debug:backtrace))) + (invoke-restart 'skip-file)))) ,test-code) - (skip-file () - (format t ">>>~a<<<~%" test-util::*failures*))) + (skip-file () + (format t ">>>~a<<<~%" test-util::*failures*))) (test-util:report-test-status) (sb-ext:quit :unix-status 104))))) @@ -145,7 +146,7 @@ (dolist (file files) (when (accept-test-file file) (force-output) - (let ((exit-code (run-impure-in-child-sbcl file + (let ((exit-code (run-impure-in-child-sbcl file (funcall test-fun file)))) (if (= exit-code 104) (with-open-file (stream "test-status.lisp-expr" @@ -172,7 +173,9 @@ (defun unexpected-failures () (remove-if (lambda (x) (or (eq (car x) :expected-failure) - (eq (car x) :unexpected-success))) + (eq (car x) :unexpected-success) + (eq (car x) :skipped-broken) + (eq (car x) :skipped-disabled))) *all-failures*)) (defun setup-cl-user () @@ -185,17 +188,20 @@ (defun cload-test (file) `(let ((compile-name (compile-file-pathname ,file))) (unwind-protect - (progn - (compile-file ,file) - (load compile-name)) + (progn + (compile-file ,file) + (load compile-name)) (ignore-errors - (delete-file compile-name))))) + (delete-file compile-name))))) (defun sh-test (file) ;; What? No SB-POSIX:EXECV? `(let ((process (sb-ext:run-program "/bin/sh" - (list (namestring ,file)) - :output *error-output*))) + (list (native-namestring ,file)) + :environment (test-util::test-env) + :output *error-output*))) + (let ((*failures* nil)) + (test-util:report-test-status)) (sb-ext:quit :unix-status (process-exit-code process)))) (defun accept-test-file (file)