;;;; -- WHN 20000127
(declaim (maybe-inline
- adjoin tree-equal nth %setnth nthcdr make-list
- member-if member-if-not tailp 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-if assoc-if-not rassoc rassoc-if rassoc-if-not subst subst-if
+ subst subst-if
subst-if-not nsubst nsubst-if nsubst-if-not sublis nsublis))
;;; These functions perform basic list operations.
(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)))
(defun append (&rest lists)
#!+sb-doc
"Construct a new list by concatenating the list arguments"
- (declare (dynamic-extent lists) (optimize speed))
+ (declare (truly-dynamic-extent lists) (optimize speed))
(labels ((fail (object)
(error 'type-error
:datum object
#!+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
(defun nconc (&rest lists)
#!+sb-doc
"Concatenates the lists given as arguments (by changing them)"
- (declare (dynamic-extent lists) (optimize speed))
+ (declare (truly-dynamic-extent lists) (optimize speed))
(flet ((fail (object)
(error 'type-error
:datum object
((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))
- (if (typep n 'index)
- (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)))))
- nil))
- (defun nbutlast (list &optional (n 1))
- (cond ((zerop n)
- list)
- ((not (typep n 'index))
- nil)
- (t (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
\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)))
- (when (satisfies-the-test item car)
- (return list))))))
+ (test (and testp (%coerce-callable-to-fun test)))
+ (test-not (and notp (%coerce-callable-to-fun test-not))))
+ (cond (test
+ (if key
+ (%member-key-test item list key test)
+ (%member-test item list test)))
+ (test-not
+ (if key
+ (%member-key-test-not item list key test-not)
+ (%member-test-not item list test-not)))
+ (t
+ (if key
+ (%member-key item list key)
+ (%member item list))))))
(defun member-if (test list &key key)
#!+sb-doc
"Return tail of LIST beginning with first element satisfying TEST."
(let ((test (%coerce-callable-to-fun test))
(key (and key (%coerce-callable-to-fun key))))
- (do ((list list (cdr list)))
- ((endp list) nil)
- (if (funcall test (apply-key key (car list)))
- (return list)))))
+ (if key
+ (%member-if-key test list key)
+ (%member-if test list))))
(defun member-if-not (test list &key key)
#!+sb-doc
"Return tail of LIST beginning with first element not satisfying TEST."
(let ((test (%coerce-callable-to-fun test))
(key (and key (%coerce-callable-to-fun key))))
- (do ((list list (cdr list)))
- ((endp list) ())
- (if (not (funcall test (apply-key key (car list))))
- (return list)))))
+ (if key
+ (%member-if-not-key test list key)
+ (%member-if-not test list))))
(defun tailp (object list)
#!+sb-doc
"Add ITEM to LIST unless it is already a member"
(when (and testp notp)
(error ":TEST and :TEST-NOT were both supplied."))
- (let ((key (and key (%coerce-callable-to-fun key))))
- (if (let ((key-val (apply-key key item)))
- (if notp
- (member key-val list :test-not test-not :key key)
- (member key-val list :test test :key key)))
- list
- (cons item list))))
+ (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)
(declare (inline member))
(when (and testp notp)
(error ":TEST and :TEST-NOT were both supplied."))
- ;; We have to possibilities here: for shortish lists we pick up the
+ ;; 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))
(key (and key (%coerce-callable-to-fun key)))
(test (if notp
(let ((test-not-fun (%coerce-callable-to-fun test-not)))
- (lambda (x) (not (funcall test-not-fun x))))
+ (lambda (x y) (not (funcall test-not-fun x y))))
(%coerce-callable-to-fun test))))
(multiple-value-bind (short long n-short)
(if (< n1 n2)
(declare (inline member))
(when (and testp notp)
(error ":TEST and :TEST-NOT were both supplied."))
- ;; We have to possibilities here: for shortish lists we pick up the
+ ;; 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))
(key (and key (%coerce-callable-to-fun key)))
(test (if notp
(let ((test-not-fun (%coerce-callable-to-fun test-not)))
- (lambda (x) (not (funcall test-not-fun x))))
+ (lambda (x y) (not (funcall test-not-fun x y))))
(%coerce-callable-to-fun test))))
(multiple-value-bind (short long n-short)
(if (< n1 n2)
(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
;;;; Specialized versions
-;;; %MEMBER-* and %ASSOC-* functions. The transforms for MEMBER and
-;;; ASSOC pick the appropriate version. These win because they have
-;;; only positional arguments, the TEST, TEST-NOT & KEY functions are
-;;; known to exist (or not), and are known to be functions instead of
-;;; function designators. We are also able to transform many common
-;;; cases to -EQ versions, which are substantially faster then EQL
-;;; using ones.
+;;; %ADJOIN-*, %ASSOC-*, %MEMBER-*, and %RASSOC-* functions. Deftransforms
+;;; delegate to TRANSFORM-LIST-PRED-SEEK and TRANSFORM-LIST-ITEM-SEEK which
+;;; pick the appropriate versions. These win because they have only positional
+;;; arguments, the TEST, TEST-NOT & KEY functions are known to exist (or not),
+;;; and are known to be functions instead of function designators. We are also
+;;; able to transform many common cases to -EQ versions, which are
+;;; substantially faster then EQL using ones.
(macrolet
((def (funs form &optional variant)
- (flet ((%def (name)
- `(defun ,(intern (format nil "%~A~{-~A~}~@[-~A~]" name funs variant))
- (item list ,@funs)
- (declare (optimize speed))
- ,@(when funs `((declare (function ,@funs))))
- (do ((list list (cdr list)))
- ((null list) nil)
- (declare (list list))
- (let ((this (car list)))
- ,(ecase name
- (assoc
- (if funs
- `(when this
- (let ((target (car this)))
- (when ,form
- (return this))))
- ;; If there is no TEST/TEST-NOT or
- ;; KEY, do the EQ/EQL test first,
- ;; before checking for NIL.
- `(let ((target (car this)))
- (when (and ,form this)
- (return this)))))
- (member
- `(let ((target this))
- (when ,form
- (return list))))))))))
+ (flet ((%def (name &optional conditional)
+ (let* ((body-loop
+ `(do ((list list (cdr list)))
+ ((null list) nil)
+ (declare (list list))
+ (let ((this (car list)))
+ ,(let ((cxx (if (char= #\A (char (string name) 0))
+ 'car ; assoc, assoc-if, assoc-if-not
+ 'cdr))) ; rassoc, rassoc-if, rassoc-if-not
+ (ecase name
+ ((assoc rassoc)
+ (if funs
+ `(when this
+ (let ((target (,cxx this)))
+ (when ,form
+ (return this))))
+ ;; If there is no TEST/TEST-NOT or
+ ;; KEY, do the EQ/EQL test first,
+ ;; before checking for NIL.
+ `(let ((target (,cxx this)))
+ (when (and ,form this)
+ (return this)))))
+ ((assoc-if assoc-if-not rassoc-if rassoc-if-not)
+ (aver (equal '(eql x) (subseq form 0 2)))
+ `(when this
+ (let ((target (,cxx this)))
+ (,conditional (funcall ,@(cdr form))
+ (return this)))))
+ (member
+ `(let ((target this))
+ (when ,form
+ (return list))))
+ ((member-if member-if-not)
+ (aver (equal '(eql x) (subseq form 0 2)))
+ `(let ((target this))
+ (,conditional (funcall ,@(cdr form))
+ (return list))))
+ (adjoin
+ `(let ((target this))
+ (when ,form
+ (return t)))))))))
+ (body (if (eq 'adjoin name)
+ `(if (let ,(when (member 'key funs)
+ `((x (funcall key x))))
+ ,body-loop)
+ list
+ (cons x list))
+ body-loop)))
+ `(defun ,(intern (format nil "%~A~{-~A~}~@[-~A~]" name funs variant))
+ (x list ,@funs)
+ (declare (optimize speed (sb!c::verify-arg-count 0)))
+ ,@(when funs `((declare (function ,@funs))))
+ ,@(unless (member name '(member assoc adjoin rassoc)) `((declare (function x))))
+ ,body))))
`(progn
+ ,(%def 'adjoin)
+ ,(%def 'assoc)
,(%def 'member)
- ,(%def 'assoc)))))
+ ,(%def 'rassoc)
+ ,@(when (and (not variant) (member funs '(() (key)) :test #'equal))
+ (list (%def 'member-if 'when)
+ (%def 'member-if-not 'unless)
+ (%def 'assoc-if 'when)
+ (%def 'assoc-if-not 'unless)
+ (%def 'rassoc-if 'when)
+ (%def 'rassoc-if-not 'unless)))))))
(def ()
- (eql item target))
+ (eql x target))
(def ()
- (eq item target)
+ (eq x target)
eq)
(def (key)
- (eql item (funcall key target)))
+ (eql x (funcall key target)))
(def (key)
- (eq item (funcall key target))
+ (eq x (funcall key target))
eq)
(def (key test)
- (funcall test item (funcall key target)))
+ (funcall test x (funcall key target)))
(def (key test-not)
- (not (funcall test-not item (funcall key target))))
+ (not (funcall test-not x (funcall key target))))
(def (test)
- (funcall test item target))
+ (funcall test x target))
(def (test-not)
- (not (funcall test-not item target))))
+ (not (funcall test-not x target))))
projects / sbcl.git / blobdiff