From: Juho S. <js...@us...> - 2006-01-26 23:16:27
|
Update of /cvsroot/sbcl/sbcl/tests In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv27210/tests Modified Files: run-tests.lisp Log Message: 0.9.9.3: Make the handling of errors outside WITH-TEST forms more robust. Index: run-tests.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/tests/run-tests.lisp,v retrieving revision 1.5 retrieving revision 1.6 diff -u -d -r1.5 -r1.6 --- run-tests.lisp 29 Sep 2005 21:41:29 -0000 1.5 +++ run-tests.lisp 26 Jan 2006 23:16:15 -0000 1.6 @@ -71,8 +71,10 @@ (dolist (file files) (when (accept-test-file file) (format t "// Running ~a~%" file) - (handler-bind ((error (make-error-handler file))) - (funcall test-fun file)))) + (restart-case + (handler-bind ((error (make-error-handler file))) + (funcall test-fun file)) + (skip-file ())))) (append-failures))) (defun impure-runner (files test-fun) @@ -85,8 +87,11 @@ (let ((pid (sb-posix:fork))) (cond ((= pid 0) (format t "// Running ~a~%" file) - (handler-bind ((error (make-error-handler file))) - (funcall test-fun 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 @@ -104,14 +109,14 @@ (defun make-error-handler (file) (lambda (condition) - (push (list :unhandled-error file) - *all-failures*) + (push (list :unhandled-error file) *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))))) + (sb-debug:backtrace))) + (invoke-restart 'skip-file))) (defun append-failures (&optional (failures *failures*)) (setf *all-failures* (append failures *all-failures*))) |