0.8.0.32:

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

diff --git a/src/code/list.lisp b/src/code/list.lisp
index 8bc2a88..a65faac 100644 (file)
--- a/src/code/list.lisp
+++ b/src/code/list.lisp
@@ -301,7 +301,7 @@
       (let ((result (list (car list))))
        (do ((x (cdr list) (cdr x))
             (splice result
       (let ((result (list (car list))))
        (do ((x (cdr list) (cdr x))
             (splice result

-                    (cdr (rplacd splice (cons (car x) '() ))) ))
+                    (cdr (rplacd splice (cons (car x) '())))))

            ((atom x)
             (unless (null x)
               (rplacd splice x))))
            ((atom x)
             (unless (null x)
               (rplacd splice x))))

@@ -310,12 +310,12 @@
 (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
             (cons (if (atom (car alist))
                       (car alist)
       alist
       (let ((result
             (cons (if (atom (car alist))
                       (car alist)

-                      (cons (caar alist) (cdar alist)) )
+                      (cons (caar alist) (cdar alist)))

                   nil)))
        (do ((x (cdr alist) (cdr x))
             (splice result
                   nil)))
        (do ((x (cdr alist) (cdr x))
             (splice result

@@ -325,10 +325,7 @@
                                       (car x)
                                       (cons (caar x) (cdar x)))
                                   nil)))))
                                       (car x)
                                       (cons (caar x) (cdar x)))
                                   nil)))))

-           ;; Non-null terminated alist done here.
-           ((atom x)
-            (unless (null x)
-              (rplacd splice x))))
+           ((endp x)))

        result)))
 
 (defun copy-tree (object)
        result)))
 
 (defun copy-tree (object)

@@ -394,7 +391,7 @@
 (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)

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