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, | |
e11e83f3 | 93 | scm_from_int (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, | |
e11e83f3 | 158 | scm_from_ulong (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; | |
d2e53ed6 | 168 | while (!scm_is_null (ls)) |
c35738c1 MD |
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) | |
b9bd8526 | 174 | scm_out_of_range (func_name, scm_from_ulong (h)); |
c35738c1 MD |
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); | |
0345e278 | 196 | scm_uintprint (t->n_items, 10, port); |
f59a096e | 197 | scm_putc ('/', port); |
0345e278 | 198 | scm_uintprint (SCM_VECTOR_LENGTH (SCM_HASHTABLE_VECTOR (exp)), 10, port); |
f59a096e MD |
199 | scm_puts (">", port); |
200 | return 1; | |
201 | } | |
202 | ||
c35738c1 MD |
203 | #define UNMARKED_CELL_P(x) (SCM_NIMP(x) && !SCM_GC_MARK_P (x)) |
204 | ||
205 | /* keep track of hash tables that need to shrink after scan */ | |
206 | static SCM to_rehash = SCM_EOL; | |
207 | ||
208 | /* scan hash tables for broken references, remove them, and update | |
209 | hash tables item count */ | |
210 | static void * | |
211 | scan_weak_hashtables (void *dummy1 SCM_UNUSED, | |
212 | void *dummy2 SCM_UNUSED, | |
213 | void *dummy3 SCM_UNUSED) | |
214 | { | |
215 | SCM *next = &weak_hashtables; | |
216 | SCM h = *next; | |
d2e53ed6 | 217 | while (!scm_is_null (h)) |
c35738c1 MD |
218 | { |
219 | if (!SCM_GC_MARK_P (h)) | |
220 | *next = h = SCM_HASHTABLE_NEXT (h); | |
221 | else | |
222 | { | |
223 | SCM alist; | |
224 | int i, n = SCM_HASHTABLE_N_BUCKETS (h); | |
225 | int weak_car = SCM_HASHTABLE_FLAGS (h) & SCM_HASHTABLEF_WEAK_CAR; | |
226 | int weak_cdr = SCM_HASHTABLE_FLAGS (h) & SCM_HASHTABLEF_WEAK_CDR; | |
227 | int check_size_p = 0; | |
228 | for (i = 0; i < n; ++i) | |
229 | { | |
230 | SCM *next_spine = (SCM *) &SCM_HASHTABLE_BUCKETS (h)[i]; | |
231 | for (alist = *next_spine; | |
d2e53ed6 | 232 | !scm_is_null (alist); |
c35738c1 MD |
233 | alist = SCM_CDR (alist)) |
234 | if ((weak_car && UNMARKED_CELL_P (SCM_CAAR (alist))) | |
235 | || (weak_cdr && UNMARKED_CELL_P (SCM_CDAR (alist)))) | |
236 | { | |
237 | *next_spine = SCM_CDR (alist); | |
238 | SCM_HASHTABLE_DECREMENT (h); | |
239 | check_size_p = 1; | |
240 | } | |
241 | else | |
242 | next_spine = SCM_CDRLOC (alist); | |
243 | } | |
244 | if (check_size_p | |
245 | && SCM_HASHTABLE_N_ITEMS (h) < SCM_HASHTABLE_LOWER (h)) | |
246 | { | |
247 | SCM tmp = SCM_HASHTABLE_NEXT (h); | |
248 | /* temporarily move table from weak_hashtables to to_rehash */ | |
249 | SCM_SET_HASHTABLE_NEXT (h, to_rehash); | |
250 | to_rehash = h; | |
251 | *next = h = tmp; | |
252 | } | |
253 | else | |
254 | { | |
255 | next = SCM_HASHTABLE_NEXTLOC (h); | |
256 | h = SCM_HASHTABLE_NEXT (h); | |
257 | } | |
258 | } | |
259 | } | |
260 | return 0; | |
261 | } | |
262 | ||
263 | static void * | |
264 | rehash_after_gc (void *dummy1 SCM_UNUSED, | |
265 | void *dummy2 SCM_UNUSED, | |
266 | void *dummy3 SCM_UNUSED) | |
267 | { | |
d2e53ed6 | 268 | if (!scm_is_null (to_rehash)) |
c35738c1 | 269 | { |
e0245b20 | 270 | SCM first = to_rehash, last, h; |
15635be5 MD |
271 | /* important to clear to_rehash here so that we don't get stuck |
272 | in an infinite loop if scm_i_rehash causes GC */ | |
273 | to_rehash = SCM_EOL; | |
e0245b20 | 274 | h = first; |
c35738c1 MD |
275 | do |
276 | { | |
277 | scm_i_rehash (h, | |
278 | /* use same hash_fn and closure as last time */ | |
279 | SCM_HASHTABLE (h)->hash_fn, | |
280 | SCM_HASHTABLE (h)->closure, | |
281 | "rehash_after_gc"); | |
282 | last = h; | |
283 | h = SCM_HASHTABLE_NEXT (h); | |
d2e53ed6 | 284 | } while (!scm_is_null (h)); |
c35738c1 MD |
285 | /* move tables back to weak_hashtables */ |
286 | SCM_SET_HASHTABLE_NEXT (last, weak_hashtables); | |
e0245b20 | 287 | weak_hashtables = first; |
c35738c1 MD |
288 | } |
289 | return 0; | |
290 | } | |
291 | ||
f59a096e MD |
292 | static size_t |
293 | hashtable_free (SCM obj) | |
294 | { | |
295 | scm_gc_free (SCM_HASHTABLE (obj), sizeof (scm_t_hashtable), s_hashtable); | |
296 | return 0; | |
297 | } | |
298 | ||
299 | ||
00ffa0e7 | 300 | SCM |
c014a02e | 301 | scm_c_make_hash_table (unsigned long k) |
00ffa0e7 | 302 | { |
c35738c1 | 303 | return make_hash_table (0, k, "scm_c_make_hash_table"); |
f59a096e MD |
304 | } |
305 | ||
306 | SCM_DEFINE (scm_make_hash_table, "make-hash-table", 0, 1, 0, | |
307 | (SCM n), | |
c35738c1 | 308 | "Make a hash table with optional minimum number of buckets @var{n}\n") |
f59a096e MD |
309 | #define FUNC_NAME s_scm_make_hash_table |
310 | { | |
311 | if (SCM_UNBNDP (n)) | |
c35738c1 | 312 | return make_hash_table (0, 0, FUNC_NAME); |
f59a096e | 313 | else |
a55c2b68 | 314 | return make_hash_table (0, scm_to_ulong (n), FUNC_NAME); |
f59a096e MD |
315 | } |
316 | #undef FUNC_NAME | |
317 | ||
c35738c1 MD |
318 | SCM_DEFINE (scm_make_weak_key_hash_table, "make-weak-key-hash-table", 0, 1, 0, |
319 | (SCM n), | |
320 | "@deffnx {Scheme Procedure} make-weak-value-hash-table size\n" | |
321 | "@deffnx {Scheme Procedure} make-doubly-weak-hash-table size\n" | |
322 | "Return a weak hash table with @var{size} buckets. As with any\n" | |
323 | "hash table, choosing a good size for the table requires some\n" | |
324 | "caution.\n" | |
325 | "\n" | |
326 | "You can modify weak hash tables in exactly the same way you\n" | |
327 | "would modify regular hash tables. (@pxref{Hash Tables})") | |
328 | #define FUNC_NAME s_scm_make_weak_key_hash_table | |
f59a096e | 329 | { |
c35738c1 MD |
330 | if (SCM_UNBNDP (n)) |
331 | return make_hash_table (SCM_HASHTABLEF_WEAK_CAR, 0, FUNC_NAME); | |
f59a096e | 332 | else |
a55c2b68 MV |
333 | return make_hash_table (SCM_HASHTABLEF_WEAK_CAR, |
334 | scm_to_ulong (n), FUNC_NAME); | |
c35738c1 MD |
335 | } |
336 | #undef FUNC_NAME | |
337 | ||
338 | ||
339 | SCM_DEFINE (scm_make_weak_value_hash_table, "make-weak-value-hash-table", 0, 1, 0, | |
340 | (SCM n), | |
341 | "Return a hash table with weak values with @var{size} buckets.\n" | |
342 | "(@pxref{Hash Tables})") | |
343 | #define FUNC_NAME s_scm_make_weak_value_hash_table | |
344 | { | |
345 | if (SCM_UNBNDP (n)) | |
346 | return make_hash_table (SCM_HASHTABLEF_WEAK_CDR, 0, FUNC_NAME); | |
f59a096e | 347 | else |
c35738c1 | 348 | { |
a55c2b68 MV |
349 | return make_hash_table (SCM_HASHTABLEF_WEAK_CDR, |
350 | scm_to_ulong (n), FUNC_NAME); | |
f59a096e | 351 | } |
c35738c1 MD |
352 | } |
353 | #undef FUNC_NAME | |
f59a096e | 354 | |
c35738c1 MD |
355 | |
356 | SCM_DEFINE (scm_make_doubly_weak_hash_table, "make-doubly-weak-hash-table", 1, 0, 0, | |
357 | (SCM n), | |
358 | "Return a hash table with weak keys and values with @var{size}\n" | |
359 | "buckets. (@pxref{Hash Tables})") | |
360 | #define FUNC_NAME s_scm_make_doubly_weak_hash_table | |
361 | { | |
362 | if (SCM_UNBNDP (n)) | |
363 | return make_hash_table (SCM_HASHTABLEF_WEAK_CAR | SCM_HASHTABLEF_WEAK_CDR, | |
364 | 0, | |
365 | FUNC_NAME); | |
366 | else | |
f59a096e | 367 | { |
c35738c1 | 368 | return make_hash_table (SCM_HASHTABLEF_WEAK_CAR | SCM_HASHTABLEF_WEAK_CDR, |
a55c2b68 | 369 | scm_to_ulong (n), |
c35738c1 | 370 | FUNC_NAME); |
f59a096e | 371 | } |
f59a096e | 372 | } |
c35738c1 MD |
373 | #undef FUNC_NAME |
374 | ||
375 | ||
376 | SCM_DEFINE (scm_hash_table_p, "hash-table?", 1, 0, 0, | |
377 | (SCM obj), | |
378 | "Return @code{#t} if @var{obj} is a hash table.") | |
379 | #define FUNC_NAME s_scm_hash_table_p | |
380 | { | |
7888309b | 381 | return scm_from_bool (SCM_HASHTABLE_P (obj)); |
c35738c1 MD |
382 | } |
383 | #undef FUNC_NAME | |
384 | ||
385 | ||
386 | SCM_DEFINE (scm_weak_key_hash_table_p, "weak-key-hash-table?", 1, 0, 0, | |
387 | (SCM obj), | |
388 | "@deffnx {Scheme Procedure} weak-value-hash-table? obj\n" | |
389 | "@deffnx {Scheme Procedure} doubly-weak-hash-table? obj\n" | |
390 | "Return @code{#t} if @var{obj} is the specified weak hash\n" | |
391 | "table. Note that a doubly weak hash table is neither a weak key\n" | |
392 | "nor a weak value hash table.") | |
393 | #define FUNC_NAME s_scm_weak_key_hash_table_p | |
394 | { | |
7888309b | 395 | return scm_from_bool (SCM_HASHTABLE_P (obj) && SCM_HASHTABLE_WEAK_KEY_P (obj)); |
c35738c1 MD |
396 | } |
397 | #undef FUNC_NAME | |
398 | ||
399 | ||
400 | SCM_DEFINE (scm_weak_value_hash_table_p, "weak-value-hash-table?", 1, 0, 0, | |
401 | (SCM obj), | |
402 | "Return @code{#t} if @var{obj} is a weak value hash table.") | |
403 | #define FUNC_NAME s_scm_weak_value_hash_table_p | |
404 | { | |
7888309b | 405 | return scm_from_bool (SCM_HASHTABLE_P (obj) && SCM_HASHTABLE_WEAK_VALUE_P (obj)); |
c35738c1 MD |
406 | } |
407 | #undef FUNC_NAME | |
408 | ||
409 | ||
410 | SCM_DEFINE (scm_doubly_weak_hash_table_p, "doubly-weak-hash-table?", 1, 0, 0, | |
411 | (SCM obj), | |
412 | "Return @code{#t} if @var{obj} is a doubly weak hash table.") | |
413 | #define FUNC_NAME s_scm_doubly_weak_hash_table_p | |
414 | { | |
7888309b | 415 | return scm_from_bool (SCM_HASHTABLE_P (obj) && SCM_HASHTABLE_DOUBLY_WEAK_P (obj)); |
c35738c1 MD |
416 | } |
417 | #undef FUNC_NAME | |
418 | ||
22a52da1 | 419 | |
0f2d19dd | 420 | SCM |
34d19ef6 | 421 | scm_hash_fn_get_handle (SCM table, SCM obj, unsigned long (*hash_fn)(), SCM (*assoc_fn)(), void * closure) |
22a52da1 | 422 | #define FUNC_NAME "scm_hash_fn_get_handle" |
0f2d19dd | 423 | { |
c014a02e | 424 | unsigned long k; |
0f2d19dd JB |
425 | SCM h; |
426 | ||
f59a096e | 427 | if (SCM_HASHTABLE_P (table)) |
0a4c1355 | 428 | table = SCM_HASHTABLE_VECTOR (table); |
f59a096e | 429 | else |
0a4c1355 | 430 | SCM_VALIDATE_VECTOR (1, table); |
bfa974f0 | 431 | if (SCM_VECTOR_LENGTH (table) == 0) |
22a52da1 | 432 | return SCM_BOOL_F; |
bfa974f0 DH |
433 | k = hash_fn (obj, SCM_VECTOR_LENGTH (table), closure); |
434 | if (k >= SCM_VECTOR_LENGTH (table)) | |
b9bd8526 | 435 | scm_out_of_range ("hash_fn_get_handle", scm_from_ulong (k)); |
0f2d19dd JB |
436 | h = assoc_fn (obj, SCM_VELTS (table)[k], closure); |
437 | return h; | |
438 | } | |
22a52da1 | 439 | #undef FUNC_NAME |
0f2d19dd JB |
440 | |
441 | ||
0f2d19dd | 442 | SCM |
34d19ef6 HWN |
443 | scm_hash_fn_create_handle_x (SCM table, SCM obj, SCM init, unsigned long (*hash_fn)(), |
444 | SCM (*assoc_fn)(), void * closure) | |
cbaadf02 | 445 | #define FUNC_NAME "scm_hash_fn_create_handle_x" |
0f2d19dd | 446 | { |
c014a02e | 447 | unsigned long k; |
f59a096e | 448 | SCM buckets, it; |
0f2d19dd | 449 | |
f59a096e | 450 | if (SCM_HASHTABLE_P (table)) |
0a4c1355 | 451 | buckets = SCM_HASHTABLE_VECTOR (table); |
f59a096e MD |
452 | else |
453 | { | |
454 | SCM_ASSERT (SCM_VECTORP (table), | |
455 | table, SCM_ARG1, "hash_fn_create_handle_x"); | |
456 | buckets = table; | |
f59a096e MD |
457 | } |
458 | if (SCM_VECTOR_LENGTH (buckets) == 0) | |
cbaadf02 DH |
459 | SCM_MISC_ERROR ("void hashtable", SCM_EOL); |
460 | ||
f59a096e MD |
461 | k = hash_fn (obj, SCM_VECTOR_LENGTH (buckets), closure); |
462 | if (k >= SCM_VECTOR_LENGTH (buckets)) | |
b9bd8526 | 463 | scm_out_of_range ("hash_fn_create_handle_x", scm_from_ulong (k)); |
f59a096e | 464 | it = assoc_fn (obj, SCM_VELTS (buckets)[k], closure); |
7888309b | 465 | if (scm_is_true (it)) |
0a4c1355 | 466 | return it; |
ee083ac2 DH |
467 | else |
468 | { | |
0a4c1355 MD |
469 | SCM old_bucket = SCM_VELTS (buckets)[k]; |
470 | SCM new_bucket = scm_acons (obj, init, old_bucket); | |
471 | SCM_VECTOR_SET (buckets, k, new_bucket); | |
f59a096e MD |
472 | if (table != buckets) |
473 | { | |
474 | SCM_HASHTABLE_INCREMENT (table); | |
475 | if (SCM_HASHTABLE_N_ITEMS (table) > SCM_HASHTABLE_UPPER (table)) | |
c35738c1 | 476 | scm_i_rehash (table, hash_fn, closure, FUNC_NAME); |
f59a096e | 477 | } |
ee083ac2 DH |
478 | return SCM_CAR (new_bucket); |
479 | } | |
0f2d19dd | 480 | } |
cbaadf02 | 481 | #undef FUNC_NAME |
0f2d19dd | 482 | |
1cc91f1b | 483 | |
0f2d19dd | 484 | SCM |
34d19ef6 HWN |
485 | scm_hash_fn_ref (SCM table, SCM obj, SCM dflt, unsigned long (*hash_fn)(), |
486 | SCM (*assoc_fn)(), void * closure) | |
0f2d19dd | 487 | { |
22a52da1 | 488 | SCM it = scm_hash_fn_get_handle (table, obj, hash_fn, assoc_fn, closure); |
d2e53ed6 | 489 | if (scm_is_pair (it)) |
0f2d19dd | 490 | return SCM_CDR (it); |
22a52da1 DH |
491 | else |
492 | return dflt; | |
0f2d19dd JB |
493 | } |
494 | ||
495 | ||
496 | ||
1cc91f1b | 497 | |
0f2d19dd | 498 | SCM |
34d19ef6 HWN |
499 | scm_hash_fn_set_x (SCM table, SCM obj, SCM val, unsigned long (*hash_fn)(), |
500 | SCM (*assoc_fn)(), void * closure) | |
0f2d19dd JB |
501 | { |
502 | SCM it; | |
503 | ||
504 | it = scm_hash_fn_create_handle_x (table, obj, SCM_BOOL_F, hash_fn, assoc_fn, closure); | |
505 | SCM_SETCDR (it, val); | |
506 | return val; | |
507 | } | |
508 | ||
509 | ||
510 | ||
511 | ||
1cc91f1b | 512 | |
0f2d19dd | 513 | SCM |
34d19ef6 HWN |
514 | scm_hash_fn_remove_x (SCM table, SCM obj, unsigned long (*hash_fn)(), SCM (*assoc_fn)(), |
515 | SCM (*delete_fn)(), void * closure) | |
0f2d19dd | 516 | { |
c014a02e | 517 | unsigned long k; |
87ca11ff | 518 | SCM buckets, h; |
0f2d19dd | 519 | |
87ca11ff | 520 | if (SCM_HASHTABLE_P (table)) |
0a4c1355 | 521 | buckets = SCM_HASHTABLE_VECTOR (table); |
87ca11ff MD |
522 | else |
523 | { | |
524 | SCM_ASSERT (SCM_VECTORP (table), table, SCM_ARG1, "hash_fn_remove_x"); | |
525 | buckets = table; | |
87ca11ff | 526 | } |
bfa974f0 | 527 | if (SCM_VECTOR_LENGTH (table) == 0) |
0f2d19dd | 528 | return SCM_EOL; |
87ca11ff | 529 | |
87ca11ff MD |
530 | k = hash_fn (obj, SCM_VECTOR_LENGTH (buckets), closure); |
531 | if (k >= SCM_VECTOR_LENGTH (buckets)) | |
b9bd8526 | 532 | scm_out_of_range ("hash_fn_remove_x", scm_from_ulong (k)); |
87ca11ff | 533 | h = assoc_fn (obj, SCM_VELTS (buckets)[k], closure); |
7888309b | 534 | if (scm_is_true (h)) |
87ca11ff MD |
535 | { |
536 | SCM_VECTOR_SET (buckets, k, delete_fn (h, SCM_VELTS (buckets)[k])); | |
537 | if (table != buckets) | |
538 | { | |
539 | SCM_HASHTABLE_DECREMENT (table); | |
540 | if (SCM_HASHTABLE_N_ITEMS (table) < SCM_HASHTABLE_LOWER (table)) | |
c35738c1 | 541 | scm_i_rehash (table, hash_fn, closure, "scm_hash_fn_remove_x"); |
87ca11ff MD |
542 | } |
543 | } | |
0f2d19dd JB |
544 | return h; |
545 | } | |
546 | ||
c35738c1 MD |
547 | SCM_DEFINE (scm_hash_clear_x, "hash-clear!", 1, 0, 0, |
548 | (SCM table), | |
549 | "Remove all items from TABLE (without triggering a resize).") | |
550 | #define FUNC_NAME s_scm_hash_clear_x | |
551 | { | |
552 | SCM_VALIDATE_HASHTABLE (1, table); | |
553 | scm_vector_fill_x (SCM_HASHTABLE_VECTOR (table), SCM_EOL); | |
554 | SCM_SET_HASHTABLE_N_ITEMS (table, 0); | |
555 | return SCM_UNSPECIFIED; | |
556 | } | |
557 | #undef FUNC_NAME | |
0f2d19dd JB |
558 | |
559 | \f | |
560 | ||
a1ec6916 | 561 | SCM_DEFINE (scm_hashq_get_handle, "hashq-get-handle", 2, 0, 0, |
22a52da1 DH |
562 | (SCM table, SCM key), |
563 | "This procedure returns the @code{(key . value)} pair from the\n" | |
564 | "hash table @var{table}. If @var{table} does not hold an\n" | |
565 | "associated value for @var{key}, @code{#f} is returned.\n" | |
566 | "Uses @code{eq?} for equality testing.") | |
1bbd0b84 | 567 | #define FUNC_NAME s_scm_hashq_get_handle |
0f2d19dd | 568 | { |
22a52da1 | 569 | return scm_hash_fn_get_handle (table, key, scm_ihashq, scm_sloppy_assq, 0); |
0f2d19dd | 570 | } |
1bbd0b84 | 571 | #undef FUNC_NAME |
0f2d19dd JB |
572 | |
573 | ||
a1ec6916 | 574 | SCM_DEFINE (scm_hashq_create_handle_x, "hashq-create-handle!", 3, 0, 0, |
d550d22a GB |
575 | (SCM table, SCM key, SCM init), |
576 | "This function looks up @var{key} in @var{table} and returns its handle.\n" | |
b380b885 MD |
577 | "If @var{key} is not already present, a new handle is created which\n" |
578 | "associates @var{key} with @var{init}.") | |
1bbd0b84 | 579 | #define FUNC_NAME s_scm_hashq_create_handle_x |
0f2d19dd | 580 | { |
d550d22a | 581 | return scm_hash_fn_create_handle_x (table, key, init, scm_ihashq, scm_sloppy_assq, 0); |
0f2d19dd | 582 | } |
1bbd0b84 | 583 | #undef FUNC_NAME |
0f2d19dd JB |
584 | |
585 | ||
a1ec6916 | 586 | SCM_DEFINE (scm_hashq_ref, "hashq-ref", 2, 1, 0, |
1e6808ea | 587 | (SCM table, SCM key, SCM dflt), |
b380b885 MD |
588 | "Look up @var{key} in the hash table @var{table}, and return the\n" |
589 | "value (if any) associated with it. If @var{key} is not found,\n" | |
5352393c MG |
590 | "return @var{default} (or @code{#f} if no @var{default} argument\n" |
591 | "is supplied). Uses @code{eq?} for equality testing.") | |
1bbd0b84 | 592 | #define FUNC_NAME s_scm_hashq_ref |
0f2d19dd | 593 | { |
54778cd3 | 594 | if (SCM_UNBNDP (dflt)) |
0f2d19dd | 595 | dflt = SCM_BOOL_F; |
1e6808ea | 596 | return scm_hash_fn_ref (table, key, dflt, scm_ihashq, scm_sloppy_assq, 0); |
0f2d19dd | 597 | } |
1bbd0b84 | 598 | #undef FUNC_NAME |
0f2d19dd JB |
599 | |
600 | ||
601 | ||
a1ec6916 | 602 | SCM_DEFINE (scm_hashq_set_x, "hashq-set!", 3, 0, 0, |
1e6808ea | 603 | (SCM table, SCM key, SCM val), |
5352393c MG |
604 | "Find the entry in @var{table} associated with @var{key}, and\n" |
605 | "store @var{value} there. Uses @code{eq?} for equality testing.") | |
1bbd0b84 | 606 | #define FUNC_NAME s_scm_hashq_set_x |
0f2d19dd | 607 | { |
1e6808ea | 608 | return scm_hash_fn_set_x (table, key, val, scm_ihashq, scm_sloppy_assq, 0); |
0f2d19dd | 609 | } |
1bbd0b84 | 610 | #undef FUNC_NAME |
0f2d19dd JB |
611 | |
612 | ||
613 | ||
a1ec6916 | 614 | SCM_DEFINE (scm_hashq_remove_x, "hashq-remove!", 2, 0, 0, |
1e6808ea | 615 | (SCM table, SCM key), |
5352393c MG |
616 | "Remove @var{key} (and any value associated with it) from\n" |
617 | "@var{table}. Uses @code{eq?} for equality tests.") | |
1bbd0b84 | 618 | #define FUNC_NAME s_scm_hashq_remove_x |
0f2d19dd | 619 | { |
1e6808ea MG |
620 | return scm_hash_fn_remove_x (table, key, scm_ihashq, scm_sloppy_assq, |
621 | scm_delq_x, 0); | |
0f2d19dd | 622 | } |
1bbd0b84 | 623 | #undef FUNC_NAME |
0f2d19dd JB |
624 | |
625 | ||
626 | \f | |
627 | ||
a1ec6916 | 628 | SCM_DEFINE (scm_hashv_get_handle, "hashv-get-handle", 2, 0, 0, |
22a52da1 DH |
629 | (SCM table, SCM key), |
630 | "This procedure returns the @code{(key . value)} pair from the\n" | |
631 | "hash table @var{table}. If @var{table} does not hold an\n" | |
632 | "associated value for @var{key}, @code{#f} is returned.\n" | |
633 | "Uses @code{eqv?} for equality testing.") | |
1bbd0b84 | 634 | #define FUNC_NAME s_scm_hashv_get_handle |
0f2d19dd | 635 | { |
22a52da1 | 636 | return scm_hash_fn_get_handle (table, key, scm_ihashv, scm_sloppy_assv, 0); |
0f2d19dd | 637 | } |
1bbd0b84 | 638 | #undef FUNC_NAME |
0f2d19dd JB |
639 | |
640 | ||
a1ec6916 | 641 | SCM_DEFINE (scm_hashv_create_handle_x, "hashv-create-handle!", 3, 0, 0, |
d550d22a GB |
642 | (SCM table, SCM key, SCM init), |
643 | "This function looks up @var{key} in @var{table} and returns its handle.\n" | |
644 | "If @var{key} is not already present, a new handle is created which\n" | |
645 | "associates @var{key} with @var{init}.") | |
1bbd0b84 | 646 | #define FUNC_NAME s_scm_hashv_create_handle_x |
0f2d19dd | 647 | { |
1e6808ea MG |
648 | return scm_hash_fn_create_handle_x (table, key, init, scm_ihashv, |
649 | scm_sloppy_assv, 0); | |
0f2d19dd | 650 | } |
1bbd0b84 | 651 | #undef FUNC_NAME |
0f2d19dd JB |
652 | |
653 | ||
a1ec6916 | 654 | SCM_DEFINE (scm_hashv_ref, "hashv-ref", 2, 1, 0, |
1e6808ea | 655 | (SCM table, SCM key, SCM dflt), |
d550d22a GB |
656 | "Look up @var{key} in the hash table @var{table}, and return the\n" |
657 | "value (if any) associated with it. If @var{key} is not found,\n" | |
5352393c MG |
658 | "return @var{default} (or @code{#f} if no @var{default} argument\n" |
659 | "is supplied). Uses @code{eqv?} for equality testing.") | |
1bbd0b84 | 660 | #define FUNC_NAME s_scm_hashv_ref |
0f2d19dd | 661 | { |
54778cd3 | 662 | if (SCM_UNBNDP (dflt)) |
0f2d19dd | 663 | dflt = SCM_BOOL_F; |
1e6808ea | 664 | return scm_hash_fn_ref (table, key, dflt, scm_ihashv, scm_sloppy_assv, 0); |
0f2d19dd | 665 | } |
1bbd0b84 | 666 | #undef FUNC_NAME |
0f2d19dd JB |
667 | |
668 | ||
669 | ||
a1ec6916 | 670 | SCM_DEFINE (scm_hashv_set_x, "hashv-set!", 3, 0, 0, |
1e6808ea | 671 | (SCM table, SCM key, SCM val), |
5352393c MG |
672 | "Find the entry in @var{table} associated with @var{key}, and\n" |
673 | "store @var{value} there. Uses @code{eqv?} for equality testing.") | |
1bbd0b84 | 674 | #define FUNC_NAME s_scm_hashv_set_x |
0f2d19dd | 675 | { |
1e6808ea | 676 | return scm_hash_fn_set_x (table, key, val, scm_ihashv, scm_sloppy_assv, 0); |
0f2d19dd | 677 | } |
1bbd0b84 | 678 | #undef FUNC_NAME |
0f2d19dd JB |
679 | |
680 | ||
a1ec6916 | 681 | SCM_DEFINE (scm_hashv_remove_x, "hashv-remove!", 2, 0, 0, |
1e6808ea | 682 | (SCM table, SCM key), |
5352393c MG |
683 | "Remove @var{key} (and any value associated with it) from\n" |
684 | "@var{table}. Uses @code{eqv?} for equality tests.") | |
1bbd0b84 | 685 | #define FUNC_NAME s_scm_hashv_remove_x |
0f2d19dd | 686 | { |
1e6808ea MG |
687 | return scm_hash_fn_remove_x (table, key, scm_ihashv, scm_sloppy_assv, |
688 | scm_delv_x, 0); | |
0f2d19dd | 689 | } |
1bbd0b84 | 690 | #undef FUNC_NAME |
0f2d19dd JB |
691 | |
692 | \f | |
693 | ||
a1ec6916 | 694 | SCM_DEFINE (scm_hash_get_handle, "hash-get-handle", 2, 0, 0, |
22a52da1 DH |
695 | (SCM table, SCM key), |
696 | "This procedure returns the @code{(key . value)} pair from the\n" | |
697 | "hash table @var{table}. If @var{table} does not hold an\n" | |
698 | "associated value for @var{key}, @code{#f} is returned.\n" | |
699 | "Uses @code{equal?} for equality testing.") | |
1bbd0b84 | 700 | #define FUNC_NAME s_scm_hash_get_handle |
0f2d19dd | 701 | { |
22a52da1 | 702 | return scm_hash_fn_get_handle (table, key, scm_ihash, scm_sloppy_assoc, 0); |
0f2d19dd | 703 | } |
1bbd0b84 | 704 | #undef FUNC_NAME |
0f2d19dd JB |
705 | |
706 | ||
a1ec6916 | 707 | SCM_DEFINE (scm_hash_create_handle_x, "hash-create-handle!", 3, 0, 0, |
d550d22a GB |
708 | (SCM table, SCM key, SCM init), |
709 | "This function looks up @var{key} in @var{table} and returns its handle.\n" | |
710 | "If @var{key} is not already present, a new handle is created which\n" | |
711 | "associates @var{key} with @var{init}.") | |
1bbd0b84 | 712 | #define FUNC_NAME s_scm_hash_create_handle_x |
0f2d19dd | 713 | { |
d550d22a | 714 | return scm_hash_fn_create_handle_x (table, key, init, scm_ihash, scm_sloppy_assoc, 0); |
0f2d19dd | 715 | } |
1bbd0b84 | 716 | #undef FUNC_NAME |
0f2d19dd JB |
717 | |
718 | ||
a1ec6916 | 719 | SCM_DEFINE (scm_hash_ref, "hash-ref", 2, 1, 0, |
1e6808ea | 720 | (SCM table, SCM key, SCM dflt), |
d550d22a GB |
721 | "Look up @var{key} in the hash table @var{table}, and return the\n" |
722 | "value (if any) associated with it. If @var{key} is not found,\n" | |
5352393c MG |
723 | "return @var{default} (or @code{#f} if no @var{default} argument\n" |
724 | "is supplied). Uses @code{equal?} for equality testing.") | |
1bbd0b84 | 725 | #define FUNC_NAME s_scm_hash_ref |
0f2d19dd | 726 | { |
54778cd3 | 727 | if (SCM_UNBNDP (dflt)) |
0f2d19dd | 728 | dflt = SCM_BOOL_F; |
1e6808ea | 729 | return scm_hash_fn_ref (table, key, dflt, scm_ihash, scm_sloppy_assoc, 0); |
0f2d19dd | 730 | } |
1bbd0b84 | 731 | #undef FUNC_NAME |
0f2d19dd JB |
732 | |
733 | ||
734 | ||
a1ec6916 | 735 | SCM_DEFINE (scm_hash_set_x, "hash-set!", 3, 0, 0, |
1e6808ea | 736 | (SCM table, SCM key, SCM val), |
5352393c MG |
737 | "Find the entry in @var{table} associated with @var{key}, and\n" |
738 | "store @var{value} there. Uses @code{equal?} for equality\n" | |
739 | "testing.") | |
1bbd0b84 | 740 | #define FUNC_NAME s_scm_hash_set_x |
0f2d19dd | 741 | { |
1e6808ea | 742 | return scm_hash_fn_set_x (table, key, val, scm_ihash, scm_sloppy_assoc, 0); |
0f2d19dd | 743 | } |
1bbd0b84 | 744 | #undef FUNC_NAME |
0f2d19dd JB |
745 | |
746 | ||
747 | ||
a1ec6916 | 748 | SCM_DEFINE (scm_hash_remove_x, "hash-remove!", 2, 0, 0, |
1e6808ea | 749 | (SCM table, SCM key), |
5352393c MG |
750 | "Remove @var{key} (and any value associated with it) from\n" |
751 | "@var{table}. Uses @code{equal?} for equality tests.") | |
1bbd0b84 | 752 | #define FUNC_NAME s_scm_hash_remove_x |
0f2d19dd | 753 | { |
1e6808ea MG |
754 | return scm_hash_fn_remove_x (table, key, scm_ihash, scm_sloppy_assoc, |
755 | scm_delete_x, 0); | |
0f2d19dd | 756 | } |
1bbd0b84 | 757 | #undef FUNC_NAME |
0f2d19dd JB |
758 | |
759 | \f | |
760 | ||
761 | ||
92c2555f | 762 | typedef struct scm_t_ihashx_closure |
0f2d19dd JB |
763 | { |
764 | SCM hash; | |
765 | SCM assoc; | |
766 | SCM delete; | |
92c2555f | 767 | } scm_t_ihashx_closure; |
0f2d19dd JB |
768 | |
769 | ||
1cc91f1b | 770 | |
c014a02e | 771 | static unsigned long |
92c2555f | 772 | scm_ihashx (SCM obj, unsigned long n, scm_t_ihashx_closure *closure) |
0f2d19dd | 773 | { |
b9bd8526 | 774 | SCM answer = scm_call_2 (closure->hash, obj, scm_from_ulong (n)); |
a55c2b68 | 775 | return scm_to_ulong (answer); |
0f2d19dd JB |
776 | } |
777 | ||
778 | ||
1cc91f1b | 779 | |
0f2d19dd | 780 | static SCM |
92c2555f | 781 | scm_sloppy_assx (SCM obj, SCM alist, scm_t_ihashx_closure *closure) |
0f2d19dd | 782 | { |
87ca11ff | 783 | return scm_call_2 (closure->assoc, obj, alist); |
0f2d19dd JB |
784 | } |
785 | ||
786 | ||
787 | ||
1cc91f1b | 788 | |
0f2d19dd | 789 | static SCM |
92c2555f | 790 | scm_delx_x (SCM obj, SCM alist, scm_t_ihashx_closure *closure) |
0f2d19dd | 791 | { |
87ca11ff | 792 | return scm_call_2 (closure->delete, obj, alist); |
0f2d19dd JB |
793 | } |
794 | ||
795 | ||
796 | ||
a1ec6916 | 797 | SCM_DEFINE (scm_hashx_get_handle, "hashx-get-handle", 4, 0, 0, |
1e6808ea MG |
798 | (SCM hash, SCM assoc, SCM table, SCM key), |
799 | "This behaves the same way as the corresponding\n" | |
800 | "@code{-get-handle} function, but uses @var{hash} as a hash\n" | |
801 | "function and @var{assoc} to compare keys. @code{hash} must be\n" | |
802 | "a function that takes two arguments, a key to be hashed and a\n" | |
d550d22a GB |
803 | "table size. @code{assoc} must be an associator function, like\n" |
804 | "@code{assoc}, @code{assq} or @code{assv}.") | |
1bbd0b84 | 805 | #define FUNC_NAME s_scm_hashx_get_handle |
0f2d19dd | 806 | { |
92c2555f | 807 | scm_t_ihashx_closure closure; |
0f2d19dd JB |
808 | closure.hash = hash; |
809 | closure.assoc = assoc; | |
1e6808ea | 810 | return scm_hash_fn_get_handle (table, key, scm_ihashx, scm_sloppy_assx, |
87ca11ff | 811 | (void *) &closure); |
0f2d19dd | 812 | } |
1bbd0b84 | 813 | #undef FUNC_NAME |
0f2d19dd JB |
814 | |
815 | ||
a1ec6916 | 816 | SCM_DEFINE (scm_hashx_create_handle_x, "hashx-create-handle!", 5, 0, 0, |
1e6808ea MG |
817 | (SCM hash, SCM assoc, SCM table, SCM key, SCM init), |
818 | "This behaves the same way as the corresponding\n" | |
819 | "@code{-create-handle} function, but uses @var{hash} as a hash\n" | |
820 | "function and @var{assoc} to compare keys. @code{hash} must be\n" | |
821 | "a function that takes two arguments, a key to be hashed and a\n" | |
d550d22a GB |
822 | "table size. @code{assoc} must be an associator function, like\n" |
823 | "@code{assoc}, @code{assq} or @code{assv}.") | |
1bbd0b84 | 824 | #define FUNC_NAME s_scm_hashx_create_handle_x |
0f2d19dd | 825 | { |
92c2555f | 826 | scm_t_ihashx_closure closure; |
0f2d19dd JB |
827 | closure.hash = hash; |
828 | closure.assoc = assoc; | |
1e6808ea MG |
829 | return scm_hash_fn_create_handle_x (table, key, init, scm_ihashx, |
830 | scm_sloppy_assx, (void *)&closure); | |
0f2d19dd | 831 | } |
1bbd0b84 | 832 | #undef FUNC_NAME |
0f2d19dd JB |
833 | |
834 | ||
835 | ||
a1ec6916 | 836 | SCM_DEFINE (scm_hashx_ref, "hashx-ref", 4, 1, 0, |
1e6808ea | 837 | (SCM hash, SCM assoc, SCM table, SCM key, SCM dflt), |
d550d22a | 838 | "This behaves the same way as the corresponding @code{ref}\n" |
1e6808ea MG |
839 | "function, but uses @var{hash} as a hash function and\n" |
840 | "@var{assoc} to compare keys. @code{hash} must be a function\n" | |
841 | "that takes two arguments, a key to be hashed and a table size.\n" | |
842 | "@code{assoc} must be an associator function, like @code{assoc},\n" | |
843 | "@code{assq} or @code{assv}.\n" | |
844 | "\n" | |
845 | "By way of illustration, @code{hashq-ref table key} is\n" | |
846 | "equivalent to @code{hashx-ref hashq assq table key}.") | |
1bbd0b84 | 847 | #define FUNC_NAME s_scm_hashx_ref |
0f2d19dd | 848 | { |
92c2555f | 849 | scm_t_ihashx_closure closure; |
54778cd3 | 850 | if (SCM_UNBNDP (dflt)) |
0f2d19dd JB |
851 | dflt = SCM_BOOL_F; |
852 | closure.hash = hash; | |
853 | closure.assoc = assoc; | |
1e6808ea MG |
854 | return scm_hash_fn_ref (table, key, dflt, scm_ihashx, scm_sloppy_assx, |
855 | (void *)&closure); | |
0f2d19dd | 856 | } |
1bbd0b84 | 857 | #undef FUNC_NAME |
0f2d19dd JB |
858 | |
859 | ||
860 | ||
861 | ||
a1ec6916 | 862 | SCM_DEFINE (scm_hashx_set_x, "hashx-set!", 5, 0, 0, |
1e6808ea | 863 | (SCM hash, SCM assoc, SCM table, SCM key, SCM val), |
d550d22a | 864 | "This behaves the same way as the corresponding @code{set!}\n" |
1e6808ea MG |
865 | "function, but uses @var{hash} as a hash function and\n" |
866 | "@var{assoc} to compare keys. @code{hash} must be a function\n" | |
867 | "that takes two arguments, a key to be hashed and a table size.\n" | |
868 | "@code{assoc} must be an associator function, like @code{assoc},\n" | |
869 | "@code{assq} or @code{assv}.\n" | |
870 | "\n" | |
871 | " By way of illustration, @code{hashq-set! table key} is\n" | |
872 | "equivalent to @code{hashx-set! hashq assq table key}.") | |
1bbd0b84 | 873 | #define FUNC_NAME s_scm_hashx_set_x |
0f2d19dd | 874 | { |
92c2555f | 875 | scm_t_ihashx_closure closure; |
0f2d19dd JB |
876 | closure.hash = hash; |
877 | closure.assoc = assoc; | |
1e6808ea MG |
878 | return scm_hash_fn_set_x (table, key, val, scm_ihashx, scm_sloppy_assx, |
879 | (void *)&closure); | |
0f2d19dd | 880 | } |
1bbd0b84 | 881 | #undef FUNC_NAME |
0f2d19dd JB |
882 | |
883 | ||
1cc91f1b | 884 | |
0f2d19dd | 885 | SCM |
1be6b49c | 886 | scm_hashx_remove_x (SCM hash, SCM assoc, SCM delete, SCM table, SCM obj) |
0f2d19dd | 887 | { |
92c2555f | 888 | scm_t_ihashx_closure closure; |
0f2d19dd JB |
889 | closure.hash = hash; |
890 | closure.assoc = assoc; | |
891 | closure.delete = delete; | |
892 | return scm_hash_fn_remove_x (table, obj, scm_ihashx, scm_sloppy_assx, scm_delx_x, 0); | |
893 | } | |
894 | ||
711a9fd7 | 895 | /* Hash table iterators */ |
b94903c2 | 896 | |
711a9fd7 | 897 | static const char s_scm_hash_fold[]; |
c7df61cd MD |
898 | |
899 | SCM | |
8cd5191b | 900 | scm_internal_hash_fold (SCM (*fn) (), void *closure, SCM init, SCM table) |
c7df61cd | 901 | { |
87ca11ff MD |
902 | long i, n; |
903 | SCM buckets, result = init; | |
87ca11ff MD |
904 | |
905 | if (SCM_HASHTABLE_P (table)) | |
0a4c1355 | 906 | buckets = SCM_HASHTABLE_VECTOR (table); |
87ca11ff | 907 | else |
0a4c1355 MD |
908 | buckets = table; |
909 | ||
87ca11ff | 910 | n = SCM_VECTOR_LENGTH (buckets); |
c7df61cd MD |
911 | for (i = 0; i < n; ++i) |
912 | { | |
87ca11ff | 913 | SCM ls = SCM_VELTS (buckets)[i], handle; |
d2e53ed6 | 914 | while (!scm_is_null (ls)) |
c7df61cd | 915 | { |
d2e53ed6 | 916 | if (!scm_is_pair (ls)) |
0a4c1355 | 917 | scm_wrong_type_arg (s_scm_hash_fold, SCM_ARG3, buckets); |
c7df61cd | 918 | handle = SCM_CAR (ls); |
d2e53ed6 | 919 | if (!scm_is_pair (handle)) |
0a4c1355 | 920 | scm_wrong_type_arg (s_scm_hash_fold, SCM_ARG3, buckets); |
c7df61cd MD |
921 | result = fn (closure, SCM_CAR (handle), SCM_CDR (handle), result); |
922 | ls = SCM_CDR (ls); | |
923 | } | |
924 | } | |
87ca11ff | 925 | |
c7df61cd MD |
926 | return result; |
927 | } | |
928 | ||
711a9fd7 MD |
929 | /* The following redundant code is here in order to be able to support |
930 | hash-for-each-handle. An alternative would have been to replace | |
931 | this code and scm_internal_hash_fold above with a single | |
932 | scm_internal_hash_fold_handles, but we don't want to promote such | |
933 | an API. */ | |
934 | ||
935 | static const char s_scm_hash_for_each[]; | |
936 | ||
937 | void | |
938 | scm_internal_hash_for_each_handle (SCM (*fn) (), void *closure, SCM table) | |
939 | { | |
940 | long i, n; | |
941 | SCM buckets; | |
942 | ||
943 | if (SCM_HASHTABLE_P (table)) | |
944 | buckets = SCM_HASHTABLE_VECTOR (table); | |
945 | else | |
946 | buckets = table; | |
947 | ||
948 | n = SCM_VECTOR_LENGTH (buckets); | |
949 | for (i = 0; i < n; ++i) | |
950 | { | |
951 | SCM ls = SCM_VELTS (buckets)[i], handle; | |
d2e53ed6 | 952 | while (!scm_is_null (ls)) |
711a9fd7 | 953 | { |
d2e53ed6 | 954 | if (!scm_is_pair (ls)) |
711a9fd7 MD |
955 | scm_wrong_type_arg (s_scm_hash_for_each, SCM_ARG3, buckets); |
956 | handle = SCM_CAR (ls); | |
d2e53ed6 | 957 | if (!scm_is_pair (handle)) |
711a9fd7 MD |
958 | scm_wrong_type_arg (s_scm_hash_for_each, SCM_ARG3, buckets); |
959 | fn (closure, handle); | |
960 | ls = SCM_CDR (ls); | |
961 | } | |
962 | } | |
963 | } | |
964 | ||
965 | SCM_DEFINE (scm_hash_fold, "hash-fold", 3, 0, 0, | |
966 | (SCM proc, SCM init, SCM table), | |
967 | "An iterator over hash-table elements.\n" | |
968 | "Accumulates and returns a result by applying PROC successively.\n" | |
969 | "The arguments to PROC are \"(key value prior-result)\" where key\n" | |
970 | "and value are successive pairs from the hash table TABLE, and\n" | |
971 | "prior-result is either INIT (for the first application of PROC)\n" | |
972 | "or the return value of the previous application of PROC.\n" | |
973 | "For example, @code{(hash-fold acons '() tab)} will convert a hash\n" | |
974 | "table into an a-list of key-value pairs.") | |
975 | #define FUNC_NAME s_scm_hash_fold | |
976 | { | |
977 | SCM_VALIDATE_PROC (1, proc); | |
978 | if (!SCM_HASHTABLE_P (table)) | |
979 | SCM_VALIDATE_VECTOR (3, table); | |
980 | return scm_internal_hash_fold (scm_call_3, (void *) SCM_UNPACK (proc), init, table); | |
981 | } | |
982 | #undef FUNC_NAME | |
983 | ||
c35738c1 | 984 | static SCM |
711a9fd7 | 985 | for_each_proc (void *proc, SCM handle) |
c35738c1 | 986 | { |
711a9fd7 | 987 | return scm_call_2 (SCM_PACK (proc), SCM_CAR (handle), SCM_CDR (handle)); |
c35738c1 MD |
988 | } |
989 | ||
990 | SCM_DEFINE (scm_hash_for_each, "hash-for-each", 2, 0, 0, | |
991 | (SCM proc, SCM table), | |
992 | "An iterator over hash-table elements.\n" | |
993 | "Applies PROC successively on all hash table items.\n" | |
994 | "The arguments to PROC are \"(key value)\" where key\n" | |
995 | "and value are successive pairs from the hash table TABLE.") | |
996 | #define FUNC_NAME s_scm_hash_for_each | |
997 | { | |
998 | SCM_VALIDATE_PROC (1, proc); | |
999 | if (!SCM_HASHTABLE_P (table)) | |
1000 | SCM_VALIDATE_VECTOR (2, table); | |
711a9fd7 MD |
1001 | |
1002 | scm_internal_hash_for_each_handle (for_each_proc, | |
1003 | (void *) SCM_UNPACK (proc), | |
1004 | table); | |
1005 | return SCM_UNSPECIFIED; | |
1006 | } | |
1007 | #undef FUNC_NAME | |
1008 | ||
1009 | SCM_DEFINE (scm_hash_for_each_handle, "hash-for-each-handle", 2, 0, 0, | |
1010 | (SCM proc, SCM table), | |
1011 | "An iterator over hash-table elements.\n" | |
1012 | "Applies PROC successively on all hash table handles.") | |
1013 | #define FUNC_NAME s_scm_hash_for_each_handle | |
1014 | { | |
1015 | scm_t_trampoline_1 call = scm_trampoline_1 (proc); | |
1016 | SCM_ASSERT (call, proc, 1, FUNC_NAME); | |
1017 | if (!SCM_HASHTABLE_P (table)) | |
1018 | SCM_VALIDATE_VECTOR (2, table); | |
1019 | ||
1020 | scm_internal_hash_for_each_handle (call, | |
1021 | (void *) SCM_UNPACK (proc), | |
1022 | table); | |
c35738c1 MD |
1023 | return SCM_UNSPECIFIED; |
1024 | } | |
1025 | #undef FUNC_NAME | |
1026 | ||
1027 | static SCM | |
1028 | map_proc (void *proc, SCM key, SCM data, SCM value) | |
1029 | { | |
1030 | return scm_cons (scm_call_2 (SCM_PACK (proc), key, data), value); | |
1031 | } | |
1032 | ||
711a9fd7 | 1033 | SCM_DEFINE (scm_hash_map_to_list, "hash-map->list", 2, 0, 0, |
c35738c1 MD |
1034 | (SCM proc, SCM table), |
1035 | "An iterator over hash-table elements.\n" | |
1036 | "Accumulates and returns as a list the results of applying PROC successively.\n" | |
1037 | "The arguments to PROC are \"(key value)\" where key\n" | |
1038 | "and value are successive pairs from the hash table TABLE.") | |
711a9fd7 | 1039 | #define FUNC_NAME s_scm_hash_map_to_list |
c35738c1 MD |
1040 | { |
1041 | SCM_VALIDATE_PROC (1, proc); | |
1042 | if (!SCM_HASHTABLE_P (table)) | |
1043 | SCM_VALIDATE_VECTOR (2, table); | |
1044 | return scm_internal_hash_fold (map_proc, | |
1045 | (void *) SCM_UNPACK (proc), | |
1046 | SCM_EOL, | |
1047 | table); | |
1048 | } | |
1049 | #undef FUNC_NAME | |
1050 | ||
0f2d19dd JB |
1051 | \f |
1052 | ||
1cc91f1b | 1053 | |
0f2d19dd | 1054 | void |
c35738c1 | 1055 | scm_hashtab_prehistory () |
0f2d19dd | 1056 | { |
f59a096e MD |
1057 | scm_tc16_hashtable = scm_make_smob_type (s_hashtable, 0); |
1058 | scm_set_smob_mark (scm_tc16_hashtable, scm_markcdr); | |
1059 | scm_set_smob_print (scm_tc16_hashtable, hashtable_print); | |
1060 | scm_set_smob_free (scm_tc16_hashtable, hashtable_free); | |
c35738c1 MD |
1061 | scm_c_hook_add (&scm_after_sweep_c_hook, scan_weak_hashtables, 0, 0); |
1062 | scm_c_hook_add (&scm_after_gc_c_hook, rehash_after_gc, 0, 0); | |
1063 | } | |
1064 | ||
1065 | void | |
1066 | scm_init_hashtab () | |
1067 | { | |
a0599745 | 1068 | #include "libguile/hashtab.x" |
0f2d19dd | 1069 | } |
89e00824 ML |
1070 | |
1071 | /* | |
1072 | Local Variables: | |
1073 | c-file-style: "gnu" | |
1074 | End: | |
1075 | */ |