X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Flist.lisp;h=edcda97d6ae7fcb96fbaaf7785bd0cb6ebb8c2cc;hb=0e35b321b97477bcfedaa1a5aed1fa87d635d262;hp=47e476afd27e8843eb1bafc28117cb2c8003a9a0;hpb=18936f9085457bc1b55d7345e7f1287e6abb85a5;p=sbcl.git diff --git a/src/code/list.lisp b/src/code/list.lisp index 47e476a..edcda97 100644 --- a/src/code/list.lisp +++ b/src/code/list.lisp @@ -11,6 +11,8 @@ (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 @@ -211,25 +213,35 @@ (cdr list)) (defun nthcdr (n list) - (declare (type index n)) #!+sb-doc "Performs the cdr function n times on a list." - (do ((i n (1- i)) - (result list (cdr result))) - ((not (plusp i)) result) - (declare (type index i)))) + (flet ((fast-nthcdr (n list) + (declare (type index n)) + (do ((i n (1- i)) + (result list (cdr result))) + ((not (plusp i)) result) + (declare (type index i))))) + (typecase n + (index (fast-nthcdr n list)) + (t (do ((i 0 (1+ i)) + (r-i list (cdr r-i)) + (r-2i list (cddr r-2i))) + ((and (eq r-i r-2i) (not (zerop i))) + (fast-nthcdr (mod n i) r-i)) + (declare (type index i))))))) (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 (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 @@ -408,30 +420,34 @@ (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 @@ -468,15 +484,21 @@ ;;; Set the Nth element of LIST to NEWVAL. (defun %setnth (n list newval) - (declare (type index n)) - (do ((count n (1- count)) - (list list (cdr list))) - ((endp list) - (error "~S is too large an index for SETF of NTH." n)) - (declare (type fixnum count)) - (when (<= count 0) - (rplaca list newval) - (return newval)))) + (typecase n + (index + (do ((count n (1- count)) + (list list (cdr list))) + ((endp list) + (error "~S is too large an index for SETF of NTH." n)) + (declare (type fixnum count)) + (when (<= count 0) + (rplaca list newval) + (return newval)))) + (t (let ((cons (nthcdr n list))) + (when (endp cons) + (error "~S is too large an index for SETF of NTH." n)) + (rplaca cons newval) + newval)))) ;;;; :KEY arg optimization to save funcall of IDENTITY @@ -570,7 +592,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))) @@ -589,7 +611,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))) @@ -608,7 +630,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))) @@ -663,16 +685,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))))) @@ -808,7 +830,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