X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=inline;f=src%2Fcode%2Flist.lisp;h=4a72e1a8caa97dcce997a5639d677cc58e567560;hb=4898febe4d3ab2eaa83c26cd4c1ff113772100c4;hp=a48af261437bfb0d53ce4361de1937a4de024055;hpb=423d7e5434081f8813e5c2399e4da052bcd36b57;p=sbcl.git diff --git a/src/code/list.lisp b/src/code/list.lisp index a48af26..4a72e1a 100644 --- a/src/code/list.lisp +++ b/src/code/list.lisp @@ -312,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 @@ -780,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. @@ -813,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))