From c906a1440506a4133adf3e77371bde75ad7721ee Mon Sep 17 00:00:00 2001
From: "Paul F. Dietz" <pfdietz@users.sourceforge.net>
Date: Thu, 28 Jul 2005 01:20:34 +0000
Subject: [PATCH] 0.9.3.4:    Speed up hashed remove-duplicate by properly
 sizing the hash table.    Make an AVER in
 make-character-set-type run in O(n) instead      of
 O(nlogn) time.

---
 src/code/early-type.lisp |    9 ++++++--
 src/code/seq.lisp        |   53 ++++++++++++++++++++++++++--------------------
 version.lisp-expr        |    2 +-
 3 files changed, 38 insertions(+), 26 deletions(-)

diff --git a/src/code/early-type.lisp b/src/code/early-type.lisp
index b338ad7..b1833ec 100644
--- a/src/code/early-type.lisp
+++ b/src/code/early-type.lisp
@@ -337,8 +337,13 @@
             (:copier nil))
   (pairs (missing-arg) :type list :read-only t))
 (defun make-character-set-type (&key pairs)
-  (aver (equal (mapcar #'car pairs)
-              (sort (mapcar #'car pairs) #'<)))
+  ; (aver (equal (mapcar #'car pairs)
+  ;              (sort (mapcar #'car pairs) #'<)))
+  ;; aver that the cars of the list elements are sorted into increasing order
+  (aver (or (null pairs)
+	    (do ((p pairs (cdr p)))
+		((null (cdr p)) t)
+	      (when (> (caar p) (caadr p)) (return nil)))))
   (let ((pairs (let (result)
                 (do ((pairs pairs (cdr pairs)))
                     ((null pairs) (nreverse result))
diff --git a/src/code/seq.lisp b/src/code/seq.lisp
index a43e2f7..e88cb37 100644
--- a/src/code/seq.lisp
+++ b/src/code/seq.lisp
@@ -1549,6 +1549,7 @@
   (let* ((result (list ())) ; Put a marker on the beginning to splice with.
          (splice result)
          (current list)
+	 (end (or end (length list)))
 	 (hash (and test
 		    (not key)
 		    (not test-not)
@@ -1556,37 +1557,43 @@
 			(eql test #'eq)
 			(eql test #'equal)
 			(eql test #'equalp))
-		    ; (> (if end (- end start) (- (length list) start)) 20)
-		    (make-hash-table :test test))))
+		    ; (> (- end start) 20)
+		    (make-hash-table :test test :size (- end start)))))
     (do ((index 0 (1+ index)))
         ((= index start))
       (declare (fixnum index))
-      ;; (if hash (setf (gethash (car current) hash) splice))
       (setq splice (cdr (rplacd splice (list (car current)))))
       (setq current (cdr current)))
-    (do ((index start (1+ index)))
-        ((or (and end (= index (the fixnum end)))
-             (atom current)))
-      (declare (fixnum index))
-      (cond
-       (hash
-	(let ((prev (gethash (car current) hash)))
-	  (cond
-	   ((not prev)
-	    (setf (gethash (car current) hash) splice)
-	    (setq splice (cdr (rplacd splice (list (car current))))))
-	   (from-end nil)
-	   (t
-	    (let ((old (cdr prev)))
-	      (let ((next (cdr old)))
-		(when next
+    (if hash
+	(do ((index start (1+ index)))
+	    ((or (and end (= index (the fixnum end)))
+		 (atom current)))
+	  (declare (fixnum index))
+	  ;; The hash table contains links from values that are
+	  ;; already in result to the cons cell *preceding* theirs
+	  ;; in the list.  That is, for each value v in the list,
+	  ;; v and (cadr (gethash v hash)) are equal under TEST.
+	  (let ((prev (gethash (car current) hash)))
+	    (cond
+	     ((not prev)
+	      (setf (gethash (car current) hash) splice)
+	      (setq splice (cdr (rplacd splice (list (car current))))))
+	     ((not from-end)
+	      (let* ((old (cdr prev))
+		     (next (cdr old)))
+		(if next
 		  (let ((next-val (car next)))
 		    ;; (assert (eq (gethash next-val hash) old))
 		    (setf (cdr prev) next
 			  (gethash next-val hash) prev
 			  (gethash (car current) hash) splice
-			  splice (cdr (rplacd splice (list (car current)))))))))))))
-       (t
+			  splice (cdr (rplacd splice (list (car current))))))
+		  (setf (car old) (car current)))))))
+	  (setq current (cdr current)))
+      (do ((index start (1+ index)))
+	  ((or (and end (= index (the fixnum end)))
+	       (atom current)))
+	(declare (fixnum index))
 	(if (or (and from-end
 		     (not (if test-not
 			      (member (apply-key key (car current))
@@ -1610,8 +1617,8 @@
 						  (apply-key key (car l))))
 				  (funcall test it (apply-key key (car l))))
 				(return t))))))
-	    (setq splice (cdr (rplacd splice (list (car current))))))))
-      (setq current (cdr current)))
+	    (setq splice (cdr (rplacd splice (list (car current))))))
+	(setq current (cdr current))))
     (do ()
         ((atom current))
       (setq splice (cdr (rplacd splice (list (car current)))))
diff --git a/version.lisp-expr b/version.lisp-expr
index 5ebaa57..4341743 100644
--- 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".)
-"0.9.3.3"
+"0.9.3.4"
-- 
1.7.10.4