From 2493116993074e1600672e2b6cce9c22ed100ab6 Mon Sep 17 00:00:00 2001 From: Chris Hanson 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