diff --git a/ansi-tests/ansi-aux.lsp b/ansi-tests/ansi-aux.lsp index bd888ea000e087fe2ea184da08616f38086d6554..d8db6a4cde0f3d9a1a7c270d333694d094107d90 100644 --- a/ansi-tests/ansi-aux.lsp +++ b/ansi-tests/ansi-aux.lsp @@ -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) diff --git a/ansi-tests/atom-errors.lsp b/ansi-tests/atom-errors.lsp index 130e0ff46dd489d4b7aaae81a13bf2d07d537844..874fae2137ad5b8a63acf76fc5dfd1ad592acc76 100644 --- a/ansi-tests/atom-errors.lsp +++ b/ansi-tests/atom-errors.lsp @@ -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))))) diff --git a/ansi-tests/catch.lsp b/ansi-tests/catch.lsp index aeb4bb87d98548f1a253db26593a161b33ca4c07..5a3732e24d409f555b0390f30c6fb97a245a7b79 100644 --- a/ansi-tests/catch.lsp +++ b/ansi-tests/catch.lsp @@ -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)) diff --git a/ansi-tests/character.lsp b/ansi-tests/character.lsp index b076efb6544f0b290e6ee46eb572f737c3eea84b..429e371a8373a96555d123d7861b905ebb8e7d69 100644 --- a/ansi-tests/character.lsp +++ b/ansi-tests/character.lsp @@ -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 diff --git a/ansi-tests/cl-symbols.lsp b/ansi-tests/cl-symbols.lsp index 6bcf2bfec1318ed001344576642dac8c58730043..58f8cb69371cebba54682faf8c1497627ac0396f 100644 --- a/ansi-tests/cl-symbols.lsp +++ b/ansi-tests/cl-symbols.lsp @@ -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) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; diff --git a/ansi-tests/compile.lsp b/ansi-tests/compile.lsp index 5902b3c558dbe8b46de694a3d452848bf18efef5..9240784ead53de2a52e724869b94d1574653d4a7 100644 --- a/ansi-tests/compile.lsp +++ b/ansi-tests/compile.lsp @@ -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) diff --git a/ansi-tests/concatenate.lsp b/ansi-tests/concatenate.lsp index 9d40b930437bc245446314c97c1fe1e33a6ea183..c38e8cdd905718981f5369b0cc2430e0040c17a1 100644 --- a/ansi-tests/concatenate.lsp +++ b/ansi-tests/concatenate.lsp @@ -41,7 +41,7 @@ (copy (concatenate 'vector orig))) (values copy - (eq copy orig))) + (eqt copy orig))) #(a b c d e) nil) diff --git a/ansi-tests/cons-test-01.lsp b/ansi-tests/cons-test-01.lsp index 0d74f107c980cbf46b75964e99518f2d9f9e986e..067fe9fc1c332d73f457cc0867b179dd12f860ca 100644 --- a/ansi-tests/cons-test-01.lsp +++ b/ansi-tests/cons-test-01.lsp @@ -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) diff --git a/ansi-tests/cons-test-02.lsp b/ansi-tests/cons-test-02.lsp index f53fe3331e5dce3727f8cd2916dc2a84ca4ac7d5..f3f5cf584edb14318e089f9f280fa2d26ad568f2 100644 --- a/ansi-tests/cons-test-02.lsp +++ b/ansi-tests/cons-test-02.lsp @@ -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))) diff --git a/ansi-tests/cons-test-03.lsp b/ansi-tests/cons-test-03.lsp index f83dc34f44193efc3863763ed0bfba219a0e7a3f..2be6107526c79058a6ff2644c1884a84d993304b 100644 --- a/ansi-tests/cons-test-03.lsp +++ b/ansi-tests/cons-test-03.lsp @@ -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) diff --git a/ansi-tests/cons-test-04.lsp b/ansi-tests/cons-test-04.lsp index 01f070939d017a22a2cdb6cccaaf372ef11ffded..72bf05df1adbcb16160a15b69dec2b8e969901c2 100644 --- a/ansi-tests/cons-test-04.lsp +++ b/ansi-tests/cons-test-04.lsp @@ -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)) diff --git a/ansi-tests/cons-test-05.lsp b/ansi-tests/cons-test-05.lsp index 1764c0dc0e6f7cadf83a2960a048fb6193b075cc..e6ab40794724e8a87461101f5933808824dc9eb6 100644 --- a/ansi-tests/cons-test-05.lsp +++ b/ansi-tests/cons-test-05.lsp @@ -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))) diff --git a/ansi-tests/cons-test-07.lsp b/ansi-tests/cons-test-07.lsp index b9ffae3cf70a80849cc42ba6bf232136810f8a54..0a3686b3b4d3f6fcd872081c016c999a5f0a74eb 100644 --- a/ansi-tests/cons-test-07.lsp +++ b/ansi-tests/cons-test-07.lsp @@ -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)) diff --git a/ansi-tests/cons-test-09.lsp b/ansi-tests/cons-test-09.lsp index fdd50320f2a950aa5bf2ea00ad9eec886e3f6d47..3bb43c7615ca5ec0d79033f322108d775d4c2fd7 100644 --- a/ansi-tests/cons-test-09.lsp +++ b/ansi-tests/cons-test-09.lsp @@ -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)) diff --git a/ansi-tests/cons-test-11.lsp b/ansi-tests/cons-test-11.lsp index f5c9fc803ef6bdc1e8d0240e0349e78cb7c8f91a..a70677cbbc33017b85b0b5ca459c15c4138a52ec 100644 --- a/ansi-tests/cons-test-11.lsp +++ b/ansi-tests/cons-test-11.lsp @@ -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 diff --git a/ansi-tests/cons-test-13.lsp b/ansi-tests/cons-test-13.lsp index 58b7ebef2a65b4bb7638e394261705a9d07707a3..f98ab48d08d5b8fefbdae13649d0242112bdaeee 100644 --- a/ansi-tests/cons-test-13.lsp +++ b/ansi-tests/cons-test-13.lsp @@ -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) diff --git a/ansi-tests/cons-test-14.lsp b/ansi-tests/cons-test-14.lsp index f7ffb326c7cff16efc9c07f9f04709eb231fda4a..6d75bda6526fbe29b626957a6bab46198599a651 100644 --- a/ansi-tests/cons-test-14.lsp +++ b/ansi-tests/cons-test-14.lsp @@ -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)))) diff --git a/ansi-tests/cons-test-15.lsp b/ansi-tests/cons-test-15.lsp index 3ace94fb187c67aad147712e6c1a940c61a89141..bba36a1aed695451bff0cb51f7020cf907aa8343 100644 --- a/ansi-tests/cons-test-15.lsp +++ b/ansi-tests/cons-test-15.lsp @@ -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)) diff --git a/ansi-tests/cons-test-16.lsp b/ansi-tests/cons-test-16.lsp index ff59832ef09697f07d84ab647731dafae805ec2d..f63965056d9ba5938701a6ec454356fd8c6d6e24 100644 --- a/ansi-tests/cons-test-16.lsp +++ b/ansi-tests/cons-test-16.lsp @@ -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))) t) @@ -165,7 +165,7 @@ (deftest assoc-24 (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)) ;; Check that the order of the arguments to test is correct @@ -174,8 +174,8 @@ (block fail (assoc 'a '((b . 1) (c . 2) (a . 3)) :test #'(lambda (x y) - (unless (eq x 'a) (return-from fail 'fail)) - (eq x y)))) + (unless (eqt x 'a) (return-from fail 'fail)) + (eqt x y)))) (A . 3)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -187,7 +187,7 @@ (result (assoc-if #'evenp x))) (and (check-scaffold-copy x xcopy) - (eq result (third x)) + (eqt result (third x)) result)) (6 . c)) @@ -198,7 +198,7 @@ (result (assoc-if #'oddp x :key #'1+))) (and (check-scaffold-copy x xcopy) - (eq result (third x)) + (eqt result (third x)) result)) (program-error (c) c)) (6 . c)) @@ -209,7 +209,7 @@ (result (assoc-if #'evenp x))) (and (check-scaffold-copy x xcopy) - (eq result (fourth x)) + (eqt result (fourth x)) result)) (6 . c)) @@ -226,7 +226,7 @@ (result (assoc-if-not #'oddp x))) (and (check-scaffold-copy x xcopy) - (eq result (third x)) + (eqt result (third x)) result)) (6 . c)) @@ -237,7 +237,7 @@ (result (assoc-if-not #'evenp x :key #'1+))) (and (check-scaffold-copy x xcopy) - (eq result (third x)) + (eqt result (third x)) result)) (program-error (c) c)) (6 . c)) @@ -248,7 +248,7 @@ (result (assoc-if-not #'oddp x))) (and (check-scaffold-copy x xcopy) - (eq result (fourth x)) + (eqt result (fourth x)) result)) (6 . c)) @@ -270,9 +270,9 @@ (= (length x) (length result)) (every #'(lambda (p1 p2) (or (and (null p1) (null p2)) - (and (not (eq p1 p2)) - (eq (car p1) (car p2)) - (eq (cdr p1) (cdr p2))))) + (and (not (eqt p1 p2)) + (eqt (car p1) (car p2)) + (eqt (cdr p1) (cdr p2))))) x result) t)) t) @@ -328,7 +328,7 @@ (check-scaffold-copy x xcopy) (check-scaffold-copy y ycopy) (check-scaffold-copy z zcopy) - (eq (cdr (cddr (cddr result))) z) + (eqt (cdr (cddr (cddr result))) z) (or (equal result expected) (equal result (append (reverse (subseq expected 0 5)) diff --git a/ansi-tests/cons-test-17.lsp b/ansi-tests/cons-test-17.lsp index 394e1a70e569da60d4482a5499e56d7662f3c678..46181f9328fe40fd7f5bc147a532b78472204b5f 100644 --- a/ansi-tests/cons-test-17.lsp +++ b/ansi-tests/cons-test-17.lsp @@ -47,7 +47,7 @@ (xcopy (make-scaffold-copy x)) (result (rassoc 'b x))) (and - (eq result (second x)) + (eqt result (second x)) (check-scaffold-copy x xcopy))) t) @@ -178,7 +178,7 @@ (copy-tree (rev-assoc-list '((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)) ;; Check that the order of the arguments to :test is correct @@ -187,8 +187,8 @@ (block fail (rassoc 'a '((1 . b) (2 . c) (3 . a)) :test #'(lambda (x y) - (unless (eq x 'a) (return-from fail 'fail)) - (eq x y)))) + (unless (eqt x 'a) (return-from fail 'fail)) + (eqt x y)))) (3 . A)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -200,7 +200,7 @@ (result (rassoc-if #'evenp x))) (and (check-scaffold-copy x xcopy) - (eq result (third x)) + (eqt result (third x)) result)) (c . 6)) @@ -211,7 +211,7 @@ (result (rassoc-if #'oddp x :key #'1+))) (and (check-scaffold-copy x xcopy) - (eq result (third x)) + (eqt result (third x)) result)) (program-error (c) c)) (c . 6)) @@ -222,7 +222,7 @@ (result (rassoc-if #'evenp x))) (and (check-scaffold-copy x xcopy) - (eq result (fourth x)) + (eqt result (fourth x)) result)) (c . 6)) @@ -240,7 +240,7 @@ (result (rassoc-if-not #'oddp x))) (and (check-scaffold-copy x xcopy) - (eq result (third x)) + (eqt result (third x)) result)) (c . 6)) @@ -251,7 +251,7 @@ (result (rassoc-if-not #'evenp x :key #'1+))) (and (check-scaffold-copy x xcopy) - (eq result (third x)) + (eqt result (third x)) result)) (program-error (c) c)) (c . 6)) @@ -262,7 +262,7 @@ (result (rassoc-if-not #'oddp x))) (and (check-scaffold-copy x xcopy) - (eq result (fourth x)) + (eqt result (fourth x)) result)) (c . 6)) diff --git a/ansi-tests/cons-test-18.lsp b/ansi-tests/cons-test-18.lsp index fa9a5ec8a38c9c981ed9d5a6a0ef08a5f4fe7847..ff9971d888aaee7887936bc06a65bc533eace2bb 100644 --- a/ansi-tests/cons-test-18.lsp +++ b/ansi-tests/cons-test-18.lsp @@ -53,7 +53,7 @@ (and (check-scaffold-copy x xcopy) (check-scaffold-copy y ycopy) - (eq tail (nthcdr 6 x)) + (eqt tail (nthcdr 6 x)) (values indicator value tail)))) g h (g h a c)) @@ -224,7 +224,7 @@ (and (remf x 'c) t) (loop for ptr on x by #'cddr count - (not (eq (car ptr) 'a))))) + (not (eqt (car ptr) 'a))))) t 0) diff --git a/ansi-tests/cons-test-19.lsp b/ansi-tests/cons-test-19.lsp index 841e959a74b513539c252abf56ff3bed8c1a34d3..59fdc57fedaf4173f3fb46c91d9e02d930f5f694 100644 --- a/ansi-tests/cons-test-19.lsp +++ b/ansi-tests/cons-test-19.lsp @@ -322,7 +322,7 @@ (y (copy-list '(3 y c q z a 18))) (result (nintersection-with-check xc y))) (and - (not (eq result 'failed)) + (not (eqt result 'failed)) (+ (loop for e in x count @@ -343,7 +343,7 @@ (y (copy-list '(a a a b b b))) (result (nintersection-with-check x y))) (and - (not (eq result 'failed)) + (not (eqt result 'failed)) (member 'a result) (not (member 'b result)))) t) @@ -394,7 +394,7 @@ (nintersection-with-check (loop for i from 0 to 1000 by 3 collect i) (loop for i from 0 to 1000 by 7 collect i)))) - (if (eq result 'failed) () result)) + (if (eqt result 'failed) () result)) #'<) (loop for i from 0 to 1000 by 21 collect i)))) t) @@ -410,7 +410,7 @@ :test #'(lambda (a b) (and (eql a b) (= (mod a 3) 0)))))) - (if (eq result 'failed) () result)) + (if (eqt result 'failed) () result)) #'<) (loop for i from 0 to 999 by (* 3 5 7) collect i)))) @@ -427,7 +427,7 @@ (let ((x (shuffle (loop for j from 1 to size collect (random maxelem state)))) (y (shuffle (loop for j from 1 to size collect (random maxelem state))))) (let ((z (nintersection-with-check (copy-list x) y))) - (when (eq z 'failed) (return (values x y z))) + (when (eqt z 'failed) (return (values x y z))) (let ((is-good (is-intersection x y z))) (unless is-good (return (values x y z))))))) nil)) diff --git a/ansi-tests/cons-test-20.lsp b/ansi-tests/cons-test-20.lsp index 0ecd34d7585a40de66bbb60cf3066c2e3a08119c..82cdfaec0eb04039b15b8f4478ed43ed323cd3bb 100644 --- a/ansi-tests/cons-test-20.lsp +++ b/ansi-tests/cons-test-20.lsp @@ -231,7 +231,7 @@ :test #'(lambda (a b) (<= (abs (- a b)) 1))))) (and - (not (eq result 'failed)) + (not (eqt result 'failed)) (sort (sublis '((2 . 1) (5 . 4) (11 . 10) (45 . 44) (102 . 101)) @@ -251,7 +251,7 @@ (setf y (* y y)))) (not (not (or - (eq x y) ;; if bignums are eq, the test is worthless + (eqt x y) ;; if bignums are eq, the test is worthless (eql (length (union-with-check (list x) (list x))) diff --git a/ansi-tests/cons-test-21.lsp b/ansi-tests/cons-test-21.lsp index 71bba875eefb5ece0805e050e6d357baf96c3ee7..b0992132cad8c776ec3be6db66187d90c52faee9 100644 --- a/ansi-tests/cons-test-21.lsp +++ b/ansi-tests/cons-test-21.lsp @@ -228,7 +228,7 @@ (setf y (* y y)))) (not (not (or - (eq x y) ;; if bignums are eq, the test is worthless + (eqt x y) ;; if bignums are eq, the test is worthless (eql (length (nunion-with-copy (list x) (list x))) 1))))) diff --git a/ansi-tests/cons-test-22.lsp b/ansi-tests/cons-test-22.lsp index fbe480d5a803700d0ecb46dcf9a719f1faabc783..a8c1feb7935589985657bdf60712d5f192acdb6d 100644 --- a/ansi-tests/cons-test-22.lsp +++ b/ansi-tests/cons-test-22.lsp @@ -18,7 +18,7 @@ (ycopy (make-scaffold-copy y))) (let ((result (apply #'set-difference x y - `(,@(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)))))) (cond @@ -31,7 +31,7 @@ (defun check-set-difference (x y z &key (key #'identity) (test #'eql)) (and - (not (eq 'failed z)) + (not (eqt 'failed z)) (every #'(lambda (e) (member e x :key key :test test)) z) (every #'(lambda (e) (or (member e y :key key :test test) (member e z :key key :test test))) x) @@ -143,7 +143,7 @@ (when (or (member x '(e f g h)) (member y '(1 2 3 4))) (return-from fail 'fail)) - (eq x y)))) + (eqt x y)))) #'<)) (1 2 3 4)) @@ -158,7 +158,7 @@ (when (or (member x '(e f g h)) (member y '(1 2 3 4))) (return-from fail 'fail)) - (eq x y)))) + (eqt x y)))) #'<)) (1 2 3 4)) @@ -173,7 +173,7 @@ (when (or (member x '(e f g h)) (member y '(1 2 3 4))) (return-from fail 'fail)) - (not (eq x y))))) + (not (eqt x y))))) #'<)) (1 2 3 4)) @@ -188,7 +188,7 @@ (when (or (member x '(e f g h)) (member y '(1 2 3 4))) (return-from fail 'fail)) - (not (eq x y))))) + (not (eqt x y))))) #'<)) (1 2 3 4)) @@ -201,7 +201,7 @@ (setf y (copy-list y)) (apply #'nset-difference x y - `(,@(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))))) @@ -318,7 +318,7 @@ (when (or (member x '(e f g h)) (member y '(1 2 3 4))) (return-from fail 'fail)) - (eq x y)))) + (eqt x y)))) #'<)) (1 2 3 4)) @@ -333,7 +333,7 @@ (when (or (member x '(e f g h)) (member y '(1 2 3 4))) (return-from fail 'fail)) - (eq x y)))) + (eqt x y)))) #'<)) (1 2 3 4)) @@ -348,7 +348,7 @@ (when (or (member x '(e f g h)) (member y '(1 2 3 4))) (return-from fail 'fail)) - (not (eq x y))))) + (not (eqt x y))))) #'<)) (1 2 3 4)) @@ -362,6 +362,6 @@ (when (or (member x '(e f g h)) (member y '(1 2 3 4))) (return-from fail 'fail)) - (not (eq x y))))) + (not (eqt x y))))) #'<)) (1 2 3 4)) diff --git a/ansi-tests/cons-test-23.lsp b/ansi-tests/cons-test-23.lsp index 95b0f7ffcc2920fd702f6deae9c2c70b700a09e1..873638c38e43e2c9998318f6a9ee9594179f686a 100644 --- a/ansi-tests/cons-test-23.lsp +++ b/ansi-tests/cons-test-23.lsp @@ -18,7 +18,7 @@ (ycopy (make-scaffold-copy y))) (let ((result (apply #'set-exclusive-or x y - `(,@(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)))))) (cond @@ -31,7 +31,7 @@ (defun check-set-exclusive-or (x y z &key (key #'identity) (test #'eql)) (and - (not (eq 'failed z)) + (not (eqt 'failed z)) (every #'(lambda (e) (or (member e x :key key :test test) (member e y :key key :test test))) z) @@ -229,7 +229,7 @@ (setf y (copy-list y)) (apply #'nset-exclusive-or x y - `(,@(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))))) diff --git a/ansi-tests/cons-test-24.lsp b/ansi-tests/cons-test-24.lsp index 31dbf09c989f94347d15c05047aadc5a30582faa..c709b502f08e94b6f607642cbbe8fd1a1c9d7eaf 100644 --- a/ansi-tests/cons-test-24.lsp +++ b/ansi-tests/cons-test-24.lsp @@ -17,7 +17,7 @@ (ycopy (make-scaffold-copy y))) (let ((result (apply #'subsetp x y - `(,@(unless (eq key 'no-key) + `(,@(unless (eqt key 'no-key) `(:key ,key)) ,@(when test `(:test ,test)) ,@(when test-not `(:test-not ,test-not)))))) @@ -75,7 +75,7 @@ (list '(z . c) '(a . y) '(b . 100) '(e . f) '(c . foo))) :test #'(lambda (e1 e2) - (eq e1 (car e2)))) + (eqt e1 (car e2)))) t) (deftest subsetp-10 @@ -85,7 +85,7 @@ (list '(z . c) '(a . y) '(b . 100) '(e . f) '(c . foo))) :test #'(lambda (e1 e2) - (eq e1 (car e2))) + (eqt e1 (car e2))) :key nil) (error (c) c)) t) @@ -96,7 +96,7 @@ (list '(z . c) '(a . y) '(b . 100) '(e . f) '(c . foo))) :test-not #'(lambda (e1 e2) - (not (eq e1 (car e2))))) + (not (eqt e1 (car e2))))) t) ;; Check that it maintains order of arguments diff --git a/ansi-tests/count-if-not.lsp b/ansi-tests/count-if-not.lsp index c6b1025aa08414c5437f0d87c512fada49eddc4c..ab401516d327f224ba3575f2fc053260e55e4f0a 100644 --- a/ansi-tests/count-if-not.lsp +++ b/ansi-tests/count-if-not.lsp @@ -55,23 +55,23 @@ 8) (deftest count-if-not-list.13 - (count-if-not #'(lambda (x) (not (eq x 'a))) + (count-if-not #'(lambda (x) (not (eqt x 'a))) '(a b c d a e f a e f f a a) :start 2) 4) (deftest count-if-not-list.14 - (count-if-not #'(lambda (x) (not (eq x 'a))) + (count-if-not #'(lambda (x) (not (eqt x 'a))) '(a b c d a e f a e f f a a) :end 7) 2) (deftest count-if-not-list.15 - (count-if-not #'(lambda (x) (not (eq x 'a))) + (count-if-not #'(lambda (x) (not (eqt x 'a))) '(a b c d a e f a e f f a a) :end 7 :start 2) 1) (deftest count-if-not-list.16 - (count-if-not #'(lambda (x) (not (eq x 'a))) + (count-if-not #'(lambda (x) (not (eqt x 'a))) '(a b c d a e f a e f f a a) :end 7 :start 2 :from-end t) 1) @@ -129,23 +129,23 @@ 8) (deftest count-if-not-vector.13 - (count-if-not #'(lambda (x) (not (eq x 'a))) + (count-if-not #'(lambda (x) (not (eqt x 'a))) #(a b c d a e f a e f f a a) :start 2) 4) (deftest count-if-not-vector.14 - (count-if-not #'(lambda (x) (not (eq x 'a))) + (count-if-not #'(lambda (x) (not (eqt x 'a))) #(a b c d a e f a e f f a a) :end 7) 2) (deftest count-if-not-vector.15 - (count-if-not #'(lambda (x) (not (eq x 'a))) + (count-if-not #'(lambda (x) (not (eqt x 'a))) #(a b c d a e f a e f f a a) :end 7 :start 2) 1) (deftest count-if-not-vector.16 - (count-if-not #'(lambda (x) (not (eq x 'a))) + (count-if-not #'(lambda (x) (not (eqt x 'a))) #(a b c d a e f a e f f a a) :end 7 :start 2 :from-end t) 1) @@ -232,28 +232,28 @@ 8) (deftest count-if-not-nonsimple-vector.13 - (count-if-not #'(lambda (x) (not (eq x 'a))) + (count-if-not #'(lambda (x) (not (eqt x 'a))) (make-array 13 :initial-contents '(a b c d a e f a e f f a a) :fill-pointer t :adjustable t) :start 2) 4) (deftest count-if-not-nonsimple-vector.14 - (count-if-not #'(lambda (x) (not (eq x 'a))) + (count-if-not #'(lambda (x) (not (eqt x 'a))) (make-array 13 :initial-contents '(a b c d a e f a e f f a a) :fill-pointer t :adjustable t) :end 7) 2) (deftest count-if-not-nonsimple-vector.15 - (count-if-not #'(lambda (x) (not (eq x 'a))) + (count-if-not #'(lambda (x) (not (eqt x 'a))) (make-array 13 :initial-contents '(a b c d a e f a e f f a a) :fill-pointer t :adjustable t) :end 7 :start 2) 1) (deftest count-if-not-nonsimple-vector.16 - (count-if-not #'(lambda (x) (not (eq x 'a))) + (count-if-not #'(lambda (x) (not (eqt x 'a))) (make-array 13 :initial-contents '(a b c d a e f a e f f a a) :fill-pointer t :adjustable t) :end 7 :start 2 :from-end t) diff --git a/ansi-tests/count-if.lsp b/ansi-tests/count-if.lsp index 357cf80920cc537bfffcac37b3db983bcf7949e3..ab226a82f425ddddb74cfa73879106b89978d1bb 100644 --- a/ansi-tests/count-if.lsp +++ b/ansi-tests/count-if.lsp @@ -55,23 +55,23 @@ 8) (deftest count-if-list.13 - (count-if #'(lambda (x) (eq x 'a)) + (count-if #'(lambda (x) (eqt x 'a)) '(a b c d a e f a e f f a a) :start 2) 4) (deftest count-if-list.14 - (count-if #'(lambda (x) (eq x 'a)) + (count-if #'(lambda (x) (eqt x 'a)) '(a b c d a e f a e f f a a) :end 7) 2) (deftest count-if-list.15 - (count-if #'(lambda (x) (eq x 'a)) + (count-if #'(lambda (x) (eqt x 'a)) '(a b c d a e f a e f f a a) :end 7 :start 2) 1) (deftest count-if-list.16 - (count-if #'(lambda (x) (eq x 'a)) + (count-if #'(lambda (x) (eqt x 'a)) '(a b c d a e f a e f f a a) :end 7 :start 2 :from-end t) 1) @@ -129,23 +129,23 @@ 8) (deftest count-if-vector.13 - (count-if #'(lambda (x) (eq x 'a)) + (count-if #'(lambda (x) (eqt x 'a)) #(a b c d a e f a e f f a a) :start 2) 4) (deftest count-if-vector.14 - (count-if #'(lambda (x) (eq x 'a)) + (count-if #'(lambda (x) (eqt x 'a)) #(a b c d a e f a e f f a a) :end 7) 2) (deftest count-if-vector.15 - (count-if #'(lambda (x) (eq x 'a)) + (count-if #'(lambda (x) (eqt x 'a)) #(a b c d a e f a e f f a a) :end 7 :start 2) 1) (deftest count-if-vector.16 - (count-if #'(lambda (x) (eq x 'a)) + (count-if #'(lambda (x) (eqt x 'a)) #(a b c d a e f a e f f a a) :end 7 :start 2 :from-end t) 1) @@ -232,28 +232,28 @@ 8) (deftest count-if-nonsimple-vector.13 - (count-if #'(lambda (x) (eq x 'a)) + (count-if #'(lambda (x) (eqt x 'a)) (make-array 13 :initial-contents '(a b c d a e f a e f f a a) :fill-pointer t :adjustable t) :start 2) 4) (deftest count-if-nonsimple-vector.14 - (count-if #'(lambda (x) (eq x 'a)) + (count-if #'(lambda (x) (eqt x 'a)) (make-array 13 :initial-contents '(a b c d a e f a e f f a a) :fill-pointer t :adjustable t) :end 7) 2) (deftest count-if-nonsimple-vector.15 - (count-if #'(lambda (x) (eq x 'a)) + (count-if #'(lambda (x) (eqt x 'a)) (make-array 13 :initial-contents '(a b c d a e f a e f f a a) :fill-pointer t :adjustable t) :end 7 :start 2) 1) (deftest count-if-nonsimple-vector.16 - (count-if #'(lambda (x) (eq x 'a)) + (count-if #'(lambda (x) (eqt x 'a)) (make-array 13 :initial-contents '(a b c d a e f a e f f a a) :fill-pointer t :adjustable t) :end 7 :start 2 :from-end t) diff --git a/ansi-tests/count.lsp b/ansi-tests/count.lsp index 73e0054f14eb664589b02859f450bd9dbc61fd0a..b6f6bb9bfe31e637cca4d9dbdb43dfb587cd891b 100644 --- a/ansi-tests/count.lsp +++ b/ansi-tests/count.lsp @@ -347,7 +347,7 @@ 7) (deftest count-string.4 - (count #\1 "00101100011011000" :key #'(lambda (x) (if (eq x #\0) #\1 #\2))) + (count #\1 "00101100011011000" :key #'(lambda (x) (if (eql x #\0) #\1 #\2))) 10) (deftest count-string.5 diff --git a/ansi-tests/fill-strings.lsp b/ansi-tests/fill-strings.lsp index cb64cbe2b3caecd5370cd9c5ae2c4262d556aed5..bf66ffaea0e72a96197fd03b9f5f7f7238bafd1a 100644 --- a/ansi-tests/fill-strings.lsp +++ b/ansi-tests/fill-strings.lsp @@ -8,7 +8,7 @@ (defun array-string-fill-test-fn (a &rest fill-args) (setq a (copy-seq a)) (let ((b (apply #'fill a fill-args))) - (values (eq a b) b))) + (values (eqt a b) b))) (deftest array-string-fill-1 (array-string-fill-test-fn "abcde" #\Z) diff --git a/ansi-tests/fill.lsp b/ansi-tests/fill.lsp index c6facb4b8fcd81e7b194bcc6a40b587507044c4a..ddaa43c459a8f6ef45d5be2d2b5238f14a8075c1 100644 --- a/ansi-tests/fill.lsp +++ b/ansi-tests/fill.lsp @@ -14,42 +14,42 @@ (deftest array-fill-1 (let* ((a (make-array '(5) :initial-contents '(a b c d e))) (b (fill a 'x))) - (values (eq a b) + (values (eqt a b) (map 'list #'identity a))) t (x x x x x)) (deftest array-fill-2 (let* ((a (make-array '(5) :initial-contents '(a b c d e))) (b (fill a 'x :start 2))) - (values (eq a b) + (values (eqt a b) (map 'list #'identity a))) t (a b x x x)) (deftest array-fill-3 (let* ((a (make-array '(5) :initial-contents '(a b c d e))) (b (fill a 'x :end 2))) - (values (eq a b) + (values (eqt a b) (map 'list #'identity a))) t (x x c d e)) (deftest array-fill-4 (let* ((a (make-array '(5) :initial-contents '(a b c d e))) (b (fill a 'x :start 1 :end 3))) - (values (eq a b) + (values (eqt a b) (map 'list #'identity a))) t (a x x d e)) (deftest array-fill-5 (let* ((a (make-array '(5) :initial-contents '(a b c d e))) (b (fill a 'x :start 1 :end nil))) - (values (eq a b) + (values (eqt a b) (map 'list #'identity a))) t (a x x x x)) (deftest array-fill-6 (let* ((a (make-array '(5) :initial-contents '(a b c d e))) (b (fill a 'x :end nil))) - (values (eq a b) + (values (eqt a b) (map 'list #'identity a))) t (x x x x x)) @@ -86,42 +86,42 @@ (deftest array-fixnum-fill-1 (let* ((a (make-array '(5) :element-type 'fixnum :initial-contents '(1 2 3 4 5))) (b (fill a 6))) - (values (eq a b) + (values (eqt a b) (map 'list #'identity a))) t (6 6 6 6 6)) (deftest array-fixnum-fill-2 (let* ((a (make-array '(5) :element-type 'fixnum :initial-contents '(1 2 3 4 5))) (b (fill a 6 :start 2))) - (values (eq a b) + (values (eqt a b) (map 'list #'identity a))) t (1 2 6 6 6)) (deftest array-fixnum-fill-3 (let* ((a (make-array '(5) :element-type 'fixnum :initial-contents '(1 2 3 4 5))) (b (fill a 7 :end 2))) - (values (eq a b) + (values (eqt a b) (map 'list #'identity a))) t (7 7 3 4 5)) (deftest array-fixnum-fill-4 (let* ((a (make-array '(5) :element-type 'fixnum :initial-contents '(1 2 3 4 5))) (b (fill a 8 :start 1 :end 3))) - (values (eq a b) + (values (eqt a b) (map 'list #'identity a))) t (1 8 8 4 5)) (deftest array-fixnum-fill-5 (let* ((a (make-array '(5) :element-type 'fixnum :initial-contents '(1 2 3 4 5))) (b (fill a 0 :start 1 :end nil))) - (values (eq a b) + (values (eqt a b) (map 'list #'identity a))) t (1 0 0 0 0)) (deftest array-fixnum-fill-6 (let* ((a (make-array '(5) :element-type 'fixnum :initial-contents '(1 2 3 4 5))) (b (fill a -1 :end nil))) - (values (eq a b) + (values (eqt a b) (map 'list #'identity a))) t (-1 -1 -1 -1 -1)) @@ -159,7 +159,7 @@ (let* ((a (make-array '(5) :element-type (list 'unsigned-byte byte-size) :initial-contents '(1 2 3 4 5))) (b (apply #'fill a fill-args))) - (values (eq a b) + (values (eqt a b) (map 'list #'identity a)))) (deftest array-unsigned-byte8-fill-1 diff --git a/ansi-tests/fmakunbound.lsp b/ansi-tests/fmakunbound.lsp index 6b46ac73492109ba4f7bd2f517fce69234255b27..f144ff2c2e51b10a7fa5e07f6bbde6692c85bbfa 100644 --- a/ansi-tests/fmakunbound.lsp +++ b/ansi-tests/fmakunbound.lsp @@ -10,7 +10,7 @@ (and (not (fboundp g)) (setf (symbol-function g) #'car) (fboundp g) - (values (eq (fmakunbound g) g) + (values (eqt (fmakunbound g) g) (fboundp g)))) t nil) @@ -19,7 +19,7 @@ (and (not (fboundp g)) (eval `(defun ,g () nil)) (fboundp g) - (values (eq (fmakunbound g) g) + (values (eqt (fmakunbound g) g) (fboundp g)))) t nil) @@ -28,7 +28,7 @@ (and (not (fboundp g)) (eval `(defmacro ,g () nil)) (fboundp g) - (values (eq (fmakunbound g) g) + (values (eqt (fmakunbound g) g) (fboundp g)))) t nil) diff --git a/ansi-tests/gclload2.lsp b/ansi-tests/gclload2.lsp index 77bba0a14819090cf07138c208dd14bbb662bc8b..645c2811ec23511c5a4b8fa97a409e50372888be 100644 --- a/ansi-tests/gclload2.lsp +++ b/ansi-tests/gclload2.lsp @@ -30,7 +30,10 @@ (load "lambda-parameters-limit.lsp") (load "let.lsp") (load "macrolet.lsp") +(load "nil.lsp") +(load "not-and-null.lsp") (load "progv.lsp") +(load "t.lsp") (load "tagbody.lsp") (load "unwind-protect.lsp") diff --git a/ansi-tests/make-array.lsp b/ansi-tests/make-array.lsp index 8f71ff6f523799266a33157282bbc4c6afe18d47..b47f39cb53490a78ae6b4538559e59ea9f274a9d 100644 --- a/ansi-tests/make-array.lsp +++ b/ansi-tests/make-array.lsp @@ -6,5 +6,5 @@ (in-package :cl-test) (defun make-array-check-upgrading (type) - (subtypep type (array-element-type (make-array 0 :element-type type)))) + (subtypep* type (array-element-type (make-array 0 :element-type type)))) diff --git a/ansi-tests/mismatch.lsp b/ansi-tests/mismatch.lsp index 54f221d3306fc67593bb51178c4a8117775fb0fb..f05438ef4f762fd41ed0ccc706a8fd4cf4ddfa76 100644 --- a/ansi-tests/mismatch.lsp +++ b/ansi-tests/mismatch.lsp @@ -392,7 +392,8 @@ nil) (deftest mismatch-string.8 - (mismatch "1001" "0110" :test #'(lambda (x y) (eql x (if (eq y #\0) #\1 #\0)))) + (mismatch "1001" "0110" :test #'(lambda (x y) (eql x (if (eql y #\0) + #\1 #\0)))) nil) (deftest mismatch-string.8a diff --git a/ansi-tests/nil.lsp b/ansi-tests/nil.lsp new file mode 100644 index 0000000000000000000000000000000000000000..afa63b9446c5b1d538d94a3071dc9a6d1d067141 --- /dev/null +++ b/ansi-tests/nil.lsp @@ -0,0 +1,44 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Thu Oct 17 06:32:46 2002 +;;;; Contains: Tests for NIL + +(in-package :cl-test) + +(deftest nil.1 + (loop for x in *universe* + thereis (subtypep (type-of x) nil)) + nil) + + +(deftest nil.2 + (loop for x in *universe* + unless (subtypep nil (type-of x)) + collect (type-of x)) + nil) + +(deftest nil.3 + (not (constantp nil)) + nil) + +(deftest nil.4 + (car nil) + nil) + +(deftest nil.5 + (cdr nil) + nil) + +(deftest nil.6 + (eval nil) + nil) + +(deftest nil.7 + (symbol-value nil) + nil) + +(deftest nil.8 + (eqt nil 'nil) + t) + +;;; NIL is, of course, present in many other files diff --git a/ansi-tests/not-and-null.lsp b/ansi-tests/not-and-null.lsp new file mode 100644 index 0000000000000000000000000000000000000000..35393302f09758de6a9b1b0d28130f7b46084258 --- /dev/null +++ b/ansi-tests/not-and-null.lsp @@ -0,0 +1,32 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Thu Oct 17 06:38:33 2002 +;;;; Contains: Tests of NOT and NULL + +(in-package :cl-test) + +(deftest null.1 + (null nil) + t) + +(deftest null.2 + (null t) + nil) + +(deftest null.3 + (some #'(lambda (x) (and x (null x))) *universe*) + nil) + +(deftest not.1 + (not nil) + t) + +(deftest not.2 + (not t) + nil) + +(deftest not.3 + (some #'(lambda (x) (and x (not x))) *universe*) + nil) + + diff --git a/ansi-tests/nstring-capitalize.lsp b/ansi-tests/nstring-capitalize.lsp index fc3ba71be037c0a4958ecdc6de29e207f85a5663..01d2068a03ade5817d780cfcd6236d40a3d31e78 100644 --- a/ansi-tests/nstring-capitalize.lsp +++ b/ansi-tests/nstring-capitalize.lsp @@ -8,25 +8,25 @@ (deftest nstring-capitalize.1 (let* ((s (copy-seq "abCd")) (s2 (nstring-capitalize s))) - (values (eq s s2) s)) + (values (eqt s s2) s)) t "Abcd") (deftest nstring-capitalize.2 (let* ((s (copy-seq "0adA2Cdd3wXy")) (s2 (nstring-capitalize s))) - (values (eq s s2) s)) + (values (eqt s s2) s)) t "0ada2cdd3wxy") (deftest nstring-capitalize.3 (let* ((s (copy-seq "1a")) (s2 (nstring-capitalize s))) - (values (eq s s2) s)) + (values (eqt s s2) s)) t "1a") (deftest nstring-capitalize.4 (let* ((s (copy-seq "a1a")) (s2 (nstring-capitalize s))) - (values (eq s s2) s)) + (values (eqt s s2) s)) t "A1a") (deftest nstring-capitalize.7 diff --git a/ansi-tests/nstring-downcase.lsp b/ansi-tests/nstring-downcase.lsp index 0bd938d73e1187e49e9ef6c7b9d0f7e825b6c084..55c9374bdbbf65723a19caffd3e7f106795da311 100644 --- a/ansi-tests/nstring-downcase.lsp +++ b/ansi-tests/nstring-downcase.lsp @@ -8,20 +8,20 @@ (deftest nstring-downcase.1 (let* ((s (copy-seq "A")) (s2 (nstring-downcase s))) - (values (eq s s2) s)) + (values (eqt s s2) s)) t "a") (deftest nstring-downcase.2 (let* ((s (copy-seq "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz")) (s2 (nstring-downcase s))) - (values (eq s s2) s)) + (values (eqt s s2) s)) t "abcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyz") (deftest nstring-downcase.3 (let* ((s (copy-seq "0123456789!@#$%^&*()_-+=|\\{}[]:\";'<>?,./ ")) (s2 (nstring-downcase s))) - (values (eq s s2) s)) + (values (eqt s s2) s)) t "0123456789!@#$%^&*()_-+=|\\{}[]:\";'<>?,./ ") @@ -29,14 +29,14 @@ (let* ((s (make-array 6 :element-type 'character :initial-contents '(#\A #\B #\C #\D #\E #\F))) (s2 (nstring-downcase s))) - (values (eq s s2) s)) + (values (eqt s s2) s)) t "abcdef") (deftest nstring-downcase.7 (let* ((s (make-array 6 :element-type 'standard-char :initial-contents '(#\A #\B #\7 #\D #\E #\F))) (s2 (nstring-downcase s))) - (values (eq s s2) s)) + (values (eqt s s2) s)) t "ab7def") diff --git a/ansi-tests/nstring-upcase.lsp b/ansi-tests/nstring-upcase.lsp index fd2056d1c0e26d81d9b4544d45b737acf3fb5025..6d0b9d26c77c4720894d880a0f74f60e2cc3b186 100644 --- a/ansi-tests/nstring-upcase.lsp +++ b/ansi-tests/nstring-upcase.lsp @@ -8,20 +8,20 @@ (deftest nstring-upcase.1 (let* ((s (copy-seq "a")) (s2 (nstring-upcase s))) - (values (eq s s2) s)) + (values (eqt s s2) s)) t "A") (deftest nstring-upcase.2 (let* ((s (copy-seq "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz")) (s2 (nstring-upcase s))) - (values (eq s s2) s)) + (values (eqt s s2) s)) t "ABCDEFGHIJKLMNOPQRSTUVWXYZABCDEFGHIJKLMNOPQRSTUVWXYZ") (deftest nstring-upcase.3 (let* ((s (copy-seq "0123456789!@#$%^&*()_-+=|\\{}[]:\";'<>?,./ ")) (s2 (nstring-upcase s))) - (values (eq s s2) s)) + (values (eqt s s2) s)) t "0123456789!@#$%^&*()_-+=|\\{}[]:\";'<>?,./ ") @@ -29,14 +29,14 @@ (let* ((s (make-array 6 :element-type 'character :initial-contents '(#\a #\b #\c #\d #\e #\f))) (s2 (nstring-upcase s))) - (values (eq s s2) s)) + (values (eqt s s2) s)) t "ABCDEF") (deftest nstring-upcase.7 (let* ((s (make-array 6 :element-type 'standard-char :initial-contents '(#\a #\b #\7 #\d #\e #\f))) (s2 (nstring-upcase s))) - (values (eq s s2) s)) + (values (eqt s s2) s)) t "AB7DEF") ;; Tests with :start, :end diff --git a/ansi-tests/packages-02.lsp b/ansi-tests/packages-02.lsp index 9b97aaa16f4c41c905c24fb610ba3d105e69174b..3a96150704a12f6f54d1406f6a9fee4251da9ce8 100644 --- a/ansi-tests/packages-02.lsp +++ b/ansi-tests/packages-02.lsp @@ -12,18 +12,18 @@ (deftest find-package-1 (let ((p (find-package "CL")) (p2 (find-package "COMMON-LISP"))) - (and p p2 (eq p p2))) + (and p p2 (eqt p p2))) t) (deftest find-package-2 (let ((p (find-package "CL-USER")) (p2 (find-package "COMMON-LISP-USER"))) - (and p p2 (eq p p2))) + (and p p2 (eqt p p2))) t) (deftest find-package-3 (let ((p (find-package "KEYWORD"))) - (and p (eq p (symbol-package :test)))) + (and p (eqt p (symbol-package :test)))) t) (deftest find-package-4 @@ -59,20 +59,20 @@ (p2 (ignore-errors (find-package "A")))) (and (packagep p) (packagep p2) - (eq p p2))) + (eqt p p2))) t) (deftest find-package-9 (let ((p (ignore-errors (find-package "A"))) (p2 (ignore-errors (find-package "B")))) - (eq p p2)) + (eqt p p2)) nil) (deftest find-package-10 (let ((p (ignore-errors (find-package #\Q))) (p2 (ignore-errors (find-package "Q")))) (and (packagep p) - (eq p p2))) + (eqt p p2))) t) (deftest find-package-11 @@ -80,7 +80,7 @@ (let ((cl (find-package "CL"))) (let ((cl2 (find-package cl))) (and (packagep cl) - (eq cl cl2)))) + (eqt cl cl2)))) (error (c) c)) t) diff --git a/ansi-tests/packages-03.lsp b/ansi-tests/packages-03.lsp index 3ebbdfd7c4e7808b08bada38280b0b9a4570d502..e4ac0df93c90a273a6313e97ab4ee8c6708a1288 100644 --- a/ansi-tests/packages-03.lsp +++ b/ansi-tests/packages-03.lsp @@ -108,7 +108,7 @@ (not (let ((name (package-name p))) (and (stringp name) - (eq (find-package name) p))))) + (eqt (find-package name) p))))) 0) ;; package-name applied to a package's name @@ -183,5 +183,5 @@ for nk in (package-nicknames p) count (not (and (stringp nk) - (eq p (find-package nk)))))) + (eqt p (find-package nk)))))) 0) diff --git a/ansi-tests/packages-04.lsp b/ansi-tests/packages-04.lsp index 5d427190c2359fe5d772e4d194d8e8fd00e03e3c..1a357266d6b4050aed93876a842a0389c08ee607 100644 --- a/ansi-tests/packages-04.lsp +++ b/ansi-tests/packages-04.lsp @@ -19,8 +19,8 @@ (and (null sym1) (null status1) (string= (symbol-name sym2) "FOO") - (eq (symbol-package sym2) p) - (eq status2 :internal) + (eqt (symbol-package sym2) p) + (eqt status2 :internal) (progn (delete-package p) t))))) t) @@ -34,7 +34,7 @@ (and (null sym1) (null status1) (string= (symbol-name sym2) "FOO") - (eq (symbol-package sym2) p) - (eq status2 :internal) + (eqt (symbol-package sym2) p) + (eqt status2 :internal) (progn (delete-package p) t))))) t) diff --git a/ansi-tests/packages-05.lsp b/ansi-tests/packages-05.lsp index 43d94f80fb07d3eeac01d54cc043aead4a79136d..3019bb39e19e390b3cfc2e68105d031642fde255 100644 --- a/ansi-tests/packages-05.lsp +++ b/ansi-tests/packages-05.lsp @@ -19,10 +19,10 @@ (find-symbol "FOO" p) (prog1 (and sym2 - (eq (symbol-package sym2) p) + (eqt (symbol-package sym2) p) (string= (symbol-name sym2) "FOO") - (eq sym sym2) - (eq status :external)) + (eqt sym sym2) + (eqt status :external)) (delete-package p))))) return-value) t) @@ -36,10 +36,10 @@ (find-symbol "FOO" p) (prog1 (and sym2 - (eq (symbol-package sym2) p) + (eqt (symbol-package sym2) p) (string= (symbol-name sym2) "FOO") - (eq sym sym2) - (eq status :external)) + (eqt sym sym2) + (eqt status :external)) (delete-package p)))))) t) diff --git a/ansi-tests/packages-06.lsp b/ansi-tests/packages-06.lsp index 8798080fa398a36b775c2368aa4fd2dc4aad333a..bb5488ec9f5ebd54d3a52958e1be7a0ec639590b 100644 --- a/ansi-tests/packages-06.lsp +++ b/ansi-tests/packages-06.lsp @@ -18,7 +18,7 @@ (unless (packagep p2) (ignore-errors (delete-package p)) (return p2)) - (unless (and (eq p p2) + (unless (and (eqt p p2) (equal (package-name p2) "TEST2")) (ignore-errors (delete-package p)) (ignore-errors (delete-package p2)) @@ -37,7 +37,7 @@ (unless (packagep p2) (ignore-errors (delete-package p)) (return p2)) - (unless (and (eq p p2) + (unless (and (eqt p p2) (equal (package-name p2) "TEST2") (null (set-exclusive-or nicknames (package-nicknames p2) @@ -59,7 +59,7 @@ (unless (packagep p2) (ignore-errors (delete-package p)) (return p2)) - (unless (and (eq p p2) + (unless (and (eqt p p2) (equal (package-name p2) "TEST2") (equal (sort (copy-list (package-nicknames p2)) @@ -85,7 +85,7 @@ (unless (packagep p2) (ignore-errors (delete-package p)) (return p2)) - (unless (and (eq p p2) + (unless (and (eqt p p2) (equal (package-name p2) "TEST2") (null (set-exclusive-or nicknames (package-nicknames p2) @@ -107,7 +107,7 @@ (unless (packagep p2) (ignore-errors (delete-package p)) (return p2)) - (unless (and (eq p p2) + (unless (and (eqt p p2) (equal (package-name p2) "G") (null (set-exclusive-or nicknames (package-nicknames p2) @@ -130,7 +130,7 @@ (unless (packagep p2) (ignore-errors (delete-package p)) (return p2)) - (unless (and (eq p p2) + (unless (and (eqt p p2) (equal (package-name p2) "TEST2") (equal (sort (copy-list (package-nicknames p2)) diff --git a/ansi-tests/packages-07.lsp b/ansi-tests/packages-07.lsp index e6a611a4ecd890ec01d086a3c5be0202b08b9052..da4d4e21e9a59d0dff3d786640dc6f2130636207 100644 --- a/ansi-tests/packages-07.lsp +++ b/ansi-tests/packages-07.lsp @@ -136,7 +136,7 @@ (shadow "X" :G) (multiple-value-bind (s2 kind) (find-symbol "X" :G) - (list (eq s1 s2) + (list (eqt s1 s2) (symbol-name s2) (package-name (symbol-package s2)) kind)))) @@ -161,7 +161,7 @@ (shadow "X" :H) (multiple-value-bind (s2 kind2) (find-symbol "X" :H) - (list (eq s1 s2) kind1 kind2)))) + (list (eqt s1 s2) kind1 kind2)))) (error (c) c)) (ignore-errors (delete-package :H)) (ignore-errors (delete-package :G))) diff --git a/ansi-tests/packages-08.lsp b/ansi-tests/packages-08.lsp index eff3ad7ab2928872d23e4c6dbbfe59d48ef8d524..c9096e70cd2bebfe166e7410e1139622cc458e1b 100644 --- a/ansi-tests/packages-08.lsp +++ b/ansi-tests/packages-08.lsp @@ -93,7 +93,7 @@ (equal (package-name P3) "P3")) (return 'fail1)) - (unless (eq (symbol-package S1) P1) + (unless (eqt (symbol-package S1) P1) (return 'fail2)) (unless (equal (prin1-to-string S1) "P1:S1") (return 'fail3)) diff --git a/ansi-tests/packages-10.lsp b/ansi-tests/packages-10.lsp index a046aa2a1c049528d51ecb67d0d9dbee202db19e..253a23aded87c3d4b01153a6e362d605e58994de 100644 --- a/ansi-tests/packages-10.lsp +++ b/ansi-tests/packages-10.lsp @@ -50,7 +50,7 @@ (return-from fail nil)) (multiple-value-bind (sym2 access2) (find-symbol (symbol-name sym) pkg) - (unless (or (eq sym sym2) + (unless (or (eqt sym sym2) (member sym2 (PACKAGE-SHADOWING-SYMBOLS pkg))) (unless (> fail-count +fail-count-limit+) (format t "Not same symbol: ~S ~S~%" sym sym2)) @@ -58,7 +58,7 @@ (format t "Further messages suppressed~%")) (incf fail-count) (return-from fail nil)) - (unless (eq access access2) + (unless (eqt access access2) (unless (> fail-count +fail-count-limit+) (format t "Not same access type: ~S ~S ~S~%" sym access access2)) @@ -74,7 +74,7 @@ (do-symbols (sym p) (multiple-value-bind (sym2 access) (find-symbol (symbol-name sym) p) - (unless (eq sym sym2) + (unless (eqt sym sym2) (unless (> fail-count +fail-count-limit+) (format t "Not same symbol (2): ~S ~S~%" sym sym2)) diff --git a/ansi-tests/packages-11.lsp b/ansi-tests/packages-11.lsp index 6a30101f04ca9df0cfa2a315c4ca16c3a77a0d4e..7256500fc9930ca2e0a3e35cb68ab57d88b40666 100644 --- a/ansi-tests/packages-11.lsp +++ b/ansi-tests/packages-11.lsp @@ -10,118 +10,123 @@ ;;; unexport (deftest unexport-1 - (handler-case - (progn - (ignore-errors (delete-package "X")) - (let* ((p (make-package "X" :use nil)) - (r (export (intern "X" p) p))) - (multiple-value-bind (sym1 access1) - (find-symbol "X" p) - (unexport sym1 p) - (multiple-value-bind (sym2 access2) - (find-symbol "X" p) - (and (eq r t) - (eq sym1 sym2) - (eq access1 :external) - (eq access2 :internal) - (equal (symbol-name sym1) "X")))))) - (error (c) c)) + (handler-case + (progn + (ignore-errors (delete-package "X")) + (let* ((p (make-package "X" :use nil)) + (r (export (intern "X" p) p))) + (multiple-value-bind (sym1 access1) + (find-symbol "X" p) + (unexport sym1 p) + (multiple-value-bind (sym2 access2) + (find-symbol "X" p) + (and (eqt r t) + (eqt sym1 sym2) + (eqt access1 :external) + (eqt access2 :internal) + (equal (symbol-name sym1) "X") + t))))) + (error (c) c)) t) (deftest unexport-2 - (handler-case - (progn - (ignore-errors (delete-package "X")) - (let* ((p (make-package "X" :use nil)) - (r (export (intern "X" p) p))) - (multiple-value-bind (sym1 access1) - (find-symbol "X" p) - (unexport (list sym1) "X") - (multiple-value-bind (sym2 access2) - (find-symbol "X" p) - (and (eq sym1 sym2) - (eq r t) - (eq access1 :external) - (eq access2 :internal) - (equal (symbol-name sym1) "X")))))) - (error (c) c)) + (handler-case + (progn + (ignore-errors (delete-package "X")) + (let* ((p (make-package "X" :use nil)) + (r (export (intern "X" p) p))) + (multiple-value-bind (sym1 access1) + (find-symbol "X" p) + (unexport (list sym1) "X") + (multiple-value-bind (sym2 access2) + (find-symbol "X" p) + (and (eqt sym1 sym2) + (eqt r t) + (eqt access1 :external) + (eqt access2 :internal) + (equal (symbol-name sym1) "X") + t))))) + (error (c) c)) t) (deftest unexport-3 - (handler-case - (progn - (ignore-errors (delete-package "X")) - (let* ((p (make-package "X" :use nil)) - (r1 (export (intern "X" p) p)) - (r2 (export (intern "Y" p) p))) - (multiple-value-bind (sym1 access1) - (find-symbol "X" p) - (multiple-value-bind (sym1a access1a) - (find-symbol "Y" p) - (unexport (list sym1 sym1a) '#:|X|) - (multiple-value-bind (sym2 access2) - (find-symbol "X" p) - (multiple-value-bind (sym2a access2a) - (find-symbol "Y" p) - (and (eq sym1 sym2) - (eq sym1a sym2a) - (eq r1 t) - (eq r2 t) - (eq access1 :external) - (eq access2 :internal) - (eq access1a :external) - (eq access2a :internal) - (equal (symbol-name sym1) "X") - (equal (symbol-name sym1a) "Y")))))))) - (error (c) c)) + (handler-case + (progn + (ignore-errors (delete-package "X")) + (let* ((p (make-package "X" :use nil)) + (r1 (export (intern "X" p) p)) + (r2 (export (intern "Y" p) p))) + (multiple-value-bind (sym1 access1) + (find-symbol "X" p) + (multiple-value-bind (sym1a access1a) + (find-symbol "Y" p) + (unexport (list sym1 sym1a) '#:|X|) + (multiple-value-bind (sym2 access2) + (find-symbol "X" p) + (multiple-value-bind (sym2a access2a) + (find-symbol "Y" p) + (and (eqt sym1 sym2) + (eqt sym1a sym2a) + (eqt r1 t) + (eqt r2 t) + (eqt access1 :external) + (eqt access2 :internal) + (eqt access1a :external) + (eqt access2a :internal) + (equal (symbol-name sym1) "X") + (equal (symbol-name sym1a) "Y") + t))))))) + (error (c) c)) t) (deftest unexport-4 - (handler-case - (progn - (ignore-errors (delete-package "X")) - (let* ((p (make-package "X" :use nil)) - (r (export (intern "X" p) p))) - (multiple-value-bind (sym1 access1) - (find-symbol "X" p) - (unexport (list sym1) #\X) - (multiple-value-bind (sym2 access2) - (find-symbol "X" p) - (and (eq sym1 sym2) - (eq r t) - (eq access1 :external) - (eq access2 :internal) - (equal (symbol-name sym1) "X")))))) - (error (c) c)) + (handler-case + (progn + (ignore-errors (delete-package "X")) + (let* ((p (make-package "X" :use nil)) + (r (export (intern "X" p) p))) + (multiple-value-bind (sym1 access1) + (find-symbol "X" p) + (unexport (list sym1) #\X) + (multiple-value-bind (sym2 access2) + (find-symbol "X" p) + (and (eqt sym1 sym2) + (eqt r t) + (eqt access1 :external) + (eqt access2 :internal) + (equal (symbol-name sym1) "X") + t))))) + (error (c) c)) t) ;; Check that it signals a package error when unexporting ;; an inaccessible symbol (deftest unexport-5 - (handler-case - (progn - (when (find-package "X") (delete-package "X")) - (unexport 'a (make-package "X" :use nil)) - nil) - (package-error () t) - (error (c) c)) + (handler-case + (progn + (when (find-package "X") (delete-package "X")) + (unexport 'a (make-package "X" :use nil)) + nil) + (package-error () t) + (error (c) c)) t) ;; Check that internal symbols are left alone (deftest unexport-6 - (handler-case - (progn - (when (find-package "X") (delete-package "X")) - (let ((p (make-package "X" :use nil))) - (let* ((sym (intern "FOO" p)) - (r (unexport sym p))) - (multiple-value-bind (sym2 access) - (find-symbol "FOO" p) - (and (eq r t) - (eq access :internal) - (eq sym sym2) - (equal (symbol-name sym) "FOO")))))) - (error (c) c)) + (handler-case + (progn + (when (find-package "X") (delete-package "X")) + (let ((p (make-package "X" :use nil))) + (let* ((sym (intern "FOO" p)) + (r (unexport sym p))) + (multiple-value-bind (sym2 access) + (find-symbol "FOO" p) + (and (eqt r t) + (eqt access :internal) + (eqt sym sym2) + (equal (symbol-name sym) "FOO") + t))))) + (error (c) c)) t) diff --git a/ansi-tests/packages-12.lsp b/ansi-tests/packages-12.lsp index 9b8831b4904c0a077018e80c7bd75f59a63243ec..6d951d10ec23bed7958ff2298467e82bc546509d 100644 --- a/ansi-tests/packages-12.lsp +++ b/ansi-tests/packages-12.lsp @@ -1,4 +1,4 @@ -;-*- Mode: Lisp -*- +();-*- Mode: Lisp -*- ;;;; Author: Paul Dietz ;;;; Created: Sat Apr 25 08:04:56 1998 ;;;; Contains: Package test code, part 12 @@ -22,7 +22,7 @@ (multiple-value-bind (sym access) (find-symbol "FOO" p) (and - (eq access :internal) + (eqt access :internal) (unintern sym p) (null (symbol-package sym)) (not (find-symbol "FOO" p))))) @@ -42,7 +42,7 @@ (multiple-value-bind (sym access) (find-symbol "FOO") (and - (eq access :internal) + (eqt access :internal) (unintern sym) (null (symbol-package sym)) (not (find-symbol "FOO"))))) @@ -60,7 +60,7 @@ (multiple-value-bind (sym access) (find-symbol "FOO" p) (and - (eq access :internal) + (eqt access :internal) (unintern sym "H") (null (symbol-package sym)) (not (find-symbol "FOO" p))))) @@ -78,7 +78,7 @@ (multiple-value-bind (sym access) (find-symbol "FOO" p) (and - (eq access :internal) + (eqt access :internal) (unintern sym '#:|H|) (null (symbol-package sym)) (not (find-symbol "FOO" p))))) @@ -97,7 +97,7 @@ (multiple-value-bind (sym access) (find-symbol "FOO" p) (and - (eq access :internal) + (eqt access :internal) (unintern sym #\H) (null (symbol-package sym)) (not (find-symbol "FOO" p))))) @@ -124,17 +124,17 @@ (multiple-value-bind (sym1 access1) (find-symbol "FOO" "H") (and sym1 - (eq access1 :external) + (eqt access1 :external) (equal "FOO" (symbol-name sym1)) - (eq (find-package "G") + (eqt (find-package "G") (symbol-package sym1)) (unintern sym1 "H") (multiple-value-bind (sym2 access2) (find-symbol "FOO" "H") - (and (eq sym1 sym2) - (eq (symbol-package sym1) + (and (eqt sym1 sym2) + (eqt (symbol-package sym1) (find-package "G")) - (eq access2 :inherited)))))) + (eqt access2 :inherited)))))) (error (c) c)) t) @@ -155,86 +155,86 @@ (find-symbol "FOO" ph) (and sym1 - (eq (symbol-package sym1) ph) - (eq access1 :internal) + (eqt (symbol-package sym1) ph) + (eqt access1 :internal) (equal (list sym1) (package-shadowing-symbols ph)) (unintern sym1 ph) (multiple-value-bind (sym2 access2) (find-symbol "FOO" ph) - (and (not (eq sym1 sym2)) - (eq access2 :inherited) + (and (not (eqt sym1 sym2)) + (eqt access2 :inherited) (null (symbol-package sym1)) - (eq (symbol-package sym2) pg))))))) + (eqt (symbol-package sym2) pg))))))) t) ;; Error situation: when the symbol is uninterned, creates ;; a name conflict from two used packages (deftest unintern-8 - (block failed - (ignore-errors (delete-package "H")) - (ignore-errors (delete-package "G1")) - (ignore-errors (delete-package "G2")) - (let* ((pg1 (make-package "G1")) - (pg2 (make-package "G2")) - (ph (make-package "H" :use (list pg1 pg2)))) - (handler-case - (shadow "FOO" ph) - (error (c) (return-from failed (list :shadow-error c)))) - (let ((gsym1 (intern "FOO" pg1)) - (gsym2 (intern "FOO" pg2))) - (export gsym1 pg1) - (export gsym2 pg2) - (multiple-value-bind (sym1 access1) - (find-symbol "FOO" ph) - (and - (equal (list sym1) (package-shadowing-symbols ph)) - (not (eq sym1 gsym1)) - (not (eq sym1 gsym2)) - (eq (symbol-package sym1) ph) - (eq access1 :internal) - (equal (symbol-name sym1) "FOO") - (handler-case - (progn - (unintern sym1 ph) - nil) - (error (c) - (format t "Properly threw an error: ~S~%" c) - t))))))) + (block failed + (ignore-errors (delete-package "H")) + (ignore-errors (delete-package "G1")) + (ignore-errors (delete-package "G2")) + (let* ((pg1 (make-package "G1")) + (pg2 (make-package "G2")) + (ph (make-package "H" :use (list pg1 pg2)))) + (handler-case + (shadow "FOO" ph) + (error (c) (return-from failed (list :shadow-error c)))) + (let ((gsym1 (intern "FOO" pg1)) + (gsym2 (intern "FOO" pg2))) + (export gsym1 pg1) + (export gsym2 pg2) + (multiple-value-bind (sym1 access1) + (find-symbol "FOO" ph) + (and + (equal (list sym1) (package-shadowing-symbols ph)) + (not (eqt sym1 gsym1)) + (not (eqt sym1 gsym2)) + (eqt (symbol-package sym1) ph) + (eqt access1 :internal) + (equal (symbol-name sym1) "FOO") + (handler-case + (progn + (unintern sym1 ph) + nil) + (error (c) + (format t "Properly threw an error: ~S~%" c) + t))))))) t) ;; Now, inherit the same symbol through two intermediate ;; packages. No error should occur when the shadowing ;; is removed (deftest unintern-9 - (block failed - (ignore-errors (delete-package "H")) - (ignore-errors (delete-package "G1")) - (ignore-errors (delete-package "G2")) - (ignore-errors (delete-package "G3")) - (let* ((pg3 (make-package "G3")) - (pg1 (make-package "G1" :use (list pg3))) - (pg2 (make-package "G2" :use (list pg3))) - (ph (make-package "H" :use (list pg1 pg2)))) - (handler-case - (shadow "FOO" ph) - (error (c) (return-from failed (list :shadow-error c)))) - (let ((gsym (intern "FOO" pg3))) - (export gsym pg3) - (export gsym pg1) - (export gsym pg2) - (multiple-value-bind (sym access) - (find-symbol "FOO" ph) - (and - (equal (list sym) (package-shadowing-symbols ph)) - (not (eq sym gsym)) - (equal (symbol-name sym) "FOO") - (equal (symbol-package sym) ph) - (eq access :internal) - (handler-case - (and (unintern sym ph) - (multiple-value-bind (sym2 access2) - (find-symbol "FOO" ph) - (and (eq gsym sym2) - (eq access2 :inherited)))) - (error (c) c))))))) + (block failed + (ignore-errors (delete-package "H")) + (ignore-errors (delete-package "G1")) + (ignore-errors (delete-package "G2")) + (ignore-errors (delete-package "G3")) + (let* ((pg3 (make-package "G3")) + (pg1 (make-package "G1" :use (list pg3))) + (pg2 (make-package "G2" :use (list pg3))) + (ph (make-package "H" :use (list pg1 pg2)))) + (handler-case + (shadow "FOO" ph) + (error (c) (return-from failed (list :shadow-error c)))) + (let ((gsym (intern "FOO" pg3))) + (export gsym pg3) + (export gsym pg1) + (export gsym pg2) + (multiple-value-bind (sym access) + (find-symbol "FOO" ph) + (and + (equal (list sym) (package-shadowing-symbols ph)) + (not (eqt sym gsym)) + (equal (symbol-name sym) "FOO") + (equal (symbol-package sym) ph) + (eqt access :internal) + (handler-case + (and (unintern sym ph) + (multiple-value-bind (sym2 access2) + (find-symbol "FOO" ph) + (and (eqt gsym sym2) + (eqt access2 :inherited)))) + (error (c) c))))))) t) diff --git a/ansi-tests/packages-13.lsp b/ansi-tests/packages-13.lsp index ed6769e675aedfd5eb259e6958bc4663c0b7b876..fd632e0903ee9ae828b5d59e02e58a64129a553d 100644 --- a/ansi-tests/packages-13.lsp +++ b/ansi-tests/packages-13.lsp @@ -13,24 +13,24 @@ (let ((*package* *package*)) (declare (special *package*)) (let ((p2 (in-package "A"))) - (and (eq p2 (find-package "A")) - (eq *package* p2)))) + (and (eqt p2 (find-package "A")) + (eqt *package* p2)))) t) (deftest in-package-2 (let ((*package* *package*)) (declare (special *package*)) (let ((p2 (in-package |A|))) - (and (eq p2 (find-package "A")) - (eq *package* p2)))) + (and (eqt p2 (find-package "A")) + (eqt *package* p2)))) t) (deftest in-package-3 (let ((*package* *package*)) (declare (special *package*)) (let ((p2 (in-package :|A|))) - (and (eq p2 (find-package "A")) - (eq *package* p2)))) + (and (eqt p2 (find-package "A")) + (eqt *package* p2)))) t) (deftest in-package-4 @@ -38,8 +38,8 @@ (declare (special *package*)) (handler-case (let ((p2 (in-package #\A))) - (and (eq p2 (find-package "A")) - (eq *package* p2))) + (and (eqt p2 (find-package "A")) + (eqt *package* p2))) (error (c) c))) t) diff --git a/ansi-tests/packages-14.lsp b/ansi-tests/packages-14.lsp index 20304bbae620d2dba830d9276bf59f7592d7cb68..230c353544884ef15e3052fce211bb184f39e80e 100644 --- a/ansi-tests/packages-14.lsp +++ b/ansi-tests/packages-14.lsp @@ -22,7 +22,7 @@ (equal (package-used-by-list pg) (list ph)) (unuse-package pg ph) (equal (package-use-list ph) nil) - (equal (package-used-by-list pg) nil)) + (null (package-used-by-list pg))) (delete-package "H") (delete-package "G")))) t) @@ -39,7 +39,7 @@ (equal (package-used-by-list pg) (list ph)) (unuse-package "G" ph) (equal (package-use-list ph) nil) - (equal (package-used-by-list pg) nil)) + (null (package-used-by-list pg))) (delete-package "H") (delete-package "G")))) t) @@ -56,7 +56,7 @@ (equal (package-used-by-list pg) (list ph)) (unuse-package :|G| ph) (equal (package-use-list ph) nil) - (equal (package-used-by-list pg) nil)) + (null (package-used-by-list pg))) (delete-package "H") (delete-package "G")))) t) @@ -73,7 +73,7 @@ (equal (package-used-by-list pg) (list ph)) (ignore-errors (unuse-package #\G ph)) (equal (package-use-list ph) nil) - (equal (package-used-by-list pg) nil)) + (null (package-used-by-list pg))) (delete-package "H") (delete-package "G")))) t) @@ -90,7 +90,7 @@ (equal (package-used-by-list pg) (list ph)) (unuse-package (list pg) ph) (equal (package-use-list ph) nil) - (equal (package-used-by-list pg) nil)) + (null (package-used-by-list pg))) (delete-package "H") (delete-package "G")))) t) @@ -107,7 +107,7 @@ (equal (package-used-by-list pg) (list ph)) (unuse-package (list "G") ph) (equal (package-use-list ph) nil) - (equal (package-used-by-list pg) nil)) + (null (package-used-by-list pg))) (delete-package "H") (delete-package "G")))) t) @@ -124,7 +124,7 @@ (equal (package-used-by-list pg) (list ph)) (unuse-package (list :|G|) ph) (equal (package-use-list ph) nil) - (equal (package-used-by-list pg) nil)) + (null (package-used-by-list pg))) (delete-package "H") (delete-package "G")))) t) @@ -141,7 +141,7 @@ (equal (package-used-by-list pg) (list ph)) (ignore-errors (unuse-package (list #\G) ph)) (equal (package-use-list ph) nil) - (equal (package-used-by-list pg) nil)) + (null (package-used-by-list pg))) (delete-package "H") (delete-package "G")))) t) @@ -178,7 +178,8 @@ (equal (sort-package-list (package-use-list ph2)) (list pg1 pg2 pg3)) (equal (sort-package-list (package-used-by-list pg2)) - (list ph1 ph2))) + (list ph1 ph2)) + t) (dolist (p '("H1" "H2" "G1" "G2" "G3")) (ignore-errors (delete-package p))))))) t) diff --git a/ansi-tests/packages-15.lsp b/ansi-tests/packages-15.lsp index 5e7691e22823f5aa4b68d0ff11e2194f076a0997..8a19d52da22bcef0b520a35565c0600b9252dfd4 100644 --- a/ansi-tests/packages-15.lsp +++ b/ansi-tests/packages-15.lsp @@ -10,184 +10,184 @@ ;;; use-package (deftest use-package-1 - (progn - (ignore-errors (delete-package "H")) - (ignore-errors (delete-package "G")) - (let* ((pg (make-package "G" :use nil)) - (ph (make-package "H" :use nil)) - (sym1 (intern "FOO" pg))) - (and - (eq (export sym1 pg) t) - (null (package-used-by-list pg)) - (null (package-used-by-list ph)) - (null (package-use-list pg)) - (null (package-use-list ph)) - (eq (use-package pg ph) t) ;; "H" will use "G" - (multiple-value-bind (sym2 access) - (find-symbol "FOO" ph) - (and - (eq access :inherited) - (eq sym1 sym2))) - (equal (package-use-list ph) (list pg)) - (equal (package-used-by-list pg) (list ph)) - (null (package-use-list pg)) - (null (package-used-by-list ph)) - (eq (unuse-package pg ph) t) - (null (find-symbol "FOO" ph))))) + (progn + (ignore-errors (delete-package "H")) + (ignore-errors (delete-package "G")) + (let* ((pg (make-package "G" :use nil)) + (ph (make-package "H" :use nil)) + (sym1 (intern "FOO" pg))) + (and + (eqt (export sym1 pg) t) + (null (package-used-by-list pg)) + (null (package-used-by-list ph)) + (null (package-use-list pg)) + (null (package-use-list ph)) + (eqt (use-package pg ph) t) ;; "H" will use "G" + (multiple-value-bind (sym2 access) + (find-symbol "FOO" ph) + (and + (eqt access :inherited) + (eqt sym1 sym2))) + (equal (package-use-list ph) (list pg)) + (equal (package-used-by-list pg) (list ph)) + (null (package-use-list pg)) + (null (package-used-by-list ph)) + (eqt (unuse-package pg ph) t) + (null (find-symbol "FOO" ph))))) t) (deftest use-package-2 - (progn - (ignore-errors (delete-package "H")) - (ignore-errors (delete-package "G")) - (let* ((pg (make-package "G" :use nil)) - (ph (make-package "H" :use nil)) - (sym1 (intern "FOO" pg))) - (and - (eq (export sym1 pg) t) - (null (package-used-by-list pg)) - (null (package-used-by-list ph)) - (null (package-use-list pg)) - (null (package-use-list ph)) - (eq (use-package "G" "H") t) ;; "H" will use "G" - (multiple-value-bind (sym2 access) - (find-symbol "FOO" ph) - (and - (eq access :inherited) - (eq sym1 sym2))) - (equal (package-use-list ph) (list pg)) - (equal (package-used-by-list pg) (list ph)) - (null (package-use-list pg)) - (null (package-used-by-list ph)) - (eq (unuse-package pg ph) t) - (null (find-symbol "FOO" ph))))) + (progn + (ignore-errors (delete-package "H")) + (ignore-errors (delete-package "G")) + (let* ((pg (make-package "G" :use nil)) + (ph (make-package "H" :use nil)) + (sym1 (intern "FOO" pg))) + (and + (eqt (export sym1 pg) t) + (null (package-used-by-list pg)) + (null (package-used-by-list ph)) + (null (package-use-list pg)) + (null (package-use-list ph)) + (eqt (use-package "G" "H") t) ;; "H" will use "G" + (multiple-value-bind (sym2 access) + (find-symbol "FOO" ph) + (and + (eqt access :inherited) + (eqt sym1 sym2))) + (equal (package-use-list ph) (list pg)) + (equal (package-used-by-list pg) (list ph)) + (null (package-use-list pg)) + (null (package-used-by-list ph)) + (eqt (unuse-package pg ph) t) + (null (find-symbol "FOO" ph))))) t) (deftest use-package-3 - (progn - (ignore-errors (delete-package "H")) - (ignore-errors (delete-package "G")) - (let* ((pg (make-package "G" :use nil)) - (ph (make-package "H" :use nil)) - (sym1 (intern "FOO" pg))) - (and - (eq (export sym1 pg) t) - (null (package-used-by-list pg)) - (null (package-used-by-list ph)) - (null (package-use-list pg)) - (null (package-use-list ph)) - (eq (use-package '#:|G| '#:|H|) t) ;; "H" will use "G" - (multiple-value-bind (sym2 access) - (find-symbol "FOO" ph) - (and - (eq access :inherited) - (eq sym1 sym2))) - (equal (package-use-list ph) (list pg)) - (equal (package-used-by-list pg) (list ph)) - (null (package-use-list pg)) - (null (package-used-by-list ph)) - (eq (unuse-package pg ph) t) - (null (find-symbol "FOO" ph))))) + (progn + (ignore-errors (delete-package "H")) + (ignore-errors (delete-package "G")) + (let* ((pg (make-package "G" :use nil)) + (ph (make-package "H" :use nil)) + (sym1 (intern "FOO" pg))) + (and + (eqt (export sym1 pg) t) + (null (package-used-by-list pg)) + (null (package-used-by-list ph)) + (null (package-use-list pg)) + (null (package-use-list ph)) + (eqt (use-package '#:|G| '#:|H|) t) ;; "H" will use "G" + (multiple-value-bind (sym2 access) + (find-symbol "FOO" ph) + (and + (eqt access :inherited) + (eqt sym1 sym2))) + (equal (package-use-list ph) (list pg)) + (equal (package-used-by-list pg) (list ph)) + (null (package-use-list pg)) + (null (package-used-by-list ph)) + (eqt (unuse-package pg ph) t) + (null (find-symbol "FOO" ph))))) t) (deftest use-package-4 - (progn - (ignore-errors (delete-package "H")) - (ignore-errors (delete-package "G")) - (let* ((pg (make-package "G" :use nil)) - (ph (make-package "H" :use nil)) - (sym1 (intern "FOO" pg))) - (and - (eq (export sym1 pg) t) - (null (package-used-by-list pg)) - (null (package-used-by-list ph)) - (null (package-use-list pg)) - (null (package-use-list ph)) - (eq (ignore-errors (use-package #\G #\H)) - t) ;; "H" will use "G" - (multiple-value-bind (sym2 access) - (find-symbol "FOO" ph) - (and - (eq access :inherited) - (eq sym1 sym2))) - (equal (package-use-list ph) (list pg)) - (equal (package-used-by-list pg) (list ph)) - (null (package-use-list pg)) - (null (package-used-by-list ph)) - (eq (unuse-package pg ph) t) - (null (find-symbol "FOO" ph))))) + (progn + (ignore-errors (delete-package "H")) + (ignore-errors (delete-package "G")) + (let* ((pg (make-package "G" :use nil)) + (ph (make-package "H" :use nil)) + (sym1 (intern "FOO" pg))) + (and + (eqt (export sym1 pg) t) + (null (package-used-by-list pg)) + (null (package-used-by-list ph)) + (null (package-use-list pg)) + (null (package-use-list ph)) + (eqt (ignore-errors (use-package #\G #\H)) + t) ;; "H" will use "G" + (multiple-value-bind (sym2 access) + (find-symbol "FOO" ph) + (and + (eqt access :inherited) + (eqt sym1 sym2))) + (equal (package-use-list ph) (list pg)) + (equal (package-used-by-list pg) (list ph)) + (null (package-use-list pg)) + (null (package-used-by-list ph)) + (eqt (unuse-package pg ph) t) + (null (find-symbol "FOO" ph))))) t) ;; use lists of packages (deftest use-package-5 - (let ((pkgs '("H" "G1" "G2" "G3")) - (vars '("FOO1" "FOO2" "FOO3"))) - (dolist (p pkgs) - (ignore-errors (delete-package p)) - (make-package p :use nil)) - (and - (every (complement #'package-use-list) pkgs) - (every (complement #'package-used-by-list) pkgs) - (every #'(lambda (v p) - (export (intern v p) p)) - vars (cdr pkgs)) - (progn - (dolist (p (cdr pkgs)) (intern "MINE" p)) - (eq (use-package (cdr pkgs) (car pkgs)) t)) - (every #'(lambda (v p) - (eq (find-symbol v p) - (find-symbol v (car pkgs)))) - vars (cdr pkgs)) - (null (find-symbol "MINE" (car pkgs))) - (every #'(lambda (p) - (equal (package-used-by-list p) - (list (find-package (car pkgs))))) - (cdr pkgs)) - (equal (sort-package-list (package-use-list (car pkgs))) - (mapcar #'find-package (cdr pkgs))) - (every (complement #'package-use-list) (cdr pkgs)) - (null (package-used-by-list (car pkgs))))) + (let ((pkgs '("H" "G1" "G2" "G3")) + (vars '("FOO1" "FOO2" "FOO3"))) + (dolist (p pkgs) + (ignore-errors (delete-package p)) + (make-package p :use nil)) + (and + (every (complement #'package-use-list) pkgs) + (every (complement #'package-used-by-list) pkgs) + (every #'(lambda (v p) + (export (intern v p) p)) + vars (cdr pkgs)) + (progn + (dolist (p (cdr pkgs)) (intern "MINE" p)) + (eqt (use-package (cdr pkgs) (car pkgs)) t)) + (every #'(lambda (v p) + (eqt (find-symbol v p) + (find-symbol v (car pkgs)))) + vars (cdr pkgs)) + (null (find-symbol "MINE" (car pkgs))) + (every #'(lambda (p) + (equal (package-used-by-list p) + (list (find-package (car pkgs))))) + (cdr pkgs)) + (equal (sort-package-list (package-use-list (car pkgs))) + (mapcar #'find-package (cdr pkgs))) + (every (complement #'package-use-list) (cdr pkgs)) + (null (package-used-by-list (car pkgs))))) t) ;; Circular package use (deftest use-package-6 - (progn - (ignore-errors (delete-package "H")) - (ignore-errors (delete-package "G")) - (let ((pg (make-package "G")) - (ph (make-package "H")) - sym1 sym2 sym3 sym4 - a1 a2 a3 a4) - (prog1 - (and - (export (intern "X" pg) pg) - (export (intern "Y" ph) ph) - (use-package pg ph) - (use-package ph pg) - (progn - (multiple-value-setq - (sym1 a1) (find-symbol "X" pg)) - (multiple-value-setq - (sym2 a2) (find-symbol "Y" ph)) - (multiple-value-setq - (sym3 a3) (find-symbol "Y" pg)) - (multiple-value-setq - (sym4 a4) (find-symbol "X" ph)) - (and - (eq a1 :external) - (eq a2 :external) - (eq a3 :inherited) - (eq a4 :inherited) - (eq sym1 sym4) - (eq sym2 sym3) - (eq (symbol-package sym1) pg) - (eq (symbol-package sym2) ph) - (unuse-package pg ph) - (unuse-package ph pg)))) - (ignore-errors (delete-package pg)) - (ignore-errors (delete-package ph))))) + (progn + (ignore-errors (delete-package "H")) + (ignore-errors (delete-package "G")) + (let ((pg (make-package "G")) + (ph (make-package "H")) + sym1 sym2 sym3 sym4 + a1 a2 a3 a4) + (prog1 + (and + (export (intern "X" pg) pg) + (export (intern "Y" ph) ph) + (use-package pg ph) + (use-package ph pg) + (progn + (multiple-value-setq + (sym1 a1) (find-symbol "X" pg)) + (multiple-value-setq + (sym2 a2) (find-symbol "Y" ph)) + (multiple-value-setq + (sym3 a3) (find-symbol "Y" pg)) + (multiple-value-setq + (sym4 a4) (find-symbol "X" ph)) + (and + (eqt a1 :external) + (eqt a2 :external) + (eqt a3 :inherited) + (eqt a4 :inherited) + (eqt sym1 sym4) + (eqt sym2 sym3) + (eqt (symbol-package sym1) pg) + (eqt (symbol-package sym2) ph) + (unuse-package pg ph) + (unuse-package ph pg)))) + (ignore-errors (delete-package pg)) + (ignore-errors (delete-package ph))))) t) ;; Also: need to check that *PACKAGE* is used as a default diff --git a/ansi-tests/packages-16.lsp b/ansi-tests/packages-16.lsp index 39d581c15d4f223cd389f53c187da527d89d4601..30266e1009bd689073a184b0d0362dd9d8f761d0 100644 --- a/ansi-tests/packages-16.lsp +++ b/ansi-tests/packages-16.lsp @@ -14,99 +14,100 @@ ;; we don't examine it here. ;; Try several ways of specifying the package name. (deftest defpackage-1 - (handler-case - (loop - for n in '("H" #:|H| #\H) count - (not - (progn - (ignore-errors (delete-package "H")) - (let ((p (ignore-errors (eval `(defpackage ,n))))) - (and - (packagep p) - (equal (package-name p) "H") - ;; (equal (package-use-list p) nil) - (equal (package-used-by-list p) nil) - (equal (package-nicknames p) nil) - (equal (package-shadowing-symbols p) nil) - (null (documentation p t)) - ))))) - (error (c) c)) + (handler-case + (loop + for n in '("H" #:|H| #\H) count + (not + (progn + (ignore-errors (delete-package "H")) + (let ((p (ignore-errors (eval `(defpackage ,n))))) + (and + (packagep p) + (equal (package-name p) "H") + ;; (equal (package-use-list p) nil) + (equal (package-used-by-list p) nil) + (equal (package-nicknames p) nil) + (equal (package-shadowing-symbols p) nil) + (null (documentation p t)) + ))))) + (error (c) c)) 0) ;; Test :nicknames option ;; Do not check use-list, because it is implementation dependent ;; Try several ways of specifying a nickname. (deftest defpackage-2 - (loop - for n in '("I" #:|I| #\I) count - (not - (ignore-errors - (progn - (ignore-errors (delete-package "H")) - (let ((p (ignore-errors - (eval `(defpackage "H" (:nicknames ,n "J")))))) - (and - (packagep p) - (equal (package-name p) "H") - ;; (equal (package-use-list p) nil) - (equal (package-used-by-list p) nil) - (equal (sort (copy-list (package-nicknames p)) - #'string<) - '("I" "J")) - (equal (package-shadowing-symbols p) nil) - (null (documentation p t)) - )))))) - 0) + (loop + for n in '("I" #:|I| #\I) count + (not + (ignore-errors + (progn + (ignore-errors (delete-package "H")) + (let ((p (ignore-errors + (eval `(defpackage "H" (:nicknames ,n "J")))))) + (and + (packagep p) + (equal (package-name p) "H") + ;; (equal (package-use-list p) nil) + (equal (package-used-by-list p) nil) + (equal (sort (copy-list (package-nicknames p)) + #'string<) + '("I" "J")) + (equal (package-shadowing-symbols p) nil) + (null (documentation p t)) + )))))) + 0) ;; Test defpackage with documentation option ;; Do not check use-list, because it is implementation dependent (deftest defpackage-3 - (progn - (ignore-errors (delete-package "H")) - (ignore-errors - (let ((p (eval '(defpackage "H" (:documentation "This is a doc string"))))) - (and - (packagep p) - (equal (package-name p) "H") - ;; (equal (package-use-list p) nil) - (equal (package-used-by-list p) nil) - (equal (package-nicknames p) nil) - (equal (package-shadowing-symbols p) nil) - (equal (documentation p t) - "This is a doc string") - )))) + (progn + (ignore-errors (delete-package "H")) + (ignore-errors + (let ((p (eval '(defpackage "H" (:documentation "This is a doc string"))))) + (and + (packagep p) + (equal (package-name p) "H") + ;; (equal (package-use-list p) nil) + (equal (package-used-by-list p) nil) + (equal (package-nicknames p) nil) + (equal (package-shadowing-symbols p) nil) + (equal (documentation p t) "This is a doc string") + t)))) t) ;; Check use argument ;; Try several ways of specifying the package to be used (deftest defpackage-4 - (loop - for n in '("A" :|A| #\A) count - (not - (ignore-errors - (progn - (ignore-errors (delete-package "H")) - (let ((p (ignore-errors (eval `(defpackage "H" (:use ,n)))))) - (and - (packagep p) - (equal (package-name p) "H") - (equal (package-use-list p) (list (find-package "A"))) - (equal (package-used-by-list p) nil) - (equal (package-nicknames p) nil) - (equal (package-shadowing-symbols p) nil) - (eql (num-symbols-in-package p) - (num-external-symbols-in-package "A")) - (equal (documentation p t) nil) - )))))) + (loop + for n in '("A" :|A| #\A) count + (not + (ignore-errors + (progn + (ignore-errors (delete-package "H")) + (let ((p (ignore-errors (eval `(defpackage "H" (:use ,n)))))) + (and + (packagep p) + (equal (package-name p) "H") + (equal (package-use-list p) (list (find-package "A"))) + (equal (package-used-by-list p) nil) + (equal (package-nicknames p) nil) + (equal (package-shadowing-symbols p) nil) + (eql (num-symbols-in-package p) + (num-external-symbols-in-package "A")) + (equal (documentation p t) nil) + )))))) 0) ;; Test defpackage shadow option, and null use (deftest defpackage-5 - (progn - (ignore-errors (delete-package "H")) - (ignore-errors - (let ((p (ignore-errors (eval `(defpackage "H" (:use) - (:shadow "foo")))))) + (progn + (ignore-errors (delete-package "H")) + (ignore-errors + (let ((p (ignore-errors (eval `(defpackage "H" (:use) + (:shadow "foo")))))) + (mapcar + #'notnot (list (not (not (packagep p))) (equal (package-name p) "H") @@ -115,45 +116,47 @@ (equal (package-nicknames p) nil) (eql (num-symbols-in-package p) 1) (multiple-value-bind (sym access) - (find-symbol "foo" p) - (and (eq access :internal) - (equal (symbol-name sym) "foo") - (equal (symbol-package sym) p) - (equal (package-shadowing-symbols p) - (list sym)))) + (find-symbol "foo" p) + (and (eqt access :internal) + (equal (symbol-name sym) "foo") + (equal (symbol-package sym) p) + (equal (package-shadowing-symbols p) + (list sym)))) (equal (documentation p t) nil) - )))) - (t t t t t t t t)) + ))))) + (t t t t t t t t)) ;; Test defpackage shadow and null use, with several ways ;; of specifying the name of the shadowed symbol (deftest defpackage-6 - (loop - for s in '(:|f| #\f) - collect - (ignore-errors - (ignore-errors (delete-package "H")) - (let ((p (ignore-errors (eval `(defpackage "H" - (:use) - (:shadow ,s)))))) - (list - (not (not (packagep p))) - (equal (package-name p) "H") - (equal (package-use-list p) nil) - (equal (package-used-by-list p) nil) - (equal (package-nicknames p) nil) - (eql (num-symbols-in-package p) 1) - (multiple-value-bind (sym access) - (find-symbol "f" p) - (and (eq access :internal) - (equal (symbol-name sym) "f") - (equal (symbol-package sym) p) - (equal (package-shadowing-symbols p) - (list sym)))) - (equal (documentation p t) nil) - )))) - ((t t t t t t t t) - (t t t t t t t t))) + (loop + for s in '(:|f| #\f) + collect + (ignore-errors + (ignore-errors (delete-package "H")) + (let ((p (ignore-errors (eval `(defpackage "H" + (:use) + (:shadow ,s)))))) + (mapcar + #'notnot + (list + (not (not (packagep p))) + (equal (package-name p) "H") + (equal (package-use-list p) nil) + (equal (package-used-by-list p) nil) + (equal (package-nicknames p) nil) + (eql (num-symbols-in-package p) 1) + (multiple-value-bind (sym access) + (find-symbol "f" p) + (and (eqt access :internal) + (equal (symbol-name sym) "f") + (equal (symbol-package sym) p) + (equal (package-shadowing-symbols p) + (list sym)))) + (equal (documentation p t) nil) + ))))) + ((t t t t t t t t) + (t t t t t t t t))) ;; Testing defpackage with shadowing-import-from. @@ -179,22 +182,24 @@ `(defpackage "H" (:use) (:shadowing-import-from "G" ,n)))))) - (list - (not (not (packagep p))) - (equal (package-name p) "H") - (equal (package-use-list p) nil) - (equal (package-used-by-list p) nil) - (equal (package-nicknames p) nil) - (eql (num-symbols-in-package p) 1) - (multiple-value-bind (sym access) - (find-symbol "A" p) - (and (eq access :internal) - (equal (symbol-name sym) "A") - (equal (symbol-package sym) pg) - (equal (package-shadowing-symbols p) - (list sym)))) - (equal (documentation p t) nil) - )))))) + (mapcar + #'notnot + (list + (not (not (packagep p))) + (equal (package-name p) "H") + (equal (package-use-list p) nil) + (equal (package-used-by-list p) nil) + (equal (package-nicknames p) nil) + (eql (num-symbols-in-package p) 1) + (multiple-value-bind (sym access) + (find-symbol "A" p) + (and (eqt access :internal) + (equal (symbol-name sym) "A") + (equal (symbol-package sym) pg) + (equal (package-shadowing-symbols p) + (list sym)))) + (equal (documentation p t) nil) + ))))))) ((t t t t t t t t) (t t t t t t t t) (t t t t t t t t))) @@ -220,26 +225,28 @@ (eval `(defpackage "H" (:use) (:import-from ,pn ,n "A")))))) - (list - (not (not (packagep p))) - (equal (package-name p) "H") - (equal (package-use-list p) nil) - (equal (package-used-by-list p) nil) - (equal (package-nicknames p) nil) - (equal (package-shadowing-symbols p) nil) - (eql (num-symbols-in-package p) 2) - (multiple-value-bind (sym access) - (find-symbol "A" p) - (and (eq access :internal) - (equal (symbol-name sym) "A") - (equal (symbol-package sym) pg))) - (multiple-value-bind (sym access) - (find-symbol "B" p) - (and (eq access :internal) - (equal (symbol-name sym) "B") - (equal (symbol-package sym) pg))) - (equal (documentation p t) nil) - ))))))) + (mapcar + #'notnot + (list + (not (not (packagep p))) + (equal (package-name p) "H") + (equal (package-use-list p) nil) + (equal (package-used-by-list p) nil) + (equal (package-nicknames p) nil) + (equal (package-shadowing-symbols p) nil) + (eql (num-symbols-in-package p) 2) + (multiple-value-bind (sym access) + (find-symbol "A" p) + (and (eqt access :internal) + (equal (symbol-name sym) "A") + (equal (symbol-package sym) pg))) + (multiple-value-bind (sym access) + (find-symbol "B" p) + (and (eqt access :internal) + (equal (symbol-name sym) "B") + (equal (symbol-package sym) pg))) + (equal (documentation p t) nil) + )))))))) (((t t t t t t t t t t) (t t t t t t t t t t) (t t t t t t t t t t)) ((t t t t t t t t t t) (t t t t t t t t t t) (t t t t t t t t t t)) ((t t t t t t t t t t) (t t t t t t t t t t) (t t t t t t t t t t)))) @@ -257,25 +264,27 @@ (eval `(defpackage "H" (:export "Q" ,n "R") (:use)))))) - (list - (not (not (packagep p))) - (equal (package-name p) "H") - (equal (package-use-list p) nil) - (equal (package-used-by-list p) nil) - (equal (package-nicknames p) nil) - (equal (package-shadowing-symbols p) nil) - (eql (num-symbols-in-package p) 3) - (loop - for s in '("Q" "Z" "R") do - (unless - (multiple-value-bind (sym access) - (find-symbol s p) - (and (eq access :external) - (equal (symbol-name sym) s) - (equal (symbol-package sym) p))) - (return nil)) - finally (return t)) - ))))) + (mapcar + #'notnot + (list + (not (not (packagep p))) + (equal (package-name p) "H") + (equal (package-use-list p) nil) + (equal (package-used-by-list p) nil) + (equal (package-nicknames p) nil) + (equal (package-shadowing-symbols p) nil) + (eql (num-symbols-in-package p) 3) + (loop + for s in '("Q" "Z" "R") do + (unless + (multiple-value-bind (sym access) + (find-symbol s p) + (and (eqt access :external) + (equal (symbol-name sym) s) + (equal (symbol-package sym) p))) + (return nil)) + finally (return t)) + )))))) ((t t t t t t t t)(t t t t t t t t)(t t t t t t t t))) ;; Test defpackage with the intern option @@ -291,25 +300,27 @@ (eval `(defpackage "H" (:intern "Q" ,n "R") (:use)))))) - (list - (not (not (packagep p))) - (equal (package-name p) "H") - (equal (package-use-list p) nil) - (equal (package-used-by-list p) nil) - (equal (package-nicknames p) nil) - (equal (package-shadowing-symbols p) nil) - (eql (num-symbols-in-package p) 3) - (loop - for s in '("Q" "Z" "R") do - (unless - (multiple-value-bind (sym access) - (find-symbol s p) - (and (eq access :internal) - (equal (symbol-name sym) s) - (equal (symbol-package sym) p))) - (return nil)) - finally (return t)) - ))))) + (mapcar + #'notnot + (list + (not (not (packagep p))) + (equal (package-name p) "H") + (equal (package-use-list p) nil) + (equal (package-used-by-list p) nil) + (equal (package-nicknames p) nil) + (equal (package-shadowing-symbols p) nil) + (eql (num-symbols-in-package p) 3) + (loop + for s in '("Q" "Z" "R") do + (unless + (multiple-value-bind (sym access) + (find-symbol s p) + (and (eqt access :internal) + (equal (symbol-name sym) s) + (equal (symbol-package sym) p))) + (return nil)) + finally (return t)) + )))))) ((t t t t t t t t) (t t t t t t t t) (t t t t t t t t))) ;; Test defpackage with size @@ -319,14 +330,16 @@ (ignore-errors (delete-package "H")) (let ((p (ignore-errors (eval '(defpackage "H" (:use) (:size 0)))))) - (list - (not (not (packagep p))) - (equal (package-name p) "H") - (equal (package-use-list p) nil) - (equal (package-used-by-list p) nil) - (equal (package-nicknames p) nil) - (equal (package-shadowing-symbols p) nil) - (not (not (zerop (num-symbols-in-package p))))))) + (mapcar + #'notnot + (list + (packagep p) + (equal (package-name p) "H") + (equal (package-use-list p) nil) + (equal (package-used-by-list p) nil) + (equal (package-nicknames p) nil) + (equal (package-shadowing-symbols p) nil) + (zerop (num-symbols-in-package p)))))) (t t t t t t t)) (deftest defpackage-12 @@ -334,14 +347,16 @@ (ignore-errors (delete-package "H")) (let ((p (ignore-errors (eval '(defpackage "H" (:use) (:size 10000)))))) - (list - (not (not (packagep p))) - (equal (package-name p) "H") - (equal (package-use-list p) nil) - (equal (package-used-by-list p) nil) - (equal (package-nicknames p) nil) - (equal (package-shadowing-symbols p) nil) - (not (not (zerop (num-symbols-in-package p))))))) + (mapcar + #'notnot + (list + (packagep p) + (equal (package-name p) "H") + (equal (package-use-list p) nil) + (equal (package-used-by-list p) nil) + (equal (package-nicknames p) nil) + (equal (package-shadowing-symbols p) nil) + (zerop (num-symbols-in-package p)))))) (t t t t t t t)) ;; defpackage error handling @@ -358,37 +373,37 @@ ;; Repeated documentation field should cause a program-error (deftest defpackage-14 - (progn - (ignore-errors (delete-package "H")) - (handler-case - (eval '(defpackage "H" (:use) - (:documentation "foo") - (:documentation "bar"))) - (program-error () 'program-error) - (error (c) c))) + (progn + (ignore-errors (delete-package "H")) + (handler-case + (eval '(defpackage "H" (:use) + (:documentation "foo") + (:documentation "bar"))) + (program-error () 'program-error) + (error (c) c))) program-error) ;; When a nickname refers to an existing package or nickname, ;; signal a package-error (deftest defpackage-15 - (progn - (ignore-errors (delete-package "H")) - (handler-case - (eval '(defpackage "H" (:use) - (:nicknames "A"))) - (package-error () 'package-error) - (error (c) c))) + (progn + (ignore-errors (delete-package "H")) + (handler-case + (eval '(defpackage "H" (:use) + (:nicknames "A"))) + (package-error () 'package-error) + (error (c) c))) package-error) (deftest defpackage-16 - (progn - (ignore-errors (delete-package "H")) - (handler-case - (eval '(defpackage "H" (:use) - (:nicknames "Q"))) - (package-error () 'package-error) - (error (c) c))) + (progn + (ignore-errors (delete-package "H")) + (handler-case + (eval '(defpackage "H" (:use) + (:nicknames "Q"))) + (package-error () 'package-error) + (error (c) c))) package-error) ;; Names in :shadow, :shadowing-import-from, :import-from, and :intern @@ -396,132 +411,132 @@ ;; :shadow and :shadowing-import-from (deftest defpackage-17 - (ignore-errors - (ignore-errors (delete-package "H")) - (ignore-errors (delete-package "G")) - (eval '(defpackage "G" (:use) (:export "A"))) - (handler-case - (eval '(defpackage "H" (:use) - (:shadow "A") - (:shadowing-import-from "G" "A"))) - (program-error () 'program-error) - (error (c) c))) + (ignore-errors + (ignore-errors (delete-package "H")) + (ignore-errors (delete-package "G")) + (eval '(defpackage "G" (:use) (:export "A"))) + (handler-case + (eval '(defpackage "H" (:use) + (:shadow "A") + (:shadowing-import-from "G" "A"))) + (program-error () 'program-error) + (error (c) c))) program-error) ;; :shadow and :import-from (deftest defpackage-18 - (ignore-errors - (ignore-errors (delete-package "H")) - (ignore-errors (delete-package "G")) - (eval '(defpackage "G" (:use) (:export "A"))) - (handler-case - (eval '(defpackage "H" (:use) - (:shadow "A") - (:import-from "G" "A"))) - (program-error () 'program-error) - (error (c) c))) + (ignore-errors + (ignore-errors (delete-package "H")) + (ignore-errors (delete-package "G")) + (eval '(defpackage "G" (:use) (:export "A"))) + (handler-case + (eval '(defpackage "H" (:use) + (:shadow "A") + (:import-from "G" "A"))) + (program-error () 'program-error) + (error (c) c))) program-error) ;; :shadow and :intern (deftest defpackage-19 - (progn - (ignore-errors (delete-package "H")) - (handler-case - (eval '(defpackage "H" (:use) - (:shadow "A") - (:intern "A"))) - (program-error () 'program-error) - (error (c) c))) + (progn + (ignore-errors (delete-package "H")) + (handler-case + (eval '(defpackage "H" (:use) + (:shadow "A") + (:intern "A"))) + (program-error () 'program-error) + (error (c) c))) program-error) ;; :shadowing-import-from and :import-from (deftest defpackage-20 - (ignore-errors - (ignore-errors (delete-package "H")) - (ignore-errors (delete-package "G")) - (eval '(defpackage "G" (:use) (:export "A"))) - (handler-case - (eval '(defpackage "H" (:use) - (:shadowing-import-from "G" "A") - (:import-from "G" "A"))) - (program-error () 'program-error) - (error (c) c))) + (ignore-errors + (ignore-errors (delete-package "H")) + (ignore-errors (delete-package "G")) + (eval '(defpackage "G" (:use) (:export "A"))) + (handler-case + (eval '(defpackage "H" (:use) + (:shadowing-import-from "G" "A") + (:import-from "G" "A"))) + (program-error () 'program-error) + (error (c) c))) program-error) ;; :shadowing-import-from and :intern (deftest defpackage-21 - (ignore-errors - (ignore-errors (delete-package "H")) - (ignore-errors (delete-package "G")) - (eval '(defpackage "G" (:use) (:export "A"))) - (handler-case - (eval '(defpackage "H" (:use) - (:shadowing-import-from "G" "A") - (:intern "A"))) - (program-error () 'program-error) - (error (c) c))) + (ignore-errors + (ignore-errors (delete-package "H")) + (ignore-errors (delete-package "G")) + (eval '(defpackage "G" (:use) (:export "A"))) + (handler-case + (eval '(defpackage "H" (:use) + (:shadowing-import-from "G" "A") + (:intern "A"))) + (program-error () 'program-error) + (error (c) c))) program-error) ;; :import-from and :intern (deftest defpackage-22 - (ignore-errors - (ignore-errors (delete-package "H")) - (ignore-errors (delete-package "G")) - (eval '(defpackage "G" (:use) (:export "A"))) - (handler-case - (eval '(defpackage "H" (:use) - (:import-from "G" "A") - (:intern "A"))) - (program-error () 'program-error) - (error (c) c))) + (ignore-errors + (ignore-errors (delete-package "H")) + (ignore-errors (delete-package "G")) + (eval '(defpackage "G" (:use) (:export "A"))) + (handler-case + (eval '(defpackage "H" (:use) + (:import-from "G" "A") + (:intern "A"))) + (program-error () 'program-error) + (error (c) c))) program-error) ;; Names given to :export and :intern must be disjoint, ;; otherwise signal a program-error (deftest defpackage-23 - (ignore-errors - (ignore-errors (delete-package "H")) - (handler-case - (eval '(defpackage "H" (:use) - (:export "A") - (:intern "A"))) - (program-error () 'program-error) - (error (c) c))) + (ignore-errors + (ignore-errors (delete-package "H")) + (handler-case + (eval '(defpackage "H" (:use) + (:export "A") + (:intern "A"))) + (program-error () 'program-error) + (error (c) c))) program-error) ;; :shadowing-import-from signals a correctable package-error ;; if the symbol is not accessible in the named package (deftest defpackage-24 - (ignore-errors - (ignore-errors (delete-package "H")) - (ignore-errors (delete-package "G")) - (eval '(defpackage "G" (:use))) - (handler-case - (eval '(defpackage "H" (:shadowing-import-from "G" "NOT-THERE"))) - (package-error (c) - (if (position 'abort (compute-restarts c) - :key #'restart-name :test-not #'eq) - 'success - 'fail)) - (error (c) c))) + (ignore-errors + (ignore-errors (delete-package "H")) + (ignore-errors (delete-package "G")) + (eval '(defpackage "G" (:use))) + (handler-case + (eval '(defpackage "H" (:shadowing-import-from "G" "NOT-THERE"))) + (package-error (c) + (if (position 'abort (compute-restarts c) + :key #'restart-name :test-not #'eq) + 'success + 'fail)) + (error (c) c))) success) ;; :import-from signals a correctable package-error if a symbol with ;; the indicated name is not accessible in the package indicated (deftest defpackage-25 - (ignore-errors - (ignore-errors (delete-package "H")) - (ignore-errors (delete-package "G")) - (eval '(defpackage "G" (:use))) - (handler-case - (eval '(defpackage "H" (:import-from "G" "NOT-THERE"))) - (package-error (c) - (if (position 'abort (compute-restarts c) - :key #'restart-name :test-not #'eq) - 'success - 'fail)) - (error (c) c))) + (ignore-errors + (ignore-errors (delete-package "H")) + (ignore-errors (delete-package "G")) + (eval '(defpackage "G" (:use))) + (handler-case + (eval '(defpackage "H" (:import-from "G" "NOT-THERE"))) + (package-error (c) + (if (position 'abort (compute-restarts c) + :key #'restart-name :test-not #'eq) + 'success + 'fail)) + (error (c) c))) success) ;; A big test that combines all the options to defpackage @@ -529,90 +544,92 @@ (deftest defpackage-26 (ignore-errors (flet - ((%do-it% (args) - (ignore-errors (delete-package "H")) - (ignore-errors (delete-package "G1")) - (ignore-errors (delete-package "G2")) - (ignore-errors (delete-package "G3")) - (let ((pg1 - (progn - (format t "Making G1...~%") - (eval '(defpackage "G1" + ((%do-it% + (args) + (ignore-errors (delete-package "H")) + (ignore-errors (delete-package "G1")) + (ignore-errors (delete-package "G2")) + (ignore-errors (delete-package "G3")) + (let ((pg1 + (progn + (format t "Making G1...~%") + (eval '(defpackage "G1" (:use) (:export "A" "B" "C") (:intern "D" "E" "F"))))) - (pg2 - (progn - (format t "Making G2...~%") - (eval '(defpackage "G2" + (pg2 + (progn + (format t "Making G2...~%") + (eval '(defpackage "G2" (:use) (:export "A" "D" "G") (:intern "E" "H" "I"))))) - (pg3 - (progn - (format t "Making G3...~%") - (eval '(defpackage "G3" + (pg3 + (progn + (format t "Making G3...~%") + (eval '(defpackage "G3" (:use) (:export "J" "K" "L") (:intern "M" "N" "O")))))) - (let ((p (eval (list* 'defpackage "H" (copy-tree args))))) - (prog () - (unless (packagep p) (return 1)) - (unless (equal (package-name p) "H") (return 2)) - (unless (equal (package-name pg1) "G1") (return 3)) - (unless (equal (package-name pg2) "G2") (return 4)) - (unless (equal (package-name pg3) "G3") (return 5)) - (unless - (equal (sort (copy-list (package-nicknames p)) #'string<) - '("H1" "H2")) - (return 6)) + (let ((p (eval (list* 'defpackage "H" (copy-tree args))))) + (prog + () + (unless (packagep p) (return 1)) + (unless (equal (package-name p) "H") (return 2)) + (unless (equal (package-name pg1) "G1") (return 3)) + (unless (equal (package-name pg2) "G2") (return 4)) + (unless (equal (package-name pg3) "G3") (return 5)) + (unless + (equal (sort (copy-list (package-nicknames p)) #'string<) + '("H1" "H2")) + (return 6)) + (unless + (or + (equal (package-use-list p) (list pg1 pg2)) + (equal (package-use-list p) (list pg2 pg1))) + (return 7)) + (unless (equal (package-used-by-list pg1) (list p)) + (return 8)) + (unless (equal (package-used-by-list pg2) (list p)) + (return 9)) + (when (package-used-by-list pg3) (return 10)) + (unless (equal (sort (mapcar #'symbol-name + (package-shadowing-symbols p)) + #'string<) + '("A" "B")) + (return 10)) + (let ((num 11)) (unless - (or - (equal (package-use-list p) (list pg1 pg2)) - (equal (package-use-list p) (list pg2 pg1))) - (return 7)) - (unless (equal (package-used-by-list pg1) (list p)) - (return 8)) - (unless (equal (package-used-by-list pg2) (list p)) - (return 9)) - (when (package-used-by-list pg3) (return 10)) - (unless (equal (sort (mapcar #'symbol-name - (package-shadowing-symbols p)) - #'string<) - '("A" "B")) - (return 10)) - (let ((num 11)) - (unless - (every - #'(lambda (str acc pkg) - (multiple-value-bind - (sym access) - (find-symbol str p) - (or - (and (or (not acc) (equal (symbol-name sym) str)) - (or (not acc) (equal (symbol-package sym) pkg)) - (equal access acc) - (incf num)) - (progn - (format t - "Failed on str = ~S, acc = ~S, pkg = ~S, sym = ~S, access = ~S~%" - str acc pkg sym access) - nil)))) - (list "A" "B" "C" "D" "E" "F" "G" - "H" "I" "J" "K" "L" "M" "N" "O") - (list :internal :internal - :external :inherited - nil nil - :inherited :internal - nil nil - nil :external - nil nil - :internal) - (list pg2 p pg1 pg2 nil nil - pg2 p nil nil nil pg3 - nil nil pg3)) - (return num))) - (return 'success)))))) + (every + #'(lambda (str acc pkg) + (multiple-value-bind + (sym access) + (find-symbol str p) + (or + (and (or (not acc) (equal (symbol-name sym) str)) + (or (not acc) (equal (symbol-package sym) pkg)) + (equal access acc) + (incf num)) + (progn + (format t + "Failed on str = ~S, acc = ~S, pkg = ~S, sym = ~S, access = ~S~%" + str acc pkg sym access) + nil)))) + (list "A" "B" "C" "D" "E" "F" "G" + "H" "I" "J" "K" "L" "M" "N" "O") + (list :internal :internal + :external :inherited + nil nil + :inherited :internal + nil nil + nil :external + nil nil + :internal) + (list pg2 p pg1 pg2 nil nil + pg2 p nil nil nil pg3 + nil nil pg3)) + (return num))) + (return 'success)))))) (let ((args '((:nicknames "H1" "H2") (:use "G1" "G2") (:shadow "B") @@ -627,4 +644,5 @@ (success success)) + diff --git a/ansi-tests/packages-17.lsp b/ansi-tests/packages-17.lsp index 6dbef1976a478c213aa3bf3ca5e3a0be680fc8a7..edb0931e005548606d8dcbff56bf1adf5aa2718a 100644 --- a/ansi-tests/packages-17.lsp +++ b/ansi-tests/packages-17.lsp @@ -44,8 +44,8 @@ (remove-duplicates (collect-symbols "DS4") :test #'(lambda (x y) - (and (eq x y) - (not (eq x 'DS4::B))))) + (and (eqt x y) + (not (eqt x 'DS4::B))))) (DS1:A DS1:B DS2::F DS3:G DS3:I DS3:J DS3:K DS4::X DS4::Y DS4::Z)) @@ -66,15 +66,15 @@ ()) (deftest do-external-symbols-5 - (equal (collect-external-symbols "KEYWORD") - (collect-symbols "KEYWORD")) - t) + (not (equal (collect-external-symbols "KEYWORD") + (collect-symbols "KEYWORD"))) + nil) ;; Test that do-symbols, do-external-symbols work without ;; a return value (and that the default return value is nil) (deftest do-symbols-6 - (do-symbols (s "DS1") (declare (ignore s)) t) + (do-symbols (s "DS1") (declare (ignore s)) t) nil) (deftest do-external-symbols-6 diff --git a/ansi-tests/packages-18.lsp b/ansi-tests/packages-18.lsp index 662a232e9680148971546bff01988a69a77b92dd..fccc062f2c744e915c62a9baa2b42d0304886c57 100644 --- a/ansi-tests/packages-18.lsp +++ b/ansi-tests/packages-18.lsp @@ -14,8 +14,8 @@ (deftest packagep-1 (loop for x in *universe* count - (unless (eq (not (not (packagep x))) - (not (not (typep x 'package)))) + (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)) @@ -25,51 +25,51 @@ ;; *package* is always a package (deftest packagep-2 - (not (not (packagep *package*))) - t) + (not (packagep *package*)) + nil) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; package-error (deftest package-error-1 - (not (not - (typep (make-condition 'package-error :package "CL") - 'package-error))) - t) + (not + (typep (make-condition 'package-error :package "CL") + 'package-error)) + nil) (deftest package-error-2 - (not (not - (typep (make-condition 'package-error - :package (find-package "CL")) - 'package-error))) - t) + (not + (typep (make-condition 'package-error + :package (find-package "CL")) + 'package-error)) + nil) (deftest package-error-3 - (subtypep 'package-error 'error) + (subtypep* 'package-error 'error) t t) (deftest package-error-4 - (not (not - (typep (make-condition 'package-error - :package (find-package '#:|CL|)) - 'package-error))) - t) + (not + (typep (make-condition 'package-error + :package (find-package '#:|CL|)) + 'package-error)) + nil) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; package-error-package (deftest package-error-package-1 (handler-case - (eq (find-package (package-error-package - (make-condition 'package-error - :package "CL"))) - (find-package "CL")) + (eqt (find-package (package-error-package + (make-condition 'package-error + :package "CL"))) + (find-package "CL")) (error (c) c)) t) (deftest package-error-package-2 (handler-case - (eq (find-package (package-error-package + (eqt (find-package (package-error-package (make-condition 'package-error :package (find-package "CL")))) (find-package "CL")) @@ -78,7 +78,7 @@ (deftest package-error-package-3 (handler-case - (eq (find-package (package-error-package + (eqt (find-package (package-error-package (make-condition 'package-error :package '#:|CL|))) (find-package "CL")) @@ -87,7 +87,7 @@ (deftest package-error-package-4 (handler-case - (eq (find-package (package-error-package + (eqt (find-package (package-error-package (make-condition 'package-error :package #\A))) (find-package "A")) diff --git a/ansi-tests/packages-19.lsp b/ansi-tests/packages-19.lsp index 0d984c71f485636b0eeb3c1ba997a0d3b284d021..07ec6a8e4c93f470aceff13a93d36391dd4514e9 100644 --- a/ansi-tests/packages-19.lsp +++ b/ansi-tests/packages-19.lsp @@ -20,15 +20,15 @@ (do-symbols (s "KEYWORD" t) (multiple-value-bind (s2 access) (find-symbol (symbol-name s) "KEYWORD") - (unless (and (eq s s2) - (eq access :external)) + (unless (and (eqt s s2) + (eqt access :external)) (return (list s2 access))))) t) ;; Every keyword evaluates to itself (deftest keyword-3 (do-symbols (s "KEYWORD" t) - (unless (eq s (eval s)) + (unless (eqt s (eval s)) (return (list s (eval s))))) t) diff --git a/ansi-tests/reader-test.lsp b/ansi-tests/reader-test.lsp index 817de73a728dc7595c7a22ae877189fb87e50ead..fb019206b3c08c71e736984551c1281eb9c92a7e 100644 --- a/ansi-tests/reader-test.lsp +++ b/ansi-tests/reader-test.lsp @@ -47,69 +47,61 @@ |a| 3) (deftest read-symbol-3 - (multiple-value-bind (s n) - (ignore-errors (read-from-string "#:abc")) - (and (symbolp s) - (eql n 5) - (not (symbol-package s)) - (string-equal (symbol-name s) "abc"))) - t) + (multiple-value-bind (s n) + (ignore-errors (read-from-string "#:abc")) + (not + (and (symbolp s) + (eql n 5) + (not (symbol-package s)) + (string-equal (symbol-name s) "abc")))) + nil) (deftest read-symbol-4 - (multiple-value-bind (s n) - (ignore-errors (read-from-string "#:|abc|")) - (and (symbolp s) - (eql n 7) - (not (symbol-package s)) - (string= (symbol-name s) "abc"))) - t) + (multiple-value-bind (s n) + (ignore-errors (read-from-string "#:|abc|")) + (not + (and (symbolp s) + (eql n 7) + (not (symbol-package s)) + (string= (symbol-name s) "abc")))) + nil) (deftest read-symbol-5 - (multiple-value-bind (s n) - (ignore-errors (read-from-string "#:||")) - (if (not (symbolp s)) - s - (and (eql n 4) - (not (symbol-package s)) - (string= (symbol-name s) "")))) + (multiple-value-bind (s n) + (ignore-errors (read-from-string "#:||")) + (if (not (symbolp s)) + s + (not (not + (and (eql n 4) + (not (symbol-package s)) + (string= (symbol-name s) "")))))) t) (deftest read-symbol-6 - (let ((str "cl-test::abcd0123")) - (multiple-value-bind (s n) - (ignore-errors (read-from-string str)) - (if (not (symbolp s)) - s - (and (eql n (length str)) - (eq (symbol-package s) (find-package :cl-test)) - (string-equal (symbol-name s) - "abcd0123"))))) - t) - -(deftest read-symbol-7 + (let ((str "cl-test::abcd0123")) (multiple-value-bind (s n) - (ignore-errors (read-from-string ":ABCD")) + (ignore-errors (read-from-string str)) (if (not (symbolp s)) s - (and (eql n 5) - (eq (symbol-package s) (find-package "KEYWORD")) - (string-equal (symbol-name s) - "ABCD")))) + (not (not + (and (eql n (length str)) + (eqt (symbol-package s) (find-package :cl-test)) + (string-equal (symbol-name s) + "abcd0123"))))))) t) - -#| -(deftest read-symbol-8 - (multiple-value-bind (s n) - (ignore-errors (read-from-string "::ABCD")) - (if (not (symbolp s)) - s - (and (eql n 6) - (eq (symbol-package s) (find-package "KEYWORD")) - (string-equal (symbol-name s) - "ABCD")))) - t) -|# +(deftest read-symbol-7 + (multiple-value-bind (s n) + (ignore-errors (read-from-string ":ABCD")) + (if (not (symbolp s)) + s + (not (not + (and (eql n 5) + (eqt (symbol-package s) (find-package "KEYWORD")) + (string-equal (symbol-name s) + "ABCD")))))) + t) + (defun read-symbol-9-body (natoms maxlen) (let* ((chars (concatenate 'string "abcdefghijklmnopqrstuvwxyz" @@ -149,15 +141,16 @@ 0) (deftest read-symbol-10 - (handler-case - (equal (symbol-name - (read-from-string - (with-output-to-string (s) - (write (make-symbol ":") - :readably t - :stream s)))) - ":") - (error (c) c)) + (handler-case + (not (not + (equal (symbol-name + (read-from-string + (with-output-to-string (s) + (write (make-symbol ":") + :readably t + :stream s)))) + ":"))) + (error (c) c)) t) diff --git a/ansi-tests/remove-aux.lsp b/ansi-tests/remove-aux.lsp index fc697dff6a8bcab0427324c9e2fc231f1a6a53b9..f46f51e1217bef66b315dfba4d65e7264514db06 100644 --- a/ansi-tests/remove-aux.lsp +++ b/ansi-tests/remove-aux.lsp @@ -7,17 +7,17 @@ (defun make-random-element (type) (cond - ((subtypep 'fixnum type) + ((subtypep* 'fixnum type) (random most-positive-fixnum)) - ((subtypep '(integer 0 255) type) + ((subtypep* '(integer 0 255) type) (random 255)) - ((subtypep '(integer 0 7) type) + ((subtypep* '(integer 0 7) type) (random 8)) - ((subtypep 'bit type) + ((subtypep* 'bit type) (random 2)) - ((subtypep 'symbol type) + ((subtypep* 'symbol type) (elt '(a b c d e f g h) (random 8))) - ((subtypep '(member #\a #\b #\c #\d #\e #\f #\g #\h) type) + ((subtypep* '(member #\a #\b #\c #\d #\e #\f #\g #\h) type) (elt "abcdefgh" (random 8))) (t (error "Can't get random element of type ~A~%." type)))) @@ -29,7 +29,7 @@ generate a random member of the sequence or a random element of the element type to delete from the sequence." - (let* ((seq (if (subtypep type 'list) + (let* ((seq (if (subtypep* type 'list) (loop for i from 1 to len collect (make-random-element element-type)) (let ((seq (make-sequence type len))) @@ -109,6 +109,9 @@ :initial-contents result)))))) (defun my-remove-if-not (pred &rest args) + (when (symbolp pred) + (setq pred (coerce pred 'function))) + (assert (typep pred 'function)) (apply #'my-remove-if (complement pred) args)) (defun make-random-rd-params (maxlen) diff --git a/ansi-tests/remove.lsp b/ansi-tests/remove.lsp index f879f526d927335a3b44e6a71215102eda1280fe..7a1ea22518093a5e74a19c85e3ad7a5c24d4170c 100644 --- a/ansi-tests/remove.lsp +++ b/ansi-tests/remove.lsp @@ -310,7 +310,7 @@ (deftest remove-if-list.2 (let* ((orig '(a b c a b d a c b a e)) (x (copy-seq orig)) - (y (remove-if #'(lambda (y) (eq y 'a)) x :key nil))) + (y (remove-if #'(lambda (y) (eqt y 'a)) x :key nil))) (and (equalp orig x) y)) (b c b d c b e)) @@ -324,7 +324,7 @@ (deftest remove-if-not-list.2 (let* ((orig '(a b c a b d a c b a e)) (x (copy-seq orig)) - (y (remove-if-not #'(lambda (y) (not (eq y 'a))) x :key nil))) + (y (remove-if-not #'(lambda (y) (not (eqt y 'a))) x :key nil))) (and (equalp orig x) y)) (b c b d c b e)) @@ -338,7 +338,7 @@ (deftest delete-if-list.2 (let* ((orig '(a b c a b d a c b a e)) (x (copy-seq orig)) - (y (delete-if #'(lambda (y) (eq y 'a)) x :key nil))) + (y (delete-if #'(lambda (y) (eqt y 'a)) x :key nil))) y) (b c b d c b e)) @@ -352,7 +352,7 @@ (deftest delete-if-not-list.2 (let* ((orig '(a b c a b d a c b a e)) (x (copy-seq orig)) - (y (delete-if-not #'(lambda (y) (not (eq y 'a))) x :key nil))) + (y (delete-if-not #'(lambda (y) (not (eqt y 'a))) x :key nil))) y) (b c b d c b e)) diff --git a/ansi-tests/replace.lsp b/ansi-tests/replace.lsp index 35bf6ad24a278a1b1fc26b94435c72539373bbbd..64289caf5c36f354ac236ed513712b288e47ff85 100644 --- a/ansi-tests/replace.lsp +++ b/ansi-tests/replace.lsp @@ -8,42 +8,42 @@ (deftest replace-list.1 (let* ((x (copy-seq '(a b c d e f g))) (result (replace x '(x y z)))) - (values (eq x result) result)) + (values (eqt x result) result)) t (x y z d e f g)) (deftest replace-list.2 (let* ((x (copy-seq '(a b c d e f g))) (result (replace x '(x y z) :start1 1))) - (values (eq x result) result)) + (values (eqt x result) result)) t (a x y z e f g)) (deftest replace-list.3 (let* ((x (copy-seq '(a b c d e f g))) (result (replace x '(x y z) :start1 4))) - (values (eq x result) result)) + (values (eqt x result) result)) t (a b c d x y z)) (deftest replace-list.4 (let* ((x (copy-seq '(a b c d e f g))) (result (replace x '(x y z) :start1 5))) - (values (eq x result) result)) + (values (eqt x result) result)) t (a b c d e x y)) (deftest replace-list.5 (let* ((x (copy-seq '(a b c d e f g))) (result (replace x '(x y z) :start1 6))) - (values (eq x result) result)) + (values (eqt x result) result)) t (a b c d e f x)) (deftest replace-list.6 (let* ((x (copy-seq '(a b c d e f g))) (result (replace x #(x y z) :start1 2))) - (values (eq x result) result)) + (values (eqt x result) result)) t (a b x y z f g)) @@ -54,21 +54,21 @@ (deftest replace-list.8 (let* ((x (copy-seq '(a b c d e f g))) (result (replace x '(x y z) :end1 1))) - (values (eq x result) result)) + (values (eqt x result) result)) t (x b c d e f g)) (deftest replace-list.9 (let* ((x (copy-seq '(a b c d e f g))) (result (replace x '(x y z) :start1 3 :end1 4))) - (values (eq x result) result)) + (values (eqt x result) result)) t (a b c x e f g)) (deftest replace-list.10 (let* ((x (copy-seq '(a b c d e f g))) (result (replace x '(x y z) :start1 0 :end1 5))) - (values (eq x result) result)) + (values (eqt x result) result)) t (x y z d e f g)) @@ -76,35 +76,35 @@ (deftest replace-list.11 (let* ((x (copy-seq '(a b c d e f g))) (result (replace x '(x y z) :start2 1))) - (values (eq x result) result)) + (values (eqt x result) result)) t (y z c d e f g)) (deftest replace-list.12 (let* ((x (copy-seq '(a b c d e f g))) (result (replace x '(x y z) :start2 1 :end1 nil))) - (values (eq x result) result)) + (values (eqt x result) result)) t (y z c d e f g)) (deftest replace-list.13 (let* ((x (copy-seq '(a b c d e f g))) (result (replace x '(x y z) :start2 1 :end2 nil))) - (values (eq x result) result)) + (values (eqt x result) result)) t (y z c d e f g)) (deftest replace-list.14 (let* ((x (copy-seq '(a b c d e f g))) (result (replace x '(x y z) :start2 1 :end2 2))) - (values (eq x result) result)) + (values (eqt x result) result)) t (y b c d e f g)) (deftest replace-list.15 (let* ((x (copy-seq '(a b c d e f g))) (result (replace x '(x y z) :start1 4 :end1 5 :start2 1 :end2 2))) - (values (eq x result) result)) + (values (eqt x result) result)) t (a b c d y f g)) @@ -114,42 +114,42 @@ (deftest replace-vector.1 (let* ((x (copy-seq #(a b c d e f g))) (result (replace x #(x y z)))) - (values (eq x result) result)) + (values (eqt x result) result)) t #(x y z d e f g)) (deftest replace-vector.2 (let* ((x (copy-seq #(a b c d e f g))) (result (replace x #(x y z) :start1 1))) - (values (eq x result) result)) + (values (eqt x result) result)) t #(a x y z e f g)) (deftest replace-vector.3 (let* ((x (copy-seq #(a b c d e f g))) (result (replace x #(x y z) :start1 4))) - (values (eq x result) result)) + (values (eqt x result) result)) t #(a b c d x y z)) (deftest replace-vector.4 (let* ((x (copy-seq #(a b c d e f g))) (result (replace x #(x y z) :start1 5))) - (values (eq x result) result)) + (values (eqt x result) result)) t #(a b c d e x y)) (deftest replace-vector.5 (let* ((x (copy-seq #(a b c d e f g))) (result (replace x #(x y z) :start1 6))) - (values (eq x result) result)) + (values (eqt x result) result)) t #(a b c d e f x)) (deftest replace-vector.6 (let* ((x (copy-seq #(a b c d e f g))) (result (replace x '(x y z) :start1 2))) - (values (eq x result) result)) + (values (eqt x result) result)) t #(a b x y z f g)) @@ -160,21 +160,21 @@ (deftest replace-vector.8 (let* ((x (copy-seq #(a b c d e f g))) (result (replace x #(x y z) :end1 1))) - (values (eq x result) result)) + (values (eqt x result) result)) t #(x b c d e f g)) (deftest replace-vector.9 (let* ((x (copy-seq #(a b c d e f g))) (result (replace x #(x y z) :start1 3 :end1 4))) - (values (eq x result) result)) + (values (eqt x result) result)) t #(a b c x e f g)) (deftest replace-vector.10 (let* ((x (copy-seq #(a b c d e f g))) (result (replace x #(x y z) :start1 0 :end1 5))) - (values (eq x result) result)) + (values (eqt x result) result)) t #(x y z d e f g)) @@ -182,35 +182,35 @@ (deftest replace-vector.11 (let* ((x (copy-seq #(a b c d e f g))) (result (replace x #(x y z) :start2 1))) - (values (eq x result) result)) + (values (eqt x result) result)) t #(y z c d e f g)) (deftest replace-vector.12 (let* ((x (copy-seq #(a b c d e f g))) (result (replace x #(x y z) :start2 1 :end1 nil))) - (values (eq x result) result)) + (values (eqt x result) result)) t #(y z c d e f g)) (deftest replace-vector.13 (let* ((x (copy-seq #(a b c d e f g))) (result (replace x #(x y z) :start2 1 :end2 nil))) - (values (eq x result) result)) + (values (eqt x result) result)) t #(y z c d e f g)) (deftest replace-vector.14 (let* ((x (copy-seq #(a b c d e f g))) (result (replace x #(x y z) :start2 1 :end2 2))) - (values (eq x result) result)) + (values (eqt x result) result)) t #(y b c d e f g)) (deftest replace-vector.15 (let* ((x (copy-seq #(a b c d e f g))) (result (replace x #(x y z) :start1 4 :end1 5 :start2 1 :end2 2))) - (values (eq x result) result)) + (values (eqt x result) result)) t #(a b c d y f g)) @@ -219,42 +219,42 @@ (deftest replace-bitstring.1 (let* ((x (copy-seq #*1101001)) (result (replace x #*011))) - (values (eq x result) result)) + (values (eqt x result) result)) t #*0111001) (deftest replace-bitstring.2 (let* ((x (copy-seq #*1101001)) (result (replace x #*011 :start1 1))) - (values (eq x result) result)) + (values (eqt x result) result)) t #*1011001) (deftest replace-bitstring.3 (let* ((x (copy-seq #*1101001)) (result (replace x #*011 :start1 4))) - (values (eq x result) result)) + (values (eqt x result) result)) t #*1101011) (deftest replace-bitstring.4 (let* ((x (copy-seq #*0000000)) (result (replace x #*111 :start1 5))) - (values (eq x result) result)) + (values (eqt x result) result)) t #*0000011) (deftest replace-bitstring.5 (let* ((x (copy-seq #*0000000)) (result (replace x #*100 :start1 6))) - (values (eq x result) result)) + (values (eqt x result) result)) t #*0000001) (deftest replace-bitstring.6 (let* ((x (copy-seq #*0000000)) (result (replace x '(1 1 1) :start1 2))) - (values (eq x result) result)) + (values (eqt x result) result)) t #*0011100) @@ -265,21 +265,21 @@ (deftest replace-bitstring.8 (let* ((x (copy-seq #*0000000)) (result (replace x #*111 :end1 1))) - (values (eq x result) result)) + (values (eqt x result) result)) t #*1000000) (deftest replace-bitstring.9 (let* ((x (copy-seq #*0000000)) (result (replace x #*110 :start1 3 :end1 4))) - (values (eq x result) result)) + (values (eqt x result) result)) t #*0001000) (deftest replace-bitstring.10 (let* ((x (copy-seq #*0000000)) (result (replace x #*111 :start1 0 :end1 5))) - (values (eq x result) result)) + (values (eqt x result) result)) t #*1110000) @@ -287,35 +287,35 @@ (deftest replace-bitstring.11 (let* ((x (copy-seq #*0000000)) (result (replace x #*011 :start2 1))) - (values (eq x result) result)) + (values (eqt x result) result)) t #*1100000) (deftest replace-bitstring.12 (let* ((x (copy-seq #*0000000)) (result (replace x #*011 :start2 1 :end1 nil))) - (values (eq x result) result)) + (values (eqt x result) result)) t #*1100000) (deftest replace-bitstring.13 (let* ((x (copy-seq #*0000000)) (result (replace x #*011 :start2 1 :end2 nil))) - (values (eq x result) result)) + (values (eqt x result) result)) t #*1100000) (deftest replace-bitstring.14 (let* ((x (copy-seq #*0000000)) (result (replace x #*011 :start2 1 :end2 2))) - (values (eq x result) result)) + (values (eqt x result) result)) t #*1000000) (deftest replace-bitstring.15 (let* ((x (copy-seq #*0000000)) (result (replace x #*011 :start1 4 :end1 5 :start2 1 :end2 2))) - (values (eq x result) result)) + (values (eqt x result) result)) t #*0000100) @@ -324,42 +324,42 @@ (deftest replace-string.1 (let* ((x (copy-seq "abcdefg")) (result (replace x "xyz"))) - (values (eq x result) result)) + (values (eqt x result) result)) t "xyzdefg") (deftest replace-string.2 (let* ((x (copy-seq "abcdefg")) (result (replace x "xyz" :start1 1))) - (values (eq x result) result)) + (values (eqt x result) result)) t "axyzefg") (deftest replace-string.3 (let* ((x (copy-seq "abcdefg")) (result (replace x "xyz" :start1 4))) - (values (eq x result) result)) + (values (eqt x result) result)) t "abcdxyz") (deftest replace-string.4 (let* ((x (copy-seq "abcdefg")) (result (replace x "xyz" :start1 5))) - (values (eq x result) result)) + (values (eqt x result) result)) t "abcdexy") (deftest replace-string.5 (let* ((x (copy-seq "abcdefg")) (result (replace x "xyz" :start1 6))) - (values (eq x result) result)) + (values (eqt x result) result)) t "abcdefx") (deftest replace-string.6 (let* ((x (copy-seq "abcdefg")) (result (replace x '(#\x #\y #\z) :start1 2))) - (values (eq x result) result)) + (values (eqt x result) result)) t "abxyzfg") @@ -370,21 +370,21 @@ (deftest replace-string.8 (let* ((x (copy-seq "abcdefg")) (result (replace x "xyz" :end1 1))) - (values (eq x result) result)) + (values (eqt x result) result)) t "xbcdefg") (deftest replace-string.9 (let* ((x (copy-seq "abcdefg")) (result (replace x "xyz" :start1 3 :end1 4))) - (values (eq x result) result)) + (values (eqt x result) result)) t "abcxefg") (deftest replace-string.10 (let* ((x (copy-seq "abcdefg")) (result (replace x "xyz" :start1 0 :end1 5))) - (values (eq x result) result)) + (values (eqt x result) result)) t "xyzdefg") @@ -392,34 +392,34 @@ (deftest replace-string.11 (let* ((x (copy-seq "abcdefg")) (result (replace x "xyz" :start2 1))) - (values (eq x result) result)) + (values (eqt x result) result)) t "yzcdefg") (deftest replace-string.12 (let* ((x (copy-seq "abcdefg")) (result (replace x "xyz" :start2 1 :end1 nil))) - (values (eq x result) result)) + (values (eqt x result) result)) t "yzcdefg") (deftest replace-string.13 (let* ((x (copy-seq "abcdefg")) (result (replace x "xyz" :start2 1 :end2 nil))) - (values (eq x result) result)) + (values (eqt x result) result)) t "yzcdefg") (deftest replace-string.14 (let* ((x (copy-seq "abcdefg")) (result (replace x "xyz" :start2 1 :end2 2))) - (values (eq x result) result)) + (values (eqt x result) result)) t "ybcdefg") (deftest replace-string.15 (let* ((x (copy-seq "abcdefg")) (result (replace x "xyz" :start1 4 :end1 5 :start2 1 :end2 2))) - (values (eq x result) result)) + (values (eqt x result) result)) t "abcdyfg") diff --git a/ansi-tests/string-aux.lsp b/ansi-tests/string-aux.lsp index d6e04f4aa3db8c4428b600c4db299aa6050bc7e3..ba765c29bae1be8afd8eef40acfb2fed973a3d64 100644 --- a/ansi-tests/string-aux.lsp +++ b/ansi-tests/string-aux.lsp @@ -136,7 +136,7 @@ (y (apply #'my-string-compare s1 s2 comparison :case case args))) (not (or (eql x y) - (and x y (eq comparison '=)))))))) + (and x y (eqt comparison '=)))))))) (defun make-random-string (n) (let ((s (random-case diff --git a/ansi-tests/string.lsp b/ansi-tests/string.lsp index 254501c5a33458db0cdfb57593c1927bf4abfe2a..0c964ba7c3b91698df37a33f8d4526e3f8fda086 100644 --- a/ansi-tests/string.lsp +++ b/ansi-tests/string.lsp @@ -6,15 +6,15 @@ (in-package :cl-test) (deftest string.1 - (subtypep 'string 'array) + (subtypep* 'string 'array) t t) (deftest string.2 - (subtypep 'string 'vector) + (subtypep* 'string 'vector) t t) (deftest string.3 - (subtypep 'string 'sequence) + (subtypep* 'string 'sequence) t t) (deftest string.4 @@ -41,75 +41,75 @@ ;;; Tests of base-string (deftest base-string.1 - (subtypep 'base-string 'string) + (subtypep* 'base-string 'string) t t) (deftest base-string.2 - (subtypep 'base-string 'vector) + (subtypep* 'base-string 'vector) t t) (deftest base-string.3 - (subtypep 'base-string 'array) + (subtypep* 'base-string 'array) t t) (deftest base-string.4 - (subtypep 'base-string 'sequence) + (subtypep* 'base-string 'sequence) t t) ;;; Tests of simple-string (deftest simple-string.1 - (subtypep 'simple-string 'string) + (subtypep* 'simple-string 'string) t t) (deftest simple-string.2 - (subtypep 'simple-string 'vector) + (subtypep* 'simple-string 'vector) t t) (deftest simple-string.3 - (subtypep 'simple-string 'simple-array) + (subtypep* 'simple-string 'simple-array) t t) (deftest simple-string.4 - (subtypep 'simple-string 'array) + (subtypep* 'simple-string 'array) t t) (deftest simple-string.5 - (subtypep 'simple-string 'sequence) + (subtypep* 'simple-string 'sequence) t t) ;;; Tests for simple-base-string (deftest simple-base-string.1 - (subtypep 'simple-base-string 'string) + (subtypep* 'simple-base-string 'string) t t) (deftest simple-base-string.2 - (subtypep 'simple-base-string 'vector) + (subtypep* 'simple-base-string 'vector) t t) (deftest simple-base-string.3 - (subtypep 'simple-base-string 'simple-array) + (subtypep* 'simple-base-string 'simple-array) t t) (deftest simple-base-string.4 - (subtypep 'simple-base-string 'array) + (subtypep* 'simple-base-string 'array) t t) (deftest simple-base-string.5 - (subtypep 'simple-base-string 'sequence) + (subtypep* 'simple-base-string 'sequence) t t) (deftest simple-base-string.6 - (subtypep 'simple-base-string 'base-string) + (subtypep* 'simple-base-string 'base-string) t t) (deftest simple-base-string.7 - (subtypep 'simple-base-string 'simple-string) + (subtypep* 'simple-base-string 'simple-string) t t) (deftest simple-base-string.8 - (subtypep 'simple-base-string 'simple-vector) + (subtypep* 'simple-base-string 'simple-vector) nil t) ;;; Tests for simple-string-p diff --git a/ansi-tests/structure-00.lsp b/ansi-tests/structure-00.lsp index 09b58dd3fd741f3da4e89d9132b3df020352f371..6beb4a0e6200b5bc19d3aa3a20d2e579edc6c08d 100644 --- a/ansi-tests/structure-00.lsp +++ b/ansi-tests/structure-00.lsp @@ -49,18 +49,18 @@ "Return an instance of a type. Signal an error if it can't figure out a value for the type." (cond - ((eq type t) ;; anything + ((eqt type t) ;; anything 'a) - ((eq type 'symbol) + ((eqt type 'symbol) 'b) - ((eq type 'null) nil) - ((eq type 'boolean) t) - ((eq type 'keyword) :foo) - ((eq type nil) (error "Cannot obtain element of type ~S~%" type)) - ((eq type 'cons) (cons 'a 'b)) - ((eq type 'list) (list 1 2 3)) - ((eq type 'fixnum) 17) - ((eq type 'bignum) + ((eqt type 'null) nil) + ((eqt type 'boolean) t) + ((eqt type 'keyword) :foo) + ((eqt type nil) (error "Cannot obtain element of type ~S~%" type)) + ((eqt type 'cons) (cons 'a 'b)) + ((eqt type 'list) (list 1 2 3)) + ((eqt type 'fixnum) 17) + ((eqt type 'bignum) (let ((x 1)) (loop until (typep x 'bignum) do (setq x (* 2 x))) @@ -71,25 +71,25 @@ (intern (concatenate 'string "MAKE-" (symbol-name type)) (symbol-package type)))) (eval (list make-fn)))) - ((eq type 'character) #\w) - ((eq type 'base-char) #\z) + ((eqt type 'character) #\w) + ((eqt type 'base-char) #\z) ((member type '(integer unsigned-byte signed-byte)) 35) - ((eq type 'bit) 1) + ((eqt type 'bit) 1) ((and (consp type) (consp (cdr type)) (consp (cddr type)) (null (cdddr type)) - (eq (car type) 'integer) + (eqt (car type) 'integer) (integerp (second type))) (second type)) ((member type '(float single-float long-float double-float short-float)) 0.0) ((and (consp type) - (eq (car type) 'member) + (eqt (car type) 'member) (consp (cdr type))) (second type)) ((and (consp type) - (eq (car type) 'or) + (eqt (car type) 'or) (consp (second type))) (create-instance-of-type (second type))) (t (error "Cannot generate element for type ~S~%" type)))) @@ -191,7 +191,7 @@ do the defstruct." ;; Check that two invocations return different structures (deftest ,(make-struct-test-name name 6) ,(let ((make-fn (make-struct-make-fn name))) - `(eq (,make-fn) (,make-fn))) + `(eqt (,make-fn) (,make-fn))) nil) ;; Check that we can setf the fields diff --git a/ansi-tests/structures-01.lsp b/ansi-tests/structures-01.lsp index 34429435b2c47b6750297d5963c0a6758ee94bac..51009854ce91144e8424f058ac503db74ae199cf 100644 --- a/ansi-tests/structures-01.lsp +++ b/ansi-tests/structures-01.lsp @@ -80,11 +80,11 @@ ;; Make produces unique items (deftest structure-1-11 - (eq (make-s-1) (make-s-1)) + (eqt (make-s-1) (make-s-1)) nil) (deftest structure-1-12 - (eq (make-s-1 :foo 'a :bar 'b) + (eqt (make-s-1 :foo 'a :bar 'b) (make-s-1 :foo 'a :bar 'b)) nil) @@ -99,5 +99,5 @@ t) (deftest structure-1-15 - (subtypep 's-1 'structure-object) + (subtypep* 's-1 'structure-object) t t) diff --git a/ansi-tests/structures-02.lsp b/ansi-tests/structures-02.lsp index 2d889a609736ea89391b57f2665107c43f67b060..4c65e92c095a256ee65e50945c5cbeaefb0d98eb 100644 --- a/ansi-tests/structures-02.lsp +++ b/ansi-tests/structures-02.lsp @@ -23,19 +23,20 @@ ;; Fields have appropriate values (deftest structure-2-1 - (let ((s (make-s-2))) - (and - (eql (s-2-f1 s) 0) - (eq (s-2-f2 s) 'a) - (eql (s-2-f3 s) 1.21) - (eql (s-2-f4 s) #\d) - (equal (s-2-f5 s) '(a b)) - (eql (s-2-f6 s) *s-2-f6-counter*))) + (let ((s (make-s-2))) + (not (not + (and + (eql (s-2-f1 s) 0) + (eqt (s-2-f2 s) 'a) + (eql (s-2-f3 s) 1.21) + (eql (s-2-f4 s) #\d) + (equal (s-2-f5 s) '(a b)) + (eql (s-2-f6 s) *s-2-f6-counter*))))) t) ;; Two successive invocations of make-s-2 return different objects (deftest structure-2-2 - (eq (s-2-f5 (make-s-2)) + (eqt (s-2-f5 (make-s-2)) (s-2-f5 (make-s-2))) nil) diff --git a/ansi-tests/subseq.lsp b/ansi-tests/subseq.lsp index 40131b8a3ada314d2486f4ca7fd56428c3cc2c62..e198eef28eb83dd7442c59fa9bc994deb92e580c 100644 --- a/ansi-tests/subseq.lsp +++ b/ansi-tests/subseq.lsp @@ -59,10 +59,10 @@ for e on x and f on y and g in z do - (when (or (not (eq g e)) + (when (or (not (eqt g e)) (not (eql (car e) (car f))) (car e) - (eq e f)) + (eqt e f)) (return nil)) finally (return t)))) @@ -117,23 +117,23 @@ (block nil (let* ((x (make-sequence 'vector 10 :initial-element 'a)) (y (subseq x 4 8))) - (unless (every #'(lambda (e) (eq e 'a)) x) + (unless (every #'(lambda (e) (eqt e 'a)) x) (return 1)) - (unless (every #'(lambda (e) (eq e 'a)) y) + (unless (every #'(lambda (e) (eqt e 'a)) y) (return 2)) (unless (eql (length x) 10) (return 3)) (unless (eql (length y) 4) (return 4)) (loop for i from 0 to 9 do (setf (aref x i) 'b)) - (unless (every #'(lambda (e) (eq e 'a)) y) + (unless (every #'(lambda (e) (eqt e 'a)) y) (return 5)) (loop for i from 0 to 3 do (setf (aref y i) 'c)) (or - (not (not (every #'(lambda (e) (eq e 'b)) x))) + (not (not (every #'(lambda (e) (eqt e 'b)) x))) 6)))) (deftest subseq-vector-1 - (subseq-vector-1-body) - t) + (subseq-vector-1-body) + t) (defun subseq-vector-2-body () (block nil diff --git a/ansi-tests/t.lsp b/ansi-tests/t.lsp new file mode 100644 index 0000000000000000000000000000000000000000..84dd79d5fb7890e2cd00265f1cf7179b23afbc51 --- /dev/null +++ b/ansi-tests/t.lsp @@ -0,0 +1,24 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Thu Oct 17 06:44:45 2002 +;;;; Contains: Tests of T + +(in-package :cl-test) + +(deftest t.1 + t t) + +(deftest t.2 + (not (constantp t)) + nil) + +(deftest t.3 + (eqt t 't) + t) + +(deftest t.4 + (symbol-value t) + t) + +;;; Tests for use of T in case forms, as a stream designator, or as a class +;;; designator will be elsewhere diff --git a/ansi-tests/types-and-class.lsp b/ansi-tests/types-and-class.lsp index 175e9eb906110cca12d0320346011ceab401de84..fd5831f49282683587e63ef8f1d57b45f279404b 100644 --- a/ansi-tests/types-and-class.lsp +++ b/ansi-tests/types-and-class.lsp @@ -23,7 +23,7 @@ t) (defun is-t-or-nil (e) - (or (eq e t) (eq e nil))) + (or (eqt e t) (eqt e nil))) (deftest boolean-type-3 (check-type-predicate 'is-t-or-nil 'boolean) @@ -144,7 +144,7 @@ (reader-error parse-error) (reader-error stream-error) ))) - (when (subtypep 'character 'base-char) + (when (subtypep* 'character 'base-char) (setq table (append '((character base-char) @@ -160,7 +160,7 @@ (let ((t1 (first pair)) (t2 (second pair))) (cond - ((not (subtypep t1 t2)) + ((not (subtypep* t1 t2)) (format t "~%~S not a subtype of ~S" t1 t2) t) (t nil)))) @@ -199,14 +199,14 @@ (loop for tp2 in types sum (cond - ((and (not (eq tp tp2)) - (not (eq tp2 'standard-object)) - (not (eq tp2 'structure-object)) + ((and (not (eqt tp tp2)) + (not (eqt tp2 'standard-object)) + (not (eqt tp2 'structure-object)) (not (member tp2 parents)) - (subtypep tp tp2) + (subtypep* tp tp2) (not (and (member tp +float-types+) (member tp2 +float-types+))) - (not (and (eq tp2 'structure-object) + (not (and (eqt tp2 'structure-object) (member 'standard-object parents)))) (format t "~%Improper subtype: ~S of ~S" tp tp2) @@ -229,7 +229,7 @@ (let ((tp (car p))) (cond ((and (not (member tp '(sequence cons list t))) - (not (subtypep tp 'atom))) + (not (subtypep* tp 'atom))) (format t "~%Not an atomic type: ~S" tp) t))))) @@ -246,16 +246,16 @@ (loop for tp in *disjoint-types-list* sum (loop for tp2 in *disjoint-types-list* count - (and (not (eq tp tp2)) - (subtypep tp tp2)))) + (and (not (eqt tp tp2)) + (subtypep* tp tp2)))) 0) (deftest types-8 (loop for tp in *disjoint-types-list* count (cond - ((and (not (eq tp 'cons)) - (not (subtypep tp 'atom))) + ((and (not (eqt tp 'cons)) + (not (subtypep* tp 'atom))) (format t "~%Should be atomic, but isn't: ~S" tp) t))) 0) @@ -276,7 +276,7 @@ (loop for y in tp-list do (multiple-value-bind (result good) - (subtypep x y) + (subtypep* x y) (declare (ignore good)) (when result (pushnew x (gethash y subs)) @@ -291,7 +291,7 @@ (loop for t2 in sup-list do (multiple-value-bind (result good) - (subtypep t1 t2) + (subtypep* t1 t2) (when (and good (not result)) (pushnew (list t1 x t2) result-list :test #'equal)))))))