Applied, thanks :) On Tue 21 Jun 2016 00:34, [email protected] (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?= > <[email protected]> > 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"
