Commit | Line | Data |
---|---|---|
f797da47 JG |
1 | ;;; hashtables.scm --- The R6RS hashtables library |
2 | ||
3 | ;; Copyright (C) 2010 Free Software Foundation, Inc. | |
4 | ;; | |
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. | |
9 | ;; | |
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. | |
14 | ;; | |
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 | |
18 | \f | |
19 | ||
20 | (library (rnrs hashtables (6)) | |
21 | (export make-eq-hashtable | |
22 | make-eqv-hashtable | |
23 | make-hashtable | |
24 | ||
25 | hashtable? | |
26 | hashtable-size | |
27 | hashtable-ref | |
28 | hashtable-set! | |
29 | hashtable-delete! | |
30 | hashtable-contains? | |
31 | hashtable-update! | |
32 | hashtable-copy | |
33 | hashtable-clear! | |
34 | hashtable-keys | |
35 | hashtable-entries | |
36 | ||
37 | hashtable-equivalence-function | |
38 | hashtable-hash-function | |
39 | hashtable-mutable? | |
40 | ||
41 | equal-hash | |
42 | string-hash | |
43 | string-ci-hash | |
44 | symbol-hash) | |
b7661092 JG |
45 | (import (rename (only (guile) string-hash-ci |
46 | string-hash | |
47 | hashq | |
3fdc1d05 JG |
48 | hashv |
49 | modulo | |
b7661092 JG |
50 | *unspecified* |
51 | @@) | |
f797da47 JG |
52 | (string-hash-ci string-ci-hash)) |
53 | (only (ice-9 optargs) define*) | |
54 | (rename (only (srfi :69) make-hash-table | |
55 | hash | |
56 | hash-by-identity | |
57 | hash-table-size | |
58 | hash-table-ref/default | |
59 | hash-table-set! | |
60 | hash-table-delete! | |
2b95784c | 61 | hash-table-exists? |
f797da47 JG |
62 | hash-table-update!/default |
63 | hash-table-copy | |
64 | hash-table-equivalence-function | |
65 | hash-table-hash-function | |
66 | hash-table-keys | |
67 | hash-table-fold) | |
68 | (hash equal-hash) | |
69 | (hash-by-identity symbol-hash)) | |
70 | (rnrs base (6)) | |
71 | (rnrs records procedural (6))) | |
72 | ||
73 | (define r6rs:hashtable | |
74 | (make-record-type-descriptor | |
75 | 'r6rs:hashtable #f #f #t #t | |
2b95784c JG |
76 | '#((mutable wrapped-table) |
77 | (immutable orig-hash-function) | |
78 | (immutable mutable)))) | |
f797da47 JG |
79 | |
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)) | |
2b95784c JG |
86 | (define r6rs:hashtable-orig-hash-function (record-accessor r6rs:hashtable 1)) |
87 | (define r6rs:hashtable-mutable? (record-accessor r6rs:hashtable 2)) | |
88 | ||
89 | (define hashtable-mutable? r6rs:hashtable-mutable?) | |
90 | ||
91 | (define hash-by-value ((@@ (srfi srfi-69) caller-with-default-size) hashv)) | |
3fdc1d05 JG |
92 | (define (wrap-hash-function proc) |
93 | (lambda (key capacity) (modulo (proc key) capacity))) | |
f797da47 JG |
94 | |
95 | (define* (make-eq-hashtable #:optional k) | |
96 | (make-r6rs-hashtable | |
2b95784c JG |
97 | (if k (make-hash-table eq? hashq k) (make-hash-table eq? symbol-hash)) |
98 | symbol-hash | |
f797da47 JG |
99 | #t)) |
100 | ||
101 | (define* (make-eqv-hashtable #:optional k) | |
102 | (make-r6rs-hashtable | |
2b95784c JG |
103 | (if k (make-hash-table eqv? hashv k) (make-hash-table eqv? hash-by-value)) |
104 | hash-by-value | |
f797da47 JG |
105 | #t)) |
106 | ||
107 | (define* (make-hashtable hash-function equiv #:optional k) | |
2b95784c JG |
108 | (let ((wrapped-hash-function (wrap-hash-function hash-function))) |
109 | (make-r6rs-hashtable | |
110 | (if k | |
111 | (make-hash-table equiv wrapped-hash-function k) | |
112 | (make-hash-table equiv wrapped-hash-function)) | |
113 | hash-function | |
114 | #t))) | |
f797da47 JG |
115 | |
116 | (define (hashtable-size hashtable) | |
117 | (hash-table-size (r6rs:hashtable-wrapped-table hashtable))) | |
118 | ||
119 | (define (hashtable-ref hashtable key default) | |
120 | (hash-table-ref/default | |
121 | (r6rs:hashtable-wrapped-table hashtable) key default)) | |
122 | ||
123 | (define (hashtable-set! hashtable key obj) | |
2b95784c | 124 | (if (r6rs:hashtable-mutable? hashtable) |
f797da47 JG |
125 | (hash-table-set! (r6rs:hashtable-wrapped-table hashtable) key obj)) |
126 | *unspecified*) | |
127 | ||
128 | (define (hashtable-delete! hashtable key) | |
2b95784c | 129 | (if (r6rs:hashtable-mutable? hashtable) |
f797da47 JG |
130 | (hash-table-delete! (r6rs:hashtable-wrapped-table hashtable) key)) |
131 | *unspecified*) | |
132 | ||
133 | (define (hashtable-contains? hashtable key) | |
134 | (hash-table-exists? (r6rs:hashtable-wrapped-table hashtable) key)) | |
135 | ||
136 | (define (hashtable-update! hashtable key proc default) | |
2b95784c | 137 | (if (r6rs:hashtable-mutable? hashtable) |
f797da47 JG |
138 | (hash-table-update!/default |
139 | (r6rs:hashtable-wrapped-table hashtable) key proc default)) | |
140 | *unspecified*) | |
141 | ||
142 | (define* (hashtable-copy hashtable #:optional mutable) | |
143 | (make-r6rs-hashtable | |
144 | (hash-table-copy (r6rs:hashtable-wrapped-table hashtable)) | |
2b95784c | 145 | (r6rs:hashtable-orig-hash-function hashtable) |
f797da47 JG |
146 | (and mutable #t))) |
147 | ||
148 | (define* (hashtable-clear! hashtable #:optional k) | |
2b95784c | 149 | (if (r6rs:hashtable-mutable? hashtable) |
f797da47 JG |
150 | (let* ((ht (r6rs:hashtable-wrapped-table hashtable)) |
151 | (equiv (hash-table-equivalence-function ht)) | |
2b95784c JG |
152 | (hash-function (r6rs:hashtable-orig-hash-function hashtable)) |
153 | (wrapped-hash-function (wrap-hash-function hash-function))) | |
f797da47 | 154 | (r6rs:hashtable-set-wrapped-table! |
2b95784c | 155 | hashtable |
f797da47 | 156 | (if k |
2b95784c JG |
157 | (make-hash-table equiv wrapped-hash-function k) |
158 | (make-hash-table equiv wrapped-hash-function))))) | |
f797da47 JG |
159 | *unspecified*) |
160 | ||
161 | (define (hashtable-keys hashtable) | |
162 | (list->vector (hash-table-keys (r6rs:hashtable-wrapped-table hashtable)))) | |
163 | ||
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) | |
170 | (lambda (k v i) | |
171 | (vector-set! keys i k) | |
172 | (vector-set! vals i v) | |
173 | (+ i 1)) | |
174 | 0) | |
175 | (values keys vals))) | |
176 | ||
177 | (define (hashtable-equivalence-function hashtable) | |
178 | (hash-table-equivalence-function (r6rs:hashtable-wrapped-table hashtable))) | |
179 | ||
180 | (define (hashtable-hash-function hashtable) | |
2b95784c | 181 | (r6rs:hashtable-orig-hash-function hashtable))) |