X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Flist.lisp;h=4a72e1a8caa97dcce997a5639d677cc58e567560;hb=19efdada13c0ca54d5b0249aeeece458f888896e;hp=2353c5a8f4fb8e4c00febc755a0691f4f668fe95;hpb=b3a419f10ad442a1c59d51edabdc70518f193648;p=sbcl.git

diff --git a/src/code/list.lisp b/src/code/list.lisp
index 2353c5a..4a72e1a 100644
--- a/src/code/list.lisp
+++ b/src/code/list.lisp
@@ -11,17 +11,19 @@
 
 (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
-	  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))
@@ -115,22 +117,22 @@
 (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))
-  (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
@@ -211,25 +213,45 @@
   (cdr list))
 
 (defun nthcdr (n list)
-  (declare (type index n))
   #!+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."
-  (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
@@ -243,10 +265,10 @@
   #!+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
@@ -254,7 +276,7 @@
   (declare (type index size))
   (do ((count size (1- count))
        (result '() (cons initial-element result)))
-      ((zerop count) result)
+      ((<= count 0) result)
     (declare (type index count))))
 
 (defun append (&rest lists)
@@ -290,22 +312,26 @@
 
 ;;;; list copying functions
 
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (sb!xc:defmacro !copy-list-macro (list &key check-proper-list)
+    ;; Unless CHECK-PROPER-LIST is true, the list is copied correctly
+    ;; even if the list is not terminated by NIL. The new list is built
+    ;; by CDR'ing SPLICE which is always at the tail of the new list.
+    `(when ,list
+       (let ((copy (list (car ,list))))
+         (do ((orig (cdr ,list) (cdr orig))
+              (splice copy (cdr (rplacd splice (cons (car orig) nil)))))
+             (,@(if check-proper-list
+                    '((endp orig))
+                    '((atom orig)
+                      (unless (null orig)
+                        (rplacd splice orig))))
+              copy))))))
+
 (defun copy-list (list)
   #!+sb-doc
-  "Return a new list which is EQUAL to LIST."
-  ;; The list is copied correctly even if the list is not terminated
-  ;; by NIL. The new list is built by CDR'ing SPLICE which is always
-  ;; at the tail of the new 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)))
+  "Return a new list which is EQUAL to LIST. LIST may be improper."
+  (!copy-list-macro list))
 
 (defun copy-alist (alist)
   #!+sb-doc
@@ -313,20 +339,20 @@
   (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
@@ -388,6 +414,16 @@
                (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)."
@@ -401,52 +437,56 @@
        ;; 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))
-    (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))
-    (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))
-	(result (list ()))
-	(splice result))
+        (result (list ()))
+        (splice result))
        ((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)
-	(return (cdr result))
-	(setq splice (cdr (rplacd splice (list (car list))))))))
+        (return (cdr result))
+        (setq splice (cdr (rplacd splice (list (car list))))))))
 
 ;;;; functions to alter list structure
 
@@ -468,15 +508,21 @@
 
 ;;; 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))))
 
 ;;;; :KEY arg optimization to save funcall of IDENTITY
 
@@ -500,8 +546,8 @@
   (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))))))
 
 ;;;; substitution of expressions
 
@@ -570,7 +616,7 @@
                (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)))
@@ -589,7 +635,7 @@
                (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)))
@@ -608,7 +654,7 @@
                (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)))
@@ -637,7 +683,7 @@
                        ((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))))))))
@@ -649,8 +695,8 @@
   (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
@@ -663,16 +709,16 @@
     (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)
-                                (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))
-                                (return (setf (Cdr last) (Cdr temp)))
+                                (return (setf (cdr last) (cdr temp)))
                                 (setf (car subtree) (s (car subtree)))))
                           subtree))))
         (s tree)))))
@@ -692,8 +738,8 @@
     (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
@@ -722,7 +768,7 @@
   (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
@@ -738,22 +784,46 @@
         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."))
-  ;; 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.
@@ -762,8 +832,8 @@
 (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
@@ -771,15 +841,44 @@
   (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))
@@ -808,7 +907,7 @@
       (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
@@ -857,7 +956,7 @@
     (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))
@@ -886,32 +985,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
-    ;; top of the list or not
+    ;; top of the list or not.
     (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)
-      (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
@@ -939,7 +1054,7 @@
        (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
@@ -1099,3 +1214,43 @@
   #!+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))))