Add WARNS check.

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

src/package.lisp

@@ -46,6 +46,7 @@
    #:is-true
    #:is-false
    #:signals
+   #:warns
    #:finishes
    #:skip
    #:pass

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))