-(defun make-test-suite (name-or-fixture &optional description testspecs)
- "Returns a new test-suite based on a name and TESTSPECS or a fixture
-instance"
- (etypecase name-or-fixture
- (symbol
- (make-test-suite-for-fixture (make-instance name-or-fixture)))
- (string
- (let ((suite (make-instance 'test-suite :name name-or-fixture
- :description description)))
- (dolist (testspec testspecs)
- (add-test (apply #'make-test testspec) suite))
- suite))))
-
-
-(defmethod add-test ((test test-fixture) (suite test-suite))
- (setf (gethash (test-name test) (tests-hash suite)) test))
-
-(defmethod add-test ((test test-suite) (suite test-suite))
- (setf (gethash (test-suite-name test) (tests-hash suite)) test))
-
-(defmethod remove-test ((test test-fixture) (suite test-suite))
- (remhash (test-name test) (tests-hash suite)))
-
-(defmethod remove-test ((test test-suite) (suite test-suite))
- (remhash (test-suite-name test) (tests-hash suite)))
-
-(defmethod test-named ((name string) (suite test-suite))
- (gethash name (tests-hash suite)))
-
+(defmethod remove-test ((test test) (suite test-suite))
+ (setf (tests suite)
+ (delete-if #'(lambda (existing-tests-or-suite)
+ (cond ((typep existing-tests-or-suite 'test-suite)
+ (eq existing-tests-or-suite test))
+ ((typep existing-tests-or-suite 'test-case)
+ (eql (name existing-tests-or-suite)
+ (name test)))))
+ (tests suite))))