(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 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."
- (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))))
+ (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)
(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)))
+ (do ((x (cdr list) (cdr x))
+ (splice result
+ (cdr (rplacd splice (cons (car x) '())))))
+ ((atom x)
+ (unless (null x)
+ (rplacd splice x))))
+ result)))
(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))
- (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))))))
+ (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))
- (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)))))
+ (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 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
(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)))))
(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))))))
+
+(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)))))
(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
(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
(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
projects / sbcl.git / blobdiff