diff options
author | Taylan Ulrich Bayırlı/Kammer <taylanbayirli@gmail.com> | 2016-06-21 00:34:45 +0200 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2016-06-21 09:48:36 +0200 |
commit | d545e4551dbc1c41babf5b9fd972fdeff62378a3 (patch) | |
tree | 55790355f8afac860840acafd507e6dc59549d5e /module/rnrs | |
parent | c1abe68dbc8580f677388e762760348ea24cbd89 (diff) | |
download | guile-d545e4551dbc1c41babf5b9fd972fdeff62378a3.tar.gz |
(rnrs hashtables): Hash functions of eq? and eqv? hashtables
Also pinging this thread with a (very slightly) updated patch. :-)
[2. text/x-diff; 0001-Hashtable-hash-function-returns-f-on-eq-and-eqv-tabl.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.
Diffstat (limited to 'module/rnrs')
-rw-r--r-- | module/rnrs/hashtables.scm | 22 |
1 files changed, 15 insertions, 7 deletions
diff --git a/module/rnrs/hashtables.scm b/module/rnrs/hashtables.scm index 5773eb1a8..22bae7f09 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))))) |