bug#22446: (rnrs hashtables): Hash functions of eq? and eqv? hashtables

bug#22446: (rnrs hashtables): Hash functions of eq? and eqv? hashtables

["Taylan Ulrich Bayırlı/Kammer"]

Per R6RS, the following forms should return #f:

    (hashtable-hash-function (make-eq-hashtable))

    (hashtable-hash-function (make-eqv-hashtable))

but in Guile they return procedures.

Taylan

bug#22446: (rnrs hashtables): Hash functions of eq? and eqv? hashtables

[Taylan Ulrich Bayırlı/Kammer]

[-- Attachment #1: Type: text/plain, Size: 29 bytes --]

Here's a patch to fix this.


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: 0001-Hashtable-hash-function-returns-f-on-eq-and-eqv-tabl.patch --]
[-- Type: text/x-diff, Size: 3822 bytes --]

From a3e5a705aaea725fd751111280a27b971d8e45e3 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Taylan=20Ulrich=20Bay=C4=B1rl=C4=B1/Kammer?=
 <taylanbayirli@gmail.com>
Date: Sun, 24 Jan 2016 12:23:34 +0100
Subject: [PATCH] Hashtable-hash-function returns #f on eq and eqv tables.

* module/rnrs/hashtables.scm (r6rs:hashtable)[type]: New field.
(r6rs:hashtable-type): New procedure.
---
 module/rnrs/hashtables.scm            | 22 +++++++++++++++-------
 test-suite/tests/r6rs-hashtables.test |  6 +++++-
 2 files changed, 20 insertions(+), 8 deletions(-)

diff --git a/module/rnrs/hashtables.scm b/module/rnrs/hashtables.scm
index 5773eb1..22bae7f 100644
--- a/module/rnrs/hashtables.scm
+++ b/module/rnrs/hashtables.scm
@@ -74,8 +74,9 @@
     (make-record-type-descriptor 
      'r6rs:hashtable #f #f #t #t 
      '#((mutable wrapped-table)
-	(immutable orig-hash-function)
-	(immutable mutable))))
+        (immutable orig-hash-function)
+        (immutable mutable)
+        (immutable type))))
 
   (define hashtable? (record-predicate r6rs:hashtable))
   (define make-r6rs-hashtable 
@@ -85,6 +86,7 @@
   (define r6rs:hashtable-set-wrapped-table! (record-mutator r6rs:hashtable 0))
   (define r6rs:hashtable-orig-hash-function (record-accessor r6rs:hashtable 1))
   (define r6rs:hashtable-mutable? (record-accessor r6rs:hashtable 2))
+  (define r6rs:hashtable-type (record-accessor r6rs:hashtable 3))
 
   (define hashtable-mutable? r6rs:hashtable-mutable?)
 
@@ -96,13 +98,15 @@
     (make-r6rs-hashtable 
      (if k (make-hash-table eq? hashq k) (make-hash-table eq? symbol-hash))
      symbol-hash
-     #t))
+     #t
+     'eq))
 
   (define* (make-eqv-hashtable #:optional k)
     (make-r6rs-hashtable 
      (if k (make-hash-table eqv? hashv k) (make-hash-table eqv? hash-by-value))
      hash-by-value
-     #t))
+     #t
+     'eqv))
 
   (define* (make-hashtable hash-function equiv #:optional k)
     (let ((wrapped-hash-function (wrap-hash-function hash-function)))
@@ -111,7 +115,8 @@
 	   (make-hash-table equiv wrapped-hash-function k)
 	   (make-hash-table equiv wrapped-hash-function))
        hash-function
-       #t)))
+       #t
+       'custom)))
  
   (define (hashtable-size hashtable)
     (hash-table-size (r6rs:hashtable-wrapped-table hashtable)))
@@ -144,7 +149,8 @@
     (make-r6rs-hashtable 
      (hash-table-copy (r6rs:hashtable-wrapped-table hashtable))
      (r6rs:hashtable-orig-hash-function hashtable)
-     (and mutable #t)))
+     (and mutable #t)
+     (r6rs:hashtable-type hashtable)))
 
   (define* (hashtable-clear! hashtable #:optional k)
     (if (r6rs:hashtable-mutable? hashtable)
@@ -179,4 +185,6 @@
     (hash-table-equivalence-function (r6rs:hashtable-wrapped-table hashtable)))
 
   (define (hashtable-hash-function hashtable)
-    (r6rs:hashtable-orig-hash-function hashtable)))
+    (case (r6rs:hashtable-type hashtable)
+      ((eq eqv) #f)
+      (else (r6rs:hashtable-orig-hash-function hashtable)))))
diff --git a/test-suite/tests/r6rs-hashtables.test b/test-suite/tests/r6rs-hashtables.test
index dbf6859..5c48579 100644
--- a/test-suite/tests/r6rs-hashtables.test
+++ b/test-suite/tests/r6rs-hashtables.test
@@ -176,7 +176,11 @@
 (with-test-prefix "hashtable-hash-function"
   (pass-if "hashtable-hash-function returns hash function"
     (let ((abs-hashtable (make-hashtable abs eqv?)))
-      (eq? (hashtable-hash-function abs-hashtable) abs))))
+      (eq? (hashtable-hash-function abs-hashtable) abs)))
+  (pass-if "hashtable-hash-function returns #f on eq table"
+    (eq? #f (hashtable-hash-function (make-eq-hashtable))))
+  (pass-if "hashtable-hash-function returns hash function"
+    (eq? #f (hashtable-hash-function (make-eqv-hashtable)))))
 
 (with-test-prefix "hashtable-mutable?"
   (pass-if "hashtable-mutable? is #t on mutable hashtables"
-- 
2.6.3

bug#22446: (rnrs hashtables): Hash functions of eq? and eqv? hashtables

[Taylan Ulrich Bayırlı/Kammer]

[-- Attachment #1: Type: text/plain, Size: 68 bytes --]

Also pinging this thread with a (very slightly) updated patch. :-)


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: 0001-Hashtable-hash-function-returns-f-on-eq-and-eqv-tabl.patch --]
[-- Type: text/x-diff, Size: 3884 bytes --]

From 17599f6ce7ba0beb100e80455ff99af07333d871 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Taylan=20Ulrich=20Bay=C4=B1rl=C4=B1/Kammer?=
 <taylanbayirli@gmail.com>
Date: Tue, 21 Jun 2016 00:23:29 +0200
Subject: [PATCH] Hashtable-hash-function returns #f on eq and eqv tables.

* module/rnrs/hashtables.scm (r6rs:hashtable)[type]: New field.
(r6rs:hashtable-type): New procedure.
* test-suite/tests/r6rs-hashtables.test: Add related tests.
---
 module/rnrs/hashtables.scm            | 22 +++++++++++++++-------
 test-suite/tests/r6rs-hashtables.test |  6 +++++-
 2 files changed, 20 insertions(+), 8 deletions(-)

diff --git a/module/rnrs/hashtables.scm b/module/rnrs/hashtables.scm
index 98d2d76..08f37e2 100644
--- a/module/rnrs/hashtables.scm
+++ b/module/rnrs/hashtables.scm
@@ -74,8 +74,9 @@
     (make-record-type-descriptor 
      'r6rs:hashtable #f #f #t #t 
      '#((mutable wrapped-table)
-	(immutable orig-hash-function)
-	(immutable mutable))))
+        (immutable orig-hash-function)
+        (immutable mutable)
+        (immutable type))))
 
   (define hashtable? (record-predicate r6rs:hashtable))
   (define make-r6rs-hashtable 
@@ -85,6 +86,7 @@
   (define r6rs:hashtable-set-wrapped-table! (record-mutator r6rs:hashtable 0))
   (define r6rs:hashtable-orig-hash-function (record-accessor r6rs:hashtable 1))
   (define r6rs:hashtable-mutable? (record-accessor r6rs:hashtable 2))
+  (define r6rs:hashtable-type (record-accessor r6rs:hashtable 3))
 
   (define hashtable-mutable? r6rs:hashtable-mutable?)
 
@@ -96,13 +98,15 @@
     (make-r6rs-hashtable 
      (if k (make-hash-table eq? hashq k) (make-hash-table eq? symbol-hash))
      symbol-hash
-     #t))
+     #t
+     'eq))
 
   (define* (make-eqv-hashtable #:optional k)
     (make-r6rs-hashtable 
      (if k (make-hash-table eqv? hashv k) (make-hash-table eqv? hash-by-value))
      hash-by-value
-     #t))
+     #t
+     'eqv))
 
   (define* (make-hashtable hash-function equiv #:optional k)
     (let ((wrapped-hash-function (wrap-hash-function hash-function)))
@@ -111,7 +115,8 @@
 	   (make-hash-table equiv wrapped-hash-function k)
 	   (make-hash-table equiv wrapped-hash-function))
        hash-function
-       #t)))
+       #t
+       'custom)))
  
   (define (hashtable-size hashtable)
     (hash-table-size (r6rs:hashtable-wrapped-table hashtable)))
@@ -143,7 +148,8 @@
     (make-r6rs-hashtable 
      (hash-table-copy (r6rs:hashtable-wrapped-table hashtable))
      (r6rs:hashtable-orig-hash-function hashtable)
-     (and mutable #t)))
+     (and mutable #t)
+     (r6rs:hashtable-type hashtable)))
 
   (define* (hashtable-clear! hashtable #:optional k)
     (if (r6rs:hashtable-mutable? hashtable)
@@ -178,4 +184,6 @@
     (hash-table-equivalence-function (r6rs:hashtable-wrapped-table hashtable)))
 
   (define (hashtable-hash-function hashtable)
-    (r6rs:hashtable-orig-hash-function hashtable)))
+    (case (r6rs:hashtable-type hashtable)
+      ((eq eqv) #f)
+      (else (r6rs:hashtable-orig-hash-function hashtable)))))
diff --git a/test-suite/tests/r6rs-hashtables.test b/test-suite/tests/r6rs-hashtables.test
index c7812c5..fbc50c9 100644
--- a/test-suite/tests/r6rs-hashtables.test
+++ b/test-suite/tests/r6rs-hashtables.test
@@ -174,7 +174,11 @@
 (with-test-prefix "hashtable-hash-function"
   (pass-if "hashtable-hash-function returns hash function"
     (let ((abs-hashtable (make-hashtable abs eqv?)))
-      (eq? (hashtable-hash-function abs-hashtable) abs))))
+      (eq? (hashtable-hash-function abs-hashtable) abs)))
+  (pass-if "hashtable-hash-function returns #f on eq table"
+    (eq? #f (hashtable-hash-function (make-eq-hashtable))))
+  (pass-if "hashtable-hash-function returns #f on eqv table"
+    (eq? #f (hashtable-hash-function (make-eqv-hashtable)))))
 
 (with-test-prefix "hashtable-mutable?"
   (pass-if "hashtable-mutable? is #t on mutable hashtables"
-- 
2.8.4

bug#22446: (rnrs hashtables): Hash functions of eq? and eqv? hashtables

[Andy Wingo]

Applied, thanks :)

On Tue 21 Jun 2016 00:34, taylanbayirli@gmail.com (Taylan Ulrich "Bayırlı/Kammer") writes:

> Also pinging this thread with a (very slightly) updated patch. :-)
>
>
> From 17599f6ce7ba0beb100e80455ff99af07333d871 Mon Sep 17 00:00:00 2001
> From: =?UTF-8?q?Taylan=20Ulrich=20Bay=C4=B1rl=C4=B1/Kammer?=
>  <taylanbayirli@gmail.com>
> Date: Tue, 21 Jun 2016 00:23:29 +0200
> Subject: [PATCH] Hashtable-hash-function returns #f on eq and eqv tables.
>
> * module/rnrs/hashtables.scm (r6rs:hashtable)[type]: New field.
> (r6rs:hashtable-type): New procedure.
> * test-suite/tests/r6rs-hashtables.test: Add related tests.
> ---
>  module/rnrs/hashtables.scm            | 22 +++++++++++++++-------
>  test-suite/tests/r6rs-hashtables.test |  6 +++++-
>  2 files changed, 20 insertions(+), 8 deletions(-)
>
> diff --git a/module/rnrs/hashtables.scm b/module/rnrs/hashtables.scm
> index 98d2d76..08f37e2 100644
> --- a/module/rnrs/hashtables.scm
> +++ b/module/rnrs/hashtables.scm
> @@ -74,8 +74,9 @@
>      (make-record-type-descriptor 
>       'r6rs:hashtable #f #f #t #t 
>       '#((mutable wrapped-table)
> -	(immutable orig-hash-function)
> -	(immutable mutable))))
> +        (immutable orig-hash-function)
> +        (immutable mutable)
> +        (immutable type))))
>  
>    (define hashtable? (record-predicate r6rs:hashtable))
>    (define make-r6rs-hashtable 
> @@ -85,6 +86,7 @@
>    (define r6rs:hashtable-set-wrapped-table! (record-mutator r6rs:hashtable 0))
>    (define r6rs:hashtable-orig-hash-function (record-accessor r6rs:hashtable 1))
>    (define r6rs:hashtable-mutable? (record-accessor r6rs:hashtable 2))
> +  (define r6rs:hashtable-type (record-accessor r6rs:hashtable 3))
>  
>    (define hashtable-mutable? r6rs:hashtable-mutable?)
>  
> @@ -96,13 +98,15 @@
>      (make-r6rs-hashtable 
>       (if k (make-hash-table eq? hashq k) (make-hash-table eq? symbol-hash))
>       symbol-hash
> -     #t))
> +     #t
> +     'eq))
>  
>    (define* (make-eqv-hashtable #:optional k)
>      (make-r6rs-hashtable 
>       (if k (make-hash-table eqv? hashv k) (make-hash-table eqv? hash-by-value))
>       hash-by-value
> -     #t))
> +     #t
> +     'eqv))
>  
>    (define* (make-hashtable hash-function equiv #:optional k)
>      (let ((wrapped-hash-function (wrap-hash-function hash-function)))
> @@ -111,7 +115,8 @@
>  	   (make-hash-table equiv wrapped-hash-function k)
>  	   (make-hash-table equiv wrapped-hash-function))
>         hash-function
> -       #t)))
> +       #t
> +       'custom)))
>   
>    (define (hashtable-size hashtable)
>      (hash-table-size (r6rs:hashtable-wrapped-table hashtable)))
> @@ -143,7 +148,8 @@
>      (make-r6rs-hashtable 
>       (hash-table-copy (r6rs:hashtable-wrapped-table hashtable))
>       (r6rs:hashtable-orig-hash-function hashtable)
> -     (and mutable #t)))
> +     (and mutable #t)
> +     (r6rs:hashtable-type hashtable)))
>  
>    (define* (hashtable-clear! hashtable #:optional k)
>      (if (r6rs:hashtable-mutable? hashtable)
> @@ -178,4 +184,6 @@
>      (hash-table-equivalence-function (r6rs:hashtable-wrapped-table hashtable)))
>  
>    (define (hashtable-hash-function hashtable)
> -    (r6rs:hashtable-orig-hash-function hashtable)))
> +    (case (r6rs:hashtable-type hashtable)
> +      ((eq eqv) #f)
> +      (else (r6rs:hashtable-orig-hash-function hashtable)))))
> diff --git a/test-suite/tests/r6rs-hashtables.test b/test-suite/tests/r6rs-hashtables.test
> index c7812c5..fbc50c9 100644
> --- a/test-suite/tests/r6rs-hashtables.test
> +++ b/test-suite/tests/r6rs-hashtables.test
> @@ -174,7 +174,11 @@
>  (with-test-prefix "hashtable-hash-function"
>    (pass-if "hashtable-hash-function returns hash function"
>      (let ((abs-hashtable (make-hashtable abs eqv?)))
> -      (eq? (hashtable-hash-function abs-hashtable) abs))))
> +      (eq? (hashtable-hash-function abs-hashtable) abs)))
> +  (pass-if "hashtable-hash-function returns #f on eq table"
> +    (eq? #f (hashtable-hash-function (make-eq-hashtable))))
> +  (pass-if "hashtable-hash-function returns #f on eqv table"
> +    (eq? #f (hashtable-hash-function (make-eqv-hashtable)))))
>  
>  (with-test-prefix "hashtable-mutable?"
>    (pass-if "hashtable-mutable? is #t on mutable hashtables"