From: Chris Hanson <org/chris-hanson/cph>
Date: Fri, 6 Jan 2017 21:18:40 +0000 (-0800)
Subject: Check arguments to set-equality-predicate-hasher!.
X-Git-Tag: mit-scheme-pucked-9.2.12~227^2~203
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=2493116993074e1600672e2b6cce9c22ed100ab6;p=mit-scheme.git

Check arguments to set-equality-predicate-hasher!.
---

diff --git a/src/runtime/hashtb.scm b/src/runtime/hashtb.scm
index abc619e15..8dbe2faf1 100644
--- a/src/runtime/hashtb.scm
+++ b/src/runtime/hashtb.scm
@@ -1388,13 +1388,13 @@ USA.
 
 (define equality-predicate?)
 (define maybe-get-equality-predicate-hasher)
-(define set-equality-predicate-hasher!)
+(define %set-equality-predicate-hasher!)
 (add-boot-init!
  (lambda ()
    (let ((table (make-hashed-metadata-table)))
      (set! equality-predicate? (table 'has?))
      (set! maybe-get-equality-predicate-hasher (table 'get-if-available))
-     (set! set-equality-predicate-hasher! (table 'put!)))
+     (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)))
@@ -1405,4 +1405,13 @@ USA.
         (error:not-a equality-predicate?
 		     equality-predicate
 		     'equality-predicate-hasher))
-    hasher))
\ No newline at end of file
+    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))
+
+(define (hasher? object)
+  (procedure-of-arity? object (make-procedure-arity 1 2)))
\ No newline at end of file