~ chicken-core (chicken-5) 5ddfa715e50a6bf9c117d7c3bbd17298a6d8061a

commit 5ddfa715e50a6bf9c117d7c3bbd17298a6d8061a
Author:     Peter Bex <peter.bex@xs4all.nl>
AuthorDate: Wed Feb 1 21:03:29 2012 +0100
Commit:     Peter Bex <peter.bex@xs4all.nl>
CommitDate: Wed Feb 1 21:03:29 2012 +0100

    Fix SRFI-69 bug which occurs when string-hash is used as a user-provided procedure
    Introduced by a85865154b4f8129f816722eef49fabb8ae8acc1 (hash table "backwards compatibility" fix after the randomization was added)
    Reported by Christian Kellermann

diff --git a/srfi-69.scm b/srfi-69.scm
index e55d9eb4..4b22a3cd 100644
--- a/srfi-69.scm
+++ b/srfi-69.scm
@@ -412,11 +412,15 @@
 (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_random_fixnum" most-positive-fixnum)))
-       (lambda (object bound)
-	 ;; Don't add unneccessary bounds checks for procedures known to be
-	 ;; well-behaved (these are not user-*created* functions)
-	 (user-function object bound randomization)))
+        (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)
diff --git a/tests/hash-table-tests.scm b/tests/hash-table-tests.scm
index 0a04fca5..8ab0913b 100644
--- a/tests/hash-table-tests.scm
+++ b/tests/hash-table-tests.scm
@@ -127,6 +127,14 @@
   (assert (list? alist))
   (assert (= (length alist) 3)) )
 
+(print "HT - Built-in string hash function")
+(set! ht (make-hash-table string=?))
+(hash-table-set! ht "test" 123)
+(hash-table-set! ht "one" 1)
+(assert (= 123 (hash-table-ref ht "test")))
+(assert (= 1 (hash-table-ref ht "one")))
+
+
 (set! ht (make-hash-table equal? (lambda (object bounds)
                                    (case object
                                      ((test) 0)