From 32f965ce37b2c7bd835823b5078728d9b3369a65 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Micha=C3=ABl=20Le=20Barbier?=
 <michael.le-barbier@melusina.org>
Date: Fri, 12 Apr 2024 15:16:23 +0200
Subject: [PATCH] fixup! Break into the debugger upon error

Simplify the INSTRUMENT-ASSERTION-1 function.
---
 src/testcase.lisp | 129 +++++++++++++++++++++++-----------------------
 1 file changed, 65 insertions(+), 64 deletions(-)

diff --git a/src/testcase.lisp b/src/testcase.lisp
index 491ee27..8743df0 100644
--- a/src/testcase.lisp
+++ b/src/testcase.lisp
@@ -319,70 +319,71 @@ 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."
-  (labels ((evaluation-strategy-1 (argument-condition argument-values)
-	     (flet ((signal-argument-condition (condition)
-		      (signal
-		       '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
-		       '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
-		       'assertion-failure
-		       :path *testcase-path*
-		       :name name
-		       :argument-names argument-names
-		       :argument-values argument-values
-		       :form form
-		       :type type
-		       :description description))
-		    (signal-success ()
-		      (signal
-		       'assertion-success
-		       :path *testcase-path*
-		       :name name
-		       :argument-names argument-names
-		       :argument-values argument-values
-		       :form form
-		       :type type)))
-	       (when argument-condition
-		 (signal-argument-condition (first argument-condition))
-		 (return-from evaluation-strategy-1))
-	       (multiple-value-bind (success-p description)
-		   (handler-case (funcall assertion-lambda argument-values)
-	     	     (serious-condition (unexpected-condition)
-		       (signal-unexpected-condition unexpected-condition)
-		       (return-from evaluation-strategy-1)))
-		 (cond
-		   ((not success-p)
-		    (signal-failure description))
-		   (t
-		    (signal-success))))))
-	   (evaluation-strategy (argument-values)
-	     (evaluation-strategy-1
-	      (member-if (lambda (object) (typep object 'condition)) argument-values)
-	      argument-values))
-	   (supervise-evaluation-1 (argument-lambda)
-	     (handler-case (funcall argument-lambda)
-	       (t (unexpected-condition)
-		 unexpected-condition)))
-	   (supervise-evaluation (argument-lambdas)
-	     (evaluation-strategy (mapcar #'supervise-evaluation-1 argument-lambdas))))
-    (supervise-evaluation argument-lambdas)))
+  (flet ((evaluate-assertion-lambda (argument-values argument-conditions)
+	   (flet ((signal-argument-condition (condition)
+		    (signal
+		     '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
+		     '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
+		     'assertion-failure
+		     :path *testcase-path*
+		     :name name
+		     :argument-names argument-names
+		     :argument-values argument-values
+		     :form form
+		     :type type
+		     :description description))
+		  (signal-success ()
+		    (signal
+		     '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))))
 
 (defmacro instrument-assertion (form)
   "Instrument the execution of the assertion FORM and return ASSERTION evaluation details.