mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-04-29 19:30:36 +02:00
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.
190 lines
6.3 KiB
Scheme
190 lines
6.3 KiB
Scheme
;;; hashtables.scm --- The R6RS hashtables library
|
||
|
||
;; Copyright (C) 2010 Free Software Foundation, Inc.
|
||
;;
|
||
;; This library is free software; you can redistribute it and/or
|
||
;; modify it under the terms of the GNU Lesser General Public
|
||
;; License as published by the Free Software Foundation; either
|
||
;; version 3 of the License, or (at your option) any later version.
|
||
;;
|
||
;; This library is distributed in the hope that it will be useful,
|
||
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
||
;; Lesser General Public License for more details.
|
||
;;
|
||
;; You should have received a copy of the GNU Lesser General Public
|
||
;; License along with this library; if not, write to the Free Software
|
||
;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
|
||
|
||
|
||
(library (rnrs hashtables (6))
|
||
(export make-eq-hashtable
|
||
make-eqv-hashtable
|
||
make-hashtable
|
||
|
||
hashtable?
|
||
hashtable-size
|
||
hashtable-ref
|
||
hashtable-set!
|
||
hashtable-delete!
|
||
hashtable-contains?
|
||
hashtable-update!
|
||
hashtable-copy
|
||
hashtable-clear!
|
||
hashtable-keys
|
||
hashtable-entries
|
||
|
||
hashtable-equivalence-function
|
||
hashtable-hash-function
|
||
hashtable-mutable?
|
||
|
||
equal-hash
|
||
string-hash
|
||
string-ci-hash
|
||
symbol-hash)
|
||
(import (rename (only (guile) string-hash-ci
|
||
string-hash
|
||
hashq
|
||
hashv
|
||
modulo
|
||
*unspecified*
|
||
@@)
|
||
(string-hash-ci string-ci-hash))
|
||
(only (ice-9 optargs) define*)
|
||
(rename (only (srfi :69) make-hash-table
|
||
hash
|
||
hash-by-identity
|
||
hash-table-size
|
||
hash-table-ref/default
|
||
hash-table-set!
|
||
hash-table-delete!
|
||
hash-table-exists?
|
||
hash-table-update!/default
|
||
hash-table-copy
|
||
hash-table-equivalence-function
|
||
hash-table-hash-function
|
||
hash-table-keys
|
||
hash-table-fold)
|
||
(hash equal-hash)
|
||
(hash-by-identity symbol-hash))
|
||
(rnrs base (6))
|
||
(rnrs records procedural (6)))
|
||
|
||
(define r6rs:hashtable
|
||
(make-record-type-descriptor
|
||
'r6rs:hashtable #f #f #t #t
|
||
'#((mutable wrapped-table)
|
||
(immutable orig-hash-function)
|
||
(immutable mutable)
|
||
(immutable type))))
|
||
|
||
(define hashtable? (record-predicate r6rs:hashtable))
|
||
(define make-r6rs-hashtable
|
||
(record-constructor (make-record-constructor-descriptor
|
||
r6rs:hashtable #f #f)))
|
||
(define r6rs:hashtable-wrapped-table (record-accessor r6rs:hashtable 0))
|
||
(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?)
|
||
|
||
(define hash-by-value ((@@ (srfi srfi-69) caller-with-default-size) hashv))
|
||
(define (wrap-hash-function proc)
|
||
(lambda (key capacity) (modulo (proc key) capacity)))
|
||
|
||
(define* (make-eq-hashtable #:optional k)
|
||
(make-r6rs-hashtable
|
||
(if k (make-hash-table eq? hashq k) (make-hash-table eq? symbol-hash))
|
||
symbol-hash
|
||
#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
|
||
'eqv))
|
||
|
||
(define* (make-hashtable hash-function equiv #:optional k)
|
||
(let ((wrapped-hash-function (wrap-hash-function hash-function)))
|
||
(make-r6rs-hashtable
|
||
(if k
|
||
(make-hash-table equiv wrapped-hash-function k)
|
||
(make-hash-table equiv wrapped-hash-function))
|
||
hash-function
|
||
#t
|
||
'custom)))
|
||
|
||
(define (hashtable-size hashtable)
|
||
(hash-table-size (r6rs:hashtable-wrapped-table hashtable)))
|
||
|
||
(define (hashtable-ref hashtable key default)
|
||
(hash-table-ref/default
|
||
(r6rs:hashtable-wrapped-table hashtable) key default))
|
||
|
||
(define (hashtable-set! hashtable key obj)
|
||
(if (r6rs:hashtable-mutable? hashtable)
|
||
(hash-table-set! (r6rs:hashtable-wrapped-table hashtable) key obj)
|
||
(assertion-violation
|
||
'hashtable-set! "Hashtable is immutable." hashtable)))
|
||
|
||
(define (hashtable-delete! hashtable key)
|
||
(if (r6rs:hashtable-mutable? hashtable)
|
||
(hash-table-delete! (r6rs:hashtable-wrapped-table hashtable) key))
|
||
*unspecified*)
|
||
|
||
(define (hashtable-contains? hashtable key)
|
||
(hash-table-exists? (r6rs:hashtable-wrapped-table hashtable) key))
|
||
|
||
(define (hashtable-update! hashtable key proc default)
|
||
(if (r6rs:hashtable-mutable? hashtable)
|
||
(hash-table-update!/default
|
||
(r6rs:hashtable-wrapped-table hashtable) key proc default))
|
||
*unspecified*)
|
||
|
||
(define* (hashtable-copy hashtable #:optional mutable)
|
||
(make-r6rs-hashtable
|
||
(hash-table-copy (r6rs:hashtable-wrapped-table hashtable))
|
||
(r6rs:hashtable-orig-hash-function hashtable)
|
||
(and mutable #t)
|
||
(r6rs:hashtable-type hashtable)))
|
||
|
||
(define* (hashtable-clear! hashtable #:optional k)
|
||
(if (r6rs:hashtable-mutable? hashtable)
|
||
(let* ((ht (r6rs:hashtable-wrapped-table hashtable))
|
||
(equiv (hash-table-equivalence-function ht))
|
||
(hash-function (r6rs:hashtable-orig-hash-function hashtable))
|
||
(wrapped-hash-function (wrap-hash-function hash-function)))
|
||
(r6rs:hashtable-set-wrapped-table!
|
||
hashtable
|
||
(if k
|
||
(make-hash-table equiv wrapped-hash-function k)
|
||
(make-hash-table equiv wrapped-hash-function)))))
|
||
*unspecified*)
|
||
|
||
(define (hashtable-keys hashtable)
|
||
(list->vector (hash-table-keys (r6rs:hashtable-wrapped-table hashtable))))
|
||
|
||
(define (hashtable-entries hashtable)
|
||
(let* ((ht (r6rs:hashtable-wrapped-table hashtable))
|
||
(size (hash-table-size ht))
|
||
(keys (make-vector size))
|
||
(vals (make-vector size)))
|
||
(hash-table-fold (r6rs:hashtable-wrapped-table hashtable)
|
||
(lambda (k v i)
|
||
(vector-set! keys i k)
|
||
(vector-set! vals i v)
|
||
(+ i 1))
|
||
0)
|
||
(values keys vals)))
|
||
|
||
(define (hashtable-equivalence-function hashtable)
|
||
(hash-table-equivalence-function (r6rs:hashtable-wrapped-table hashtable)))
|
||
|
||
(define (hashtable-hash-function hashtable)
|
||
(case (r6rs:hashtable-type hashtable)
|
||
((eq eqv) #f)
|
||
(else (r6rs:hashtable-orig-hash-function hashtable)))))
|