diff --git a/ansi-tests/ansi-aux.lsp b/ansi-tests/ansi-aux.lsp index 11daeb72437cfade76052d724adf23d483e48739..7b0808e5ba9cd08ea04e3eed6abc6df61ebbac4e 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 6126d5e3618259a388597bf04ce9e7f5db40d929..e08dc1f7b502936cb765da1d58562d9eb31959b2 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 eadc342d2d83532363d0c19ae3a40e8bc986d134..341626add881068ece18ff6749171867be173e45 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 0100befe9b2813bbe34d9cf3c9b99ed45b2940ef..8898adf31a0db285e9e1f32c9b9684c7c42937f3 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 126b5f66b37a2afead441b08b96c165a16bfc08b..ea4c798915d4871dbe755b64e09ce38049050788 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 27cd82a6d43cf1e8676651c45def14ddcd87aaa9..d98489fdd9b89aa987920c709636c18460638044 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 ddcd6f0c00751807b8282257ce43c0d1952f0ee2..fefb1a3cf9c05f6ee426298c19bc7aa35c541df0 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 9c5dd24e9dd4af6c06d227a1ede728613f3a7d4b..3bcd96184456d3a5abf895077c36408ec806a011 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 02c15a0ed3a1aaa5544d67f76e97beb3648c517f..18cd3f60efcd1a3119a7cae80dad851b7db7f43b 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 13493d4c3dff6bebad7001674cb9090a65c743c5..c141d54dd29fbd3ee0081983a2a4fe44d7fd44e1 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 bf8dc08603f28be319ba85a5ae21bb3879865f19..a3801106339e85bd94a54408195a43dd0e24c53a 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 b72d1574f60f78fd3324b91b346f3d1c2507ab53..c43bfc1827df879bc969352aea9193ad2c8e7cbd 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 e85a6d9d9867141485487181e835de6165bbc7d2..2f7f529f9bc8bc6e628ee279e8740b9490061cb3 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 0d4cf1c2b9706a1b97fac9a5e4ed849e7150b96e..a52440142fe8d0f28817fb8d7c72ce01415951d3 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 07ead156b3226b153516a0145f2b8bc3e2a9763a..0d1e01e48c489ada4cad59f4cbacef6d055685b4 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 af2723db51e7c7ac3ada82b606852639b85244d4..7b3b355a7bb623dc0988a4e05817faea0e7fc4d4 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 713f8d6ed7ff864d8079742270597beec6487160..1fa211f0867340922b468d15f677fe6eb070aef4 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 a2d666c59d23cc0b3e605667929d89a7162ae814..02fb021c4178b9dad1e19a755cd22cd287edc1f7 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 bfc0810ef2645c4ecbc37f611e6f014ff5352fd4..df099d1319f39d8ddc61ce5ae01a3385fbb6801d 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 3cac79bb9f787cd7be364b02f850d849f49288f5..cdc5a025797c9f1aebe9d71da801383830e4db77 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 c458f35d3a99254748eb00afaf500e1336a0467c..3c70a344524dc46eec591ce6e213c947a308ca2e 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 b0f567416f5be4cdd2d17a11eb718fa533a6a5e2..1c369f88c50e8daa8301fb327d362e8b21921098 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 9ae321ba39ac74c94e717dc2900ac53d70802d09..08931f781bef24fbabae96f96f9be174a82c32dc 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 77793506634ce5c56e9509214d0162cce1c8d99f..94290b1628e684ee77125504bd6c5b4a263663b4 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 9c6cf01f5917b14de5b2602f86435b64184b90ac..e796847a0842e390a20011981de12a8f74f4d1c1 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 87d71fe6bba8c71a55bd654358344aa6759fbf15..0b78c8384218813d00f6ed83dae140c02a3ae1b2 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 64b581c23271ce69c51f567397f71873d107ca78..796a0a8669e43f8b7b8c8ef60e5c8a0317a91f55 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 0acce958ea18f9559cb129a45e4b14382642fe2f..a93dac86eb572ac66172bfb244ce5e7ceeb06902 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 7d8ea97088205389a59c63ab8297645b4f93a898..8cbf4e9e8c21de6ced74a6f53a4730687dfad8aa 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 aaeff271c59bf4c8d1e8ff525e2529d6e53444c0..6c598dc9af37bdd4ff74f5041b36e367508ce824 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 1959eef0b74db1b72aea5011bdf610315a061efc..b64255b8548a4dfc8b4c21f0cfbd397065d54abb 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 18402b84b82d7c88cc01754d7f2562c14eb51882..48a03d46370aa04d4bfdd319472cbcc67dae3ca1 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 b4c4ca0da30731bcbfd52464348174ef3ba3c2cf..c81bf3cc1d5d49eed7fcbb26fd5367e2772f6950 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 195dcfd89c601121dcad837a98543d980c2786d5..0a66f5a318ca2beedabe93fbf982cb4751b9ecd9 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 d4927431795afdc8adcad5b0e8d0b1ace1b3b209..2ffd9658a1ee5c21694bc2da2c7407226013d38b 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 b97ca2fc320ec9910cb0e3dd0015afebb446e5dc..70a971928b9d05e6d18dfad417732ec95f0240d5 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 f16fca0920e7b0cebbd605a56a2452bfe695c8bf..f892ea2100e2d1f1cd8854a869a8648ce581562b 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 15ae2d3e26617a2438bb9b6a24d24a978419a8cd..f5682f6540bf21936d6e1e5b3ca21cbac4777a95 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 9cd545fa548c53ef754310b636c74d1d023e1f2b..c56329c359c5a1db4a5cbb2c2f98966aafef6ddb 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 aa4ee9bdc14087606956241a1bb2dd70963b697f..a62de8b596944f336e644d3043856d68a093594d 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 7fa8fc01a0d5fe1316f5150dfdfeef8a8e5e3889..f217f6a146e1d3d9ae76af10905273ece154ecbd 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 efd9a148521f312ec9d4ed068c7495d62a745fc7..2f8d42eb030117a8ae2380776217f6b35cb0d2bc 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