X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Flist.lisp;h=fe663c658b569333f732c021df8a9ce8d654263d;hb=54da325f13fb41669869aea688ae195426c0e231;hp=2353c5a8f4fb8e4c00febc755a0691f4f668fe95;hpb=b3a419f10ad442a1c59d51edabdc70518f193648;p=sbcl.git diff --git a/src/code/list.lisp b/src/code/list.lisp index 2353c5a..fe663c6 100644 --- a/src/code/list.lisp +++ b/src/code/list.lisp @@ -11,17 +11,19 @@ (in-package "SB!IMPL") +;;; Limitation: no list might have more than INDEX conses. + ;;;; KLUDGE: comment from CMU CL, what does it mean? ;;;; NSUBLIS, things at the beginning broken. ;;;; -- WHN 20000127 (declaim (maybe-inline - tree-equal nth %setnth nthcdr last make-list append - nconc member member-if member-if-not tailp adjoin union - nunion intersection nintersection set-difference nset-difference - set-exclusive-or nset-exclusive-or subsetp acons assoc - 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)) + tree-equal nth %setnth nthcdr make-list + tailp union + nunion intersection nintersection set-difference nset-difference + set-exclusive-or nset-exclusive-or subsetp acons + subst subst-if + subst-if-not nsubst nsubst-if nsubst-if-not sublis nsublis)) ;;; These functions perform basic list operations. (defun car (list) #!+sb-doc "Return the 1st object in a list." (car list)) @@ -115,22 +117,22 @@ (defun tree-equal-test-not (x y test-not) (declare (type function test-not)) (cond ((consp x) - (and (consp y) - (tree-equal-test-not (car x) (car y) test-not) - (tree-equal-test-not (cdr x) (cdr y) test-not))) - ((consp y) nil) - ((not (funcall test-not x y)) t) - (t ()))) + (and (consp y) + (tree-equal-test-not (car x) (car y) test-not) + (tree-equal-test-not (cdr x) (cdr y) test-not))) + ((consp y) nil) + ((not (funcall test-not x y)) t) + (t ()))) (defun tree-equal-test (x y test) (declare (type function test)) - (cond ((consp x) - (and (consp y) - (tree-equal-test (car x) (car y) test) - (tree-equal-test (cdr x) (cdr y) test))) - ((consp y) nil) - ((funcall test x y) t) - (t ()))) + (cond ((consp x) + (and (consp y) + (tree-equal-test (car x) (car y) test) + (tree-equal-test (cdr x) (cdr y) test))) + ((consp y) nil) + ((funcall test x y) t) + (t ()))) (defun tree-equal (x y &key (test #'eql testp) (test-not nil notp)) #!+sb-doc @@ -211,25 +213,102 @@ (cdr list)) (defun nthcdr (n list) - (declare (type index n)) #!+sb-doc "Performs the cdr function n times on a list." - (do ((i n (1- i)) - (result list (cdr result))) - ((not (plusp i)) result) - (declare (type index i)))) - -(defun last (list &optional (n 1)) - #!+sb-doc - "Return the last N conses (not the last element!) of a list." - (declare (type index n)) - (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)))) + (flet ((fast-nthcdr (n list) + (declare (type index n)) + (do ((i n (1- i)) + (result list (cdr result))) + ((not (plusp i)) result) + (declare (type index i))))) + (typecase n + (index (fast-nthcdr n list)) + (t (do ((i 0 (1+ i)) + (r-i list (cdr r-i)) + (r-2i list (cddr r-2i))) + ((and (eq r-i r-2i) (not (zerop i))) + (fast-nthcdr (mod n i) r-i)) + (declare (type index i))))))) + +;;; 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 @@ -241,12 +320,14 @@ (defun list* (arg &rest others) #!+sb-doc - "Return a list of the arguments with last cons a dotted pair" + "Return a list of the arguments with last cons a dotted pair." + ;; We know the &REST is a proper list. + (declare (optimize (sb!c::type-check 0))) (cond ((atom others) arg) - ((atom (cdr others)) (cons arg (car others))) - (t (do ((x others (cdr x))) - ((null (cddr x)) (rplacd x (cadr x)))) - (cons arg others)))) + ((atom (cdr others)) (cons arg (car others))) + (t (do ((x others (cdr x))) + ((null (cddr x)) (rplacd x (cadr x)))) + (cons arg others)))) (defun make-list (size &key initial-element) #!+sb-doc @@ -254,58 +335,90 @@ (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) #!+sb-doc "Construct a new list by concatenating the list arguments" + (declare (truly-dynamic-extent lists) (optimize speed)) (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)) - (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))) - (cond ((null rest) current) + (cond ((null rest) + current) ((consp current) (let ((result (truly-the cons (list (car current))))) (append-into result - (cdr current) - rest) + (cdr current) + rest) result)) - ((null current) (append1 rest)) - (t (fail current)))))) + ((null current) + (append1 rest)) + (t + (fail current)))))) (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))) ;;;; 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 @@ -313,27 +426,40 @@ (if (endp alist) alist (let ((result - (cons (if (atom (car alist)) - (car alist) - (cons (caar alist) (cdar alist))) - nil))) - (do ((x (cdr alist) (cdr x)) - (splice result - (cdr (rplacd splice - (cons - (if (atom (car x)) - (car x) - (cons (caar x) (cdar x))) - nil))))) - ((endp x))) - result))) + (cons (if (atom (car alist)) + (car alist) + (cons (caar alist) (cdar alist))) + nil))) + (do ((x (cdr alist) (cdr x)) + (splice result + (cdr (rplacd splice + (cons + (if (atom (car x)) + (car x) + (cons (caar x) (cdar x))) + nil))))) + ((endp x))) + result))) (defun copy-tree (object) #!+sb-doc "Recursively copy trees of conses." (if (consp object) - (cons (copy-tree (car object)) (copy-tree (cdr object))) + (let ((result (list (if (consp (car object)) + (copy-tree (car object)) + (car object))))) + (loop for last-cons = result then new-cons + for cdr = (cdr object) then (cdr cdr) + for car = (if (consp cdr) + (car cdr) + (return (setf (cdr last-cons) cdr))) + for new-cons = (list (if (consp car) + (copy-tree car) + car)) + do (setf (cdr last-cons) new-cons)) + result) object)) + ;;;; more commonly-used list functions @@ -356,37 +482,36 @@ ;;; 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))))))) + #!+sb-doc + "Concatenates the lists given as arguments (by changing them)" + (declare (truly-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 @@ -397,68 +522,67 @@ ((atom 2nd) 3rd) (rplacd 2nd 3rd))) -(flet (;; Return the number of conses at the head of the - ;; possibly-improper list LIST. (Or if LIST is circular, you - ;; lose.) - (count-conses (list) - (do ((in-list list (cdr in-list)) - (result 0 (1+ result))) - ((atom in-list) - result) - (declare (type index result))))) - (declare (ftype (function (t) index) count-conses)) - (defun butlast (list &optional (n 1)) - (let ((n-conses-in-list (count-conses list))) - (cond ((zerop n) - ;; (We can't use SUBSEQ in this case because LIST isn't - ;; necessarily a proper list, but SUBSEQ expects a - ;; proper sequence. COPY-LIST isn't so fussy.) - (copy-list list)) - ((>= n n-conses-in-list) - nil) - (t - ;; (LIST isn't necessarily a proper list in this case - ;; either, and technically SUBSEQ wants a proper - ;; sequence, but no reasonable implementation of SUBSEQ - ;; will actually walk down to the end of the list to - ;; check, and since we're calling our own implementation - ;; we know it's reasonable, so it's OK.) - (subseq list 0 (- n-conses-in-list n)))))) - (defun nbutlast (list &optional (n 1)) - (if (zerop n) - list - (let ((n-conses-in-list (count-conses list))) - (unless (<= n-conses-in-list n) - (setf (cdr (nthcdr (- n-conses-in-list n 1) list)) - nil) - list))))) +(defun butlast (list &optional (n 1)) + (cond ((zerop n) + (copy-list list)) + ((not (typep n 'index)) + nil) + (t + (let ((head (nthcdr (1- n) list))) + (and (consp head) ; there are at least n + (collect ((copy)) ; conses; copy! + (do ((trail list (cdr trail)) + (head head (cdr head))) + ;; HEAD is n-1 conses ahead of TRAIL; + ;; when HEAD is at the last cons, return + ;; the data copied so far. + ((atom (cdr head)) + (copy)) + (copy (car trail))))))))) + +(defun nbutlast (list &optional (n 1)) + (cond ((zerop n) + list) + ((not (typep n 'index)) + nil) + (t + (let ((head (nthcdr (1- n) list))) + (and (consp head) ; there are more than n + (consp (cdr head)) ; conses. + ;; TRAIL trails by n cons to be able to + ;; cut the list at the cons just before. + (do ((trail list (cdr trail)) + (head (cdr head) (cdr head))) + ((atom (cdr head)) + (setf (cdr trail) nil) + list))))))) (defun ldiff (list object) "Return a new list, whose elements are those of LIST that appear before OBJECT. If OBJECT is not a tail of LIST, a copy of LIST is returned. LIST must be a proper list or a dotted list." (do* ((list list (cdr list)) - (result (list ())) - (splice result)) + (result (list ())) + (splice result)) ((atom list) - (if (eql list object) - (cdr result) - (progn (rplacd splice list) (cdr result)))) + (if (eql list object) + (cdr result) + (progn (rplacd splice list) (cdr result)))) (if (eql list object) - (return (cdr result)) - (setq splice (cdr (rplacd splice (list (car list)))))))) + (return (cdr result)) + (setq splice (cdr (rplacd splice (list (car list)))))))) ;;;; 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. @@ -468,15 +592,21 @@ ;;; Set the Nth element of LIST to NEWVAL. (defun %setnth (n list newval) - (declare (type index n)) - (do ((count n (1- count)) - (list list (cdr list))) - ((endp list) - (error "~S is too large an index for SETF of NTH." n)) - (declare (type fixnum count)) - (when (<= count 0) - (rplaca list newval) - (return newval)))) + (typecase n + (index + (do ((count n (1- count)) + (list list (cdr list))) + ((endp list) + (error "~S is too large an index for SETF of NTH." n)) + (declare (type fixnum count)) + (when (<= count 0) + (rplaca list newval) + (return newval)))) + (t (let ((cons (nthcdr n list))) + (when (endp cons) + (error "~S is too large an index for SETF of NTH." n)) + (rplaca cons newval) + newval)))) ;;;; :KEY arg optimization to save funcall of IDENTITY @@ -500,8 +630,8 @@ (let ((key-tmp (gensym))) `(let ((,key-tmp (apply-key key ,elt))) (cond (testp (funcall test ,item ,key-tmp)) - (notp (not (funcall test-not ,item ,key-tmp))) - (t (funcall test ,item ,key-tmp)))))) + (notp (not (funcall test-not ,item ,key-tmp))) + (t (funcall test ,item ,key-tmp)))))) ;;;; substitution of expressions @@ -570,7 +700,7 @@ (cond ((satisfies-the-test old subtree) new) ((atom subtree) subtree) (t (do* ((last nil subtree) - (subtree subtree (Cdr subtree))) + (subtree subtree (cdr subtree))) ((atom subtree) (if (satisfies-the-test old subtree) (setf (cdr last) new))) @@ -589,7 +719,7 @@ (cond ((funcall test (apply-key key subtree)) new) ((atom subtree) subtree) (t (do* ((last nil subtree) - (subtree subtree (Cdr subtree))) + (subtree subtree (cdr subtree))) ((atom subtree) (if (funcall test (apply-key key subtree)) (setf (cdr last) new))) @@ -608,7 +738,7 @@ (cond ((not (funcall test (apply-key key subtree))) new) ((atom subtree) subtree) (t (do* ((last nil subtree) - (subtree subtree (Cdr subtree))) + (subtree subtree (cdr subtree))) ((atom subtree) (if (not (funcall test (apply-key key subtree))) (setf (cdr last) new))) @@ -637,7 +767,7 @@ ((atom subtree) subtree) (t (let ((car (s (car subtree))) (cdr (s (cdr subtree)))) - (if (and (eq car (car subtreE)) + (if (and (eq car (car subtree)) (eq cdr (cdr subtree))) subtree (cons car cdr)))))))) @@ -649,8 +779,8 @@ (let ((key-tmp (gensym))) `(let ((,key-tmp (apply-key key subtree))) (if notp - (assoc ,key-tmp alist :test-not test-not) - (assoc ,key-tmp alist :test test))))) + (assoc ,key-tmp alist :test-not test-not) + (assoc ,key-tmp alist :test test))))) (defun nsublis (alist tree &key key (test #'eql testp) (test-not #'eql notp)) #!+sb-doc @@ -663,57 +793,61 @@ (declare (inline assoc)) (let (temp) (labels ((s (subtree) - (cond ((Setq temp (nsublis-macro)) + (cond ((setq temp (nsublis-macro)) (cdr temp)) ((atom subtree) subtree) (t (do* ((last nil subtree) - (subtree subtree (Cdr subtree))) + (subtree subtree (cdr subtree))) ((atom subtree) (if (setq temp (nsublis-macro)) (setf (cdr last) (cdr temp)))) (if (setq temp (nsublis-macro)) - (return (setf (Cdr last) (Cdr temp))) + (return (setf (cdr last) (cdr temp))) (setf (car subtree) (s (car subtree))))) subtree)))) (s tree))))) ;;;; functions for using lists as sets -(defun member (item list &key key (test #'eql testp) (test-not #'eql notp)) +(defun member (item list &key key (test nil testp) (test-not nil notp)) #!+sb-doc "Return the tail of LIST beginning with first element satisfying EQLity, :TEST, or :TEST-NOT with the given ITEM." (when (and testp notp) (error ":TEST and :TEST-NOT were both supplied.")) (let ((key (and key (%coerce-callable-to-fun key))) - (test (if testp (%coerce-callable-to-fun test) test)) - (test-not (if notp (%coerce-callable-to-fun test-not) test-not))) - (declare (type function test test-not)) - (do ((list list (cdr list))) - ((null list) nil) - (let ((car (car list))) - (if (satisfies-the-test item car) - (return list)))))) + (test (and testp (%coerce-callable-to-fun test))) + (test-not (and notp (%coerce-callable-to-fun test-not)))) + (cond (test + (if key + (%member-key-test item list key test) + (%member-test item list test))) + (test-not + (if key + (%member-key-test-not item list key test-not) + (%member-test-not item list test-not))) + (t + (if key + (%member-key item list key) + (%member item list)))))) (defun member-if (test list &key key) #!+sb-doc "Return tail of LIST beginning with first element satisfying TEST." (let ((test (%coerce-callable-to-fun test)) (key (and key (%coerce-callable-to-fun key)))) - (do ((list list (cdr list))) - ((endp list) nil) - (if (funcall test (apply-key key (car list))) - (return list))))) + (if key + (%member-if-key test list key) + (%member-if test list)))) (defun member-if-not (test list &key key) #!+sb-doc "Return tail of LIST beginning with first element not satisfying TEST." (let ((test (%coerce-callable-to-fun test)) (key (and key (%coerce-callable-to-fun key)))) - (do ((list list (cdr list))) - ((endp list) ()) - (if (not (funcall test (apply-key key (car list)))) - (return list))))) + (if key + (%member-if-not-key test list key) + (%member-if-not test list)))) (defun tailp (object list) #!+sb-doc @@ -722,21 +856,30 @@ (do ((list list (cdr list))) ((atom list) (eql list object)) (if (eql object list) - (return t)))) + (return t)))) (defun adjoin (item list &key key (test #'eql testp) (test-not nil notp)) #!+sb-doc "Add ITEM to LIST unless it is already a member" (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) - (member key-val list :test test :key key))) - list - (cons item list)))) + (let ((key (and key (%coerce-callable-to-fun key))) + (test (and testp (%coerce-callable-to-fun test))) + (test-not (and notp (%coerce-callable-to-fun test-not)))) + (cond (test + (if key + (%adjoin-key-test item list key test) + (%adjoin-test item list test))) + (test-not + (if key + (%adjoin-key-test-not item list key test-not) + (%adjoin-test-not item list test-not))) + (t + (if key + (%adjoin-key item list key) + (%adjoin item list)))))) + +(defconstant +list-based-union-limit+ 80) (defun union (list1 list2 &key key (test #'eql testp) (test-not nil notp)) #!+sb-doc @@ -744,16 +887,38 @@ (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 two 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 y) (not (funcall test-not-fun x y)))) + (%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. @@ -762,8 +927,8 @@ (defmacro steve-splice (source destination) `(let ((temp ,source)) (setf ,source (cdr ,source) - (cdr temp) ,destination - ,destination temp))) + (cdr temp) ,destination + ,destination temp))) (defun nunion (list1 list2 &key key (test #'eql testp) (test-not nil notp)) #!+sb-doc @@ -771,15 +936,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 two 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 y) (not (funcall test-not-fun x y)))) + (%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)) @@ -808,7 +1002,7 @@ (do () ((endp list1)) (if (with-set-keys (member (apply-key key (car list1)) list2)) (steve-splice list1 res) - (setq list1 (Cdr list1)))) + (setq list1 (cdr list1)))) res))) (defun set-difference (list1 list2 @@ -857,7 +1051,7 @@ (declare (type function test test-not)) (dolist (elt list1) (unless (with-set-keys (member (apply-key key elt) list2)) - (setq result (cons elt result)))) + (setq result (cons elt result)))) (let ((test (if testp (lambda (x y) (funcall test y x)) test)) @@ -886,32 +1080,48 @@ ;; reached, what is left of LIST2 is tacked onto what is left of ;; LIST1. The splicing operation ensures that the correct ;; operation is performed depending on whether splice is at the - ;; top of the list or not + ;; top of the list or not. (do ((list1 list1) (list2 list2) (x list1 (cdr x)) - (splicex ())) + (splicex ()) + (deleted-y ()) + ;; elements of LIST2, which are "equal" to some processed + ;; earlier elements of LIST1 + ) ((endp x) (if (null splicex) (setq list1 list2) (rplacd splicex list2)) list1) - (do ((y list2 (cdr y)) - (splicey ())) - ((endp y) (setq splicex x)) - (cond ((let ((key-val-x (apply-key key (car x))) - (key-val-y (apply-key key (Car y)))) - (if notp - (not (funcall test-not key-val-x key-val-y)) - (funcall test key-val-x key-val-y))) - (if (null splicex) - (setq list1 (cdr x)) - (rplacd splicex (cdr x))) - (if (null splicey) - (setq list2 (cdr y)) - (rplacd splicey (cdr y))) - (return ())) ; assume lists are really sets - (t (setq splicey y))))))) + (let ((key-val-x (apply-key key (car x))) + (found-duplicate nil)) + + ;; Move all elements from LIST2, which are "equal" to (CAR X), + ;; to DELETED-Y. + (do* ((y list2 next-y) + (next-y (cdr y) (cdr y)) + (splicey ())) + ((endp y)) + (cond ((let ((key-val-y (apply-key key (car y)))) + (if notp + (not (funcall test-not key-val-x key-val-y)) + (funcall test key-val-x key-val-y))) + (if (null splicey) + (setq list2 (cdr y)) + (rplacd splicey (cdr y))) + (setq deleted-y (rplacd y deleted-y)) + (setq found-duplicate t)) + (t (setq splicey y)))) + + (unless found-duplicate + (setq found-duplicate (with-set-keys (member key-val-x deleted-y)))) + + (if found-duplicate + (if (null splicex) + (setq list1 (cdr x)) + (rplacd splicex (cdr x))) + (setq splicex x)))))) (defun subsetp (list1 list2 &key key (test #'eql testp) (test-not nil notp)) #!+sb-doc @@ -939,18 +1149,9 @@ (y data (cdr y))) ((and (endp x) (endp y)) alist) (if (or (endp x) (endp y)) - (error "The lists of keys and data are of unequal length.")) + (error "The lists of keys and data are of unequal length.")) (setq alist (acons (car x) (car y) alist)))) -;;; This is defined in the run-time environment, not just the compile-time -;;; environment (i.e. not wrapped in EVAL-WHEN (COMPILE EVAL)) because it -;;; can appear in inline expansions. -(defmacro assoc-guts (test-expr) - `(do ((alist alist (cdr alist))) - ((endp alist)) - (when (and (car alist) ,test-expr) - (return (car alist))))) - (defun assoc (item alist &key key (test nil testp) (test-not nil notp)) #!+sb-doc "Return the cons in ALIST whose car is equal (by a given test or EQL) to @@ -962,17 +1163,16 @@ (test-not (and notp (%coerce-callable-to-fun test-not)))) (cond (test (if key - (assoc-guts (funcall test item (funcall key (caar alist)))) - (assoc-guts (funcall test item (caar alist))))) + (%assoc-key-test item alist key test) + (%assoc-test item alist test))) (test-not (if key - (assoc-guts (not (funcall test-not item - (funcall key (caar alist))))) - (assoc-guts (not (funcall test-not item (caar alist)))))) + (%assoc-key-test-not item alist key test-not) + (%assoc-test-not item alist test-not))) (t (if key - (assoc-guts (eql item (funcall key (caar alist)))) - (assoc-guts (eql item (caar alist)))))))) + (%assoc-key item alist key) + (%assoc item alist)))))) (defun assoc-if (predicate alist &key key) #!+sb-doc @@ -981,8 +1181,8 @@ (let ((predicate (%coerce-callable-to-fun predicate)) (key (and key (%coerce-callable-to-fun key)))) (if key - (assoc-guts (funcall predicate (funcall key (caar alist)))) - (assoc-guts (funcall predicate (caar alist)))))) + (%assoc-if-key predicate alist key) + (%assoc-if predicate alist)))) (defun assoc-if-not (predicate alist &key key) #!+sb-doc @@ -991,8 +1191,8 @@ (let ((predicate (%coerce-callable-to-fun predicate)) (key (and key (%coerce-callable-to-fun key)))) (if key - (assoc-guts (not (funcall predicate (funcall key (caar alist))))) - (assoc-guts (not (funcall predicate (caar alist))))))) + (%assoc-if-not-key predicate alist key) + (%assoc-if-not predicate alist)))) (defun rassoc (item alist &key key (test nil testp) (test-not nil notp)) (declare (list alist)) @@ -1006,17 +1206,16 @@ (test-not (and notp (%coerce-callable-to-fun test-not)))) (cond (test (if key - (assoc-guts (funcall test item (funcall key (cdar alist)))) - (assoc-guts (funcall test item (cdar alist))))) + (%rassoc-key-test item alist key test) + (%rassoc-test item alist test))) (test-not (if key - (assoc-guts (not (funcall test-not item - (funcall key (cdar alist))))) - (assoc-guts (not (funcall test-not item (cdar alist)))))) + (%rassoc-key-test-not item alist key test-not) + (%rassoc-test-not item alist test-not))) (t (if key - (assoc-guts (eql item (funcall key (cdar alist)))) - (assoc-guts (eql item (cdar alist)))))))) + (%rassoc-key item alist key) + (%rassoc item alist)))))) (defun rassoc-if (predicate alist &key key) #!+sb-doc @@ -1025,8 +1224,8 @@ (let ((predicate (%coerce-callable-to-fun predicate)) (key (and key (%coerce-callable-to-fun key)))) (if key - (assoc-guts (funcall predicate (funcall key (cdar alist)))) - (assoc-guts (funcall predicate (cdar alist)))))) + (%rassoc-if-key predicate alist key) + (%rassoc-if predicate alist)))) (defun rassoc-if-not (predicate alist &key key) #!+sb-doc @@ -1035,8 +1234,8 @@ (let ((predicate (%coerce-callable-to-fun predicate)) (key (and key (%coerce-callable-to-fun key)))) (if key - (assoc-guts (not (funcall predicate (funcall key (cdar alist))))) - (assoc-guts (not (funcall predicate (cdar alist))))))) + (%rassoc-if-not-key predicate alist key) + (%rassoc-if-not predicate alist)))) ;;;; mapping functions @@ -1099,3 +1298,99 @@ #!+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-*, %MEMBER-*, and %RASSOC-* functions. Deftransforms +;;; delegate to TRANSFORM-LIST-PRED-SEEK and TRANSFORM-LIST-ITEM-SEEK which +;;; pick the appropriate versions. 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 &optional conditional) + (let* ((body-loop + `(do ((list list (cdr list))) + ((null list) nil) + (declare (list list)) + (let ((this (car list))) + ,(let ((cxx (if (char= #\A (char (string name) 0)) + 'car ; assoc, assoc-if, assoc-if-not + 'cdr))) ; rassoc, rassoc-if, rassoc-if-not + (ecase name + ((assoc rassoc) + (if funs + `(when this + (let ((target (,cxx 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 (,cxx this))) + (when (and ,form this) + (return this))))) + ((assoc-if assoc-if-not rassoc-if rassoc-if-not) + (aver (equal '(eql x) (subseq form 0 2))) + `(when this + (let ((target (,cxx this))) + (,conditional (funcall ,@(cdr form)) + (return this))))) + (member + `(let ((target this)) + (when ,form + (return list)))) + ((member-if member-if-not) + (aver (equal '(eql x) (subseq form 0 2))) + `(let ((target this)) + (,conditional (funcall ,@(cdr form)) + (return list)))) + (adjoin + `(let ((target this)) + (when ,form + (return t))))))))) + (body (if (eq 'adjoin name) + `(if (let ,(when (member 'key funs) + `((x (funcall key x)))) + ,body-loop) + list + (cons x list)) + body-loop))) + `(defun ,(intern (format nil "%~A~{-~A~}~@[-~A~]" name funs variant)) + (x list ,@funs) + (declare (optimize speed (sb!c::verify-arg-count 0))) + ,@(when funs `((declare (function ,@funs)))) + ,@(unless (member name '(member assoc adjoin rassoc)) `((declare (function x)))) + ,body)))) + `(progn + ,(%def 'adjoin) + ,(%def 'assoc) + ,(%def 'member) + ,(%def 'rassoc) + ,@(when (and (not variant) (member funs '(() (key)) :test #'equal)) + (list (%def 'member-if 'when) + (%def 'member-if-not 'unless) + (%def 'assoc-if 'when) + (%def 'assoc-if-not 'unless) + (%def 'rassoc-if 'when) + (%def 'rassoc-if-not 'unless))))))) + (def () + (eql x target)) + (def () + (eq x target) + eq) + (def (key) + (eql x (funcall key target))) + (def (key) + (eq x (funcall key target)) + eq) + (def (key test) + (funcall test x (funcall key target))) + (def (key test-not) + (not (funcall test-not x (funcall key target)))) + (def (test) + (funcall test x target)) + (def (test-not) + (not (funcall test-not x target))))