X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=sidebyside;f=src%2Ftest.lisp;h=0bfac1f5c333aa98d8bc166ff192b5e390f8f810;hb=08b391a6ecfb01d739fabaedad8557c21971b197;hp=9289c888a31b00218f4d77a247ca21af34e2cf73;hpb=c9c5c68ee1fa066834633b342984484c91adbbfe;p=fiveam.git diff --git a/src/test.lisp b/src/test.lisp index 9289c88..0bfac1f 100644 --- a/src/test.lisp +++ b/src/test.lisp @@ -16,8 +16,19 @@ "Lookup table mapping test (and test suite) names to objects.") -(defun get-test (key &optional default) - (gethash key *test* default)) +(defun get-test (key &key default error) + "Finds the test named KEY. If KEY is a testable-object (a test case +or a test suite) then we just return KEY, otherwise we look for a test +named KEY in the *TEST* hash table." + (if (testable-object-p key) + key + (multiple-value-bind (value foundp) + (gethash key *test*) + (if foundp + value + (if error + (error "Unable to find test named ~S." key) + default))))) (defun (setf get-test) (value key) (setf (gethash key *test*) value)) @@ -30,41 +41,17 @@ collect test)) (defmacro test (name &body body) - "Create a test named NAME. If NAME is a list it must be of the -form: - - (name &key depends-on suite fixture compile-at profile) - -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." - (simple-style-warning "~A is OBSOLETE! Use ~A instead." - 'test 'def-test) + "Deprecated. See DEF-TEST." + (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) +(defmacro def-test (name (&key depends-on + (suite nil suite-p) + fixture + (compile-at :run-time) + profile) &body body) "Create a test named NAME. @@ -72,14 +59,14 @@ 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 +\(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 +\(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. +\(NOT test-name) - This is test is run only if TEST-NAME failed. AND, OR and NOT can be combined to produce complex dependencies. @@ -87,47 +74,78 @@ 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. +SUITE is the suite to put the test under. It defaults to +*SUITE* (which itself defaults to the default global suite). + 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))) +If PROFILE is T profiling information will be collected as well. + +COMPILE-AT can be either :RUN-TIME, in which case compilation of the +test code will be delayed until the test is run, or :DEFINITION-TIME, +in which case the code will be compiled when the DEF-TEST form itself +is compiled." + (check-type compile-at (member :run-time :definition-time)) + (multiple-value-bind (forms decls docstring) + (parse-body body :documentation t :whole name) + (let* ((description (or docstring "")) + (body-forms (append decls forms)) + (suite-form (if suite-p + (if suite + `(get-test ',suite) + nil) + '*suite*)) + (effective-body (let* ((test-fixture fixture) + (suite-fixture (if suite-p + (if suite + (fixture (get-test suite :error t)) + nil) + (if *suite* + (fixture *suite*) + nil))) + (effective-fixture (or test-fixture suite-fixture))) + (if effective-fixture + (destructuring-bind (name &rest args) + (ensure-list effective-fixture) + `((with-fixture ,name ,args ,@body-forms))) + body-forms)))) `(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) + (register-test :name ',name + :description ,description + :body ',effective-body + :suite ,suite-form + :depends-on ',depends-on + :compile-at ,compile-at + :profile ,profile) (when *run-test-when-defined* (run! ',name)) ',name)))) +(defun register-test (&key name description body suite depends-on compile-at profile) + (remove-from-suites name) + (let ((lambda-name + (format-symbol t "%~A-~A" '#:test name)) + (inner-lambda-name + (format-symbol t "%~A-~A" '#:inner-test name))) + (setf (get-test name) + (make-instance 'test-case + :name name + :runtime-package (find-package (package-name *package*)) + :test-lambda + (eval + `(named-lambda ,lambda-name () + ,@(ecase compile-at + (:run-time `((funcall + (let ((*package* (find-package ',(package-name *package*)))) + (compile ',inner-lambda-name + '(lambda () ,@body)))))) + (:definition-time body)))) + :description description + :depends-on depends-on + :collect-profiling-info profile)) + (when suite + (setf (gethash name (tests (get-test suite :error t))) name)))) + (defvar *run-test-when-defined* nil "When non-NIL tests are run as soon as they are defined.")