From 2493116993074e1600672e2b6cce9c22ed100ab6 Mon Sep 17 00:00:00 2001
From: Chris Hanson <org/chris-hanson/cph>
Date: Fri, 6 Jan 2017 13:18:40 -0800
Subject: [PATCH] Check arguments to set-equality-predicate-hasher!.
---
src/runtime/hashtb.scm | 15 ++++++++++++---
1 file changed, 12 insertions(+), 3 deletions(-)
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
--
2.25.1