diff --git a/src/check.lisp b/src/check.lisp index 57e95e1..1a7dbfc 100644 --- a/src/check.lisp +++ b/src/check.lisp @@ -237,26 +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) + (let ((block-name (gensym)) + (signaled-p (gensym)) + (body-results (gensym)) + (tag (gensym))) + (destructuring-bind (condition &optional reason-control 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))))) + (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/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..b6037ed 100644 --- a/t/tests.lisp +++ b/t/tests.lisp @@ -42,12 +42,46 @@ (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) + (signals warning + (plusp 1))) + + +(def-test warns () + (signals warning + (warn "This is a warning.")) + (let ((foo 1)) + (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: 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.")) + (with-test-results (results no-warn) + (is (= 1 (length results))) + (is-true (test-failure-p (first results))))) (def-test pass () (pass))