Commit | Line | Data |
---|---|---|
328255e4 | 1 | /* Copyright (C) 1995,1996,1998,1999,2000,2001, 2003, 2004, 2006, 2008, 2009, 2010, 2011 Free Software Foundation, Inc. |
0f2d19dd | 2 | * |
73be1d9e | 3 | * This library is free software; you can redistribute it and/or |
53befeb7 NJ |
4 | * modify it under the terms of the GNU Lesser General Public License |
5 | * as published by the Free Software Foundation; either version 3 of | |
6 | * the License, or (at your option) any later version. | |
0f2d19dd | 7 | * |
53befeb7 NJ |
8 | * This library is distributed in the hope that it will be useful, but |
9 | * WITHOUT ANY WARRANTY; without even the implied warranty of | |
73be1d9e MV |
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 | |
53befeb7 NJ |
15 | * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA |
16 | * 02110-1301 USA | |
73be1d9e | 17 | */ |
1bbd0b84 | 18 | |
1bbd0b84 | 19 | |
0f2d19dd | 20 | \f |
dbb605f5 LC |
21 | #ifdef HAVE_CONFIG_H |
22 | # include <config.h> | |
23 | #endif | |
0f2d19dd | 24 | |
cdd47ec7 | 25 | #include <alloca.h> |
06c1d900 | 26 | #include <stdio.h> |
63229905 | 27 | #include <assert.h> |
06c1d900 | 28 | |
a0599745 MD |
29 | #include "libguile/_scm.h" |
30 | #include "libguile/alist.h" | |
31 | #include "libguile/hash.h" | |
32 | #include "libguile/eval.h" | |
fdc28395 | 33 | #include "libguile/root.h" |
a0599745 | 34 | #include "libguile/vectors.h" |
f59a096e | 35 | #include "libguile/ports.h" |
62c290e9 | 36 | #include "libguile/bdw-gc.h" |
a0599745 MD |
37 | |
38 | #include "libguile/validate.h" | |
39 | #include "libguile/hashtab.h" | |
e4d21e6b | 40 | |
e4d21e6b | 41 | |
0f2d19dd JB |
42 | \f |
43 | ||
c99de5aa | 44 | /* A hash table is a cell containing a vector of association lists. |
c35738c1 MD |
45 | * |
46 | * Growing or shrinking, with following rehashing, is triggered when | |
47 | * the load factor | |
48 | * | |
49 | * L = N / S (N: number of items in table, S: bucket vector length) | |
50 | * | |
51 | * passes an upper limit of 0.9 or a lower limit of 0.25. | |
52 | * | |
53 | * The implementation stores the upper and lower number of items which | |
54 | * trigger a resize in the hashtable object. | |
55 | * | |
56 | * Possible hash table sizes (primes) are stored in the array | |
57 | * hashtable_size. | |
f59a096e MD |
58 | */ |
59 | ||
0a4c1355 MD |
60 | static unsigned long hashtable_size[] = { |
61 | 31, 61, 113, 223, 443, 883, 1759, 3517, 7027, 14051, 28099, 56197, 112363, | |
93777082 | 62 | 224717, 449419, 898823, 1797641, 3595271, 7190537, 14381041 |
328255e4 AW |
63 | #if SIZEOF_SCM_T_BITS > 4 |
64 | /* vector lengths are stored in the first word of vectors, shifted by | |
65 | 8 bits for the tc8, so for 32-bit we only get 2^24-1 = 16777215 | |
66 | elements. But we allow a few more sizes for 64-bit. */ | |
67 | , 28762081, 57524111, 115048217, 230096423, 460192829 | |
93777082 | 68 | #endif |
f59a096e MD |
69 | }; |
70 | ||
93777082 MV |
71 | #define HASHTABLE_SIZE_N (sizeof(hashtable_size)/sizeof(unsigned long)) |
72 | ||
f59a096e MD |
73 | static char *s_hashtable = "hashtable"; |
74 | ||
3a2de079 | 75 | static SCM |
54a9b981 | 76 | make_hash_table (unsigned long k, const char *func_name) |
a9cf5c71 | 77 | { |
c99de5aa | 78 | SCM vector; |
9358af6a | 79 | scm_t_hashtable *t; |
110beb83 | 80 | int i = 0, n = k ? k : 31; |
7c888dfa | 81 | while (i + 1 < HASHTABLE_SIZE_N && n > hashtable_size[i]) |
110beb83 MD |
82 | ++i; |
83 | n = hashtable_size[i]; | |
3a2de079 | 84 | |
3a2de079 LC |
85 | vector = scm_c_make_vector (n, SCM_EOL); |
86 | ||
87 | t = scm_gc_malloc_pointerless (sizeof (*t), s_hashtable); | |
c35738c1 | 88 | t->min_size_index = t->size_index = i; |
f59a096e | 89 | t->n_items = 0; |
c35738c1 | 90 | t->lower = 0; |
110beb83 | 91 | t->upper = 9 * n / 10; |
c6a35e35 | 92 | |
c99de5aa AW |
93 | /* FIXME: we just need two words of storage, not three */ |
94 | return scm_double_cell (scm_tc7_hashtable, SCM_UNPACK (vector), | |
95 | (scm_t_bits)t, 0); | |
f59a096e MD |
96 | } |
97 | ||
c35738c1 MD |
98 | void |
99 | scm_i_rehash (SCM table, | |
f044da55 | 100 | scm_t_hash_fn hash_fn, |
c35738c1 MD |
101 | void *closure, |
102 | const char* func_name) | |
103 | { | |
104 | SCM buckets, new_buckets; | |
105 | int i; | |
106 | unsigned long old_size; | |
107 | unsigned long new_size; | |
108 | ||
109 | if (SCM_HASHTABLE_N_ITEMS (table) < SCM_HASHTABLE_LOWER (table)) | |
110 | { | |
111 | /* rehashing is not triggered when i <= min_size */ | |
112 | i = SCM_HASHTABLE (table)->size_index; | |
113 | do | |
114 | --i; | |
115 | while (i > SCM_HASHTABLE (table)->min_size_index | |
116 | && SCM_HASHTABLE_N_ITEMS (table) < hashtable_size[i] / 4); | |
117 | } | |
118 | else | |
119 | { | |
120 | i = SCM_HASHTABLE (table)->size_index + 1; | |
121 | if (i >= HASHTABLE_SIZE_N) | |
122 | /* don't rehash */ | |
123 | return; | |
c35738c1 MD |
124 | } |
125 | SCM_HASHTABLE (table)->size_index = i; | |
76da80e7 | 126 | |
c35738c1 MD |
127 | new_size = hashtable_size[i]; |
128 | if (i <= SCM_HASHTABLE (table)->min_size_index) | |
129 | SCM_HASHTABLE (table)->lower = 0; | |
130 | else | |
131 | SCM_HASHTABLE (table)->lower = new_size / 4; | |
132 | SCM_HASHTABLE (table)->upper = 9 * new_size / 10; | |
133 | buckets = SCM_HASHTABLE_VECTOR (table); | |
3a2de079 LC |
134 | |
135 | new_buckets = scm_c_make_vector (new_size, SCM_EOL); | |
c35738c1 | 136 | |
bc6580eb MV |
137 | SCM_SET_HASHTABLE_VECTOR (table, new_buckets); |
138 | SCM_SET_HASHTABLE_N_ITEMS (table, 0); | |
bc6580eb | 139 | |
3ebc1832 | 140 | old_size = SCM_SIMPLE_VECTOR_LENGTH (buckets); |
c35738c1 MD |
141 | for (i = 0; i < old_size; ++i) |
142 | { | |
bc6580eb MV |
143 | SCM ls, cell, handle; |
144 | ||
145 | ls = SCM_SIMPLE_VECTOR_REF (buckets, i); | |
c2f21af5 MV |
146 | SCM_SIMPLE_VECTOR_SET (buckets, i, SCM_EOL); |
147 | ||
bc6580eb | 148 | while (scm_is_pair (ls)) |
c35738c1 MD |
149 | { |
150 | unsigned long h; | |
c6a35e35 | 151 | |
bc6580eb MV |
152 | cell = ls; |
153 | handle = SCM_CAR (cell); | |
154 | ls = SCM_CDR (ls); | |
c6a35e35 | 155 | |
c35738c1 MD |
156 | h = hash_fn (SCM_CAR (handle), new_size, closure); |
157 | if (h >= new_size) | |
b9bd8526 | 158 | scm_out_of_range (func_name, scm_from_ulong (h)); |
bc6580eb MV |
159 | SCM_SETCDR (cell, SCM_SIMPLE_VECTOR_REF (new_buckets, h)); |
160 | SCM_SIMPLE_VECTOR_SET (new_buckets, h, cell); | |
161 | SCM_HASHTABLE_INCREMENT (table); | |
c35738c1 MD |
162 | } |
163 | } | |
c35738c1 MD |
164 | } |
165 | ||
166 | ||
c99de5aa AW |
167 | void |
168 | scm_i_hashtable_print (SCM exp, SCM port, scm_print_state *pstate) | |
f59a096e | 169 | { |
54a9b981 | 170 | scm_puts ("#<hash-table ", port); |
06c1d900 | 171 | scm_uintprint (SCM_HASHTABLE_N_ITEMS (exp), 10, port); |
f59a096e | 172 | scm_putc ('/', port); |
3ebc1832 MV |
173 | scm_uintprint (SCM_SIMPLE_VECTOR_LENGTH (SCM_HASHTABLE_VECTOR (exp)), |
174 | 10, port); | |
f59a096e | 175 | scm_puts (">", port); |
c99de5aa AW |
176 | } |
177 | ||
f59a096e | 178 | |
00ffa0e7 | 179 | SCM |
c014a02e | 180 | scm_c_make_hash_table (unsigned long k) |
00ffa0e7 | 181 | { |
54a9b981 | 182 | return make_hash_table (k, "scm_c_make_hash_table"); |
f59a096e MD |
183 | } |
184 | ||
185 | SCM_DEFINE (scm_make_hash_table, "make-hash-table", 0, 1, 0, | |
186 | (SCM n), | |
a9cf5c71 | 187 | "Make a new abstract hash table object with minimum number of buckets @var{n}\n") |
f59a096e MD |
188 | #define FUNC_NAME s_scm_make_hash_table |
189 | { | |
54a9b981 | 190 | return make_hash_table (SCM_UNBNDP (n) ? 0 : scm_to_ulong (n), FUNC_NAME); |
f59a096e | 191 | } |
c35738c1 MD |
192 | #undef FUNC_NAME |
193 | ||
54a9b981 | 194 | #define SCM_WEAK_TABLE_P(x) (scm_is_true (scm_weak_table_p (x))) |
c35738c1 MD |
195 | |
196 | SCM_DEFINE (scm_hash_table_p, "hash-table?", 1, 0, 0, | |
197 | (SCM obj), | |
a9cf5c71 | 198 | "Return @code{#t} if @var{obj} is an abstract hash table object.") |
c35738c1 MD |
199 | #define FUNC_NAME s_scm_hash_table_p |
200 | { | |
54a9b981 | 201 | return scm_from_bool (SCM_HASHTABLE_P (obj) || SCM_WEAK_TABLE_P (obj)); |
c35738c1 MD |
202 | } |
203 | #undef FUNC_NAME | |
204 | ||
d587c9e8 LC |
205 | \f |
206 | /* Accessing hash table entries. */ | |
22a52da1 | 207 | |
0f2d19dd | 208 | SCM |
d587c9e8 LC |
209 | scm_hash_fn_get_handle (SCM table, SCM obj, |
210 | scm_t_hash_fn hash_fn, scm_t_assoc_fn assoc_fn, | |
211 | void * closure) | |
22a52da1 | 212 | #define FUNC_NAME "scm_hash_fn_get_handle" |
0f2d19dd | 213 | { |
c014a02e | 214 | unsigned long k; |
63229905 | 215 | SCM buckets, h; |
0f2d19dd | 216 | |
f0554ee7 AW |
217 | SCM_VALIDATE_HASHTABLE (SCM_ARG1, table); |
218 | buckets = SCM_HASHTABLE_VECTOR (table); | |
d9c82e20 LC |
219 | |
220 | if (SCM_SIMPLE_VECTOR_LENGTH (buckets) == 0) | |
22a52da1 | 221 | return SCM_BOOL_F; |
d9c82e20 LC |
222 | k = hash_fn (obj, SCM_SIMPLE_VECTOR_LENGTH (buckets), closure); |
223 | if (k >= SCM_SIMPLE_VECTOR_LENGTH (buckets)) | |
f0554ee7 | 224 | scm_out_of_range (FUNC_NAME, scm_from_ulong (k)); |
3a2de079 | 225 | |
54a9b981 | 226 | h = assoc_fn (obj, SCM_SIMPLE_VECTOR_REF (buckets, k), closure); |
6efbc280 AW |
227 | |
228 | return h; | |
229 | } | |
230 | #undef FUNC_NAME | |
231 | ||
232 | ||
0f2d19dd | 233 | SCM |
f044da55 LC |
234 | scm_hash_fn_create_handle_x (SCM table, SCM obj, SCM init, |
235 | scm_t_hash_fn hash_fn, scm_t_assoc_fn assoc_fn, | |
236 | void * closure) | |
cbaadf02 | 237 | #define FUNC_NAME "scm_hash_fn_create_handle_x" |
0f2d19dd | 238 | { |
c014a02e | 239 | unsigned long k; |
63229905 | 240 | SCM buckets, it; |
0f2d19dd | 241 | |
f0554ee7 AW |
242 | SCM_VALIDATE_HASHTABLE (SCM_ARG1, table); |
243 | buckets = SCM_HASHTABLE_VECTOR (table); | |
244 | ||
3ebc1832 | 245 | if (SCM_SIMPLE_VECTOR_LENGTH (buckets) == 0) |
cbaadf02 DH |
246 | SCM_MISC_ERROR ("void hashtable", SCM_EOL); |
247 | ||
3ebc1832 MV |
248 | k = hash_fn (obj, SCM_SIMPLE_VECTOR_LENGTH (buckets), closure); |
249 | if (k >= SCM_SIMPLE_VECTOR_LENGTH (buckets)) | |
b9bd8526 | 250 | scm_out_of_range ("hash_fn_create_handle_x", scm_from_ulong (k)); |
3a2de079 | 251 | |
54a9b981 | 252 | it = assoc_fn (obj, SCM_SIMPLE_VECTOR_REF (buckets, k), closure); |
e4d21e6b | 253 | |
0306509b | 254 | if (scm_is_pair (it)) |
0a4c1355 | 255 | return it; |
15bd90ea NJ |
256 | else if (scm_is_true (it)) |
257 | scm_wrong_type_arg_msg (NULL, 0, it, "a pair"); | |
ee083ac2 DH |
258 | else |
259 | { | |
3a2de079 LC |
260 | SCM handle, new_bucket; |
261 | ||
54a9b981 | 262 | handle = scm_cons (obj, init); |
3a2de079 LC |
263 | new_bucket = scm_cons (handle, SCM_EOL); |
264 | ||
f0554ee7 | 265 | if (!scm_is_eq (SCM_HASHTABLE_VECTOR (table), buckets)) |
5b582466 MV |
266 | { |
267 | buckets = SCM_HASHTABLE_VECTOR (table); | |
268 | k = hash_fn (obj, SCM_SIMPLE_VECTOR_LENGTH (buckets), closure); | |
269 | if (k >= SCM_SIMPLE_VECTOR_LENGTH (buckets)) | |
270 | scm_out_of_range ("hash_fn_create_handle_x", scm_from_ulong (k)); | |
271 | } | |
bc6580eb | 272 | SCM_SETCDR (new_bucket, SCM_SIMPLE_VECTOR_REF (buckets, k)); |
3ebc1832 | 273 | SCM_SIMPLE_VECTOR_SET (buckets, k, new_bucket); |
f0554ee7 | 274 | SCM_HASHTABLE_INCREMENT (table); |
40d2a007 | 275 | |
62c290e9 | 276 | /* Maybe rehash the table. */ |
f0554ee7 AW |
277 | if (SCM_HASHTABLE_N_ITEMS (table) < SCM_HASHTABLE_LOWER (table) |
278 | || SCM_HASHTABLE_N_ITEMS (table) > SCM_HASHTABLE_UPPER (table)) | |
279 | scm_i_rehash (table, hash_fn, closure, FUNC_NAME); | |
ee083ac2 DH |
280 | return SCM_CAR (new_bucket); |
281 | } | |
0f2d19dd | 282 | } |
cbaadf02 | 283 | #undef FUNC_NAME |
0f2d19dd | 284 | |
1cc91f1b | 285 | |
f044da55 LC |
286 | SCM |
287 | scm_hash_fn_ref (SCM table, SCM obj, SCM dflt, | |
288 | scm_t_hash_fn hash_fn, scm_t_assoc_fn assoc_fn, | |
289 | void *closure) | |
0f2d19dd | 290 | { |
22a52da1 | 291 | SCM it = scm_hash_fn_get_handle (table, obj, hash_fn, assoc_fn, closure); |
d2e53ed6 | 292 | if (scm_is_pair (it)) |
0f2d19dd | 293 | return SCM_CDR (it); |
22a52da1 DH |
294 | else |
295 | return dflt; | |
0f2d19dd JB |
296 | } |
297 | ||
f044da55 LC |
298 | SCM |
299 | scm_hash_fn_set_x (SCM table, SCM obj, SCM val, | |
300 | scm_t_hash_fn hash_fn, scm_t_assoc_fn assoc_fn, | |
301 | void *closure) | |
0f2d19dd | 302 | { |
ecc9d1b5 | 303 | SCM pair; |
0f2d19dd | 304 | |
ecc9d1b5 AW |
305 | pair = scm_hash_fn_create_handle_x (table, obj, val, |
306 | hash_fn, assoc_fn, closure); | |
5a99a574 | 307 | |
636c99d4 | 308 | if (!scm_is_eq (SCM_CDR (pair), val)) |
54a9b981 | 309 | SCM_SETCDR (pair, val); |
ecc9d1b5 | 310 | |
0f2d19dd JB |
311 | return val; |
312 | } | |
313 | ||
314 | ||
d9c82e20 | 315 | SCM |
a9cf5c71 | 316 | scm_hash_fn_remove_x (SCM table, SCM obj, |
f044da55 LC |
317 | scm_t_hash_fn hash_fn, |
318 | scm_t_assoc_fn assoc_fn, | |
a9cf5c71 | 319 | void *closure) |
f0554ee7 | 320 | #define FUNC_NAME "hash_fn_remove_x" |
0f2d19dd | 321 | { |
c014a02e | 322 | unsigned long k; |
63229905 | 323 | SCM buckets, h; |
0f2d19dd | 324 | |
f0554ee7 AW |
325 | SCM_VALIDATE_HASHTABLE (SCM_ARG1, table); |
326 | ||
327 | buckets = SCM_HASHTABLE_VECTOR (table); | |
328 | ||
c99de5aa | 329 | if (SCM_SIMPLE_VECTOR_LENGTH (buckets) == 0) |
0f2d19dd | 330 | return SCM_EOL; |
87ca11ff | 331 | |
3ebc1832 MV |
332 | k = hash_fn (obj, SCM_SIMPLE_VECTOR_LENGTH (buckets), closure); |
333 | if (k >= SCM_SIMPLE_VECTOR_LENGTH (buckets)) | |
f0554ee7 | 334 | scm_out_of_range (FUNC_NAME, scm_from_ulong (k)); |
3a2de079 | 335 | |
54a9b981 | 336 | h = assoc_fn (obj, SCM_SIMPLE_VECTOR_REF (buckets, k), closure); |
e4d21e6b | 337 | |
7888309b | 338 | if (scm_is_true (h)) |
87ca11ff | 339 | { |
3ebc1832 | 340 | SCM_SIMPLE_VECTOR_SET |
a9cf5c71 | 341 | (buckets, k, scm_delq_x (h, SCM_SIMPLE_VECTOR_REF (buckets, k))); |
f0554ee7 AW |
342 | SCM_HASHTABLE_DECREMENT (table); |
343 | if (SCM_HASHTABLE_N_ITEMS (table) < SCM_HASHTABLE_LOWER (table)) | |
344 | scm_i_rehash (table, hash_fn, closure, FUNC_NAME); | |
87ca11ff | 345 | } |
0f2d19dd JB |
346 | return h; |
347 | } | |
f0554ee7 | 348 | #undef FUNC_NAME |
0f2d19dd | 349 | |
c35738c1 MD |
350 | SCM_DEFINE (scm_hash_clear_x, "hash-clear!", 1, 0, 0, |
351 | (SCM table), | |
a9cf5c71 | 352 | "Remove all items from @var{table} (without triggering a resize).") |
c35738c1 MD |
353 | #define FUNC_NAME s_scm_hash_clear_x |
354 | { | |
54a9b981 AW |
355 | if (SCM_WEAK_TABLE_P (table)) |
356 | return scm_weak_table_clear_x (table); | |
357 | ||
f0554ee7 AW |
358 | SCM_VALIDATE_HASHTABLE (SCM_ARG1, table); |
359 | ||
360 | scm_vector_fill_x (SCM_HASHTABLE_VECTOR (table), SCM_EOL); | |
361 | SCM_SET_HASHTABLE_N_ITEMS (table, 0); | |
362 | ||
c35738c1 MD |
363 | return SCM_UNSPECIFIED; |
364 | } | |
365 | #undef FUNC_NAME | |
0f2d19dd JB |
366 | |
367 | \f | |
368 | ||
a1ec6916 | 369 | SCM_DEFINE (scm_hashq_get_handle, "hashq-get-handle", 2, 0, 0, |
22a52da1 DH |
370 | (SCM table, SCM key), |
371 | "This procedure returns the @code{(key . value)} pair from the\n" | |
372 | "hash table @var{table}. If @var{table} does not hold an\n" | |
373 | "associated value for @var{key}, @code{#f} is returned.\n" | |
374 | "Uses @code{eq?} for equality testing.") | |
1bbd0b84 | 375 | #define FUNC_NAME s_scm_hashq_get_handle |
0f2d19dd | 376 | { |
d587c9e8 LC |
377 | return scm_hash_fn_get_handle (table, key, |
378 | (scm_t_hash_fn) scm_ihashq, | |
379 | (scm_t_assoc_fn) scm_sloppy_assq, | |
380 | 0); | |
0f2d19dd | 381 | } |
1bbd0b84 | 382 | #undef FUNC_NAME |
0f2d19dd JB |
383 | |
384 | ||
a1ec6916 | 385 | SCM_DEFINE (scm_hashq_create_handle_x, "hashq-create-handle!", 3, 0, 0, |
d550d22a GB |
386 | (SCM table, SCM key, SCM init), |
387 | "This function looks up @var{key} in @var{table} and returns its handle.\n" | |
b380b885 MD |
388 | "If @var{key} is not already present, a new handle is created which\n" |
389 | "associates @var{key} with @var{init}.") | |
1bbd0b84 | 390 | #define FUNC_NAME s_scm_hashq_create_handle_x |
0f2d19dd | 391 | { |
d587c9e8 LC |
392 | return scm_hash_fn_create_handle_x (table, key, init, |
393 | (scm_t_hash_fn) scm_ihashq, | |
394 | (scm_t_assoc_fn) scm_sloppy_assq, | |
395 | 0); | |
0f2d19dd | 396 | } |
1bbd0b84 | 397 | #undef FUNC_NAME |
0f2d19dd JB |
398 | |
399 | ||
a1ec6916 | 400 | SCM_DEFINE (scm_hashq_ref, "hashq-ref", 2, 1, 0, |
1e6808ea | 401 | (SCM table, SCM key, SCM dflt), |
b380b885 MD |
402 | "Look up @var{key} in the hash table @var{table}, and return the\n" |
403 | "value (if any) associated with it. If @var{key} is not found,\n" | |
5352393c MG |
404 | "return @var{default} (or @code{#f} if no @var{default} argument\n" |
405 | "is supplied). Uses @code{eq?} for equality testing.") | |
1bbd0b84 | 406 | #define FUNC_NAME s_scm_hashq_ref |
0f2d19dd | 407 | { |
54778cd3 | 408 | if (SCM_UNBNDP (dflt)) |
0f2d19dd | 409 | dflt = SCM_BOOL_F; |
54a9b981 AW |
410 | |
411 | if (SCM_WEAK_TABLE_P (table)) | |
412 | return scm_weak_table_refq (table, key, dflt); | |
413 | ||
d587c9e8 LC |
414 | return scm_hash_fn_ref (table, key, dflt, |
415 | (scm_t_hash_fn) scm_ihashq, | |
416 | (scm_t_assoc_fn) scm_sloppy_assq, | |
417 | 0); | |
0f2d19dd | 418 | } |
1bbd0b84 | 419 | #undef FUNC_NAME |
0f2d19dd JB |
420 | |
421 | ||
422 | ||
a1ec6916 | 423 | SCM_DEFINE (scm_hashq_set_x, "hashq-set!", 3, 0, 0, |
1e6808ea | 424 | (SCM table, SCM key, SCM val), |
5352393c MG |
425 | "Find the entry in @var{table} associated with @var{key}, and\n" |
426 | "store @var{value} there. Uses @code{eq?} for equality testing.") | |
1bbd0b84 | 427 | #define FUNC_NAME s_scm_hashq_set_x |
0f2d19dd | 428 | { |
54a9b981 AW |
429 | if (SCM_WEAK_TABLE_P (table)) |
430 | return scm_weak_table_putq_x (table, key, val); | |
431 | ||
d587c9e8 LC |
432 | return scm_hash_fn_set_x (table, key, val, |
433 | (scm_t_hash_fn) scm_ihashq, | |
434 | (scm_t_assoc_fn) scm_sloppy_assq, | |
435 | 0); | |
0f2d19dd | 436 | } |
1bbd0b84 | 437 | #undef FUNC_NAME |
0f2d19dd JB |
438 | |
439 | ||
440 | ||
a1ec6916 | 441 | SCM_DEFINE (scm_hashq_remove_x, "hashq-remove!", 2, 0, 0, |
1e6808ea | 442 | (SCM table, SCM key), |
5352393c MG |
443 | "Remove @var{key} (and any value associated with it) from\n" |
444 | "@var{table}. Uses @code{eq?} for equality tests.") | |
1bbd0b84 | 445 | #define FUNC_NAME s_scm_hashq_remove_x |
0f2d19dd | 446 | { |
54a9b981 AW |
447 | if (SCM_WEAK_TABLE_P (table)) |
448 | return scm_weak_table_remq_x (table, key); | |
449 | ||
d587c9e8 LC |
450 | return scm_hash_fn_remove_x (table, key, |
451 | (scm_t_hash_fn) scm_ihashq, | |
452 | (scm_t_assoc_fn) scm_sloppy_assq, | |
453 | 0); | |
0f2d19dd | 454 | } |
1bbd0b84 | 455 | #undef FUNC_NAME |
0f2d19dd JB |
456 | |
457 | ||
458 | \f | |
459 | ||
a1ec6916 | 460 | SCM_DEFINE (scm_hashv_get_handle, "hashv-get-handle", 2, 0, 0, |
22a52da1 DH |
461 | (SCM table, SCM key), |
462 | "This procedure returns the @code{(key . value)} pair from the\n" | |
463 | "hash table @var{table}. If @var{table} does not hold an\n" | |
464 | "associated value for @var{key}, @code{#f} is returned.\n" | |
465 | "Uses @code{eqv?} for equality testing.") | |
1bbd0b84 | 466 | #define FUNC_NAME s_scm_hashv_get_handle |
0f2d19dd | 467 | { |
d587c9e8 LC |
468 | return scm_hash_fn_get_handle (table, key, |
469 | (scm_t_hash_fn) scm_ihashv, | |
470 | (scm_t_assoc_fn) scm_sloppy_assv, | |
471 | 0); | |
0f2d19dd | 472 | } |
1bbd0b84 | 473 | #undef FUNC_NAME |
0f2d19dd JB |
474 | |
475 | ||
a1ec6916 | 476 | SCM_DEFINE (scm_hashv_create_handle_x, "hashv-create-handle!", 3, 0, 0, |
d550d22a GB |
477 | (SCM table, SCM key, SCM init), |
478 | "This function looks up @var{key} in @var{table} and returns its handle.\n" | |
479 | "If @var{key} is not already present, a new handle is created which\n" | |
480 | "associates @var{key} with @var{init}.") | |
1bbd0b84 | 481 | #define FUNC_NAME s_scm_hashv_create_handle_x |
0f2d19dd | 482 | { |
d587c9e8 LC |
483 | return scm_hash_fn_create_handle_x (table, key, init, |
484 | (scm_t_hash_fn) scm_ihashv, | |
485 | (scm_t_assoc_fn) scm_sloppy_assv, | |
486 | 0); | |
0f2d19dd | 487 | } |
1bbd0b84 | 488 | #undef FUNC_NAME |
0f2d19dd JB |
489 | |
490 | ||
54a9b981 AW |
491 | static int |
492 | assv_predicate (SCM k, SCM v, void *closure) | |
493 | { | |
21041372 | 494 | return scm_is_true (scm_eqv_p (k, SCM_PACK_POINTER (closure))); |
54a9b981 AW |
495 | } |
496 | ||
a1ec6916 | 497 | SCM_DEFINE (scm_hashv_ref, "hashv-ref", 2, 1, 0, |
1e6808ea | 498 | (SCM table, SCM key, SCM dflt), |
d550d22a GB |
499 | "Look up @var{key} in the hash table @var{table}, and return the\n" |
500 | "value (if any) associated with it. If @var{key} is not found,\n" | |
5352393c MG |
501 | "return @var{default} (or @code{#f} if no @var{default} argument\n" |
502 | "is supplied). Uses @code{eqv?} for equality testing.") | |
1bbd0b84 | 503 | #define FUNC_NAME s_scm_hashv_ref |
0f2d19dd | 504 | { |
54778cd3 | 505 | if (SCM_UNBNDP (dflt)) |
0f2d19dd | 506 | dflt = SCM_BOOL_F; |
54a9b981 AW |
507 | |
508 | if (SCM_WEAK_TABLE_P (table)) | |
509 | return scm_c_weak_table_ref (table, scm_ihashv (key, -1), | |
510 | assv_predicate, SCM_PACK (key), dflt); | |
511 | ||
d587c9e8 LC |
512 | return scm_hash_fn_ref (table, key, dflt, |
513 | (scm_t_hash_fn) scm_ihashv, | |
514 | (scm_t_assoc_fn) scm_sloppy_assv, | |
515 | 0); | |
0f2d19dd | 516 | } |
1bbd0b84 | 517 | #undef FUNC_NAME |
0f2d19dd JB |
518 | |
519 | ||
520 | ||
a1ec6916 | 521 | SCM_DEFINE (scm_hashv_set_x, "hashv-set!", 3, 0, 0, |
1e6808ea | 522 | (SCM table, SCM key, SCM val), |
5352393c MG |
523 | "Find the entry in @var{table} associated with @var{key}, and\n" |
524 | "store @var{value} there. Uses @code{eqv?} for equality testing.") | |
1bbd0b84 | 525 | #define FUNC_NAME s_scm_hashv_set_x |
0f2d19dd | 526 | { |
54a9b981 AW |
527 | if (SCM_WEAK_TABLE_P (table)) |
528 | { | |
529 | scm_c_weak_table_put_x (table, scm_ihashv (key, -1), | |
530 | assv_predicate, SCM_PACK (key), | |
531 | key, val); | |
532 | return SCM_UNSPECIFIED; | |
533 | } | |
534 | ||
d587c9e8 LC |
535 | return scm_hash_fn_set_x (table, key, val, |
536 | (scm_t_hash_fn) scm_ihashv, | |
537 | (scm_t_assoc_fn) scm_sloppy_assv, | |
538 | 0); | |
0f2d19dd | 539 | } |
1bbd0b84 | 540 | #undef FUNC_NAME |
0f2d19dd JB |
541 | |
542 | ||
a1ec6916 | 543 | SCM_DEFINE (scm_hashv_remove_x, "hashv-remove!", 2, 0, 0, |
1e6808ea | 544 | (SCM table, SCM key), |
5352393c MG |
545 | "Remove @var{key} (and any value associated with it) from\n" |
546 | "@var{table}. Uses @code{eqv?} for equality tests.") | |
1bbd0b84 | 547 | #define FUNC_NAME s_scm_hashv_remove_x |
0f2d19dd | 548 | { |
54a9b981 AW |
549 | if (SCM_WEAK_TABLE_P (table)) |
550 | { | |
551 | scm_c_weak_table_remove_x (table, scm_ihashv (key, -1), | |
552 | assv_predicate, SCM_PACK (key)); | |
553 | return SCM_UNSPECIFIED; | |
554 | } | |
555 | ||
d587c9e8 LC |
556 | return scm_hash_fn_remove_x (table, key, |
557 | (scm_t_hash_fn) scm_ihashv, | |
558 | (scm_t_assoc_fn) scm_sloppy_assv, | |
559 | 0); | |
0f2d19dd | 560 | } |
1bbd0b84 | 561 | #undef FUNC_NAME |
0f2d19dd JB |
562 | |
563 | \f | |
564 | ||
a1ec6916 | 565 | SCM_DEFINE (scm_hash_get_handle, "hash-get-handle", 2, 0, 0, |
22a52da1 DH |
566 | (SCM table, SCM key), |
567 | "This procedure returns the @code{(key . value)} pair from the\n" | |
568 | "hash table @var{table}. If @var{table} does not hold an\n" | |
569 | "associated value for @var{key}, @code{#f} is returned.\n" | |
570 | "Uses @code{equal?} for equality testing.") | |
1bbd0b84 | 571 | #define FUNC_NAME s_scm_hash_get_handle |
0f2d19dd | 572 | { |
d587c9e8 LC |
573 | return scm_hash_fn_get_handle (table, key, |
574 | (scm_t_hash_fn) scm_ihash, | |
575 | (scm_t_assoc_fn) scm_sloppy_assoc, | |
576 | 0); | |
0f2d19dd | 577 | } |
1bbd0b84 | 578 | #undef FUNC_NAME |
0f2d19dd JB |
579 | |
580 | ||
a1ec6916 | 581 | SCM_DEFINE (scm_hash_create_handle_x, "hash-create-handle!", 3, 0, 0, |
d550d22a GB |
582 | (SCM table, SCM key, SCM init), |
583 | "This function looks up @var{key} in @var{table} and returns its handle.\n" | |
584 | "If @var{key} is not already present, a new handle is created which\n" | |
585 | "associates @var{key} with @var{init}.") | |
1bbd0b84 | 586 | #define FUNC_NAME s_scm_hash_create_handle_x |
0f2d19dd | 587 | { |
d587c9e8 LC |
588 | return scm_hash_fn_create_handle_x (table, key, init, |
589 | (scm_t_hash_fn) scm_ihash, | |
590 | (scm_t_assoc_fn) scm_sloppy_assoc, | |
591 | 0); | |
0f2d19dd | 592 | } |
1bbd0b84 | 593 | #undef FUNC_NAME |
0f2d19dd JB |
594 | |
595 | ||
54a9b981 AW |
596 | static int |
597 | assoc_predicate (SCM k, SCM v, void *closure) | |
598 | { | |
21041372 | 599 | return scm_is_true (scm_equal_p (k, SCM_PACK_POINTER (closure))); |
54a9b981 AW |
600 | } |
601 | ||
a1ec6916 | 602 | SCM_DEFINE (scm_hash_ref, "hash-ref", 2, 1, 0, |
1e6808ea | 603 | (SCM table, SCM key, SCM dflt), |
d550d22a GB |
604 | "Look up @var{key} in the hash table @var{table}, and return the\n" |
605 | "value (if any) associated with it. If @var{key} is not found,\n" | |
5352393c MG |
606 | "return @var{default} (or @code{#f} if no @var{default} argument\n" |
607 | "is supplied). Uses @code{equal?} for equality testing.") | |
1bbd0b84 | 608 | #define FUNC_NAME s_scm_hash_ref |
0f2d19dd | 609 | { |
54778cd3 | 610 | if (SCM_UNBNDP (dflt)) |
0f2d19dd | 611 | dflt = SCM_BOOL_F; |
54a9b981 AW |
612 | |
613 | if (SCM_WEAK_TABLE_P (table)) | |
614 | return scm_c_weak_table_ref (table, scm_ihash (key, -1), | |
615 | assoc_predicate, SCM_PACK (key), dflt); | |
616 | ||
d587c9e8 LC |
617 | return scm_hash_fn_ref (table, key, dflt, |
618 | (scm_t_hash_fn) scm_ihash, | |
619 | (scm_t_assoc_fn) scm_sloppy_assoc, | |
620 | 0); | |
0f2d19dd | 621 | } |
1bbd0b84 | 622 | #undef FUNC_NAME |
0f2d19dd JB |
623 | |
624 | ||
625 | ||
a1ec6916 | 626 | SCM_DEFINE (scm_hash_set_x, "hash-set!", 3, 0, 0, |
1e6808ea | 627 | (SCM table, SCM key, SCM val), |
5352393c MG |
628 | "Find the entry in @var{table} associated with @var{key}, and\n" |
629 | "store @var{value} there. Uses @code{equal?} for equality\n" | |
630 | "testing.") | |
1bbd0b84 | 631 | #define FUNC_NAME s_scm_hash_set_x |
0f2d19dd | 632 | { |
54a9b981 AW |
633 | if (SCM_WEAK_TABLE_P (table)) |
634 | { | |
635 | scm_c_weak_table_put_x (table, scm_ihash (key, -1), | |
636 | assoc_predicate, SCM_PACK (key), | |
637 | key, val); | |
638 | return SCM_UNSPECIFIED; | |
639 | } | |
640 | ||
d587c9e8 LC |
641 | return scm_hash_fn_set_x (table, key, val, |
642 | (scm_t_hash_fn) scm_ihash, | |
643 | (scm_t_assoc_fn) scm_sloppy_assoc, | |
644 | 0); | |
0f2d19dd | 645 | } |
1bbd0b84 | 646 | #undef FUNC_NAME |
0f2d19dd JB |
647 | |
648 | ||
649 | ||
a1ec6916 | 650 | SCM_DEFINE (scm_hash_remove_x, "hash-remove!", 2, 0, 0, |
1e6808ea | 651 | (SCM table, SCM key), |
5352393c MG |
652 | "Remove @var{key} (and any value associated with it) from\n" |
653 | "@var{table}. Uses @code{equal?} for equality tests.") | |
1bbd0b84 | 654 | #define FUNC_NAME s_scm_hash_remove_x |
0f2d19dd | 655 | { |
54a9b981 AW |
656 | if (SCM_WEAK_TABLE_P (table)) |
657 | { | |
658 | scm_c_weak_table_remove_x (table, scm_ihash (key, -1), | |
659 | assoc_predicate, SCM_PACK (key)); | |
660 | return SCM_UNSPECIFIED; | |
661 | } | |
662 | ||
d587c9e8 LC |
663 | return scm_hash_fn_remove_x (table, key, |
664 | (scm_t_hash_fn) scm_ihash, | |
665 | (scm_t_assoc_fn) scm_sloppy_assoc, | |
666 | 0); | |
0f2d19dd | 667 | } |
1bbd0b84 | 668 | #undef FUNC_NAME |
0f2d19dd JB |
669 | |
670 | \f | |
671 | ||
672 | ||
92c2555f | 673 | typedef struct scm_t_ihashx_closure |
0f2d19dd JB |
674 | { |
675 | SCM hash; | |
676 | SCM assoc; | |
54a9b981 | 677 | SCM key; |
92c2555f | 678 | } scm_t_ihashx_closure; |
0f2d19dd | 679 | |
c014a02e | 680 | static unsigned long |
d587c9e8 | 681 | scm_ihashx (SCM obj, unsigned long n, void *arg) |
0f2d19dd | 682 | { |
d587c9e8 LC |
683 | SCM answer; |
684 | scm_t_ihashx_closure *closure = (scm_t_ihashx_closure *) arg; | |
685 | answer = scm_call_2 (closure->hash, obj, scm_from_ulong (n)); | |
a55c2b68 | 686 | return scm_to_ulong (answer); |
0f2d19dd JB |
687 | } |
688 | ||
0f2d19dd | 689 | static SCM |
d587c9e8 | 690 | scm_sloppy_assx (SCM obj, SCM alist, void *arg) |
0f2d19dd | 691 | { |
d587c9e8 | 692 | scm_t_ihashx_closure *closure = (scm_t_ihashx_closure *) arg; |
87ca11ff | 693 | return scm_call_2 (closure->assoc, obj, alist); |
0f2d19dd JB |
694 | } |
695 | ||
54a9b981 AW |
696 | static int |
697 | assx_predicate (SCM k, SCM v, void *closure) | |
698 | { | |
699 | scm_t_ihashx_closure *c = (scm_t_ihashx_closure *) closure; | |
700 | ||
701 | /* FIXME: The hashx interface is crazy. Hash tables have nothing to | |
702 | do with alists in principle. Instead of getting an assoc proc, | |
703 | hashx functions should use an equality predicate. Perhaps we can | |
704 | change this before 2.2, but until then, add a terrible, terrible | |
705 | hack. */ | |
706 | ||
707 | return scm_is_true (scm_call_2 (c->assoc, c->key, scm_acons (k, v, SCM_EOL))); | |
708 | } | |
709 | ||
0f2d19dd | 710 | |
a1ec6916 | 711 | SCM_DEFINE (scm_hashx_get_handle, "hashx-get-handle", 4, 0, 0, |
1e6808ea MG |
712 | (SCM hash, SCM assoc, SCM table, SCM key), |
713 | "This behaves the same way as the corresponding\n" | |
714 | "@code{-get-handle} function, but uses @var{hash} as a hash\n" | |
715 | "function and @var{assoc} to compare keys. @code{hash} must be\n" | |
716 | "a function that takes two arguments, a key to be hashed and a\n" | |
d550d22a GB |
717 | "table size. @code{assoc} must be an associator function, like\n" |
718 | "@code{assoc}, @code{assq} or @code{assv}.") | |
1bbd0b84 | 719 | #define FUNC_NAME s_scm_hashx_get_handle |
0f2d19dd | 720 | { |
92c2555f | 721 | scm_t_ihashx_closure closure; |
0f2d19dd JB |
722 | closure.hash = hash; |
723 | closure.assoc = assoc; | |
54a9b981 | 724 | closure.key = key; |
1d9c2e62 | 725 | |
1e6808ea | 726 | return scm_hash_fn_get_handle (table, key, scm_ihashx, scm_sloppy_assx, |
87ca11ff | 727 | (void *) &closure); |
0f2d19dd | 728 | } |
1bbd0b84 | 729 | #undef FUNC_NAME |
0f2d19dd JB |
730 | |
731 | ||
a1ec6916 | 732 | SCM_DEFINE (scm_hashx_create_handle_x, "hashx-create-handle!", 5, 0, 0, |
1e6808ea MG |
733 | (SCM hash, SCM assoc, SCM table, SCM key, SCM init), |
734 | "This behaves the same way as the corresponding\n" | |
735 | "@code{-create-handle} function, but uses @var{hash} as a hash\n" | |
736 | "function and @var{assoc} to compare keys. @code{hash} must be\n" | |
737 | "a function that takes two arguments, a key to be hashed and a\n" | |
d550d22a GB |
738 | "table size. @code{assoc} must be an associator function, like\n" |
739 | "@code{assoc}, @code{assq} or @code{assv}.") | |
1bbd0b84 | 740 | #define FUNC_NAME s_scm_hashx_create_handle_x |
0f2d19dd | 741 | { |
92c2555f | 742 | scm_t_ihashx_closure closure; |
0f2d19dd JB |
743 | closure.hash = hash; |
744 | closure.assoc = assoc; | |
54a9b981 | 745 | closure.key = key; |
1d9c2e62 | 746 | |
1e6808ea MG |
747 | return scm_hash_fn_create_handle_x (table, key, init, scm_ihashx, |
748 | scm_sloppy_assx, (void *)&closure); | |
0f2d19dd | 749 | } |
1bbd0b84 | 750 | #undef FUNC_NAME |
0f2d19dd JB |
751 | |
752 | ||
753 | ||
a1ec6916 | 754 | SCM_DEFINE (scm_hashx_ref, "hashx-ref", 4, 1, 0, |
1e6808ea | 755 | (SCM hash, SCM assoc, SCM table, SCM key, SCM dflt), |
d550d22a | 756 | "This behaves the same way as the corresponding @code{ref}\n" |
1e6808ea MG |
757 | "function, but uses @var{hash} as a hash function and\n" |
758 | "@var{assoc} to compare keys. @code{hash} must be a function\n" | |
759 | "that takes two arguments, a key to be hashed and a table size.\n" | |
760 | "@code{assoc} must be an associator function, like @code{assoc},\n" | |
761 | "@code{assq} or @code{assv}.\n" | |
762 | "\n" | |
763 | "By way of illustration, @code{hashq-ref table key} is\n" | |
764 | "equivalent to @code{hashx-ref hashq assq table key}.") | |
1bbd0b84 | 765 | #define FUNC_NAME s_scm_hashx_ref |
0f2d19dd | 766 | { |
92c2555f | 767 | scm_t_ihashx_closure closure; |
54778cd3 | 768 | if (SCM_UNBNDP (dflt)) |
0f2d19dd JB |
769 | dflt = SCM_BOOL_F; |
770 | closure.hash = hash; | |
771 | closure.assoc = assoc; | |
54a9b981 AW |
772 | closure.key = key; |
773 | ||
774 | if (SCM_WEAK_TABLE_P (table)) | |
775 | { | |
776 | unsigned long h = scm_to_ulong (scm_call_2 (hash, key, | |
777 | scm_from_ulong (-1))); | |
778 | return scm_c_weak_table_ref (table, h, assx_predicate, &closure, dflt); | |
779 | } | |
780 | ||
1e6808ea MG |
781 | return scm_hash_fn_ref (table, key, dflt, scm_ihashx, scm_sloppy_assx, |
782 | (void *)&closure); | |
0f2d19dd | 783 | } |
1bbd0b84 | 784 | #undef FUNC_NAME |
0f2d19dd JB |
785 | |
786 | ||
787 | ||
788 | ||
a1ec6916 | 789 | SCM_DEFINE (scm_hashx_set_x, "hashx-set!", 5, 0, 0, |
1e6808ea | 790 | (SCM hash, SCM assoc, SCM table, SCM key, SCM val), |
d550d22a | 791 | "This behaves the same way as the corresponding @code{set!}\n" |
1e6808ea MG |
792 | "function, but uses @var{hash} as a hash function and\n" |
793 | "@var{assoc} to compare keys. @code{hash} must be a function\n" | |
794 | "that takes two arguments, a key to be hashed and a table size.\n" | |
795 | "@code{assoc} must be an associator function, like @code{assoc},\n" | |
796 | "@code{assq} or @code{assv}.\n" | |
797 | "\n" | |
798 | " By way of illustration, @code{hashq-set! table key} is\n" | |
799 | "equivalent to @code{hashx-set! hashq assq table key}.") | |
1bbd0b84 | 800 | #define FUNC_NAME s_scm_hashx_set_x |
0f2d19dd | 801 | { |
92c2555f | 802 | scm_t_ihashx_closure closure; |
0f2d19dd JB |
803 | closure.hash = hash; |
804 | closure.assoc = assoc; | |
54a9b981 AW |
805 | closure.key = key; |
806 | ||
807 | if (SCM_WEAK_TABLE_P (table)) | |
808 | { | |
809 | unsigned long h = scm_to_ulong (scm_call_2 (hash, key, | |
810 | scm_from_ulong (-1))); | |
811 | scm_c_weak_table_put_x (table, h, assx_predicate, &closure, key, val); | |
812 | return SCM_UNSPECIFIED; | |
813 | } | |
814 | ||
1e6808ea MG |
815 | return scm_hash_fn_set_x (table, key, val, scm_ihashx, scm_sloppy_assx, |
816 | (void *)&closure); | |
0f2d19dd | 817 | } |
1bbd0b84 | 818 | #undef FUNC_NAME |
0f2d19dd | 819 | |
a9cf5c71 MV |
820 | SCM_DEFINE (scm_hashx_remove_x, "hashx-remove!", 4, 0, 0, |
821 | (SCM hash, SCM assoc, SCM table, SCM obj), | |
822 | "This behaves the same way as the corresponding @code{remove!}\n" | |
823 | "function, but uses @var{hash} as a hash function and\n" | |
824 | "@var{assoc} to compare keys. @code{hash} must be a function\n" | |
825 | "that takes two arguments, a key to be hashed and a table size.\n" | |
826 | "@code{assoc} must be an associator function, like @code{assoc},\n" | |
827 | "@code{assq} or @code{assv}.\n" | |
828 | "\n" | |
829 | " By way of illustration, @code{hashq-remove! table key} is\n" | |
830 | "equivalent to @code{hashx-remove! hashq assq #f table key}.") | |
831 | #define FUNC_NAME s_scm_hashx_remove_x | |
0f2d19dd | 832 | { |
92c2555f | 833 | scm_t_ihashx_closure closure; |
0f2d19dd JB |
834 | closure.hash = hash; |
835 | closure.assoc = assoc; | |
54a9b981 AW |
836 | closure.key = obj; |
837 | ||
838 | if (SCM_WEAK_TABLE_P (table)) | |
839 | { | |
840 | unsigned long h = scm_to_ulong (scm_call_2 (hash, obj, | |
841 | scm_from_ulong (-1))); | |
842 | scm_c_weak_table_remove_x (table, h, assx_predicate, &closure); | |
843 | return SCM_UNSPECIFIED; | |
844 | } | |
845 | ||
4cff503f KR |
846 | return scm_hash_fn_remove_x (table, obj, scm_ihashx, scm_sloppy_assx, |
847 | (void *) &closure); | |
0f2d19dd | 848 | } |
a9cf5c71 | 849 | #undef FUNC_NAME |
0f2d19dd | 850 | |
711a9fd7 | 851 | /* Hash table iterators */ |
b94903c2 | 852 | |
162125af AW |
853 | SCM_DEFINE (scm_hash_fold, "hash-fold", 3, 0, 0, |
854 | (SCM proc, SCM init, SCM table), | |
855 | "An iterator over hash-table elements.\n" | |
856 | "Accumulates and returns a result by applying PROC successively.\n" | |
857 | "The arguments to PROC are \"(key value prior-result)\" where key\n" | |
858 | "and value are successive pairs from the hash table TABLE, and\n" | |
859 | "prior-result is either INIT (for the first application of PROC)\n" | |
860 | "or the return value of the previous application of PROC.\n" | |
861 | "For example, @code{(hash-fold acons '() tab)} will convert a hash\n" | |
862 | "table into an a-list of key-value pairs.") | |
863 | #define FUNC_NAME s_scm_hash_fold | |
864 | { | |
865 | SCM_VALIDATE_PROC (1, proc); | |
54a9b981 AW |
866 | |
867 | if (SCM_WEAK_TABLE_P (table)) | |
868 | return scm_weak_table_fold (proc, init, table); | |
869 | ||
2dd7d8ce | 870 | SCM_VALIDATE_HASHTABLE (3, table); |
162125af AW |
871 | return scm_internal_hash_fold ((scm_t_hash_fold_fn) scm_call_3, |
872 | (void *) SCM_UNPACK (proc), init, table); | |
873 | } | |
874 | #undef FUNC_NAME | |
875 | ||
876 | static SCM | |
877 | for_each_proc (void *proc, SCM handle) | |
878 | { | |
879 | return scm_call_2 (SCM_PACK (proc), SCM_CAR (handle), SCM_CDR (handle)); | |
880 | } | |
881 | ||
882 | SCM_DEFINE (scm_hash_for_each, "hash-for-each", 2, 0, 0, | |
883 | (SCM proc, SCM table), | |
884 | "An iterator over hash-table elements.\n" | |
885 | "Applies PROC successively on all hash table items.\n" | |
886 | "The arguments to PROC are \"(key value)\" where key\n" | |
887 | "and value are successive pairs from the hash table TABLE.") | |
888 | #define FUNC_NAME s_scm_hash_for_each | |
889 | { | |
890 | SCM_VALIDATE_PROC (1, proc); | |
54a9b981 AW |
891 | |
892 | if (SCM_WEAK_TABLE_P (table)) | |
893 | return scm_weak_table_for_each (proc, table); | |
894 | ||
2dd7d8ce | 895 | SCM_VALIDATE_HASHTABLE (2, table); |
162125af AW |
896 | |
897 | scm_internal_hash_for_each_handle (for_each_proc, | |
898 | (void *) SCM_UNPACK (proc), | |
899 | table); | |
900 | return SCM_UNSPECIFIED; | |
901 | } | |
902 | #undef FUNC_NAME | |
903 | ||
904 | SCM_DEFINE (scm_hash_for_each_handle, "hash-for-each-handle", 2, 0, 0, | |
905 | (SCM proc, SCM table), | |
906 | "An iterator over hash-table elements.\n" | |
907 | "Applies PROC successively on all hash table handles.") | |
908 | #define FUNC_NAME s_scm_hash_for_each_handle | |
909 | { | |
910 | SCM_ASSERT (scm_is_true (scm_procedure_p (proc)), proc, 1, FUNC_NAME); | |
2dd7d8ce | 911 | SCM_VALIDATE_HASHTABLE (2, table); |
162125af AW |
912 | |
913 | scm_internal_hash_for_each_handle ((scm_t_hash_handle_fn) scm_call_1, | |
914 | (void *) SCM_UNPACK (proc), | |
915 | table); | |
916 | return SCM_UNSPECIFIED; | |
917 | } | |
918 | #undef FUNC_NAME | |
919 | ||
920 | static SCM | |
921 | map_proc (void *proc, SCM key, SCM data, SCM value) | |
922 | { | |
923 | return scm_cons (scm_call_2 (SCM_PACK (proc), key, data), value); | |
924 | } | |
925 | ||
926 | SCM_DEFINE (scm_hash_map_to_list, "hash-map->list", 2, 0, 0, | |
927 | (SCM proc, SCM table), | |
928 | "An iterator over hash-table elements.\n" | |
929 | "Accumulates and returns as a list the results of applying PROC successively.\n" | |
930 | "The arguments to PROC are \"(key value)\" where key\n" | |
931 | "and value are successive pairs from the hash table TABLE.") | |
932 | #define FUNC_NAME s_scm_hash_map_to_list | |
933 | { | |
934 | SCM_VALIDATE_PROC (1, proc); | |
54a9b981 AW |
935 | |
936 | if (SCM_WEAK_TABLE_P (table)) | |
937 | return scm_weak_table_map_to_list (proc, table); | |
938 | ||
2dd7d8ce | 939 | SCM_VALIDATE_HASHTABLE (2, table); |
162125af AW |
940 | return scm_internal_hash_fold (map_proc, |
941 | (void *) SCM_UNPACK (proc), | |
942 | SCM_EOL, | |
943 | table); | |
944 | } | |
945 | #undef FUNC_NAME | |
946 | ||
947 | \f | |
c7df61cd MD |
948 | |
949 | SCM | |
a07010bf LC |
950 | scm_internal_hash_fold (scm_t_hash_fold_fn fn, void *closure, |
951 | SCM init, SCM table) | |
2dd7d8ce | 952 | #define FUNC_NAME s_scm_hash_fold |
c7df61cd | 953 | { |
87ca11ff MD |
954 | long i, n; |
955 | SCM buckets, result = init; | |
87ca11ff | 956 | |
54a9b981 AW |
957 | if (SCM_WEAK_TABLE_P (table)) |
958 | return scm_c_weak_table_fold (fn, closure, init, table); | |
959 | ||
2dd7d8ce AW |
960 | SCM_VALIDATE_HASHTABLE (0, table); |
961 | buckets = SCM_HASHTABLE_VECTOR (table); | |
0a4c1355 | 962 | |
3ebc1832 | 963 | n = SCM_SIMPLE_VECTOR_LENGTH (buckets); |
c7df61cd MD |
964 | for (i = 0; i < n; ++i) |
965 | { | |
2187975e | 966 | SCM ls, handle; |
741e83fc | 967 | |
2187975e AW |
968 | for (ls = SCM_SIMPLE_VECTOR_REF (buckets, i); !scm_is_null (ls); |
969 | ls = SCM_CDR (ls)) | |
c7df61cd | 970 | { |
c7df61cd | 971 | handle = SCM_CAR (ls); |
54a9b981 | 972 | result = fn (closure, SCM_CAR (handle), SCM_CDR (handle), result); |
c7df61cd MD |
973 | } |
974 | } | |
87ca11ff | 975 | |
c7df61cd MD |
976 | return result; |
977 | } | |
2dd7d8ce | 978 | #undef FUNC_NAME |
c7df61cd | 979 | |
711a9fd7 MD |
980 | /* The following redundant code is here in order to be able to support |
981 | hash-for-each-handle. An alternative would have been to replace | |
982 | this code and scm_internal_hash_fold above with a single | |
983 | scm_internal_hash_fold_handles, but we don't want to promote such | |
984 | an API. */ | |
985 | ||
711a9fd7 | 986 | void |
a07010bf LC |
987 | scm_internal_hash_for_each_handle (scm_t_hash_handle_fn fn, void *closure, |
988 | SCM table) | |
2dd7d8ce | 989 | #define FUNC_NAME s_scm_hash_for_each |
711a9fd7 MD |
990 | { |
991 | long i, n; | |
992 | SCM buckets; | |
993 | ||
2dd7d8ce AW |
994 | SCM_VALIDATE_HASHTABLE (0, table); |
995 | buckets = SCM_HASHTABLE_VECTOR (table); | |
3ebc1832 | 996 | n = SCM_SIMPLE_VECTOR_LENGTH (buckets); |
2dd7d8ce | 997 | |
711a9fd7 MD |
998 | for (i = 0; i < n; ++i) |
999 | { | |
3ebc1832 | 1000 | SCM ls = SCM_SIMPLE_VECTOR_REF (buckets, i), handle; |
d2e53ed6 | 1001 | while (!scm_is_null (ls)) |
711a9fd7 | 1002 | { |
d2e53ed6 | 1003 | if (!scm_is_pair (ls)) |
2dd7d8ce | 1004 | SCM_WRONG_TYPE_ARG (SCM_ARG3, buckets); |
711a9fd7 | 1005 | handle = SCM_CAR (ls); |
d2e53ed6 | 1006 | if (!scm_is_pair (handle)) |
2dd7d8ce | 1007 | SCM_WRONG_TYPE_ARG (SCM_ARG3, buckets); |
711a9fd7 MD |
1008 | fn (closure, handle); |
1009 | ls = SCM_CDR (ls); | |
1010 | } | |
1011 | } | |
1012 | } | |
2dd7d8ce | 1013 | #undef FUNC_NAME |
711a9fd7 | 1014 | |
0f2d19dd JB |
1015 | \f |
1016 | ||
1cc91f1b | 1017 | |
c35738c1 MD |
1018 | void |
1019 | scm_init_hashtab () | |
1020 | { | |
a0599745 | 1021 | #include "libguile/hashtab.x" |
0f2d19dd | 1022 | } |
89e00824 ML |
1023 | |
1024 | /* | |
1025 | Local Variables: | |
1026 | c-file-style: "gnu" | |
1027 | End: | |
1028 | */ |