0.9.0.12:

[sbcl.git] / src / code / list.lisp

diff --git a/src/code/list.lisp b/src/code/list.lisp
index a65faac..edcda97 100644 (file)
--- a/src/code/list.lisp
+++ b/src/code/list.lisp
@@ -11,6 +11,8 @@
 
 (in-package "SB!IMPL")
 
 
 (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
 ;;;; 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)
   (cdr list))
 
 (defun nthcdr (n list)

-  (declare (type index n))

   #!+sb-doc
   "Performs the cdr function n times on a list."
   #!+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."
 
 (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
 
 (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))
           (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))
   (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
 
 (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)
 
 ;;; 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))))

 \f
 ;;;; :KEY arg optimization to save funcall of IDENTITY
 
 \f
 ;;;; :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)
                (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)))
                              ((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)
                (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)))
                              ((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)
                (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)))
                              ((atom subtree)
                               (if (not (funcall test (apply-key key subtree)))
                                   (setf (cdr last) new)))

@@ -637,7 +659,7 @@
                        ((atom subtree) subtree)
                        (t (let ((car (s (car subtree)))
                                 (cdr (s (cdr subtree))))
                        ((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))))))))
                                      (eq cdr (cdr subtree)))
                                 subtree
                                 (cons car cdr))))))))

@@ -663,16 +685,16 @@
     (declare (inline assoc))
     (let (temp)
       (labels ((s (subtree)
     (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)
                         (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))
                                ((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)))))
                                 (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)
       (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
       res)))
 
 (defun set-difference (list1 list2