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

diff --git a/src/runtime/hashtb.scm b/src/runtime/hashtb.scm
index abc619e15e8227b6c966f9dd4b33b5f9a0136a56..8dbe2faf1aa30f2422de1a7d032ea799ce577086 100644 (file)
--- 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