0.9.3.13:

 -- Make list-remove-duplicates use a hash table only if the number
    of items to traverse is more than 20.
 -- Add special case routine LAST1 (equivalent to single argument
   call to LAST) and have NCONC call this instead of the general
   function.
 -- Add a special two-argument form of NCONC, called NCONC2. TODO:
    add a source transform to call this.

diff --git a/src/code/list.lisp b/src/code/list.lisp
index e21535c..b328681 100644 (file)
--- a/src/code/list.lisp
+++ b/src/code/list.lisp
@@ -18,8 +18,8 @@
 ;;;; -- 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
+          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
           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,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

@@ -385,12 +394,12 @@
                  ((endp elements))
                (let ((ele (car elements)))
                  (typecase ele
                  ((endp elements))
                (let ((ele (car elements)))
                  (typecase ele

-                   (cons (rplacd (last splice) ele)
+                   (cons (rplacd (last1 splice) ele)

                          (setf splice ele))
                          (setf splice ele))

-                   (null (rplacd (last splice) nil))
+                   (null (rplacd (last1 splice) nil))

                    (atom (if (cdr elements)
                              (fail ele)
                    (atom (if (cdr elements)
                              (fail ele)

-                             (rplacd (last splice) ele)))
+                             (rplacd (last1 splice) ele)))

                    (t (fail ele)))))
              (return result)))
           (null)
                    (t (fail ele)))))
              (return result)))
           (null)

@@ -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)."

@@ -1102,7 +1121,7 @@
           (setf (car l) (cdar l)))
         (setq res (apply fun (nreverse args)))
         (case accumulate
           (setf (car l) (cdar l)))
         (setq res (apply fun (nreverse args)))
         (case accumulate

-          (:nconc (setq temp (last (nconc temp res))))
+          (:nconc (setq temp (last1 (nconc temp res))))

           (:list (rplacd temp (list res))
                  (setq temp (cdr temp))))))))
 
           (:list (rplacd temp (list res))
                  (setq temp (cdr temp))))))))
 

diff --git a/src/code/seq.lisp b/src/code/seq.lisp
index 67ade1b..5fe1f97 100644 (file)
--- a/src/code/seq.lisp
+++ b/src/code/seq.lisp
@@ -1550,14 +1550,14 @@
          (splice result)
          (current list)
          (end (or end (length list)))
          (splice result)
          (current list)
          (end (or end (length list)))

-         (hash (and test
+         (hash (and (> (- end start) 20)
+                    test

                     (not key)
                     (not test-not)
                     (or (eql test #'eql)
                         (eql test #'eq)
                         (eql test #'equal)
                         (eql test #'equalp))
                     (not key)
                     (not test-not)
                     (or (eql test #'eql)
                         (eql test #'eq)
                         (eql test #'equal)
                         (eql test #'equalp))

-                    ; (> (- end start) 20)

                     (make-hash-table :test test :size (- end start)))))
     (do ((index 0 (1+ index)))
         ((= index start))
                     (make-hash-table :test test :size (- end start)))))
     (do ((index 0 (1+ index)))
         ((= index start))

diff --git a/src/compiler/fndb.lisp b/src/compiler/fndb.lisp
index 704e7f0..49f9cfe 100644 (file)
--- a/src/compiler/fndb.lisp
+++ b/src/compiler/fndb.lisp
@@ -671,6 +671,7 @@
 (defknown nth (unsigned-byte list) t (foldable flushable))
 (defknown nthcdr (unsigned-byte list) t (foldable unsafely-flushable))
 (defknown last (list &optional unsigned-byte) t (foldable flushable))
 (defknown nth (unsigned-byte list) t (foldable flushable))
 (defknown nthcdr (unsigned-byte list) t (foldable unsafely-flushable))
 (defknown last (list &optional unsigned-byte) t (foldable flushable))

+(defknown sb!impl::last1 (list) t (foldable flushable))

 (defknown list (&rest t) list (movable flushable unsafe))
 (defknown list* (t &rest t) t (movable flushable unsafe))
 (defknown make-list (index &key (:initial-element t)) list
 (defknown list (&rest t) list (movable flushable unsafe))
 (defknown list* (t &rest t) t (movable flushable unsafe))
 (defknown make-list (index &key (:initial-element t)) list

@@ -689,6 +690,7 @@
 ;;; express that in this syntax. The result must be LIST, but we do
 ;;; not check it now :-).
 (defknown nconc (&rest t) t ())
 ;;; express that in this syntax. The result must be LIST, but we do
 ;;; not check it now :-).
 (defknown nconc (&rest t) t ())

+(defknown sb!impl::nconc2 (list t) t ())

 
 (defknown nreconc (list t) t ())
 (defknown butlast (list &optional unsigned-byte) list (flushable))
 
 (defknown nreconc (list t) t ())
 (defknown butlast (list &optional unsigned-byte) list (flushable))

diff --git a/version.lisp-expr b/version.lisp-expr
index da52f48..7f3b8d1 100644 (file)
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -17,4 +17,4 @@
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)

-"0.9.3.12"
+"0.9.3.13"