1 /* Copyright (C) 1995,1996,1998,1999,2000,2001, 2003, 2004, 2006, 2008, 2010 Free Software Foundation, Inc.
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.
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.
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
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"
34 #include "libguile/validate.h"
35 #include "libguile/hashtab.h"
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.
45 * 2. All hash table operations still work on alist vectors.
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
54 * Growing or shrinking, with following rehashing, is triggered when
57 * L = N / S (N: number of items in table, S: bucket vector length)
59 * passes an upper limit of 0.9 or a lower limit of 0.25.
61 * The implementation stores the upper and lower number of items which
62 * trigger a resize in the hashtable object.
64 * Possible hash table sizes (primes) are stored in the array
68 scm_t_bits scm_tc16_hashtable;
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
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 */
80 #define HASHTABLE_SIZE_N (sizeof(hashtable_size)/sizeof(unsigned long))
82 static char *s_hashtable = "hashtable";
84 SCM weak_hashtables = SCM_EOL;
87 make_hash_table (int flags, unsigned long k, const char *func_name)
91 int i = 0, n = k ? k : 31;
92 while (i < HASHTABLE_SIZE_N && n > hashtable_size[i])
94 n = hashtable_size[i];
96 vector = scm_i_allocate_weak_vector (flags, scm_from_int (n), SCM_EOL);
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;
103 t->upper = 9 * n / 10;
108 SCM_NEWSMOB3 (table, scm_tc16_hashtable, vector, t, weak_hashtables);
109 weak_hashtables = table;
112 SCM_NEWSMOB3 (table, scm_tc16_hashtable, vector, t, SCM_EOL);
117 scm_i_rehash (SCM table,
118 unsigned long (*hash_fn)(),
120 const char* func_name)
122 SCM buckets, new_buckets;
124 unsigned long old_size;
125 unsigned long new_size;
127 if (SCM_HASHTABLE_N_ITEMS (table) < SCM_HASHTABLE_LOWER (table))
129 /* rehashing is not triggered when i <= min_size */
130 i = SCM_HASHTABLE (table)->size_index;
133 while (i > SCM_HASHTABLE (table)->min_size_index
134 && SCM_HASHTABLE_N_ITEMS (table) < hashtable_size[i] / 4);
138 i = SCM_HASHTABLE (table)->size_index + 1;
139 if (i >= HASHTABLE_SIZE_N)
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.
148 SCM_HASHTABLE (table)->hash_fn = hash_fn;
150 SCM_HASHTABLE (table)->size_index = i;
152 new_size = hashtable_size[i];
153 if (i <= SCM_HASHTABLE (table)->min_size_index)
154 SCM_HASHTABLE (table)->lower = 0;
156 SCM_HASHTABLE (table)->lower = new_size / 4;
157 SCM_HASHTABLE (table)->upper = 9 * new_size / 10;
158 buckets = SCM_HASHTABLE_VECTOR (table);
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),
165 new_buckets = scm_c_make_vector (new_size, SCM_EOL);
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
174 SCM_SET_HASHTABLE_VECTOR (table, new_buckets);
175 SCM_SET_HASHTABLE_N_ITEMS (table, 0);
177 old_size = SCM_SIMPLE_VECTOR_LENGTH (buckets);
178 for (i = 0; i < old_size; ++i)
180 SCM ls, cell, handle;
182 ls = SCM_SIMPLE_VECTOR_REF (buckets, i);
183 SCM_SIMPLE_VECTOR_SET (buckets, i, SCM_EOL);
185 while (scm_is_pair (ls))
189 handle = SCM_CAR (cell);
191 h = hash_fn (SCM_CAR (handle), new_size, closure);
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);
203 hashtable_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED)
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)),
217 scm_puts (">", port);
221 #define UNMARKED_CELL_P(x) (SCM_NIMP(x) && !SCM_GC_MARK_P (x))
223 /* keep track of hash tables that need to shrink after scan */
224 static SCM to_rehash = SCM_EOL;
226 /* scan hash tables and update hash tables item count */
228 scm_i_scan_weak_hashtables ()
230 SCM *next = &weak_hashtables;
232 while (!scm_is_null (h))
234 if (!SCM_GC_MARK_P (h))
235 *next = h = SCM_HASHTABLE_NEXT (h);
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);
243 if (SCM_HASHTABLE_N_ITEMS (h) < SCM_HASHTABLE_LOWER (h))
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);
253 next = SCM_HASHTABLE_NEXTLOC (h);
254 h = SCM_HASHTABLE_NEXT (h);
261 rehash_after_gc (void *dummy1 SCM_UNUSED,
262 void *dummy2 SCM_UNUSED,
263 void *dummy3 SCM_UNUSED)
265 if (!scm_is_null (to_rehash))
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 */
274 /* Rehash only when we have a hash_fn.
276 if (SCM_HASHTABLE (h)->hash_fn)
277 scm_i_rehash (h, SCM_HASHTABLE (h)->hash_fn, NULL,
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;
290 hashtable_free (SCM obj)
292 scm_gc_free (SCM_HASHTABLE (obj), sizeof (scm_t_hashtable), s_hashtable);
298 scm_c_make_hash_table (unsigned long k)
300 return make_hash_table (0, k, "scm_c_make_hash_table");
303 SCM_DEFINE (scm_make_hash_table, "make-hash-table", 0, 1, 0,
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
309 return make_hash_table (0, 0, FUNC_NAME);
311 return make_hash_table (0, scm_to_ulong (n), FUNC_NAME);
315 SCM_DEFINE (scm_make_weak_key_hash_table, "make-weak-key-hash-table", 0, 1, 0,
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"
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
326 return make_hash_table (SCM_HASHTABLEF_WEAK_CAR, 0, FUNC_NAME);
328 return make_hash_table (SCM_HASHTABLEF_WEAK_CAR,
329 scm_to_ulong (n), FUNC_NAME);
334 SCM_DEFINE (scm_make_weak_value_hash_table, "make-weak-value-hash-table", 0, 1, 0,
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
341 return make_hash_table (SCM_HASHTABLEF_WEAK_CDR, 0, FUNC_NAME);
344 return make_hash_table (SCM_HASHTABLEF_WEAK_CDR,
345 scm_to_ulong (n), FUNC_NAME);
351 SCM_DEFINE (scm_make_doubly_weak_hash_table, "make-doubly-weak-hash-table", 1, 0, 0,
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
358 return make_hash_table (SCM_HASHTABLEF_WEAK_CAR | SCM_HASHTABLEF_WEAK_CDR,
363 return make_hash_table (SCM_HASHTABLEF_WEAK_CAR | SCM_HASHTABLEF_WEAK_CDR,
371 SCM_DEFINE (scm_hash_table_p, "hash-table?", 1, 0, 0,
373 "Return @code{#t} if @var{obj} is an abstract hash table object.")
374 #define FUNC_NAME s_scm_hash_table_p
376 return scm_from_bool (SCM_HASHTABLE_P (obj));
381 SCM_DEFINE (scm_weak_key_hash_table_p, "weak-key-hash-table?", 1, 0, 0,
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
390 return scm_from_bool (SCM_HASHTABLE_P (obj) && SCM_HASHTABLE_WEAK_KEY_P (obj));
395 SCM_DEFINE (scm_weak_value_hash_table_p, "weak-value-hash-table?", 1, 0, 0,
397 "Return @code{#t} if @var{obj} is a weak value hash table.")
398 #define FUNC_NAME s_scm_weak_value_hash_table_p
400 return scm_from_bool (SCM_HASHTABLE_P (obj) && SCM_HASHTABLE_WEAK_VALUE_P (obj));
405 SCM_DEFINE (scm_doubly_weak_hash_table_p, "doubly-weak-hash-table?", 1, 0, 0,
407 "Return @code{#t} if @var{obj} is a doubly weak hash table.")
408 #define FUNC_NAME s_scm_doubly_weak_hash_table_p
410 return scm_from_bool (SCM_HASHTABLE_P (obj) && SCM_HASHTABLE_DOUBLY_WEAK_P (obj));
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"
422 if (SCM_HASHTABLE_P (table))
423 table = SCM_HASHTABLE_VECTOR (table);
425 SCM_VALIDATE_VECTOR (1, table);
426 if (SCM_SIMPLE_VECTOR_LENGTH (table) == 0)
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);
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"
445 if (SCM_HASHTABLE_P (table))
446 buckets = SCM_HASHTABLE_VECTOR (table);
449 SCM_ASSERT (scm_is_simple_vector (table),
450 table, SCM_ARG1, "hash_fn_create_handle_x");
453 if (SCM_SIMPLE_VECTOR_LENGTH (buckets) == 0)
454 SCM_MISC_ERROR ("void hashtable", SCM_EOL);
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))
462 else if (scm_is_true (it))
463 scm_wrong_type_arg_msg (NULL, 0, it, "a pair");
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.
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))
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));
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))
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
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);
495 return SCM_CAR (new_bucket);
502 scm_hash_fn_ref (SCM table, SCM obj, SCM dflt, unsigned long (*hash_fn)(),
503 SCM (*assoc_fn)(), void * closure)
505 SCM it = scm_hash_fn_get_handle (table, obj, hash_fn, assoc_fn, closure);
506 if (scm_is_pair (it))
516 scm_hash_fn_set_x (SCM table, SCM obj, SCM val, unsigned long (*hash_fn)(),
517 SCM (*assoc_fn)(), void * closure)
521 it = scm_hash_fn_create_handle_x (table, obj, SCM_BOOL_F, hash_fn, assoc_fn, closure);
522 SCM_SETCDR (it, val);
528 scm_hash_fn_remove_x (SCM table, SCM obj,
529 unsigned long (*hash_fn)(),
536 if (SCM_HASHTABLE_P (table))
537 buckets = SCM_HASHTABLE_VECTOR (table);
540 SCM_ASSERT (scm_is_simple_vector (table), table,
541 SCM_ARG1, "hash_fn_remove_x");
544 if (SCM_SIMPLE_VECTOR_LENGTH (table) == 0)
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);
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))
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");
565 SCM_DEFINE (scm_hash_clear_x, "hash-clear!", 1, 0, 0,
567 "Remove all items from @var{table} (without triggering a resize).")
568 #define FUNC_NAME s_scm_hash_clear_x
570 if (SCM_HASHTABLE_P (table))
572 scm_vector_fill_x (SCM_HASHTABLE_VECTOR (table), SCM_EOL);
573 SCM_SET_HASHTABLE_N_ITEMS (table, 0);
576 scm_vector_fill_x (table, SCM_EOL);
577 return SCM_UNSPECIFIED;
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
591 return scm_hash_fn_get_handle (table, key, scm_ihashq, scm_sloppy_assq, 0);
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
603 return scm_hash_fn_create_handle_x (table, key, init, scm_ihashq, scm_sloppy_assq, 0);
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
616 if (SCM_UNBNDP (dflt))
618 return scm_hash_fn_ref (table, key, dflt, scm_ihashq, scm_sloppy_assq, 0);
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
630 return scm_hash_fn_set_x (table, key, val, scm_ihashq, scm_sloppy_assq, 0);
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
642 return scm_hash_fn_remove_x (table, key, scm_ihashq, scm_sloppy_assq, 0);
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
657 return scm_hash_fn_get_handle (table, key, scm_ihashv, scm_sloppy_assv, 0);
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
669 return scm_hash_fn_create_handle_x (table, key, init, scm_ihashv,
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
683 if (SCM_UNBNDP (dflt))
685 return scm_hash_fn_ref (table, key, dflt, scm_ihashv, scm_sloppy_assv, 0);
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
697 return scm_hash_fn_set_x (table, key, val, scm_ihashv, scm_sloppy_assv, 0);
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
708 return scm_hash_fn_remove_x (table, key, scm_ihashv, scm_sloppy_assv, 0);
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
722 return scm_hash_fn_get_handle (table, key, scm_ihash, scm_sloppy_assoc, 0);
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
734 return scm_hash_fn_create_handle_x (table, key, init, scm_ihash, scm_sloppy_assoc, 0);
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
747 if (SCM_UNBNDP (dflt))
749 return scm_hash_fn_ref (table, key, dflt, scm_ihash, scm_sloppy_assoc, 0);
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"
760 #define FUNC_NAME s_scm_hash_set_x
762 return scm_hash_fn_set_x (table, key, val, scm_ihash, scm_sloppy_assoc, 0);
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
774 return scm_hash_fn_remove_x (table, key, scm_ihash, scm_sloppy_assoc, 0);
781 typedef struct scm_t_ihashx_closure
785 } scm_t_ihashx_closure;
790 scm_ihashx (SCM obj, unsigned long n, scm_t_ihashx_closure *closure)
792 SCM answer = scm_call_2 (closure->hash, obj, scm_from_ulong (n));
793 return scm_to_ulong (answer);
799 scm_sloppy_assx (SCM obj, SCM alist, scm_t_ihashx_closure *closure)
801 return scm_call_2 (closure->assoc, obj, alist);
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
815 scm_t_ihashx_closure closure;
817 closure.assoc = assoc;
818 return scm_hash_fn_get_handle (table, key, scm_ihashx, scm_sloppy_assx,
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
834 scm_t_ihashx_closure closure;
836 closure.assoc = assoc;
837 return scm_hash_fn_create_handle_x (table, key, init, scm_ihashx,
838 scm_sloppy_assx, (void *)&closure);
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"
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
857 scm_t_ihashx_closure closure;
858 if (SCM_UNBNDP (dflt))
861 closure.assoc = assoc;
862 return scm_hash_fn_ref (table, key, dflt, scm_ihashx, scm_sloppy_assx,
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"
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
883 scm_t_ihashx_closure closure;
885 closure.assoc = assoc;
886 return scm_hash_fn_set_x (table, key, val, scm_ihashx, scm_sloppy_assx,
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"
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
904 scm_t_ihashx_closure closure;
906 closure.assoc = assoc;
907 return scm_hash_fn_remove_x (table, obj, scm_ihashx, scm_sloppy_assx,
912 /* Hash table iterators */
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
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);
934 for_each_proc (void *proc, SCM handle)
936 return scm_call_2 (SCM_PACK (proc), SCM_CAR (handle), SCM_CDR (handle));
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
947 SCM_VALIDATE_PROC (1, proc);
948 if (!SCM_HASHTABLE_P (table))
949 SCM_VALIDATE_VECTOR (2, table);
951 scm_internal_hash_for_each_handle (for_each_proc,
952 (void *) SCM_UNPACK (proc),
954 return SCM_UNSPECIFIED;
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
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);
969 scm_internal_hash_for_each_handle (call,
970 (void *) SCM_UNPACK (proc),
972 return SCM_UNSPECIFIED;
977 map_proc (void *proc, SCM key, SCM data, SCM value)
979 return scm_cons (scm_call_2 (SCM_PACK (proc), key, data), value);
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
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),
1003 scm_internal_hash_fold (SCM (*fn) (), void *closure, SCM init, SCM table)
1006 SCM buckets, result = init;
1008 if (SCM_HASHTABLE_P (table))
1009 buckets = SCM_HASHTABLE_VECTOR (table);
1013 n = SCM_SIMPLE_VECTOR_LENGTH (buckets);
1014 for (i = 0; i < n; ++i)
1016 SCM ls = SCM_SIMPLE_VECTOR_REF (buckets, i), handle;
1017 while (!scm_is_null (ls))
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);
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
1039 scm_internal_hash_for_each_handle (SCM (*fn) (), void *closure, SCM table)
1044 if (SCM_HASHTABLE_P (table))
1045 buckets = SCM_HASHTABLE_VECTOR (table);
1049 n = SCM_SIMPLE_VECTOR_LENGTH (buckets);
1050 for (i = 0; i < n; ++i)
1052 SCM ls = SCM_SIMPLE_VECTOR_REF (buckets, i), handle;
1053 while (!scm_is_null (ls))
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);
1070 scm_hashtab_prehistory ()
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);
1082 #include "libguile/hashtab.x"