Commit | Line | Data |
---|---|---|
22ec6a31 LC |
1 | ;;; -*- mode: scheme; coding: utf-8; -*- |
2 | ;;; | |
228e9ec1 | 3 | ;;; Copyright (C) 2009, 2010, 2011, 2012 Free Software Foundation, Inc. |
22ec6a31 LC |
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 | ||
19 | (define-module (ice-9 vlist) | |
20 | #:use-module (srfi srfi-1) | |
21 | #:use-module (srfi srfi-9) | |
a94469c6 | 22 | #:use-module (srfi srfi-9 gnu) |
22ec6a31 | 23 | #:use-module (srfi srfi-26) |
228e9ec1 | 24 | #:use-module (ice-9 format) |
22ec6a31 LC |
25 | |
26 | #:export (vlist? vlist-cons vlist-head vlist-tail vlist-null? | |
27 | vlist-null list->vlist vlist-ref vlist-drop vlist-take | |
28 | vlist-length vlist-fold vlist-fold-right vlist-map | |
29 | vlist-unfold vlist-unfold-right vlist-append | |
30 | vlist-reverse vlist-filter vlist-delete vlist->list | |
31 | vlist-for-each | |
32 | block-growth-factor | |
33 | ||
34 | vhash? vhash-cons vhash-consq vhash-consv | |
35 | vhash-assoc vhash-assq vhash-assv | |
8bc5b79d | 36 | vhash-delete vhash-delq vhash-delv |
19301dc5 | 37 | vhash-fold vhash-fold-right |
927bf5e8 LC |
38 | vhash-fold* vhash-foldq* vhash-foldv* |
39 | alist->vhash)) | |
22ec6a31 LC |
40 | |
41 | ;;; Author: Ludovic Courtès <ludo@gnu.org> | |
42 | ;;; | |
43 | ;;; Commentary: | |
44 | ;;; | |
45 | ;;; This module provides an implementations of vlists, a functional list-like | |
46 | ;;; data structure described by Phil Bagwell in "Fast Functional Lists, | |
47 | ;;; Hash-Lists, Dequeues and Variable-Length Arrays", EPFL Technical Report, | |
48 | ;;; 2002. | |
49 | ;;; | |
50 | ;;; The idea is to store vlist elements in increasingly large contiguous blocks | |
51 | ;;; (implemented as vectors here). These blocks are linked to one another using | |
52 | ;;; a pointer to the next block (called `block-base' here) and an offset within | |
53 | ;;; that block (`block-offset' here). The size of these blocks form a geometric | |
54 | ;;; series with ratio `block-growth-factor'. | |
55 | ;;; | |
56 | ;;; In the best case (e.g., using a vlist returned by `list->vlist'), | |
57 | ;;; elements from the first half of an N-element vlist are accessed in O(1) | |
58 | ;;; (assuming `block-growth-factor' is 2), and `vlist-length' takes only | |
59 | ;;; O(ln(N)). Furthermore, the data structure improves data locality since | |
60 | ;;; vlist elements are adjacent, which plays well with caches. | |
61 | ;;; | |
62 | ;;; Code: | |
63 | ||
64 | \f | |
65 | ;;; | |
66 | ;;; VList Blocks and Block Descriptors. | |
67 | ;;; | |
68 | ||
69 | (define block-growth-factor | |
aafb4ed7 | 70 | (make-fluid 2)) |
22ec6a31 | 71 | |
299ce911 | 72 | (define-inlinable (make-block base offset size hash-tab?) |
4bd53c1b AW |
73 | ;; Return a block (and block descriptor) of SIZE elements pointing to |
74 | ;; BASE at OFFSET. If HASH-TAB? is true, we also reserve space for a | |
75 | ;; "hash table". Note: We use `next-free' instead of `last-used' as | |
76 | ;; suggested by Bagwell. | |
77 | (if hash-tab? | |
78 | (vector (make-vector (* size 3) #f) | |
79 | base offset size 0) | |
80 | (vector (make-vector size) | |
81 | base offset size 0))) | |
22ec6a31 | 82 | |
0c65f52c | 83 | (define-syntax-rule (define-block-accessor name index) |
299ce911 | 84 | (define-inlinable (name block) |
0c65f52c | 85 | (vector-ref block index))) |
22ec6a31 LC |
86 | |
87 | (define-block-accessor block-content 0) | |
88 | (define-block-accessor block-base 1) | |
89 | (define-block-accessor block-offset 2) | |
90 | (define-block-accessor block-size 3) | |
91 | (define-block-accessor block-next-free 4) | |
4bd53c1b AW |
92 | |
93 | (define-inlinable (block-hash-table? block) | |
94 | (< (block-size block) (vector-length (block-content block)))) | |
22ec6a31 | 95 | |
f6a554a6 AW |
96 | (define-inlinable (set-block-next-free! block next-free) |
97 | (vector-set! block 4 next-free)) | |
22ec6a31 | 98 | |
f6a554a6 | 99 | (define-inlinable (block-append! block value offset) |
22ec6a31 | 100 | ;; This is not thread-safe. To fix it, see Section 2.8 of the paper. |
f6a554a6 AW |
101 | (and (< offset (block-size block)) |
102 | (= offset (block-next-free block)) | |
103 | (begin | |
104 | (set-block-next-free! block (1+ offset)) | |
105 | (vector-set! (block-content block) offset value) | |
106 | #t))) | |
22ec6a31 | 107 | |
4bd53c1b AW |
108 | ;; Return the item at slot OFFSET. |
109 | (define-inlinable (block-ref content offset) | |
110 | (vector-ref content offset)) | |
111 | ||
112 | ;; Return the offset of the next item in the hash bucket, after the one | |
113 | ;; at OFFSET. | |
114 | (define-inlinable (block-hash-table-next-offset content size offset) | |
115 | (vector-ref content (+ size size offset))) | |
22ec6a31 | 116 | |
4bd53c1b AW |
117 | ;; Save the offset of the next item in the hash bucket, after the one |
118 | ;; at OFFSET. | |
119 | (define-inlinable (block-hash-table-set-next-offset! content size offset | |
120 | next-offset) | |
121 | (vector-set! content (+ size size offset) next-offset)) | |
22ec6a31 | 122 | |
4bd53c1b AW |
123 | ;; Returns the index of the last entry stored in CONTENT with |
124 | ;; SIZE-modulo hash value KHASH. | |
125 | (define-inlinable (block-hash-table-ref content size khash) | |
126 | (vector-ref content (+ size khash))) | |
22ec6a31 | 127 | |
4bd53c1b AW |
128 | (define-inlinable (block-hash-table-set! content size khash offset) |
129 | (vector-set! content (+ size khash) offset)) | |
130 | ||
131 | ;; Add hash table information for the item recently added at OFFSET, | |
132 | ;; with SIZE-modulo hash KHASH. | |
133 | (define-inlinable (block-hash-table-add! content size khash offset) | |
134 | (block-hash-table-set-next-offset! content size offset | |
135 | (block-hash-table-ref content size khash)) | |
136 | (block-hash-table-set! content size khash offset)) | |
22ec6a31 LC |
137 | |
138 | (define block-null | |
139 | ;; The null block. | |
140 | (make-block #f 0 0 #f)) | |
141 | ||
142 | \f | |
143 | ;;; | |
144 | ;;; VLists. | |
145 | ;;; | |
146 | ||
147 | (define-record-type <vlist> | |
148 | ;; A vlist is just a base+offset pair pointing to a block. | |
149 | ||
150 | ;; XXX: Allocating a <vlist> record in addition to the block at each | |
151 | ;; `vlist-cons' call is inefficient. However, Bagwell's hack to avoid it | |
152 | ;; (Section 2.2) would require GC_ALL_INTERIOR_POINTERS, which would be a | |
153 | ;; performance hit for everyone. | |
154 | (make-vlist base offset) | |
155 | vlist? | |
156 | (base vlist-base) | |
157 | (offset vlist-offset)) | |
158 | ||
a94469c6 LC |
159 | (set-record-type-printer! <vlist> |
160 | (lambda (vl port) | |
161 | (cond ((vlist-null? vl) | |
162 | (format port "#<vlist ()>")) | |
4bd53c1b | 163 | ((vhash? vl) |
a94469c6 LC |
164 | (format port "#<vhash ~x ~a pairs>" |
165 | (object-address vl) | |
4bd53c1b | 166 | (vlist-length vl))) |
a94469c6 LC |
167 | (else |
168 | (format port "#<vlist ~a>" | |
169 | (vlist->list vl)))))) | |
170 | ||
22ec6a31 LC |
171 | |
172 | (define vlist-null | |
173 | ;; The empty vlist. | |
174 | (make-vlist block-null 0)) | |
175 | ||
4bd53c1b AW |
176 | ;; Asserting that something is a vlist is actually a win if your next |
177 | ;; step is to call record accessors, because that causes CSE to | |
178 | ;; eliminate the type checks in those accessors. | |
179 | ;; | |
180 | (define-inlinable (assert-vlist val) | |
181 | (unless (vlist? val) | |
182 | (throw 'wrong-type-arg | |
183 | #f | |
184 | "Not a vlist: ~S" | |
185 | (list val) | |
186 | (list val)))) | |
187 | ||
299ce911 | 188 | (define-inlinable (block-cons item vlist hash-tab?) |
f6a554a6 AW |
189 | (let ((base (vlist-base vlist)) |
190 | (offset (1+ (vlist-offset vlist)))) | |
191 | (cond | |
192 | ((block-append! base item offset) | |
193 | ;; Fast path: We added the item directly to the block. | |
194 | (make-vlist base offset)) | |
195 | (else | |
196 | ;; Slow path: Allocate a new block. | |
197 | (let* ((size (block-size base)) | |
198 | (base (make-block | |
199 | base | |
200 | (1- offset) | |
201 | (cond | |
202 | ((zero? size) 1) | |
203 | ((< offset size) 1) ;; new vlist head | |
204 | (else (* (fluid-ref block-growth-factor) size))) | |
205 | hash-tab?))) | |
206 | (set-block-next-free! base 1) | |
207 | (vector-set! (block-content base) 0 item) | |
208 | (make-vlist base 0)))))) | |
22ec6a31 LC |
209 | |
210 | (define (vlist-cons item vlist) | |
c04c1184 | 211 | "Return a new vlist with ITEM as its head and VLIST as its |
22ec6a31 | 212 | tail." |
4bd53c1b AW |
213 | ;; Note: Although the result of `vlist-cons' on a vhash is a valid |
214 | ;; vlist, it is not a valid vhash. The new item does not get a hash | |
215 | ;; table entry. If we allocate a new block, the new block will not | |
216 | ;; have a hash table. Perhaps we can do something more sensible here, | |
217 | ;; but this is a hot function, so there are performance impacts. | |
218 | (assert-vlist vlist) | |
22ec6a31 LC |
219 | (block-cons item vlist #f)) |
220 | ||
221 | (define (vlist-head vlist) | |
c04c1184 | 222 | "Return the head of VLIST." |
4bd53c1b | 223 | (assert-vlist vlist) |
22ec6a31 LC |
224 | (let ((base (vlist-base vlist)) |
225 | (offset (vlist-offset vlist))) | |
4bd53c1b | 226 | (block-ref (block-content base) offset))) |
22ec6a31 LC |
227 | |
228 | (define (vlist-tail vlist) | |
c04c1184 | 229 | "Return the tail of VLIST." |
4bd53c1b | 230 | (assert-vlist vlist) |
22ec6a31 LC |
231 | (let ((base (vlist-base vlist)) |
232 | (offset (vlist-offset vlist))) | |
233 | (if (> offset 0) | |
234 | (make-vlist base (- offset 1)) | |
235 | (make-vlist (block-base base) | |
236 | (block-offset base))))) | |
237 | ||
238 | (define (vlist-null? vlist) | |
c04c1184 | 239 | "Return true if VLIST is empty." |
4bd53c1b | 240 | (assert-vlist vlist) |
22ec6a31 LC |
241 | (let ((base (vlist-base vlist))) |
242 | (and (not (block-base base)) | |
243 | (= 0 (block-size base))))) | |
244 | ||
245 | \f | |
246 | ;;; | |
247 | ;;; VList Utilities. | |
248 | ;;; | |
249 | ||
250 | (define (list->vlist lst) | |
c04c1184 | 251 | "Return a new vlist whose contents correspond to LST." |
22ec6a31 LC |
252 | (vlist-reverse (fold vlist-cons vlist-null lst))) |
253 | ||
254 | (define (vlist-fold proc init vlist) | |
c04c1184 | 255 | "Fold over VLIST, calling PROC for each element." |
22ec6a31 | 256 | ;; FIXME: Handle multiple lists. |
4bd53c1b | 257 | (assert-vlist vlist) |
22ec6a31 LC |
258 | (let loop ((base (vlist-base vlist)) |
259 | (offset (vlist-offset vlist)) | |
260 | (result init)) | |
261 | (if (eq? base block-null) | |
262 | result | |
263 | (let* ((next (- offset 1)) | |
264 | (done? (< next 0))) | |
265 | (loop (if done? (block-base base) base) | |
266 | (if done? (block-offset base) next) | |
4bd53c1b | 267 | (proc (block-ref (block-content base) offset) result)))))) |
22ec6a31 LC |
268 | |
269 | (define (vlist-fold-right proc init vlist) | |
c04c1184 | 270 | "Fold over VLIST, calling PROC for each element, starting from |
22ec6a31 | 271 | the last element." |
4bd53c1b AW |
272 | (assert-vlist vlist) |
273 | (let loop ((index (1- (vlist-length vlist))) | |
bc00e06c LC |
274 | (result init)) |
275 | (if (< index 0) | |
276 | result | |
277 | (loop (1- index) | |
4bd53c1b | 278 | (proc (vlist-ref vlist index) result))))) |
22ec6a31 LC |
279 | |
280 | (define (vlist-reverse vlist) | |
c04c1184 | 281 | "Return a new VLIST whose content are those of VLIST in reverse |
22ec6a31 LC |
282 | order." |
283 | (vlist-fold vlist-cons vlist-null vlist)) | |
284 | ||
285 | (define (vlist-map proc vlist) | |
c04c1184 | 286 | "Map PROC over the elements of VLIST and return a new vlist." |
22ec6a31 LC |
287 | (vlist-fold (lambda (item result) |
288 | (vlist-cons (proc item) result)) | |
289 | vlist-null | |
290 | (vlist-reverse vlist))) | |
291 | ||
292 | (define (vlist->list vlist) | |
c04c1184 | 293 | "Return a new list whose contents match those of VLIST." |
22ec6a31 LC |
294 | (vlist-fold-right cons '() vlist)) |
295 | ||
296 | (define (vlist-ref vlist index) | |
c04c1184 | 297 | "Return the element at index INDEX in VLIST." |
4bd53c1b | 298 | (assert-vlist vlist) |
22ec6a31 LC |
299 | (let loop ((index index) |
300 | (base (vlist-base vlist)) | |
301 | (offset (vlist-offset vlist))) | |
302 | (if (<= index offset) | |
4bd53c1b | 303 | (block-ref (block-content base) (- offset index)) |
22ec6a31 LC |
304 | (loop (- index offset 1) |
305 | (block-base base) | |
306 | (block-offset base))))) | |
307 | ||
308 | (define (vlist-drop vlist count) | |
c04c1184 LC |
309 | "Return a new vlist that does not contain the COUNT first elements of |
310 | VLIST." | |
4bd53c1b | 311 | (assert-vlist vlist) |
22ec6a31 LC |
312 | (let loop ((count count) |
313 | (base (vlist-base vlist)) | |
314 | (offset (vlist-offset vlist))) | |
315 | (if (<= count offset) | |
316 | (make-vlist base (- offset count)) | |
317 | (loop (- count offset 1) | |
318 | (block-base base) | |
319 | (block-offset base))))) | |
320 | ||
321 | (define (vlist-take vlist count) | |
c04c1184 LC |
322 | "Return a new vlist that contains only the COUNT first elements of |
323 | VLIST." | |
22ec6a31 LC |
324 | (let loop ((count count) |
325 | (vlist vlist) | |
326 | (result vlist-null)) | |
327 | (if (= 0 count) | |
328 | (vlist-reverse result) | |
329 | (loop (- count 1) | |
330 | (vlist-tail vlist) | |
331 | (vlist-cons (vlist-head vlist) result))))) | |
332 | ||
333 | (define (vlist-filter pred vlist) | |
c04c1184 LC |
334 | "Return a new vlist containing all the elements from VLIST that |
335 | satisfy PRED." | |
22ec6a31 LC |
336 | (vlist-fold-right (lambda (e v) |
337 | (if (pred e) | |
338 | (vlist-cons e v) | |
339 | v)) | |
340 | vlist-null | |
341 | vlist)) | |
342 | ||
343 | (define* (vlist-delete x vlist #:optional (equal? equal?)) | |
c04c1184 LC |
344 | "Return a new vlist corresponding to VLIST without the elements |
345 | EQUAL? to X." | |
22ec6a31 LC |
346 | (vlist-filter (lambda (e) |
347 | (not (equal? e x))) | |
348 | vlist)) | |
349 | ||
350 | (define (vlist-length vlist) | |
c04c1184 | 351 | "Return the length of VLIST." |
4bd53c1b | 352 | (assert-vlist vlist) |
22ec6a31 LC |
353 | (let loop ((base (vlist-base vlist)) |
354 | (len (vlist-offset vlist))) | |
355 | (if (eq? base block-null) | |
356 | len | |
357 | (loop (block-base base) | |
358 | (+ len 1 (block-offset base)))))) | |
359 | ||
360 | (define* (vlist-unfold p f g seed | |
361 | #:optional (tail-gen (lambda (x) vlist-null))) | |
362 | "Return a new vlist. See the description of SRFI-1 `unfold' for details." | |
363 | (let uf ((seed seed)) | |
364 | (if (p seed) | |
365 | (tail-gen seed) | |
366 | (vlist-cons (f seed) | |
367 | (uf (g seed)))))) | |
368 | ||
369 | (define* (vlist-unfold-right p f g seed #:optional (tail vlist-null)) | |
370 | "Return a new vlist. See the description of SRFI-1 `unfold-right' for | |
371 | details." | |
372 | (let uf ((seed seed) (lis tail)) | |
373 | (if (p seed) | |
374 | lis | |
375 | (uf (g seed) (vlist-cons (f seed) lis))))) | |
376 | ||
377 | (define (vlist-append . vlists) | |
378 | "Append the given lists." | |
379 | (if (null? vlists) | |
380 | vlist-null | |
381 | (fold-right (lambda (vlist result) | |
382 | (vlist-fold-right (lambda (e v) | |
383 | (vlist-cons e v)) | |
384 | result | |
385 | vlist)) | |
386 | vlist-null | |
387 | vlists))) | |
388 | ||
389 | (define (vlist-for-each proc vlist) | |
c04c1184 | 390 | "Call PROC on each element of VLIST. The result is unspecified." |
22ec6a31 LC |
391 | (vlist-fold (lambda (item x) |
392 | (proc item)) | |
393 | (if #f #f) | |
394 | vlist)) | |
395 | ||
396 | \f | |
397 | ;;; | |
398 | ;;; Hash Lists, aka. `VHash'. | |
399 | ;;; | |
400 | ||
401 | ;; Assume keys K1 and K2, H = hash(K1) = hash(K2), and two values V1 and V2 | |
402 | ;; associated with K1 and K2, respectively. The resulting layout is a | |
403 | ;; follows: | |
404 | ;; | |
4bd53c1b AW |
405 | ;; ,--------------------. |
406 | ;; 0| ,-> (K1 . V1) | Vlist array | |
407 | ;; 1| | | | |
408 | ;; 2| | (K2 . V2) | | |
409 | ;; 3| | | | |
410 | ;; size +-|------------------+ | |
411 | ;; 0| | | Hash table | |
412 | ;; 1| | | | |
413 | ;; 2| +-- O <------------- H | |
414 | ;; 3| | | | |
415 | ;; size * 2 +-|------------------+ | |
416 | ;; 0| `-> 2 | Chain links | |
417 | ;; 1| | | |
418 | ;; 2| #f | | |
419 | ;; 3| | | |
420 | ;; size * 3 `--------------------' | |
421 | ;; | |
422 | ;; The backing store for the vhash is partitioned into three areas: the | |
423 | ;; vlist part, the hash table part, and the chain links part. In this | |
424 | ;; example we have a hash H which, when indexed into the hash table | |
425 | ;; part, indicates that a value with this hash can be found at offset 0 | |
426 | ;; in the vlist part. The corresponding index (in this case, 0) of the | |
427 | ;; chain links array holds the index of the next element in this block | |
428 | ;; with this hash value, or #f if we reached the end of the chain. | |
22ec6a31 | 429 | ;; |
4bd53c1b AW |
430 | ;; This API potentially requires users to repeat which hash function and |
431 | ;; which equality predicate to use. This can lead to unpredictable | |
432 | ;; results if they are used in consistenly, e.g., between `vhash-cons' | |
433 | ;; and `vhash-assoc', which is undesirable, as argued in | |
434 | ;; http://savannah.gnu.org/bugs/?22159 . OTOH, two arguments can be | |
435 | ;; made in favor of this API: | |
22ec6a31 LC |
436 | ;; |
437 | ;; - It's consistent with how alists are handled in SRFI-1. | |
438 | ;; | |
4bd53c1b AW |
439 | ;; - In practice, users will probably consistenly use either the `q', |
440 | ;; the `v', or the plain variant (`vlist-cons' and `vlist-assoc' | |
441 | ;; without any optional argument), i.e., they will rarely explicitly | |
442 | ;; pass a hash function or equality predicate. | |
22ec6a31 LC |
443 | |
444 | (define (vhash? obj) | |
c04c1184 | 445 | "Return true if OBJ is a hash list." |
22ec6a31 | 446 | (and (vlist? obj) |
4bd53c1b | 447 | (block-hash-table? (vlist-base obj)))) |
22ec6a31 LC |
448 | |
449 | (define* (vhash-cons key value vhash #:optional (hash hash)) | |
c04c1184 LC |
450 | "Return a new hash list based on VHASH where KEY is associated |
451 | with VALUE. Use HASH to compute KEY's hash." | |
4bd53c1b AW |
452 | (assert-vlist vhash) |
453 | ;; We should also assert that it is a hash table. Need to check the | |
454 | ;; performance impacts of that. Also, vlist-null is a valid hash | |
455 | ;; table, which does not pass vhash?. A bug, perhaps. | |
456 | (let* ((vhash (block-cons (cons key value) vhash #t)) | |
457 | (base (vlist-base vhash)) | |
458 | (offset (vlist-offset vhash)) | |
459 | (size (block-size base)) | |
460 | (khash (hash key size)) | |
461 | (content (block-content base))) | |
462 | (block-hash-table-add! content size khash offset) | |
463 | vhash)) | |
22ec6a31 LC |
464 | |
465 | (define vhash-consq (cut vhash-cons <> <> <> hashq)) | |
466 | (define vhash-consv (cut vhash-cons <> <> <> hashv)) | |
467 | ||
299ce911 | 468 | (define-inlinable (%vhash-fold* proc init key vhash equal? hash) |
927bf5e8 | 469 | ;; Fold over all the values associated with KEY in VHASH. |
4bd53c1b AW |
470 | (define (visit-block base max-offset result) |
471 | (let* ((size (block-size base)) | |
472 | (content (block-content base)) | |
473 | (khash (hash key size))) | |
474 | (let loop ((offset (block-hash-table-ref content size khash)) | |
475 | (result result)) | |
476 | (if offset | |
477 | (loop (block-hash-table-next-offset content size offset) | |
478 | (if (and (<= offset max-offset) | |
479 | (equal? key (car (block-ref content offset)))) | |
480 | (proc (cdr (block-ref content offset)) result) | |
481 | result)) | |
482 | (let ((next-block (block-base base))) | |
483 | (if (> (block-size next-block) 0) | |
484 | (visit-block next-block (block-offset base) result) | |
485 | result)))))) | |
486 | ||
487 | (assert-vlist vhash) | |
488 | (if (> (block-size (vlist-base vhash)) 0) | |
489 | (visit-block (vlist-base vhash) | |
490 | (vlist-offset vhash) | |
491 | init) | |
492 | init)) | |
927bf5e8 LC |
493 | |
494 | (define* (vhash-fold* proc init key vhash | |
495 | #:optional (equal? equal?) (hash hash)) | |
c04c1184 LC |
496 | "Fold over all the values associated with KEY in VHASH, with each |
497 | call to PROC having the form ‘(proc value result)’, where | |
498 | RESULT is the result of the previous call to PROC and INIT the | |
499 | value of RESULT for the first call to PROC." | |
927bf5e8 LC |
500 | (%vhash-fold* proc init key vhash equal? hash)) |
501 | ||
502 | (define (vhash-foldq* proc init key vhash) | |
c04c1184 | 503 | "Same as ‘vhash-fold*’, but using ‘hashq’ and ‘eq?’." |
927bf5e8 LC |
504 | (%vhash-fold* proc init key vhash eq? hashq)) |
505 | ||
506 | (define (vhash-foldv* proc init key vhash) | |
c04c1184 | 507 | "Same as ‘vhash-fold*’, but using ‘hashv’ and ‘eqv?’." |
927bf5e8 LC |
508 | (%vhash-fold* proc init key vhash eqv? hashv)) |
509 | ||
299ce911 | 510 | (define-inlinable (%vhash-assoc key vhash equal? hash) |
927bf5e8 LC |
511 | ;; A specialization of `vhash-fold*' that stops when the first value |
512 | ;; associated with KEY is found or when the end-of-list is reached. Inline to | |
513 | ;; make sure `vhash-assq' gets to use the `eq?' instruction instead of calling | |
514 | ;; the `eq?' subr. | |
4bd53c1b AW |
515 | (define (visit-block base max-offset) |
516 | (let* ((size (block-size base)) | |
517 | (content (block-content base)) | |
518 | (khash (hash key size))) | |
519 | (let loop ((offset (block-hash-table-ref content size khash))) | |
520 | (if offset | |
521 | (if (and (<= offset max-offset) | |
522 | (equal? key (car (block-ref content offset)))) | |
523 | (block-ref content offset) | |
524 | (loop (block-hash-table-next-offset content size offset))) | |
525 | (let ((next-block (block-base base))) | |
526 | (and (> (block-size next-block) 0) | |
527 | (visit-block next-block (block-offset base)))))))) | |
528 | ||
529 | (assert-vlist vhash) | |
530 | (and (> (block-size (vlist-base vhash)) 0) | |
531 | (visit-block (vlist-base vhash) | |
532 | (vlist-offset vhash)))) | |
22ec6a31 LC |
533 | |
534 | (define* (vhash-assoc key vhash #:optional (equal? equal?) (hash hash)) | |
c04c1184 LC |
535 | "Return the first key/value pair from VHASH whose key is equal to |
536 | KEY according to the EQUAL? equality predicate." | |
0c368d2b | 537 | (%vhash-assoc key vhash equal? hash)) |
22ec6a31 LC |
538 | |
539 | (define (vhash-assq key vhash) | |
c04c1184 LC |
540 | "Return the first key/value pair from VHASH whose key is ‘eq?’ to |
541 | KEY." | |
0c368d2b | 542 | (%vhash-assoc key vhash eq? hashq)) |
22ec6a31 LC |
543 | |
544 | (define (vhash-assv key vhash) | |
c04c1184 LC |
545 | "Return the first key/value pair from VHASH whose key is ‘eqv?’ to |
546 | KEY." | |
0c368d2b | 547 | (%vhash-assoc key vhash eqv? hashv)) |
22ec6a31 LC |
548 | |
549 | (define* (vhash-delete key vhash #:optional (equal? equal?) (hash hash)) | |
c04c1184 LC |
550 | "Remove all associations from VHASH with KEY, comparing keys |
551 | with EQUAL?." | |
2a39def1 LC |
552 | (if (vhash-assoc key vhash equal? hash) |
553 | (vlist-fold (lambda (k+v result) | |
554 | (let ((k (car k+v)) | |
555 | (v (cdr k+v))) | |
556 | (if (equal? k key) | |
557 | result | |
da0c22b5 | 558 | (vhash-cons k v result hash)))) |
2a39def1 LC |
559 | vlist-null |
560 | vhash) | |
561 | vhash)) | |
22ec6a31 LC |
562 | |
563 | (define vhash-delq (cut vhash-delete <> <> eq? hashq)) | |
564 | (define vhash-delv (cut vhash-delete <> <> eqv? hashv)) | |
565 | ||
2f50d0a8 | 566 | (define (vhash-fold proc init vhash) |
c04c1184 LC |
567 | "Fold over the key/pair elements of VHASH from left to right, with |
568 | each call to PROC having the form ‘(PROC key value result)’, | |
569 | where RESULT is the result of the previous call to PROC and | |
570 | INIT the value of RESULT for the first call to PROC." | |
22ec6a31 LC |
571 | (vlist-fold (lambda (key+value result) |
572 | (proc (car key+value) (cdr key+value) | |
573 | result)) | |
2f50d0a8 | 574 | init |
22ec6a31 LC |
575 | vhash)) |
576 | ||
2f50d0a8 | 577 | (define (vhash-fold-right proc init vhash) |
c04c1184 LC |
578 | "Fold over the key/pair elements of VHASH from right to left, with |
579 | each call to PROC having the form ‘(PROC key value result)’, | |
580 | where RESULT is the result of the previous call to PROC and | |
581 | INIT the value of RESULT for the first call to PROC." | |
19301dc5 LC |
582 | (vlist-fold-right (lambda (key+value result) |
583 | (proc (car key+value) (cdr key+value) | |
584 | result)) | |
2f50d0a8 | 585 | init |
19301dc5 LC |
586 | vhash)) |
587 | ||
22ec6a31 | 588 | (define* (alist->vhash alist #:optional (hash hash)) |
c04c1184 | 589 | "Return the vhash corresponding to ALIST, an association list." |
22ec6a31 LC |
590 | (fold-right (lambda (pair result) |
591 | (vhash-cons (car pair) (cdr pair) result hash)) | |
592 | vlist-null | |
593 | alist)) | |
594 | ||
595 | ;;; vlist.scm ends here |