From e8bbac684406062746dc0f31bf9bf1124120e0bf Mon Sep 17 00:00:00 2001 From: Attila Lendvai Date: Sun, 1 Oct 2006 19:47:55 +0200 Subject: [PATCH] Extended the 'is' macro to support multiple values (is (equal (decode-universal-time (universal-time (encode-local-time 1 2 3 4 5 6 2008))) (values 2 3 4 5 6 2008 3 * *))) the expressions' result is converted to list with mutliple-value-list and then the predicate is applied to the two lists. *'s are replaced/setf'd to nil. --- src/check.lisp | 72 ++++++++++++++++++++++++++++++++++++++------------------ 1 file changed, 49 insertions(+), 23 deletions(-) diff --git a/src/check.lisp b/src/check.lisp index 5244704..2e91193 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) -- 1.7.10.4