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