(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))
(defun tree-equal-test-not (x y test-not)
(declare (type function test-not))
(cond ((consp x)
- (and (consp y)
- (tree-equal-test-not (car x) (car y) test-not)
- (tree-equal-test-not (cdr x) (cdr y) test-not)))
- ((consp y) nil)
- ((not (funcall test-not x y)) t)
- (t ())))
+ (and (consp y)
+ (tree-equal-test-not (car x) (car y) test-not)
+ (tree-equal-test-not (cdr x) (cdr y) test-not)))
+ ((consp y) nil)
+ ((not (funcall test-not x y)) t)
+ (t ())))
(defun tree-equal-test (x y test)
(declare (type function test))
- (cond ((consp x)
- (and (consp y)
- (tree-equal-test (car x) (car y) test)
- (tree-equal-test (cdr x) (cdr y) test)))
- ((consp y) nil)
- ((funcall test x y) t)
- (t ())))
+ (cond ((consp x)
+ (and (consp y)
+ (tree-equal-test (car x) (car y) test)
+ (tree-equal-test (cdr x) (cdr y) test)))
+ ((consp y) nil)
+ ((funcall test x y) t)
+ (t ())))
(defun tree-equal (x y &key (test #'eql testp) (test-not nil notp))
#!+sb-doc
(fast-nthcdr (mod n i) r-i))
(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))))
+;;; 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
(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
(declare (type index size))
(do ((count size (1- count))
(result '() (cons initial-element result)))
- ((zerop count) result)
+ ((<= count 0) result)
(declare (type index count))))
\f
(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)))
\f
;;;; 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
(if (endp alist)
alist
(let ((result
- (cons (if (atom (car alist))
- (car alist)
- (cons (caar alist) (cdar alist)))
- nil)))
- (do ((x (cdr alist) (cdr x))
- (splice result
- (cdr (rplacd splice
- (cons
- (if (atom (car x))
- (car x)
- (cons (caar x) (cdar x)))
- nil)))))
- ((endp x)))
- result)))
+ (cons (if (atom (car alist))
+ (car alist)
+ (cons (caar alist) (cdar alist)))
+ nil)))
+ (do ((x (cdr alist) (cdr x))
+ (splice result
+ (cdr (rplacd splice
+ (cons
+ (if (atom (car x))
+ (car x)
+ (cons (caar x) (cdar x)))
+ nil)))))
+ ((endp x)))
+ result)))
(defun copy-tree (object)
#!+sb-doc
"Recursively copy trees of conses."
(if (consp object)
- (cons (copy-tree (car object)) (copy-tree (cdr object)))
+ (let ((result (list (if (consp (car object))
+ (copy-tree (car object))
+ (car object)))))
+ (loop for last-cons = result then new-cons
+ for cdr = (cdr object) then (cdr cdr)
+ for car = (if (consp cdr)
+ (car cdr)
+ (return (setf (cdr last-cons) cdr)))
+ for new-cons = (list (if (consp car)
+ (copy-tree car)
+ car))
+ do (setf (cdr last-cons) new-cons))
+ result)
object))
+
\f
;;;; more commonly-used list functions
;;; 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
((atom 2nd) 3rd)
(rplacd 2nd 3rd)))
\f
-(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))))))))
\f
;;;; 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.
(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))))))
\f
;;;; substitution of expressions
(cond ((satisfies-the-test old subtree) new)
((atom subtree) subtree)
(t (do* ((last nil subtree)
- (subtree subtree (Cdr subtree)))
+ (subtree subtree (cdr subtree)))
((atom subtree)
(if (satisfies-the-test old subtree)
(setf (cdr last) new)))
(cond ((funcall test (apply-key key subtree)) new)
((atom subtree) subtree)
(t (do* ((last nil subtree)
- (subtree subtree (Cdr subtree)))
+ (subtree subtree (cdr subtree)))
((atom subtree)
(if (funcall test (apply-key key subtree))
(setf (cdr last) new)))
(cond ((not (funcall test (apply-key key subtree))) new)
((atom subtree) subtree)
(t (do* ((last nil subtree)
- (subtree subtree (Cdr subtree)))
+ (subtree subtree (cdr subtree)))
((atom subtree)
(if (not (funcall test (apply-key key subtree)))
(setf (cdr last) new)))
(let ((key-tmp (gensym)))
`(let ((,key-tmp (apply-key key subtree)))
(if notp
- (assoc ,key-tmp alist :test-not test-not)
- (assoc ,key-tmp alist :test test)))))
+ (assoc ,key-tmp alist :test-not test-not)
+ (assoc ,key-tmp alist :test test)))))
(defun nsublis (alist tree &key key (test #'eql testp) (test-not #'eql notp))
#!+sb-doc
(declare (inline assoc))
(let (temp)
(labels ((s (subtree)
- (cond ((Setq temp (nsublis-macro))
+ (cond ((setq temp (nsublis-macro))
(cdr temp))
((atom subtree) subtree)
(t (do* ((last nil subtree)
- (subtree subtree (Cdr subtree)))
+ (subtree subtree (cdr subtree)))
((atom subtree)
(if (setq temp (nsublis-macro))
(setf (cdr last) (cdr temp))))
(if (setq temp (nsublis-macro))
- (return (setf (Cdr last) (Cdr temp)))
+ (return (setf (cdr last) (cdr temp)))
(setf (car subtree) (s (car subtree)))))
subtree))))
(s tree)))))
\f
;;;; functions for using lists as sets
-(defun member (item list &key key (test #'eql testp) (test-not #'eql notp))
+(defun member (item list &key key (test nil testp) (test-not nil notp))
#!+sb-doc
"Return the tail of LIST beginning with first element satisfying EQLity,
:TEST, or :TEST-NOT with the given ITEM."
(when (and testp notp)
(error ":TEST and :TEST-NOT were both supplied."))
(let ((key (and key (%coerce-callable-to-fun key)))
- (test (if testp (%coerce-callable-to-fun test) test))
- (test-not (if notp (%coerce-callable-to-fun test-not) test-not)))
- (declare (type function test test-not))
- (do ((list list (cdr list)))
- ((null list) nil)
- (let ((car (car list)))
- (if (satisfies-the-test item car)
- (return list))))))
+ (test (and testp (%coerce-callable-to-fun test)))
+ (test-not (and notp (%coerce-callable-to-fun test-not))))
+ (cond (test
+ (if key
+ (%member-key-test item list key test)
+ (%member-test item list test)))
+ (test-not
+ (if key
+ (%member-key-test-not item list key test-not)
+ (%member-test-not item list test-not)))
+ (t
+ (if key
+ (%member-key item list key)
+ (%member item list))))))
(defun member-if (test list &key key)
#!+sb-doc
"Return tail of LIST beginning with first element satisfying TEST."
(let ((test (%coerce-callable-to-fun test))
(key (and key (%coerce-callable-to-fun key))))
- (do ((list list (cdr list)))
- ((endp list) nil)
- (if (funcall test (apply-key key (car list)))
- (return list)))))
+ (if key
+ (%member-if-key test list key)
+ (%member-if test list))))
(defun member-if-not (test list &key key)
#!+sb-doc
"Return tail of LIST beginning with first element not satisfying TEST."
(let ((test (%coerce-callable-to-fun test))
(key (and key (%coerce-callable-to-fun key))))
- (do ((list list (cdr list)))
- ((endp list) ())
- (if (not (funcall test (apply-key key (car list))))
- (return list)))))
+ (if key
+ (%member-if-not-key test list key)
+ (%member-if-not test list))))
(defun tailp (object list)
#!+sb-doc
(do ((list list (cdr list)))
((atom list) (eql list object))
(if (eql object list)
- (return t))))
+ (return t))))
(defun adjoin (item list &key key (test #'eql testp) (test-not nil notp))
#!+sb-doc
"Add ITEM to LIST unless it is already a member"
(when (and testp notp)
(error ":TEST and :TEST-NOT were both supplied."))
- (let ((key (and key (%coerce-callable-to-fun key))))
- (declare (inline member))
- (if (let ((key-val (apply-key key item)))
- (if notp
- (member key-val list :test-not test-not :key key)
- (member key-val list :test test :key key)))
- list
- (cons item list))))
+ (let ((key (and key (%coerce-callable-to-fun key)))
+ (test (and testp (%coerce-callable-to-fun test)))
+ (test-not (and notp (%coerce-callable-to-fun test-not))))
+ (cond (test
+ (if key
+ (%adjoin-key-test item list key test)
+ (%adjoin-test item list test)))
+ (test-not
+ (if key
+ (%adjoin-key-test-not item list key test-not)
+ (%adjoin-test-not item list test-not)))
+ (t
+ (if key
+ (%adjoin-key item list key)
+ (%adjoin item list))))))
+
+(defconstant +list-based-union-limit+ 80)
(defun union (list1 list2 &key key (test #'eql testp) (test-not nil notp))
#!+sb-doc
(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.
(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
(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))
(do () ((endp list1))
(if (with-set-keys (member (apply-key key (car list1)) list2))
(steve-splice list1 res)
- (setq list1 (Cdr list1))))
+ (setq list1 (cdr list1))))
res)))
(defun set-difference (list1 list2
(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))
(y data (cdr y)))
((and (endp x) (endp y)) alist)
(if (or (endp x) (endp y))
- (error "The lists of keys and data are of unequal length."))
+ (error "The lists of keys and data are of unequal length."))
(setq alist (acons (car x) (car y) alist))))
-;;; This is defined in the run-time environment, not just the compile-time
-;;; environment (i.e. not wrapped in EVAL-WHEN (COMPILE EVAL)) because it
-;;; can appear in inline expansions.
-(defmacro assoc-guts (test-expr)
- `(do ((alist alist (cdr alist)))
- ((endp alist))
- (when (and (car alist) ,test-expr)
- (return (car alist)))))
-
(defun assoc (item alist &key key (test nil testp) (test-not nil notp))
#!+sb-doc
"Return the cons in ALIST whose car is equal (by a given test or EQL) to
(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
(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
(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))
(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
(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
(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))))
\f
;;;; mapping functions
#!+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))))
projects / sbcl.git / blobdiff