X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcheck.lisp;h=506d7ba5c54993b401b73dbab430a69fd2603164;hb=e7014feff8dbe5f64b13bb9741f1e716c527a395;hp=f5162f05aa066e4ae3573e6ce8d1deb784e614f5;hpb=1454981ac5f4f7ea8fe741a8125efbf0b09497ea;p=fiveam.git diff --git a/src/check.lisp b/src/check.lisp index f5162f0..506d7ba 100644 --- a/src/check.lisp +++ b/src/check.lisp @@ -33,7 +33,8 @@ (defclass test-result () ((reason :accessor reason :initarg :reason :initform "no reason given") - (test-case :accessor test-case :initarg :test-case)) + (test-case :accessor test-case :initarg :test-case) + (test-expr :accessor test-expr :initarg :test-expr)) (:documentation "All checking macros will generate an object of type TEST-RESULT.")) @@ -77,9 +78,11 @@ when appropiate.")) initialize args MAKE-INSTANCE-ARGS and adds the resulting object to the list of test results." (with-run-state (result-list current-test) - (let ((result (apply #'make-instance result-type (append make-instance-args (list :test-case current-test))))) + (let ((result (apply #'make-instance result-type + (append make-instance-args (list :test-case current-test))))) (etypecase result (test-passed (format *test-dribble* ".")) + (unexpected-test-failure (format *test-dribble* "X")) (test-failure (format *test-dribble* "f")) (test-skipped (format *test-dribble* "s"))) (push result result-list)))) @@ -107,22 +110,38 @@ Wrapping the TEST form in a NOT simply preducse a negated reason string." (assert (listp test) (test) "Argument to IS must be a list, not ~S" test) - `(if ,test - (add-result 'test-passed) - (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))))) + (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))) + (t + (setf bindings '() + effective-test test))) + `(let ,bindings + (if ,effective-test + (add-result 'test-passed :test-expr ',test) + (add-result 'test-failure + :reason ,(if (null reason-args) + `(format nil ,@default-reason-args) + `(format nil ,@reason-args)) + :test-expr ',test)))))) ;;;; *** Other checks @@ -138,10 +157,11 @@ Wrapping the TEST form in a NOT simply preducse a negated reason string." does not inspect CONDITION to determine how to report the failure." `(if ,condition - (add-result 'test-passed) + (add-result 'test-passed :test-expr ',condition) (add-result 'test-failure :reason ,(if reason-args `(format nil ,@reason-args) - `(format nil "~S did not return a true value" ',condition))))) + `(format nil "~S did not return a true value" ',condition)) + :test-expr ',condition))) (defmacro is-false (condition &rest reason-args) "Generates a pass if CONDITION returns false, generates a @@ -151,8 +171,9 @@ Wrapping the TEST form in a NOT simply preducse a negated reason string." `(if ,condition (add-result 'test-failure :reason ,(if reason-args `(format nil ,@reason-args) - `(format nil "~S returned a true value" ',condition))) - (add-result 'test-passed))) + `(format nil "~S returned a true value" ',condition)) + :test-expr ',condition) + (add-result 'test-passed :test-expr ',condition))) (defmacro signals (condition &body body) "Generates a pass if BODY signals a condition of type @@ -163,11 +184,14 @@ not evaluated." (handler-bind ((,condition (lambda (c) (declare (ignore c)) ;; ok, body threw condition - (add-result 'test-passed) + (add-result 'test-passed + :test-expr ',condition) (return-from ,block-name t)))) (block nil ,@body - (add-result 'test-failure :reason (format nil "Failed to signal a ~S" ',condition)) + (add-result 'test-failure + :reason (format nil "Failed to signal a ~S" ',condition) + :test-expr ',condition) (return-from ,block-name nil)))))) (defmacro finishes (&body body) @@ -180,19 +204,24 @@ fails." ,@body (setf ok t)) (if ok - (add-result 'test-passed) + (add-result 'test-passed :test-expr ',body) (add-result 'test-failure - :reason (format nil "Test didn't finish")))))) + :reason (format nil "Test didn't finish") + :test-expr ',body))))) (defmacro pass (&rest message-args) "Simply generate a PASS." - `(add-result 'test-passed ,@(when message-args - `(:reason (format nil ,@message-args))))) + `(add-result 'test-passed + :test-expr ',message-args + ,@(when message-args + `(:reason (format nil ,@message-args))))) (defmacro fail (&rest message-args) "Simply generate a FAIL." - `(add-result 'test-failure ,@(when message-args - `(:reason (format nil ,@message-args))))) + `(add-result 'test-failure + :test-expr ',message-args + ,@(when message-args + `(:reason (format nil ,@message-args))))) ;; Copyright (c) 2002-2003, Edward Marco Baringer ;; All rights reserved.