Commit 5d7f0d72 authored by pfdietz's avatar pfdietz

Replaced EQ with EQT and SUBTYPEP with SUBTYPEP* in many places.

These are the same as the original except they are guaranteed to
return T when a true value is to be returned.

Added NOTNOT, which coerces true to T.

These changes are intended to make the test more fully standard compliant,
avoiding the unwarranted assumption that a function that returns true
is returning T (even though this is the case in many implementations.)

Added tests for NIL, T, NOT, and NULL.
parent 0061060b
......@@ -8,6 +8,12 @@
(declaim (optimize (safety 3)))
(defun eqt (x y)
"Function like EQ, but guaranteed to return T for true."
(if (eq x y) t nil))
(defun notnot (x) (not (not x)))
(defun make-int-list (n)
(loop for i from 0 to (1- n) collect i))
......@@ -178,8 +184,8 @@ the condition to go uncaught if it cannot be classified."
(defun nextdigit (c)
(cadr (member c '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9))))
(defun is-eq-p (x) #'(lambda (y) (eq x y)))
(defun is-not-eq-p (x) #'(lambda (y) (not (eq x y))))
(defun is-eq-p (x) #'(lambda (y) (eqt x y)))
(defun is-not-eq-p (x) #'(lambda (y) (not (eqt x y))))
(defun char-invertcase (c)
(if (upper-case-p c) (char-downcase c)
......
......@@ -36,4 +36,4 @@ STREAM-ERROR
END-OF-FILE
PRINT-NOT-READABLE
READER-ERROR)
collect (list tp (multiple-value-list (subtypep tp 'atom)))))
collect (list tp (multiple-value-list (subtypep* tp 'atom)))))
......@@ -27,7 +27,7 @@
(deftest catch.6
(let ((tag1 (1+ most-positive-fixnum))
(tag2 (1+ most-positive-fixnum)))
(if (eq tag1 tag2)
(if (eqt tag1 tag2)
'good
(catch tag1
(catch tag2 (throw tag1 'good))
......
......@@ -8,18 +8,18 @@
(defun char-type-error-check (fn)
(loop for x in *universe*
always (or (characterp x)
(eq (catch-type-error (funcall fn x)) 'type-error))))
(eqt (catch-type-error (funcall fn x)) 'type-error))))
(deftest character-class.1
(subtypep 'character t)
(subtypep* 'character t)
t t)
(deftest base-char.1
(subtypep 'base-char 'character)
(subtypep* 'base-char 'character)
t t)
(deftest base-char.2
(subtypep 'base-char t)
(subtypep* 'base-char t)
t t)
(deftest base-char.3
......@@ -27,15 +27,15 @@
t)
(deftest standard-char.1
(subtypep 'standard-char 'base-char)
(subtypep* 'standard-char 'base-char)
t t)
(deftest standard-char.2
(subtypep 'standard-char 'character)
(subtypep* 'standard-char 'character)
t t)
(deftest standard-char.3
(subtypep 'standard-char t)
(subtypep* 'standard-char t)
t t)
(deftest standard-char.4
......@@ -50,11 +50,11 @@
t)
(deftest extended-char.1
(subtypep 'extended-char 'character)
(subtypep* 'extended-char 'character)
t t)
(deftest extended-char.2
(subtypep 'extended-char t)
(subtypep* 'extended-char t)
t t)
(deftest extended-char.3
......
......@@ -12,8 +12,8 @@
(defun is-external-symbol-of (sym package)
(multiple-value-bind (sym2 status)
(find-symbol (symbol-name sym) package)
(and (eq sym sym2)
(eq status :external))))
(and (eqt sym sym2)
(eqt status :external))))
(defun test-if-not-in-cl-package (str)
(multiple-value-bind (sym status)
......@@ -25,7 +25,7 @@
;; Check if it has any properties whose indicators are
;; external in any of the standard packages or are accessible
;; in CL-USER
(and (eq status :external)
(and (eqt status :external)
(let ((plist (symbol-plist sym)))
(loop for e = plist then (cddr e)
while e
......@@ -33,7 +33,7 @@
when (and (symbolp indicator)
(or (is-external-symbol-of indicator "COMMON-LISP")
(is-external-symbol-of indicator "KEYWORD")
(eq indicator (find-symbol (symbol-name indicator)
(eqt indicator (find-symbol (symbol-name indicator)
"COMMON-LISP-USER"))))
collect indicator))))))
......@@ -1033,11 +1033,11 @@
(multiple-value-bind (sym status)
(find-symbol (symbol-name s) keyword-package)
(cond
((not (eq s sym)) (push (list s sym) results))
((eq status :internal)
((not (eqt s sym)) (push (list s sym) results))
((eqt status :internal)
(push (list s status) result))
((eq status :external)
(unless (and (eq (symbol-value s) s)
((eqt status :external)
(unless (and (eqt (symbol-value s) s)
(constantp s))
(push (list s sym 'not-constant) result)))))))
nil)
......@@ -1151,7 +1151,7 @@
"xyz")
(deftest make-symbol-6
(eq (make-symbol "A")
(eqt (make-symbol "A")
(make-symbol "A"))
nil)
......@@ -1264,8 +1264,8 @@
(every #'eq (symbol-plist y) (symbol-plist x))
(symbolp y)
(if (boundp x)
(eq (symbol-value x)
(symbol-value y))
(eqt (symbol-value x)
(symbol-value y))
(not (boundp y)))
(not (fboundp y))
(null (symbol-package y))
......@@ -1278,7 +1278,7 @@
t)
(deftest copy-symbol-4
(eq (copy-symbol 'a) (copy-symbol 'a))
(eqt (copy-symbol 'a) (copy-symbol 'a))
nil)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
......
......@@ -57,33 +57,33 @@
(deftest compile.3
(let ((x (list 'a 'b))
(y (list 'a 'b)))
(and (not (eq x y))
(funcall (compile nil `(lambda () (eq ',x ',y))))))
(and (not (eqt x y))
(funcall (compile nil `(lambda () (eqt ',x ',y))))))
nil)
(deftest compile.4
(let ((x (copy-seq "abc"))
(y (copy-seq "abc")))
(and (not (eq x y))
(funcall (compile nil `(lambda () (eq ,x ,y))))))
(and (not (eqt x y))
(funcall (compile nil `(lambda () (eqt ,x ,y))))))
nil)
(deftest compile.5
(let ((x (copy-seq "abc")))
(funcall (compile nil `(lambda () (eq ,x ,x)))))
(funcall (compile nil `(lambda () (eqt ,x ,x)))))
t)
(deftest compile.6
(let ((x (copy-seq "abc")))
(funcall (compile nil `(lambda () (eq ',x ',x)))))
(funcall (compile nil `(lambda () (eqt ',x ',x)))))
t)
(deftest compile.7
(let ((x (copy-seq "abc")))
(eq x (funcall (compile nil `(lambda () ,x)))))
(eqt x (funcall (compile nil `(lambda () ,x)))))
t)
(deftest compile.8
(let ((x (list 'a 'b)))
(eq x (funcall (compile nil `(lambda () ',x)))))
(eqt x (funcall (compile nil `(lambda () ',x)))))
t)
......@@ -41,7 +41,7 @@
(copy (concatenate 'vector orig)))
(values
copy
(eq copy orig)))
(eqt copy orig)))
#(a b c d e)
nil)
......
......@@ -138,7 +138,7 @@
(deftest cons-eq-equal
(let ((x (cons 'a 'b))
(y (cons 'a 'b)))
(and (not (eq x y))
(and (not (eqt x y))
(equal x y)
t))
t)
......@@ -328,20 +328,20 @@
(deftest rplaca-1
(let ((x (cons 'a 'b)))
(let ((y x))
(and (eq (rplaca x 'c) y)
(eq x y)
(eq (car x) 'c)
(eq (cdr x) 'b)
(and (eqt (rplaca x 'c) y)
(eqt x y)
(eqt (car x) 'c)
(eqt (cdr x) 'b)
t)))
t)
(deftest rplacd-1
(let ((x (cons 'a 'b)))
(let ((y x))
(and (eq (rplacd x 'd) y)
(eq x y)
(eq (car x) 'a)
(eq (cdr x) 'd)
(and (eqt (rplacd x 'd) y)
(eqt x y)
(eqt (car x) 'a)
(eqt (cdr x) 'd)
t)))
t)
......
......@@ -17,10 +17,10 @@
(cond
((consp x)
(and (consp y)
(not (eq x y))
(not (eqt x y))
(check-cons-copy (car x) (car y))
(check-cons-copy (cdr x) (cdr y))))
((eq x y) t)
((eqt x y) t)
(t nil)))
;; Try copy-tree on a tree containing elements of various kinds
......@@ -55,7 +55,7 @@
(apply #'sublis al a
`(,@(when test `(:test ,test))
,@(when test-not `(:test-not ,test-not))
,@(unless (eq key 'no-key) `(:key ,key))))))
,@(unless (eqt key 'no-key) `(:key ,key))))))
(and
(check-scaffold-copy a acopy)
(check-scaffold-copy al alcopy)
......@@ -131,7 +131,7 @@
(apply #'sublis (copy-tree al) (copy-tree a)
`(,@(when test `(:test ,test))
,@(when test-not `(:test-not ,test-not))
,@(unless (eq key 'no-key) `(:key ,key))))))
,@(unless (eqt key 'no-key) `(:key ,key))))))
as))
......@@ -215,7 +215,7 @@
(treecopy (make-scaffold-copy tree)))
(let ((result
(apply #'subst new old tree
`(,@(unless (eq key 'no-key) `(:key ,key))
`(,@(unless (eqt key 'no-key) `(:key ,key))
,@(when test `(:test ,test))
,@(when test-not `(:test-not ,test-not))))))
(and (check-scaffold-copy new newcopy)
......@@ -296,7 +296,7 @@
(treecopy (make-scaffold-copy tree)))
(let ((result
(apply #'subst-if new pred tree
(unless (eq key 'no-key) `(:key ,key)))))
(unless (eqt key 'no-key) `(:key ,key)))))
(and (check-scaffold-copy new newcopy)
(check-scaffold-copy pred predcopy)
(check-scaffold-copy tree treecopy)
......@@ -312,7 +312,7 @@
(treecopy (make-scaffold-copy tree)))
(let ((result
(apply #'subst-if-not new pred tree
(unless (eq key 'no-key) `(:key ,key)))))
(unless (eqt key 'no-key) `(:key ,key)))))
(and (check-scaffold-copy new newcopy)
(check-scaffold-copy pred predcopy)
(check-scaffold-copy tree treecopy)
......@@ -403,7 +403,7 @@
(setf old (copy-tree old))
(setf tree (copy-tree tree))
(apply #'nsubst new old tree
`(,@(unless (eq key 'no-key) `(:key ,key))
`(,@(unless (eqt key 'no-key) `(:key ,key))
,@(when test `(:test ,test))
,@(when test-not `(:test-not ,test-not)))))
......@@ -474,14 +474,14 @@
(setf new (copy-tree new))
(setf tree (copy-tree tree))
(apply #'nsubst-if new pred tree
(unless (eq key 'no-key) `(:key ,key))))
(unless (eqt key 'no-key) `(:key ,key))))
(defun check-nsubst-if-not (new pred tree &key (key 'no-key))
"Call nsubst-if-not new pred tree, with keyword arguments if present."
(setf new (copy-tree new))
(setf tree (copy-tree tree))
(apply #'nsubst-if-not new pred tree
(unless (eq key 'no-key) `(:key ,key))))
(unless (eqt key 'no-key) `(:key ,key))))
(deftest nsubst-if-1
(check-nsubst-if 'a #'consp '((100 1) (2 3) (4 3 2 1) (a b c)))
......
......@@ -15,10 +15,10 @@
(if
(consp x)
(and (consp y)
(not (eq x y))
(eq (car x) (car y))
(not (eqt x y))
(eqt (car x) (car y))
(check-copy-list-copy (cdr x) (cdr y)))
(and (eq x y) t)))
(and (eqt x y) t)))
(defun check-copy-list (x)
"Apply copy-list, checking that it properly copies,
......@@ -102,7 +102,7 @@
(loop
for x in (list 'a 1 1.0 #\w (make-array '(10))
'(a b . c) (symbol-package 'cons))
count (not (eq (catch-type-error (list-length x))
count (not (eqt (catch-type-error (list-length x))
'type-error)))
0)
......
......@@ -28,7 +28,7 @@
(let ((x (copy-tree '(a))))
(push x x)
(and
(eq (car x) (cdr x))
(eqt (car x) (cdr x))
x))
((a) a))
......@@ -52,7 +52,7 @@
(y x))
(push 'c x)
(and
(eq (cdr x) y)
(eqt (cdr x) y)
(pop x)))
c)
......@@ -63,7 +63,7 @@
(let ((x nil))
(let ((y (pushnew 'a x)))
(and
(eq x y)
(eqt x y)
(equal x '(a))
t)))
t)
......@@ -72,7 +72,7 @@
(let* ((x (copy-tree '(b c d a k f q)))
(y (pushnew 'a x)))
(and
(eq x y)
(eqt x y)
x))
(b c d a k f q))
......@@ -80,7 +80,7 @@
(let* ((x (copy-tree '(1 2 3 4 5 6 7 8)))
(y (pushnew 7 x)))
(and
(eq x y)
(eqt x y)
x))
(1 2 3 4 5 6 7 8))
......@@ -88,7 +88,7 @@
(let* ((x (copy-tree '((a b) 1 "and" c d e)))
(y (pushnew (copy-tree '(c d)) x
:test 'equal)))
(and (eq x y)
(and (eqt x y)
x))
((c d) (a b) 1 "and" c d e))
......@@ -97,7 +97,7 @@
(y (pushnew (copy-tree '(a b)) x
:test 'equal)))
(and
(eq x y)
(eqt x y)
x))
((a b) 1 "and" c d e))
......@@ -105,8 +105,8 @@
(let* ((x (copy-tree '((a b) (c e) (d f) (g h))))
(y (pushnew (copy-tree '(d i)) x :key #'car))
(z (pushnew (copy-tree '(z 10)) x :key #'car)))
(and (eq y (cdr z))
(eq z x)
(and (eqt y (cdr z))
(eqt z x)
x))
((z 10) (a b) (c e) (d f) (g h)))
......@@ -118,8 +118,8 @@
x
:key #'car :test #'string=)))
(and
(eq y (cdr x))
(eq x z)
(eqt y (cdr x))
(eqt x z)
x))
(("xyz" 10) ("abc" 1) ("def" 2) ("ghi" 3)))
......@@ -130,8 +130,8 @@
(z (pushnew (copy-tree '("xyz" 10)) x
:key #'car :test-not (complement #'string=))))
(and
(eq y (cdr x))
(eq x z)
(eqt y (cdr x))
(eqt x z)
x))
(("xyz" 10) ("abc" 1) ("def" 2) ("ghi" 3)))
......@@ -142,8 +142,8 @@
(z (pushnew (copy-tree '("xyz" 10)) x
:key 'car :test-not (complement #'string=))))
(and
(eq y (cdr x))
(eq x z)
(eqt y (cdr x))
(eqt x z)
x))
(("xyz" 10) ("abc" 1) ("def" 2) ("ghi" 3)))
......@@ -163,7 +163,7 @@
(y (pushnew (copy-tree '(a b)) x
:test 'equal :key nil)))
(and
(eq x y)
(eqt x y)
x))
(error (c) c))
((a b) 1 "and" c d e))
......
......@@ -44,7 +44,7 @@
(deftest rest-set-1
(let ((x (list 'a 'b 'c)))
(and
(eq (setf (rest x) 'd) 'd)
(eqt (setf (rest x) 'd) 'd)
x))
(a . d))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
......@@ -110,7 +110,7 @@
(loop
for e in x
and i from 0
count (not (eq e (nth i x)))))
count (not (eqt e (nth i x)))))
(deftest nth-1
(nth-1-body (loop for i from 1 to 2000 collect (* 4 i)))
......
......@@ -30,7 +30,7 @@
(let ((result (nconc x y)))
(and
(check-scaffold-copy y ycopy)
(eq (cdddr x) y)
(eqt (cdddr x) y)
result))))
(a b c d e f))
......@@ -38,7 +38,7 @@
(let ((x (list 'a 'b 'c)))
(nconc x x)
(and
(eq (cdddr x) x)
(eqt (cdddr x) x)
(null (list-length x))))
t)
......@@ -48,9 +48,9 @@
(z (list 'i 'j 'k)))
(let ((result (nconc x y z 'foo)))
(and
(eq (nthcdr 3 x) y)
(eq (nthcdr 5 y) z)
(eq (nthcdr 3 z) 'foo)
(eqt (nthcdr 3 x) y)
(eqt (nthcdr 5 y) z)
(eqt (nthcdr 3 z) 'foo)
result)))
(a b c d e f g h i j k . foo))
......@@ -119,7 +119,7 @@
(and
(check-scaffold-copy x xcopy)
(check-scaffold-copy y ycopy)
(eq (cdddr result) y)
(eqt (cdddr result) y)
result)))
(c b a d e f))
......
......@@ -63,9 +63,9 @@
(let ((y (cdr x))
(z (cddr x)))
(let ((result (nbutlast x 2)))
(and (eq x result)
(eq (cdr x) y)
(eq (cddr x) z)
(and (eqt x result)
(eqt (cdr x) y)
(eqt (cddr x) z)
result))))
(a b c))
......@@ -84,7 +84,7 @@
(deftest nbutlast-4
(let ((x (list* 'a 'b 'c 'd)))
(let ((result (catch-type-error (nbutlast x 1))))
(and (eq result x)
(and (eqt result x)
result)))
(a b))
......
......@@ -28,7 +28,7 @@
(zerop
(loop
for a on x and b on result count
(eq a b)))
(eqt a b)))
result)))
(error (c) c))
(a b c d e f))
......@@ -99,7 +99,7 @@
(loop
for c1 on x
for c2 on result
count (eq c1 c2)))))
count (eqt c1 c2)))))
0)
......@@ -141,7 +141,7 @@
(loop
for x in *universe*
count (and (not (listp x))
(not (eq 'type-error
(not (eqt 'type-error
(catch-type-error (ldiff x x)))))))
(deftest ldiff-12
......@@ -216,7 +216,7 @@
(loop
for x in *universe*
count (and (not (listp x))
(eq 'type-error
(eqt 'type-error
(catch-type-error (tailp x x))))))
(deftest tailp-7
......
......@@ -15,7 +15,7 @@
(xcopy (make-scaffold-copy x))
(result (member 'c x)))
(and
(eq result (cddr x))
(eqt result (cddr x))
(check-scaffold-copy x xcopy)))
t)
......@@ -24,7 +24,7 @@
(xcopy (make-scaffold-copy x))
(result (member 'e x)))
(and
(eq result (cddddr x))
(eqt result (cddddr x))
(check-scaffold-copy x xcopy)))
t)
......@@ -33,7 +33,7 @@
(xcopy (make-scaffold-copy x))
(result (member 4 x)))
(and
(eq result (cdddr x))
(eqt result (cdddr x))
(check-scaffold-copy x xcopy)))
t)
......@@ -42,7 +42,7 @@
(xcopy (make-scaffold-copy x))
(result (member 9 x :key #'1+)))
(and
(eq result (cdddr x))
(eqt result (cdddr x))
(check-scaffold-copy x xcopy)))
t)
......@@ -51,7 +51,7 @@
(xcopy (make-scaffold-copy x))
(result (member '(c d) x :test #'equal)))
(and
(eq result (cdr x))
(eqt result (cdr x))
(check-scaffold-copy x xcopy)))
t)
......@@ -60,7 +60,7 @@
(xcopy (make-scaffold-copy x))
(result (member 'c x :key #'car)))
(and
(eq result (cdr x))
(eqt result (cdr x))
(check-scaffold-copy x xcopy)))
t)
......@@ -69,7 +69,7 @@
(xcopy (make-scaffold-copy x))
(result (member 'c x :key #'car :test #'eq)))
(and
(eq result (cdr x))
(eqt result (cdr x))
(check-scaffold-copy x xcopy)))
t)
......@@ -78,7 +78,7 @@
(xcopy (make-scaffold-copy x))
(result (member 'c x :key #'car :test-not (complement #'eq))))
(and
(eq result (cdr x))
(eqt result (cdr x))
(check-scaffold-copy x xcopy)))
t)
......@@ -87,7 +87,7 @@
(xcopy (make-scaffold-copy x))
(result (member 'c x :key #'car :test #'eql)))
(and
(eq result (cdr x))
(eqt result (cdr x))
(check-scaffold-copy x xcopy)))
t)
......@@ -96,7 +96,7 @@
(xcopy (make-scaffold-copy x))
(result (member (list 'd) x :key #'cdr :test #'equal)))
(and
(eq result (cdr x))
(eqt result (cdr x))
(check-scaffold-copy x xcopy)))
t)
......
......@@ -15,7 +15,7 @@
nil)
(deftest member-if-2
(member-if #'(lambda (x) (eq x 'a)) '(1 2 a 3 4))
(member-if #'(lambda (x) (eqt x 'a)) '(1 2 a 3 4))
(a 3 4))
(deftest member-if-3
......@@ -32,7 +32,7 @@
(not (every
#'(lambda (x)
(let ((result (catch-type-error (member-if #'listp x))))
(or (eq result 'type-error)
(or (eqt result 'type-error)
(progn
(format t "~%On ~S: returned ~%~S" x result)
nil))))
......@@ -48,7 +48,7 @@
nil)
(deftest member-if-not-2
(member-if-not #'(lambda (x) (eq x 'a)) '(a 1 2 a 3 4))
(member-if-not #'(lambda (x) (eqt x 'a)) '(a 1 2 a 3 4))
(1 2 a 3 4))
(deftest member-if-not-3
......@@ -65,7 +65,7 @@
(not (every
#'(lambda (x)
(let ((result (catch-type-error (member-if-not #'listp x))))
(or (eq result 'type-error)
(or (eqt result 'type-error)
(progn
(format t "~%On x = ~S, returns: ~%~S" x result)
nil))))
......
......@@ -60,7 +60,7 @@
(setf *mapc-6-var* nil)
(let ((result (mapc 'mapc-6-fun x)))
(and (check-scaffold-copy x xcopy)
(eq result x)
(eqt result x)
*mapc-6-var*)))
(h g f e d c b a))
......@@ -161,7 +161,7 @@
(loop
for e1 on x
and e2 on result
count (or (eq e1 e2) (not (eql (car e1) (car e2)))))))
count (or (eqt e1 e2) (not (eql (car e1) (car e2)))))))
0)
(deftest mapcan-4
......@@ -246,7 +246,7 @@
x)))
(and
(check-scaffold-copy x xcopy)
(eq result x)
(eqt result x)
a))
((c) (b c) (a b c)))
......@@ -263,7 +263,7 @@
a)))
x y)))
(and
(eq result x)
(eqt result x)
(check-scaffold-copy x xcopy)
(check-scaffold-copy y ycopy)
a))
......@@ -283,7 +283,7 @@
a)))
x y)))
(and
(eq result x)
(eqt result x)
(check-scaffold-copy x xcopy)
(check-scaffold-copy y ycopy)
a))
......@@ -303,7 +303,7 @@
a)))
x y)))
(and
(eq result x)
(eqt result x)
(check-scaffold-copy x xcopy)
(check-scaffold-copy y ycopy)
a))
......
......@@ -16,7 +16,7 @@
(result (acons 'a 'b x)))
(and
(check-scaffold-copy x xcopy)
(eq (cdr result) x)
(eqt (cdr result) x)
result))
((a . b) (c . d) (e . f)))
......@@ -72,7 +72,7 @@
(xcopy (make-scaffold-copy x))
(result (assoc 'b x)))
(and
(eq result (second x))
(eqt result (second x))
(check-scaffold-copy x xcopy)))