From: Juho Snellman Date: Thu, 29 Sep 2005 21:41:29 +0000 (+0000) Subject: 0.9.5.13: X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=ad0133544b3497c34e656ba2519cee5dfd70e828;p=sbcl.git 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 --- 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 --- 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 --- 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 --- 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 --- 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 --- 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"