X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Flist.lisp;h=39af79ec1333c0b1f5dd186a9e6b1ceabdd8a9fb;hb=75f37cd646778cc8d4bed86d79309b7161bd41dc;hp=96911d1fbd9287acdffeea5015495e8e72d8e2c5;hpb=557df1e8a17c2f4d9f97752cb8476805e79f0073;p=sbcl.git diff --git a/src/code/list.lisp b/src/code/list.lisp index 96911d1..39af79e 100644 --- a/src/code/list.lisp +++ b/src/code/list.lisp @@ -19,10 +19,10 @@ (declaim (maybe-inline tree-equal nth %setnth nthcdr make-list - nconc nconc2 member-if member-if-not tailp union + 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 @@ -467,47 +469,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))))))) - -(defun nconc2 (x y) - (if (null x) y - (let ((z x) - (rest (cdr x))) - (loop - (unless (consp rest) - (rplacd z y) - (return x)) - (shiftf z rest (cdr rest)))))) + #!+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 @@ -810,41 +801,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 @@ -860,21 +855,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)))) - -(define-compiler-macro adjoin (item list &rest keys) - (with-unique-names (n-item n-list) - `(let ((,n-item ,item) - (,n-list ,list)) - (if (member ,n-item ,n-list ,@keys) - ,n-list - (cons ,n-item ,n-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) @@ -892,7 +887,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) @@ -941,7 +936,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) @@ -1149,15 +1144,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 @@ -1169,17 +1155,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 @@ -1188,8 +1173,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 @@ -1198,8 +1183,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)) @@ -1213,17 +1198,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 @@ -1232,8 +1216,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 @@ -1242,8 +1226,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 @@ -1309,59 +1293,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))))