Changeset 236

Timestamp:

Jan 7, 2004, 3:39:42 PM (21 years ago)

Author:

Gary Byers

Message:

ASSOC variants don't allow NIL in an alist. ASSEQL typechecks CAR/CDR.
MEMEQL uses ENDP, doesn't use %CAR/%CDR in unsafe contexts.

File:

• trunk/ccl/level-1/l1-utils.lisp (modified) (7 diffs)

trunk/ccl/level-1/l1-utils.lisp

@@ -446 +446 @@
 
 (defun asseql (item list)
-  (when (not (listp list))(setq list (%kernel-restart $xwrongtype list 'list)))
-  (locally (declare (list list))
-    (if (need-use-eql-macro item)
-      (dolist (pair list)
-        (if (and pair (eql item (%car pair)))
-          (return pair)))
-      (dolist (pair list)        
-        (when (and pair (eq item (%car pair)))
-          (return pair))))))
+  (if (need-use-eql-macro item)
+    (dolist (pair list)
+      (if pair
+        (if (eql item (car pair))
+          (return pair)
+          (report-bad-arg pair 'cons))))
+    (assq pair list)))
 
 ; (assoc-test item list test-fn) 
@@ -462 +460 @@
 (defun assoc-test (item list test-fn)
   (dolist (pair list)
-    (if (and pair (funcall test-fn item (car pair)))
-      (return pair))))
+    (if pair
+      (if (funcall test-fn item (car pair))
+        (return pair))
+      (report-bad-arg pair 'cons))))
 
 
@@ -473 +473 @@
 (defun assoc-test-not (item list test-not-fn)
   (dolist (pair list)
-    (if (and pair (not (funcall test-not-fn item (car pair))))
-      (return pair))))
+    (if pair
+      (if (not (funcall test-not-fn item (car pair)))
+        (return pair))
+      (report-bad-arg pair 'cons))))
 
 (defun assoc (item list &key test test-not key)
@@ -488 +490 @@
       (if test
         (dolist (pair list)
-          (when pair
+          (if pair
             (if (funcall test item (funcall key (car pair)))
-              (return pair))))
+              (return pair))
+            (report-bad-arg pair 'cons)))
         (dolist (pair list)
-          (when pair
+          (if pair
             (unless (funcall test-not item (funcall key (car pair)))
-              (return pair))))))))
+              (return pair))
+            (report-bad-arg pair 'cons)))))))
 
 
@@ -504 +508 @@
 ;nil or error - supposed to error if not proper list?
 (defun memeql (item list)
-  (when (not (listp list))(setq list (%kernel-restart $xwrongtype list 'list)))
   (if (need-use-eql-macro item)
-    (do* ((l list (cdr l)))
-         ((null l))
+    (do* ((l list (%cdr l)))
+         ((endp l))
       (when (eql (%car l) item) (return l)))
-    (do* ((tail list (cdr tail)))
-         ((null tail))
-      (if (eq item (%car tail))
-        (return tail)))))
+    (memq item list))
+)
 
 ; (member-test item list test-fn) 
@@ -538 +539 @@
 (defun member-test-not (item list test-not-fn)
   (do* ((l list (cdr l)))
-       ((null l))
-    (unless (funcall test-not-fn item (car l)) (return l))))
+       ((endp l))
+    (unless (funcall test-not-fn item (%car l)) (return l))))
 
 (defun member (item list &key test test-not key)
@@ -553 +554 @@
       (if test
         (do* ((l list (cdr l)))
-             ((null l))
+             ((endp l))
           (if (funcall test item (funcall key (car l)))
               (return l)))