1 ;;; srfi-69.scm --- Basic hash tables
3 ;; Copyright (C) 2007 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 2.1 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
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.
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.
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:
36 ;; ((hash-table-hash-function (make-hash-table)) obj)
37 ;; error> Wrong number of arguments to #<primitive-procedure hash>
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.
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?
52 ;; (alist->hash-table '(("xY" . 1) ("Xy" . 2)) string-ci=?))
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))
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.
67 ;;;; Module definition & exports
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
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!
87 string-ci-hash hash-by-identity)
88 #:re-export (string-hash)
91 (cond-expand-provide (current-module) '(srfi-37))
95 ;;; The largest fixnum is in `most-positive-fixnum' in module (guile),
96 ;;; though not documented anywhere but libguile/numbers.c.
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))
104 (define hash (caller-with-default-size (@ (guile) hash)))
106 (define string-ci-hash string-hash-ci)
108 (define hash-by-identity (caller-with-default-size hashq))
110 ;;;; Reflective queries, construction, predicate
112 (define-record-type srfi-69:hash-table
113 (make-srfi-69-hash-table real-table associator size weakness
114 equivalence-function hash-function)
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))
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))))
139 (define (without-keyword-args rest-list)
140 "Answer REST-LIST with all keywords removed along with items that
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)))
146 (else (lp (cons (first rest-list) acc) (cdr rest-list))))))
148 (define (guile-ht-ctor weakness)
149 "Answer the Guile HT constructor for the given 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))))
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)))))
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))
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))))
188 (set! size (1+ size))
189 (hashx-set! hash-proc associator real-table
190 (car pair) (cdr pair))))))
192 (ht-size! result size)
195 ;;;; Accessing table items
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"))
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)
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)))
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))
228 (define (hash-table-ref/default ht key default)
229 "Lookup KEY in HT and answer the value. Answer DEFAULT if KEY isn't
231 (hashx-invoke hashx-ref ht key default))
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))
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)
246 (ht-size! ht (1- (ht-size ht)))
247 (hashx-remove! h a real-ht key))))
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))
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
262 (with-hashx-values (hash-proc associator real-table) ht
263 (let ((handle (hashx-get-handle hash-proc associator real-table key)))
265 (set-cdr! handle (modifier (cdr handle))))
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)))))))
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)))
279 ;;;; Accessing whole tables
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."
285 (hash-table-fold ht (lambda (k v ans) (1+ ans)) 0)
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)) '()))
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)) '()))
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)
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)))
307 (define (hash-table->alist ht)
308 "Return an alist for HT."
309 (hash-table-fold ht alist-cons '()))
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))
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))))
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."
326 ht (lambda (k v ign) (hash-table-set! ht k v)) #f)
329 ;;; srfi-69.scm ends here