X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Flist.lisp;h=0454ffc919dfcb5825ef7f34b9f4a5895d191e99;hb=78fa16bf55be44cc16845be84d98023e83fb14bc;hp=762561c4a1ffb653603982ba047ad4b07d406d93;hpb=d2241edb01a6dad8a7bc1107d28d0873f5f8d83e;p=sbcl.git diff --git a/src/code/list.lisp b/src/code/list.lisp index 762561c..0454ffc 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 @@ -301,7 +313,7 @@ (let ((result (list (car list)))) (do ((x (cdr list) (cdr x)) (splice result - (cdr (rplacd splice (cons (car x) '() ))) )) + (cdr (rplacd splice (cons (car x) '()))))) ((atom x) (unless (null x) (rplacd splice x)))) @@ -310,12 +322,12 @@ (defun copy-alist (alist) #!+sb-doc "Return a new association list which is EQUAL to ALIST." - (if (atom alist) + (if (endp alist) alist (let ((result (cons (if (atom (car alist)) (car alist) - (cons (caar alist) (cdar alist)) ) + (cons (caar alist) (cdar alist))) nil))) (do ((x (cdr alist) (cdr x)) (splice result @@ -325,10 +337,7 @@ (car x) (cons (caar x) (cdar x))) nil))))) - ;; Non-null terminated alist done here. - ((atom x) - (unless (null x) - (rplacd splice x)))) + ((endp x))) result))) (defun copy-tree (object) @@ -411,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 @@ -471,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 @@ -640,7 +659,7 @@ ((atom subtree) subtree) (t (let ((car (s (car subtree))) (cdr (s (cdr subtree)))) - (if (and (eq car (car subtreE)) + (if (and (eq car (car subtree)) (eq cdr (cdr subtree))) subtree (cons car cdr)))))))) @@ -889,32 +908,48 @@ ;; reached, what is left of LIST2 is tacked onto what is left of ;; LIST1. The splicing operation ensures that the correct ;; operation is performed depending on whether splice is at the - ;; top of the list or not + ;; top of the list or not. (do ((list1 list1) (list2 list2) (x list1 (cdr x)) - (splicex ())) + (splicex ()) + (deleted-y ()) + ;; elements of LIST2, which are "equal" to some processed + ;; earlier elements of LIST1 + ) ((endp x) (if (null splicex) (setq list1 list2) (rplacd splicex list2)) list1) - (do ((y list2 (cdr y)) - (splicey ())) - ((endp y) (setq splicex x)) - (cond ((let ((key-val-x (apply-key key (car x))) - (key-val-y (apply-key key (Car y)))) - (if notp - (not (funcall test-not key-val-x key-val-y)) - (funcall test key-val-x key-val-y))) - (if (null splicex) - (setq list1 (cdr x)) - (rplacd splicex (cdr x))) - (if (null splicey) - (setq list2 (cdr y)) - (rplacd splicey (cdr y))) - (return ())) ; assume lists are really sets - (t (setq splicey y))))))) + (let ((key-val-x (apply-key key (car x))) + (found-duplicate nil)) + + ;; Move all elements from LIST2, which are "equal" to (CAR X), + ;; to DELETED-Y. + (do* ((y list2 next-y) + (next-y (cdr y) (cdr y)) + (splicey ())) + ((endp y)) + (cond ((let ((key-val-y (apply-key key (car y)))) + (if notp + (not (funcall test-not key-val-x key-val-y)) + (funcall test key-val-x key-val-y))) + (if (null splicey) + (setq list2 (cdr y)) + (rplacd splicey (cdr y))) + (setq deleted-y (rplacd y deleted-y)) + (setq found-duplicate t)) + (t (setq splicey y)))) + + (unless found-duplicate + (setq found-duplicate (with-set-keys (member key-val-x deleted-y)))) + + (if found-duplicate + (if (null splicex) + (setq list1 (cdr x)) + (rplacd splicex (cdr x))) + (setq splicex x)))))) (defun subsetp (list1 list2 &key key (test #'eql testp) (test-not nil notp)) #!+sb-doc