0.9.8.34:

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

diff --git a/src/code/list.lisp b/src/code/list.lisp
index 8bc2a88..f15ad9f 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

@@ -299,37 +321,34 @@
   (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
   "Return a new association list which is EQUAL to ALIST."
 
 (defun copy-alist (alist)
   #!+sb-doc
   "Return a new association list which is EQUAL to ALIST."

-  (if (atom alist)
+  (if (endp alist)

       alist
       (let ((result
       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)))))
-           ;; Non-null terminated alist done here.
-           ((atom x)
-            (unless (null x)
-              (rplacd splice 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

@@ -391,10 +410,20 @@
                (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)."

-  (do ((1st (cdr x) (if (atom 1st) 1st (cdr 1st)))
+  (do ((1st (cdr x) (if (endp 1st) 1st (cdr 1st)))

        (2nd x 1st)              ;2nd follows first down the list.
        (3rd y 2nd))             ;3rd follows 2nd down the list.
       ((atom 2nd) 3rd)
        (2nd x 1st)              ;2nd follows first down the list.
        (3rd y 2nd))             ;3rd follows 2nd down the list.
       ((atom 2nd) 3rd)

@@ -404,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
 

@@ -471,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
 

@@ -503,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
 

@@ -573,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)))

@@ -592,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)))

@@ -611,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)))

@@ -640,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))))))))

@@ -652,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

@@ -666,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)))))

@@ -725,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

@@ -765,8 +804,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

@@ -811,7 +850,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

@@ -860,7 +899,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))

@@ -889,32 +928,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

@@ -942,7 +997,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