alternative implementation of *debug-on-failure* (without spurious call frames)

diff --git a/src/check.lisp b/src/check.lisp
index e0eb723..b8ec760 100644 (file)
--- a/src/check.lisp
+++ b/src/check.lisp
@@ -46,6 +46,22 @@
   (:method ((o t)) nil)
   (:method ((o test-passed)) t))
 
+(define-condition check-failure (error)
+  ((reason :accessor reason :initarg :reason :initform "no reason given")
+   (test-case :accessor test-case :initarg :test-case)
+   (test-expr :accessor test-expr :initarg :test-expr))
+  (:documentation "Signaled when a check fails.")
+  (:report  (lambda (c stream)
+              (format stream "The following check failed: ~S~%~A."
+                      (test-expr c)
+                      (reason c)))))
+
+(defmacro process-failure (&rest args)
+  `(progn
+    (with-simple-restart (ignore-failure "Continue the test run.")
+      (error 'check-failure ,@args))
+    (add-result 'test-failure ,@args)))
+
 (defclass test-failure (test-result)
   ()
   (:documentation "Class for unsuccessful checks."))
@@ -138,11 +154,10 @@ Wrapping the TEST form in a NOT simply preducse a negated reason string."
       `(let ,bindings
          (if ,effective-test
              (add-result 'test-passed :test-expr ',test)
-             (add-result 'test-failure
-                         :reason ,(if (null reason-args)
-                                      `(format nil ,@default-reason-args)
-                                      `(format nil ,@reason-args))
-                         :test-expr ',test))))))
+             (process-failure :reason ,(if (null reason-args)
+                                           `(format nil ,@default-reason-args)
+                                           `(format nil ,@reason-args))
+                              :test-expr ',test))))))
 
 ;;;; *** Other checks
 
@@ -158,11 +173,12 @@ Wrapping the TEST form in a NOT simply preducse a negated reason string."
   does not inspect CONDITION to determine how to report the
   failure."
   `(if ,condition
-       (add-result 'test-passed :test-expr ',condition)
-       (add-result 'test-failure :reason ,(if reason-args
-                                             `(format nil ,@reason-args)
-                                             `(format nil "~S did not return a true value" ',condition))
-                   :test-expr ',condition)))
+    (add-result 'test-passed :test-expr ',condition)
+    (process-failure
+     :reason ,(if reason-args
+                  `(format nil ,@reason-args)
+                  `(format nil "~S did not return a true value" ',condition))
+     :test-expr ',condition)))
 
 (defmacro is-false (condition &rest reason-args)
   "Generates a pass if CONDITION returns false, generates a
@@ -170,11 +186,12 @@ Wrapping the TEST form in a NOT simply preducse a negated reason string."
   not inspect CONDITION to determine what reason to give it case
   of test failure"
   `(if ,condition
-       (add-result 'test-failure :reason ,(if reason-args
-                                             `(format nil ,@reason-args)
-                                             `(format nil "~S returned a true value" ',condition))
-                   :test-expr ',condition)
-       (add-result 'test-passed :test-expr ',condition)))
+    (process-failure
+     :reason ,(if reason-args
+                  `(format nil ,@reason-args)
+                  `(format nil "~S returned a true value" ',condition))
+     :test-expr ',condition)
+    (add-result 'test-passed :test-expr ',condition)))
 
 (defmacro signals (condition &body body)
   "Generates a pass if BODY signals a condition of type
@@ -190,9 +207,9 @@ not evaluated."
                                     (return-from ,block-name t))))
         (block nil
           ,@body
-          (add-result 'test-failure 
-                       :reason (format nil "Failed to signal a ~S" ',condition)
-                       :test-expr ',condition)
+           (process-failure
+            :reason (format nil "Failed to signal a ~S" ',condition)
+            :test-expr ',condition)
           (return-from ,block-name nil))))))
 
 (defmacro finishes (&body body)
@@ -206,9 +223,9 @@ fails."
           (setf ok t))
        (if ok
           (add-result 'test-passed :test-expr ',body)
-          (add-result 'test-failure
-                      :reason (format nil "Test didn't finish")
-                       :test-expr ',body)))))
+           (process-failure
+            :reason (format nil "Test didn't finish")
+            :test-expr ',body)))))
 
 (defmacro pass (&rest message-args)
   "Simply generate a PASS."
@@ -219,10 +236,10 @@ fails."
 
 (defmacro fail (&rest message-args)
   "Simply generate a FAIL."
-  `(add-result 'test-failure
-               :test-expr ',message-args
-               ,@(when message-args
-                       `(:reason (format nil ,@message-args)))))
+  `(process-failure
+    :test-expr ',message-args
+    ,@(when message-args
+            `(:reason (format nil ,@message-args)))))
 
 ;; Copyright (c) 2002-2003, Edward Marco Baringer
 ;; All rights reserved. 

diff --git a/src/packages.lisp b/src/packages.lisp
index 6536e28..53e30ae 100644 (file)
--- a/src/packages.lisp
+++ b/src/packages.lisp
@@ -55,6 +55,7 @@
            #:!!
            #:!!!
           #:*debug-on-error*
+           #:*debug-on-failure*
            #:*verbose-failures*))
 
 ;;;; You can use #+5am to put your test-defining code inline with your

diff --git a/src/run.lisp b/src/run.lisp
index 481f33a..3f03cfa 100644 (file)
--- a/src/run.lisp
+++ b/src/run.lisp
@@ -36,6 +36,9 @@
 (defparameter *debug-on-error* nil
   "T if we should drop into a debugger on error, NIL otherwise.")
 
+(defparameter *debug-on-failure* nil
+  "T if we should drop into a debugger on a failing check, NIL otherwise.")
+
 (defun import-testing-symbols (package-designator)
   (import '(5am::is 5am::is-true 5am::is-false 5am::signals 5am::finishes)
          package-designator))
@@ -133,8 +136,14 @@ run."))
                (run-it ()
                  (let ((result-list '()))
                    (declare (special result-list))
-                   (handler-bind ((error (lambda (e)
-                                           (unless *debug-on-error*
+                   (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