fixup! Break into the debugger upon error

Work the restart strategy out

src/testcase.lisp

@@ -319,89 +319,94 @@ instead of returning normally."))
 
 (defun instrument-assertion-1 (&key name form type argument-names argument-lambdas assertion-lambda)
   "Supervise the execution of ARGUMENTS-LAMBDA and ASSERTION-LAMBDA."
-  (flet ((evaluate-assertion-lambda (argument-values argument-conditions)
-	   (labels ((signal-or-break (condition)
-		      (if *testcase-break-into-the-debugger-on-errors*
-			  (restart-case (error condition)
-			    (assertion-retry ()
-			      :report "Retry to evaluate this assertion and its arguments."
-			      (error "Not implemented"))
-			    (testcase-continue ()
-			      :report
-			      (lambda (stream)
-				(let ((testcase-name
-					(testcase-name *current-testcase-outcome*)))
-				  (format stream "Register an error and continue testcase ~A." testcase-name)))
-			      (signal condition)))
-			  (signal condition)))
-		    (signal-argument-condition (condition)
-		      (signal-or-break
-		       (make-condition
-			'assertion-condition
-			:path *testcase-path*
-			:name name
-			:argument-names argument-names
-			:argument-values argument-values
-			:form form
-			:type type
-			:condition condition)))
-		    (signal-unexpected-condition (condition)
-		      (signal-or-break
-		       (make-condition
-			'assertion-condition
-			:path *testcase-path*
-			:name name
-			:argument-names argument-names
-			:argument-values argument-values
-			:form form
-			:type type
-			:condition condition)))
-		    (signal-failure (description)
-		      (signal-or-break
-		       (make-condition
-			'assertion-failure
-			:path *testcase-path*
-			:name name
-			:argument-names argument-names
-			:argument-values argument-values
-			:form form
-			:type type
-			:description description)))
-		    (signal-success ()
-		      (signal
-		       (make-condition
-			'assertion-success
-			:path *testcase-path*
-			:name name
-			:argument-names argument-names
-			:argument-values argument-values
-			:form form
-			:type type))))
-	     (when argument-conditions
-	       (signal-argument-condition (first argument-conditions))
-	       (return-from evaluate-assertion-lambda))
-	     (multiple-value-bind (success-p description)
-		 (handler-case (funcall assertion-lambda argument-values)
-	     	   (serious-condition (unexpected-condition)
-		     (signal-unexpected-condition unexpected-condition)
-		     (return-from evaluate-assertion-lambda)))
-	       (cond
-		 ((not success-p)
-		  (signal-failure description))
-		 (t
-		  (signal-success))))))
-	 (evaluate-argument-lambda (argument-lambda)
-	   (handler-case (values nil (funcall argument-lambda))
-	     (t (unexpected-condition)
-	       (values t unexpected-condition)))))
-    (loop :with argument-condition-p :and argument-value
-	  :for argument-lambda :in argument-lambdas
-	  :do (setf (values argument-condition-p argument-value)
-		    (evaluate-argument-lambda argument-lambda))
-	  :collect argument-value :into argument-values
-	  :when argument-condition-p
-	  :collect argument-value :into argument-conditions
-	  :finally (evaluate-assertion-lambda argument-values argument-conditions))))
+  (labels ((evaluate-assertion-lambda (argument-values argument-conditions)
+	     (labels ((signal-or-break (condition)
+			(if *testcase-break-into-the-debugger-on-errors*
+			    (restart-case (error condition)
+			      (assertion-retry ()
+				:report "Retry to evaluate this assertion and its arguments."
+				(throw :retry-assertion t))
+			      (testcase-continue ()
+				:report
+				(lambda (stream)
+				  (let ((testcase-name
+					  (testcase-name *current-testcase-outcome*)))
+				    (format stream "Register an error and continue testcase ~A." testcase-name)))
+				(signal condition)))
+			    (signal condition)))
+		      (signal-argument-condition (condition)
+			(signal-or-break
+			 (make-condition
+			  'assertion-condition
+			  :path *testcase-path*
+			  :name name
+			  :argument-names argument-names
+			  :argument-values argument-values
+			  :form form
+			  :type type
+			  :condition condition)))
+		      (signal-unexpected-condition (condition)
+			(signal-or-break
+			 (make-condition
+			  'assertion-condition
+			  :path *testcase-path*
+			  :name name
+			  :argument-names argument-names
+			  :argument-values argument-values
+			  :form form
+			  :type type
+			  :condition condition)))
+		      (signal-failure (description)
+			(signal-or-break
+			 (make-condition
+			  'assertion-failure
+			  :path *testcase-path*
+			  :name name
+			  :argument-names argument-names
+			  :argument-values argument-values
+			  :form form
+			  :type type
+			  :description description)))
+		      (signal-success ()
+			(signal
+			 (make-condition
+			  'assertion-success
+			  :path *testcase-path*
+			  :name name
+			  :argument-names argument-names
+			  :argument-values argument-values
+			  :form form
+			  :type type))))
+	       (when argument-conditions
+		 (signal-argument-condition (first argument-conditions))
+		 (return-from evaluate-assertion-lambda))
+	       (multiple-value-bind (success-p description)
+		   (handler-case (funcall assertion-lambda argument-values)
+	     	     (serious-condition (unexpected-condition)
+		       (signal-unexpected-condition unexpected-condition)
+		       (return-from evaluate-assertion-lambda)))
+		 (cond
+		   ((not success-p)
+		    (signal-failure description))
+		   (t
+		    (signal-success)))
+		 (values nil))))
+	   (evaluate-argument-lambda (argument-lambda)
+	     (handler-case (values nil (funcall argument-lambda))
+	       (t (unexpected-condition)
+		 (values t unexpected-condition))))
+	   (evaluate-assertion ()
+	     (loop :with argument-condition-p :and argument-value
+		   :for argument-lambda :in argument-lambdas
+		   :do (setf (values argument-condition-p argument-value)
+			     (evaluate-argument-lambda argument-lambda))
+		   :collect argument-value :into argument-values
+		   :when argument-condition-p
+		   :collect argument-value :into argument-conditions
+		   :finally (evaluate-assertion-lambda argument-values argument-conditions)))
+	   (evaluate-assertion-with-retry ()
+	     (loop :while (catch :retry-assertion (evaluate-assertion)))))
+    (evaluate-assertion-with-retry)))
 
 (defmacro instrument-assertion (form)
   "Instrument the execution of the assertion FORM and return ASSERTION evaluation details.
@@ -528,7 +533,7 @@ symbol of this function."
 			 (format stream "Retry testcase ~A." testcase-name)))
 		     :test
 		     (lambda (condition) (current-testcase-p condition))
-		     (error "Cannot retry testcase."))
+		     (throw :testcase-retry t))
 		   (testcase-step-up ()
 		     :report
 		     (lambda (stream)
@@ -537,8 +542,11 @@ symbol of this function."
 			 (format stream "Step up from testcase ~A." testcase-name)))
 		     :test
 		     (lambda (condition) (current-testcase-p condition))
-		     (return-from run-testcase-with-restarts)))))
-	     (install-signal-handlers-and-run-testcase-with-restarts ()
+		     (return-from run-testcase-with-restarts))))
+	       (values nil))
+	     (run-testcase-with-retry ()
+	       (loop :while (catch :testcase-retry (run-testcase-with-restarts))))
+	     (install-signal-handlers-and-run-testcase-with-retry ()
 	       (handler-bind
 		   ((assertion-success
 		      (lambda (condition)
@@ -576,14 +584,14 @@ symbol of this function."
 			    (incf current-success testcase-success)
 			    (incf current-failure testcase-failure)
 			    (incf current-condition testcase-condition))))))
-		 (run-testcase-with-restarts)
+		 (run-testcase-with-retry)
 		 (setf *last-testsuite-outcome* this-testcase-outcome)
 		 (describe *last-testsuite-outcome*)
 		 (terpri))))
       (if testsuite-p
-	  (install-signal-handlers-and-run-testcase-with-restarts)
+	  (install-signal-handlers-and-run-testcase-with-retry)
 	  (progn
-	    (run-testcase-with-restarts)
+	    (run-testcase-with-retry)
 	    (signal 'testcase-end :outcome this-testcase-outcome)))
       (values this-testcase-outcome))))