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.