From d6b750d12a113dcb8675295280d60192f6c454ac Mon Sep 17 00:00:00 2001 From: "Robert P. Goldman" Date: Wed, 22 Sep 2021 19:08:14 -0500 Subject: [PATCH 1/2] Add WARNS check. The SIGNALS check can correctly detect whether a block of code signals a warning, but it also aborts the code block's execution. That's appropriate for checking for an error, but not for a warning. This new check confirms that a warning of a particular class is raised, a la SIGNALS, but also allows the block of code in its scope to complete, which may be more natural for some cases. --- src/check.lisp | 29 +++++++++++++++++++++++++++++ src/package.lisp | 1 + t/tests.lisp | 23 +++++++++++++++++++++++ 3 files changed, 53 insertions(+) diff --git a/src/check.lisp b/src/check.lisp index 57e95e1..843d9a8 100644 --- a/src/check.lisp +++ b/src/check.lisp @@ -258,6 +258,35 @@ not evaluated." `("Failed to signal a ~S" ',condition))) (return-from ,block-name nil))))) +(defmacro warns (condition-spec &body body) + "Generates a pass if BODY signals a warning of type CONDITION-SPEC. BODY +is evaluated in a block named NIL, CONDITION-SPEC is not evaluated. + Is like SIGNALS, but does NOT abort the execution of BODY upon the signal +being raised." + (let ((block-name (gensym)) + (signaled-p (gensym))) + (destructuring-bind (condition &optional reason-control reason-args) + (ensure-list condition-spec) + `(let ((,signaled-p nil)) + (block ,block-name + (handler-bind ((,condition (lambda (c) + (unless (typep c 'warning) + (error "Cannot use FiveAM \"warns\" check for non-warning conditions.")) + ;; ok, body threw condition + (add-result 'test-passed + :test-expr ',condition) + (setf ,signaled-p t) + (muffle-warning c)))) + (block nil + ,@body)) + (when ,signaled-p (return-from ,block-name t)) + (process-failure + ',condition + ,@(if reason-control + `(,reason-control ,@reason-args) + `("Failed to signal a ~S" ',condition))) + (return-from ,block-name nil)))))) + (defmacro finishes (&body body) "Generates a pass if BODY executes to normal completion. In other words if body does signal, return-from or throw this test diff --git a/src/package.lisp b/src/package.lisp index 1cc8dcc..f1d4fb3 100644 --- a/src/package.lisp +++ b/src/package.lisp @@ -46,6 +46,7 @@ #:is-true #:is-false #:signals + #:warns #:finishes #:skip #:pass diff --git a/t/tests.lisp b/t/tests.lisp index b5136f5..b27567c 100644 --- a/t/tests.lisp +++ b/t/tests.lisp @@ -49,6 +49,29 @@ (signals error (error "an error")))) +(def-test no-warn (:suite test-suite :fixture null-fixture) + (warns warning + (plusp 1))) + + +(def-test warns () + (warns warning + (warn "This is a warning.")) + (let ((foo 1)) + (warns warning + (warn "this is a warning; it doesn't stop its code block from completing.") + (setf foo 2)) + (is (= 2 foo) "Foo did not get updated: WARNS check not working.")) + ;; showing how signals behaves differently + (let ((foo 1)) + (signals warning + (warn "this is a warning; in the SIGNALS context it aborts its code block.") + (setf foo 2)) + (is (= 1 foo) "Foo got updated: SIGNALS check not working as expected.")) + (with-test-results (results no-warn) + (is (= 1 (length results))) + (is-true (test-failure-p (first results))))) + (def-test pass () (pass)) From 1cb2463bd036e036a3d2ab88f822ef406fde5a7b Mon Sep 17 00:00:00 2001 From: "Robert P. Goldman" Date: Sat, 2 Sep 2023 12:33:27 -0500 Subject: [PATCH 2/2] Replace new WARNS macro with SIGNALS rewrite. SIGNALS now captures the return value of the signaling block, EXCEPT when the condition signaled is an error, in which case there may not be a value to return. Changes in tests.lisp illustrate the trade-offs. --- src/check.lisp | 75 +++++++++++++++++++------------------------------- t/tests.lisp | 33 ++++++++++++++-------- 2 files changed, 51 insertions(+), 57 deletions(-) diff --git a/src/check.lisp b/src/check.lisp index 843d9a8..1a7dbfc 100644 --- a/src/check.lisp +++ b/src/check.lisp @@ -237,55 +237,38 @@ REASON-ARGS is provided, is generated based on the form of TEST: (defmacro signals (condition-spec &body body) "Generates a pass if BODY signals a condition of type -CONDITION. BODY is evaluated in a block named NIL, CONDITION is +CONDITION-SPEC. BODY is evaluated in a block named NIL, CONDITION-SPEC is not evaluated." - (let ((block-name (gensym))) - (destructuring-bind (condition &optional reason-control &rest reason-args) - (ensure-list condition-spec) - `(block ,block-name - (handler-bind ((,condition (lambda (c) - (declare (ignore c)) - ;; ok, body threw condition - (add-result 'test-passed - :test-expr ',condition) - (return-from ,block-name t)))) - (block nil - ,@body)) - (process-failure - ',condition - ,@(if reason-control - `(,reason-control ,@reason-args) - `("Failed to signal a ~S" ',condition))) - (return-from ,block-name nil))))) - -(defmacro warns (condition-spec &body body) - "Generates a pass if BODY signals a warning of type CONDITION-SPEC. BODY -is evaluated in a block named NIL, CONDITION-SPEC is not evaluated. - Is like SIGNALS, but does NOT abort the execution of BODY upon the signal -being raised." (let ((block-name (gensym)) - (signaled-p (gensym))) - (destructuring-bind (condition &optional reason-control reason-args) + (signaled-p (gensym)) + (body-results (gensym)) + (tag (gensym))) + (destructuring-bind (condition &optional reason-control reason-args) (ensure-list condition-spec) - `(let ((,signaled-p nil)) - (block ,block-name - (handler-bind ((,condition (lambda (c) - (unless (typep c 'warning) - (error "Cannot use FiveAM \"warns\" check for non-warning conditions.")) - ;; ok, body threw condition - (add-result 'test-passed - :test-expr ',condition) - (setf ,signaled-p t) - (muffle-warning c)))) - (block nil - ,@body)) - (when ,signaled-p (return-from ,block-name t)) - (process-failure - ',condition - ,@(if reason-control - `(,reason-control ,@reason-args) - `("Failed to signal a ~S" ',condition))) - (return-from ,block-name nil)))))) + `(block ,block-name + (let ((,signaled-p nil) + ,body-results) + (setf ,body-results + (multiple-value-list + (handler-bind ((,condition (lambda (c) + ;; ok, body threw condition + (add-result 'test-passed + :test-expr ',condition) + (setf ,signaled-p t) + (when (typep c 'warning) + (muffle-warning c)) + (when (typep c 'error) + (throw ',tag nil))))) + (catch ',tag + (block nil + ,@body))))) + (unless ,signaled-p + (process-failure + ',condition + ,@(if reason-control + `(,reason-control ,@reason-args) + `("Failed to signal a ~S" ',condition)))) + (return-from ,block-name (values-list ,body-results))))))) (defmacro finishes (&body body) "Generates a pass if BODY executes to normal completion. In diff --git a/t/tests.lisp b/t/tests.lisp index b27567c..b6037ed 100644 --- a/t/tests.lisp +++ b/t/tests.lisp @@ -42,32 +42,43 @@ (def-test signals/finishes () (signals error (error "an error")) + ;; I don't know what the following is meant to test: when I try + ;; to run it, I get an error -- it seems like the `signals` form + ;; gives an error-generating FORM instead of an error class. + ;; It's possible that this was originally intended to show that + ;; the SIGNALS check would handle an error arising in its own + ;; expansion, but ... ¯\_(ツ)_/¯ [2023/09/02:rpg] + #+nil (signals (error "The form ~S is expected to signal an ~S" '(error "an error") 'error) (error "an error")) - (finishes + ;; SIGNALS returns NIL when the signal is a subtype of ERROR. + (is-false (signals error - (error "an error")))) + (error "an error"))) + (finishes + (signals error + (error "an error")))) (def-test no-warn (:suite test-suite :fixture null-fixture) - (warns warning + (signals warning (plusp 1))) (def-test warns () - (warns warning + (signals warning (warn "This is a warning.")) (let ((foo 1)) - (warns warning + (signals warning (warn "this is a warning; it doesn't stop its code block from completing.") (setf foo 2)) - (is (= 2 foo) "Foo did not get updated: WARNS check not working.")) + (is (= 2 foo) "Foo did not get updated: SIGNALS check not working.")) ;; showing how signals behaves differently - (let ((foo 1)) - (signals warning - (warn "this is a warning; in the SIGNALS context it aborts its code block.") - (setf foo 2)) - (is (= 1 foo) "Foo got updated: SIGNALS check not working as expected.")) + ;; (let ((foo 1)) + ;; (signals warning + ;; (warn "this is a warning; in the SIGNALS context it aborts its code block.") + ;; (setf foo 2)) + ;; (is (= 1 foo) "Foo got updated: SIGNALS check not working as expected.")) (with-test-results (results no-warn) (is (= 1 (length results))) (is-true (test-failure-p (first results)))))