;;;; -- 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 last last1 make-list append
+ nconc nconc2 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))
;;; 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 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 (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))
+ (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)))
(defun list (&rest args)
#!+sb-doc
#!+sb-doc
"Return a list of the arguments with last cons a dotted pair"
(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)
\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
(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))))))
+
(defun nreconc (x y)
#!+sb-doc
"Return (NCONC (NREVERSE X) Y)."
;; 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)))))
+ (do ((in-list list (cdr in-list))
+ (result 0 (1+ result)))
+ ((atom in-list)
+ result)
+ (declare (type index result)))))
(declare (ftype (function (t) index) count-conses))
(defun butlast (list &optional (n 1))
(if (typep n 'index)
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
(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
(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
(do ((list list (cdr list)))
((null list) nil)
(let ((car (car list)))
- (if (satisfies-the-test item car)
- (return list))))))
+ (when (satisfies-the-test item car)
+ (return list))))))
(defun member-if (test list &key key)
#!+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
list
(cons 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 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 to 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) (not (funcall test-not-fun x))))
+ (%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 to 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) (not (funcall test-not-fun x))))
+ (%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))
(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
#!+sb-doc
"Apply FUNCTION to successive CDRs of lists. Return NCONC of results."
(map1 function (cons list more-lists) :nconc nil))
+
+;;;; Specialized versions
+
+;;; %MEMBER-* and %ASSOC-* function. The transforms for %MEMBER and %ASSOC pick
+;;; the appropriate version. These win because they have only positional arguments,
+;;; the TEST & KEY functions are known to exist (or not), and are known to be
+;;; functions, not function designators.
+(macrolet ((def (funs form)
+ (flet ((%def (name)
+ `(defun ,(intern (format nil "%~A~{-~A~}" name funs))
+ (item list ,@funs)
+ ,@(when funs `((declare (function ,@funs))))
+ (do ((list list (cdr list)))
+ ((null list) nil)
+ (let ((this (car list)))
+ ,(ecase name
+ (assoc
+ `(when this
+ (let ((target (car this)))
+ (when (and this ,form)
+ (return this)))))
+ (member
+ `(let ((target this))
+ (when ,form
+ (return list))))))))))
+ `(progn
+ ,(%def 'member)
+ ,(%def 'assoc)))))
+ (def ()
+ (eql item target))
+ (def (key)
+ (eql item (funcall key target)))
+ (def (key test)
+ (funcall test item (funcall key target)))
+ (def (key test-not)
+ (not (funcall test-not item (funcall key target))))
+ (def (test)
+ (funcall test item target))
+ (def (test-not)
+ (not (funcall test-not item target))))