1 ;;; hashtables.scm --- The R6RS hashtables library
3 ;; Copyright (C) 2010 Free Software Foundation, Inc.
5 ;; This library is free software; you can redistribute it and/or
6 ;; modify it under the terms of the GNU Lesser General Public
7 ;; License as published by the Free Software Foundation; either
8 ;; version 3 of the License, or (at your option) any later version.
10 ;; This library is distributed in the hope that it will be useful,
11 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
12 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
13 ;; Lesser General Public License for more details.
15 ;; You should have received a copy of the GNU Lesser General Public
16 ;; License along with this library; if not, write to the Free Software
17 ;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
20 (library (rnrs hashtables (6))
21 (export make-eq-hashtable
37 hashtable-equivalence-function
38 hashtable-hash-function
45 (import (rename (only (guile) string-hash-ci
52 (string-hash-ci string-ci-hash))
53 (only (ice-9 optargs) define*)
54 (rename (only (srfi :69) make-hash-table
58 hash-table-ref/default
62 hash-table-update!/default
64 hash-table-equivalence-function
65 hash-table-hash-function
69 (hash-by-identity symbol-hash))
71 (rnrs records procedural (6)))
73 (define r6rs:hashtable
74 (make-record-type-descriptor
75 'r6rs:hashtable #f #f #t #t
76 '#((mutable wrapped-table)
77 (immutable orig-hash-function)
78 (immutable mutable))))
80 (define hashtable? (record-predicate r6rs:hashtable))
81 (define make-r6rs-hashtable
82 (record-constructor (make-record-constructor-descriptor
83 r6rs:hashtable #f #f)))
84 (define r6rs:hashtable-wrapped-table (record-accessor r6rs:hashtable 0))
85 (define r6rs:hashtable-set-wrapped-table! (record-mutator r6rs:hashtable 0))
86 (define r6rs:hashtable-orig-hash-function (record-accessor r6rs:hashtable 1))
87 (define r6rs:hashtable-mutable? (record-accessor r6rs:hashtable 2))
89 (define hashtable-mutable? r6rs:hashtable-mutable?)
91 (define hash-by-value ((@@ (srfi srfi-69) caller-with-default-size) hashv))
92 (define (wrap-hash-function proc)
93 (lambda (key capacity) (modulo (proc key) capacity)))
95 (define* (make-eq-hashtable #:optional k)
97 (if k (make-hash-table eq? hashq k) (make-hash-table eq? symbol-hash))
101 (define* (make-eqv-hashtable #:optional k)
103 (if k (make-hash-table eqv? hashv k) (make-hash-table eqv? hash-by-value))
107 (define* (make-hashtable hash-function equiv #:optional k)
108 (let ((wrapped-hash-function (wrap-hash-function hash-function)))
111 (make-hash-table equiv wrapped-hash-function k)
112 (make-hash-table equiv wrapped-hash-function))
116 (define (hashtable-size hashtable)
117 (hash-table-size (r6rs:hashtable-wrapped-table hashtable)))
119 (define (hashtable-ref hashtable key default)
120 (hash-table-ref/default
121 (r6rs:hashtable-wrapped-table hashtable) key default))
123 (define (hashtable-set! hashtable key obj)
124 (if (r6rs:hashtable-mutable? hashtable)
125 (hash-table-set! (r6rs:hashtable-wrapped-table hashtable) key obj))
128 (define (hashtable-delete! hashtable key)
129 (if (r6rs:hashtable-mutable? hashtable)
130 (hash-table-delete! (r6rs:hashtable-wrapped-table hashtable) key))
133 (define (hashtable-contains? hashtable key)
134 (hash-table-exists? (r6rs:hashtable-wrapped-table hashtable) key))
136 (define (hashtable-update! hashtable key proc default)
137 (if (r6rs:hashtable-mutable? hashtable)
138 (hash-table-update!/default
139 (r6rs:hashtable-wrapped-table hashtable) key proc default))
142 (define* (hashtable-copy hashtable #:optional mutable)
144 (hash-table-copy (r6rs:hashtable-wrapped-table hashtable))
145 (r6rs:hashtable-orig-hash-function hashtable)
148 (define* (hashtable-clear! hashtable #:optional k)
149 (if (r6rs:hashtable-mutable? hashtable)
150 (let* ((ht (r6rs:hashtable-wrapped-table hashtable))
151 (equiv (hash-table-equivalence-function ht))
152 (hash-function (r6rs:hashtable-orig-hash-function hashtable))
153 (wrapped-hash-function (wrap-hash-function hash-function)))
154 (r6rs:hashtable-set-wrapped-table!
157 (make-hash-table equiv wrapped-hash-function k)
158 (make-hash-table equiv wrapped-hash-function)))))
161 (define (hashtable-keys hashtable)
162 (list->vector (hash-table-keys (r6rs:hashtable-wrapped-table hashtable))))
164 (define (hashtable-entries hashtable)
165 (let* ((ht (r6rs:hashtable-wrapped-table hashtable))
166 (size (hash-table-size ht))
167 (keys (make-vector size))
168 (vals (make-vector size)))
169 (hash-table-fold (r6rs:hashtable-wrapped-table hashtable)
171 (vector-set! keys i k)
172 (vector-set! vals i v)
177 (define (hashtable-equivalence-function hashtable)
178 (hash-table-equivalence-function (r6rs:hashtable-wrapped-table hashtable)))
180 (define (hashtable-hash-function hashtable)
181 (r6rs:hashtable-orig-hash-function hashtable)))