- `(if ,test
- (add-result 'test-passed :test-expr ',test)
- (add-result 'test-failure
- :reason ,(if (null reason-args)
- (list-match-case test
- ((not (?predicate ?expected ?actual))
- `(format nil "~S was ~S to ~S" ,?actual ',?predicate ,?expected))
- ((not (?satisfies ?value))
- `(format nil "~S satisfied ~S" ,?value ',?satisfies))
- ((?predicate ?expected ?actual)
- `(format nil "~S was not ~S to ~S" ,?actual ',?predicate ,?expected))
- ((?satisfies ?value)
- `(format nil "~S did not satisfy ~S" ,?value ',?satisfies))
- (t
- `(is-true ,test ,@reason-args)))
- `(format nil ,@reason-args))
- :test-expr ',test)))
+ (let (bindings effective-test default-reason-args)
+ (with-unique-names (e a v)
+ (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 evaluated to ~S, which is ~S to ~S (it should not be)"
+ `',?actual a `',?predicate e)))
+ ((not (?satisfies ?value))
+ (setf bindings (list (list v ?value))
+ effective-test `(not (,?satisfies ,v))
+ default-reason-args
+ (list "~S evaluated to ~S, which satisfies ~S (it should not)"
+ `',?value v `',?satisfies)))
+ ((?predicate ?expected ?actual)
+ (process-entry ?predicate ?expected ?actual)
+ (setf default-reason-args
+ (list "~S evaluated to ~S, which is not ~S to ~S."
+ `',?actual a `',?predicate e)))
+ ((?satisfies ?value)
+ (setf bindings (list (list v ?value))
+ effective-test `(,?satisfies ,v)
+ default-reason-args
+ (list "~S evaluated to ~S, which does not satisfy ~S"
+ `',?value v `',?satisfies)))
+ (?_
+ (setf bindings '()
+ effective-test test
+ default-reason-args (list "~S was NIL." `',test)))))
+ `(let ,bindings
+ (if ,effective-test
+ (add-result 'test-passed :test-expr ',test)
+ (process-failure :reason (format nil ,@(or reason-args default-reason-args))
+ :test-expr ',test))))))