X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Flist.lisp;h=fe663c658b569333f732c021df8a9ce8d654263d;hb=4ba392170e98744f0ef0b8e08a5d42b988f1d0c9;hp=088394cc451cfe47ff8394c6161ea6f2d5c52b93;hpb=1aefe68236aaf048ce602e7725ad26d130be1fd5;p=sbcl.git diff --git a/src/code/list.lisp b/src/code/list.lisp index 088394c..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)) @@ -113,29 +115,33 @@ (declaim (maybe-inline tree-equal-test tree-equal-test-not)) (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) - (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) test-not) + (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 ()))) + +(defun tree-equal (x y &key (test #'eql testp) (test-not nil notp)) #!+sb-doc "Return T if X and Y are isomorphic trees with identical leaves." + (when (and testp notp) + (error ":TEST and :TEST-NOT were both supplied.")) (if test-not - (tree-equal-test-not x y test-not) - (tree-equal-test x y test))) + (tree-equal-test-not x y (%coerce-callable-to-fun test-not)) + (tree-equal-test x y (%coerce-callable-to-fun test)))) (defun endp (object) #!+sb-doc @@ -151,7 +157,8 @@ (y list (cddr y)) (z list (cdr z))) (()) - (declare (fixnum n) (list y z)) + (declare (type fixnum n) + (type list y z)) (when (endp y) (return n)) (when (endp (cdr y)) (return (+ n 1))) (when (and (eq y z) (> n 0)) (return nil)))) @@ -206,42 +213,121 @@ (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 "Return constructs and returns a list of its arguments." args) -;;; List* is done the same as list, except that the last cons is made a -;;; dotted pair +;;; LIST* is done the same as LIST, except that the last cons is made +;;; a dotted pair. (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 @@ -249,100 +335,133 @@ (declare (type index size)) (do ((count size (1- count)) (result '() (cons initial-element result))) - ((zerop count) result) + ((<= count 0) result) (declare (type index count)))) -;;; The outer loop finds the first non-null list and the result is started. -;;; The remaining lists in the arguments are tacked to the end of the result -;;; using splice which cdr's down the end of the new list - (defun append (&rest lists) #!+sb-doc "Construct a new list by concatenating the list arguments" - (flet ((fail (object) - (error 'type-error - :datum object - :expected-type 'list))) - (do ((top lists (cdr top))) ; CDR to first non-null list. - ((atom top) '()) - (cond ((null (car top))) ; NIL -> Keep looping - ((not (consp (car top))) ; Non CONS - (if (cdr top) - (fail (car top)) - (return (car top)))) - (t ; Start appending - (return - (if (atom (cdr top)) - (car top) ; Special case. - (let* ((result (cons (caar top) '())) - (splice result)) - (do ((x (cdar top) (cdr x))) ; Copy first list - ((atom x)) - (setq splice - (cdr (rplacd splice (cons (car x) ()) ))) ) - (do ((y (cdr top) (cdr y))) ; Copy rest of lists. - ((atom (cdr y)) - (setq splice (rplacd splice (car y))) - result) - (if (listp (car y)) - (do ((x (car y) (cdr x))) ; Inner copy loop. - ((atom x)) - (setq - splice - (cdr (rplacd splice (cons (car x) ()))))) - (fail (car y)))))))))))) + (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). + (declare (cons last-cons 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) + ((consp current) + (let ((result (truly-the cons (list (car current))))) + (append-into result + (cdr current) + rest) + result)) + ((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 +;;;; 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 "Return a new association list which is EQUAL to ALIST." - (if (atom alist) + (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))))) - ;; Non-null terminated alist done here. - ((atom x) - (unless (null x) - (rplacd splice 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 +;;;; more commonly-used list functions (defun revappend (x y) #!+sb-doc @@ -363,109 +482,107 @@ ;;; 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 - "Return (nconc (nreverse x) y)." - (do ((1st (cdr x) (if (atom 1st) 1st (cdr 1st))) - (2nd x 1st) ;2nd follows first down the list. - (3rd y 2nd)) ;3rd follows 2nd down the list. + "Return (NCONC (NREVERSE X) Y)." + (do ((1st (cdr x) (if (endp 1st) 1st (cdr 1st))) + (2nd x 1st) ;2nd follows first down the list. + (3rd y 2nd)) ;3rd follows 2nd down the list. ((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. @@ -475,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 (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 @@ -499,187 +622,232 @@ ;;; Use these with the following &KEY args: (defmacro with-set-keys (funcall) - `(cond ((and testp notp) (error ":TEST and :TEST-NOT were both supplied.")) - (notp ,(append funcall '(:key key :test-not test-not))) - (t ,(append funcall '(:key key :test test))))) + `(if notp + ,(append funcall '(:key key :test-not test-not)) + ,(append funcall '(:key key :test test)))) (defmacro satisfies-the-test (item elt) (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 -(defun subst (new old tree &key key (test #'eql testp) (test-not nil notp)) +(defun subst (new old tree &key key (test #'eql testp) (test-not #'eql notp)) #!+sb-doc "Substitutes new for subtrees matching old." - (labels ((s (subtree) - (cond ((satisfies-the-test old subtree) new) - ((atom subtree) subtree) - (t (let ((car (s (car subtree))) - (cdr (s (cdr subtree)))) - (if (and (eq car (car subtree)) - (eq cdr (cdr subtree))) - subtree - (cons car cdr))))))) - (s tree))) + (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)) + (labels ((s (subtree) + (cond ((satisfies-the-test old subtree) new) + ((atom subtree) subtree) + (t (let ((car (s (car subtree))) + (cdr (s (cdr subtree)))) + (if (and (eq car (car subtree)) + (eq cdr (cdr subtree))) + subtree + (cons car cdr))))))) + (s tree)))) (defun subst-if (new test tree &key key) #!+sb-doc "Substitutes new for subtrees for which test is true." - (labels ((s (subtree) - (cond ((funcall test (apply-key key subtree)) new) - ((atom subtree) subtree) - (t (let ((car (s (car subtree))) - (cdr (s (cdr subtree)))) - (if (and (eq car (car subtree)) - (eq cdr (cdr subtree))) - subtree - (cons car cdr))))))) - (s tree))) + (let ((test (%coerce-callable-to-fun test)) + (key (and key (%coerce-callable-to-fun key)))) + (labels ((s (subtree) + (cond ((funcall test (apply-key key subtree)) new) + ((atom subtree) subtree) + (t (let ((car (s (car subtree))) + (cdr (s (cdr subtree)))) + (if (and (eq car (car subtree)) + (eq cdr (cdr subtree))) + subtree + (cons car cdr))))))) + (s tree)))) (defun subst-if-not (new test tree &key key) #!+sb-doc "Substitutes new for subtrees for which test is false." - (labels ((s (subtree) - (cond ((not (funcall test (apply-key key subtree))) new) - ((atom subtree) subtree) - (t (let ((car (s (car subtree))) - (cdr (s (cdr subtree)))) - (if (and (eq car (car subtree)) - (eq cdr (cdr subtree))) - subtree - (cons car cdr))))))) - (s tree))) - -(defun nsubst (new old tree &key key (test #'eql testp) (test-not nil notp)) + (let ((test (%coerce-callable-to-fun test)) + (key (and key (%coerce-callable-to-fun key)))) + (labels ((s (subtree) + (cond ((not (funcall test (apply-key key subtree))) new) + ((atom subtree) subtree) + (t (let ((car (s (car subtree))) + (cdr (s (cdr subtree)))) + (if (and (eq car (car subtree)) + (eq cdr (cdr subtree))) + subtree + (cons car cdr))))))) + (s tree)))) + +(defun nsubst (new old tree &key key (test #'eql testp) (test-not #'eql notp)) #!+sb-doc - "Substitutes new for subtrees matching old." - (labels ((s (subtree) - (cond ((satisfies-the-test old subtree) new) - ((atom subtree) subtree) - (t (do* ((last nil subtree) - (subtree subtree (Cdr subtree))) - ((atom subtree) - (if (satisfies-the-test old subtree) - (setf (cdr last) new))) - (if (satisfies-the-test old subtree) - (return (setf (cdr last) new)) - (setf (car subtree) (s (car subtree))))) - subtree)))) - (s tree))) + "Substitute NEW for subtrees matching OLD." + (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)) + (labels ((s (subtree) + (cond ((satisfies-the-test old subtree) new) + ((atom subtree) subtree) + (t (do* ((last nil subtree) + (subtree subtree (cdr subtree))) + ((atom subtree) + (if (satisfies-the-test old subtree) + (setf (cdr last) new))) + (if (satisfies-the-test old subtree) + (return (setf (cdr last) new)) + (setf (car subtree) (s (car subtree))))) + subtree)))) + (s tree)))) (defun nsubst-if (new test tree &key key) #!+sb-doc - "Substitutes new for subtrees of tree for which test is true." - (labels ((s (subtree) - (cond ((funcall test (apply-key key subtree)) new) - ((atom subtree) subtree) - (t (do* ((last nil subtree) - (subtree subtree (Cdr subtree))) - ((atom subtree) - (if (funcall test (apply-key key subtree)) - (setf (cdr last) new))) - (if (funcall test (apply-key key subtree)) - (return (setf (cdr last) new)) - (setf (car subtree) (s (car subtree))))) - subtree)))) - (s tree))) + "Substitute NEW for subtrees of TREE for which TEST is true." + (let ((test (%coerce-callable-to-fun test)) + (key (and key (%coerce-callable-to-fun key)))) + (labels ((s (subtree) + (cond ((funcall test (apply-key key subtree)) new) + ((atom subtree) subtree) + (t (do* ((last nil subtree) + (subtree subtree (cdr subtree))) + ((atom subtree) + (if (funcall test (apply-key key subtree)) + (setf (cdr last) new))) + (if (funcall test (apply-key key subtree)) + (return (setf (cdr last) new)) + (setf (car subtree) (s (car subtree))))) + subtree)))) + (s tree)))) (defun nsubst-if-not (new test tree &key key) #!+sb-doc - "Substitutes new for subtrees of tree for which test is false." - (labels ((s (subtree) - (cond ((not (funcall test (apply-key key subtree))) new) - ((atom subtree) subtree) - (t (do* ((last nil subtree) - (subtree subtree (Cdr subtree))) - ((atom subtree) - (if (not (funcall test (apply-key key subtree))) - (setf (cdr last) new))) - (if (not (funcall test (apply-key key subtree))) - (return (setf (cdr last) new)) - (setf (car subtree) (s (car subtree))))) - subtree)))) - (s tree))) + "Substitute NEW for subtrees of TREE for which TEST is false." + (let ((test (%coerce-callable-to-fun test)) + (key (and key (%coerce-callable-to-fun key)))) + (labels ((s (subtree) + (cond ((not (funcall test (apply-key key subtree))) new) + ((atom subtree) subtree) + (t (do* ((last nil subtree) + (subtree subtree (cdr subtree))) + ((atom subtree) + (if (not (funcall test (apply-key key subtree))) + (setf (cdr last) new))) + (if (not (funcall test (apply-key key subtree))) + (return (setf (cdr last) new)) + (setf (car subtree) (s (car subtree))))) + subtree)))) + (s tree)))) -(defun sublis (alist tree &key key (test #'eql) (test-not nil notp)) - #!+sb-doc - "Substitutes from alist into tree nondestructively." - (declare (inline assoc)) - (labels ((s (subtree) - (let* ((key-val (apply-key key subtree)) - (assoc (if notp - (assoc key-val alist :test-not test-not) - (assoc key-val alist :test test)))) - (cond (assoc (cdr assoc)) - ((atom subtree) subtree) - (t (let ((car (s (car subtree))) - (cdr (s (cdr subtree)))) - (if (and (eq car (car subtreE)) - (eq cdr (cdr subtree))) - subtree - (cons car cdr)))))))) - (s tree))) - -;;; These are in run-time env (i.e. not wrapped in EVAL-WHEN (COMPILE EVAL)) -;;; because they can be referenced in inline expansions. +(defun sublis (alist tree &key key (test #'eql testp) (test-not #'eql notp)) + #!+sb-doc + "Substitute from ALIST into TREE nondestructively." + (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)) + (declare (inline assoc)) + (labels ((s (subtree) + (let* ((key-val (apply-key key subtree)) + (assoc (if notp + (assoc key-val alist :test-not test-not) + (assoc key-val alist :test test)))) + (cond (assoc (cdr assoc)) + ((atom subtree) subtree) + (t (let ((car (s (car subtree))) + (cdr (s (cdr subtree)))) + (if (and (eq car (car subtree)) + (eq cdr (cdr subtree))) + subtree + (cons car cdr)))))))) + (s tree)))) + +;;; This is in run-time env (i.e. not wrapped in EVAL-WHEN (COMPILE EVAL)) +;;; because it can be referenced in inline expansions. (defmacro nsublis-macro () (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))))) - -(defun nsublis (alist tree &key key (test #'eql) (test-not nil notp)) - #!+sb-doc - "Substitutes new for subtrees matching old." - (declare (inline assoc)) - (let (temp) - (labels ((s (subtree) - (cond ((Setq temp (nsublis-macro)) - (cdr temp)) - ((atom subtree) subtree) - (t (do* ((last nil 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))) - (setf (car subtree) (s (car subtree))))) - subtree)))) - (s tree)))) + (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 + "Substitute from ALIST into TRUE destructively." + (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 (inline assoc)) + (let (temp) + (labels ((s (subtree) + (cond ((setq temp (nsublis-macro)) + (cdr temp)) + ((atom subtree) subtree) + (t (do* ((last nil 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))) + (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 nil 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." - (do ((list list (cdr list))) - ((null list) nil) - (let ((car (car list))) - (if (satisfies-the-test item car) - (return list))))) + (when (and testp notp) + (error ":TEST and :TEST-NOT were both supplied.")) + (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 + (%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." - (do ((list list (Cdr list))) - ((endp list) nil) - (if (funcall test (apply-key key (car list))) - (return list)))) + (let ((test (%coerce-callable-to-fun test)) + (key (and key (%coerce-callable-to-fun key)))) + (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." - (do ((list list (cdr list))) - ((endp list) ()) - (if (not (funcall test (apply-key key (car list)))) - (return list)))) + (let ((test (%coerce-callable-to-fun test)) + (key (and key (%coerce-callable-to-fun key)))) + (if key + (%member-if-not-key test list key) + (%member-if-not test list)))) (defun tailp (object list) #!+sb-doc @@ -688,33 +856,69 @@ (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) (test-not nil notp)) +(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" - (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))) - -;;; This function 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. + (when (and testp notp) + (error ":TEST and :TEST-NOT were both supplied.")) + (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 "Return the union of LIST1 and LIST2." (declare (inline member)) - (when (and testp notp) (error "Test and test-not both supplied.")) - (let ((res list2)) - (dolist (elt list1) - (unless (with-set-keys (member (apply-key key elt) list2)) - (push elt res))) - res)) + (when (and testp notp) + (error ":TEST and :TEST-NOT were both supplied.")) + ;; 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. @@ -723,96 +927,131 @@ (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 "Destructively return the union of LIST1 and LIST2." (declare (inline member)) - (if (and testp notp) - (error ":TEST and :TEST-NOT were both supplied.")) - (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)) - -(defun intersection (list1 list2 &key key - (test #'eql testp) (test-not nil notp)) + (when (and testp notp) + (error ":TEST and :TEST-NOT were both supplied.")) + ;; 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)) #!+sb-doc "Return the intersection of LIST1 and LIST2." (declare (inline member)) - (if (and testp notp) - (error "Test and test-not both supplied.")) - (let ((res nil)) - (dolist (elt list1) - (if (with-set-keys (member (apply-key key elt) list2)) - (push elt res))) - res)) - -(defun nintersection (list1 list2 &key key - (test #'eql testp) (test-not nil notp)) + (when (and testp notp) + (error ":TEST and :TEST-NOT were both supplied.")) + (let ((key (and key (%coerce-callable-to-fun key)))) + (let ((res nil)) + (dolist (elt list1) + (if (with-set-keys (member (apply-key key elt) list2)) + (push elt res))) + res))) + +(defun nintersection (list1 list2 + &key key (test #'eql testp) (test-not nil notp)) #!+sb-doc "Destructively return the intersection of LIST1 and LIST2." (declare (inline member)) - (if (and testp notp) - (error "Test and test-not both supplied.")) - (let ((res nil) - (list1 list1)) - (do () ((endp list1)) - (if (with-set-keys (member (apply-key key (car list1)) list2)) - (steve-splice list1 res) - (setq list1 (Cdr list1)))) - res)) - -(defun set-difference (list1 list2 &key key - (test #'eql testp) (test-not nil notp)) + (when (and testp notp) + (error ":TEST and :TEST-NOT were both supplied.")) + (let ((key (and key (%coerce-callable-to-fun key)))) + (let ((res nil) + (list1 list1)) + (do () ((endp list1)) + (if (with-set-keys (member (apply-key key (car list1)) list2)) + (steve-splice list1 res) + (setq list1 (cdr list1)))) + res))) + +(defun set-difference (list1 list2 + &key key (test #'eql testp) (test-not nil notp)) #!+sb-doc "Return the elements of LIST1 which are not in LIST2." (declare (inline member)) - (if (and testp notp) - (error "Test and test-not both supplied.")) - (if (null list2) - list1 - (let ((res nil)) - (dolist (elt list1) - (if (not (with-set-keys (member (apply-key key elt) list2))) - (push elt res))) - res))) - -(defun nset-difference (list1 list2 &key key - (test #'eql testp) (test-not nil notp)) + (when (and testp notp) + (error ":TEST and :TEST-NOT were both supplied.")) + (let ((key (and key (%coerce-callable-to-fun key)))) + (if (null list2) + list1 + (let ((res nil)) + (dolist (elt list1) + (if (not (with-set-keys (member (apply-key key elt) list2))) + (push elt res))) + res)))) + +(defun nset-difference (list1 list2 + &key key (test #'eql testp) (test-not nil notp)) #!+sb-doc "Destructively return the elements of LIST1 which are not in LIST2." (declare (inline member)) - (if (and testp notp) - (error "Test and test-not both supplied.")) - (let ((res nil) - (list1 list1)) - (do () ((endp list1)) - (if (not (with-set-keys (member (apply-key key (car list1)) list2))) - (steve-splice list1 res) - (setq list1 (cdr list1)))) - res)) - -(defun set-exclusive-or (list1 list2 &key key - (test #'eql testp) (test-not nil notp)) + (when (and testp notp) + (error ":TEST and :TEST-NOT were both supplied.")) + (let ((key (and key (%coerce-callable-to-fun key)))) + (let ((res nil) + (list1 list1)) + (do () ((endp list1)) + (if (not (with-set-keys (member (apply-key key (car list1)) list2))) + (steve-splice list1 res) + (setq list1 (cdr list1)))) + res))) + +(defun set-exclusive-or (list1 list2 + &key key (test #'eql testp) (test-not #'eql notp)) #!+sb-doc "Return new list of elements appearing exactly once in LIST1 and LIST2." (declare (inline member)) + (when (and testp notp) + (error ":TEST and :TEST-NOT were both supplied.")) (let ((result nil) - (key (when key (coerce key 'function))) - (test (coerce test 'function)) - (test-not (if test-not (coerce test-not 'function) #'eql))) - (declare (type (or function null) key) - (type function test test-not)) + (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)) (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)) @@ -824,53 +1063,79 @@ (setq result (cons elt result))))) result)) -;;; The outer loop examines list1 while the inner loop examines list2. -;;; If an element is found in list2 "equal" to the element in list1, -;;; both are spliced out. When the end of list1 is 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 -(defun nset-exclusive-or (list1 list2 &key (test #'eql) (test-not nil notp) - key) +(defun nset-exclusive-or (list1 list2 + &key key (test #'eql testp) (test-not #'eql notp)) #!+sb-doc "Destructively return a list with elements which appear but once in LIST1 and LIST2." - (do ((list1 list1) - (list2 list2) - (x list1 (cdr x)) - (splicex ())) - ((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)))))) + (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)) + ;; The outer loop examines LIST1 while the inner loop examines + ;; LIST2. If an element is found in LIST2 "equal" to the element + ;; in LIST1, both are spliced out. When the end of LIST1 is + ;; 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. + (do ((list1 list1) + (list2 list2) + (x list1 (cdr x)) + (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) + (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 "Return T if every element in LIST1 is also in LIST2." (declare (inline member)) - (dolist (elt list1) - (unless (with-set-keys (member (apply-key key elt) list2)) - (return-from subsetp nil))) - T) + (when (and testp notp) + (error ":TEST and :TEST-NOT were both supplied.")) + (let ((key (and key (%coerce-callable-to-fun key)))) + (dolist (elt list1) + (unless (with-set-keys (member (apply-key key elt) list2)) + (return-from subsetp nil))) + t)) -;;; functions that operate on association lists +;;;; functions that operate on association lists (defun acons (key datum alist) #!+sb-doc @@ -884,143 +1149,248 @@ (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 in the run-time environment (i.e. not wrapped in -;;; EVAL-WHEN (COMPILE EVAL)) because these guys can be inline -;;; expanded. -(defmacro assoc-guts (test-guy) - `(do ((alist alist (cdr alist))) - ((endp alist)) - ;; FIXME: would be clearer as (WHEN (AND ..) ..) - (if (car alist) - (if ,test-guy (return (car alist)))))) - -(defun assoc (item alist &key key test test-not) +(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 the ITEM." - ;; FIXME: Shouldn't there be a check for existence of both TEST and TEST-NOT? - (cond (test - (if key - (assoc-guts (funcall test item (funcall key (caar alist)))) - (assoc-guts (funcall test item (caar alist))))) - (test-not - (if key - (assoc-guts (not (funcall test-not item - (funcall key (caar alist))))) - (assoc-guts (not (funcall test-not item (caar alist)))))) - (t - (if key - (assoc-guts (eql item (funcall key (caar alist)))) - (assoc-guts (eql item (caar alist))))))) + (when (and testp notp) + (error ":TEST and :TEST-NOT were both supplied.")) + (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 + (%assoc-key-test item alist key test) + (%assoc-test item alist test))) + (test-not + (if key + (%assoc-key-test-not item alist key test-not) + (%assoc-test-not item alist test-not))) + (t + (if key + (%assoc-key item alist key) + (%assoc item alist)))))) (defun assoc-if (predicate alist &key key) #!+sb-doc - "Return the first cons in alist whose car satisfies the Predicate. If - key is supplied, apply it to the car of each cons before testing." - (if key - (assoc-guts (funcall predicate (funcall key (caar alist)))) - (assoc-guts (funcall predicate (caar alist))))) + "Return the first cons in ALIST whose CAR satisfies PREDICATE. If + KEY is supplied, apply it to the CAR of each cons before testing." + (let ((predicate (%coerce-callable-to-fun predicate)) + (key (and key (%coerce-callable-to-fun key)))) + (if key + (%assoc-if-key predicate alist key) + (%assoc-if predicate alist)))) (defun assoc-if-not (predicate alist &key key) #!+sb-doc - "Return the first cons in ALIST whose car does not satisfy the PREDICATE. - If KEY is supplied, apply it to the car of each cons before testing." - (if key - (assoc-guts (not (funcall predicate (funcall key (caar alist))))) - (assoc-guts (not (funcall predicate (caar alist)))))) + "Return the first cons in ALIST whose CAR does not satisfy PREDICATE. + If KEY is supplied, apply it to the CAR of each cons before testing." + (let ((predicate (%coerce-callable-to-fun predicate)) + (key (and key (%coerce-callable-to-fun key)))) + (if key + (%assoc-if-not-key predicate alist key) + (%assoc-if-not predicate alist)))) -(defun rassoc (item alist &key key test test-not) +(defun rassoc (item alist &key key (test nil testp) (test-not nil notp)) (declare (list alist)) #!+sb-doc - "Return the cons in ALIST whose cdr is equal (by a given test or EQL) to + "Return the cons in ALIST whose CDR is equal (by a given test or EQL) to the ITEM." - (cond (test - (if key - (assoc-guts (funcall test item (funcall key (cdar alist)))) - (assoc-guts (funcall test item (cdar alist))))) - (test-not - (if key - (assoc-guts (not (funcall test-not item - (funcall key (cdar alist))))) - (assoc-guts (not (funcall test-not item (cdar alist)))))) - (t - (if key - (assoc-guts (eql item (funcall key (cdar alist)))) - (assoc-guts (eql item (cdar alist))))))) + (when (and testp notp) + (error ":TEST and :TEST-NOT were both supplied.")) + (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 + (%rassoc-key-test item alist key test) + (%rassoc-test item alist test))) + (test-not + (if key + (%rassoc-key-test-not item alist key test-not) + (%rassoc-test-not item alist test-not))) + (t + (if key + (%rassoc-key item alist key) + (%rassoc item alist)))))) (defun rassoc-if (predicate alist &key key) #!+sb-doc - "Return the first cons in alist whose cdr satisfies the Predicate. If key - is supplied, apply it to the cdr of each cons before testing." - (if key - (assoc-guts (funcall predicate (funcall key (cdar alist)))) - (assoc-guts (funcall predicate (cdar alist))))) + "Return the first cons in ALIST whose CDR satisfies PREDICATE. If KEY + is supplied, apply it to the CDR of each cons before testing." + (let ((predicate (%coerce-callable-to-fun predicate)) + (key (and key (%coerce-callable-to-fun key)))) + (if key + (%rassoc-if-key predicate alist key) + (%rassoc-if predicate alist)))) (defun rassoc-if-not (predicate alist &key key) #!+sb-doc - "Return the first cons in alist whose cdr does not satisfy the Predicate. - If key is supplied, apply it to the cdr of each cons before testing." - (if key - (assoc-guts (not (funcall predicate (funcall key (cdar alist))))) - (assoc-guts (not (funcall predicate (cdar alist)))))) + "Return the first cons in ALIST whose CDR does not satisfy PREDICATE. + If KEY is supplied, apply it to the CDR of each cons before testing." + (let ((predicate (%coerce-callable-to-fun predicate)) + (key (and key (%coerce-callable-to-fun key)))) + (if key + (%rassoc-if-not-key predicate alist key) + (%rassoc-if-not predicate alist)))) ;;;; mapping functions -(defun map1 (function original-arglists accumulate take-car) - #!+sb-doc - "This function is called by mapc, mapcar, mapcan, mapl, maplist, and mapcon. - It Maps function over the arglists in the appropriate way. It is done when any - of the arglists runs out. Until then, it CDRs down the arglists calling the - function and accumulating results as desired." - - (let* ((arglists (copy-list original-arglists)) - (ret-list (list nil)) - (temp ret-list)) - (do ((res nil) - (args '() '())) - ((dolist (x arglists nil) (if (null x) (return t))) - (if accumulate - (cdr ret-list) - (car original-arglists))) - (do ((l arglists (cdr l))) - ((null l)) - (push (if take-car (caar l) (car l)) args) - (setf (car l) (cdar l))) - (setq res (apply function (nreverse args))) - (case accumulate - (:nconc (setq temp (last (nconc temp res)))) - (:list (rplacd temp (list res)) - (setq temp (cdr temp))))))) +;;; a helper function for implementation of MAPC, MAPCAR, MAPCAN, +;;; MAPL, MAPLIST, and MAPCON +;;; +;;; Map the designated function over the arglists in the appropriate +;;; way. It is done when any of the arglists runs out. Until then, it +;;; CDRs down the arglists calling the function and accumulating +;;; results as desired. +(defun map1 (fun-designator original-arglists accumulate take-car) + (let ((fun (%coerce-callable-to-fun fun-designator))) + (let* ((arglists (copy-list original-arglists)) + (ret-list (list nil)) + (temp ret-list)) + (do ((res nil) + (args '() '())) + ((dolist (x arglists nil) (if (null x) (return t))) + (if accumulate + (cdr ret-list) + (car original-arglists))) + (do ((l arglists (cdr l))) + ((null l)) + (push (if take-car (caar l) (car l)) args) + (setf (car l) (cdar l))) + (setq res (apply fun (nreverse args))) + (case accumulate + (:nconc (setq temp (last (nconc temp res)))) + (:list (rplacd temp (list res)) + (setq temp (cdr temp)))))))) (defun mapc (function list &rest more-lists) #!+sb-doc - "Applies fn to successive elements of lists, returns its second argument." + "Apply FUNCTION to successive elements of lists. Return the second argument." (map1 function (cons list more-lists) nil t)) (defun mapcar (function list &rest more-lists) #!+sb-doc - "Applies fn to successive elements of list, returns list of results." + "Apply FUNCTION to successive elements of LIST. Return list of FUNCTION + return values." (map1 function (cons list more-lists) :list t)) (defun mapcan (function list &rest more-lists) #!+sb-doc - "Applies fn to successive elements of list, returns NCONC of results." + "Apply FUNCTION to successive elements of LIST. Return NCONC of FUNCTION + results." (map1 function (cons list more-lists) :nconc t)) (defun mapl (function list &rest more-lists) #!+sb-doc - "Applies fn to successive CDRs of list, returns ()." + "Apply FUNCTION to successive CDRs of list. Return NIL." (map1 function (cons list more-lists) nil nil)) (defun maplist (function list &rest more-lists) #!+sb-doc - "Applies fn to successive CDRs of list, returns list of results." + "Apply FUNCTION to successive CDRs of list. Return list of results." (map1 function (cons list more-lists) :list nil)) (defun mapcon (function list &rest more-lists) #!+sb-doc - "Applies fn to successive CDRs of lists, returns NCONC of results." + "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))))