- (with-simple-restart (ignore-failure "Continue the test run.")
- (error 'check-failure ,@args))
- (add-result 'test-failure ,@args)))
+ (with-simple-restart (ignore-failure "Continue the test run.")
+ (error 'check-failure ,@args))
+ (add-result 'test-failure ,@args)))
(let ((result (apply #'make-instance result-type
(append make-instance-args (list :test-case current-test)))))
(etypecase result
(let ((result (apply #'make-instance result-type
(append make-instance-args (list :test-case current-test)))))
(etypecase result
string."
(assert (listp test)
(test)
"Argument to IS must be a list, not ~S" test)
(let (bindings effective-test default-reason-args)
string."
(assert (listp test)
(test)
"Argument to IS must be a list, not ~S" test)
(let (bindings effective-test default-reason-args)
(flet ((process-entry (predicate expected actual &optional negatedp)
;; make sure EXPECTED is holding the entry that starts with 'values
(when (and (consp actual)
(flet ((process-entry (predicate expected actual &optional negatedp)
;; make sure EXPECTED is holding the entry that starts with 'values
(when (and (consp actual)
(assert (not (and (consp expected)
(eq (car expected) 'values))) ()
"Both the expected and actual part is a values expression.")
(assert (not (and (consp expected)
(eq (car expected) 'values))) ()
"Both the expected and actual part is a values expression.")
- ,@setf-forms
- ,(if negatedp
- `(not (,predicate ,e ,a))
- `(,predicate ,e ,a)))))))
+ ,@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-match-case test
((not (?predicate ?expected ?actual))
(process-entry ?predicate ?expected ?actual t)
(setf default-reason-args
`',?actual a `',?predicate e)))
((not (?satisfies ?value))
(setf bindings (list (list v ?value))
effective-test `(not (,?satisfies ,v))
default-reason-args
`',?actual a `',?predicate e)))
((not (?satisfies ?value))
(setf bindings (list (list v ?value))
effective-test `(not (,?satisfies ,v))
default-reason-args
`',?value v `',?satisfies)))
((?predicate ?expected ?actual)
(process-entry ?predicate ?expected ?actual)
(setf default-reason-args
`',?value v `',?satisfies)))
((?predicate ?expected ?actual)
(process-entry ?predicate ?expected ?actual)
(setf default-reason-args
`',?actual a `',?predicate e)))
((?satisfies ?value)
(setf bindings (list (list v ?value))
effective-test `(,?satisfies ,v)
default-reason-args
`',?actual a `',?predicate e)))
((?satisfies ?value)
(setf bindings (list (list v ?value))
effective-test `(,?satisfies ,v)
default-reason-args
"The input is either a list of lists, or a list of pairs. Generates (is (,predicate ,expr ,value))
for each pair of elements or (is (,predicate ,expr ,value) ,@reason) for each list."
`(progn
"The input is either a list of lists, or a list of pairs. Generates (is (,predicate ,expr ,value))
for each pair of elements or (is (,predicate ,expr ,value) ,@reason) for each list."
`(progn
- ,@(if (every #'consp clauses)
- (loop for (expected actual . reason) in clauses
- collect `(is (,predicate ,expected ,actual) ,@reason))
- (progn
- (assert (evenp (list-length clauses)))
- (loop for (expr value) on clauses by #'cddr
- collect `(is (,predicate ,expr ,value)))))))
+ ,@(if (every #'consp clauses)
+ (loop for (expected actual . reason) in clauses
+ collect `(is (,predicate ,expected ,actual) ,@reason))
+ (progn
+ (assert (evenp (list-length clauses)))
+ (loop for (expr value) on clauses by #'cddr
+ collect `(is (,predicate ,expr ,value)))))))
(defmacro is-true (condition &rest reason-args)
"Like IS this check generates a pass if CONDITION returns true
(defmacro is-true (condition &rest reason-args)
"Like IS this check generates a pass if CONDITION returns true
- (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)))
+ (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
failure otherwise. Like IS-TRUE, and unlike IS, IS-FALSE does
not inspect CONDITION to determine what reason to give it case
of test failure"
(defmacro is-false (condition &rest reason-args)
"Generates a pass if CONDITION returns false, generates a
failure otherwise. Like IS-TRUE, and unlike IS, IS-FALSE does
not inspect CONDITION to determine what reason to give it case
of test failure"
(handler-bind ((,condition (lambda (c)
(declare (ignore c))
;; ok, body threw condition
(handler-bind ((,condition (lambda (c)
(declare (ignore c))
;; ok, body threw condition
(process-failure
:reason (format nil "Test didn't finish")
:test-expr ',body)))))
(defmacro pass (&rest message-args)
"Simply generate a PASS."
(process-failure
:reason (format nil "Test didn't finish")
:test-expr ',body)))))
(defmacro pass (&rest message-args)
"Simply generate a PASS."
:test-expr ',message-args
,@(when message-args
`(:reason (format nil ,@message-args)))))
:test-expr ',message-args
,@(when message-args
`(:reason (format nil ,@message-args)))))
`(:reason (format nil ,@message-args)))))
;; Copyright (c) 2002-2003, Edward Marco Baringer
`(:reason (format nil ,@message-args)))))
;; Copyright (c) 2002-2003, Edward Marco Baringer
;; Redistribution and use in source and binary forms, with or without
;; modification, are permitted provided that the following conditions are
;; met:
;; Redistribution and use in source and binary forms, with or without
;; modification, are permitted provided that the following conditions are
;; met:
;; - Redistributions of source code must retain the above copyright
;; notice, this list of conditions and the following disclaimer.
;; - Redistributions of source code must retain the above copyright
;; notice, this list of conditions and the following disclaimer.
;; - Redistributions in binary form must reproduce the above copyright
;; notice, this list of conditions and the following disclaimer in the
;; documentation and/or other materials provided with the distribution.
;; - Redistributions in binary form must reproduce the above copyright
;; notice, this list of conditions and the following disclaimer in the
;; documentation and/or other materials provided with the distribution.
;; - Neither the name of Edward Marco Baringer, nor BESE, nor the names
;; of its contributors may be used to endorse or promote products
;; derived from this software without specific prior written permission.
;; - Neither the name of Edward Marco Baringer, nor BESE, nor the names
;; of its contributors may be used to endorse or promote products
;; derived from this software without specific prior written permission.
;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR