summaryrefslogtreecommitdiff
path: root/module/rnrs
diff options
context:
space:
mode:
authorTaylan Ulrich Bayırlı/Kammer <taylanbayirli@gmail.com>2016-06-21 00:34:45 +0200
committerAndy Wingo <wingo@pobox.com>2016-06-21 09:48:36 +0200
commitd545e4551dbc1c41babf5b9fd972fdeff62378a3 (patch)
tree55790355f8afac860840acafd507e6dc59549d5e /module/rnrs
parentc1abe68dbc8580f677388e762760348ea24cbd89 (diff)
downloadguile-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.scm22
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)))))