1.0.8.8: restore reuse-sap value after incomplete writes in FROB-OUTPUT-LATER

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

diff --git a/src/code/list.lisp b/src/code/list.lisp
index e21535c..a48af26 100644 (file)
--- a/src/code/list.lisp
+++ b/src/code/list.lisp
@@ -18,8 +18,8 @@
 ;;;; -- WHN 20000127
 
 (declaim (maybe-inline
-          tree-equal nth %setnth nthcdr last make-list append
-          nconc member member-if member-if-not tailp adjoin union
+          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
@@ -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
@@ -266,7 +276,7 @@
   (declare (type index size))
   (do ((count size (1- count))
        (result '() (cons initial-element result)))
-      ((zerop count) result)
+      ((<= count 0) result)
     (declare (type index count))))
 \f
 (defun append (&rest lists)
@@ -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)."
@@ -714,8 +734,8 @@
     (do ((list list (cdr list)))
         ((null list) nil)
       (let ((car (car list)))
-        (if (satisfies-the-test item car)
-            (return list))))))
+        (when (satisfies-the-test item car)
+          (return list))))))
 
 (defun member-if (test list &key key)
   #!+sb-doc
@@ -1137,3 +1157,43 @@
   #!+sb-doc
   "Apply FUNCTION to successive CDRs of lists. Return NCONC of results."
   (map1 function (cons list more-lists) :nconc nil))
+
+;;;; Specialized versions
+
+;;; %MEMBER-* and %ASSOC-* function. The transforms for %MEMBER and %ASSOC pick
+;;; the appropriate version. These win because they have only positional arguments,
+;;; the TEST & KEY functions are known to exist (or not), and are known to be
+;;; functions, not function designators.
+(macrolet ((def (funs form)
+             (flet ((%def (name)
+                      `(defun ,(intern (format nil "%~A~{-~A~}" name funs))
+                           (item list ,@funs)
+                         ,@(when funs `((declare (function ,@funs))))
+                         (do ((list list (cdr list)))
+                             ((null list) nil)
+                           (let ((this (car list)))
+                             ,(ecase name
+                                    (assoc
+                                     `(when this
+                                        (let ((target (car this)))
+                                          (when (and this ,form)
+                                            (return this)))))
+                                    (member
+                                     `(let ((target this))
+                                        (when ,form
+                                          (return list))))))))))
+               `(progn
+                  ,(%def 'member)
+                  ,(%def 'assoc)))))
+  (def ()
+      (eql item target))
+  (def (key)
+      (eql item (funcall key target)))
+  (def (key test)
+      (funcall test item (funcall key target)))
+  (def (key test-not)
+      (not (funcall test-not item (funcall key target))))
+  (def (test)
+      (funcall test item target))
+  (def (test-not)
+    (not (funcall test-not item target))))