Commit b9bf5c99 authored by pfdietz's avatar pfdietz

Refactor tests iterating over *universe*

parent 52a2b767
......@@ -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*))
......
......@@ -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
......
......@@ -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
......
......@@ -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)
......
......@@ -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
......
......@@ -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
......
......@@ -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)))
......
......@@ -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)
......@@ -54,7 +54,7 @@
;;
(deftest null-null-universe
(check-type-predicate 'null 'null)
0)
nil)
(defvar *cons-fns*
(list 'cons 'consp 'atom 'rplaca 'rplacd
......
......@@ -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))
......
......@@ -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
......
......@@ -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
......
......@@ -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))
......
......@@ -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)
......@@ -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
......
......@@ -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
......
......@@ -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))
......
......@@ -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)))
......
......@@ -33,7 +33,7 @@
(deftest listp-universe
(check-type-predicate 'listp 'list)
0)
nil)
(deftest listp.order.1
(let ((i 0))
......
......@@ -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)
......
......@@ -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)
......
......@@ -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
......
......@@ -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)
......@@ -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
......
......@@ -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)
......
......@@ -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
......
......@@ -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)
......@@ -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
......
......@@ -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)
......@@ -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)
......
......@@ -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"))
......
......@@ -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
......
......@@ -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
......
......@@ -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)
......@@ -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
......
......@@ -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
......
......@@ -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"))
......
......@@ -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
......
......@@ -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
......
......@@ -13,72 +13,59 @@
a)
(deftest the.3