- (let (bindings effective-test failure-init-args)
- (with-gensyms (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.")
- (rotatef expected actual))
- (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))))
- (values e a))))
- (list-match-case test
- ((not (?predicate ?expected ?actual))
- (multiple-value-bind (expected-value actual-value)
- (process-entry ?predicate ?expected ?actual t)
- (setf failure-init-args `('is-negated-binary-failure
- :predicate ',?predicate
- :expected-form ',?expected
- :expected-value ,expected-value
- :actual-form ',?actual
- :actual-value ,actual-value))))
- ((not (?satisfies ?value))
- (setf bindings (list (list v ?value))
- effective-test `(not (,?satisfies ,v))
- failure-init-args `('is-negated-unary-failure
- :predicate ',?satisfies
- :expected-form ',?value
- :expected-value ,v)))
- ((?predicate ?expected ?actual)
- (multiple-value-bind (expected-value actual-value)
- (process-entry ?predicate ?expected ?actual)
- (setf failure-init-args `('is-binary-failure
- :predicate ',?predicate
- :expected-form ',?expected
- :expected-value ,expected-value
- :actual-value ,actual-value
- :actual-form ',?actual))))
- ((?satisfies ?value)
- (setf bindings (list (list v ?value))
- effective-test `(,?satisfies ,v)
- failure-init-args `('is-unary-failure
- :predicate ',?satisfies
- :expected-form ',?value
- :expected-value ,v)))
- (?_
- (setf bindings '()
- effective-test test
- failure-init-args `('test-failure
- :reason (format nil "~2&~S~2% returned NIL." ',test)
- :test-expr ',test)))))
- (when reason-args
- (setf failure-init-args (list* :result `(format nil ,@reason-args) failure-init-args)))
- `(let ,bindings
- (if ,effective-test
- (add-result 'test-passed :test-expr ',test)
- (let ((failure (make-instance ,@failure-init-args)))
- (restartable-check-failure :reason (reason failure) :test-expr ',test)
- (add-result failure)))))))