From 0cf37702e1f78eb20a40e3d0cb71ac62528cff08 Mon Sep 17 00:00:00 2001
From: wlott <wlott>
Date: Thu, 7 May 1992 08:48:08 +0000
Subject: [PATCH] Rewrote most everything.  MAKE-HASH-TABLE now conforms to the
 X3J13 spec.

---
 code/hash.lisp | 723 +++++++++++++++++++++++++------------------------
 1 file changed, 363 insertions(+), 360 deletions(-)

diff --git a/code/hash.lisp b/code/hash.lisp
index 1aa2a93a0..9f1356339 100644
--- a/code/hash.lisp
+++ b/code/hash.lisp
@@ -1,4 +1,4 @@
-;;; -*- Log: code.log; Package: Lisp -*-
+;;; -*- Package: CL -*-
 ;;;
 ;;; **********************************************************************
 ;;; This code was written as part of the CMU Common Lisp project at
@@ -7,80 +7,118 @@
 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/hash.lisp,v 1.12 1992/04/23 14:11:06 wlott Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/hash.lisp,v 1.13 1992/05/07 08:48:08 wlott Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
 ;;; Hashing and hash table functions for Spice Lisp.
-;;; Written by Skef Wholey.
+;;; Originally written by Skef Wholey.
+;;; Everything except SXHASH rewritten by William Lott.
 ;;;
-(in-package 'lisp)
+(in-package :common-lisp)
+
 (export '(hash-table hash-table-p make-hash-table
 	  gethash remhash maphash clrhash
-	  hash-table-count sxhash
-	  with-hash-table-iterator))
-
-;;; Vector subtype codes.
-
-(defconstant valid-hashing 2)
-(defconstant must-rehash 3)
-
+	  hash-table-count with-hash-table-iterator
+	  hash-table-rehash-size hash-table-rehash-threshold
+	  hash-table-size hash-table-test
+	  sxhash))
 
-;;; What a hash-table is:
+
+;;;; The hash-table structure.
 
-(defstruct (hash-table (:constructor make-hash-table-structure)
-		       (:conc-name hash-table-)
-		       (:print-function %print-hash-table)
-		       (:make-load-form-fun make-hash-table-load-form))
+(defstruct (hash-table
+	    (:constructor %make-hash-table)
+	    (:print-function %print-hash-table)
+	    (:make-load-form-fun make-hash-table-load-form))
   "Structure used to implement hash tables."
-  (kind 'eq)
-  (size 65 :type fixnum)
-  (rehash-size 101)				; might be a float
-  (rehash-threshold 57 :type fixnum)
-  (number-entries 0 :type fixnum)
+  ;;
+  ;; The type of hash table this is.  Only used for printing and as part of
+  ;; the exported interface.
+  (test (required-argument) :type symbol :read-only t)
+  ;;
+  ;; The function used to compare two keys.  Returns T if they are the same
+  ;; and NIL if not.
+  (test-fun (required-argument) :type function :read-only t)
+  ;;
+  ;; The function used to compute the hashing of a key.  Returns two values:
+  ;; the index hashing and T if that might change with the next GC.
+  (hash-fun (required-argument) :type function :read-only t)
+  ;;
+  ;; How much to grow the hash table by when it fills up.  If an index, then
+  ;; add that amount.  If a floating point number, then multiple it by that.
+  (rehash-size (required-argument) :type (or index (float (1.0))) :read-only t)
+  ;;
+  ;; How full the hash table has to get before we rehash.
+  (rehash-threshold (required-argument) :type (real 0 1) :read-only t)
+  ;;
+  ;; (* rehash-threshold (length table)), saved here so we don't have to keep
+  ;; recomputing it.
+  (rehash-trigger (required-argument) :type index)
+  ;;
+  ;; The current number of entries in the table.
+  (number-entries 0 :type index)
+  ;;
+  ;; Vector of ht-buckets.
   (table (required-argument) :type simple-vector))
+;;;
+(defun %print-hash-table (ht stream depth)
+  (declare (ignore depth))
+  (print-unreadable-object (ht stream :identity t)
+    (format stream "~A hash table, ~D entries"
+	    (symbol-name (hash-table-test ht))
+	    (hash-table-number-entries ht))))
 
-;;; A hash-table-table is a vector of association lists.  When an
-;;; entry is made in a hash table, a pair of (key . value) is consed onto
-;;; the element in the vector arrived at by hashing.
+(defconstant max-hash most-positive-fixnum)
 
-;;; How to print one:
+(deftype hash ()
+  `(integer 0 ,max-hash))
 
-(defun %print-hash-table (structure stream depth)
-  (declare (ignore depth))
-  (format stream "#<~A Hash Table {~X}>"
-	  (symbol-name (hash-table-kind structure))
-	  (system:%primitive make-fixnum structure)))
+
+(defstruct hash-table-bucket
+  ;;
+  ;; The hashing associated with key, kept around so we don't have to recompute
+  ;; it each time.  When NIL, then just use %primitive make-fixnum.  We don't
+  ;; cache the results of make-fixnum, because it can change with a GC.
+  (hash nil :type (or hash null))
+  ;;
+  ;; The key and value, originally supplied by the user.
+  (key nil :type t)
+  (value nil :type t)
+  ;;
+  ;; The next bucket, or NIL if there are no more.
+  (next nil :type (or hash-table-bucket null)))
 
 
 
-;;; Hashing functions for the three kinds of hash tables:
+;;;; Utility functions.
 
-(eval-when (compile)
+(declaim (inline pointer-hash))
+(defun pointer-hash (key)
+  (declare (values hash))
+  (truly-the hash (%primitive make-fixnum key)))
 
-(defmacro eq-hash (object)
-  "Gives us a hashing of an object such that (eq a b) implies
-   (= (eq-hash a) (eq-hash b))"
-  `(truly-the (unsigned-byte 24) (%primitive make-fixnum ,object)))
+(declaim (inline eq-hash))
+(defun eq-hash (key)
+  (declare (values hash (member t nil)))
+  (values (pointer-hash key)
+	  (oddp (get-lisp-obj-address key))))
 
-(defmacro eql-hash (object)
-  "Gives us a hashing of an object such that (eql a b) implies
-   (= (eql-hash a) (eql-hash b))"
-  `(if (numberp ,object)
-       (logand (truncate ,object) most-positive-fixnum)
-       (truly-the fixnum (%primitive make-fixnum ,object))))
+(declaim (inline eql-hash))
+(defun eql-hash (key)
+  (declare (values hash (member t nil)))
+  (if (numberp key)
+      (equal-hash key)
+      (eq-hash key)))
 
-(defmacro equal-hash (object)
-  "Gives us a hashing of an object such that (equal a b) implies
-   (= (equal-hash a) (equal-hash b))"
-  `(sxhash ,object))
+(declaim (inline equal-hash))
+(defun equal-hash (key)
+  (declare (values hash (member t nil)))
+  (values (sxhash key) nil))
 
-)
-
-;;; Rehashing functions:
 
 (defun almost-primify (num)
-  (declare (fixnum num))
+  (declare (type index num))
   "Almost-Primify returns an almost prime number greater than or equal
    to NUM."
   (if (= (rem num 2) 0)
@@ -91,287 +129,289 @@
       (setq num (+ 4 num)))
   num)
 
-(eval-when (compile)
-
-(defmacro grow-size (table)
-  "Returns a fixnum for the next size of a growing hash-table."
-  `(let ((rehash-size (hash-table-rehash-size ,table)))
-     (if (floatp rehash-size)
-	 (ceiling (* rehash-size (hash-table-size ,table)))
-	 (+ rehash-size (hash-table-size ,table)))))
-
-(defmacro grow-rehash-threshold (table new-length)
-  "Returns the next rehash threshold for the table."
-  table
-  `,new-length
-;  `(ceiling (* (hash-table-rehash-threshold ,table)
-;	       (/ ,new-length (hash-table-size ,table))))
-  )
-
-(defmacro hash-set (vector key value length hashing-function)
-  "Used for rehashing.  Enters the value for the key into the vector
-   by hashing.  Never grows the vector.  Assumes the key is not yet
-   entered."
-  `(let ((index (rem (the fixnum (funcall ,hashing-function ,key))
-		     (the fixnum ,length))))
-     (declare (fixnum index))
-     (setf (aref (the simple-vector ,vector) index)
-	   (cons (cons ,key ,value)
-		 (aref (the simple-vector ,vector) index)))))
-
-)
-
-(defun rehash (structure hash-vector new-length)
-  (declare (simple-vector hash-vector))
-  (declare (fixnum new-length))
-  "Rehashes a hash table and replaces the TABLE entry in the structure if
-   someone hasn't done so already.  New vector is of NEW-LENGTH."
-  (do ((new-vector (make-array new-length :initial-element nil))
-       (i 0 (1+ i))
-       (size (hash-table-size structure))
-       (hashing-function (case (hash-table-kind structure)
-			   (eq #'(lambda (x) (eq-hash x)))
-			   (eql #'(lambda (x) (eql-hash x)))
-			   (equal #'(lambda (x) (equal-hash x))))))
-      ((= i size)
-       (cond ((eq hash-vector (hash-table-table structure))
-	      (cond ((> new-length size)
-		     (setf (hash-table-table structure) new-vector)
-		     (setf (hash-table-rehash-threshold structure)
-			   (grow-rehash-threshold structure new-length))
-		     (setf (hash-table-size structure) new-length))
-		    (t
-		     (setf (hash-table-table structure) new-vector)))
-	      (if (not (eq (hash-table-kind structure) 'equal))
-		  (%primitive set-vector-subtype new-vector
-			      valid-hashing)))))
-    (declare (fixnum i size))
-    (do ((bucket (aref hash-vector i) (cdr bucket)))
-	((null bucket))
-      (hash-set new-vector (caar bucket) (cdar bucket) new-length
-		hashing-function))
-    (setf (aref hash-vector i) nil)))
-
-;;; Macros for Gethash, %Puthash, and Remhash:
-
-(eval-when (compile)
-
-;;; Hashop dispatches on the kind of hash table we've got, rehashes if
-;;; necessary, and binds Vector to the hash vector, Index to the index
-;;; into that vector that the Key points to, and Size to the size of the
-;;; hash vector.  Since Equal hash tables only need to be maybe rehashed
-;;; sometimes, one can tell it if it's one of those times with the
-;;; Equal-Needs-To-Rehash-P argument.
-
-(defmacro hashop (equal-needs-to-rehash-p eq-body eql-body equal-body)
-  `(let* ((vector (hash-table-table hash-table))
-	  (size (length vector)))
-     (declare (simple-vector vector) (fixnum size)
-	      (inline assoc))
-     (case (hash-table-kind hash-table)
-       (equal
-	,@(if equal-needs-to-rehash-p `((equal-rehash-if-needed)))
-	(let ((index (rem (the fixnum (equal-hash key)) size)))
-	  (declare (fixnum index))
-	  ,equal-body))
-       (eq
-	(without-gcing
-	  (eq-rehash-if-needed)
-	  (let ((index (rem (the fixnum (eq-hash key)) size)))
-	    (declare (fixnum index))
-	    ,eq-body)))
-       (eql
-	(without-gcing
-	  (eq-rehash-if-needed)
-	  (let ((index (rem (the fixnum (eql-hash key)) size)))
-	    (declare (fixnum index))
-	    ,eql-body))))))
-
-(defmacro eq-rehash-if-needed ()
-  `(let ((subtype (truly-the (unsigned-byte 24)
-			     (%primitive get-vector-subtype vector))))
-     (declare (type (unsigned-byte 24) subtype))
-     (cond ((/= subtype valid-hashing)
-	    (rehash hash-table vector size)
-	    (setq vector (hash-table-table hash-table)))
-	   ((> (hash-table-number-entries hash-table)
-	       (hash-table-rehash-threshold hash-table))
-	    (rehash hash-table vector (grow-size hash-table))
-	    (setq vector (hash-table-table hash-table))
-	    (setq size (length vector))))))
-
-(defmacro equal-rehash-if-needed ()
-  `(cond ((> (hash-table-number-entries hash-table)
-	     (hash-table-rehash-threshold hash-table))
-	  (rehash hash-table vector (grow-size hash-table))
-	  (setq vector (hash-table-table hash-table))
-	  (setq size (length vector)))))
-
-(defmacro rehash-if-needed ()
-  `(let ((subtype (truly-the (unsigned-byte 24)
-			     (%primitive get-vector-subtype vector)))
-	 (size (length vector)))
-     (declare (type (unsigned-byte 24) subtype)
-	      (fixnum size))
-     (cond ((and (not (eq (hash-table-kind hash-table) 'equal))
-		 (/= subtype valid-hashing))
-	    (rehash hash-table vector size)
-	    (setq vector (hash-table-table hash-table))
-	    (setq size (length vector)))
-	   ((> (hash-table-number-entries hash-table)
-	       (hash-table-rehash-threshold hash-table))
-	    (rehash hash-table vector (grow-size hash-table))
-	    (setq vector (hash-table-table hash-table))
-	    (setq size (length vector))))))
-
-)
-
-;;; Making hash tables:
 
-(defun make-hash-table (&key (test 'eql) (size 65) (rehash-size 101)
-			     (rehash-threshold size))
-  "Creates and returns a hash table.  See manual for details."
+
+;;;; Construction and simple accessors.
+
+;;; MAKE-HASH-TABLE -- public.
+;;; 
+(defun make-hash-table (&key (test 'eql) (size 65) (rehash-size 1.5)
+			     (rehash-threshold 1))
+  "Creates and returns a new hash table.  The keywords are as follows:
+     :TEST -- Indicates what kind of test to use.  Only EQ, EQL, and EQUAL
+       are currently supported.
+     :SIZE -- A hint as to how many elements will be put in this hash
+       table.
+     :REHASH-SIZE -- Indicates how to expand the table when it fills up.
+       If an integer, add space for that many elements.  If a floating
+       point number (which must be greater than 1.0), multiple the size
+       by that amount.
+     :REHASH-THRESHOLD -- Indicates how dense the table can become before
+       forcing a rehash.  Can be any real number between 0 and 1 (inclusive)."
   (declare (type (or function (member eq eql equal)) test)
-	   (type index size rehash-size)
-	   (type (or (float 0.0 1.0) index) rehash-threshold))
-  (let* ((test (cond ((or (eq test #'eq) (eq test 'eq)) 'eq)
-		     ((or (eq test #'eql) (eq test 'eql)) 'eql)
-		     ((or (eq test #'equal) (eq test 'equal)) 'equal)
-		     (t
-		      (error "~S is an illegal :Test for hash tables." test))))
-	 (size (if (<= size 37) 37 (almost-primify size)))
-	 (rehash-threshold
-	  (cond ((and (fixnump rehash-threshold)
-		      (<= 0 rehash-threshold size))
-		 rehash-threshold)
-		((and (floatp rehash-threshold)
-		      (<= 0.0 rehash-threshold 1.0))
-		 (ceiling (* rehash-threshold size)))
-		(t
-		 (error "Invalid rehash-threshold: ~S.~%Must be either a float ~
-			 between 0.0 and 1.0 ~%or an integer between 0 and ~D."
-			rehash-threshold
-			size))))
-	 (table (make-array size :initial-element nil)))
-    (make-hash-table-structure :size size
-			       :rehash-size rehash-size
-			       :rehash-threshold rehash-threshold
-			       :table
-			       (if (eq test 'equal)
-				   table
-				   (%primitive set-vector-subtype
-					       table
-					       valid-hashing))
-			       :kind test)))
+	   (type index size)
+	   (type (or index (float (1.0))) rehash-size)
+	   (type (real 0 1) rehash-threshold))
+  (multiple-value-bind
+      (test test-fun hash-fun)
+      (cond ((or (eq test #'eq) (eq test 'eq))
+	     (values 'eq #'eq #'eq-hash))
+	    ((or (eq test #'eql) (eq test 'eql))
+	     (values 'eql #'eql #'eql-hash))
+	    ((or (eq test #'equal) (eq test 'equal))
+	     (values 'equal #'equal #'equal-hash))
+	    (t
+	     (error "Unknown :TEST for MAKE-HASH-TABLE: ~S" test)))
+    (let* ((size (ceiling size rehash-threshold))
+	   (length (if (<= size 37) 37 (almost-primify size)))
+	   (vector (make-array length :initial-element nil)))
+      (make-hash-table-structure
+       :test test
+       :test-fun test-fun
+       :hash-fun hash-fun
+       :rehash-size rehash-size
+       :rehash-threshold rehash-threshold
+       :rehash-trigger (* size rehash-threshold)
+       :table vector))))
+
+(defun hash-table-count (hash-table)
+  "Returns the number of entries in the given HASH-TABLE."
+  (declare (type hash-table hash-table)
+	   (values index))
+  (hash-table-number-entries hash-table))
+
+(setf (documentation 'hash-table-rehash-size 'function)
+      "Return the rehash-size HASH-TABLE was created with.")
+
+(setf (documentation 'hash-table-rehash-threshold 'function)
+      "Return the rehash-threshold HASH-TABLE was created with.")
+
+(defun hash-table-size (hash-table)
+  "Return a size that can be used with MAKE-HASH-TABLE to create a hash
+   table that can hold however many entries HASH-TABLE can hold without
+   having to be grown."
+  (hash-table-rehash-trigger hash-table))
+
+(setf (documentation 'hash-table-test 'function)
+      "Return the test HASH-TABLE was created with.")
+
 
-;;; Manipulating hash tables:
+;;;; Accessing functions.
 
+;;; REHASH -- internal.
+;;;
+;;; Make a new vector for TABLE.  If GROW is NIL, use the same size as before,
+;;; otherwise extend the table based on the rehash-size.
+;;;
+(defun rehash (table grow)
+  (declare (type hash-table table))
+  (let* ((old-vector (hash-table-table table))
+	 (old-length (length old-vector))
+	 (new-length
+	  (if grow
+	      (let ((rehash-size (hash-table-rehash-size table)))
+		(etypecase rehash-size
+		  (fixnum
+		   (+ rehash-size old-length))
+		  (float
+		   (ceiling (* rehash-size old-length)))))
+	      old-length))
+	 (new-vector (make-array new-length :initial-element nil)))
+    (dotimes (i old-length)
+      (do ((bucket (svref old-vector i) next)
+	   (next nil))
+	  ((null bucket))
+	(setf next (hash-table-bucket-next bucket))
+	(let* ((old-hashing (hash-table-bucket-hash bucket))
+	       (hashing (cond
+			 (old-hashing old-hashing)
+			 (t
+			  (set-header-data new-vector
+					   vm:vector-valid-hashing-subtype)
+			  (pointer-hash (hash-table-bucket-key bucket)))))
+	       (index (rem hashing new-length)))
+	  (setf (hash-table-bucket-next bucket) (svref new-vector index))
+	  (setf (svref new-vector index) bucket)))
+      ;; We clobber the old vector contents so that if it is living in
+      ;; static space it won't keep ahold of pointers into dynamic space.
+      (setf (svref old-vector i) nil))
+    (setf (hash-table-table table) new-vector)
+    (unless (= new-length old-length)
+      (setf (hash-table-rehash-trigger table)
+	    (let ((threshold (hash-table-rehash-threshold table)))
+	      ;; Optimize the threshold=1 case so we don't have to use
+	      ;; generic arithmetic in the most common case.
+	      (if (eql threshold 1)
+		  new-length
+		  (truncate (* threshold new-length)))))))
+  (undefined-value))
+
+;;; GETHASH -- Public.
+;;; 
 (defun gethash (key hash-table &optional default)
-  "Finds the entry in Hash-Table whose key is Key and returns the associated
-   value and T as multiple values, or returns Default and Nil if there is no
-   such entry."
-  (macrolet ((lookup (test)
-	       `(let ((cons (assoc key (aref vector index) :test #',test)))
-		  (declare (list cons))
-		  (if cons
-		      (values (cdr cons) t)
-		      (values default nil)))))
-    (hashop nil
-      (lookup eq)
-      (lookup eql)
-      (lookup equal))))
-
+  "Finds the entry in HASH-TABLE whose key is KEY and returns the associated
+   value and T as multiple values, or returns DEFAULT and NIL if there is no
+   such entry.  Entries can be added using SETF."
+  (declare (type hash-table hash-table)
+	   (values t (member t nil)))
+  (without-gcing
+   (when (= (get-header-data (hash-table-table hash-table))
+	    vm:vector-must-rehash-subtype)
+     (rehash hash-table nil))
+   (let* ((vector (hash-table-table hash-table))
+	  (length (length vector))
+	  (hashing (funcall (hash-table-hash-fun hash-table) key))
+	  (index (rem hashing length))
+	  (test-fun (hash-table-test-fun hash-table)))
+     (do ((bucket (svref vector index) (hash-table-bucket-next bucket)))
+	 ((null bucket) (values default nil))
+       (let ((bucket-hashing (hash-table-bucket-hash bucket)))
+	 (when (if bucket-hashing
+		   (and (= bucket-hashing hashing)
+			(funcall test-fun key (hash-table-bucket-key bucket)))
+		   (eq key (hash-table-bucket-key bucket)))
+	   (return (values (hash-table-bucket-value bucket) t))))))))
+
+;;; %PUTHASH -- public setf method.
+;;; 
 (defun %puthash (key hash-table value)
-  "Create an entry in HASH-TABLE associating KEY with VALUE; if there already
-   is an entry for KEY, replace it.  Returns VALUE."
-  (macrolet ((store (test)
-	       `(let ((cons (assoc key (aref vector index) :test #',test)))
-		  (declare (list cons))
-		  (cond (cons (setf (cdr cons) value))
-			(t
-			 (push (cons key value) (aref vector index))
-			 (incf (hash-table-number-entries hash-table))
-			 value)))))
-    (hashop t
-      (store eq)
-      (store eql)
-      (store equal))))
-
+  (declare (type hash-table hash-table))
+  (without-gcing
+   (let ((entries (1+ (hash-table-number-entries hash-table))))
+     (setf (hash-table-number-entries hash-table) entries)
+     (cond ((> entries (hash-table-rehash-trigger hash-table))
+	    (rehash hash-table t))
+	   ((= (get-header-data (hash-table-table hash-table))
+	       vm:vector-must-rehash-subtype)
+	    (rehash hash-table nil))))
+   (multiple-value-bind
+       (hashing eq-based)
+       (funcall (hash-table-hash-fun hash-table) key)
+     (let* ((vector (hash-table-table hash-table))
+	    (length (length vector))
+	    (index (rem hashing length))
+	    (first-bucket (svref vector index))
+	    (test-fun (hash-table-test-fun hash-table)))
+       (do ((bucket first-bucket (hash-table-bucket-next bucket)))
+	   ((null bucket)
+	    (setf (svref vector index)
+		  (make-hash-table-bucket
+		   :hash (unless eq-based hashing)
+		   :key key
+		   :value value
+		   :next first-bucket)))
+	 (let ((bucket-hashing (hash-table-bucket-hash bucket)))
+	   (when (if bucket-hashing
+		     (and (= bucket-hashing hashing)
+			  (funcall test-fun
+				   key (hash-table-bucket-key bucket)))
+		     (eq key (hash-table-bucket-key bucket)))
+	     (setf (hash-table-bucket-value bucket) value)
+	     (decf (hash-table-number-entries hash-table))
+	     (return)))))))
+  value)
+
+;;; REMHASH -- public.
+;;; 
 (defun remhash (key hash-table)
-  "Remove any entry for KEY in HASH-TABLE.  Returns T if such an entry
-   existed; () otherwise."
-  (hashop nil
-   (let ((bucket (aref vector index)))		; EQ case
-     (cond ((and bucket (eq (caar bucket) key))
-	    (pop (aref vector index))
-	    (decf (hash-table-number-entries hash-table))
-	    t)
-	   (t
-	    (do ((last bucket bucket)
-		 (bucket (cdr bucket) (cdr bucket)))
-		((null bucket) ())
-	      (when (eq (caar bucket) key)
-		(rplacd last (cdr bucket))
-		(decf (hash-table-number-entries hash-table))
-		(return t))))))
-   (let ((bucket (aref vector index)))		; EQL case
-     (cond ((and bucket (eql (caar bucket) key))
-	    (pop (aref vector index))
-	    (decf (hash-table-number-entries hash-table))
-	    t)
-	   (t
-	    (do ((last bucket bucket)
-		 (bucket (cdr bucket) (cdr bucket)))
-		((null bucket) ())
-	      (when (eql (caar bucket) key)
-		(rplacd last (cdr bucket))
-		(decf (hash-table-number-entries hash-table))
-		(return t))))))
-   (let ((bucket (aref vector index)))		; EQUAL case
-     (cond ((and bucket (equal (caar bucket) key))
-	    (pop (aref vector index))
-	    (decf (hash-table-number-entries hash-table))
-	    t)
-	   (t
-	    (do ((last bucket bucket)
-		 (bucket (cdr bucket) (cdr bucket)))
-		((null bucket) ())
-	      (when (equal (caar bucket) key)
-		(rplacd last (cdr bucket))
-		(decf (hash-table-number-entries hash-table))
-		(return t))))))))
+  "Remove the entry in HASH-TABLE associated with KEY.  Returns T if there
+   was such an entry, and NIL if not."
+  (declare (type hash-table hash-table)
+	   (values (member t nil)))
+  (without-gcing
+   (when (= (get-header-data (hash-table-table hash-table))
+	    vm:vector-must-rehash-subtype)
+     (rehash hash-table nil))
+   (let* ((vector (hash-table-table hash-table))
+	  (length (length vector))
+	  (hashing (funcall (hash-table-hash-fun hash-table) key))
+	  (index (rem hashing length))
+	  (test-fun (hash-table-test-fun hash-table)))
+     (do ((prev nil bucket)
+	  (bucket (svref vector index) (hash-table-bucket-next bucket)))
+	 ((null bucket) nil)
+       (let ((bucket-hashing (hash-table-bucket-hash bucket)))
+	 (when (if bucket-hashing
+		   (and (= bucket-hashing hashing)
+			(funcall test-fun key (hash-table-bucket-key bucket)))
+		   (eq key (hash-table-bucket-key bucket)))
+	   (if prev
+	       (setf (hash-table-bucket-next prev)
+		     (hash-table-bucket-next bucket))
+	       (setf (svref vector index)
+		     (hash-table-bucket-next bucket)))
+	   (return t)))))))
+
+;;; CLRHASH -- public.
+;;; 
+(defun clrhash (hash-table)
+  "This removes all the entries from HASH-TABLE and returns the hash table
+   itself."
+  (let ((vector (hash-table-table hash-table)))
+    (dotimes (i (length vector))
+      (setf (aref vector i) nil))
+    (setf (hash-table-number-entries hash-table) 0)
+    (set-header-data vector vm:vector-normal-subtype))
+  hash-table)
+
+
 
+;;;; MAPHASH and WITH-HASH-TABLE-ITERATOR
+
+(declaim (maybe-inline maphash))
 (defun maphash (map-function hash-table)
   "For each entry in HASH-TABLE, calls MAP-FUNCTION on the key and value
-  of the entry; returns NIL."
-  (let ((vector (hash-table-table hash-table)))
-    (declare (simple-vector vector))
-    (rehash-if-needed)
-    (do ((i 0 (1+ i))
-	 (size (hash-table-size hash-table)))
-	((= i size))
-      (declare (fixnum i size))
-      (do ((bucket (aref vector i) (cdr bucket)))
+   of the entry; returns NIL."
+  (declare (type (or function symbol) map-function)
+	   (type hash-table hash-table))
+  (let ((fun (etypecase map-function
+	       (function
+		map-function)
+	       (symbol
+		(symbol-function map-function))))
+	(vector (hash-table-table hash-table)))
+    (dotimes (i (length vector))
+      (do ((bucket (svref vector i) (hash-table-bucket-next bucket)))
 	  ((null bucket))
-	
-	(funcall map-function (caar bucket) (cdar bucket))))))
+	(funcall fun
+		 (hash-table-bucket-key bucket)
+		 (hash-table-bucket-value bucket))))))
+
+
+(defmacro with-hash-table-iterator ((function hash-table) &body body)
+  "WITH-HASH-TABLE-ITERATOR ((function hash-table) &body body)
+   provides a method of manually looping over the elements of a hash-table.
+   function is bound to a generator-macro that, withing the scope of the
+   invocation, returns three values.  First, whether there are any more objects
+   in the hash-table, second, the key, and third, the value."
+  (let ((n-function (gensym "WITH-HASH-TABLE-ITERRATOR-")))
+    `(let ((,n-function
+	    (let* ((table ,hash-table)
+		   (vector (hash-table-table table))
+		   (length (length vector))
+		   (index 0)
+		   (bucket (svref vector 0)))
+	      (labels
+		  ((,function ()
+		     (cond
+		      (bucket
+		       (multiple-value-prog1
+			   (values t
+				   (hash-table-bucket-key bucket)
+				   (hash-table-bucket-value bucket))
+			 (setf bucket (hash-table-bucket-next bucket))))
+		      ((= (incf index) length)
+		       (values nil))
+		      (t
+		       (setf bucket (svref vector index))
+		       (,function)))))
+		#',function))))
+       (macrolet ((,function () (funcall ,n-function)))
+	 ,@body))))
 
-(defun clrhash (hash-table)
-  "Removes all entries of HASH-TABLE and returns the hash table itself."
-  (let ((vector (hash-table-table hash-table)))
-    (declare (simple-vector vector))
-    (setf (hash-table-number-entries hash-table) 0)
-    (do ((i 0 (1+ i))
-	 (size (hash-table-size hash-table)))
-	((= i size) hash-table)
-      (declare (fixnum i size))
-      (setf (aref vector i) nil))))
 
-(defun hash-table-count (hash-table)
-  "Returns the number of entries in the given Hash-Table."
-  (hash-table-number-entries hash-table))
 
-;;; Primitive Hash Function
+;;;; SXHASH and support functions
 
 ;;; The maximum length and depth to which we hash lists.
 (defconstant sxhash-max-len 7)
@@ -469,57 +509,20 @@
     (t 42)))
 
 
-
-;;;; WITH-HASH-TABLE-ITERATOR
-
-(defmacro with-hash-table-iterator ((function hash-table) &body body)
-  "WITH-HASH-TABLE-ITERATOR ((function hash-table) &body body)
-   provides a method of manually looping over the elements of a hash-table.
-   function is bound to a generator-macro that, withing the scope of the
-   invocation, returns three values.  First, whether there are any more objects
-   in the hash-table, second, the key, and third, the value."
-  (let ((counter (gensym))
-	(pointer (gensym))
-	(table (gensym))
-	(size (gensym))
-	(the-table (gensym)))
-    `(let* ((,the-table ,hash-table)
-	    (,table (hash-table-table ,the-table))
-	    (,size (hash-table-size ,the-table))
-	    (,counter 0)
-	    (,pointer nil))
-       (macrolet ((,function ()
-		     `(loop
-			(when (= ,',counter ,',size) (return))
-			(let ((bucket (or ,',pointer
-					  (aref ,',table ,',counter))))
-			  (when bucket
-			    (cond ((cdr bucket)
-				   (setf ,',pointer (cdr bucket)))
-				  (t
-				   (setf ,',pointer nil)
-				   (incf ,',counter)))
-			    (return (values t (caar bucket) (cdar bucket)))))
-			(incf ,',counter))))
-	 ,@body))))
-
-
 
 ;;;; Dumping one as a constant.
 
 (defun make-hash-table-load-form (table)
   (values
    `(make-hash-table
-     :test ',(hash-table-kind table) :size ',(hash-table-size table)
+     :test ',(hash-table-test table) :size ',(hash-table-size table)
      :hash-table-rehash-size ',(hash-table-rehash-size table)
      :hash-table-rehash-threshold ',(hash-table-rehash-threshold table))
    (let ((sets nil))
-     (with-hash-table-iterator (next table)
-       (loop
-	 (multiple-value-bind (more key value) (next)
-	   (if more
-	       (setf sets (list* `(gethash ',key ,table) `',value sets))
-	       (return)))))
+     (declare (inline maphash))
+     (maphash #'(lambda (key value)
+		  (setf sets (list* `(gethash ',key ,table) `',value sets)))
+	      table)
      (if sets
 	 `(setf ,@sets)
 	 nil))))
-- 
GitLab