- (catch 'run-block
- (bind-run-state ((current-test test))
- (handler-bind ((error (lambda (e) (handle-unexpected-error test e))))
- (restart-case
- (let ((results (return-result-list (test-lambda test))))
- (setf (status test) (results-status results)
- result-list (nconc result-list results)))
- (retest ()
- :report (lambda (stream)
- (format stream "~@<Rerun the test ~S~@:>" test))
- (%run test))
- (ignore ()
- :report (lambda (stream)
- (format stream "~@<Signal a test failure and abort the test ~S.~@:>" test))
- (push (make-instance 'test-failure :test-case test
- :reason "Failure restart.")
- result-list))))))))
+ (bind-run-state ((current-test test))
+ (labels ((abort-test (e)
+ (add-result 'unexpected-test-failure
+ :test-expr nil
+ :test-case test
+ :reason (format nil "Unexpected Error: ~S~%~A." e e)
+ :condition e))
+ (run-it ()
+ (let ((result-list '()))
+ (declare (special result-list))
+ (handler-bind ((check-failure (lambda (e)
+ (declare (ignore e))
+ (unless *debug-on-failure*
+ (invoke-restart
+ (find-restart 'ignore-failure)))))
+ (error (lambda (e)
+ (unless (or *debug-on-error*
+ (typep e 'check-failure))
+ (abort-test e)
+ (return-from run-it result-list)))))
+ (restart-case
+ (let ((*readtable* (copy-readtable))
+ (*package* (runtime-package test)))
+ (if (collect-profiling-info test)
+ ;; Timing info doesn't get collected ATM, we need a portable library
+ ;; (setf (profiling-info test) (collect-timing (test-lambda test)))
+ (funcall (test-lambda test))
+ (funcall (test-lambda test))))
+ (retest ()
+ :report (lambda (stream)
+ (format stream "~@<Rerun the test ~S~@:>" test))
+ (return-from run-it (run-it)))
+ (ignore ()
+ :report (lambda (stream)
+ (format stream "~@<Signal an exceptional test failure and abort the test ~S.~@:>" test))
+ (abort-test (make-instance 'test-failure :test-case test
+ :reason "Failure restart."))))
+ result-list))))
+ (let ((results (run-it)))
+ (setf (status test) (results-status results)
+ result-list (nconc result-list results)))))))