From: Chris Hanson <org/chris-hanson/cph>
Date: Fri, 4 Jan 2019 05:16:54 +0000 (-0500)
Subject: Tweak equality-predicate-property to accept a default-value argument.
X-Git-Tag: mit-scheme-pucked-10.1.9~3^2~38
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=f36ecd9184c30ebd51f7fc27d9690984dac6bd24;p=mit-scheme.git

Tweak equality-predicate-property to accept a default-value argument.
---

diff --git a/src/runtime/hash-table.scm b/src/runtime/hash-table.scm
index 8eaff600a..8c886bc9b 100644
--- a/src/runtime/hash-table.scm
+++ b/src/runtime/hash-table.scm
@@ -1374,14 +1374,11 @@ USA.
    (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)))
+   (set-equality-predicate-properties! int:= int:modulo #f)
+   (register-predicate! equality-predicate? 'equality-predicate)))
 
 (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))
+  (%equality-predicate-properties equality-predicate '()))
 
 (define (equality-predicate-property-names equality-predicate)
   (let loop ((keylist (equality-predicate-keylist equality-predicate)))
@@ -1389,14 +1386,25 @@ USA.
 	(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-property equality-predicate name
+				     #!optional default-value)
+  (let ((value
+	 (get-keyword-value (equality-predicate-keylist equality-predicate)
+			    name)))
+    (if (default-object? value)
+	(begin
+	  (if (default-object? default-value)
+	      (error "Equality predicate missing property" name))
+	  default-value)
+	value)))
 
 (define (equality-predicate-hasher equality-predicate)
   (equality-predicate-property equality-predicate 'hasher))
 
 (define (equality-predicate-rehash-after-gc? equality-predicate)
-  (equality-predicate-property equality-predicate 'rehash-after-gc?))
+  (equality-predicate-property equality-predicate
+			       'rehash-after-gc?
+			       #t))
 
 (define (set-equality-predicate-properties! equality-predicate hasher
 					    rehash-after-gc? . keylist)