Added is-equal test

[fiveam.git] / src / check.lisp

diff --git a/src/check.lisp b/src/check.lisp
index 8641302..8d5f99f 100644 (file)
--- a/src/check.lisp
+++ b/src/check.lisp
@@ -147,10 +147,10 @@ Wrapping the TEST form in a NOT simply preducse a negated reason string."
          (setf bindings (list (list v ?value))
                effective-test `(,?satisfies ,v)
                default-reason-args (list "~S did not satisfy ~S" v `',?satisfies)))
-        (_?
+        (?_
          (setf bindings '()
                effective-test test
-               default-reason-args (list "No reason supplied."))))
+               default-reason-args (list "No reason supplied"))))
       `(let ,bindings
          (if ,effective-test
              (add-result 'test-passed :test-expr ',test)
@@ -165,6 +165,25 @@ Wrapping the TEST form in a NOT simply preducse a negated reason string."
      (format *test-dribble* "s")
      (add-result 'test-skipped :reason (format nil ,@reason))))
 
+(defmacro is-equal (&rest args)
+  "Generates (is (equal (multiple-value-list ,expr) (multiple-value-list ,value))) for each pair of elements.
+If the value is a (values a b * d *) form then the elements at * are not compared."
+  (with-unique-names (expr-result)
+    `(progn
+      ,@(loop for (expr value) on args by #'cddr
+              do (assert (and expr value))
+              if (and (consp value)
+                      (eq (car value) 'values))
+              collect `(let ((,expr-result (multiple-value-list ,expr)))
+                        ,@(loop for cell = (rest (copy-list value)) then (cdr cell)
+                                for i from 0
+                                while cell
+                                when (eq (car cell) '*)
+                                collect `(setf (elt ,expr-result ,i) nil)
+                                and do (setf (car cell) nil))
+                        (is (equal ,expr-result (multiple-value-list ,value))))
+              else collect `(is (equal ,expr ,value))))))
+
 (defmacro is-true (condition &rest reason-args)
   "Like IS this check generates a pass if CONDITION returns true
   and a failure if CONDITION returns false. Unlike IS this check
@@ -207,13 +226,13 @@ not evaluated."
                                                   :test-expr ',condition)
                                       (return-from ,block-name t))))
            (block nil
-             ,@body
-             (process-failure
-              :reason ,(if reason-control
-                           `(format nil ,reason-control ,@reason-args)
-                           `(format nil "Failed to signal a ~S" ',condition))
-              :test-expr ',condition)
-             (return-from ,block-name nil)))))))
+             ,@body))
+         (process-failure
+          :reason ,(if reason-control
+                       `(format nil ,reason-control ,@reason-args)
+                       `(format nil "Failed to signal a ~S" ',condition))
+          :test-expr ',condition)
+         (return-from ,block-name nil)))))
 
 (defmacro finishes (&body body)
   "Generates a pass if BODY executes to normal completion. In