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