X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Frun-tests.lisp;h=d2942b1d9b23263d4834c8a8b11e4e69b6034d67;hb=b4f7516350d9dd848552a3b38890fc7c908cea8e;hp=f1a046f6e51146d58a2ccd2f36d13c99052f430b;hpb=fb56427f3e946aae6562e7c9cbc4636a754cd754;p=sbcl.git

diff --git a/tests/run-tests.lisp b/tests/run-tests.lisp
index f1a046f..d2942b1 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
@@ -73,10 +73,64 @@
         (format t "// Running ~a~%" file)
         (restart-case
             (handler-bind ((error (make-error-handler file)))
-              (funcall test-fun file))
+              (eval (funcall test-fun file)))
           (skip-file ()))))
     (append-failures)))
 
+(defun run-in-child-sbcl (load-forms forms)
+  ;; 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
+   (#-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
+    `((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)))
@@ -84,28 +138,15 @@
     (dolist (file files)
       (when (accept-test-file file)
         (force-output)
-        (let ((pid (sb-posix:fork)))
-          (cond ((= pid 0)
-                 (format t "// Running ~a~%" file)
-                 (restart-case
-                     (handler-bind ((error (make-error-handler file)))
-                       (funcall test-fun file))
-                   (skip-file ()
-                     (format t ">>>~a<<<~%" *failures*)))
-                 (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)
@@ -132,23 +173,23 @@
   (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 (native-namestring ,file))
+                                      :output *error-output*)))
+     (sb-ext:quit :unix-status (process-exit-code process))))
 
 (defun accept-test-file (file)
   (if *accept-files*