Skip to content
Snippets Groups Projects
Commit b9bf5c99 authored by pfdietz's avatar pfdietz
Browse files

Refactor tests iterating over *universe*

parent 52a2b767
No related branches found
No related tags found
No related merge requests found
Showing
with 85 additions and 122 deletions
......@@ -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)
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment