From c9ef69744bb153ac62958d19e8cbe23bc9510544 Mon Sep 17 00:00:00 2001
From: Chris Hanson <org/chris-hanson/cph>
Date: Mon, 23 Apr 2018 23:19:40 -0700
Subject: [PATCH] Rename set-equality-predicate-hasher! ->
 set-equality-predicate-properties!.

Now has two required arguments: hash-function and rehash-after-gc?.
A rest argument is a keyword list for additional properties.
---
 src/runtime/hash-table.scm | 63 ++++++++++++++++++++++++--------------
 src/runtime/memoizer.scm   | 10 ++++--
 src/runtime/runtime.pkg    |  5 ++-
 3 files changed, 52 insertions(+), 26 deletions(-)

diff --git a/src/runtime/hash-table.scm b/src/runtime/hash-table.scm
index 7bc04bae9..05afcc353 100644
--- a/src/runtime/hash-table.scm
+++ b/src/runtime/hash-table.scm
@@ -1403,33 +1403,50 @@ USA.
   (list 'default-marker))
 
 (define equality-predicate?)
-(define get-equality-predicate-hasher)
-(define %set-equality-predicate-hasher!)
+(define %equality-predicate-properties)
+(define %set-equality-predicate-properties!)
 (add-boot-init!
  (lambda ()
    (let ((table (make-hashed-metadata-table)))
      (set! equality-predicate? (table 'has?))
-     (set! get-equality-predicate-hasher (table 'get))
-     (set! %set-equality-predicate-hasher! (table 'put!)))
-   (set-equality-predicate-hasher! eq? hash-by-identity)
-   (set-equality-predicate-hasher! eqv? hash-by-eqv)
-   (set-equality-predicate-hasher! equal? hash-by-equal)
-   (set-equality-predicate-hasher! string=? string-hash)
-   (set-equality-predicate-hasher! string-ci=? string-ci-hash)))
+     (set! %equality-predicate-properties (table 'get))
+     (set! %set-equality-predicate-properties! (table 'put!)))
+   (set-equality-predicate-properties! eq? hash-by-identity #t)
+   (set-equality-predicate-properties! eqv? hash-by-eqv #t)
+   (set-equality-predicate-properties! equal? hash-by-equal #t)
+   (set-equality-predicate-properties! string=? string-hash #f)
+   (set-equality-predicate-properties! string-ci=? string-ci-hash #f)
+   (set-equality-predicate-properties! int:= int:modulo #f)))
+
+(define (equality-predicate-keylist equality-predicate)
+  (let ((props (%equality-predicate-properties equality-predicate #f)))
+    (if (not props)
+        (error:not-a equality-predicate? equality-predicate
+		     'equality-predicate-keylist))
+    props))
+
+(define (equality-predicate-property-names equality-predicate)
+  (let loop ((keylist (equality-predicate-keylist equality-predicate)))
+    (if (pair? keylist)
+	(cons (car keylist) (loop (cddr keylist)))
+	'())))
+
+(define (equality-predicate-property equality-predicate name)
+  (get-keyword-value (equality-predicate-keylist equality-predicate) name))
 
 (define (equality-predicate-hasher equality-predicate)
-  (let ((hasher (get-equality-predicate-hasher equality-predicate #f)))
-    (if (not hasher)
-        (error:not-a equality-predicate?
-		     equality-predicate
-		     'equality-predicate-hasher))
-    hasher))
-
-(define (set-equality-predicate-hasher! equality-predicate hasher)
-  (guarantee binary-procedure? equality-predicate
-	     'set-equality-predicate-hasher!)
-  (guarantee hasher? hasher 'set-equality-predicate-hasher!)
-  (%set-equality-predicate-hasher! equality-predicate hasher))
+  (equality-predicate-property equality-predicate 'hasher))
+
+(define (equality-predicate-rehash-after-gc? equality-predicate)
+  (equality-predicate-property equality-predicate 'rehash-after-gc?))
 
-(define (hasher? object)
-  (procedure-of-arity? object (make-procedure-arity 1 2)))
\ No newline at end of file
+(define (set-equality-predicate-properties! equality-predicate hasher
+					    rehash-after-gc? . keylist)
+  (guarantee binary-procedure? equality-predicate
+	     'set-equality-predicate-properties!)
+  (guarantee binary-procedure? hasher 'set-equality-predicate-properties!)
+  (guarantee keyword-list? keylist 'set-equality-predicate-properties!)
+  (%set-equality-predicate-properties! equality-predicate
+				       (cons* 'hasher hasher
+					      'rehash-after-gc? rehash-after-gc?
+					      keylist)))
diff --git a/src/runtime/memoizer.scm b/src/runtime/memoizer.scm
index fa2a15311..f9f0445d1 100644
--- a/src/runtime/memoizer.scm
+++ b/src/runtime/memoizer.scm
@@ -96,14 +96,20 @@ USA.
   (let ((compare
          (lambda (a b)
            (list= elt= a b))))
-    (set-equality-predicate-hasher! compare (%make-list-hash elt=))
+    (set-equality-predicate-properties!
+     compare
+     (%make-list-hash elt=)
+     (equality-predicate-rehash-after-gc? elt=))
     compare))
 
 (define (make-lset= elt=)
   (let ((compare
          (lambda (a b)
            (lset= elt= a b))))
-    (set-equality-predicate-hasher! compare (%make-list-hash elt=))
+    (set-equality-predicate-properties!
+     compare
+     (%make-list-hash elt=)
+     (equality-predicate-rehash-after-gc? elt=))
     compare))
 
 (define (%make-list-hash elt=)
diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 836a03e15..7a7bd7d91 100644
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -2414,6 +2414,9 @@ USA.
 	  equal-hash-mod
 	  equal-hash-table-type
 	  equality-predicate-hasher
+	  equality-predicate-property
+	  equality-predicate-property-names
+	  equality-predicate-rehash-after-gc?
 	  equality-predicate?
 	  eqv-hash
 	  eqv-hash-mod
@@ -2471,7 +2474,7 @@ USA.
 	  make-strong-eq-hash-table
 	  make-strong-eqv-hash-table
 	  non-pointer-hash-table-type
-	  set-equality-predicate-hasher!
+	  set-equality-predicate-properties!
 	  set-hash-table-rehash-size!
 	  set-hash-table-rehash-threshold!
 	  string-hash-table-type
-- 
2.25.1