0.9.5.13:

        Some test framework improvements, inspired by trying to remote-debug a
        test failure on #lisp:

        * Print a backtrace for unhandled errors (unless running with
          --break-on-failure).
        * Consistently use HANDLER-BIND instead of HANDLER-CASE, to
          get the backtrace/debugger prompt in the right dynamic
          state.
        * Name all WITH-TESTs. Most tests were already named, and the
          automatically assigned numbers aren't really optimal for
          locating tests.

diff --git a/tests/debug.impure.lisp b/tests/debug.impure.lisp
index a3f3fbb..12de035 100644 (file)
--- a/tests/debug.impure.lisp
+++ b/tests/debug.impure.lisp
@@ -139,7 +139,8 @@
          (declare (optimize (speed 1) (debug 2))) ; no tail call elimination
          (funcall fun)))
 
-  (with-test (:fails-on '(or :alpha))   ; bug 346
+  (with-test (:name (:undefined-function :bug-346)
+              :fails-on '(or :alpha))   ; bug 346
     (assert (verify-backtrace
              (lambda () (test #'optimized))
              (list *undefined-function-frame*
@@ -147,7 +148,8 @@
 
   ;; bug 353: This test fails at least most of the time for x86/linux
   ;; ca. 0.8.20.16. -- WHN
-  (with-test (:fails-on '(or (and :x86 :linux) :alpha))
+  (with-test (:name (:undefined-function :bug-356)
+              :fails-on '(or (and :x86 :linux) :alpha))
     (assert (verify-backtrace
              (lambda () (test #'not-optimized))
              (list *undefined-function-frame*
@@ -175,17 +177,20 @@
        (test (fun)
          (declare (optimize (speed 1) (debug 2))) ; no tail call elimination
          (funcall fun)))
-  (with-test (:fails-on '(or :alpha))   ; bug 346
+  (with-test (:name (:divide-by-zero :bug-346)
+              :fails-on '(or :alpha))   ; bug 346
     (assert (verify-backtrace (lambda () (test #'optimized))
                               (list '(/ 42 &rest)
                                     (list '(flet test) #'optimized)))))
-  (with-test (:fails-on '(or :alpha))   ; bug 346
+  (with-test (:name (:divide-by-zero :bug-356)
+              :fails-on '(or :alpha))   ; bug 356
     (assert (verify-backtrace (lambda () (test #'not-optimized))
                               (list '(/ 42 &rest)
                                     '((flet not-optimized))
                                     (list '(flet test) #'not-optimized))))))
 
-(with-test (:fails-on '(or (and :x86 :linux) :alpha))
+(with-test (:name (:throw :no-such-tag)
+            :fails-on '(or (and :x86 :linux) :alpha))
   (progn
     (defun throw-test ()
       (throw 'no-such-tag t))
@@ -226,7 +231,9 @@
 (defbt 5 (&optional (opt (oops)))
   (list opt))
 
-(with-test (:fails-on '(and :x86 :linux))
+;;; FIXME: This test really should be broken into smaller pieces
+(with-test (:name (:backtrace :misc)
+            :fails-on '(and :x86 :linux))
   (macrolet ((with-details (bool &body body)
                `(let ((sb-debug:*show-entry-point-details* ,bool))
                  ,@body)))
@@ -338,6 +345,9 @@
   (assert (search "returned OK" out)))
 
 ;;; bug 379
+;;; This is not a WITH-TEST :FAILS-ON PPC DARWIN since there are
+;;; suspicions that the breakpoint trace might corrupt the whole image
+;;; on that platform.
 #-(and ppc darwin)
 (let ((out (with-output-to-string (*trace-output*)
              (trace trace-this :encapsulate nil)

diff --git a/tests/float.pure.lisp b/tests/float.pure.lisp
index 0e2d57b..bf91142 100644 (file)
--- a/tests/float.pure.lisp
+++ b/tests/float.pure.lisp
@@ -92,7 +92,8 @@
 (assert (= 0.0 (scale-float 1.0 most-negative-fixnum)))
 (assert (= 0.0d0 (scale-float 1.0d0 (1- most-negative-fixnum))))
 
-(with-test (:fails-on '(or :ppc)) ;; bug 372
+(with-test (:name (:scale-float-overflow :bug-372)
+            :fails-on '(or :ppc)) ;; bug 372
   (progn
     (assert (raises-error? (scale-float 1.0 most-positive-fixnum)
                            floating-point-overflow))
@@ -117,7 +118,8 @@
    #c(1.0d0 2.0d0))
     'double-float))
 
-(with-test (:fails-on '(or :ppc))
+(with-test (:name (:addition-overflow :bug-372)
+            :fails-on '(or :ppc))
   (assert (typep (nth-value
                   1
                   (ignore-errors

diff --git a/tests/package-locks.impure.lisp b/tests/package-locks.impure.lisp
index f91a32f..77b2a9e 100644 (file)
--- a/tests/package-locks.impure.lisp
+++ b/tests/package-locks.impure.lisp
@@ -437,7 +437,8 @@
 
 ;;;; Program-errors from lexical violations
 ;;;; In addition to that, this is also testing for bug 387
-(with-test (:fails-on :sbcl)
+(with-test (:name :program-error
+            :fails-on :sbcl)
   (reset-test)
   (set-test-locks t)
   (dolist (pair *illegal-compile-time-forms-alist*)

diff --git a/tests/run-tests.lisp b/tests/run-tests.lisp
index c1d4f15..d01a33b 100644 (file)
--- a/tests/run-tests.lisp
+++ b/tests/run-tests.lisp
@@ -71,13 +71,8 @@
     (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)
@@ -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,6 +102,17 @@
                        (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*)))
 

diff --git a/tests/test-util.lisp b/tests/test-util.lisp
index 8ed24c8..e49c627 100644 (file)
--- a/tests/test-util.lisp
+++ b/tests/test-util.lisp
@@ -13,15 +13,18 @@
 (defvar *break-on-expected-failure* nil)
 
 (defmacro with-test ((&key fails-on name) &body body)
-  `(handler-case (progn
-                   (start-test)
-                   ,@body
-                   (when (expected-failure-p ,fails-on)
-                     (fail-test :unexpected-success ',name nil)))
-    (error (error)
-     (if (expected-failure-p ,fails-on)
-         (fail-test :expected-failure ',name error)
-         (fail-test :unexpected-failure ',name error)))))
+  (let ((block-name (gensym)))
+    `(block ,block-name
+       (handler-bind ((error (lambda (error)
+                               (if (expected-failure-p ,fails-on)
+                                   (fail-test :expected-failure ',name error)
+                                   (fail-test :unexpected-failure ',name error))
+                               (return-from ,block-name))))
+         (progn
+           (start-test)
+           ,@body
+           (when (expected-failure-p ,fails-on)
+             (fail-test :unexpected-success ',name nil)))))))
 
 (defun report-test-status ()
   (with-standard-io-syntax

diff --git a/version.lisp-expr b/version.lisp-expr
index f0954bb..1d4f1ce 100644 (file)
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -17,4 +17,4 @@
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"0.9.5.12"
+"0.9.5.13"