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