From b9bf5c99214c88c0c1b279f59489b6c11e0788d3 Mon Sep 17 00:00:00 2001
From: pfdietz <pfdietz@localhost>
Date: Sun, 26 Jun 2005 14:52:07 +0000
Subject: [PATCH] Refactor tests iterating over *universe*

---
 ansi-tests/ansi-aux.lsp                    | 18 +++++-
 ansi-tests/array-rank.lsp                  |  6 +-
 ansi-tests/arrayp.lsp                      |  7 +--
 ansi-tests/bit-vector-p.lsp                |  7 +--
 ansi-tests/coerce.lsp                      | 23 ++++---
 ansi-tests/compiled-function-p.lsp         |  6 +-
 ansi-tests/complement.lsp                  |  8 +--
 ansi-tests/complexp.lsp                    |  8 +--
 ansi-tests/cons-test-01.lsp                |  2 +-
 ansi-tests/consp.lsp                       | 10 ++-
 ansi-tests/constantp.lsp                   |  6 +-
 ansi-tests/copy-alist.lsp                  |  6 +-
 ansi-tests/eql.lsp                         |  4 +-
 ansi-tests/floatp.lsp                      |  8 +--
 ansi-tests/function.lsp                    |  9 +--
 ansi-tests/functionp.lsp                   | 13 ++--
 ansi-tests/hash-table-p.lsp                |  7 +--
 ansi-tests/identity.lsp                    |  5 +-
 ansi-tests/listp.lsp                       |  2 +-
 ansi-tests/macroexpand-1.lsp               | 52 +++++++---------
 ansi-tests/macroexpand.lsp                 | 47 ++++++--------
 ansi-tests/nil.lsp                         |  7 +--
 ansi-tests/numberp.lsp                     |  8 +--
 ansi-tests/packagep.lsp                    | 11 +---
 ansi-tests/pathnamep.lsp                   | 16 ++---
 ansi-tests/random-state-p.lsp              |  6 +-
 ansi-tests/rationalp.lsp                   |  4 +-
 ansi-tests/readtablep.lsp                  |  5 +-
 ansi-tests/realp.lsp                       |  8 +--
 ansi-tests/simple-bit-vector-p.lsp         |  7 +--
 ansi-tests/simple-string-p.lsp             |  7 +--
 ansi-tests/simple-vector-p.lsp             |  6 +-
 ansi-tests/slot-exists-p.lsp               |  4 +-
 ansi-tests/slot-value.lsp                  | 24 ++++----
 ansi-tests/streamp.lsp                     |  6 +-
 ansi-tests/string.lsp                      | 14 ++---
 ansi-tests/stringp.lsp                     |  7 +--
 ansi-tests/sxhash.lsp                      |  5 +-
 ansi-tests/symbolp.lsp                     |  8 +--
 ansi-tests/the.lsp                         | 71 +++++++++-------------
 ansi-tests/types-and-class.lsp             |  2 +-
 ansi-tests/upgraded-array-element-type.lsp |  4 +-
 42 files changed, 179 insertions(+), 305 deletions(-)

diff --git a/ansi-tests/ansi-aux.lsp b/ansi-tests/ansi-aux.lsp
index 11daeb72..7b0808e5 100644
--- a/ansi-tests/ansi-aux.lsp
+++ b/ansi-tests/ansi-aux.lsp
@@ -172,9 +172,10 @@ Results: ~A~%" expected-number form n results))))
     (assert (fboundp p))
     (setf p (symbol-function p)))
   (assert (typep p 'function))
-  
+
   (loop
-      for x in *universe* count
+      for x in *universe*
+      when
 	(block failed
 	  (let ((p1 (handler-case
 			(normally (funcall (the function p) x))
@@ -190,7 +191,18 @@ Results: ~A~%" expected-number form n results))))
 			(and (not p1) p2))
 		(format t "(FUNCALL ~S ~S) = ~S, (TYPEP ~S '~S) = ~S~%"
 			P x p1 x TYPE p2)
-		t)))))
+		t)))
+	collect x))
+
+;;; We have a common idiom where a guarded predicate should be
+;;; true everywhere
+
+(defun check-predicate (predicate &optional guard (universe *universe*))
+  "Return all elements of UNIVERSE for which the guard (if present) is false
+   and for which PREDICATE is false."
+  (remove-if #'(lambda (e) (or (and guard (funcall guard e))
+			       (funcall predicate e)))
+	     universe))
 
 (declaim (special *catch-error-type*))
 
diff --git a/ansi-tests/array-rank.lsp b/ansi-tests/array-rank.lsp
index 6126d5e3..e08dc1f7 100644
--- a/ansi-tests/array-rank.lsp
+++ b/ansi-tests/array-rank.lsp
@@ -12,10 +12,8 @@
   0)
 
 (deftest array-rank.2
-  (loop for e in *universe*
-	when (and (typep e 'vector)
-		  (not (eql (array-rank e) 1)))
-	collect e)
+  (check-predicate #'(lambda (e) (or (not (typep e 'vector))
+				     (eql (array-rank e) 1))))
   nil)
 
 (deftest array-rank.order.1
diff --git a/ansi-tests/arrayp.lsp b/ansi-tests/arrayp.lsp
index eadc342d..341626ad 100644
--- a/ansi-tests/arrayp.lsp
+++ b/ansi-tests/arrayp.lsp
@@ -28,12 +28,7 @@
   t)
 
 (deftest arrayp.6
-  (loop for e in *universe*
-	for a = (arrayp e)
-	for b = (typep e 'array)
-	when (or (and a (not b))
-		 (and b (not a)))
-	collect e)
+  (check-type-predicate #'arrayp 'array)
   nil)
 
 (deftest arrayp.order.1
diff --git a/ansi-tests/bit-vector-p.lsp b/ansi-tests/bit-vector-p.lsp
index 0100befe..8898adf3 100644
--- a/ansi-tests/bit-vector-p.lsp
+++ b/ansi-tests/bit-vector-p.lsp
@@ -47,11 +47,8 @@
   nil)
 
 (deftest bit-vector-p.12
-  (loop for e in *universe*
-	for p1 = (typep e 'bit-vector)
-	for p2 = (bit-vector-p e)
-	always (if p1 p2 (not p2)))
-  t)
+  (check-type-predicate #'bit-vector-p 'bit-vector)
+  nil)
 
 (deftest bit-vector-p.order.1
   (let ((i 0) x)
diff --git a/ansi-tests/coerce.lsp b/ansi-tests/coerce.lsp
index 126b5f66..ea4c7989 100644
--- a/ansi-tests/coerce.lsp
+++ b/ansi-tests/coerce.lsp
@@ -6,22 +6,21 @@
 (in-package :cl-test)
 
 (deftest coerce.1
-  (loop for x in *universe*
-	for type = (type-of x)
-	unless (and (consp type) (eqt (car type) 'function))
-	count (not (eql (coerce x type) x)))
-  0)
+  (check-predicate #'(lambda (x)
+		       (let ((type (type-of x)))
+			 (or (and (consp type) (eqt (car type) 'function))
+			     (eql (coerce x type) x)))))
+  nil)
 
 (deftest coerce.2
-  (loop for x in *universe*
-	count (not (eql (coerce x t) x)))
-  0)
+  (check-predicate #'(lambda (x) (eql (coerce x t) x)))
+  nil)
 
 (deftest coerce.3
-  (loop for x in *universe*
-	for class = (class-of x)
-	when (and class (not (eql (coerce x class) x)))
-	collect x)
+  (check-predicate
+   #'(lambda (x)
+       (let ((class (class-of x)))
+	 (eql (coerce x class) x))))
   nil)
 
 (deftest coerce.4
diff --git a/ansi-tests/compiled-function-p.lsp b/ansi-tests/compiled-function-p.lsp
index 27cd82a6..d98489fd 100644
--- a/ansi-tests/compiled-function-p.lsp
+++ b/ansi-tests/compiled-function-p.lsp
@@ -6,11 +6,7 @@
 (in-package :cl-test)
 
 (deftest compiled-function-p.1
-  (some #'(lambda (obj)
-	     (if (check-values (compiled-function-p obj))
-		 (not (typep obj 'compiled-function))
-	       (typep obj 'compiled-function)))
-	 *universe*)
+  (check-type-predicate #'compiled-function-p 'compiled-function)
   nil)
 
 (deftest compiled-function-p.2
diff --git a/ansi-tests/complement.lsp b/ansi-tests/complement.lsp
index ddcd6f0c..fefb1a3c 100644
--- a/ansi-tests/complement.lsp
+++ b/ansi-tests/complement.lsp
@@ -14,10 +14,10 @@
   nil)
 
 (deftest complement.3
-  (every #'(lambda (x) (eql (funcall (cl::complement #'not) x)
-			    (not (not x))))
-	 *universe*)
-  t)
+  (check-predicate
+   #'(lambda (x) (eql (funcall (cl::complement #'not) x)
+		      (not (not x)))))
+  nil)
 
 (deftest complement.4
   (let ((x '(#\b)))
diff --git a/ansi-tests/complexp.lsp b/ansi-tests/complexp.lsp
index 9c5dd24e..3bcd9618 100644
--- a/ansi-tests/complexp.lsp
+++ b/ansi-tests/complexp.lsp
@@ -18,11 +18,5 @@
   t)
 
 (deftest complexp.1
-  (loop for x in *universe*
-	for vals = (multiple-value-list (complexp x))
-	when (or (/= (length vals) 1)
-		 (if (typep x 'complex)
-		     (not (car vals))
-		   (car vals)))
-	collect (cons x vals))
+  (check-type-predicate #'complexp 'complex)
   nil)
diff --git a/ansi-tests/cons-test-01.lsp b/ansi-tests/cons-test-01.lsp
index 02c15a0e..18cd3f60 100644
--- a/ansi-tests/cons-test-01.lsp
+++ b/ansi-tests/cons-test-01.lsp
@@ -54,7 +54,7 @@
 ;;
 (deftest null-null-universe
   (check-type-predicate 'null 'null)
-  0)
+  nil)
 
 (defvar *cons-fns*
   (list 'cons 'consp 'atom 'rplaca 'rplacd
diff --git a/ansi-tests/consp.lsp b/ansi-tests/consp.lsp
index 13493d4c..c141d54d 100644
--- a/ansi-tests/consp.lsp
+++ b/ansi-tests/consp.lsp
@@ -35,16 +35,14 @@
 ;; For everything in *universe*, it is either an atom, or satisfies
 ;; consp, but not both
 (deftest consp-xor-atom-universe
-  (notnot-mv
-   (every #'(lambda (x) (or (and (consp x) (not (atom x)))
-			    (and (not (consp x)) (atom x))))
-	  *universe*))
-  t)
+  (check-predicate #'(lambda (x) (or (and (consp x) (not (atom x)))
+				     (and (not (consp x)) (atom x)))))
+  nil)
 
 ;; Everything in type cons satisfies consp, and vice versa
 (deftest consp-cons-universe
   (check-type-predicate 'consp 'cons)
-  0)
+  nil)
 
 (deftest consp.order.1
   (let ((i 0))
diff --git a/ansi-tests/constantp.lsp b/ansi-tests/constantp.lsp
index bf8dc086..a3801106 100644
--- a/ansi-tests/constantp.lsp
+++ b/ansi-tests/constantp.lsp
@@ -20,11 +20,7 @@
 ;;; Non-error tests
 
 (deftest constantp.1
-  (loop for e in *universe*
-	when (and (not (symbolp e))
-		   (not (consp e))
-		   (not (constantp e)))
-	collect e)
+  (check-predicate #'(lambda (e) (or (symbolp e) (consp e) (constantp e))))
   nil)
 
 (deftest constantp.2
diff --git a/ansi-tests/copy-alist.lsp b/ansi-tests/copy-alist.lsp
index b72d1574..c43bfc18 100644
--- a/ansi-tests/copy-alist.lsp
+++ b/ansi-tests/copy-alist.lsp
@@ -25,9 +25,9 @@
        t))
   t)
 
-(def-fold-test copy-alist.1 (copy-alist '((a . b) nil (c . d))))
-(def-fold-test copy-alist.2 (car (copy-alist '((a . b) nil (c . d)))))
-(def-fold-test copy-alist.3 (caddr (copy-alist '((a . b) nil (c . d)))))
+(def-fold-test copy-alist.2 (copy-alist '((a . b) nil (c . d))))
+(def-fold-test copy-alist.3 (car (copy-alist '((a . b) nil (c . d)))))
+(def-fold-test copy-alist.4 (caddr (copy-alist '((a . b) nil (c . d)))))
 
 ;;; Error tests
 
diff --git a/ansi-tests/eql.lsp b/ansi-tests/eql.lsp
index e85a6d9d..2f7f529f 100644
--- a/ansi-tests/eql.lsp
+++ b/ansi-tests/eql.lsp
@@ -10,8 +10,8 @@
 ;;; is true.
 
 (deftest eql.1
-  (loop for x in *universe* always (check-values (eql x x)))
-  t)
+  (check-predicate #'(lambda (x) (eql x x)))
+  nil)
 
 (deftest eql.2
   (eqlt 2 (1+ 1))
diff --git a/ansi-tests/floatp.lsp b/ansi-tests/floatp.lsp
index 0d4cf1c2..a5244014 100644
--- a/ansi-tests/floatp.lsp
+++ b/ansi-tests/floatp.lsp
@@ -26,12 +26,6 @@
   nil)
 
 (deftest floatp.3
-  (loop for x in *universe*
-	for vals = (multiple-value-list (floatp x))
-	unless (and (= (length vals) 1)
-		    (if (car vals)
-			(typep x 'float)
-		      (not (typep x 'float))))
-	collect x)
+  (check-type-predicate #'floatp 'float)
   nil)
 
diff --git a/ansi-tests/function.lsp b/ansi-tests/function.lsp
index 07ead156..0d1e01e4 100644
--- a/ansi-tests/function.lsp
+++ b/ansi-tests/function.lsp
@@ -65,12 +65,9 @@
 ;;; The next test demonstrates an incompatibility between CLtL1 and ANSI CL.
 ;;; In ANSI CL, symbols and cons can no longer also be of type FUNCTION.
 (deftest function.10
-  (loop for x in *universe*
-	when (and (or (numberp x) (characterp x)
-		      (symbolp x) (consp x)
-		      (typep x 'array))
-		  (typep x 'function))
-	collect x)
+  (check-predicate (typef '(not (and (or number character symbol
+					 cons array)
+				     function))))
   nil)
 
 (deftest function.11
diff --git a/ansi-tests/functionp.lsp b/ansi-tests/functionp.lsp
index af2723db..7b3b355a 100644
--- a/ansi-tests/functionp.lsp
+++ b/ansi-tests/functionp.lsp
@@ -63,12 +63,11 @@
 
 ;;; In ANSI CL, symbols and cons can no longer be functions
 (deftest functionp.10
-  (loop for x in *universe*
-	when (and (or (numberp x) (characterp x)
-		      (symbolp x) (consp x)
-		      (typep x 'array))
-		  (functionp x))
-	collect x)
+  (check-predicate #'(lambda (x)
+		       (not (and (or (numberp x) (characterp x)
+				     (symbolp x) (consp x)
+				     (typep x 'array))
+				 (functionp x)))))
   nil)
 
 (deftest functionp.11
@@ -79,6 +78,8 @@
   (flet ((%f () nil)) (not-mv (functionp #'%f)))
   nil)
 
+;;; TODO: Add check-type-predicate test?
+
 (deftest functionp.order.1
   (let ((i 0))
     (values
diff --git a/ansi-tests/hash-table-p.lsp b/ansi-tests/hash-table-p.lsp
index 713f8d6e..1fa211f0 100644
--- a/ansi-tests/hash-table-p.lsp
+++ b/ansi-tests/hash-table-p.lsp
@@ -14,11 +14,8 @@
   nil)
 
 (deftest hash-table-p.2
-  (loop for e in *universe*
-	for p = (typep e 'hash-table)
-	for q = (hash-table-p e)
-	always (if p q (not q)))
-  t)
+  (check-type-predicate #'hash-table-p 'hash-table)
+  nil)
 
 (deftest hash-table-p.3
   (let ((i 0))
diff --git a/ansi-tests/identity.lsp b/ansi-tests/identity.lsp
index a2d666c5..02fb021c 100644
--- a/ansi-tests/identity.lsp
+++ b/ansi-tests/identity.lsp
@@ -6,9 +6,8 @@
 (in-package :cl-test)
 
 (deftest identity.1
-  (loop for x in *universe*
-	always (eqlt x (check-values (identity x))))
-  t)
+  (check-predicate #'(lambda (x) (eqlt x (check-values (identity x)))))
+  nil)
 
 (deftest identity.2
   (let ((x (ash 1 100)))
diff --git a/ansi-tests/listp.lsp b/ansi-tests/listp.lsp
index bfc0810e..df099d13 100644
--- a/ansi-tests/listp.lsp
+++ b/ansi-tests/listp.lsp
@@ -33,7 +33,7 @@
 
 (deftest listp-universe
   (check-type-predicate 'listp 'list)
-  0)
+  nil)
 
 (deftest listp.order.1
   (let ((i 0))
diff --git a/ansi-tests/macroexpand-1.lsp b/ansi-tests/macroexpand-1.lsp
index 3cac79bb..cdc5a025 100644
--- a/ansi-tests/macroexpand-1.lsp
+++ b/ansi-tests/macroexpand-1.lsp
@@ -16,49 +16,39 @@
 ;;; Non-error tests
 
 (deftest macroexpand-1.1
-  (let (vals)
-    (loop for x in *universe*
-	  unless (or (symbolp x)
-		     (consp x)
-		     (progn
-		       (setq vals (multiple-value-list (macroexpand-1 x)))
-		       (and (= (length vals) 2)
-			    (eql (car vals) x)
-			    (null (cadr vals)))))
-	  collect (cons x vals)))
+  (check-predicate
+   #'(lambda (x)
+       (or (symbolp x) (consp x)
+	   (let ((vals (multiple-value-list (macroexpand-1 x))))
+	     (and (= (length vals) 2)
+		  (eql (car vals) x)
+		  (null (cadr vals)))))))
   nil)
 
 (deftest macroexpand-1.2
-  (let (vals)
-    (loop for x in *universe*
-	  unless (or (symbolp x)
-		     (consp x)
-		     (progn
-		       (setq vals (multiple-value-list (macroexpand-1 x nil)))
-		       (and (= (length vals) 2)
-			    (eql (car vals) x)
-			    (null (cadr vals)))))
-	  collect (cons x vals)))
+  (check-predicate
+   #'(lambda (x)
+       (or (symbolp x) (consp x)
+	   (let ((vals (multiple-value-list (macroexpand-1 x nil))))
+	     (and (= (length vals) 2)
+		  (eql (car vals) x)
+		  (null (cadr vals)))))))
   nil)
 
 (deftest macroexpand-1.3
   (macrolet
       ((%m (&environment env)
 	   `(quote
-	     ,(let (vals)
-		(loop for x in *universe*
-		      unless (or (symbolp x)
-				 (consp x)
-				 (progn
-				   (setq vals (multiple-value-list (macroexpand-1 x env)))
-				   (and (= (length vals) 2)
-					(eql (car vals) x)
-					(null (cadr vals)))))
-		      collect (cons x vals))))))
+	     ,(check-predicate
+	       #'(lambda (x)
+		   (or (symbolp x) (consp x)
+		       (let ((vals (multiple-value-list (macroexpand-1 x env))))
+			 (and (= (length vals) 2)
+			      (eql (car vals) x)
+			      (null (cadr vals))))))))))
     (%m))
   nil)
 
-
 (deftest macroexpand-1.4
   (macrolet ((%m () ''foo))
     (macrolet ((%m2 (&environment env)
diff --git a/ansi-tests/macroexpand.lsp b/ansi-tests/macroexpand.lsp
index c458f35d..3c70a344 100644
--- a/ansi-tests/macroexpand.lsp
+++ b/ansi-tests/macroexpand.lsp
@@ -16,49 +16,38 @@
 ;;; Non-error tests
 
 (deftest macroexpand.1
-  (let (vals)
-    (loop for x in *universe*
-	  unless (or (symbolp x)
-		     (consp x)
-		     (progn
-		       (setq vals (multiple-value-list (macroexpand x)))
-		       (and (= (length vals) 2)
-			    (eql (car vals) x)
-			    (null (cadr vals)))))
-	  collect (cons x vals)))
+  (check-predicate
+   #'(lambda (x)
+       (or (symbolp x) (consp x)
+	   (let ((vals (multiple-value-list (macroexpand x))))
+	     (and (= (length vals) 2)
+		  (eql (car vals) x)
+		  (null (cadr vals)))))))
   nil)
 
 (deftest macroexpand.2
-  (let (vals)
-    (loop for x in *universe*
-	  unless (or (symbolp x)
-		     (consp x)
-		     (progn
-		       (setq vals (multiple-value-list (macroexpand x nil)))
-		       (and (= (length vals) 2)
-			    (eql (car vals) x)
-			    (null (cadr vals)))))
-	  collect (cons x vals)))
+  (check-predicate
+   #'(lambda (x)
+       (or (symbolp x) (consp x)
+	   (let ((vals (multiple-value-list (macroexpand x nil))))
+	     (and (= (length vals) 2)
+		  (eql (car vals) x)
+		  (null (cadr vals)))))))
   nil)
 
 (deftest macroexpand.3
   (macrolet
       ((%m (&environment env)
 	   `(quote
-	     ,(let (vals)
-		(loop for x in *universe*
-		      unless (or (symbolp x)
-				 (consp x)
-				 (progn
-				   (setq vals (multiple-value-list (macroexpand x env)))
+	     ,(check-predicate
+	       #'(lambda (x) (or (symbolp x) (consp x)
+				 (let ((vals (multiple-value-list (macroexpand x env))))
 				   (and (= (length vals) 2)
 					(eql (car vals) x)
-					(null (cadr vals)))))
-		      collect (cons x vals))))))
+					(null (cadr vals))))))))))
     (%m))
   nil)
 
-
 (deftest macroexpand.4
   (macrolet ((%m () ''foo))
     (macrolet ((%m2 (&environment env)
diff --git a/ansi-tests/nil.lsp b/ansi-tests/nil.lsp
index b0f56741..1c369f88 100644
--- a/ansi-tests/nil.lsp
+++ b/ansi-tests/nil.lsp
@@ -6,15 +6,12 @@
 (in-package :cl-test)
 
 (deftest nil.1
-  (loop for x in *universe*
-	thereis (subtypep (type-of x) nil))
+  (check-predicate #'(lambda (x) (not (subtypep (type-of x) nil))))
   nil)
 
 
 (deftest nil.2
-  (loop for x in *universe*
-	unless (subtypep nil (type-of x))
-	collect (type-of x))
+  (check-predicate #'(lambda (x) (subtypep nil (type-of x))))
   nil)
 
 (deftest nil.3
diff --git a/ansi-tests/numberp.lsp b/ansi-tests/numberp.lsp
index 9ae321ba..08931f78 100644
--- a/ansi-tests/numberp.lsp
+++ b/ansi-tests/numberp.lsp
@@ -18,11 +18,5 @@
   t)
 
 (deftest numberp.1
-  (loop for x in *universe*
-	for vals = (multiple-value-list (numberp x))
-	for val = (car vals)
-	unless (and (= (length vals) 1)
-		    (if val (typep x 'number)
-		      (not (typep x 'number))))
-	collect (cons x vals))
+  (check-type-predicate #'numberp 'number)
   nil)
diff --git a/ansi-tests/packagep.lsp b/ansi-tests/packagep.lsp
index 77793506..94290b16 100644
--- a/ansi-tests/packagep.lsp
+++ b/ansi-tests/packagep.lsp
@@ -6,15 +6,8 @@
 (in-package :cl-test)
 
 (deftest packagep.1
-  (loop
-   for x in *universe* count
-   (unless (eqt (not (packagep x))
-		(not (typep x 'package)))
-	   (format t
-		   "(packagep ~S) = ~S, (typep x 'package) = ~S~%"
-		   x (packagep x) x (typep x 'package))
-	   t))
-  0)
+  (check-type-predicate #'packagep 'package)
+  nil)
 
 ;;; *package* is always a package
 
diff --git a/ansi-tests/pathnamep.lsp b/ansi-tests/pathnamep.lsp
index 9c6cf01f..e796847a 100644
--- a/ansi-tests/pathnamep.lsp
+++ b/ansi-tests/pathnamep.lsp
@@ -6,22 +6,16 @@
 (in-package :cl-test)
 
 (deftest pathnamep.1
-  (loop for x in *universe*
-	unless (if (pathnamep x) (typep x 'pathname)
-		 (not (typep x 'pathname)))
-	collect x)
+  (check-type-predicate #'pathnamep 'pathname)
   nil)
 
 (deftest pathnamep.2
-  (loop for x in *universe*
-	always (eql (length (multiple-value-list (pathnamep x))) 1))
-  t)
+  (check-predicate #'(lambda (x) (eql (length (multiple-value-list (pathnamep x))) 1)))
+  nil)
 
 (deftest pathnamep.3
-  (loop for x in *universe*
-	always (or (not (typep x 'logical-pathname))
-		   (pathnamep x)))
-  t)
+  (check-predicate (typef '(not logical-pathname)) #'pathnamep)
+  nil)
 
 (deftest pathnamep.error.1
   (signals-error (pathnamep) program-error)
diff --git a/ansi-tests/random-state-p.lsp b/ansi-tests/random-state-p.lsp
index 87d71fe6..0b78c838 100644
--- a/ansi-tests/random-state-p.lsp
+++ b/ansi-tests/random-state-p.lsp
@@ -14,11 +14,7 @@
   t)
 
 (deftest random-state-p.1
-  (loop for x in *universe*
-	when (if (typep x 'random-state)
-		 (not (random-state-p x))
-	       (random-state-p x))
-	collect x)
+  (check-type-predicate #'random-state-p 'random-state)
   nil)
 
 (deftest random-state-p.2
diff --git a/ansi-tests/rationalp.lsp b/ansi-tests/rationalp.lsp
index 64b581c2..796a0a86 100644
--- a/ansi-tests/rationalp.lsp
+++ b/ansi-tests/rationalp.lsp
@@ -34,9 +34,7 @@
   nil)
 
 (deftest rationalp.3
-  (loop for x in *universe*
-	when (if (typep x 'rational) (not (rationalp x)) (rationalp x))
-	collect x)
+  (check-type-predicate #'rationalp 'rational)
   nil)
 
 
diff --git a/ansi-tests/readtablep.lsp b/ansi-tests/readtablep.lsp
index 0acce958..a93dac86 100644
--- a/ansi-tests/readtablep.lsp
+++ b/ansi-tests/readtablep.lsp
@@ -33,10 +33,7 @@
   t)
 
 (deftest readtablep.2
-  (loop for x in *universe*
-	unless (if (typep x 'readtable) (readtablep x)
-		 (not (readtablep x)))
-	collect x)
+  (check-type-predicate #'readtablep 'readtable)
   nil)
 
 (deftest readtablep.3
diff --git a/ansi-tests/realp.lsp b/ansi-tests/realp.lsp
index 7d8ea970..8cbf4e9e 100644
--- a/ansi-tests/realp.lsp
+++ b/ansi-tests/realp.lsp
@@ -38,12 +38,8 @@
   nil)
 
 (deftest realp.6
-  (loop for x in *universe*
-	for vals = (multiple-value-list (realp x))
-	for p = (car vals)
-	when (or (/= (length vals) 1)
-		 (if (typep x 'real) (not p) p))
-	collect (cons x vals))
+  (check-type-predicate #'realp 'real)
   nil)
 
 
+
diff --git a/ansi-tests/simple-bit-vector-p.lsp b/ansi-tests/simple-bit-vector-p.lsp
index aaeff271..6c598dc9 100644
--- a/ansi-tests/simple-bit-vector-p.lsp
+++ b/ansi-tests/simple-bit-vector-p.lsp
@@ -47,11 +47,8 @@
   nil)
 
 (deftest simple-bit-vector-p.12
-  (loop for e in *universe*
-	for p1 = (typep e 'simple-bit-vector)
-	for p2 = (simple-bit-vector-p e)
-	always (if p1 p2 (not p2)))
-  t)
+  (check-type-predicate #'simple-bit-vector-p 'simple-bit-vector)
+  nil)
 
 (deftest simple-bit-vector-p.error.1
   (signals-error (simple-bit-vector-p) program-error)
diff --git a/ansi-tests/simple-string-p.lsp b/ansi-tests/simple-string-p.lsp
index 1959eef0..b64255b8 100644
--- a/ansi-tests/simple-string-p.lsp
+++ b/ansi-tests/simple-string-p.lsp
@@ -6,11 +6,8 @@
 (in-package :cl-test)
 
 (deftest simple-string-p.1
-  (loop for x in *universe*
-	always (if (typep x 'simple-string)
-		   (simple-string-p x)
-		 (not (simple-string-p x))))
-  t)
+  (check-type-predicate #'simple-string-p 'simple-string)
+  nil)
 
 (deftest simple-string-p.2
   (notnot-mv (simple-string-p "ancd"))
diff --git a/ansi-tests/simple-vector-p.lsp b/ansi-tests/simple-vector-p.lsp
index 18402b84..48a03d46 100644
--- a/ansi-tests/simple-vector-p.lsp
+++ b/ansi-tests/simple-vector-p.lsp
@@ -8,11 +8,7 @@
 ;;; More tests for this are in make-array.lsp
 
 (deftest simple-vector-p.1
-  (loop for e in *universe*
-	unless (if (typep e 'simple-vector)
-		   (simple-vector-p e)
-		 (not (simple-vector-p e)))
-	collect e)
+  (check-type-predicate #'simple-vector-p 'simple-vector)
   nil)
 
 (deftest simple-vector-p.2
diff --git a/ansi-tests/slot-exists-p.lsp b/ansi-tests/slot-exists-p.lsp
index b4c4ca0d..c81bf3cc 100644
--- a/ansi-tests/slot-exists-p.lsp
+++ b/ansi-tests/slot-exists-p.lsp
@@ -49,9 +49,7 @@
 
 (deftest slot-exists-p.8
   (let ((slot-name (gensym)))
-    (loop for x in *universe*
-	  when (slot-exists-p x slot-name)
-	  collect x))
+    (check-predicate #'(lambda (x) (not (slot-exists-p x slot-name)))))
   nil)
 
 ;;; With various types
diff --git a/ansi-tests/slot-value.lsp b/ansi-tests/slot-value.lsp
index 195dcfd8..0a66f5a3 100644
--- a/ansi-tests/slot-value.lsp
+++ b/ansi-tests/slot-value.lsp
@@ -131,21 +131,21 @@
 (deftest slot-value.error.5
   (let ((built-in-class (find-class 'built-in-class))
 	(slot-name (gensym)))
-    (loop for e in *universe*
-	  for class = (class-of e)
-	  when (and (eq (class-of class) built-in-class)
-		    (handler-case (progn (slot-value e slot-name) t)
-				  (error () nil)))
-	  collect e))
+    (check-predicate
+     #'(lambda (e)
+	 (let ((class (class-of e)))
+	   (or (not (eq (class-of class) built-in-class))
+	       (handler-case (progn (slot-value e slot-name) nil)
+			     (error () t)))))))
   nil)
 
 (deftest slot-value.error.6
   (let ((built-in-class (find-class 'built-in-class))
 	(slot-name (gensym)))
-    (loop for e in *universe*
-	  for class = (class-of e)
-	  when (and (eq (class-of class) built-in-class)
-		    (handler-case (setf (slot-value e slot-name) t)
-				  (error () nil)))
-	  collect e))
+    (check-predicate
+     #'(lambda (e)
+	 (let ((class (class-of e)))
+	   (or (not (eq (class-of class) built-in-class))
+	       (handler-case (setf (slot-value e slot-name) nil)
+				  (error () t)))))))
   nil)
diff --git a/ansi-tests/streamp.lsp b/ansi-tests/streamp.lsp
index d4927431..2ffd9658 100644
--- a/ansi-tests/streamp.lsp
+++ b/ansi-tests/streamp.lsp
@@ -15,11 +15,7 @@
   nil)
 
 (deftest streamp.2
-  (loop for x in *universe*
-	when (if (typep x 'stream)
-		 (not (streamp x))
-	       (streamp x))
-	collect x)
+  (check-type-predicate #'streamp 'stream)
   nil)
 
 (deftest streamp.3
diff --git a/ansi-tests/string.lsp b/ansi-tests/string.lsp
index b97ca2fc..70a97192 100644
--- a/ansi-tests/string.lsp
+++ b/ansi-tests/string.lsp
@@ -33,10 +33,11 @@
   t "FOO")
 
 (deftest string.7
-  (loop for x in *universe*
-	always (handler-case (stringp (string x))
-			     (type-error () :caught)))
-  t)
+  (check-predicate
+   #'(lambda (x)
+       (handler-case (stringp (string x))
+		     (type-error () :caught))))
+  nil)
 
 (deftest string.8 
   :notes (:nil-vectors-are-strings)
@@ -94,10 +95,7 @@
   nil)
 
 (deftest string.16
-  (loop for s in *universe*
-	when (and (stringp s)
-		  (not (eq s (string s))))
-	collect s)
+  (check-predicate #'(lambda (s) (or (not (stringp s)) (eq s (string s)))))
   nil)
 
 (deftest string.17
diff --git a/ansi-tests/stringp.lsp b/ansi-tests/stringp.lsp
index f16fca09..f892ea21 100644
--- a/ansi-tests/stringp.lsp
+++ b/ansi-tests/stringp.lsp
@@ -6,11 +6,8 @@
 (in-package :cl-test)
 
 (deftest stringp.1
-  (loop for x in *universe*
-	always (if (typep x 'string)
-		   (stringp x)
-		 (not (stringp x))))
-  t)
+  (check-type-predicate #'stringp 'string)
+  nil)
 
 (deftest stringp.2
   (notnot (stringp "abcd"))
diff --git a/ansi-tests/sxhash.lsp b/ansi-tests/sxhash.lsp
index 15ae2d3e..f5682f65 100644
--- a/ansi-tests/sxhash.lsp
+++ b/ansi-tests/sxhash.lsp
@@ -6,10 +6,7 @@
 (in-package :cl-test)
 
 (deftest sxhash.1
-  (loop for x in *universe*
-	for hash-code = (sxhash x)
-	unless (typep hash-code '(and unsigned-byte fixnum))
-	collect x)
+  (check-predicate #'(lambda (x) (typep (sxhash x) '(and unsigned-byte fixnum))))
   nil)
 
 (deftest sxhash.2
diff --git a/ansi-tests/symbolp.lsp b/ansi-tests/symbolp.lsp
index 9cd545fa..c56329c3 100644
--- a/ansi-tests/symbolp.lsp
+++ b/ansi-tests/symbolp.lsp
@@ -10,15 +10,11 @@
   t)
 
 (deftest symbolp.2
-  (loop for x in *symbols*
-	unless (symbolp x)
-	collect x)
+  (check-predicate #'symbolp nil *symbols*)
   nil)
 
 (deftest symbolp.3
-  (loop for x in (set-difference *universe* *symbols*)
-	when (symbolp x)
-	collect x)
+  (check-predicate (complement #'symbolp) #'(lambda (x) (member x *symbols*)))
   nil)
 
 ;;; Error cases
diff --git a/ansi-tests/the.lsp b/ansi-tests/the.lsp
index aa4ee9bd..a62de8b5 100644
--- a/ansi-tests/the.lsp
+++ b/ansi-tests/the.lsp
@@ -13,72 +13,59 @@
   a)
 
 (deftest the.3
-  (loop for e in *universe*
-	for x = (multiple-value-list (eval `(the (values) (quote ,e))))
-	unless (and x (not (cdr x)) (eql (car x) e))
-	collect e)
+  (check-predicate #'(lambda (e)
+		       (let ((x (multiple-value-list (eval `(the (values) (quote ,e))))))
+			 (and x (not (cdr x)) (eql (car x) e)))))
   nil)
 
 (deftest the.4
-  (loop for e in *universe*
-	for x = (multiple-value-list (eval `(the ,(type-of e) (quote ,e))))
-	unless (and x (not (cdr x)) (eql (car x) e))
-	collect e)
+  (check-predicate #'(lambda (e)
+		       (let ((x (multiple-value-list (eval `(the ,(type-of e) (quote ,e))))))
+			 (and x (not (cdr x)) (eql (car x) e)))))
   nil)
 
 (deftest the.5
-  (loop for e in *universe*
-	for x = (multiple-value-list (eval `(the (values ,(type-of e))
-					      (quote ,e))))
-	unless (and x (not (cdr x)) (eql (car x) e))
-	collect e)
+  (check-predicate #'(lambda (e)
+		       (let ((x (multiple-value-list (eval `(the (values ,(type-of e)) (quote ,e))))))
+			 (and x (not (cdr x)) (eql (car x) e)))))
   nil)
 
 (deftest the.6
-  (loop for e in *universe*
-	for x = (multiple-value-list (eval `(the (values ,(type-of e) t)
-					      (quote ,e))))
-	unless (and x (not (cdr x)) (eql (car x) e))
-	collect e)
+  (check-predicate #'(lambda (e)
+		       (let ((x (multiple-value-list (eval `(the (values ,(type-of e) t) (quote ,e))))))
+			 (and x (not (cdr x)) (eql (car x) e)))))
   nil)
 
 (deftest the.7
-  (loop for e in *universe*
-	for x = (multiple-value-list (eval `(the (values ,(type-of e))
-					      (values (quote ,e) :ignored))))
-	unless (and (eql (length x) 2)
-		    (eql (car x) e)
-		    (eql (cadr x) :ignored))
-	collect e)
+  (check-predicate
+   #'(lambda (e)
+       (let ((x (multiple-value-list (eval `(the (values ,(type-of e))
+					      (values (quote ,e) :ignored))))))
+	 (and (eql (length x) 2)
+	      (eql (car x) e)
+	      (eql (cadr x) :ignored)))))
   nil)
 
 (deftest the.8
-  (loop for e in *universe*
-	when (and (constantp e)
-		  (not (eql (eval `(the ,(type-of e) ,e)) e)))
-	collect e)
+  (check-predicate #'(lambda (e) (or (not (constantp e))
+				     (eql (eval `(the ,(type-of e) ,e)) e))))
   nil)
 
 (deftest the.9
-  (loop for e in *universe*
-	when (and (constantp e)
-		  (not (eql (eval `(the ,(class-of e) ,e)) e)))
-	collect e)
+  (check-predicate #'(lambda (e) (or (not (constantp e))
+				     (eql (eval `(the ,(class-of e) ,e)) e))))
   nil)
 
 (deftest the.10
-  (loop for e in *universe*
-	unless (eql (eval `(the ,(class-of e) ',e)) e)
-	collect e)
+  (check-predicate #'(lambda (e) (eql (eval `(the ,(class-of e) ',e)) e)))
   nil)
 
 (deftest the.11
-  (loop for e in *universe*
-	for type = (type-of e)
-	for x = (multiple-value-list (eval `(the ,type (the ,type
-							 (quote ,e)))))
-	unless (and x (not (cdr x)) (eql (car x) e))
-	collect e)
+  (check-predicate
+   #'(lambda (e)
+       (let* ((type (type-of e))
+	      (x (multiple-value-list (eval `(the ,type (the ,type (quote ,e)))))))
+	 (and x (not (cdr x)) (eql (car x) e)))))
   nil)
 
 (deftest the.12
diff --git a/ansi-tests/types-and-class.lsp b/ansi-tests/types-and-class.lsp
index 7fa8fc01..f217f6a1 100644
--- a/ansi-tests/types-and-class.lsp
+++ b/ansi-tests/types-and-class.lsp
@@ -21,7 +21,7 @@
 
 (deftest boolean-type.3
   (check-type-predicate 'is-t-or-nil 'boolean)
-  0)
+  nil)
 
 (deftest types.3
   (loop
diff --git a/ansi-tests/upgraded-array-element-type.lsp b/ansi-tests/upgraded-array-element-type.lsp
index efd9a148..2f8d42eb 100644
--- a/ansi-tests/upgraded-array-element-type.lsp
+++ b/ansi-tests/upgraded-array-element-type.lsp
@@ -110,9 +110,7 @@
 
 (deftest upgraded-array-element-type.nil.1
   (let ((uaet-nil (upgraded-array-element-type nil)))
-    (loop for e in *universe*
-	  when (typep e uaet-nil)
-	  collect e))
+    (check-predicate (typef `(not ,uaet-nil))))
   nil)
     
 ;;; Error tests
-- 
GitLab