From c9c5c68ee1fa066834633b342984484c91adbbfe Mon Sep 17 00:00:00 2001
From: Stelian Ionescu <sionescu@cddr.org>
Date: Sun, 29 Jul 2012 19:04:03 +0200
Subject: [PATCH] Add macro DEF-TEST with a different arglist than TEST and
 deprecate TEST

LP #1024777
---
 src/package.lisp |    1 +
 src/test.lisp    |  112 ++++++++++++++++++++++++++++++++++--------------------
 2 files changed, 71 insertions(+), 42 deletions(-)

diff --git a/src/package.lisp b/src/package.lisp
index ec84e56..4183f11 100644
--- a/src/package.lisp
+++ b/src/package.lisp
@@ -28,6 +28,7 @@
    #:in-suite*
    #:make-test
    #:test
+   #:def-test
    #:get-test
    #:rem-test
    #:test-names
diff --git a/src/test.lisp b/src/test.lisp
index 616b77e..9289c88 100644
--- a/src/test.lisp
+++ b/src/test.lisp
@@ -57,48 +57,76 @@ depending on another.
 FIXTURE specifies a fixture to wrap the body in.
 
 If PROFILE is T profiling information will be collected as well."
-  (let* ((tmp (gensym))
-         (suite-arg (getf (cdr (ensure-list name)) :suite tmp))
-         (suite-form (cond
-                       ((eq tmp suite-arg) '*suite*)
-                       (t                  `(get-test ',suite-arg)))))
-    (when (consp name)
-      (remf (cdr name) :suite))
-    (destructuring-bind (name &key depends-on (compile-at :run-time) fixture profile)
-        (ensure-list name)
-      (declare (type (member :run-time :definition-time) compile-at))
-      (let ((description (if (stringp (car body))
-                             (pop body)
-                             ""))
-            (effective-body (if fixture
-                                (destructuring-bind (name &rest args)
-                                    (ensure-list fixture)
-                                  `((with-fixture ,name ,args ,@body)))
-                                body))
-            (lambda-name
-              (format-symbol t "%~A-~A" '#:test name))
-            (inner-lambda-name
-              (format-symbol t "%~A-~A" '#:inner-test name)))
-        `(progn
-           (setf (get-test ',name)
-                 (make-instance 'test-case
-                                :name ',name
-                                :runtime-package (find-package ,(package-name *package*))
-                                :test-lambda
-                                (named-lambda ,lambda-name ()
-                                  ,@ (ecase compile-at
-                                       (:run-time `((funcall
-                                                     (let ((*package* (find-package ',(package-name *package*))))
-                                                       (compile ',inner-lambda-name
-                                                                '(lambda () ,@effective-body))))))
-                                       (:definition-time effective-body)))
-                                :description ,description
-                                :depends-on ',depends-on
-                                :collect-profiling-info ,profile))
-           (setf (gethash ',name (tests ,suite-form)) ',name)
-           (when *run-test-when-defined*
-             (run! ',name))
-           ',name)))))
+  (simple-style-warning "~A is OBSOLETE! Use ~A instead."
+                        'test 'def-test)
+  (destructuring-bind (name &rest args)
+      (ensure-list name)
+    `(def-test ,name (,@args) ,@body)))
+
+(defmacro def-test (name (&key depends-on (suite '*suite* suite-p) fixture
+                            (compile-at :run-time) profile)
+                    &body body)
+  "Create a test named NAME.
+
+NAME is the symbol which names the test.
+
+DEPENDS-ON is a list of the form:
+
+ (AND . test-names) - This test is run only if all of the tests
+ in TEST-NAMES have passed, otherwise a single test-skipped
+ result is generated.
+
+ (OR . test-names) - If any of TEST-NAMES has passed this test is
+ run, otherwise a test-skipped result is generated.
+
+ (NOT test-name) - This is test is run only if TEST-NAME failed.
+
+AND, OR and NOT can be combined to produce complex dependencies.
+
+If DEPENDS-ON is a symbol it is interpreted as `(AND
+,depends-on), this is accomadate the common case of one test
+depending on another.
+
+FIXTURE specifies a fixture to wrap the body in.
+
+If PROFILE is T profiling information will be collected as well."
+  (let ((suite-form
+          (if suite-p
+              `(get-test ',suite)
+              (or suite '*suite*))))
+    (check-type compile-at (member :run-time :definition-time))
+    (let ((description (if (stringp (car body))
+                           (pop body)
+                           ""))
+          (effective-body (if fixture
+                              (destructuring-bind (name &rest args)
+                                  (ensure-list fixture)
+                                `((with-fixture ,name ,args ,@body)))
+                              body))
+          (lambda-name
+            (format-symbol t "%~A-~A" '#:test name))
+          (inner-lambda-name
+            (format-symbol t "%~A-~A" '#:inner-test name)))
+      `(progn
+         (setf (get-test ',name)
+               (make-instance 'test-case
+                              :name ',name
+                              :runtime-package (find-package ,(package-name *package*))
+                              :test-lambda
+                              (named-lambda ,lambda-name ()
+                                ,@ (ecase compile-at
+                                     (:run-time `((funcall
+                                                   (let ((*package* (find-package ',(package-name *package*))))
+                                                     (compile ',inner-lambda-name
+                                                              '(lambda () ,@effective-body))))))
+                                     (:definition-time effective-body)))
+                              :description ,description
+                              :depends-on ',depends-on
+                              :collect-profiling-info ,profile))
+         (setf (gethash ',name (tests ,suite-form)) ',name)
+         (when *run-test-when-defined*
+           (run! ',name))
+         ',name))))
 
 (defvar *run-test-when-defined* nil
   "When non-NIL tests are run as soon as they are defined.")
-- 
1.7.10.4