X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Flist.lisp;h=f15ad9f8aa0fd68f770900b2d77d1847527397e9;hb=2561033fd3ed9e224dffc445262e097e5abfa920;hp=dee37904db7b6fcb39913707c4076dfd0e9fa5b5;hpb=5f492c8a8eea8a407d82de104e16b7148a7f9eb8;p=sbcl.git diff --git a/src/code/list.lisp b/src/code/list.lisp index dee3790..f15ad9f 100644 --- a/src/code/list.lisp +++ b/src/code/list.lisp @@ -11,17 +11,19 @@ (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)) @@ -115,22 +117,22 @@ (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 @@ -228,17 +230,28 @@ (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 @@ -252,10 +265,10 @@ #!+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 @@ -308,13 +321,13 @@ (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 @@ -322,20 +335,20 @@ (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 @@ -397,6 +410,16 @@ (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)." @@ -410,52 +433,56 @@ ;; 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)))))))) ;;;; functions to alter list structure @@ -515,8 +542,8 @@ (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)))))) ;;;; substitution of expressions @@ -585,7 +612,7 @@ (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))) @@ -604,7 +631,7 @@ (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))) @@ -623,7 +650,7 @@ (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))) @@ -664,8 +691,8 @@ (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 @@ -678,16 +705,16 @@ (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))))) @@ -737,7 +764,7 @@ (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 @@ -777,8 +804,8 @@ (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 @@ -823,7 +850,7 @@ (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 @@ -872,7 +899,7 @@ (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)) @@ -970,7 +997,7 @@ (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