X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcheck.lisp;h=b968755f85e9d323e0b89424bb15ba56848da8cc;hb=06aed0a0dd52f650afc11f1a247f6e4d2ac4b582;hp=8641302cfd6cee9088f9b3b7a0e31bbb833f4c25;hpb=085b9010ceb3b650a11e6311cea38157fec2acb5;p=fiveam.git

diff --git a/src/check.lisp b/src/check.lisp
index 8641302..b968755 100644
--- a/src/check.lisp
+++ b/src/check.lisp
@@ -128,29 +128,55 @@ Wrapping the TEST form in a NOT simply preducse a negated reason string."
           "Argument to IS must be a list, not ~S" test)
   (let (bindings effective-test default-reason-args)
     (with-unique-names (e a v)
-      (list-match-case test
-        ((not (?predicate ?expected ?actual))
-         (setf bindings (list (list e ?expected)
-                              (list a ?actual))
-               effective-test `(not (,?predicate ,e ,a))
-               default-reason-args (list "~S was ~S to ~S" a `',?predicate e)))
-        ((not (?satisfies ?value))
-         (setf bindings (list (list v ?value))
-               effective-test `(not (,?satisfies ,v))
-               default-reason-args (list  "~S satisfied ~S" v `',?satisfies)))
-        ((?predicate ?expected ?actual)
-         (setf bindings (list (list e ?expected)
-                              (list a ?actual))
-               effective-test `(,?predicate ,e ,a)
-               default-reason-args (list "~S was not ~S to ~S" a `',?predicate e)))
-        ((?satisfies ?value)
-         (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."))))
+      (flet ((process-entry (predicate expected actual &optional negatedp)
+               ;; make sure EXPECTED is holding the entry that starts with 'values
+               (when (and (consp actual)
+                          (eq (car actual) 'values))
+                 (assert (not (and (consp expected)
+                                   (eq (car expected) 'values))) ()
+                                   "Both the expected and actual part is a values expression.")
+                 (let ((tmp expected))
+                   (setf expected actual
+                         actual tmp)))
+               (let ((setf-forms))
+                 (if (and (consp expected)
+                          (eq (car expected) 'values))
+                     (progn
+                       (setf expected (copy-list expected))
+                       (setf setf-forms (loop for cell = (rest expected) then (cdr cell)
+                                              for i from 0
+                                              while cell
+                                              when (eq (car cell) '*)
+                                              collect `(setf (elt ,a ,i) nil)
+                                              and do (setf (car cell) nil)))
+                       (setf bindings (list (list e `(list ,@(rest expected)))
+                                            (list a `(multiple-value-list ,actual)))))
+                     (setf bindings (list (list e expected)
+                                          (list a actual))))
+                 (setf effective-test `(progn
+                                        ,@setf-forms
+                                        ,(if negatedp
+                                             `(not (,predicate ,e ,a))
+                                             `(,predicate ,e ,a)))))))
+        (list-match-case test
+          ((not (?predicate ?expected ?actual))
+           (process-entry ?predicate ?expected ?actual t)
+           (setf default-reason-args (list "~S was ~S to ~S" a `',?predicate e)))
+          ((not (?satisfies ?value))
+           (setf bindings (list (list v ?value))
+                 effective-test `(not (,?satisfies ,v))
+                 default-reason-args (list  "~S satisfied ~S" v `',?satisfies)))
+          ((?predicate ?expected ?actual)
+           (process-entry ?predicate ?expected ?actual)
+           (setf default-reason-args (list "~S was not ~S to ~S" a `',?predicate e)))
+          ((?satisfies ?value)
+           (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")))))
       `(let ,bindings
          (if ,effective-test
              (add-result 'test-passed :test-expr ',test)
@@ -165,6 +191,18 @@ 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-every (predicate &body clauses)
+  "The input is either a list of lists, or a list of pairs. Generates (is (,predicate ,expr ,value))
+   for each pair of elements or (is (,predicate ,expr ,value) ,@reason) for each list."
+  `(progn
+    ,@(if (every #'consp clauses)
+          (loop for (expected actual . reason) in clauses
+                collect `(is (,predicate ,expected ,actual) ,@reason))
+          (progn
+            (assert (evenp (list-length clauses)))
+            (loop for (expr value) on clauses by #'cddr
+                  collect `(is (,predicate ,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 +245,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