X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=sidebyside;f=src%2Fcode%2Flist.lisp;h=fe663c658b569333f732c021df8a9ce8d654263d;hb=0e3c4b4db102bd204a30402d7e5a0de44aea57ce;hp=4d03a1adb1f45dd33aa7502d086276422cd2d601;hpb=9cafc84b9f5a885d622db5909d5bc8e2b87f4cd5;p=sbcl.git diff --git a/src/code/list.lisp b/src/code/list.lisp index 4d03a1a..fe663c6 100644 --- a/src/code/list.lisp +++ b/src/code/list.lisp @@ -18,11 +18,11 @@ ;;;; -- WHN 20000127 (declaim (maybe-inline - adjoin tree-equal nth %setnth nthcdr make-list - member-if member-if-not tailp union + tree-equal nth %setnth nthcdr make-list + tailp union nunion intersection nintersection set-difference nset-difference set-exclusive-or nset-exclusive-or subsetp acons - assoc-if assoc-if-not rassoc rassoc-if rassoc-if-not subst subst-if + subst subst-if subst-if-not nsubst nsubst-if nsubst-if-not sublis nsublis)) ;;; These functions perform basic list operations. @@ -320,7 +320,9 @@ (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))) @@ -339,7 +341,7 @@ (defun append (&rest lists) #!+sb-doc "Construct a new list by concatenating the list arguments" - (declare (dynamic-extent lists) (optimize speed)) + (declare (truly-dynamic-extent lists) (optimize speed)) (labels ((fail (object) (error 'type-error :datum object @@ -443,8 +445,21 @@ #!+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 @@ -469,7 +484,7 @@ (defun nconc (&rest lists) #!+sb-doc "Concatenates the lists given as arguments (by changing them)" - (declare (dynamic-extent lists) (optimize speed)) + (declare (truly-dynamic-extent lists) (optimize speed)) (flet ((fail (object) (error 'type-error :datum object @@ -507,45 +522,40 @@ ((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)) - (if (typep n 'index) - (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))))) - nil)) - (defun nbutlast (list &optional (n 1)) - (cond ((zerop n) - list) - ((not (typep n 'index)) - nil) - (t (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 @@ -799,41 +809,45 @@ ;;;; 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))) - (when (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 @@ -849,13 +863,21 @@ "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)))) - (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) @@ -865,7 +887,7 @@ (declare (inline member)) (when (and testp notp) (error ":TEST and :TEST-NOT were both supplied.")) - ;; We have to possibilities here: for shortish lists we pick up the + ;; 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)) @@ -873,7 +895,7 @@ (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)))) + (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) @@ -914,7 +936,7 @@ (declare (inline member)) (when (and testp notp) (error ":TEST and :TEST-NOT were both supplied.")) - ;; We have to possibilities here: for shortish lists we pick up the + ;; 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)) @@ -922,7 +944,7 @@ (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)))) + (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) @@ -1130,15 +1152,6 @@ (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 @@ -1150,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 @@ -1169,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 @@ -1179,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)) @@ -1194,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 @@ -1213,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 @@ -1223,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 @@ -1290,59 +1301,96 @@ ;;;; Specialized versions -;;; %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. +;;; %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) - `(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)))))))))) + (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 'assoc))))) + ,(%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 item target)) + (eql x target)) (def () - (eq item target) + (eq x target) eq) (def (key) - (eql item (funcall key target))) + (eql x (funcall key target))) (def (key) - (eq item (funcall key target)) + (eq x (funcall key target)) eq) (def (key test) - (funcall test item (funcall key target))) + (funcall test x (funcall key target))) (def (key test-not) - (not (funcall test-not item (funcall key target)))) + (not (funcall test-not x (funcall key target)))) (def (test) - (funcall test item target)) + (funcall test x target)) (def (test-not) - (not (funcall test-not item target)))) + (not (funcall test-not x target))))