1.0.16.13: use TRANSFORM-LIST-ITEM-SEEK for ADJOIN as well

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

diff --git a/src/code/list.lisp b/src/code/list.lisp
index 225f1bb..551420d 100644 (file)
--- a/src/code/list.lisp
+++ b/src/code/list.lisp
@@ -18,10 +18,10 @@
 ;;;; -- WHN 20000127
 
 (declaim (maybe-inline
 ;;;; -- WHN 20000127
 
 (declaim (maybe-inline

-          tree-equal nth %setnth nthcdr last last1 make-list append
-          nconc nconc2 member member-if member-if-not tailp adjoin union
+          tree-equal nth %setnth nthcdr make-list
+          member-if member-if-not tailp union

           nunion intersection nintersection set-difference nset-difference
           nunion intersection nintersection set-difference nset-difference

-          set-exclusive-or nset-exclusive-or subsetp acons assoc
+          set-exclusive-or nset-exclusive-or subsetp acons

           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))
 
           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))
 

@@ -230,27 +230,85 @@
               (fast-nthcdr (mod n i) r-i))
            (declare (type index 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))
-    (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."
-  (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)))
+;;; LAST
+;;;
+;;; Transforms in src/compiler/srctran.lisp pick the most specific
+;;; version possible. %LAST/BIGNUM is admittedly somewhat academic...
+(macrolet ((last0-macro ()
+             `(let ((rest list)
+                    (list list))
+                (loop (unless (consp rest)
+                        (return rest))
+                  (shiftf list rest (cdr rest)))))
+           (last1-macro ()
+             `(let ((rest list)
+                    (list list))
+                (loop (unless (consp rest)
+                        (return list))
+                  (shiftf list rest (cdr rest)))))
+           (lastn-macro (type)
+             `(let ((returned-list list)
+                    (checked-list list)
+                    (n (truly-the ,type n)))
+                (declare (,type n))
+                (tagbody
+                 :scan
+                   (pop checked-list)
+                   (when (atom checked-list)
+                     (go :done))
+                   (if (zerop (truly-the ,type (decf n)))
+                       (go :pop)
+                       (go :scan))
+                 :pop
+                   (pop returned-list)
+                   (pop checked-list)
+                   (if (atom checked-list)
+                       (go :done)
+                       (go :pop))
+                 :done)
+                returned-list)))
+
+  (defun %last0 (list)
+    (declare (optimize speed (sb!c::verify-arg-count 0)))
+    (last0-macro))
+
+  (defun %last1 (list)
+    (declare (optimize speed (sb!c::verify-arg-count 0)))
+    (last1-macro))
+
+  (defun %lastn/fixnum (list n)
+    (declare (optimize speed (sb!c::verify-arg-count 0))
+             (type (and unsigned-byte fixnum) n))
+    (case n
+      (1 (last1-macro))
+      (0 (last0-macro))
+      (t (lastn-macro fixnum))))
+
+  (defun %lastn/bignum (list n)
+    (declare (optimize speed (sb!c::verify-arg-count 0))
+             (type (and unsigned-byte bignum) n))
+    (lastn-macro unsigned-byte))
+
+  (defun last (list &optional (n 1))
+    #!+sb-doc
+    "Return the last N conses (not the last element!) of a list."
+    (case n
+      (1 (last1-macro))
+      (0 (last0-macro))
+      (t
+       (typecase n
+         (fixnum
+          (lastn-macro fixnum))
+         (bignum
+          (lastn-macro unsigned-byte)))))))
+
+(define-compiler-macro last (&whole form list &optional (n 1) &environment env)
+  (if (sb!xc:constantp n env)
+      (case (constant-form-value n env)
+        (0 `(%last0 ,list))
+        (1 `(%last1 ,list))
+        (t form))
+      form))

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

@@ -275,58 +333,90 @@
   (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)
   #!+sb-doc
   "Construct a new list by concatenating the list arguments"
     (declare (type index count))))
 \f
 (defun append (&rest lists)
   #!+sb-doc
   "Construct a new list by concatenating the list arguments"

+  (declare (dynamic-extent lists) (optimize speed))

   (labels ((fail (object)
              (error 'type-error
                     :datum object
                     :expected-type 'list))
            (append-into (last-cons current rest)
   (labels ((fail (object)
              (error 'type-error
                     :datum object
                     :expected-type 'list))
            (append-into (last-cons current rest)

-             "Set (CDR LAST-CONS) to (APPLY #'APPEND CURRENT REST)."
+             ;; Set (CDR LAST-CONS) to (APPLY #'APPEND CURRENT REST).

              (declare (cons last-cons rest))
              (declare (cons last-cons rest))

-             (cond ((consp current)
-                    (append-into (setf (cdr last-cons) (list (car current)))
-                                (cdr current)
-                                rest))
-                   ((not (null current)) (fail current))
-                   ((null (cdr rest)) (setf (cdr last-cons) (car rest)))
-                   (t (append-into last-cons (car rest) (cdr rest)))))
+             (if (listp current)
+                 (if (consp current)
+                     ;; normal case, cdr down the list
+                     (append-into (setf (cdr last-cons) (list (car current)))
+                                  (cdr current)
+                                  rest)
+                     ;; empty list
+                     (let ((more (cdr rest)))
+                       (if (null more)
+                           (setf (cdr last-cons) (car rest))
+                           (append-into last-cons (car rest) more))))
+                 (fail current)))

            (append1 (lists)
              (let ((current (car lists))
                    (rest (cdr lists)))
            (append1 (lists)
              (let ((current (car lists))
                    (rest (cdr lists)))

-               (cond ((null rest) current)
+               (cond ((null rest)
+                      current)

                      ((consp current)
                       (let ((result (truly-the cons (list (car current)))))
                         (append-into result
                      ((consp current)
                       (let ((result (truly-the cons (list (car current)))))
                         (append-into result

-                                    (cdr current)
-                                    rest)
+                                     (cdr current)
+                                     rest)

                         result))
                         result))

-                     ((null current) (append1 rest))
-                     (t (fail current))))))
+                     ((null current)
+                      (append1 rest))
+                     (t
+                      (fail current))))))

     (append1 lists)))
     (append1 lists)))

+
+(defun append2 (x y)
+  (declare (optimize speed (sb!c::verify-arg-count 0)))
+  (if (null x)
+      y
+      (let ((result (list (car x))))
+        (do ((more (cdr x) (cdr more))
+             (tail result (cdr tail)))
+            ((null more)
+             (rplacd tail y)
+             result)
+          (rplacd tail (list (car more)))))))
+
+(define-compiler-macro append (&whole form &rest lists)
+  (case (length lists)
+    (0 nil)
+    (1 (car lists))
+    (2 `(append2 ,@lists))
+    (t form)))

 \f
 ;;;; list copying functions
 
 \f
 ;;;; 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
 (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
 
 (defun copy-alist (alist)
   #!+sb-doc

@@ -377,47 +467,36 @@
 ;;; and it avoids running down the last argument to NCONC which allows
 ;;; the last argument to be circular.
 (defun nconc (&rest lists)
 ;;; and it avoids running down the last argument to NCONC which allows
 ;;; the last argument to be circular.
 (defun nconc (&rest lists)

-  #!+sb-doc
-  "Concatenates the lists given as arguments (by changing them)"
-  (flet ((fail (object)
-           (error 'type-error
-                  :datum object
-                  :expected-type 'list)))
-    (do ((top lists (cdr top)))
-        ((null top) nil)
-      (let ((top-of-top (car top)))
-        (typecase top-of-top
-          (cons
-           (let* ((result top-of-top)
-                  (splice result))
-             (do ((elements (cdr top) (cdr elements)))
-                 ((endp elements))
-               (let ((ele (car elements)))
-                 (typecase ele
-                   (cons (rplacd (last splice) ele)
-                         (setf splice ele))
-                   (null (rplacd (last splice) nil))
-                   (atom (if (cdr elements)
-                             (fail ele)
-                             (rplacd (last splice) ele)))
-                   (t (fail ele)))))
-             (return result)))
-          (null)
-          (atom
-           (if (cdr top)
-               (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))))))
+   #!+sb-doc
+   "Concatenates the lists given as arguments (by changing them)"
+   (declare (dynamic-extent lists) (optimize speed))
+   (flet ((fail (object)
+            (error 'type-error
+                   :datum object
+                   :expected-type 'list)))
+     (do ((top lists (cdr top)))
+         ((null top) nil)
+       (let ((top-of-top (car top)))
+         (typecase top-of-top
+           (cons
+            (let* ((result top-of-top)
+                   (splice result))
+              (do ((elements (cdr top) (cdr elements)))
+                  ((endp elements))
+                (let ((ele (car elements)))
+                  (typecase ele
+                    (cons (rplacd (last splice) ele)
+                          (setf splice ele))
+                    (null (rplacd (last splice) nil))
+                    (atom (if (cdr elements)
+                              (fail ele)
+                              (rplacd (last splice) ele))))))
+              (return result)))
+           (null)
+           (atom
+            (if (cdr top)
+                (fail top-of-top)
+                (return top-of-top))))))))

 
 (defun nreconc (x y)
   #!+sb-doc
 
 (defun nreconc (x y)
   #!+sb-doc

@@ -485,15 +564,15 @@
 \f
 ;;;; functions to alter list structure
 
 \f
 ;;;; functions to alter list structure
 

-(defun rplaca (x y)
+(defun rplaca (cons x)

   #!+sb-doc
   #!+sb-doc

-  "Change the CAR of X to Y and return the new X."
-  (rplaca x y))
+  "Change the CAR of CONS to X and return the CONS."
+  (rplaca cons x))

 
 

-(defun rplacd (x y)
+(defun rplacd (cons x)

   #!+sb-doc
   #!+sb-doc

-  "Change the CDR of X to Y and return the new X."
-  (rplacd x y))
+  "Change the CDR of CONS to X and return the CONS."
+  (rplacd cons x))

 
 ;;; The following are for use by SETF.
 
 
 ;;; The following are for use by SETF.
 

@@ -733,8 +812,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

@@ -771,7 +850,6 @@
   (when (and testp notp)
     (error ":TEST and :TEST-NOT were both supplied."))
   (let ((key (and key (%coerce-callable-to-fun key))))
   (when (and testp notp)
     (error ":TEST and :TEST-NOT were both supplied."))
   (let ((key (and key (%coerce-callable-to-fun key))))

-    (declare (inline member))

     (if (let ((key-val (apply-key key item)))
           (if notp
               (member key-val list :test-not test-not :key key)
     (if (let ((key-val (apply-key key item)))
           (if notp
               (member key-val list :test-not test-not :key key)

@@ -779,22 +857,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.

@@ -812,15 +914,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))

@@ -1156,3 +1287,76 @@
   #!+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
+
+;;; %ADJOIN-*, %ASSOC-*, and %MEMBER-* functions. Deftransforms
+;;; delegate to TRANSFORM-LIST-ITEM-SEEK which picks the appropriate
+;;; version. These win because they have only positional arguments,
+;;; the TEST, TEST-NOT & KEY functions are known to exist (or not),
+;;; and are known to be functions instead of function designators. We
+;;; are also able to transform many common cases to -EQ versions,
+;;; which are substantially faster then EQL using ones.
+(macrolet
+    ((def (funs form &optional variant)
+       (flet ((%def (name)
+                (let* ((body-loop
+                        `(do ((list list (cdr list)))
+                             ((null list) nil)
+                           (declare (list list))
+                           (let ((this (car list)))
+                             ,(ecase name
+                                     (assoc
+                                      (if funs
+                                          `(when this
+                                             (let ((target (car this)))
+                                               (when ,form
+                                                 (return this))))
+                                          ;; If there is no TEST/TEST-NOT or
+                                          ;; KEY, do the EQ/EQL test first,
+                                          ;; before checking for NIL.
+                                          `(let ((target (car this)))
+                                             (when (and ,form this)
+                                               (return this)))))
+                                     (member
+                                      `(let ((target this))
+                                         (when ,form
+                                           (return list))))
+                                     (adjoin
+                                      `(let ((target this))
+                                         (when ,form
+                                           (return t))))))))
+                       (body (if (eq 'adjoin name)
+                                 `(if (let ,(when (member 'key funs)
+                                                  `((item (funcall key item))))
+                                        ,body-loop)
+                                      list
+                                      (cons item list))
+                                 body-loop)))
+                  `(defun ,(intern (format nil "%~A~{-~A~}~@[-~A~]" name funs variant))
+                       (item list ,@funs)
+                     (declare (optimize speed (sb!c::verify-arg-count 0)))
+                     ,@(when funs `((declare (function ,@funs))))
+                     ,body))))
+         `(progn
+            ,(%def 'adjoin)
+            ,(%def 'assoc)
+            ,(%def 'member)))))
+  (def ()
+      (eql item target))
+  (def ()
+      (eq item target)
+    eq)
+  (def (key)
+      (eql item (funcall key target)))
+  (def (key)
+      (eq item (funcall key target))
+    eq)
+  (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))))