X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Frun-tests.lisp;h=ae0fee2618d17f655f94d808117f3b9608967ebb;hb=c7c7bab2b37d8b9fbda8f955f09540db17573afa;hp=32f7bb97cb2db06cecaf77f596adaddb5c7f165f;hpb=14d9ae2d08892daee9a94da1a050bb6f2ca57dbe;p=sbcl.git diff --git a/tests/run-tests.lisp b/tests/run-tests.lisp index 32f7bb9..ae0fee2 100644 --- a/tests/run-tests.lisp +++ b/tests/run-tests.lisp @@ -32,7 +32,7 @@ (pure-runner (pure-cload-files) #'cload-test) (impure-runner (impure-load-files) #'load-test) (impure-runner (impure-cload-files) #'cload-test) - (impure-runner (sh-files) #'sh-test) + #-win32 (impure-runner (sh-files) #'sh-test) (report) (sb-ext:quit :unix-status (if (unexpected-failures) 1 @@ -43,7 +43,7 @@ (format t "Finished running tests.~%") (cond (*all-failures* (format t "Status:~%") - (dolist (fail (reverse *all-failures*)) + (dolist (fail (reverse *all-failures*)) (cond ((eq (car fail) :unhandled-error) (format t " ~20a ~a~%" "Unhandled error" @@ -71,15 +71,74 @@ (dolist (file files) (when (accept-test-file file) (format t "// Running ~a~%" file) - (handler-case - (funcall test-fun file) - (error (error) - (push (list :unhandled-error file) - *all-failures*) - (when *break-on-error* - (test-util:really-invoke-debugger error)))))) + (restart-case + (handler-bind ((error (make-error-handler file))) + (eval (funcall test-fun file))) + (skip-file ())))) (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 + (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*))) + +(defun run-impure-in-child-sbcl (test-file test-code) + (run-in-child-sbcl + `((load "test-util") + (load "assertoid") + (defpackage :run-tests + (:use :cl :test-util :sb-ext))) + + `((in-package :cl-user) + (use-package :test-util) + (use-package :assertoid) + (setf test-util:*break-on-failure* ,test-util:*break-on-failure*) + (setf test-util:*break-on-expected-failure* + ,test-util:*break-on-expected-failure*) + (let ((file ,test-file) + (*break-on-error* ,run-tests::*break-on-error*)) + (format t "// Running ~a~%" file) + (restart-case + (handler-bind + ((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*))) + (test-util:report-test-status) + (sb-ext:quit :unix-status 104))))) + (defun impure-runner (files test-fun) (format t "// Running impure tests (~a)~%" test-fun) (let ((*package* (find-package :cl-user))) @@ -87,58 +146,58 @@ (dolist (file files) (when (accept-test-file file) (force-output) - (let ((pid (sb-posix:fork))) - (cond ((= pid 0) - (format t "// Running ~a~%" file) - (handler-case - (funcall test-fun file) - (error (error) - (push (list :unhandled-error file) *failures*) - (when *break-on-error* - (test-util:really-invoke-debugger error)))) - (report-test-status) - (sb-ext:quit :unix-status 104)) - (t - (let ((status (make-array 1 :element-type '(signed-byte 32)))) - (sb-posix:waitpid pid 0 status) - (if (and (sb-posix:wifexited (aref status 0)) - (= (sb-posix:wexitstatus (aref status 0)) - 104)) - (with-open-file (stream "test-status.lisp-expr" - :direction :input - :if-does-not-exist :error) - (append-failures (read stream))) - (push (list :invalid-exit-status file) - *all-failures*)))))))))) + (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" + :direction :input + :if-does-not-exist :error) + (append-failures (read stream))) + (push (list :invalid-exit-status file) + *all-failures*))))))) + +(defun make-error-handler (file) + (lambda (condition) + (push (list :unhandled-error file) *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))) (defun append-failures (&optional (failures *failures*)) (setf *all-failures* (append failures *all-failures*))) (defun unexpected-failures () - (remove-if (lambda (x) (eq (car x) :expected-failure)) *all-failures*)) + (remove-if (lambda (x) + (or (eq (car x) :expected-failure) + (eq (car x) :unexpected-success))) + *all-failures*)) (defun setup-cl-user () (use-package :test-util) (use-package :assertoid)) (defun load-test (file) - (load file)) + `(load ,file)) (defun cload-test (file) - (let ((compile-name (compile-file-pathname file))) - (unwind-protect - (progn - (compile-file file) - (load compile-name)) - (ignore-errors - (delete-file compile-name))))) + `(let ((compile-name (compile-file-pathname ,file))) + (unwind-protect + (progn + (compile-file ,file) + (load compile-name)) + (ignore-errors + (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*))) - (sb-ext:quit :unix-status (process-exit-code process)))) + `(let ((process (sb-ext:run-program "/bin/sh" + (list (namestring ,file)) + :output *error-output*))) + (sb-ext:quit :unix-status (process-exit-code process)))) (defun accept-test-file (file) (if *accept-files*