X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Flist.lisp;h=4a72e1a8caa97dcce997a5639d677cc58e567560;hb=a01e7ac2e8a9f3afae8f759381a0829fceb5bfde;hp=f15ad9f8aa0fd68f770900b2d77d1847527397e9;hpb=abd50c820df25616883a6850df1780044365137e;p=sbcl.git diff --git a/src/code/list.lisp b/src/code/list.lisp index f15ad9f..4a72e1a 100644 --- a/src/code/list.lisp +++ b/src/code/list.lisp @@ -276,7 +276,7 @@ (declare (type index size)) (do ((count size (1- count)) (result '() (cons initial-element result))) - ((zerop count) result) + ((<= count 0) result) (declare (type index count)))) (defun append (&rest lists) @@ -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 @@ -734,8 +738,8 @@ (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 @@ -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)) @@ -1157,3 +1214,43 @@ #!+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))))