Commit | Line | Data |
---|---|---|
711a9fd7 | 1 | /* Copyright (C) 1995,1996,1998,1999,2000,2001, 2003, 2004 Free Software Foundation, Inc. |
0f2d19dd | 2 | * |
73be1d9e MV |
3 | * This library is free software; you can redistribute it and/or |
4 | * modify it under the terms of the GNU Lesser General Public | |
5 | * License as published by the Free Software Foundation; either | |
6 | * version 2.1 of the License, or (at your option) any later version. | |
0f2d19dd | 7 | * |
73be1d9e MV |
8 | * This library is distributed in the hope that it will be useful, |
9 | * but WITHOUT ANY WARRANTY; without even the implied warranty of | |
10 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU | |
11 | * Lesser General Public License for more details. | |
0f2d19dd | 12 | * |
73be1d9e MV |
13 | * You should have received a copy of the GNU Lesser General Public |
14 | * License along with this library; if not, write to the Free Software | |
15 | * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA | |
16 | */ | |
1bbd0b84 | 17 | |
1bbd0b84 | 18 | |
0f2d19dd JB |
19 | \f |
20 | ||
a0599745 MD |
21 | #include "libguile/_scm.h" |
22 | #include "libguile/alist.h" | |
23 | #include "libguile/hash.h" | |
24 | #include "libguile/eval.h" | |
fdc28395 | 25 | #include "libguile/root.h" |
a0599745 | 26 | #include "libguile/vectors.h" |
f59a096e | 27 | #include "libguile/ports.h" |
a0599745 MD |
28 | |
29 | #include "libguile/validate.h" | |
30 | #include "libguile/hashtab.h" | |
0f2d19dd JB |
31 | \f |
32 | ||
c35738c1 MD |
33 | /* NOTES |
34 | * | |
35 | * 1. The current hash table implementation uses weak alist vectors | |
36 | * (implementation in weaks.c) internally, but we do the scanning | |
37 | * ourselves (in scan_weak_hashtables) because we need to update the | |
38 | * hash table structure when items are dropped during GC. | |
39 | * | |
40 | * 2. All hash table operations still work on alist vectors. | |
41 | * | |
f59a096e MD |
42 | */ |
43 | ||
c35738c1 MD |
44 | /* Hash tables are either vectors of association lists or smobs |
45 | * containing such vectors. Currently, the vector version represents | |
46 | * constant size tables while those wrapped in a smob represents | |
47 | * resizing tables. | |
48 | * | |
49 | * Growing or shrinking, with following rehashing, is triggered when | |
50 | * the load factor | |
51 | * | |
52 | * L = N / S (N: number of items in table, S: bucket vector length) | |
53 | * | |
54 | * passes an upper limit of 0.9 or a lower limit of 0.25. | |
55 | * | |
56 | * The implementation stores the upper and lower number of items which | |
57 | * trigger a resize in the hashtable object. | |
58 | * | |
59 | * Possible hash table sizes (primes) are stored in the array | |
60 | * hashtable_size. | |
f59a096e MD |
61 | */ |
62 | ||
f59a096e MD |
63 | scm_t_bits scm_tc16_hashtable; |
64 | ||
0a4c1355 | 65 | #define HASHTABLE_SIZE_N 25 |
f59a096e | 66 | |
0a4c1355 MD |
67 | static unsigned long hashtable_size[] = { |
68 | 31, 61, 113, 223, 443, 883, 1759, 3517, 7027, 14051, 28099, 56197, 112363, | |
69 | 224717, 449419, 898823, 1797641, 3595271, 7190537, 14381041, 28762081, | |
70 | 57524111, 115048217, 230096423, 460192829 /* larger values can't be | |
71 | represented as INUMs */ | |
f59a096e MD |
72 | }; |
73 | ||
f59a096e MD |
74 | /* Turn an empty vector hash table into an opaque resizable one. */ |
75 | ||
76 | static char *s_hashtable = "hashtable"; | |
77 | ||
c35738c1 MD |
78 | SCM weak_hashtables = SCM_EOL; |
79 | ||
80 | static SCM | |
81 | make_hash_table (int flags, unsigned long k, const char *func_name) { | |
82 | SCM table, vector; | |
9358af6a | 83 | scm_t_hashtable *t; |
110beb83 MD |
84 | int i = 0, n = k ? k : 31; |
85 | while (i < HASHTABLE_SIZE_N && n > hashtable_size[i]) | |
86 | ++i; | |
87 | n = hashtable_size[i]; | |
c35738c1 MD |
88 | if (flags) |
89 | /* The SCM_WVECTF_NOSCAN flag informs the weak vector code not to | |
90 | perform the final scan for broken references. Instead we do | |
91 | that ourselves in scan_weak_hashtables. */ | |
92 | vector = scm_i_allocate_weak_vector (flags | SCM_WVECTF_NOSCAN, | |
93ccaef0 | 93 | SCM_I_MAKINUM (n), |
c35738c1 MD |
94 | SCM_EOL, |
95 | func_name); | |
96 | else | |
97 | vector = scm_c_make_vector (n, SCM_EOL); | |
9358af6a | 98 | t = scm_gc_malloc (sizeof (*t), s_hashtable); |
c35738c1 | 99 | t->min_size_index = t->size_index = i; |
f59a096e | 100 | t->n_items = 0; |
c35738c1 | 101 | t->lower = 0; |
110beb83 | 102 | t->upper = 9 * n / 10; |
c35738c1 MD |
103 | t->flags = flags; |
104 | if (flags) | |
105 | { | |
106 | SCM_NEWSMOB3 (table, scm_tc16_hashtable, vector, t, weak_hashtables); | |
107 | weak_hashtables = table; | |
108 | } | |
109 | else | |
110 | SCM_NEWSMOB3 (table, scm_tc16_hashtable, vector, t, SCM_EOL); | |
f59a096e MD |
111 | return table; |
112 | } | |
113 | ||
c35738c1 MD |
114 | |
115 | void | |
116 | scm_i_rehash (SCM table, | |
117 | unsigned long (*hash_fn)(), | |
118 | void *closure, | |
119 | const char* func_name) | |
120 | { | |
121 | SCM buckets, new_buckets; | |
122 | int i; | |
123 | unsigned long old_size; | |
124 | unsigned long new_size; | |
125 | ||
126 | if (SCM_HASHTABLE_N_ITEMS (table) < SCM_HASHTABLE_LOWER (table)) | |
127 | { | |
128 | /* rehashing is not triggered when i <= min_size */ | |
129 | i = SCM_HASHTABLE (table)->size_index; | |
130 | do | |
131 | --i; | |
132 | while (i > SCM_HASHTABLE (table)->min_size_index | |
133 | && SCM_HASHTABLE_N_ITEMS (table) < hashtable_size[i] / 4); | |
134 | } | |
135 | else | |
136 | { | |
137 | i = SCM_HASHTABLE (table)->size_index + 1; | |
138 | if (i >= HASHTABLE_SIZE_N) | |
139 | /* don't rehash */ | |
140 | return; | |
141 | /* store for use in rehash_after_gc */ | |
142 | SCM_HASHTABLE (table)->hash_fn = hash_fn; | |
143 | SCM_HASHTABLE (table)->closure = closure; | |
144 | } | |
145 | SCM_HASHTABLE (table)->size_index = i; | |
146 | ||
147 | new_size = hashtable_size[i]; | |
148 | if (i <= SCM_HASHTABLE (table)->min_size_index) | |
149 | SCM_HASHTABLE (table)->lower = 0; | |
150 | else | |
151 | SCM_HASHTABLE (table)->lower = new_size / 4; | |
152 | SCM_HASHTABLE (table)->upper = 9 * new_size / 10; | |
153 | buckets = SCM_HASHTABLE_VECTOR (table); | |
154 | ||
155 | if (SCM_HASHTABLE_WEAK_P (table)) | |
156 | new_buckets = scm_i_allocate_weak_vector (SCM_HASHTABLE_FLAGS (table) | |
157 | | SCM_WVECTF_NOSCAN, | |
93ccaef0 | 158 | SCM_I_MAKINUM (new_size), |
c35738c1 MD |
159 | SCM_EOL, |
160 | func_name); | |
161 | else | |
162 | new_buckets = scm_c_make_vector (new_size, SCM_EOL); | |
163 | ||
164 | old_size = SCM_VECTOR_LENGTH (buckets); | |
165 | for (i = 0; i < old_size; ++i) | |
166 | { | |
167 | SCM ls = SCM_VELTS (buckets)[i], handle; | |
168 | while (!SCM_NULLP (ls)) | |
169 | { | |
170 | unsigned long h; | |
171 | handle = SCM_CAR (ls); | |
172 | h = hash_fn (SCM_CAR (handle), new_size, closure); | |
173 | if (h >= new_size) | |
174 | scm_out_of_range (func_name, scm_ulong2num (h)); | |
175 | SCM_VECTOR_SET (new_buckets, h, | |
176 | scm_cons (handle, SCM_VELTS (new_buckets)[h])); | |
177 | ls = SCM_CDR (ls); | |
178 | } | |
179 | } | |
180 | SCM_SET_HASHTABLE_VECTOR (table, new_buckets); | |
181 | } | |
182 | ||
183 | ||
f59a096e MD |
184 | static int |
185 | hashtable_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED) | |
186 | { | |
187 | scm_t_hashtable *t = SCM_HASHTABLE (exp); | |
c35738c1 MD |
188 | scm_puts ("#<", port); |
189 | if (SCM_HASHTABLE_WEAK_KEY_P (exp)) | |
190 | scm_puts ("weak-key-", port); | |
191 | else if (SCM_HASHTABLE_WEAK_VALUE_P (exp)) | |
192 | scm_puts ("weak-value-", port); | |
193 | else if (SCM_HASHTABLE_DOUBLY_WEAK_P (exp)) | |
194 | scm_puts ("doubly-weak-", port); | |
195 | scm_puts ("hash-table ", port); | |
196 | scm_intprint ((unsigned long) t->n_items, 10, port); | |
f59a096e MD |
197 | scm_putc ('/', port); |
198 | scm_intprint ((unsigned long) SCM_VECTOR_LENGTH (SCM_HASHTABLE_VECTOR (exp)), | |
199 | 10, port); | |
200 | scm_puts (">", port); | |
201 | return 1; | |
202 | } | |
203 | ||
c35738c1 MD |
204 | #define UNMARKED_CELL_P(x) (SCM_NIMP(x) && !SCM_GC_MARK_P (x)) |
205 | ||
206 | /* keep track of hash tables that need to shrink after scan */ | |
207 | static SCM to_rehash = SCM_EOL; | |
208 | ||
209 | /* scan hash tables for broken references, remove them, and update | |
210 | hash tables item count */ | |
211 | static void * | |
212 | scan_weak_hashtables (void *dummy1 SCM_UNUSED, | |
213 | void *dummy2 SCM_UNUSED, | |
214 | void *dummy3 SCM_UNUSED) | |
215 | { | |
216 | SCM *next = &weak_hashtables; | |
217 | SCM h = *next; | |
218 | while (!SCM_NULLP (h)) | |
219 | { | |
220 | if (!SCM_GC_MARK_P (h)) | |
221 | *next = h = SCM_HASHTABLE_NEXT (h); | |
222 | else | |
223 | { | |
224 | SCM alist; | |
225 | int i, n = SCM_HASHTABLE_N_BUCKETS (h); | |
226 | int weak_car = SCM_HASHTABLE_FLAGS (h) & SCM_HASHTABLEF_WEAK_CAR; | |
227 | int weak_cdr = SCM_HASHTABLE_FLAGS (h) & SCM_HASHTABLEF_WEAK_CDR; | |
228 | int check_size_p = 0; | |
229 | for (i = 0; i < n; ++i) | |
230 | { | |
231 | SCM *next_spine = (SCM *) &SCM_HASHTABLE_BUCKETS (h)[i]; | |
232 | for (alist = *next_spine; | |
233 | !SCM_NULLP (alist); | |
234 | alist = SCM_CDR (alist)) | |
235 | if ((weak_car && UNMARKED_CELL_P (SCM_CAAR (alist))) | |
236 | || (weak_cdr && UNMARKED_CELL_P (SCM_CDAR (alist)))) | |
237 | { | |
238 | *next_spine = SCM_CDR (alist); | |
239 | SCM_HASHTABLE_DECREMENT (h); | |
240 | check_size_p = 1; | |
241 | } | |
242 | else | |
243 | next_spine = SCM_CDRLOC (alist); | |
244 | } | |
245 | if (check_size_p | |
246 | && SCM_HASHTABLE_N_ITEMS (h) < SCM_HASHTABLE_LOWER (h)) | |
247 | { | |
248 | SCM tmp = SCM_HASHTABLE_NEXT (h); | |
249 | /* temporarily move table from weak_hashtables to to_rehash */ | |
250 | SCM_SET_HASHTABLE_NEXT (h, to_rehash); | |
251 | to_rehash = h; | |
252 | *next = h = tmp; | |
253 | } | |
254 | else | |
255 | { | |
256 | next = SCM_HASHTABLE_NEXTLOC (h); | |
257 | h = SCM_HASHTABLE_NEXT (h); | |
258 | } | |
259 | } | |
260 | } | |
261 | return 0; | |
262 | } | |
263 | ||
264 | static void * | |
265 | rehash_after_gc (void *dummy1 SCM_UNUSED, | |
266 | void *dummy2 SCM_UNUSED, | |
267 | void *dummy3 SCM_UNUSED) | |
268 | { | |
269 | if (!SCM_NULLP (to_rehash)) | |
270 | { | |
e0245b20 | 271 | SCM first = to_rehash, last, h; |
15635be5 MD |
272 | /* important to clear to_rehash here so that we don't get stuck |
273 | in an infinite loop if scm_i_rehash causes GC */ | |
274 | to_rehash = SCM_EOL; | |
e0245b20 | 275 | h = first; |
c35738c1 MD |
276 | do |
277 | { | |
278 | scm_i_rehash (h, | |
279 | /* use same hash_fn and closure as last time */ | |
280 | SCM_HASHTABLE (h)->hash_fn, | |
281 | SCM_HASHTABLE (h)->closure, | |
282 | "rehash_after_gc"); | |
283 | last = h; | |
284 | h = SCM_HASHTABLE_NEXT (h); | |
285 | } while (!SCM_NULLP (h)); | |
286 | /* move tables back to weak_hashtables */ | |
287 | SCM_SET_HASHTABLE_NEXT (last, weak_hashtables); | |
e0245b20 | 288 | weak_hashtables = first; |
c35738c1 MD |
289 | } |
290 | return 0; | |
291 | } | |
292 | ||
f59a096e MD |
293 | static size_t |
294 | hashtable_free (SCM obj) | |
295 | { | |
296 | scm_gc_free (SCM_HASHTABLE (obj), sizeof (scm_t_hashtable), s_hashtable); | |
297 | return 0; | |
298 | } | |
299 | ||
300 | ||
00ffa0e7 | 301 | SCM |
c014a02e | 302 | scm_c_make_hash_table (unsigned long k) |
00ffa0e7 | 303 | { |
c35738c1 | 304 | return make_hash_table (0, k, "scm_c_make_hash_table"); |
f59a096e MD |
305 | } |
306 | ||
307 | SCM_DEFINE (scm_make_hash_table, "make-hash-table", 0, 1, 0, | |
308 | (SCM n), | |
c35738c1 | 309 | "Make a hash table with optional minimum number of buckets @var{n}\n") |
f59a096e MD |
310 | #define FUNC_NAME s_scm_make_hash_table |
311 | { | |
312 | if (SCM_UNBNDP (n)) | |
c35738c1 | 313 | return make_hash_table (0, 0, FUNC_NAME); |
f59a096e MD |
314 | else |
315 | { | |
316 | int k; | |
317 | SCM_VALIDATE_INUM_COPY (1, n, k); | |
c35738c1 | 318 | return make_hash_table (0, k, FUNC_NAME); |
f59a096e MD |
319 | } |
320 | } | |
321 | #undef FUNC_NAME | |
322 | ||
c35738c1 MD |
323 | SCM_DEFINE (scm_make_weak_key_hash_table, "make-weak-key-hash-table", 0, 1, 0, |
324 | (SCM n), | |
325 | "@deffnx {Scheme Procedure} make-weak-value-hash-table size\n" | |
326 | "@deffnx {Scheme Procedure} make-doubly-weak-hash-table size\n" | |
327 | "Return a weak hash table with @var{size} buckets. As with any\n" | |
328 | "hash table, choosing a good size for the table requires some\n" | |
329 | "caution.\n" | |
330 | "\n" | |
331 | "You can modify weak hash tables in exactly the same way you\n" | |
332 | "would modify regular hash tables. (@pxref{Hash Tables})") | |
333 | #define FUNC_NAME s_scm_make_weak_key_hash_table | |
f59a096e | 334 | { |
c35738c1 MD |
335 | if (SCM_UNBNDP (n)) |
336 | return make_hash_table (SCM_HASHTABLEF_WEAK_CAR, 0, FUNC_NAME); | |
f59a096e | 337 | else |
0a4c1355 | 338 | { |
c35738c1 MD |
339 | int k; |
340 | SCM_VALIDATE_INUM_COPY (1, n, k); | |
341 | return make_hash_table (SCM_HASHTABLEF_WEAK_CAR, k, FUNC_NAME); | |
0a4c1355 | 342 | } |
c35738c1 MD |
343 | } |
344 | #undef FUNC_NAME | |
345 | ||
346 | ||
347 | SCM_DEFINE (scm_make_weak_value_hash_table, "make-weak-value-hash-table", 0, 1, 0, | |
348 | (SCM n), | |
349 | "Return a hash table with weak values with @var{size} buckets.\n" | |
350 | "(@pxref{Hash Tables})") | |
351 | #define FUNC_NAME s_scm_make_weak_value_hash_table | |
352 | { | |
353 | if (SCM_UNBNDP (n)) | |
354 | return make_hash_table (SCM_HASHTABLEF_WEAK_CDR, 0, FUNC_NAME); | |
f59a096e | 355 | else |
c35738c1 MD |
356 | { |
357 | int k; | |
358 | SCM_VALIDATE_INUM_COPY (1, n, k); | |
359 | return make_hash_table (SCM_HASHTABLEF_WEAK_CDR, k, FUNC_NAME); | |
f59a096e | 360 | } |
c35738c1 MD |
361 | } |
362 | #undef FUNC_NAME | |
f59a096e | 363 | |
c35738c1 MD |
364 | |
365 | SCM_DEFINE (scm_make_doubly_weak_hash_table, "make-doubly-weak-hash-table", 1, 0, 0, | |
366 | (SCM n), | |
367 | "Return a hash table with weak keys and values with @var{size}\n" | |
368 | "buckets. (@pxref{Hash Tables})") | |
369 | #define FUNC_NAME s_scm_make_doubly_weak_hash_table | |
370 | { | |
371 | if (SCM_UNBNDP (n)) | |
372 | return make_hash_table (SCM_HASHTABLEF_WEAK_CAR | SCM_HASHTABLEF_WEAK_CDR, | |
373 | 0, | |
374 | FUNC_NAME); | |
375 | else | |
f59a096e | 376 | { |
c35738c1 MD |
377 | int k; |
378 | SCM_VALIDATE_INUM_COPY (1, n, k); | |
379 | return make_hash_table (SCM_HASHTABLEF_WEAK_CAR | SCM_HASHTABLEF_WEAK_CDR, | |
380 | k, | |
381 | FUNC_NAME); | |
f59a096e | 382 | } |
f59a096e | 383 | } |
c35738c1 MD |
384 | #undef FUNC_NAME |
385 | ||
386 | ||
387 | SCM_DEFINE (scm_hash_table_p, "hash-table?", 1, 0, 0, | |
388 | (SCM obj), | |
389 | "Return @code{#t} if @var{obj} is a hash table.") | |
390 | #define FUNC_NAME s_scm_hash_table_p | |
391 | { | |
7888309b | 392 | return scm_from_bool (SCM_HASHTABLE_P (obj)); |
c35738c1 MD |
393 | } |
394 | #undef FUNC_NAME | |
395 | ||
396 | ||
397 | SCM_DEFINE (scm_weak_key_hash_table_p, "weak-key-hash-table?", 1, 0, 0, | |
398 | (SCM obj), | |
399 | "@deffnx {Scheme Procedure} weak-value-hash-table? obj\n" | |
400 | "@deffnx {Scheme Procedure} doubly-weak-hash-table? obj\n" | |
401 | "Return @code{#t} if @var{obj} is the specified weak hash\n" | |
402 | "table. Note that a doubly weak hash table is neither a weak key\n" | |
403 | "nor a weak value hash table.") | |
404 | #define FUNC_NAME s_scm_weak_key_hash_table_p | |
405 | { | |
7888309b | 406 | return scm_from_bool (SCM_HASHTABLE_P (obj) && SCM_HASHTABLE_WEAK_KEY_P (obj)); |
c35738c1 MD |
407 | } |
408 | #undef FUNC_NAME | |
409 | ||
410 | ||
411 | SCM_DEFINE (scm_weak_value_hash_table_p, "weak-value-hash-table?", 1, 0, 0, | |
412 | (SCM obj), | |
413 | "Return @code{#t} if @var{obj} is a weak value hash table.") | |
414 | #define FUNC_NAME s_scm_weak_value_hash_table_p | |
415 | { | |
7888309b | 416 | return scm_from_bool (SCM_HASHTABLE_P (obj) && SCM_HASHTABLE_WEAK_VALUE_P (obj)); |
c35738c1 MD |
417 | } |
418 | #undef FUNC_NAME | |
419 | ||
420 | ||
421 | SCM_DEFINE (scm_doubly_weak_hash_table_p, "doubly-weak-hash-table?", 1, 0, 0, | |
422 | (SCM obj), | |
423 | "Return @code{#t} if @var{obj} is a doubly weak hash table.") | |
424 | #define FUNC_NAME s_scm_doubly_weak_hash_table_p | |
425 | { | |
7888309b | 426 | return scm_from_bool (SCM_HASHTABLE_P (obj) && SCM_HASHTABLE_DOUBLY_WEAK_P (obj)); |
c35738c1 MD |
427 | } |
428 | #undef FUNC_NAME | |
429 | ||
22a52da1 | 430 | |
0f2d19dd | 431 | SCM |
34d19ef6 | 432 | scm_hash_fn_get_handle (SCM table, SCM obj, unsigned long (*hash_fn)(), SCM (*assoc_fn)(), void * closure) |
22a52da1 | 433 | #define FUNC_NAME "scm_hash_fn_get_handle" |
0f2d19dd | 434 | { |
c014a02e | 435 | unsigned long k; |
0f2d19dd JB |
436 | SCM h; |
437 | ||
f59a096e | 438 | if (SCM_HASHTABLE_P (table)) |
0a4c1355 | 439 | table = SCM_HASHTABLE_VECTOR (table); |
f59a096e | 440 | else |
0a4c1355 | 441 | SCM_VALIDATE_VECTOR (1, table); |
bfa974f0 | 442 | if (SCM_VECTOR_LENGTH (table) == 0) |
22a52da1 | 443 | return SCM_BOOL_F; |
bfa974f0 DH |
444 | k = hash_fn (obj, SCM_VECTOR_LENGTH (table), closure); |
445 | if (k >= SCM_VECTOR_LENGTH (table)) | |
0a4c1355 | 446 | scm_out_of_range ("hash_fn_get_handle", scm_ulong2num (k)); |
0f2d19dd JB |
447 | h = assoc_fn (obj, SCM_VELTS (table)[k], closure); |
448 | return h; | |
449 | } | |
22a52da1 | 450 | #undef FUNC_NAME |
0f2d19dd JB |
451 | |
452 | ||
0f2d19dd | 453 | SCM |
34d19ef6 HWN |
454 | scm_hash_fn_create_handle_x (SCM table, SCM obj, SCM init, unsigned long (*hash_fn)(), |
455 | SCM (*assoc_fn)(), void * closure) | |
cbaadf02 | 456 | #define FUNC_NAME "scm_hash_fn_create_handle_x" |
0f2d19dd | 457 | { |
c014a02e | 458 | unsigned long k; |
f59a096e | 459 | SCM buckets, it; |
0f2d19dd | 460 | |
f59a096e | 461 | if (SCM_HASHTABLE_P (table)) |
0a4c1355 | 462 | buckets = SCM_HASHTABLE_VECTOR (table); |
f59a096e MD |
463 | else |
464 | { | |
465 | SCM_ASSERT (SCM_VECTORP (table), | |
466 | table, SCM_ARG1, "hash_fn_create_handle_x"); | |
467 | buckets = table; | |
f59a096e MD |
468 | } |
469 | if (SCM_VECTOR_LENGTH (buckets) == 0) | |
cbaadf02 DH |
470 | SCM_MISC_ERROR ("void hashtable", SCM_EOL); |
471 | ||
f59a096e MD |
472 | k = hash_fn (obj, SCM_VECTOR_LENGTH (buckets), closure); |
473 | if (k >= SCM_VECTOR_LENGTH (buckets)) | |
0a4c1355 | 474 | scm_out_of_range ("hash_fn_create_handle_x", scm_ulong2num (k)); |
f59a096e | 475 | it = assoc_fn (obj, SCM_VELTS (buckets)[k], closure); |
7888309b | 476 | if (scm_is_true (it)) |
0a4c1355 | 477 | return it; |
ee083ac2 DH |
478 | else |
479 | { | |
0a4c1355 MD |
480 | SCM old_bucket = SCM_VELTS (buckets)[k]; |
481 | SCM new_bucket = scm_acons (obj, init, old_bucket); | |
482 | SCM_VECTOR_SET (buckets, k, new_bucket); | |
f59a096e MD |
483 | if (table != buckets) |
484 | { | |
485 | SCM_HASHTABLE_INCREMENT (table); | |
486 | if (SCM_HASHTABLE_N_ITEMS (table) > SCM_HASHTABLE_UPPER (table)) | |
c35738c1 | 487 | scm_i_rehash (table, hash_fn, closure, FUNC_NAME); |
f59a096e | 488 | } |
ee083ac2 DH |
489 | return SCM_CAR (new_bucket); |
490 | } | |
0f2d19dd | 491 | } |
cbaadf02 | 492 | #undef FUNC_NAME |
0f2d19dd | 493 | |
1cc91f1b | 494 | |
0f2d19dd | 495 | SCM |
34d19ef6 HWN |
496 | scm_hash_fn_ref (SCM table, SCM obj, SCM dflt, unsigned long (*hash_fn)(), |
497 | SCM (*assoc_fn)(), void * closure) | |
0f2d19dd | 498 | { |
22a52da1 DH |
499 | SCM it = scm_hash_fn_get_handle (table, obj, hash_fn, assoc_fn, closure); |
500 | if (SCM_CONSP (it)) | |
0f2d19dd | 501 | return SCM_CDR (it); |
22a52da1 DH |
502 | else |
503 | return dflt; | |
0f2d19dd JB |
504 | } |
505 | ||
506 | ||
507 | ||
1cc91f1b | 508 | |
0f2d19dd | 509 | SCM |
34d19ef6 HWN |
510 | scm_hash_fn_set_x (SCM table, SCM obj, SCM val, unsigned long (*hash_fn)(), |
511 | SCM (*assoc_fn)(), void * closure) | |
0f2d19dd JB |
512 | { |
513 | SCM it; | |
514 | ||
515 | it = scm_hash_fn_create_handle_x (table, obj, SCM_BOOL_F, hash_fn, assoc_fn, closure); | |
516 | SCM_SETCDR (it, val); | |
517 | return val; | |
518 | } | |
519 | ||
520 | ||
521 | ||
522 | ||
1cc91f1b | 523 | |
0f2d19dd | 524 | SCM |
34d19ef6 HWN |
525 | scm_hash_fn_remove_x (SCM table, SCM obj, unsigned long (*hash_fn)(), SCM (*assoc_fn)(), |
526 | SCM (*delete_fn)(), void * closure) | |
0f2d19dd | 527 | { |
c014a02e | 528 | unsigned long k; |
87ca11ff | 529 | SCM buckets, h; |
0f2d19dd | 530 | |
87ca11ff | 531 | if (SCM_HASHTABLE_P (table)) |
0a4c1355 | 532 | buckets = SCM_HASHTABLE_VECTOR (table); |
87ca11ff MD |
533 | else |
534 | { | |
535 | SCM_ASSERT (SCM_VECTORP (table), table, SCM_ARG1, "hash_fn_remove_x"); | |
536 | buckets = table; | |
87ca11ff | 537 | } |
bfa974f0 | 538 | if (SCM_VECTOR_LENGTH (table) == 0) |
0f2d19dd | 539 | return SCM_EOL; |
87ca11ff | 540 | |
87ca11ff MD |
541 | k = hash_fn (obj, SCM_VECTOR_LENGTH (buckets), closure); |
542 | if (k >= SCM_VECTOR_LENGTH (buckets)) | |
0a4c1355 | 543 | scm_out_of_range ("hash_fn_remove_x", scm_ulong2num (k)); |
87ca11ff | 544 | h = assoc_fn (obj, SCM_VELTS (buckets)[k], closure); |
7888309b | 545 | if (scm_is_true (h)) |
87ca11ff MD |
546 | { |
547 | SCM_VECTOR_SET (buckets, k, delete_fn (h, SCM_VELTS (buckets)[k])); | |
548 | if (table != buckets) | |
549 | { | |
550 | SCM_HASHTABLE_DECREMENT (table); | |
551 | if (SCM_HASHTABLE_N_ITEMS (table) < SCM_HASHTABLE_LOWER (table)) | |
c35738c1 | 552 | scm_i_rehash (table, hash_fn, closure, "scm_hash_fn_remove_x"); |
87ca11ff MD |
553 | } |
554 | } | |
0f2d19dd JB |
555 | return h; |
556 | } | |
557 | ||
c35738c1 MD |
558 | SCM_DEFINE (scm_hash_clear_x, "hash-clear!", 1, 0, 0, |
559 | (SCM table), | |
560 | "Remove all items from TABLE (without triggering a resize).") | |
561 | #define FUNC_NAME s_scm_hash_clear_x | |
562 | { | |
563 | SCM_VALIDATE_HASHTABLE (1, table); | |
564 | scm_vector_fill_x (SCM_HASHTABLE_VECTOR (table), SCM_EOL); | |
565 | SCM_SET_HASHTABLE_N_ITEMS (table, 0); | |
566 | return SCM_UNSPECIFIED; | |
567 | } | |
568 | #undef FUNC_NAME | |
0f2d19dd JB |
569 | |
570 | \f | |
571 | ||
a1ec6916 | 572 | SCM_DEFINE (scm_hashq_get_handle, "hashq-get-handle", 2, 0, 0, |
22a52da1 DH |
573 | (SCM table, SCM key), |
574 | "This procedure returns the @code{(key . value)} pair from the\n" | |
575 | "hash table @var{table}. If @var{table} does not hold an\n" | |
576 | "associated value for @var{key}, @code{#f} is returned.\n" | |
577 | "Uses @code{eq?} for equality testing.") | |
1bbd0b84 | 578 | #define FUNC_NAME s_scm_hashq_get_handle |
0f2d19dd | 579 | { |
22a52da1 | 580 | return scm_hash_fn_get_handle (table, key, scm_ihashq, scm_sloppy_assq, 0); |
0f2d19dd | 581 | } |
1bbd0b84 | 582 | #undef FUNC_NAME |
0f2d19dd JB |
583 | |
584 | ||
a1ec6916 | 585 | SCM_DEFINE (scm_hashq_create_handle_x, "hashq-create-handle!", 3, 0, 0, |
d550d22a GB |
586 | (SCM table, SCM key, SCM init), |
587 | "This function looks up @var{key} in @var{table} and returns its handle.\n" | |
b380b885 MD |
588 | "If @var{key} is not already present, a new handle is created which\n" |
589 | "associates @var{key} with @var{init}.") | |
1bbd0b84 | 590 | #define FUNC_NAME s_scm_hashq_create_handle_x |
0f2d19dd | 591 | { |
d550d22a | 592 | return scm_hash_fn_create_handle_x (table, key, init, scm_ihashq, scm_sloppy_assq, 0); |
0f2d19dd | 593 | } |
1bbd0b84 | 594 | #undef FUNC_NAME |
0f2d19dd JB |
595 | |
596 | ||
a1ec6916 | 597 | SCM_DEFINE (scm_hashq_ref, "hashq-ref", 2, 1, 0, |
1e6808ea | 598 | (SCM table, SCM key, SCM dflt), |
b380b885 MD |
599 | "Look up @var{key} in the hash table @var{table}, and return the\n" |
600 | "value (if any) associated with it. If @var{key} is not found,\n" | |
5352393c MG |
601 | "return @var{default} (or @code{#f} if no @var{default} argument\n" |
602 | "is supplied). Uses @code{eq?} for equality testing.") | |
1bbd0b84 | 603 | #define FUNC_NAME s_scm_hashq_ref |
0f2d19dd | 604 | { |
54778cd3 | 605 | if (SCM_UNBNDP (dflt)) |
0f2d19dd | 606 | dflt = SCM_BOOL_F; |
1e6808ea | 607 | return scm_hash_fn_ref (table, key, dflt, scm_ihashq, scm_sloppy_assq, 0); |
0f2d19dd | 608 | } |
1bbd0b84 | 609 | #undef FUNC_NAME |
0f2d19dd JB |
610 | |
611 | ||
612 | ||
a1ec6916 | 613 | SCM_DEFINE (scm_hashq_set_x, "hashq-set!", 3, 0, 0, |
1e6808ea | 614 | (SCM table, SCM key, SCM val), |
5352393c MG |
615 | "Find the entry in @var{table} associated with @var{key}, and\n" |
616 | "store @var{value} there. Uses @code{eq?} for equality testing.") | |
1bbd0b84 | 617 | #define FUNC_NAME s_scm_hashq_set_x |
0f2d19dd | 618 | { |
1e6808ea | 619 | return scm_hash_fn_set_x (table, key, val, scm_ihashq, scm_sloppy_assq, 0); |
0f2d19dd | 620 | } |
1bbd0b84 | 621 | #undef FUNC_NAME |
0f2d19dd JB |
622 | |
623 | ||
624 | ||
a1ec6916 | 625 | SCM_DEFINE (scm_hashq_remove_x, "hashq-remove!", 2, 0, 0, |
1e6808ea | 626 | (SCM table, SCM key), |
5352393c MG |
627 | "Remove @var{key} (and any value associated with it) from\n" |
628 | "@var{table}. Uses @code{eq?} for equality tests.") | |
1bbd0b84 | 629 | #define FUNC_NAME s_scm_hashq_remove_x |
0f2d19dd | 630 | { |
1e6808ea MG |
631 | return scm_hash_fn_remove_x (table, key, scm_ihashq, scm_sloppy_assq, |
632 | scm_delq_x, 0); | |
0f2d19dd | 633 | } |
1bbd0b84 | 634 | #undef FUNC_NAME |
0f2d19dd JB |
635 | |
636 | ||
637 | \f | |
638 | ||
a1ec6916 | 639 | SCM_DEFINE (scm_hashv_get_handle, "hashv-get-handle", 2, 0, 0, |
22a52da1 DH |
640 | (SCM table, SCM key), |
641 | "This procedure returns the @code{(key . value)} pair from the\n" | |
642 | "hash table @var{table}. If @var{table} does not hold an\n" | |
643 | "associated value for @var{key}, @code{#f} is returned.\n" | |
644 | "Uses @code{eqv?} for equality testing.") | |
1bbd0b84 | 645 | #define FUNC_NAME s_scm_hashv_get_handle |
0f2d19dd | 646 | { |
22a52da1 | 647 | return scm_hash_fn_get_handle (table, key, scm_ihashv, scm_sloppy_assv, 0); |
0f2d19dd | 648 | } |
1bbd0b84 | 649 | #undef FUNC_NAME |
0f2d19dd JB |
650 | |
651 | ||
a1ec6916 | 652 | SCM_DEFINE (scm_hashv_create_handle_x, "hashv-create-handle!", 3, 0, 0, |
d550d22a GB |
653 | (SCM table, SCM key, SCM init), |
654 | "This function looks up @var{key} in @var{table} and returns its handle.\n" | |
655 | "If @var{key} is not already present, a new handle is created which\n" | |
656 | "associates @var{key} with @var{init}.") | |
1bbd0b84 | 657 | #define FUNC_NAME s_scm_hashv_create_handle_x |
0f2d19dd | 658 | { |
1e6808ea MG |
659 | return scm_hash_fn_create_handle_x (table, key, init, scm_ihashv, |
660 | scm_sloppy_assv, 0); | |
0f2d19dd | 661 | } |
1bbd0b84 | 662 | #undef FUNC_NAME |
0f2d19dd JB |
663 | |
664 | ||
a1ec6916 | 665 | SCM_DEFINE (scm_hashv_ref, "hashv-ref", 2, 1, 0, |
1e6808ea | 666 | (SCM table, SCM key, SCM dflt), |
d550d22a GB |
667 | "Look up @var{key} in the hash table @var{table}, and return the\n" |
668 | "value (if any) associated with it. If @var{key} is not found,\n" | |
5352393c MG |
669 | "return @var{default} (or @code{#f} if no @var{default} argument\n" |
670 | "is supplied). Uses @code{eqv?} for equality testing.") | |
1bbd0b84 | 671 | #define FUNC_NAME s_scm_hashv_ref |
0f2d19dd | 672 | { |
54778cd3 | 673 | if (SCM_UNBNDP (dflt)) |
0f2d19dd | 674 | dflt = SCM_BOOL_F; |
1e6808ea | 675 | return scm_hash_fn_ref (table, key, dflt, scm_ihashv, scm_sloppy_assv, 0); |
0f2d19dd | 676 | } |
1bbd0b84 | 677 | #undef FUNC_NAME |
0f2d19dd JB |
678 | |
679 | ||
680 | ||
a1ec6916 | 681 | SCM_DEFINE (scm_hashv_set_x, "hashv-set!", 3, 0, 0, |
1e6808ea | 682 | (SCM table, SCM key, SCM val), |
5352393c MG |
683 | "Find the entry in @var{table} associated with @var{key}, and\n" |
684 | "store @var{value} there. Uses @code{eqv?} for equality testing.") | |
1bbd0b84 | 685 | #define FUNC_NAME s_scm_hashv_set_x |
0f2d19dd | 686 | { |
1e6808ea | 687 | return scm_hash_fn_set_x (table, key, val, scm_ihashv, scm_sloppy_assv, 0); |
0f2d19dd | 688 | } |
1bbd0b84 | 689 | #undef FUNC_NAME |
0f2d19dd JB |
690 | |
691 | ||
a1ec6916 | 692 | SCM_DEFINE (scm_hashv_remove_x, "hashv-remove!", 2, 0, 0, |
1e6808ea | 693 | (SCM table, SCM key), |
5352393c MG |
694 | "Remove @var{key} (and any value associated with it) from\n" |
695 | "@var{table}. Uses @code{eqv?} for equality tests.") | |
1bbd0b84 | 696 | #define FUNC_NAME s_scm_hashv_remove_x |
0f2d19dd | 697 | { |
1e6808ea MG |
698 | return scm_hash_fn_remove_x (table, key, scm_ihashv, scm_sloppy_assv, |
699 | scm_delv_x, 0); | |
0f2d19dd | 700 | } |
1bbd0b84 | 701 | #undef FUNC_NAME |
0f2d19dd JB |
702 | |
703 | \f | |
704 | ||
a1ec6916 | 705 | SCM_DEFINE (scm_hash_get_handle, "hash-get-handle", 2, 0, 0, |
22a52da1 DH |
706 | (SCM table, SCM key), |
707 | "This procedure returns the @code{(key . value)} pair from the\n" | |
708 | "hash table @var{table}. If @var{table} does not hold an\n" | |
709 | "associated value for @var{key}, @code{#f} is returned.\n" | |
710 | "Uses @code{equal?} for equality testing.") | |
1bbd0b84 | 711 | #define FUNC_NAME s_scm_hash_get_handle |
0f2d19dd | 712 | { |
22a52da1 | 713 | return scm_hash_fn_get_handle (table, key, scm_ihash, scm_sloppy_assoc, 0); |
0f2d19dd | 714 | } |
1bbd0b84 | 715 | #undef FUNC_NAME |
0f2d19dd JB |
716 | |
717 | ||
a1ec6916 | 718 | SCM_DEFINE (scm_hash_create_handle_x, "hash-create-handle!", 3, 0, 0, |
d550d22a GB |
719 | (SCM table, SCM key, SCM init), |
720 | "This function looks up @var{key} in @var{table} and returns its handle.\n" | |
721 | "If @var{key} is not already present, a new handle is created which\n" | |
722 | "associates @var{key} with @var{init}.") | |
1bbd0b84 | 723 | #define FUNC_NAME s_scm_hash_create_handle_x |
0f2d19dd | 724 | { |
d550d22a | 725 | return scm_hash_fn_create_handle_x (table, key, init, scm_ihash, scm_sloppy_assoc, 0); |
0f2d19dd | 726 | } |
1bbd0b84 | 727 | #undef FUNC_NAME |
0f2d19dd JB |
728 | |
729 | ||
a1ec6916 | 730 | SCM_DEFINE (scm_hash_ref, "hash-ref", 2, 1, 0, |
1e6808ea | 731 | (SCM table, SCM key, SCM dflt), |
d550d22a GB |
732 | "Look up @var{key} in the hash table @var{table}, and return the\n" |
733 | "value (if any) associated with it. If @var{key} is not found,\n" | |
5352393c MG |
734 | "return @var{default} (or @code{#f} if no @var{default} argument\n" |
735 | "is supplied). Uses @code{equal?} for equality testing.") | |
1bbd0b84 | 736 | #define FUNC_NAME s_scm_hash_ref |
0f2d19dd | 737 | { |
54778cd3 | 738 | if (SCM_UNBNDP (dflt)) |
0f2d19dd | 739 | dflt = SCM_BOOL_F; |
1e6808ea | 740 | return scm_hash_fn_ref (table, key, dflt, scm_ihash, scm_sloppy_assoc, 0); |
0f2d19dd | 741 | } |
1bbd0b84 | 742 | #undef FUNC_NAME |
0f2d19dd JB |
743 | |
744 | ||
745 | ||
a1ec6916 | 746 | SCM_DEFINE (scm_hash_set_x, "hash-set!", 3, 0, 0, |
1e6808ea | 747 | (SCM table, SCM key, SCM val), |
5352393c MG |
748 | "Find the entry in @var{table} associated with @var{key}, and\n" |
749 | "store @var{value} there. Uses @code{equal?} for equality\n" | |
750 | "testing.") | |
1bbd0b84 | 751 | #define FUNC_NAME s_scm_hash_set_x |
0f2d19dd | 752 | { |
1e6808ea | 753 | return scm_hash_fn_set_x (table, key, val, scm_ihash, scm_sloppy_assoc, 0); |
0f2d19dd | 754 | } |
1bbd0b84 | 755 | #undef FUNC_NAME |
0f2d19dd JB |
756 | |
757 | ||
758 | ||
a1ec6916 | 759 | SCM_DEFINE (scm_hash_remove_x, "hash-remove!", 2, 0, 0, |
1e6808ea | 760 | (SCM table, SCM key), |
5352393c MG |
761 | "Remove @var{key} (and any value associated with it) from\n" |
762 | "@var{table}. Uses @code{equal?} for equality tests.") | |
1bbd0b84 | 763 | #define FUNC_NAME s_scm_hash_remove_x |
0f2d19dd | 764 | { |
1e6808ea MG |
765 | return scm_hash_fn_remove_x (table, key, scm_ihash, scm_sloppy_assoc, |
766 | scm_delete_x, 0); | |
0f2d19dd | 767 | } |
1bbd0b84 | 768 | #undef FUNC_NAME |
0f2d19dd JB |
769 | |
770 | \f | |
771 | ||
772 | ||
92c2555f | 773 | typedef struct scm_t_ihashx_closure |
0f2d19dd JB |
774 | { |
775 | SCM hash; | |
776 | SCM assoc; | |
777 | SCM delete; | |
92c2555f | 778 | } scm_t_ihashx_closure; |
0f2d19dd JB |
779 | |
780 | ||
1cc91f1b | 781 | |
c014a02e | 782 | static unsigned long |
92c2555f | 783 | scm_ihashx (SCM obj, unsigned long n, scm_t_ihashx_closure *closure) |
0f2d19dd | 784 | { |
87ca11ff MD |
785 | SCM answer = scm_call_2 (closure->hash, |
786 | obj, | |
787 | scm_ulong2num ((unsigned long) n)); | |
0f2d19dd JB |
788 | return SCM_INUM (answer); |
789 | } | |
790 | ||
791 | ||
1cc91f1b | 792 | |
0f2d19dd | 793 | static SCM |
92c2555f | 794 | scm_sloppy_assx (SCM obj, SCM alist, scm_t_ihashx_closure *closure) |
0f2d19dd | 795 | { |
87ca11ff | 796 | return scm_call_2 (closure->assoc, obj, alist); |
0f2d19dd JB |
797 | } |
798 | ||
799 | ||
800 | ||
1cc91f1b | 801 | |
0f2d19dd | 802 | static SCM |
92c2555f | 803 | scm_delx_x (SCM obj, SCM alist, scm_t_ihashx_closure *closure) |
0f2d19dd | 804 | { |
87ca11ff | 805 | return scm_call_2 (closure->delete, obj, alist); |
0f2d19dd JB |
806 | } |
807 | ||
808 | ||
809 | ||
a1ec6916 | 810 | SCM_DEFINE (scm_hashx_get_handle, "hashx-get-handle", 4, 0, 0, |
1e6808ea MG |
811 | (SCM hash, SCM assoc, SCM table, SCM key), |
812 | "This behaves the same way as the corresponding\n" | |
813 | "@code{-get-handle} function, but uses @var{hash} as a hash\n" | |
814 | "function and @var{assoc} to compare keys. @code{hash} must be\n" | |
815 | "a function that takes two arguments, a key to be hashed and a\n" | |
d550d22a GB |
816 | "table size. @code{assoc} must be an associator function, like\n" |
817 | "@code{assoc}, @code{assq} or @code{assv}.") | |
1bbd0b84 | 818 | #define FUNC_NAME s_scm_hashx_get_handle |
0f2d19dd | 819 | { |
92c2555f | 820 | scm_t_ihashx_closure closure; |
0f2d19dd JB |
821 | closure.hash = hash; |
822 | closure.assoc = assoc; | |
1e6808ea | 823 | return scm_hash_fn_get_handle (table, key, scm_ihashx, scm_sloppy_assx, |
87ca11ff | 824 | (void *) &closure); |
0f2d19dd | 825 | } |
1bbd0b84 | 826 | #undef FUNC_NAME |
0f2d19dd JB |
827 | |
828 | ||
a1ec6916 | 829 | SCM_DEFINE (scm_hashx_create_handle_x, "hashx-create-handle!", 5, 0, 0, |
1e6808ea MG |
830 | (SCM hash, SCM assoc, SCM table, SCM key, SCM init), |
831 | "This behaves the same way as the corresponding\n" | |
832 | "@code{-create-handle} function, but uses @var{hash} as a hash\n" | |
833 | "function and @var{assoc} to compare keys. @code{hash} must be\n" | |
834 | "a function that takes two arguments, a key to be hashed and a\n" | |
d550d22a GB |
835 | "table size. @code{assoc} must be an associator function, like\n" |
836 | "@code{assoc}, @code{assq} or @code{assv}.") | |
1bbd0b84 | 837 | #define FUNC_NAME s_scm_hashx_create_handle_x |
0f2d19dd | 838 | { |
92c2555f | 839 | scm_t_ihashx_closure closure; |
0f2d19dd JB |
840 | closure.hash = hash; |
841 | closure.assoc = assoc; | |
1e6808ea MG |
842 | return scm_hash_fn_create_handle_x (table, key, init, scm_ihashx, |
843 | scm_sloppy_assx, (void *)&closure); | |
0f2d19dd | 844 | } |
1bbd0b84 | 845 | #undef FUNC_NAME |
0f2d19dd JB |
846 | |
847 | ||
848 | ||
a1ec6916 | 849 | SCM_DEFINE (scm_hashx_ref, "hashx-ref", 4, 1, 0, |
1e6808ea | 850 | (SCM hash, SCM assoc, SCM table, SCM key, SCM dflt), |
d550d22a | 851 | "This behaves the same way as the corresponding @code{ref}\n" |
1e6808ea MG |
852 | "function, but uses @var{hash} as a hash function and\n" |
853 | "@var{assoc} to compare keys. @code{hash} must be a function\n" | |
854 | "that takes two arguments, a key to be hashed and a table size.\n" | |
855 | "@code{assoc} must be an associator function, like @code{assoc},\n" | |
856 | "@code{assq} or @code{assv}.\n" | |
857 | "\n" | |
858 | "By way of illustration, @code{hashq-ref table key} is\n" | |
859 | "equivalent to @code{hashx-ref hashq assq table key}.") | |
1bbd0b84 | 860 | #define FUNC_NAME s_scm_hashx_ref |
0f2d19dd | 861 | { |
92c2555f | 862 | scm_t_ihashx_closure closure; |
54778cd3 | 863 | if (SCM_UNBNDP (dflt)) |
0f2d19dd JB |
864 | dflt = SCM_BOOL_F; |
865 | closure.hash = hash; | |
866 | closure.assoc = assoc; | |
1e6808ea MG |
867 | return scm_hash_fn_ref (table, key, dflt, scm_ihashx, scm_sloppy_assx, |
868 | (void *)&closure); | |
0f2d19dd | 869 | } |
1bbd0b84 | 870 | #undef FUNC_NAME |
0f2d19dd JB |
871 | |
872 | ||
873 | ||
874 | ||
a1ec6916 | 875 | SCM_DEFINE (scm_hashx_set_x, "hashx-set!", 5, 0, 0, |
1e6808ea | 876 | (SCM hash, SCM assoc, SCM table, SCM key, SCM val), |
d550d22a | 877 | "This behaves the same way as the corresponding @code{set!}\n" |
1e6808ea MG |
878 | "function, but uses @var{hash} as a hash function and\n" |
879 | "@var{assoc} to compare keys. @code{hash} must be a function\n" | |
880 | "that takes two arguments, a key to be hashed and a table size.\n" | |
881 | "@code{assoc} must be an associator function, like @code{assoc},\n" | |
882 | "@code{assq} or @code{assv}.\n" | |
883 | "\n" | |
884 | " By way of illustration, @code{hashq-set! table key} is\n" | |
885 | "equivalent to @code{hashx-set! hashq assq table key}.") | |
1bbd0b84 | 886 | #define FUNC_NAME s_scm_hashx_set_x |
0f2d19dd | 887 | { |
92c2555f | 888 | scm_t_ihashx_closure closure; |
0f2d19dd JB |
889 | closure.hash = hash; |
890 | closure.assoc = assoc; | |
1e6808ea MG |
891 | return scm_hash_fn_set_x (table, key, val, scm_ihashx, scm_sloppy_assx, |
892 | (void *)&closure); | |
0f2d19dd | 893 | } |
1bbd0b84 | 894 | #undef FUNC_NAME |
0f2d19dd JB |
895 | |
896 | ||
1cc91f1b | 897 | |
0f2d19dd | 898 | SCM |
1be6b49c | 899 | scm_hashx_remove_x (SCM hash, SCM assoc, SCM delete, SCM table, SCM obj) |
0f2d19dd | 900 | { |
92c2555f | 901 | scm_t_ihashx_closure closure; |
0f2d19dd JB |
902 | closure.hash = hash; |
903 | closure.assoc = assoc; | |
904 | closure.delete = delete; | |
905 | return scm_hash_fn_remove_x (table, obj, scm_ihashx, scm_sloppy_assx, scm_delx_x, 0); | |
906 | } | |
907 | ||
711a9fd7 | 908 | /* Hash table iterators */ |
b94903c2 | 909 | |
711a9fd7 | 910 | static const char s_scm_hash_fold[]; |
c7df61cd MD |
911 | |
912 | SCM | |
8cd5191b | 913 | scm_internal_hash_fold (SCM (*fn) (), void *closure, SCM init, SCM table) |
c7df61cd | 914 | { |
87ca11ff MD |
915 | long i, n; |
916 | SCM buckets, result = init; | |
87ca11ff MD |
917 | |
918 | if (SCM_HASHTABLE_P (table)) | |
0a4c1355 | 919 | buckets = SCM_HASHTABLE_VECTOR (table); |
87ca11ff | 920 | else |
0a4c1355 MD |
921 | buckets = table; |
922 | ||
87ca11ff | 923 | n = SCM_VECTOR_LENGTH (buckets); |
c7df61cd MD |
924 | for (i = 0; i < n; ++i) |
925 | { | |
87ca11ff | 926 | SCM ls = SCM_VELTS (buckets)[i], handle; |
22a52da1 | 927 | while (!SCM_NULLP (ls)) |
c7df61cd | 928 | { |
87ca11ff | 929 | if (!SCM_CONSP (ls)) |
0a4c1355 | 930 | scm_wrong_type_arg (s_scm_hash_fold, SCM_ARG3, buckets); |
c7df61cd | 931 | handle = SCM_CAR (ls); |
87ca11ff | 932 | if (!SCM_CONSP (handle)) |
0a4c1355 | 933 | scm_wrong_type_arg (s_scm_hash_fold, SCM_ARG3, buckets); |
c7df61cd MD |
934 | result = fn (closure, SCM_CAR (handle), SCM_CDR (handle), result); |
935 | ls = SCM_CDR (ls); | |
936 | } | |
937 | } | |
87ca11ff | 938 | |
c7df61cd MD |
939 | return result; |
940 | } | |
941 | ||
711a9fd7 MD |
942 | /* The following redundant code is here in order to be able to support |
943 | hash-for-each-handle. An alternative would have been to replace | |
944 | this code and scm_internal_hash_fold above with a single | |
945 | scm_internal_hash_fold_handles, but we don't want to promote such | |
946 | an API. */ | |
947 | ||
948 | static const char s_scm_hash_for_each[]; | |
949 | ||
950 | void | |
951 | scm_internal_hash_for_each_handle (SCM (*fn) (), void *closure, SCM table) | |
952 | { | |
953 | long i, n; | |
954 | SCM buckets; | |
955 | ||
956 | if (SCM_HASHTABLE_P (table)) | |
957 | buckets = SCM_HASHTABLE_VECTOR (table); | |
958 | else | |
959 | buckets = table; | |
960 | ||
961 | n = SCM_VECTOR_LENGTH (buckets); | |
962 | for (i = 0; i < n; ++i) | |
963 | { | |
964 | SCM ls = SCM_VELTS (buckets)[i], handle; | |
965 | while (!SCM_NULLP (ls)) | |
966 | { | |
967 | if (!SCM_CONSP (ls)) | |
968 | scm_wrong_type_arg (s_scm_hash_for_each, SCM_ARG3, buckets); | |
969 | handle = SCM_CAR (ls); | |
970 | if (!SCM_CONSP (handle)) | |
971 | scm_wrong_type_arg (s_scm_hash_for_each, SCM_ARG3, buckets); | |
972 | fn (closure, handle); | |
973 | ls = SCM_CDR (ls); | |
974 | } | |
975 | } | |
976 | } | |
977 | ||
978 | SCM_DEFINE (scm_hash_fold, "hash-fold", 3, 0, 0, | |
979 | (SCM proc, SCM init, SCM table), | |
980 | "An iterator over hash-table elements.\n" | |
981 | "Accumulates and returns a result by applying PROC successively.\n" | |
982 | "The arguments to PROC are \"(key value prior-result)\" where key\n" | |
983 | "and value are successive pairs from the hash table TABLE, and\n" | |
984 | "prior-result is either INIT (for the first application of PROC)\n" | |
985 | "or the return value of the previous application of PROC.\n" | |
986 | "For example, @code{(hash-fold acons '() tab)} will convert a hash\n" | |
987 | "table into an a-list of key-value pairs.") | |
988 | #define FUNC_NAME s_scm_hash_fold | |
989 | { | |
990 | SCM_VALIDATE_PROC (1, proc); | |
991 | if (!SCM_HASHTABLE_P (table)) | |
992 | SCM_VALIDATE_VECTOR (3, table); | |
993 | return scm_internal_hash_fold (scm_call_3, (void *) SCM_UNPACK (proc), init, table); | |
994 | } | |
995 | #undef FUNC_NAME | |
996 | ||
c35738c1 | 997 | static SCM |
711a9fd7 | 998 | for_each_proc (void *proc, SCM handle) |
c35738c1 | 999 | { |
711a9fd7 | 1000 | return scm_call_2 (SCM_PACK (proc), SCM_CAR (handle), SCM_CDR (handle)); |
c35738c1 MD |
1001 | } |
1002 | ||
1003 | SCM_DEFINE (scm_hash_for_each, "hash-for-each", 2, 0, 0, | |
1004 | (SCM proc, SCM table), | |
1005 | "An iterator over hash-table elements.\n" | |
1006 | "Applies PROC successively on all hash table items.\n" | |
1007 | "The arguments to PROC are \"(key value)\" where key\n" | |
1008 | "and value are successive pairs from the hash table TABLE.") | |
1009 | #define FUNC_NAME s_scm_hash_for_each | |
1010 | { | |
1011 | SCM_VALIDATE_PROC (1, proc); | |
1012 | if (!SCM_HASHTABLE_P (table)) | |
1013 | SCM_VALIDATE_VECTOR (2, table); | |
711a9fd7 MD |
1014 | |
1015 | scm_internal_hash_for_each_handle (for_each_proc, | |
1016 | (void *) SCM_UNPACK (proc), | |
1017 | table); | |
1018 | return SCM_UNSPECIFIED; | |
1019 | } | |
1020 | #undef FUNC_NAME | |
1021 | ||
1022 | SCM_DEFINE (scm_hash_for_each_handle, "hash-for-each-handle", 2, 0, 0, | |
1023 | (SCM proc, SCM table), | |
1024 | "An iterator over hash-table elements.\n" | |
1025 | "Applies PROC successively on all hash table handles.") | |
1026 | #define FUNC_NAME s_scm_hash_for_each_handle | |
1027 | { | |
1028 | scm_t_trampoline_1 call = scm_trampoline_1 (proc); | |
1029 | SCM_ASSERT (call, proc, 1, FUNC_NAME); | |
1030 | if (!SCM_HASHTABLE_P (table)) | |
1031 | SCM_VALIDATE_VECTOR (2, table); | |
1032 | ||
1033 | scm_internal_hash_for_each_handle (call, | |
1034 | (void *) SCM_UNPACK (proc), | |
1035 | table); | |
c35738c1 MD |
1036 | return SCM_UNSPECIFIED; |
1037 | } | |
1038 | #undef FUNC_NAME | |
1039 | ||
1040 | static SCM | |
1041 | map_proc (void *proc, SCM key, SCM data, SCM value) | |
1042 | { | |
1043 | return scm_cons (scm_call_2 (SCM_PACK (proc), key, data), value); | |
1044 | } | |
1045 | ||
711a9fd7 | 1046 | SCM_DEFINE (scm_hash_map_to_list, "hash-map->list", 2, 0, 0, |
c35738c1 MD |
1047 | (SCM proc, SCM table), |
1048 | "An iterator over hash-table elements.\n" | |
1049 | "Accumulates and returns as a list the results of applying PROC successively.\n" | |
1050 | "The arguments to PROC are \"(key value)\" where key\n" | |
1051 | "and value are successive pairs from the hash table TABLE.") | |
711a9fd7 | 1052 | #define FUNC_NAME s_scm_hash_map_to_list |
c35738c1 MD |
1053 | { |
1054 | SCM_VALIDATE_PROC (1, proc); | |
1055 | if (!SCM_HASHTABLE_P (table)) | |
1056 | SCM_VALIDATE_VECTOR (2, table); | |
1057 | return scm_internal_hash_fold (map_proc, | |
1058 | (void *) SCM_UNPACK (proc), | |
1059 | SCM_EOL, | |
1060 | table); | |
1061 | } | |
1062 | #undef FUNC_NAME | |
1063 | ||
0f2d19dd JB |
1064 | \f |
1065 | ||
1cc91f1b | 1066 | |
0f2d19dd | 1067 | void |
c35738c1 | 1068 | scm_hashtab_prehistory () |
0f2d19dd | 1069 | { |
f59a096e MD |
1070 | scm_tc16_hashtable = scm_make_smob_type (s_hashtable, 0); |
1071 | scm_set_smob_mark (scm_tc16_hashtable, scm_markcdr); | |
1072 | scm_set_smob_print (scm_tc16_hashtable, hashtable_print); | |
1073 | scm_set_smob_free (scm_tc16_hashtable, hashtable_free); | |
c35738c1 MD |
1074 | scm_c_hook_add (&scm_after_sweep_c_hook, scan_weak_hashtables, 0, 0); |
1075 | scm_c_hook_add (&scm_after_gc_c_hook, rehash_after_gc, 0, 0); | |
1076 | } | |
1077 | ||
1078 | void | |
1079 | scm_init_hashtab () | |
1080 | { | |
a0599745 | 1081 | #include "libguile/hashtab.x" |
0f2d19dd | 1082 | } |
89e00824 ML |
1083 | |
1084 | /* | |
1085 | Local Variables: | |
1086 | c-file-style: "gnu" | |
1087 | End: | |
1088 | */ |