~ chicken-core (chicken-5) c948b4baf8a159fa9c033fcd3512dd8fd31c391d

commit c948b4baf8a159fa9c033fcd3512dd8fd31c391d
Author:     Jim Ursetto <zbigniewsz@gmail.com>
AuthorDate: Wed Apr 18 18:28:11 2012 -0500
Commit:     Peter Bex <peter.bex@xs4all.nl>
CommitDate: Thu Apr 19 09:42:52 2012 +0200

    Ensure outside hash functions do not leak into srfi-69 (fixes #818)
    
    Signed-off-by: Peter Bex <peter.bex@xs4all.nl>

diff --git a/srfi-69.scm b/srfi-69.scm
index 99025a21..122e8cdb 100644
--- a/srfi-69.scm
+++ b/srfi-69.scm
@@ -410,26 +410,30 @@
 	  cur
 	  (loop nxt) ) ) ) )
 
-(define (*make-hash-function user-function)
-  (if (memq user-function (list eq?-hash eqv?-hash equal?-hash hash
-				string-hash string-hash-ci number-hash))
-      ;; Don't add unneccessary bounds checks for procedures known to be
-      ;; well-behaved (these are not user-*created* functions)
-      (let ((randomization (##core#inline "C_rnd_fix")))
-        (if (memq user-function (list string-hash string-hash-ci))
-            ;; String functions have differing signatures; treat them specially
-            (lambda (object bound)
-              (user-function object bound #f #f randomization))
-            (lambda (object bound)
-              (user-function object bound randomization))))
-      (lambda (object bound)
-	(let ((hash (user-function object bound)))
-	  (##sys#check-exact hash 'hash user-function)
-	  (if (and (fx< hash bound) (fx>= hash 0))
-	      hash
-	      (##sys#signal-hook 
-	       #:bounds-error 'hash
-	       "Hash value out of bounds" bound hash user-function) )))))
+(define *make-hash-function
+  (let ((eq?-hash eq?-hash) (eqv?-hash eqv?-hash) (equal?-hash equal?-hash)
+	(hash hash) (string-hash string-hash) (string-hash-ci string-hash-ci)
+	(number-hash number-hash))
+    (lambda (user-function)
+      (if (memq user-function (list eq?-hash eqv?-hash equal?-hash hash
+				    string-hash string-hash-ci number-hash))
+	  ;; Don't add unnecessary bounds checks for procedures known to be
+	  ;; well-behaved (these are not user-*created* functions)
+	  (let ((randomization (##core#inline "C_rnd_fix")))
+	    (if (memq user-function (list string-hash string-hash-ci))
+		;; String functions have differing signatures; treat them specially
+		(lambda (object bound)
+		  (user-function object bound #f #f randomization))
+		(lambda (object bound)
+		  (user-function object bound randomization))))
+	  (lambda (object bound)
+	    (let ((hash (user-function object bound)))
+	      (##sys#check-exact hash 'hash user-function)
+	      (if (and (fx< hash bound) (fx>= hash 0))
+		  hash
+		  (##sys#signal-hook 
+		   #:bounds-error 'hash
+		   "Hash value out of bounds" bound hash user-function) )))))))
 
 ;; "Raw" make-hash-table:
 
@@ -462,7 +466,10 @@
 	[core-equal? equal?]
 	[core-string=? string=?]
 	[core-string-ci=? string-ci=?]
-	[core= =] )
+	[core= =]
+	(eq?-hash eq?-hash) (eqv?-hash eqv?-hash) (equal?-hash equal?-hash)
+	(hash hash) (string-hash string-hash) (string-hash-ci string-hash-ci)
+	(number-hash number-hash))
     (lambda arguments0
       (let ([arguments arguments0]
 	    [test equal?]