X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Frun-tests.lisp;h=d01a33b9b6f4f2ddb3fa5bfddb389b0e5ade567e;hb=0af996ffd49f08b71ba071c6d69dd2b465b4202f;hp=7845a6e5fe589c363fe5b3a412bdb0205b3f5ee0;hpb=175c318c892b0627b36fa3c4db66f59680242204;p=sbcl.git

diff --git a/tests/run-tests.lisp b/tests/run-tests.lisp
index 7845a6e..d01a33b 100644
--- a/tests/run-tests.lisp
+++ b/tests/run-tests.lisp
@@ -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"
@@ -57,7 +57,7 @@
                           (ecase (first fail)
                             (:expected-failure "Expected failure:")
                             (:unexpected-failure "Failure:")
-                            (:unexpected-success "Unexcepted success:"))
+                            (:unexpected-success "Unexpected success:"))
                           (enough-namestring (second fail))
                           (third fail))))))
         (t
@@ -71,15 +71,10 @@
     (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))))))
+        (handler-bind ((error (make-error-handler file)))
+          (funcall test-fun file))))
     (append-failures)))
-  
+
 (defun impure-runner (files test-fun)
   (format t "// Running impure tests (~a)~%" test-fun)
   (let ((*package* (find-package :cl-user)))
@@ -90,12 +85,8 @@
         (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))))
+                 (handler-bind ((error (make-error-handler file)))
+                   (funcall test-fun file))
                  (report-test-status)
                  (sb-ext:quit :unix-status 104))
                 (t
@@ -111,11 +102,25 @@
                        (push (list :invalid-exit-status file)
                              *all-failures*))))))))))
 
+(defun make-error-handler (file)
+  (lambda (condition)
+    (push (list :unhandled-error file)
+          *all-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)))))
+
 (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)
@@ -135,9 +140,9 @@
 
 (defun sh-test (file)
   ;; What? No SB-POSIX:EXECV?
-  (let ((process (sb-ext:run-program "/bin/sh" 
+  (let ((process (sb-ext:run-program "/bin/sh"
                                      (list (namestring file))
-                                     :output *error-output*))) 
+                                     :output *error-output*)))
     (sb-ext:quit :unix-status (process-exit-code process))))
 
 (defun accept-test-file (file)