0.9.3.31:

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

diff --git a/src/code/list.lisp b/src/code/list.lisp
index edcda97..225f1bb 100644 (file)
--- a/src/code/list.lisp
+++ b/src/code/list.lisp
@@ -18,12 +18,12 @@
 ;;;; -- WHN 20000127
 
 (declaim (maybe-inline
 ;;;; -- 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))
 
 ;;; 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)
 (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))
 
 (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
 
 (defun tree-equal (x y &key (test #'eql testp) (test-not nil notp))
   #!+sb-doc

@@ -230,18 +230,27 @@
               (fast-nthcdr (mod n i) r-i))
            (declare (type index i)))))))
 
               (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))
+    (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."
 (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
 
 (defun list (&rest args)
   #!+sb-doc

@@ -255,10 +264,10 @@
   #!+sb-doc
   "Return a list of the arguments with last cons a dotted pair"
   (cond ((atom others) arg)
   #!+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
 
 (defun make-list (size &key initial-element)
   #!+sb-doc

@@ -311,13 +320,13 @@
   (if (atom list)
       list
       (let ((result (list (car list))))
   (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
 
 (defun copy-alist (alist)
   #!+sb-doc

@@ -325,20 +334,20 @@
   (if (endp alist)
       alist
       (let ((result
   (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
 
 (defun copy-tree (object)
   #!+sb-doc

@@ -400,6 +409,16 @@
                (return top-of-top)))
           (t (fail top-of-top)))))))
 
                (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)."
 (defun nreconc (x y)
   #!+sb-doc
   "Return (NCONC (NREVERSE X) Y)."

@@ -413,11 +432,11 @@
        ;; possibly-improper list LIST. (Or if LIST is circular, you
        ;; lose.)
        (count-conses (list)
        ;; 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)
   (declare (ftype (function (t) index) count-conses))
   (defun butlast (list &optional (n 1))
     (if (typep n 'index)

@@ -454,15 +473,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))
    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)
        ((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)
     (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))))))))

 \f
 ;;;; functions to alter list structure
 
 \f
 ;;;; functions to alter list structure
 

@@ -522,8 +541,8 @@
   (let ((key-tmp (gensym)))
     `(let ((,key-tmp (apply-key key ,elt)))
       (cond (testp (funcall test ,item ,key-tmp))
   (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))))))

 \f
 ;;;; substitution of expressions
 
 \f
 ;;;; substitution of expressions
 

@@ -671,8 +690,8 @@
   (let ((key-tmp (gensym)))
     `(let ((,key-tmp (apply-key key subtree)))
       (if notp
   (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
 
 (defun nsublis (alist tree &key key (test #'eql testp) (test-not #'eql notp))
   #!+sb-doc

@@ -744,7 +763,7 @@
   (do ((list list (cdr list)))
       ((atom list) (eql list object))
     (if (eql object list)
   (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
 
 (defun adjoin (item list &key key (test #'eql testp) (test-not nil notp))
   #!+sb-doc

@@ -784,8 +803,8 @@
 (defmacro steve-splice (source destination)
   `(let ((temp ,source))
      (setf ,source (cdr ,source)
 (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
 
 (defun nunion (list1 list2 &key key (test #'eql testp) (test-not nil notp))
   #!+sb-doc

@@ -879,7 +898,7 @@
     (declare (type function test test-not))
     (dolist (elt list1)
       (unless (with-set-keys (member (apply-key key elt) list2))
     (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))
     (let ((test (if testp
                     (lambda (x y) (funcall test y x))
                     test))

@@ -977,7 +996,7 @@
        (y data (cdr y)))
       ((and (endp x) (endp y)) alist)
     (if (or (endp x) (endp y))
        (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
     (setq alist (acons (car x) (car y) alist))))
 
 ;;; This is defined in the run-time environment, not just the compile-time