From c7b220dd02e00ca266128fd6741b867dda94eccc Mon Sep 17 00:00:00 2001
From: dtc <dtc>
Date: Thu, 13 Jan 2000 16:55:46 +0000
Subject: [PATCH] Add support for EQUALP hash tables; by Douglas Crosher based
 on the work of William H. Newman and Cadabra Inc.

Special case characters within sxhash returning the character code
rather than returning a constant, as per the new equalp-hash.

Declare hash-table-count and hash-table-size inline so they compile to
inline slot accesses.
---
 code/hash-new.lisp | 138 +++++++++++++++++++++++++++++++++++++++++----
 code/hash.lisp     | 138 +++++++++++++++++++++++++++++++++++++++++----
 2 files changed, 252 insertions(+), 24 deletions(-)

diff --git a/code/hash-new.lisp b/code/hash-new.lisp
index d0f2ae265..3595b9951 100644
--- a/code/hash-new.lisp
+++ b/code/hash-new.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/hash-new.lisp,v 1.7 2000/01/13 16:54:31 dtc Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/hash-new.lisp,v 1.8 2000/01/13 16:55:46 dtc Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -13,6 +13,7 @@
 ;;; Originally written by Skef Wholey.
 ;;; Everything except SXHASH rewritten by William Lott.
 ;;; Hash table functions rewritten by Douglas Crosher, 1997.
+;;; Equalp hashing by William Newman, Cadabra Inc, and Douglas Crosher, 2000.
 ;;;
 (in-package :common-lisp)
 
@@ -139,6 +140,9 @@
   (declare (values hash (member t nil)))
   (values (sxhash key) nil))
 
+(defun equalp-hash (key)
+  (values (internal-equalp-hash key 0) nil))
+
 
 (defun almost-primify (num)
   (declare (type index num))
@@ -179,8 +183,8 @@
 (defun make-hash-table (&key (test 'eql) (size 65) (rehash-size 1.5)
 			     (rehash-threshold 1) (weak-p nil))
   "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.
+     :TEST -- Indicates what kind of test to use.  Only EQ, EQL, EQUAL,
+       and EQUALP 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.
@@ -208,6 +212,8 @@
 	       (values 'eql #'eql #'eql-hash))
 	      ((or (eq test #'equal) (eq test 'equal))
 	       (values 'equal #'equal #'equal-hash))
+	      ((or (eq test #'equalp) (eq test 'equalp))
+	       (values 'equalp #'equalp #'equalp-hash))
 	      (t
 	       (dolist (info *hash-table-tests*
 			     (error "Unknown :TEST for MAKE-HASH-TABLE: ~S"
@@ -259,6 +265,7 @@
 	  table)))))
 
 
+(declaim (inline hash-table-count))
 (defun hash-table-count (hash-table)
   "Returns the number of entries in the given HASH-TABLE."
   (declare (type hash-table hash-table)
@@ -271,6 +278,7 @@
 (setf (documentation 'hash-table-rehash-threshold 'function)
       "Return the rehash-threshold HASH-TABLE was created with.")
 
+(declaim (inline hash-table-size))
 (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
@@ -862,31 +870,28 @@
 	   (sxhash-simple-string (coerce (the string ,sequence)
 					 'simple-string))))))
 
-(defmacro sxhash-list (sequence depth)
+(defmacro sxhash-list (sequence depth &key (equalp nil))
   `(if (= ,depth sxhash-max-depth)
        0
        (do ((sequence ,sequence (cdr (the list sequence)))
 	    (index 0 (1+ index))
-	    (hash 2))
+	    (hash 2)
+	    (,depth (1+ ,depth)))
 	   ((or (atom sequence) (= index sxhash-max-len)) hash)
 	 (declare (fixnum hash index))
-	 (sxmash hash (internal-sxhash (car sequence) (1+ ,depth))))))
-
+	 (sxmash hash (,(if equalp 'internal-equalp-hash 'internal-sxhash)
+			(car sequence) ,depth)))))
 
 ); eval-when (compile eval)
 
 
-(defun sxhash (s-expr)
-  "Computes a hash code for S-EXPR and returns it as an integer."
-  (internal-sxhash s-expr 0))
-
-
 (defun internal-sxhash (s-expr depth)
   (declare (type index depth) (values hash))
   (typecase s-expr
     ;; The pointers and immediate types.
     (list (sxhash-list s-expr depth))
     (fixnum (ldb sxhash-bits-byte s-expr))
+    (character (char-code (char-upcase s-expr)))
     (instance
      (if (typep s-expr 'structure-object)
 	 (internal-sxhash (class-name (layout-class (%instance-layout s-expr)))
@@ -932,6 +937,115 @@
     ;; Everything else.
     (t 42)))
 
+(defun sxhash (s-expr)
+  "Computes a hash code for S-EXPR and returns it as an integer."
+  (internal-sxhash s-expr 0))
+
+
+;;;; Equalp hash.
+
+(eval-when (compile eval)
+
+(defmacro hash-table-equalp-hash (table)
+  `(let ((hash (hash-table-count ,table)))
+     (declare (type hash hash))
+     (sxmash hash (sxhash (hash-table-test ,table)))
+     hash))
+
+(defmacro structure-equalp-hash (structure depth)
+  `(if (= ,depth sxhash-max-depth)
+       0
+       (let* ((layout (%instance-layout ,structure))
+	      (length (min (1- (layout-length layout)) sxhash-max-len))
+	      (hash (internal-sxhash (class-name (layout-class layout))
+				     depth))
+	      (,depth (+ ,depth 1)))
+	 (declare (type index length) (type hash hash))
+	 (do ((index 1 (1+ index)))
+	     ((= index length) hash)
+	   (declare (type index index))
+	   (sxmash hash (internal-equalp-hash
+			 (%instance-ref ,structure index) ,depth))))))
+
+(defmacro vector-equalp-hash (vector depth)
+  `(if (= ,depth sxhash-max-depth)
+       0
+       (let ((hash 4)
+	     (length (length ,vector)))
+	 (declare (type hash hash) (type index length))
+	 (sxmash hash length)
+	 (let ((,depth (+ ,depth 1)))
+	   (dotimes (index (min length sxhash-max-len) hash)
+	     (declare (type index index))
+	     (sxmash hash (internal-equalp-hash (aref ,vector index)
+						,depth)))))))
+
+(defmacro array-equalp-hash (array depth)
+  `(if (= ,depth sxhash-max-depth)
+       0
+       (let ((hash 4))
+	 (declare (type hash hash))
+	 (dotimes (index (min sxhash-max-len (array-rank ,array)))
+	   (sxmash hash (array-dimension ,array index)))
+	 (let ((,depth (+ ,depth 1)))
+	   (dotimes (index (min sxhash-max-len (array-total-size ,array)) hash)
+	     (sxmash hash (internal-equalp-hash
+			   (row-major-aref ,array index) ,depth)))))))
+
+); eval-when (compile eval)
+
+
+(defun internal-equalp-hash (s-expr depth)
+  (declare (type index depth) (values hash))
+  (typecase s-expr
+    ;; The pointers and immediate types.
+    (list (sxhash-list s-expr depth :equalp t))
+    (fixnum (ldb sxhash-bits-byte s-expr))
+    (character (char-code (char-upcase s-expr)))
+    (instance
+     (typecase s-expr
+       (hash-table (hash-table-equalp-hash s-expr))
+       (structure-object (structure-equalp-hash s-expr depth))
+       (t 42)))
+    ;; Other-pointer types.
+    (simple-string (vector-equalp-hash (truly-the simple-string s-expr) depth))
+    (symbol (sxhash-simple-string (symbol-name s-expr)))
+    (number
+     (etypecase s-expr
+       (integer (sxhash s-expr))
+       (float
+	(macrolet ((frob (val type)
+		     (let ((lo (coerce most-negative-fixnum type))
+			   (hi (coerce most-positive-fixnum type)))
+		       `(if (<= ,lo ,val ,hi)
+			    (multiple-value-bind (q r)
+				(truncate ,val)
+			      (if (zerop r)
+				  (sxhash q)
+				  (sxhash (coerce ,val 'long-float))))
+			    (multiple-value-bind (q r)
+				(truncate ,val)
+			      (if (zerop r)
+				  (sxhash q)
+				  (sxhash (coerce ,val 'long-float))))))))
+	  (etypecase s-expr
+	    (single-float (frob s-expr single-float))
+	    (double-float (frob s-expr double-float))
+	    #+long-float (long-float (frob s-expr long-float)))))
+       (ratio
+	(let ((float (coerce s-expr 'long-float)))
+	  (if (= float s-expr)
+	      (sxhash float)
+	      (sxhash s-expr))))
+       (complex (if (zerop (imagpart s-expr))
+		    (internal-equalp-hash (realpart s-expr) 0)
+		    (logxor (internal-equalp-hash (realpart s-expr) 0)
+			    (internal-equalp-hash (realpart s-expr) 0))))))
+    (simple-vector (vector-equalp-hash (truly-the simple-vector s-expr) depth))
+    (array (array-equalp-hash s-expr depth))
+    ;; Everything else.
+    (t 42)))
+
 
 ;;;; Dumping one as a constant.
 
diff --git a/code/hash.lisp b/code/hash.lisp
index 3e890c6d4..b4dade692 100644
--- a/code/hash.lisp
+++ b/code/hash.lisp
@@ -5,13 +5,14 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/hash.lisp,v 1.31 2000/01/13 16:54:31 dtc Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/hash.lisp,v 1.32 2000/01/13 16:55:46 dtc Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
 ;;; Hashing and hash table functions for Spice Lisp.
 ;;; Originally written by Skef Wholey.
 ;;; Everything except SXHASH rewritten by William Lott.
+;;; Equalp hashing by William Newman, Cadabra Inc, and Douglas Crosher, 2000.
 ;;;
 (in-package :common-lisp)
 
@@ -204,6 +205,9 @@
   (declare (values hash (member t nil)))
   (values (sxhash key) nil))
 
+(defun equalp-hash (key)
+  (values (internal-equalp-hash key 0) nil))
+
 
 (defun almost-primify (num)
   (declare (type index num))
@@ -244,8 +248,8 @@
 (defun make-hash-table (&key (test 'eql) (size 65) (rehash-size 1.5)
 			     (rehash-threshold 1) (weak-p nil))
   "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.
+     :TEST -- Indicates what kind of test to use.  Only EQ, EQL, EQUAL,
+       and EQUALP 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.
@@ -273,6 +277,8 @@
 	       (values 'eql #'eql #'eql-hash))
 	      ((or (eq test #'equal) (eq test 'equal))
 	       (values 'equal #'equal #'equal-hash))
+	      ((or (eq test #'equalp) (eq test 'equalp))
+	       (values 'equalp #'equalp #'equalp-hash))
 	      (t
 	       (dolist (info *hash-table-tests*
 			     (error "Unknown :TEST for MAKE-HASH-TABLE: ~S"
@@ -297,6 +303,7 @@
 	 :table vector
 	 :weak-p weak-p)))))
 
+(declaim (inline hash-table-count))
 (defun hash-table-count (hash-table)
   "Returns the number of entries in the given HASH-TABLE."
   (declare (type hash-table hash-table)
@@ -309,6 +316,7 @@
 (setf (documentation 'hash-table-rehash-threshold 'function)
       "Return the rehash-threshold HASH-TABLE was created with.")
 
+(declaim (inline hash-table-size))
 (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
@@ -831,31 +839,28 @@
 	   (sxhash-simple-string (coerce (the string ,sequence)
 					 'simple-string))))))
 
-(defmacro sxhash-list (sequence depth)
+(defmacro sxhash-list (sequence depth &key (equalp nil))
   `(if (= ,depth sxhash-max-depth)
        0
        (do ((sequence ,sequence (cdr (the list sequence)))
 	    (index 0 (1+ index))
-	    (hash 2))
+	    (hash 2)
+	    (,depth (1+ ,depth)))
 	   ((or (atom sequence) (= index sxhash-max-len)) hash)
 	 (declare (fixnum hash index))
-	 (sxmash hash (internal-sxhash (car sequence) (1+ ,depth))))))
-
+	 (sxmash hash (,(if equalp 'internal-equalp-hash 'internal-sxhash)
+			(car sequence) ,depth)))))
 
 ); eval-when (compile eval)
 
 
-(defun sxhash (s-expr)
-  "Computes a hash code for S-EXPR and returns it as an integer."
-  (internal-sxhash s-expr 0))
-
-
 (defun internal-sxhash (s-expr depth)
   (declare (type index depth) (values hash))
   (typecase s-expr
     ;; The pointers and immediate types.
     (list (sxhash-list s-expr depth))
     (fixnum (ldb sxhash-bits-byte s-expr))
+    (character (char-code (char-upcase s-expr)))
     (instance
      (if (typep s-expr 'structure-object)
 	 (internal-sxhash (class-name (layout-class (%instance-layout s-expr)))
@@ -901,6 +906,115 @@
     ;; Everything else.
     (t 42)))
 
+(defun sxhash (s-expr)
+  "Computes a hash code for S-EXPR and returns it as an integer."
+  (internal-sxhash s-expr 0))
+
+
+;;;; Equalp hash.
+
+(eval-when (compile eval)
+
+(defmacro hash-table-equalp-hash (table)
+  `(let ((hash (hash-table-count ,table)))
+     (declare (type hash hash))
+     (sxmash hash (sxhash (hash-table-test ,table)))
+     hash))
+
+(defmacro structure-equalp-hash (structure depth)
+  `(if (= ,depth sxhash-max-depth)
+       0
+       (let* ((layout (%instance-layout ,structure))
+	      (length (min (1- (layout-length layout)) sxhash-max-len))
+	      (hash (internal-sxhash (class-name (layout-class layout))
+				     depth))
+	      (,depth (+ ,depth 1)))
+	 (declare (type index length) (type hash hash))
+	 (do ((index 1 (1+ index)))
+	     ((= index length) hash)
+	   (declare (type index index))
+	   (sxmash hash (internal-equalp-hash
+			 (%instance-ref ,structure index) ,depth))))))
+
+(defmacro vector-equalp-hash (vector depth)
+  `(if (= ,depth sxhash-max-depth)
+       0
+       (let ((hash 4)
+	     (length (length ,vector)))
+	 (declare (type hash hash) (type index length))
+	 (sxmash hash length)
+	 (let ((,depth (+ ,depth 1)))
+	   (dotimes (index (min length sxhash-max-len) hash)
+	     (declare (type index index))
+	     (sxmash hash (internal-equalp-hash (aref ,vector index)
+						,depth)))))))
+
+(defmacro array-equalp-hash (array depth)
+  `(if (= ,depth sxhash-max-depth)
+       0
+       (let ((hash 4))
+	 (declare (type hash hash))
+	 (dotimes (index (min sxhash-max-len (array-rank ,array)))
+	   (sxmash hash (array-dimension ,array index)))
+	 (let ((,depth (+ ,depth 1)))
+	   (dotimes (index (min sxhash-max-len (array-total-size ,array)) hash)
+	     (sxmash hash (internal-equalp-hash
+			   (row-major-aref ,array index) ,depth)))))))
+
+); eval-when (compile eval)
+
+
+(defun internal-equalp-hash (s-expr depth)
+  (declare (type index depth) (values hash))
+  (typecase s-expr
+    ;; The pointers and immediate types.
+    (list (sxhash-list s-expr depth :equalp t))
+    (fixnum (ldb sxhash-bits-byte s-expr))
+    (character (char-code (char-upcase s-expr)))
+    (instance
+     (typecase s-expr
+       (hash-table (hash-table-equalp-hash s-expr))
+       (structure-object (structure-equalp-hash s-expr depth))
+       (t 42)))
+    ;; Other-pointer types.
+    (simple-string (vector-equalp-hash (truly-the simple-string s-expr) depth))
+    (symbol (sxhash-simple-string (symbol-name s-expr)))
+    (number
+     (etypecase s-expr
+       (integer (sxhash s-expr))
+       (float
+	(macrolet ((frob (val type)
+		     (let ((lo (coerce most-negative-fixnum type))
+			   (hi (coerce most-positive-fixnum type)))
+		       `(if (<= ,lo ,val ,hi)
+			    (multiple-value-bind (q r)
+				(truncate ,val)
+			      (if (zerop r)
+				  (sxhash q)
+				  (sxhash (coerce ,val 'long-float))))
+			    (multiple-value-bind (q r)
+				(truncate ,val)
+			      (if (zerop r)
+				  (sxhash q)
+				  (sxhash (coerce ,val 'long-float))))))))
+	  (etypecase s-expr
+	    (single-float (frob s-expr single-float))
+	    (double-float (frob s-expr double-float))
+	    #+long-float (long-float (frob s-expr long-float)))))
+       (ratio
+	(let ((float (coerce s-expr 'long-float)))
+	  (if (= float s-expr)
+	      (sxhash float)
+	      (sxhash s-expr))))
+       (complex (if (zerop (imagpart s-expr))
+		    (internal-equalp-hash (realpart s-expr) 0)
+		    (logxor (internal-equalp-hash (realpart s-expr) 0)
+			    (internal-equalp-hash (realpart s-expr) 0))))))
+    (simple-vector (vector-equalp-hash (truly-the simple-vector s-expr) depth))
+    (array (array-equalp-hash s-expr depth))
+    ;; Everything else.
+    (t 42)))
+
 
 ;;;; Dumping one as a constant.
 
-- 
GitLab