(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."))
(:method ((o t)) nil)
(:method ((o test-passed)) t))
+(define-condition check-failure (error)
+ ((reason :accessor reason :initarg :reason :initform "no reason given")
+ (test-case :accessor test-case :initarg :test-case)
+ (test-expr :accessor test-expr :initarg :test-expr))
+ (:documentation "Signaled when a check fails.")
+ (:report (lambda (c stream)
+ (format stream "The following check failed: ~S~%~A."
+ (test-expr c)
+ (reason c)))))
+
+(defmacro process-failure (&rest args)
+ `(progn
+ (with-simple-restart (ignore-failure "Continue the test run.")
+ (error 'check-failure ,@args))
+ (add-result 'test-failure ,@args)))
+
(defclass test-failure (test-result)
()
(:documentation "Class for unsuccessful checks."))
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))))
(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
+ default-reason-args "No reason supplied.")))
+ `(let ,bindings
+ (if ,effective-test
+ (add-result 'test-passed :test-expr ',test)
+ (process-failure :reason ,(if (null reason-args)
+ `(format nil ,@default-reason-args)
+ `(format nil ,@reason-args))
+ :test-expr ',test))))))
;;;; *** Other checks
does not inspect CONDITION to determine how to report the
failure."
`(if ,condition
- (add-result 'test-passed)
- (add-result 'test-failure :reason ,(if reason-args
- `(format nil ,@reason-args)
- `(format nil "~S did not return a true value" ',condition)))))
+ (add-result 'test-passed :test-expr ',condition)
+ (process-failure
+ :reason ,(if reason-args
+ `(format nil ,@reason-args)
+ `(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
not inspect CONDITION to determine what reason to give it case
of test failure"
`(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)))
+ (process-failure
+ :reason ,(if reason-args
+ `(format nil ,@reason-args)
+ `(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
(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))
+ (process-failure
+ :reason (format nil "Failed to signal a ~S" ',condition)
+ :test-expr ',condition)
(return-from ,block-name nil))))))
(defmacro finishes (&body body)
,@body
(setf ok t))
(if ok
- (add-result 'test-passed)
- (add-result 'test-failure
- :reason (format nil "Test didn't finish"))))))
+ (add-result 'test-passed :test-expr ',body)
+ (process-failure
+ :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)))))
+ `(process-failure
+ :test-expr ',message-args
+ ,@(when message-args
+ `(:reason (format nil ,@message-args)))))
;; Copyright (c) 2002-2003, Edward Marco Baringer
;; All rights reserved.