Update of /cvsroot/sbcl/sbcl/tests
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv24971/tests
Modified Files:
debug.impure.lisp float.pure.lisp run-tests.lisp
test-util.lisp package-locks.impure.lisp
Log Message:
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.
Index: debug.impure.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/tests/debug.impure.lisp,v
retrieving revision 1.22
retrieving revision 1.23
diff -u -d -r1.22 -r1.23
--- debug.impure.lisp 28 Aug 2005 02:26:45 -0000 1.22
+++ debug.impure.lisp 29 Sep 2005 21:41:29 -0000 1.23
@@ -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)
Index: float.pure.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/tests/float.pure.lisp,v
retrieving revision 1.22
retrieving revision 1.23
diff -u -d -r1.22 -r1.23
--- float.pure.lisp 28 Aug 2005 02:26:45 -0000 1.22
+++ float.pure.lisp 29 Sep 2005 21:41:29 -0000 1.23
@@ -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
Index: run-tests.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/tests/run-tests.lisp,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -d -r1.4 -r1.5
--- run-tests.lisp 31 Aug 2005 14:52:22 -0000 1.4
+++ run-tests.lisp 29 Sep 2005 21:41:29 -0000 1.5
@@ -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*)))
Index: test-util.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/tests/test-util.lisp,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -d -r1.2 -r1.3
--- test-util.lisp 31 Aug 2005 14:12:37 -0000 1.2
+++ test-util.lisp 29 Sep 2005 21:41:29 -0000 1.3
@@ -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
Index: package-locks.impure.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/tests/package-locks.impure.lisp,v
retrieving revision 1.8
retrieving revision 1.9
diff -u -d -r1.8 -r1.9
--- package-locks.impure.lisp 27 Aug 2005 09:43:20 -0000 1.8
+++ package-locks.impure.lisp 29 Sep 2005 21:41:29 -0000 1.9
@@ -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*)
|