X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Flist.lisp;h=ca4463235947df4ae3cc7507e4ecd3724c214798;hb=068cf4b55af3f8f8acf2c7c06869441612261cd4;hp=a48af261437bfb0d53ce4361de1937a4de024055;hpb=423d7e5434081f8813e5c2399e4da052bcd36b57;p=sbcl.git diff --git a/src/code/list.lisp b/src/code/list.lisp index a48af26..ca44632 100644 --- a/src/code/list.lisp +++ b/src/code/list.lisp @@ -19,9 +19,9 @@ (declaim (maybe-inline tree-equal nth %setnth nthcdr last last1 make-list append - nconc nconc2 member member-if member-if-not tailp adjoin union + nconc nconc2 member-if member-if-not tailp adjoin union 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)) @@ -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 @@ -486,15 +490,15 @@ ;;;; functions to alter list structure -(defun rplaca (x y) +(defun rplaca (cons x) #!+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 - "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. @@ -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)) @@ -1160,35 +1217,54 @@ ;;;; 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))))) +;;; %MEMBER-* and %ASSOC-* functions. The transforms for MEMBER and +;;; ASSOC pick 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) + `(defun ,(intern (format nil "%~A~{-~A~}~@[-~A~]" name funs variant)) + (item list ,@funs) + (declare (optimize speed)) + ,@(when funs `((declare (function ,@funs)))) + (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)))))))))) + `(progn + ,(%def 'member) + ,(%def 'assoc))))) (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)