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

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