[armedbear-cvs] r13312 - trunk/abcl/test/lisp/abcl

[mevenson at common-lisp.net]

Author: mevenson
Date: Wed Jun  8 08:28:11 2011
New Revision: 13312

Log:
Renam RUN-MATCHING to DO-MATCHING improving output.

Modified:
   trunk/abcl/test/lisp/abcl/package.lisp

Modified: trunk/abcl/test/lisp/abcl/package.lisp
==============================================================================
--- trunk/abcl/test/lisp/abcl/package.lisp	Tue Jun  7 22:23:25 2011	(r13311)
+++ trunk/abcl/test/lisp/abcl/package.lisp	Wed Jun  8 08:28:11 2011	(r13312)
@@ -2,8 +2,10 @@
   (:use #:cl #:abcl-rt)
   (:nicknames "ABCL-TEST-LISP" "ABCL-TEST")
   (:export 
-   #:run #:run-matching
-   #:do-test #:do-tests))
+   #:run 
+   #:do-matching #:run-matching
+   #:do-test 
+   #:do-tests))
 (in-package #:abcl.test.lisp)
 
 (defparameter *abcl-test-directory* 
@@ -18,21 +20,26 @@
   (let ((*default-pathname-defaults* *abcl-test-directory*))
     (do-tests)))
 
+;;; XXX move this into test-utilities.lisp?
 (defvar *last-run-matching* "url-pathname")
 
-;;; XXX move this into test-utilities.lisp?
-(defun run-matching (&optional (match *last-run-matching*))
+(defun do-matching (&optional (match *last-run-matching*))
   "Run all tests in suite whose symbol contains MATCH in a case-insensitive manner."
   (setf *last-run-matching* match)
   (let* ((matching (string-upcase match))
-         (tests
-          (remove-if-not
-           (lambda (name) (search matching name))
-           (mapcar (lambda (entry) 
-                     (symbol-name (abcl-rt::name entry))) 
-                   (rest abcl-rt::*entries*)))))
-    (dolist (test tests)
-      (do-test (intern test :abcl.test.lisp)))))
+         (count 0))
+    (mapcar (lambda (entry) 
+              (if (search matching (symbol-name (abcl-rt::name entry)))
+                  (setf (abcl-rt::pend entry) t
+                        count (1+ count))
+                  (setf (abcl-rt::pend entry) nil)))
+            (rest abcl-rt::*entries*))
+    (format t "Performing ~A tests matching '~A'.~%" count matching)
+    (abcl-rt::do-entries t)))
+
+;;; Deprecated 
+(setf (symbol-function 'run-matching) #'do-matching)
+