1.0.9.53: trivial typo fixes

[sbcl.git] / src / code / list.lisp

diff --git a/src/code/list.lisp b/src/code/list.lisp
index 2353c5a..5f96806 100644 (file)
--- a/src/code/list.lisp
+++ b/src/code/list.lisp
@@ -11,17 +11,19 @@
 
 (in-package "SB!IMPL")
 
 
 (in-package "SB!IMPL")
 

+;;; Limitation: no list might have more than INDEX conses.
+

 ;;;; KLUDGE: comment from CMU CL, what does it mean?
 ;;;;   NSUBLIS, things at the beginning broken.
 ;;;; -- WHN 20000127
 
 (declaim (maybe-inline
 ;;;; KLUDGE: comment from CMU CL, what does it mean?
 ;;;;   NSUBLIS, things at the beginning broken.
 ;;;; -- WHN 20000127
 
 (declaim (maybe-inline

-         tree-equal nth %setnth nthcdr last make-list append
-         nconc member member-if member-if-not tailp adjoin union
-         nunion intersection nintersection set-difference nset-difference
-         set-exclusive-or nset-exclusive-or subsetp acons assoc
-         assoc-if assoc-if-not rassoc rassoc-if rassoc-if-not subst subst-if
-         subst-if-not nsubst nsubst-if nsubst-if-not sublis nsublis))
+          tree-equal nth %setnth nthcdr last last1 make-list append
+          nconc nconc2 member member-if member-if-not tailp adjoin union
+          nunion intersection nintersection set-difference nset-difference
+          set-exclusive-or nset-exclusive-or subsetp acons assoc
+          assoc-if assoc-if-not rassoc rassoc-if rassoc-if-not subst subst-if
+          subst-if-not nsubst nsubst-if nsubst-if-not sublis nsublis))

 
 ;;; These functions perform basic list operations.
 (defun car (list) #!+sb-doc "Return the 1st object in a list." (car list))
 
 ;;; These functions perform basic list operations.
 (defun car (list) #!+sb-doc "Return the 1st object in a list." (car list))

@@ -115,22 +117,22 @@
 (defun tree-equal-test-not (x y test-not)
   (declare (type function test-not))
   (cond ((consp x)
 (defun tree-equal-test-not (x y test-not)
   (declare (type function test-not))
   (cond ((consp x)

-        (and (consp y)
-             (tree-equal-test-not (car x) (car y) test-not)
-             (tree-equal-test-not (cdr x) (cdr y) test-not)))
-       ((consp y) nil)
-       ((not (funcall test-not x y)) t)
-       (t ())))
+         (and (consp y)
+              (tree-equal-test-not (car x) (car y) test-not)
+              (tree-equal-test-not (cdr x) (cdr y) test-not)))
+        ((consp y) nil)
+        ((not (funcall test-not x y)) t)
+        (t ())))

 
 (defun tree-equal-test (x y test)
   (declare (type function test))
 
 (defun tree-equal-test (x y test)
   (declare (type function test))

-  (cond        ((consp x)
-        (and (consp y)
-             (tree-equal-test (car x) (car y) test)
-             (tree-equal-test (cdr x) (cdr y) test)))
-       ((consp y) nil)
-       ((funcall test x y) t)
-       (t ())))
+  (cond ((consp x)
+         (and (consp y)
+              (tree-equal-test (car x) (car y) test)
+              (tree-equal-test (cdr x) (cdr y) test)))
+        ((consp y) nil)
+        ((funcall test x y) t)
+        (t ())))

 
 (defun tree-equal (x y &key (test #'eql testp) (test-not nil notp))
   #!+sb-doc
 
 (defun tree-equal (x y &key (test #'eql testp) (test-not nil notp))
   #!+sb-doc

@@ -211,25 +213,45 @@
   (cdr list))
 
 (defun nthcdr (n list)
   (cdr list))
 
 (defun nthcdr (n list)

-  (declare (type index n))

   #!+sb-doc
   "Performs the cdr function n times on a list."
   #!+sb-doc
   "Performs the cdr function n times on a list."

-  (do ((i n (1- i))
-       (result list (cdr result)))
-      ((not (plusp i)) result)
-      (declare (type index i))))
+  (flet ((fast-nthcdr (n list)
+           (declare (type index n))
+           (do ((i n (1- i))
+                (result list (cdr result)))
+               ((not (plusp i)) result)
+             (declare (type index i)))))
+    (typecase n
+      (index (fast-nthcdr n list))
+      (t (do ((i 0 (1+ i))
+              (r-i list (cdr r-i))
+              (r-2i list (cddr r-2i)))
+             ((and (eq r-i r-2i) (not (zerop i)))
+              (fast-nthcdr (mod n i) r-i))
+           (declare (type index i)))))))
+
+(defun last1 (list)
+  #!+sb-doc
+  "Return the last cons (not the last element) of a list"
+  (let ((rest list)
+        (list list))
+    (loop (unless (consp rest) (return list))
+          (shiftf list rest (cdr rest)))))

 
 (defun last (list &optional (n 1))
   #!+sb-doc
   "Return the last N conses (not the last element!) of a list."
 
 (defun last (list &optional (n 1))
   #!+sb-doc
   "Return the last N conses (not the last element!) of a list."

-  (declare (type index n))
-  (do ((checked-list list (cdr checked-list))
-       (returned-list list)
-       (index 0 (1+ index)))
-      ((atom checked-list) returned-list)
-    (declare (type index index))
-    (if (>= index n)
-       (pop returned-list))))
+  (if (eql n 1)
+      (last1 list)
+    (if (typep n 'index)
+        (do ((checked-list list (cdr checked-list))
+             (returned-list list)
+             (index 0 (1+ index)))
+            ((atom checked-list) returned-list)
+          (declare (type index index))
+          (if (>= index n)
+              (pop returned-list)))
+      list)))

 
 (defun list (&rest args)
   #!+sb-doc
 
 (defun list (&rest args)
   #!+sb-doc

@@ -243,10 +265,10 @@
   #!+sb-doc
   "Return a list of the arguments with last cons a dotted pair"
   (cond ((atom others) arg)
   #!+sb-doc
   "Return a list of the arguments with last cons a dotted pair"
   (cond ((atom others) arg)

-       ((atom (cdr others)) (cons arg (car others)))
-       (t (do ((x others (cdr x)))
-              ((null (cddr x)) (rplacd x (cadr x))))
-          (cons arg others))))
+        ((atom (cdr others)) (cons arg (car others)))
+        (t (do ((x others (cdr x)))
+               ((null (cddr x)) (rplacd x (cadr x))))
+           (cons arg others))))

 
 (defun make-list (size &key initial-element)
   #!+sb-doc
 
 (defun make-list (size &key initial-element)
   #!+sb-doc

@@ -254,7 +276,7 @@
   (declare (type index size))
   (do ((count size (1- count))
        (result '() (cons initial-element result)))
   (declare (type index size))
   (do ((count size (1- count))
        (result '() (cons initial-element result)))

-      ((zerop count) result)
+      ((<= count 0) result)

     (declare (type index count))))
 \f
 (defun append (&rest lists)
     (declare (type index count))))
 \f
 (defun append (&rest lists)

@@ -299,13 +321,13 @@
   (if (atom list)
       list
       (let ((result (list (car list))))
   (if (atom list)
       list
       (let ((result (list (car list))))

-       (do ((x (cdr list) (cdr x))
-            (splice result
-                    (cdr (rplacd splice (cons (car x) '())))))
-           ((atom x)
-            (unless (null x)
-              (rplacd splice x))))
-       result)))
+        (do ((x (cdr list) (cdr x))
+             (splice result
+                     (cdr (rplacd splice (cons (car x) '())))))
+            ((atom x)
+             (unless (null x)
+               (rplacd splice x))))
+        result)))

 
 (defun copy-alist (alist)
   #!+sb-doc
 
 (defun copy-alist (alist)
   #!+sb-doc

@@ -313,20 +335,20 @@
   (if (endp alist)
       alist
       (let ((result
   (if (endp alist)
       alist
       (let ((result

-            (cons (if (atom (car alist))
-                      (car alist)
-                      (cons (caar alist) (cdar alist)))
-                  nil)))
-       (do ((x (cdr alist) (cdr x))
-            (splice result
-                    (cdr (rplacd splice
-                                 (cons
-                                  (if (atom (car x))
-                                      (car x)
-                                      (cons (caar x) (cdar x)))
-                                  nil)))))
-           ((endp x)))
-       result)))
+             (cons (if (atom (car alist))
+                       (car alist)
+                       (cons (caar alist) (cdar alist)))
+                   nil)))
+        (do ((x (cdr alist) (cdr x))
+             (splice result
+                     (cdr (rplacd splice
+                                  (cons
+                                   (if (atom (car x))
+                                       (car x)
+                                       (cons (caar x) (cdar x)))
+                                   nil)))))
+            ((endp x)))
+        result)))

 
 (defun copy-tree (object)
   #!+sb-doc
 
 (defun copy-tree (object)
   #!+sb-doc

@@ -388,6 +410,16 @@
                (return top-of-top)))
           (t (fail top-of-top)))))))
 
                (return top-of-top)))
           (t (fail top-of-top)))))))
 

+(defun nconc2 (x y)
+  (if (null x) y
+    (let ((z x)
+          (rest (cdr x)))
+      (loop
+       (unless (consp rest)
+         (rplacd z y)
+         (return x))
+       (shiftf z rest (cdr rest))))))
+

 (defun nreconc (x y)
   #!+sb-doc
   "Return (NCONC (NREVERSE X) Y)."
 (defun nreconc (x y)
   #!+sb-doc
   "Return (NCONC (NREVERSE X) Y)."

@@ -401,52 +433,56 @@
        ;; possibly-improper list LIST. (Or if LIST is circular, you
        ;; lose.)
        (count-conses (list)
        ;; possibly-improper list LIST. (Or if LIST is circular, you
        ;; lose.)
        (count-conses (list)

-        (do ((in-list list (cdr in-list))
-             (result 0 (1+ result)))
-            ((atom in-list)
-             result)
-          (declare (type index result)))))
+         (do ((in-list list (cdr in-list))
+              (result 0 (1+ result)))
+             ((atom in-list)
+              result)
+           (declare (type index result)))))

   (declare (ftype (function (t) index) count-conses))
   (defun butlast (list &optional (n 1))
   (declare (ftype (function (t) index) count-conses))
   (defun butlast (list &optional (n 1))

-    (let ((n-conses-in-list (count-conses list)))
-      (cond ((zerop n)
-            ;; (We can't use SUBSEQ in this case because LIST isn't
-            ;; necessarily a proper list, but SUBSEQ expects a
-            ;; proper sequence. COPY-LIST isn't so fussy.)
-            (copy-list list))
-           ((>= n n-conses-in-list)
-            nil)
-           (t
-            ;; (LIST isn't necessarily a proper list in this case
-            ;; either, and technically SUBSEQ wants a proper
-            ;; sequence, but no reasonable implementation of SUBSEQ
-            ;; will actually walk down to the end of the list to
-            ;; check, and since we're calling our own implementation
-            ;; we know it's reasonable, so it's OK.)
-            (subseq list 0 (- n-conses-in-list n))))))
+    (if (typep n 'index)
+        (let ((n-conses-in-list (count-conses list)))
+          (cond ((zerop n)
+                 ;; (We can't use SUBSEQ in this case because LIST isn't
+                 ;; necessarily a proper list, but SUBSEQ expects a
+                 ;; proper sequence. COPY-LIST isn't so fussy.)
+                 (copy-list list))
+                ((>= n n-conses-in-list)
+                 nil)
+                (t
+                 ;; (LIST isn't necessarily a proper list in this case
+                 ;; either, and technically SUBSEQ wants a proper
+                 ;; sequence, but no reasonable implementation of SUBSEQ
+                 ;; will actually walk down to the end of the list to
+                 ;; check, and since we're calling our own implementation
+                 ;; we know it's reasonable, so it's OK.)
+                 (subseq list 0 (- n-conses-in-list n)))))
+        nil))

   (defun nbutlast (list &optional (n 1))
   (defun nbutlast (list &optional (n 1))

-    (if (zerop n)
-       list
-       (let ((n-conses-in-list (count-conses list)))
-         (unless (<= n-conses-in-list n)
-           (setf (cdr (nthcdr (- n-conses-in-list n 1) list))
-                 nil)
-           list)))))
+    (cond ((zerop n)
+           list)
+          ((not (typep n 'index))
+           nil)
+          (t (let ((n-conses-in-list (count-conses list)))
+               (unless (<= n-conses-in-list n)
+                 (setf (cdr (nthcdr (- n-conses-in-list n 1) list))
+                       nil)
+                 list))))))

 
 (defun ldiff (list object)
   "Return a new list, whose elements are those of LIST that appear before
    OBJECT. If OBJECT is not a tail of LIST, a copy of LIST is returned.
    LIST must be a proper list or a dotted list."
   (do* ((list list (cdr list))
 
 (defun ldiff (list object)
   "Return a new list, whose elements are those of LIST that appear before
    OBJECT. If OBJECT is not a tail of LIST, a copy of LIST is returned.
    LIST must be a proper list or a dotted list."
   (do* ((list list (cdr list))

-       (result (list ()))
-       (splice result))
+        (result (list ()))
+        (splice result))

        ((atom list)
        ((atom list)

-       (if (eql list object)
-           (cdr result)
-           (progn (rplacd splice list) (cdr result))))
+        (if (eql list object)
+            (cdr result)
+            (progn (rplacd splice list) (cdr result))))

     (if (eql list object)
     (if (eql list object)

-       (return (cdr result))
-       (setq splice (cdr (rplacd splice (list (car list))))))))
+        (return (cdr result))
+        (setq splice (cdr (rplacd splice (list (car list))))))))

 \f
 ;;;; functions to alter list structure
 
 \f
 ;;;; functions to alter list structure
 

@@ -468,15 +504,21 @@
 
 ;;; Set the Nth element of LIST to NEWVAL.
 (defun %setnth (n list newval)
 
 ;;; Set the Nth element of LIST to NEWVAL.
 (defun %setnth (n list newval)

-  (declare (type index n))
-  (do ((count n (1- count))
-       (list list (cdr list)))
-      ((endp list)
-       (error "~S is too large an index for SETF of NTH." n))
-    (declare (type fixnum count))
-    (when (<= count 0)
-      (rplaca list newval)
-      (return newval))))
+  (typecase n
+    (index
+     (do ((count n (1- count))
+          (list list (cdr list)))
+         ((endp list)
+          (error "~S is too large an index for SETF of NTH." n))
+       (declare (type fixnum count))
+       (when (<= count 0)
+         (rplaca list newval)
+         (return newval))))
+    (t (let ((cons (nthcdr n list)))
+         (when (endp cons)
+           (error "~S is too large an index for SETF of NTH." n))
+         (rplaca cons newval)
+         newval))))

 \f
 ;;;; :KEY arg optimization to save funcall of IDENTITY
 
 \f
 ;;;; :KEY arg optimization to save funcall of IDENTITY
 

@@ -500,8 +542,8 @@
   (let ((key-tmp (gensym)))
     `(let ((,key-tmp (apply-key key ,elt)))
       (cond (testp (funcall test ,item ,key-tmp))
   (let ((key-tmp (gensym)))
     `(let ((,key-tmp (apply-key key ,elt)))
       (cond (testp (funcall test ,item ,key-tmp))

-           (notp (not (funcall test-not ,item ,key-tmp)))
-           (t (funcall test ,item ,key-tmp))))))
+            (notp (not (funcall test-not ,item ,key-tmp)))
+            (t (funcall test ,item ,key-tmp))))))

 \f
 ;;;; substitution of expressions
 
 \f
 ;;;; substitution of expressions
 

@@ -570,7 +612,7 @@
                (cond ((satisfies-the-test old subtree) new)
                      ((atom subtree) subtree)
                      (t (do* ((last nil subtree)
                (cond ((satisfies-the-test old subtree) new)
                      ((atom subtree) subtree)
                      (t (do* ((last nil subtree)

-                              (subtree subtree (Cdr subtree)))
+                              (subtree subtree (cdr subtree)))

                              ((atom subtree)
                               (if (satisfies-the-test old subtree)
                                   (setf (cdr last) new)))
                              ((atom subtree)
                               (if (satisfies-the-test old subtree)
                                   (setf (cdr last) new)))

@@ -589,7 +631,7 @@
                (cond ((funcall test (apply-key key subtree)) new)
                      ((atom subtree) subtree)
                      (t (do* ((last nil subtree)
                (cond ((funcall test (apply-key key subtree)) new)
                      ((atom subtree) subtree)
                      (t (do* ((last nil subtree)

-                              (subtree subtree (Cdr subtree)))
+                              (subtree subtree (cdr subtree)))

                              ((atom subtree)
                               (if (funcall test (apply-key key subtree))
                                   (setf (cdr last) new)))
                              ((atom subtree)
                               (if (funcall test (apply-key key subtree))
                                   (setf (cdr last) new)))

@@ -608,7 +650,7 @@
                (cond ((not (funcall test (apply-key key subtree))) new)
                      ((atom subtree) subtree)
                      (t (do* ((last nil subtree)
                (cond ((not (funcall test (apply-key key subtree))) new)
                      ((atom subtree) subtree)
                      (t (do* ((last nil subtree)

-                              (subtree subtree (Cdr subtree)))
+                              (subtree subtree (cdr subtree)))

                              ((atom subtree)
                               (if (not (funcall test (apply-key key subtree)))
                                   (setf (cdr last) new)))
                              ((atom subtree)
                               (if (not (funcall test (apply-key key subtree)))
                                   (setf (cdr last) new)))

@@ -637,7 +679,7 @@
                        ((atom subtree) subtree)
                        (t (let ((car (s (car subtree)))
                                 (cdr (s (cdr subtree))))
                        ((atom subtree) subtree)
                        (t (let ((car (s (car subtree)))
                                 (cdr (s (cdr subtree))))

-                            (if (and (eq car (car subtreE))
+                            (if (and (eq car (car subtree))

                                      (eq cdr (cdr subtree)))
                                 subtree
                                 (cons car cdr))))))))
                                      (eq cdr (cdr subtree)))
                                 subtree
                                 (cons car cdr))))))))

@@ -649,8 +691,8 @@
   (let ((key-tmp (gensym)))
     `(let ((,key-tmp (apply-key key subtree)))
       (if notp
   (let ((key-tmp (gensym)))
     `(let ((,key-tmp (apply-key key subtree)))
       (if notp

-         (assoc ,key-tmp alist :test-not test-not)
-         (assoc ,key-tmp alist :test test)))))
+          (assoc ,key-tmp alist :test-not test-not)
+          (assoc ,key-tmp alist :test test)))))

 
 (defun nsublis (alist tree &key key (test #'eql testp) (test-not #'eql notp))
   #!+sb-doc
 
 (defun nsublis (alist tree &key key (test #'eql testp) (test-not #'eql notp))
   #!+sb-doc

@@ -663,16 +705,16 @@
     (declare (inline assoc))
     (let (temp)
       (labels ((s (subtree)
     (declare (inline assoc))
     (let (temp)
       (labels ((s (subtree)

-                 (cond ((Setq temp (nsublis-macro))
+                 (cond ((setq temp (nsublis-macro))

                         (cdr temp))
                        ((atom subtree) subtree)
                        (t (do* ((last nil subtree)
                         (cdr temp))
                        ((atom subtree) subtree)
                        (t (do* ((last nil subtree)

-                                (subtree subtree (Cdr subtree)))
+                                (subtree subtree (cdr subtree)))

                                ((atom subtree)
                                 (if (setq temp (nsublis-macro))
                                     (setf (cdr last) (cdr temp))))
                             (if (setq temp (nsublis-macro))
                                ((atom subtree)
                                 (if (setq temp (nsublis-macro))
                                     (setf (cdr last) (cdr temp))))
                             (if (setq temp (nsublis-macro))

-                                (return (setf (Cdr last) (Cdr temp)))
+                                (return (setf (cdr last) (cdr temp)))

                                 (setf (car subtree) (s (car subtree)))))
                           subtree))))
         (s tree)))))
                                 (setf (car subtree) (s (car subtree)))))
                           subtree))))
         (s tree)))))

@@ -692,8 +734,8 @@
     (do ((list list (cdr list)))
         ((null list) nil)
       (let ((car (car list)))
     (do ((list list (cdr list)))
         ((null list) nil)
       (let ((car (car list)))

-        (if (satisfies-the-test item car)
-            (return list))))))
+        (when (satisfies-the-test item car)
+          (return list))))))

 
 (defun member-if (test list &key key)
   #!+sb-doc
 
 (defun member-if (test list &key key)
   #!+sb-doc

@@ -722,7 +764,7 @@
   (do ((list list (cdr list)))
       ((atom list) (eql list object))
     (if (eql object list)
   (do ((list list (cdr list)))
       ((atom list) (eql list object))
     (if (eql object list)

-       (return t))))
+        (return t))))

 
 (defun adjoin (item list &key key (test #'eql testp) (test-not nil notp))
   #!+sb-doc
 
 (defun adjoin (item list &key key (test #'eql testp) (test-not nil notp))
   #!+sb-doc

@@ -738,22 +780,46 @@
         list
         (cons item list))))
 
         list
         (cons item list))))
 

+(defconstant +list-based-union-limit+ 80)
+

 (defun union (list1 list2 &key key (test #'eql testp) (test-not nil notp))
   #!+sb-doc
   "Return the union of LIST1 and LIST2."
   (declare (inline member))
   (when (and testp notp)
     (error ":TEST and :TEST-NOT were both supplied."))
 (defun union (list1 list2 &key key (test #'eql testp) (test-not nil notp))
   #!+sb-doc
   "Return the union of LIST1 and LIST2."
   (declare (inline member))
   (when (and testp notp)
     (error ":TEST and :TEST-NOT were both supplied."))

-  ;; We assumes LIST2 is the result, adding to it from LIST1 as
-  ;; necessary. LIST2 must initialize the result value, so the call to
-  ;; MEMBER will apply the test to the elements from LIST1 and LIST2
-  ;; in the correct order.
-  (let ((key (and key (%coerce-callable-to-fun key))))
-    (let ((res list2))
-      (dolist (elt list1)
-        (unless (with-set-keys (member (apply-key key elt) list2))
-          (push elt res)))
-      res)))
+  ;; We have to possibilities here: for shortish lists we pick up the
+  ;; shorter one as the result, and add the other one to it. For long
+  ;; lists we use a hash-table when possible.
+  (let ((n1 (length list1))
+        (n2 (length list2))
+        (key (and key (%coerce-callable-to-fun key)))
+        (test (if notp
+                  (let ((test-not-fun (%coerce-callable-to-fun test-not)))
+                    (lambda (x) (not (funcall test-not-fun x))))
+                  (%coerce-callable-to-fun test))))
+    (multiple-value-bind (short long n-short)
+        (if (< n1 n2)
+            (values list1 list2 n1)
+            (values list2 list1 n2))
+      (if (or (< n-short +list-based-union-limit+)
+              (not (member test (list #'eq #'eql #'equal #'equalp))))
+          (let ((orig short))
+            (dolist (elt long)
+              (unless (member (apply-key key elt) orig :key key :test test)
+                (push elt short)))
+            short)
+          (let ((table (make-hash-table :test test :size (+ n1 n2)))
+                (union nil))
+            (dolist (elt long)
+              (setf (gethash (apply-key key elt) table) elt))
+            (dolist (elt short)
+              (setf (gethash (apply-key key elt) table) elt))
+            (maphash (lambda (k v)
+                       (declare (ignore k))
+                       (push v union))
+                     table)
+            union)))))

 
 ;;; Destination and source are SETF-able and many-evaluable. Set the
 ;;; SOURCE to the CDR, and "cons" the 1st elt of source to DESTINATION.
 
 ;;; Destination and source are SETF-able and many-evaluable. Set the
 ;;; SOURCE to the CDR, and "cons" the 1st elt of source to DESTINATION.

@@ -762,8 +828,8 @@
 (defmacro steve-splice (source destination)
   `(let ((temp ,source))
      (setf ,source (cdr ,source)
 (defmacro steve-splice (source destination)
   `(let ((temp ,source))
      (setf ,source (cdr ,source)

-          (cdr temp) ,destination
-          ,destination temp)))
+           (cdr temp) ,destination
+           ,destination temp)))

 
 (defun nunion (list1 list2 &key key (test #'eql testp) (test-not nil notp))
   #!+sb-doc
 
 (defun nunion (list1 list2 &key key (test #'eql testp) (test-not nil notp))
   #!+sb-doc

@@ -771,15 +837,44 @@
   (declare (inline member))
   (when (and testp notp)
     (error ":TEST and :TEST-NOT were both supplied."))
   (declare (inline member))
   (when (and testp notp)
     (error ":TEST and :TEST-NOT were both supplied."))

-  (let ((key (and key (%coerce-callable-to-fun key))))
-    (let ((res list2)
-          (list1 list1))
-      (do ()
-          ((endp list1))
-        (if (not (with-set-keys (member (apply-key key (car list1)) list2)))
-            (steve-splice list1 res)
-            (setf list1 (cdr list1))))
-      res)))
+  ;; We have to possibilities here: for shortish lists we pick up the
+  ;; shorter one as the result, and add the other one to it. For long
+  ;; lists we use a hash-table when possible.
+  (let ((n1 (length list1))
+        (n2 (length list2))
+        (key (and key (%coerce-callable-to-fun key)))
+        (test (if notp
+                  (let ((test-not-fun (%coerce-callable-to-fun test-not)))
+                    (lambda (x) (not (funcall test-not-fun x))))
+                  (%coerce-callable-to-fun test))))
+    (multiple-value-bind (short long n-short)
+        (if (< n1 n2)
+            (values list1 list2 n1)
+            (values list2 list1 n2))
+      (if (or (< n-short +list-based-union-limit+)
+              (not (member test (list #'eq #'eql #'equal #'equalp))))
+          (let ((orig short))
+            (do ((elt (car long) (car long)))
+                ((endp long))
+              (if (not (member (apply-key key elt) orig :key key :test test))
+                  (steve-splice long short)
+                  (setf long (cdr long))))
+            short)
+          (let ((table (make-hash-table :test test :size (+ n1 n2))))
+            (dolist (elt long)
+              (setf (gethash (apply-key key elt) table) elt))
+            (dolist (elt short)
+              (setf (gethash (apply-key key elt) table) elt))
+            (let ((union long)
+                  (head long))
+              (maphash (lambda (k v)
+                         (declare (ignore k))
+                         (if head
+                             (setf (car head) v
+                                   head (cdr head))
+                             (push v union)))
+                      table)
+              union))))))

 
 (defun intersection (list1 list2
                      &key key (test #'eql testp) (test-not nil notp))
 
 (defun intersection (list1 list2
                      &key key (test #'eql testp) (test-not nil notp))

@@ -808,7 +903,7 @@
       (do () ((endp list1))
         (if (with-set-keys (member (apply-key key (car list1)) list2))
             (steve-splice list1 res)
       (do () ((endp list1))
         (if (with-set-keys (member (apply-key key (car list1)) list2))
             (steve-splice list1 res)

-            (setq list1 (Cdr list1))))
+            (setq list1 (cdr list1))))

       res)))
 
 (defun set-difference (list1 list2
       res)))
 
 (defun set-difference (list1 list2

@@ -857,7 +952,7 @@
     (declare (type function test test-not))
     (dolist (elt list1)
       (unless (with-set-keys (member (apply-key key elt) list2))
     (declare (type function test test-not))
     (dolist (elt list1)
       (unless (with-set-keys (member (apply-key key elt) list2))

-       (setq result (cons elt result))))
+        (setq result (cons elt result))))

     (let ((test (if testp
                     (lambda (x y) (funcall test y x))
                     test))
     (let ((test (if testp
                     (lambda (x y) (funcall test y x))
                     test))

@@ -886,32 +981,48 @@
     ;; reached, what is left of LIST2 is tacked onto what is left of
     ;; LIST1. The splicing operation ensures that the correct
     ;; operation is performed depending on whether splice is at the
     ;; reached, what is left of LIST2 is tacked onto what is left of
     ;; LIST1. The splicing operation ensures that the correct
     ;; operation is performed depending on whether splice is at the

-    ;; top of the list or not
+    ;; top of the list or not.

     (do ((list1 list1)
          (list2 list2)
          (x list1 (cdr x))
     (do ((list1 list1)
          (list2 list2)
          (x list1 (cdr x))

-         (splicex ()))
+         (splicex ())
+         (deleted-y ())
+         ;; elements of LIST2, which are "equal" to some processed
+         ;; earlier elements of LIST1
+         )

         ((endp x)
          (if (null splicex)
              (setq list1 list2)
              (rplacd splicex list2))
          list1)
         ((endp x)
          (if (null splicex)
              (setq list1 list2)
              (rplacd splicex list2))
          list1)

-      (do ((y list2 (cdr y))
-           (splicey ()))
-          ((endp y) (setq splicex x))
-        (cond ((let ((key-val-x (apply-key key (car x)))
-                     (key-val-y (apply-key key (Car y))))
-                 (if notp
-                     (not (funcall test-not key-val-x key-val-y))
-                     (funcall test key-val-x key-val-y)))
-               (if (null splicex)
-                   (setq list1 (cdr x))
-                   (rplacd splicex (cdr x)))
-               (if (null splicey)
-                   (setq list2 (cdr y))
-                   (rplacd splicey (cdr y)))
-               (return ())) ; assume lists are really sets
-              (t (setq splicey y)))))))
+      (let ((key-val-x (apply-key key (car x)))
+            (found-duplicate nil))
+
+        ;; Move all elements from LIST2, which are "equal" to (CAR X),
+        ;; to DELETED-Y.
+        (do* ((y list2 next-y)
+              (next-y (cdr y) (cdr y))
+              (splicey ()))
+             ((endp y))
+          (cond ((let ((key-val-y (apply-key key (car y))))
+                   (if notp
+                       (not (funcall test-not key-val-x key-val-y))
+                       (funcall test key-val-x key-val-y)))
+                 (if (null splicey)
+                     (setq list2 (cdr y))
+                     (rplacd splicey (cdr y)))
+                 (setq deleted-y (rplacd y deleted-y))
+                 (setq found-duplicate t))
+                (t (setq splicey y))))
+
+        (unless found-duplicate
+          (setq found-duplicate (with-set-keys (member key-val-x deleted-y))))
+
+        (if found-duplicate
+            (if (null splicex)
+                (setq list1 (cdr x))
+                (rplacd splicex (cdr x)))
+            (setq splicex x))))))

 
 (defun subsetp (list1 list2 &key key (test #'eql testp) (test-not nil notp))
   #!+sb-doc
 
 (defun subsetp (list1 list2 &key key (test #'eql testp) (test-not nil notp))
   #!+sb-doc

@@ -939,7 +1050,7 @@
        (y data (cdr y)))
       ((and (endp x) (endp y)) alist)
     (if (or (endp x) (endp y))
        (y data (cdr y)))
       ((and (endp x) (endp y)) alist)
     (if (or (endp x) (endp y))

-       (error "The lists of keys and data are of unequal length."))
+        (error "The lists of keys and data are of unequal length."))

     (setq alist (acons (car x) (car y) alist))))
 
 ;;; This is defined in the run-time environment, not just the compile-time
     (setq alist (acons (car x) (car y) alist))))
 
 ;;; This is defined in the run-time environment, not just the compile-time

@@ -1099,3 +1210,43 @@
   #!+sb-doc
   "Apply FUNCTION to successive CDRs of lists. Return NCONC of results."
   (map1 function (cons list more-lists) :nconc nil))
   #!+sb-doc
   "Apply FUNCTION to successive CDRs of lists. Return NCONC of results."
   (map1 function (cons list more-lists) :nconc nil))

+
+;;;; Specialized versions
+
+;;; %MEMBER-* and %ASSOC-* function. The transforms for %MEMBER and %ASSOC pick
+;;; the appropriate version. These win because they have only positional arguments,
+;;; the TEST & KEY functions are known to exist (or not), and are known to be
+;;; functions, not function designators.
+(macrolet ((def (funs form)
+             (flet ((%def (name)
+                      `(defun ,(intern (format nil "%~A~{-~A~}" name funs))
+                           (item list ,@funs)
+                         ,@(when funs `((declare (function ,@funs))))
+                         (do ((list list (cdr list)))
+                             ((null list) nil)
+                           (let ((this (car list)))
+                             ,(ecase name
+                                    (assoc
+                                     `(when this
+                                        (let ((target (car this)))
+                                          (when (and this ,form)
+                                            (return this)))))
+                                    (member
+                                     `(let ((target this))
+                                        (when ,form
+                                          (return list))))))))))
+               `(progn
+                  ,(%def 'member)
+                  ,(%def 'assoc)))))
+  (def ()
+      (eql item target))
+  (def (key)
+      (eql item (funcall key target)))
+  (def (key test)
+      (funcall test item (funcall key target)))
+  (def (key test-not)
+      (not (funcall test-not item (funcall key target))))
+  (def (test)
+      (funcall test item target))
+  (def (test-not)
+    (not (funcall test-not item target))))