X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Flist.lisp;h=f15ad9f8aa0fd68f770900b2d77d1847527397e9;hb=25fe91bf63fd473d9316675b0e0ca9be0079e9eb;hp=edcda97d6ae7fcb96fbaaf7785bd0cb6ebb8c2cc;hpb=4dc4761909992ceb346d003f3fb19e5c837ee985;p=sbcl.git diff --git a/src/code/list.lisp b/src/code/list.lisp index edcda97..f15ad9f 100644 --- a/src/code/list.lisp +++ b/src/code/list.lisp @@ -18,12 +18,12 @@ ;;;; -- 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)) @@ -117,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 @@ -230,18 +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." - (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 @@ -255,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 @@ -311,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 @@ -325,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 @@ -400,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)." @@ -413,11 +433,11 @@ ;; 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) @@ -454,15 +474,15 @@ 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 @@ -522,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 @@ -671,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 @@ -744,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 @@ -784,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 @@ -879,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)) @@ -977,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