X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Frun.lisp;h=c3038ef981a7eac4cef3b826b89b29546aa0c1fb;hb=8e2b8ea5671d45cd1b3efdd037af289200e6e0a8;hp=681939256b87776a2665e15baaa7693f3fadf7b2;hpb=325262d82eb9620b042e4c2bad38eb5dd47c03ef;p=fiveam.git

diff --git a/src/run.lisp b/src/run.lisp
index 6819392..c3038ef 100644
--- a/src/run.lisp
+++ b/src/run.lisp
@@ -149,7 +149,10 @@ run."))
                      (restart-case
                          (let ((*readtable* (copy-readtable))
                                (*package* (runtime-package test)))
-                           (funcall (test-lambda test)))
+                           (if (collect-profiling-info test)
+                               (setf (profiling-info test)
+                                     (arnesi:collect-timing (test-lambda test)))
+                               (funcall (test-lambda test))))
                        (retest ()
                          :report (lambda (stream)
                                    (format stream "~@<Rerun the test ~S~@:>" test))
@@ -177,18 +180,22 @@ run."))
 
 (defmethod %run ((suite test-suite))
   (let ((suite-results '()))
-    (unwind-protect
-         (bind-run-state ((result-list '()))
-           (unwind-protect
-                (loop for test being the hash-values of (tests suite)
-                      do (%run test))
-             (setf suite-results result-list))
-           (setf (status suite)
-                 (every (lambda (res)
-                          (typep res 'test-passed))
-                        suite-results)))
-      (with-run-state (result-list)
-        (setf result-list (nconc result-list suite-results))))))
+    (flet ((run-tests ()
+             (loop
+                for test being the hash-values of (tests suite)
+                do (%run test))))
+      (unwind-protect
+           (bind-run-state ((result-list '()))
+             (unwind-protect
+                  (if (collect-profiling-info suite)
+                      (setf (profiling-info suite) (collect-timing #'run-tests))
+                      (run-tests)))
+             (setf suite-results result-list
+                   (status suite) (every (lambda (res)
+                                           (typep res 'test-passed))
+                                         suite-results)))
+        (with-run-state (result-list)
+          (setf result-list (nconc result-list suite-results)))))))
 
 (defmethod %run ((test-name symbol))
   (when-bind test (get-test test-name)