X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Flist.lisp;h=da6ca8e60a30b7c9c8b17894fe4dd9b973dc37f7;hb=0c08cc954cc0910079bdcf153cccf9a95ef11d67;hp=7cedd8176d6032ecf0a57e037a963085fc4be2cc;hpb=1ac7e7c95d8badd4ff01d676dffece6b710cea13;p=sbcl.git diff --git a/src/code/list.lisp b/src/code/list.lisp index 7cedd81..da6ca8e 100644 --- a/src/code/list.lisp +++ b/src/code/list.lisp @@ -18,11 +18,11 @@ ;;;; -- WHN 20000127 (declaim (maybe-inline - tree-equal nth %setnth nthcdr last last1 make-list append - nconc nconc2 member member-if member-if-not tailp adjoin 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 - assoc-if assoc-if-not rassoc rassoc-if rassoc-if-not subst subst-if + 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. @@ -230,28 +230,85 @@ (fast-nthcdr (mod n i) r-i)) (declare (type index i))))))) -(defun last1 (list) - #!+sb-doc - "Return the last cons (not the last element) of a list" - (let ((rest list) - (list list)) - (loop (unless (consp rest) (return list)) - (shiftf list rest (cdr rest))))) - -(defun last (list &optional (n 1)) - #!+sb-doc - "Return the last N conses (not the last element!) of a list." - (if (eql n 1) - (last1 list) - (if (typep n 'index) - (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))) - list))) +;;; 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 @@ -263,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))) @@ -282,52 +341,84 @@ (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 @@ -354,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 @@ -378,47 +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))))))) - -(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 @@ -486,15 +579,15 @@ ;;;; functions to alter list structure -(defun rplaca (x y) +(defun rplaca (cons x) #!+sb-doc - "Change the CAR of X to Y and return the new X." - (rplaca x y)) + "Change the CAR of CONS to X and return the CONS." + (rplaca cons x)) -(defun rplacd (x y) +(defun rplacd (cons x) #!+sb-doc - "Change the CDR of X to Y and return the new X." - (rplacd x y)) + "Change the CDR of CONS to X and return the CONS." + (rplacd cons x)) ;;; The following are for use by SETF. @@ -721,61 +814,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)))))) - -(macrolet ((def (name funs form) - `(defun ,name (item list ,@funs) - ,@(when funs `((declare (function ,@funs)))) - (do ((list list (cdr list))) - ((null list) nil) - (when ,form - (return list)))))) - (def %member () - (eql item (car list))) - (def %member-key (key) - (eql item (funcall key (car list)))) - (def %member-key-test (key test) - (funcall test item (funcall key (car list)))) - (def %member-key-test-not (key test-not) - (not (funcall test-not item (funcall key (car list))))) - (def %member-test (test) - (funcall test item (car list))) - (def %member-test-not (test-not) - (not (funcall test-not item (car 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 @@ -791,14 +868,23 @@ "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 @@ -806,16 +892,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. @@ -833,15 +941,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)) @@ -1020,15 +1157,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 @@ -1040,17 +1168,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 @@ -1059,8 +1186,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 @@ -1069,8 +1196,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)) @@ -1084,17 +1211,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 @@ -1103,8 +1229,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 @@ -1113,8 +1239,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 @@ -1177,3 +1303,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))))