Commit | Line | Data |
---|---|---|
2ae87f26 LC |
1 | ;;; srfi-69.scm --- Basic hash tables |
2 | ||
3 | ;; Copyright (C) 2007 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 2.1 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 | ;;;; Commentary: | |
20 | ||
21 | ;; My `hash' is compatible with core `hash', so I replace it. | |
22 | ;; However, my `hash-table?' and `make-hash-table' are different, so | |
23 | ;; importing this module will warn about them. If you don't rename my | |
24 | ;; imports, you shouldn't use both my hash tables and Guile's hash | |
25 | ;; tables in the same module. | |
26 | ;; | |
27 | ;; SRFI-13 `string-hash' and `string-hash-ci' have more arguments, but | |
28 | ;; are compatible with my `string-hash' and `string-ci-hash', and are | |
29 | ;; furthermore primitive in Guile, so I use them as my own. | |
30 | ;; | |
31 | ;; I also have the extension of allowing hash functions that require a | |
32 | ;; second argument to be used as the `hash-table-hash-function', and use | |
33 | ;; these in defaults to avoid an indirection in the hashx functions. The | |
34 | ;; only deviation this causes is: | |
35 | ;; | |
36 | ;; ((hash-table-hash-function (make-hash-table)) obj) | |
37 | ;; error> Wrong number of arguments to #<primitive-procedure hash> | |
38 | ;; | |
39 | ;; I don't think that SRFI 69 actually specifies that I *can't* do this, | |
40 | ;; because it only implies the signature of a hash function by way of the | |
41 | ;; named, exported hash functions. However, if this matters enough I can | |
42 | ;; add a private derivation of hash-function to the srfi-69:hash-table | |
43 | ;; record type, like associator is to equivalence-function. | |
44 | ;; | |
45 | ;; Also, outside of the issue of how weak keys and values are referenced | |
46 | ;; outside the table, I always interpret key equivalence to be that of | |
47 | ;; the `hash-table-equivalence-function'. For example, given the | |
48 | ;; requirement that `alist->hash-table' give earlier associations | |
49 | ;; priority, what should these answer? | |
50 | ;; | |
51 | ;; (hash-table-keys | |
52 | ;; (alist->hash-table '(("xY" . 1) ("Xy" . 2)) string-ci=?)) | |
53 | ;; | |
54 | ;; (let ((ht (make-hash-table string-ci=?))) | |
55 | ;; (hash-table-set! ht "xY" 2) | |
56 | ;; (hash-table-set! ht "Xy" 1) | |
57 | ;; (hash-table-keys ht)) | |
58 | ;; | |
59 | ;; My interpretation is that they can answer either ("Xy") or ("xY"), | |
60 | ;; where `hash-table-values' will of course always answer (1), because | |
61 | ;; the keys are the same according to the equivalence function. In this | |
62 | ;; implementation, both answer ("xY"). However, I don't guarantee that | |
63 | ;; this won't change in the future. | |
64 | ||
65 | ;;; Code: | |
66 | \f | |
67 | ;;;; Module definition & exports | |
68 | ||
69 | (define-module (srfi srfi-69) | |
70 | #:use-module (srfi srfi-1) ;alist-cons,second&c,assoc | |
71 | #:use-module (srfi srfi-9) | |
72 | #:use-module (srfi srfi-13) ;string-hash,string-hash-ci | |
73 | #:use-module (ice-9 optargs) | |
74 | #:export (;; Type constructors & predicate | |
75 | make-hash-table hash-table? alist->hash-table | |
76 | ;; Reflective queries | |
77 | hash-table-equivalence-function hash-table-hash-function | |
78 | ;; Dealing with single elements | |
79 | hash-table-ref hash-table-ref/default hash-table-set! | |
80 | hash-table-delete! hash-table-exists? hash-table-update! | |
81 | hash-table-update!/default | |
82 | ;; Dealing with the whole contents | |
83 | hash-table-size hash-table-keys hash-table-values | |
84 | hash-table-walk hash-table-fold hash-table->alist | |
85 | hash-table-copy hash-table-merge! | |
86 | ;; Hashing | |
87 | string-ci-hash hash-by-identity) | |
88 | #:re-export (string-hash) | |
89 | #:replace (hash)) | |
90 | ||
91 | (cond-expand-provide (current-module) '(srfi-37)) | |
92 | \f | |
93 | ;;;; Hashing | |
94 | ||
95 | ;;; The largest fixnum is in `most-positive-fixnum' in module (guile), | |
96 | ;;; though not documented anywhere but libguile/numbers.c. | |
97 | ||
98 | (define (caller-with-default-size hash-fn) | |
99 | "Answer a function that makes `most-positive-fixnum' the default | |
100 | second argument to HASH-FN, a 2-arg procedure." | |
101 | (lambda* (obj #:optional (size most-positive-fixnum)) | |
102 | (hash-fn obj size))) | |
103 | ||
104 | (define hash (caller-with-default-size (@ (guile) hash))) | |
105 | ||
106 | (define string-ci-hash string-hash-ci) | |
107 | ||
108 | (define hash-by-identity (caller-with-default-size hashq)) | |
109 | \f | |
110 | ;;;; Reflective queries, construction, predicate | |
111 | ||
112 | (define-record-type srfi-69:hash-table | |
113 | (make-srfi-69-hash-table real-table associator size weakness | |
114 | equivalence-function hash-function) | |
115 | hash-table? | |
116 | (real-table ht-real-table) | |
117 | (associator ht-associator) | |
118 | ;; required for O(1) by SRFI-69. It really makes a mess of things, | |
119 | ;; and I'd like to compute it in O(n) and memoize it because it | |
120 | ;; doesn't seem terribly useful, but SRFI-69 is final. | |
121 | (size ht-size ht-size!) | |
122 | ;; required for `hash-table-copy' | |
123 | (weakness ht-weakness) | |
124 | ;; used only to implement hash-table-equivalence-function; I don't | |
125 | ;; use it internally other than for `ht-associator'. | |
126 | (equivalence-function hash-table-equivalence-function) | |
127 | (hash-function hash-table-hash-function)) | |
128 | ||
129 | (define (guess-hash-function equal-proc) | |
130 | "Guess a hash function for EQUAL-PROC, falling back on `hash', as | |
131 | specified in SRFI-69 for `make-hash-table'." | |
132 | (cond ((eq? equal? equal-proc) (@ (guile) hash)) ;shortcut most common case | |
133 | ((eq? eq? equal-proc) hashq) | |
134 | ((eq? eqv? equal-proc) hashv) | |
135 | ((eq? string=? equal-proc) string-hash) | |
136 | ((eq? string-ci=? equal-proc) string-ci-hash) | |
137 | (else (@ (guile) hash)))) | |
138 | ||
139 | (define (without-keyword-args rest-list) | |
140 | "Answer REST-LIST with all keywords removed along with items that | |
141 | follow them." | |
142 | (let lp ((acc '()) (rest-list rest-list)) | |
143 | (cond ((null? rest-list) (reverse! acc)) | |
144 | ((keyword? (first rest-list)) | |
145 | (lp acc (cddr rest-list))) | |
70a44044 | 146 | (else (lp (cons (first rest-list) acc) (cdr rest-list)))))) |
2ae87f26 LC |
147 | |
148 | (define (guile-ht-ctor weakness) | |
149 | "Answer the Guile HT constructor for the given WEAKNESS." | |
150 | (case weakness | |
151 | ((#f) (@ (guile) make-hash-table)) | |
152 | ((key) make-weak-key-hash-table) | |
153 | ((value) make-weak-value-hash-table) | |
154 | ((key-or-value) make-doubly-weak-hash-table) | |
155 | (else (error "Invalid weak hash table type" weakness)))) | |
156 | ||
157 | (define (equivalence-proc->associator equal-proc) | |
158 | "Answer an `assoc'-like procedure that compares the argument key to | |
159 | alist keys with EQUAL-PROC." | |
160 | (cond ((or (eq? equal? equal-proc) | |
161 | (eq? string=? equal-proc)) (@ (guile) assoc)) | |
162 | ((eq? eq? equal-proc) assq) | |
163 | ((eq? eqv? equal-proc) assv) | |
164 | (else (lambda (item alist) | |
165 | (assoc item alist equal-proc))))) | |
166 | ||
167 | (define* (make-hash-table | |
168 | #:optional (equal-proc equal?) | |
169 | (hash-proc (guess-hash-function equal-proc)) | |
170 | #:key (weak #f) #:rest guile-opts) | |
171 | "Answer a new hash table using EQUAL-PROC as the comparison | |
172 | function, and HASH-PROC as the hash function. See the reference | |
173 | manual for specifics, of which there are many." | |
174 | (make-srfi-69-hash-table | |
175 | (apply (guile-ht-ctor weak) (without-keyword-args guile-opts)) | |
176 | (equivalence-proc->associator equal-proc) | |
177 | 0 weak equal-proc hash-proc)) | |
178 | ||
179 | (define (alist->hash-table alist . mht-args) | |
180 | "Convert ALIST to a hash table created with MHT-ARGS." | |
181 | (let* ((result (apply make-hash-table mht-args)) | |
182 | (size (ht-size result))) | |
183 | (with-hashx-values (hash-proc associator real-table) result | |
184 | (for-each (lambda (pair) | |
185 | (let ((handle (hashx-get-handle hash-proc associator | |
186 | real-table (car pair)))) | |
187 | (cond ((not handle) | |
188 | (set! size (1+ size)) | |
189 | (hashx-set! hash-proc associator real-table | |
190 | (car pair) (cdr pair)))))) | |
191 | alist)) | |
192 | (ht-size! result size) | |
193 | result)) | |
194 | \f | |
195 | ;;;; Accessing table items | |
196 | ||
197 | ;; We use this to denote missing or unspecified values to avoid | |
198 | ;; possible collision with *unspecified*. | |
199 | (define ht-unspecified (cons *unspecified* "ht-value")) | |
200 | ||
201 | ;; I am a macro only for efficiency, to avoid varargs/apply. | |
202 | (define-macro (hashx-invoke hashx-proc ht-var . args) | |
203 | "Invoke HASHX-PROC, a `hashx-*' procedure taking a hash-function, | |
204 | assoc-function, and the hash-table as first args." | |
205 | `(,hashx-proc (hash-table-hash-function ,ht-var) | |
206 | (ht-associator ,ht-var) | |
207 | (ht-real-table ,ht-var) | |
208 | . ,args)) | |
209 | ||
210 | (define-macro (with-hashx-values bindings ht-var . body-forms) | |
211 | "Bind BINDINGS to the hash-function, associator, and real-table of | |
212 | HT-VAR, while evaluating BODY-FORMS." | |
213 | `(let ((,(first bindings) (hash-table-hash-function ,ht-var)) | |
214 | (,(second bindings) (ht-associator ,ht-var)) | |
215 | (,(third bindings) (ht-real-table ,ht-var))) | |
216 | . ,body-forms)) | |
217 | ||
218 | (define (hash-table-ref ht key . default-thunk-lst) | |
219 | "Lookup KEY in HT and answer the value, invoke DEFAULT-THUNK if KEY | |
220 | isn't present, or signal an error if DEFAULT-THUNK isn't provided." | |
221 | (let ((result (hashx-invoke hashx-ref ht key ht-unspecified))) | |
222 | (if (eq? ht-unspecified result) | |
223 | (if (pair? default-thunk-lst) | |
224 | ((first default-thunk-lst)) | |
225 | (error "Key not in table" key ht)) | |
226 | result))) | |
227 | ||
228 | (define (hash-table-ref/default ht key default) | |
229 | "Lookup KEY in HT and answer the value. Answer DEFAULT if KEY isn't | |
230 | present." | |
231 | (hashx-invoke hashx-ref ht key default)) | |
232 | ||
233 | (define (hash-table-set! ht key new-value) | |
234 | "Set KEY to NEW-VALUE in HT." | |
235 | (let ((handle (hashx-invoke hashx-create-handle! ht key ht-unspecified))) | |
236 | (if (eq? ht-unspecified (cdr handle)) | |
237 | (ht-size! ht (1+ (ht-size ht)))) | |
238 | (set-cdr! handle new-value)) | |
239 | *unspecified*) | |
240 | ||
241 | (define (hash-table-delete! ht key) | |
242 | "Remove KEY's association in HT." | |
243 | (with-hashx-values (h a real-ht) ht | |
244 | (if (hashx-get-handle h a real-ht key) | |
245 | (begin | |
246 | (ht-size! ht (1- (ht-size ht))) | |
247 | (hashx-remove! h a real-ht key)))) | |
248 | *unspecified*) | |
249 | ||
250 | (define (hash-table-exists? ht key) | |
251 | "Return whether KEY is a key in HT." | |
252 | (and (hashx-invoke hashx-get-handle ht key) #t)) | |
253 | ||
254 | ;;; `hashx-set!' duplicates the hash lookup, but we use it anyway to | |
255 | ;;; avoid creating a handle in case DEFAULT-THUNK exits | |
256 | ;;; `hash-table-update!' non-locally. | |
257 | (define (hash-table-update! ht key modifier . default-thunk-lst) | |
258 | "Modify HT's value at KEY by passing its value to MODIFIER and | |
259 | setting it to the result thereof. Invoke DEFAULT-THUNK for the old | |
260 | value if KEY isn't in HT, or signal an error if DEFAULT-THUNK is not | |
261 | provided." | |
262 | (with-hashx-values (hash-proc associator real-table) ht | |
263 | (let ((handle (hashx-get-handle hash-proc associator real-table key))) | |
264 | (cond (handle | |
265 | (set-cdr! handle (modifier (cdr handle)))) | |
266 | (else | |
267 | (hashx-set! hash-proc associator real-table key | |
268 | (if (pair? default-thunk-lst) | |
269 | (modifier ((car default-thunk-lst))) | |
270 | (error "Key not in table" key ht))) | |
271 | (ht-size! ht (1+ (ht-size ht))))))) | |
272 | *unspecified*) | |
273 | ||
274 | (define (hash-table-update!/default ht key modifier default) | |
275 | "Modify HT's value at KEY by passing its old value, or DEFAULT if it | |
276 | doesn't have one, to MODIFIER, and setting it to the result thereof." | |
277 | (hash-table-update! ht key modifier (lambda () default))) | |
278 | \f | |
279 | ;;;; Accessing whole tables | |
280 | ||
281 | (define (hash-table-size ht) | |
282 | "Return the number of associations in HT. This is guaranteed O(1) | |
283 | for tables where #:weak was #f or not specified at creation time." | |
284 | (if (ht-weakness ht) | |
285 | (hash-table-fold ht (lambda (k v ans) (1+ ans)) 0) | |
286 | (ht-size ht))) | |
287 | ||
288 | (define (hash-table-keys ht) | |
289 | "Return a list of the keys in HT." | |
290 | (hash-table-fold ht (lambda (k v lst) (cons k lst)) '())) | |
291 | ||
292 | (define (hash-table-values ht) | |
293 | "Return a list of the values in HT." | |
294 | (hash-table-fold ht (lambda (k v lst) (cons v lst)) '())) | |
295 | ||
296 | (define (hash-table-walk ht proc) | |
297 | "Call PROC with each key and value as two arguments." | |
298 | (hash-table-fold ht (lambda (k v unspec) (proc k v) unspec) | |
299 | *unspecified*)) | |
300 | ||
301 | (define (hash-table-fold ht f knil) | |
302 | "Invoke (F KEY VAL PREV) for each KEY and VAL in HT, where PREV is | |
303 | the result of the previous invocation, using KNIL as the first PREV. | |
304 | Answer the final F result." | |
305 | (hash-fold f knil (ht-real-table ht))) | |
306 | ||
307 | (define (hash-table->alist ht) | |
308 | "Return an alist for HT." | |
309 | (hash-table-fold ht alist-cons '())) | |
310 | ||
311 | (define (hash-table-copy ht) | |
312 | "Answer a copy of HT." | |
313 | (with-hashx-values (h a real-ht) ht | |
314 | (let* ((size (hash-table-size ht)) (weak (ht-weakness ht)) | |
315 | (new-real-ht ((guile-ht-ctor weak) size))) | |
316 | (hash-fold (lambda (k v ign) (hashx-set! h a new-real-ht k v)) | |
317 | #f real-ht) | |
318 | (make-srfi-69-hash-table ;real,assoc,size,weak,equiv,h | |
319 | new-real-ht a size weak | |
320 | (hash-table-equivalence-function ht) h)))) | |
321 | ||
322 | (define (hash-table-merge! ht other-ht) | |
323 | "Add all key/value pairs from OTHER-HT to HT, overriding HT's | |
324 | mappings where present. Return HT." | |
325 | (hash-table-fold | |
326 | ht (lambda (k v ign) (hash-table-set! ht k v)) #f) | |
327 | ht) | |
328 | ||
329 | ;;; srfi-69.scm ends here |