1.0.10.51: New function: THREAD-YIELD

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

diff --git a/src/code/list.lisp b/src/code/list.lisp
index b328681..5f96806 100644 (file)
--- a/src/code/list.lisp
+++ b/src/code/list.lisp
@@ -233,7 +233,8 @@
 (defun last1 (list)
   #!+sb-doc
   "Return the last cons (not the last element) of a list"
 (defun last1 (list)
   #!+sb-doc
   "Return the last cons (not the last element) of a list"

-  (let ((rest list))
+  (let ((rest list)
+        (list list))

     (loop (unless (consp rest) (return list))
           (shiftf list rest (cdr rest)))))
 
     (loop (unless (consp rest) (return list))
           (shiftf list rest (cdr rest)))))
 

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

@@ -394,12 +395,12 @@
                  ((endp elements))
                (let ((ele (car elements)))
                  (typecase ele
                  ((endp elements))
                (let ((ele (car elements)))
                  (typecase ele

-                   (cons (rplacd (last1 splice) ele)
+                   (cons (rplacd (last splice) ele)

                          (setf splice ele))
                          (setf splice ele))

-                   (null (rplacd (last1 splice) nil))
+                   (null (rplacd (last splice) nil))

                    (atom (if (cdr elements)
                              (fail ele)
                    (atom (if (cdr elements)
                              (fail ele)

-                             (rplacd (last1 splice) ele)))
+                             (rplacd (last splice) ele)))

                    (t (fail ele)))))
              (return result)))
           (null)
                    (t (fail ele)))))
              (return result)))
           (null)

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

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

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

@@ -1121,7 +1175,7 @@
           (setf (car l) (cdar l)))
         (setq res (apply fun (nreverse args)))
         (case accumulate
           (setf (car l) (cdar l)))
         (setq res (apply fun (nreverse args)))
         (case accumulate

-          (:nconc (setq temp (last1 (nconc temp res))))
+          (:nconc (setq temp (last (nconc temp res))))

           (:list (rplacd temp (list res))
                  (setq temp (cdr temp))))))))
 
           (:list (rplacd temp (list res))
                  (setq temp (cdr temp))))))))
 

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