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.

diff --git a/src/runtime/hash-table.scm b/src/runtime/hash-table.scm
index 7bc04bae91ce3b39dde56f41994e71a12a1c683d..05afcc353acb3139095512b64b72398c5bec4a6b 100644 (file)
--- 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 fa2a15311650b52ca09e7b6d0a66dadee8912eb9..f9f0445d1317c8e1e13d3c05f5d2cf66fef1c336 100644 (file)
--- 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 836a03e15b71d5c698f4834f5e3c1a69d137f440..7a7bd7d91f0529537d172129f3840192a042e71b 100644 (file)
--- 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