1 /* Copyright (C) 1995,1996,1998,1999,2000,2001, 2003, 2004, 2006 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
23 #include "libguile/_scm.h"
24 #include "libguile/alist.h"
25 #include "libguile/hash.h"
26 #include "libguile/eval.h"
27 #include "libguile/root.h"
28 #include "libguile/vectors.h"
29 #include "libguile/ports.h"
31 #include "libguile/validate.h"
32 #include "libguile/hashtab.h"
39 * 1. The current hash table implementation uses weak alist vectors
40 * (implementation in weaks.c) internally, but we do the scanning
41 * ourselves (in scan_weak_hashtables) because we need to update the
42 * hash table structure when items are dropped during GC.
44 * 2. All hash table operations still work on alist vectors.
48 /* Hash tables are either vectors of association lists or smobs
49 * containing such vectors. Currently, the vector version represents
50 * constant size tables while those wrapped in a smob represents
53 * Growing or shrinking, with following rehashing, is triggered when
56 * L = N / S (N: number of items in table, S: bucket vector length)
58 * passes an upper limit of 0.9 or a lower limit of 0.25.
60 * The implementation stores the upper and lower number of items which
61 * trigger a resize in the hashtable object.
63 * Possible hash table sizes (primes) are stored in the array
67 scm_t_bits scm_tc16_hashtable
;
69 static unsigned long hashtable_size
[] = {
70 31, 61, 113, 223, 443, 883, 1759, 3517, 7027, 14051, 28099, 56197, 112363,
71 224717, 449419, 898823, 1797641, 3595271, 7190537, 14381041
73 /* vectors are currently restricted to 2^24-1 = 16777215 elements. */
74 28762081, 57524111, 115048217, 230096423, 460192829
75 /* larger values can't be represented as INUMs */
79 #define HASHTABLE_SIZE_N (sizeof(hashtable_size)/sizeof(unsigned long))
81 static char *s_hashtable
= "hashtable";
85 /* Helper functions and macros to deal with weak pairs.
87 Weak pairs need to be accessed very carefully since their components can
88 be nullified by the GC when the object they refer to becomes unreachable.
89 Hence the macros and functions below that detect such weak pairs within
90 buckets and remove them. */
93 /* Return a ``usable'' version of ALIST, an alist of weak pairs. By
94 ``usable'', we mean that it contains only valid Scheme objects. On
95 return, REMOVE_ITEMS is set to the number of pairs that have been
98 scm_fixup_weak_alist (SCM alist
, size_t *removed_items
)
106 prev
= alist
, alist
= SCM_CDR (alist
))
108 SCM pair
= SCM_CAR (alist
);
110 if (scm_is_pair (pair
))
112 if (SCM_WEAK_PAIR_DELETED_P (pair
))
114 /* Remove from ALIST weak pair PAIR whose car/cdr has been
115 nullified by the GC. */
117 result
= SCM_CDR (alist
);
119 SCM_SETCDR (prev
, SCM_CDR (alist
));
133 /* Return true if OBJ is either a weak hash table or a weak alist vector (as
134 defined in `weaks.[ch]').
135 FIXME: We should eventually keep only weah hash tables. Actually, the
136 procs in `weaks.c' already no longer return vectors. */
137 /* XXX: We assume that if OBJ is a vector, then it's a _weak_ alist vector. */
138 #define IS_WEAK_THING(_obj) \
139 ((SCM_HASHTABLE_P (table) && (SCM_HASHTABLE_WEAK_P (table))) \
140 || (SCM_I_IS_VECTOR (table)))
144 /* Fixup BUCKET, an alist part of weak hash table OBJ. BUCKETS is the full
145 bucket vector for OBJ and IDX is the index of BUCKET within this
146 vector. See also `scm_internal_hash_fold ()'. */
147 #define START_WEAK_BUCKET_FIXUP(_obj, _buckets, _idx, _bucket, _hashfn) \
152 /* Disable the GC so that BUCKET remains valid until ASSOC_FN has \
154 /* FIXME: We could maybe trigger a rehash here depending on whether \
155 `scm_fixup_weak_alist ()' noticed some change. */ \
157 (_bucket) = scm_fixup_weak_alist ((_bucket), &_removed); \
158 SCM_SIMPLE_VECTOR_SET ((_buckets), (_idx), (_bucket)); \
160 if ((_removed) && (SCM_HASHTABLE_P (_obj))) \
162 SCM_SET_HASHTABLE_N_ITEMS ((_obj), \
163 SCM_HASHTABLE_N_ITEMS (_obj) - _removed); \
164 scm_i_rehash ((_obj), (_hashfn), \
165 NULL, "START_WEAK_BUCKET_FIXUP"); \
170 /* Terminate a weak bucket fixup phase. */
171 #define END_WEAK_BUCKET_FIXUP(_obj, _buckets, _idx, _bucket, _hashfn) \
172 do { GC_enable (); } while (0)
177 make_hash_table (int flags
, unsigned long k
, const char *func_name
)
181 int i
= 0, n
= k
? k
: 31;
182 while (i
< HASHTABLE_SIZE_N
&& n
> hashtable_size
[i
])
184 n
= hashtable_size
[i
];
186 /* In both cases, i.e., regardless of whether we are creating a weak hash
187 table, we return a non-weak vector. This is because the vector itself
188 is not weak in the case of a weak hash table: the alist pairs are. */
189 vector
= scm_c_make_vector (n
, SCM_EOL
);
191 t
= scm_gc_malloc_pointerless (sizeof (*t
), s_hashtable
);
192 t
->min_size_index
= t
->size_index
= i
;
195 t
->upper
= 9 * n
/ 10;
199 SCM_NEWSMOB2 (table
, scm_tc16_hashtable
, vector
, t
);
205 scm_i_rehash (SCM table
,
206 unsigned long (*hash_fn
)(),
208 const char* func_name
)
210 SCM buckets
, new_buckets
;
212 unsigned long old_size
;
213 unsigned long new_size
;
215 if (SCM_HASHTABLE_N_ITEMS (table
) < SCM_HASHTABLE_LOWER (table
))
217 /* rehashing is not triggered when i <= min_size */
218 i
= SCM_HASHTABLE (table
)->size_index
;
221 while (i
> SCM_HASHTABLE (table
)->min_size_index
222 && SCM_HASHTABLE_N_ITEMS (table
) < hashtable_size
[i
] / 4);
226 i
= SCM_HASHTABLE (table
)->size_index
+ 1;
227 if (i
>= HASHTABLE_SIZE_N
)
231 /* Remember HASH_FN for rehash_after_gc, but only when CLOSURE
232 is not needed since CLOSURE can not be guaranteed to be valid
233 after this function returns.
236 SCM_HASHTABLE (table
)->hash_fn
= hash_fn
;
238 SCM_HASHTABLE (table
)->size_index
= i
;
240 new_size
= hashtable_size
[i
];
241 if (i
<= SCM_HASHTABLE (table
)->min_size_index
)
242 SCM_HASHTABLE (table
)->lower
= 0;
244 SCM_HASHTABLE (table
)->lower
= new_size
/ 4;
245 SCM_HASHTABLE (table
)->upper
= 9 * new_size
/ 10;
246 buckets
= SCM_HASHTABLE_VECTOR (table
);
248 new_buckets
= scm_c_make_vector (new_size
, SCM_EOL
);
250 /* When this is a weak hashtable, running the GC might change it.
251 We need to cope with this while rehashing its elements. We do
252 this by first installing the new, empty bucket vector. Then we
253 remove the elements from the old bucket vector and insert them
257 SCM_SET_HASHTABLE_VECTOR (table
, new_buckets
);
258 SCM_SET_HASHTABLE_N_ITEMS (table
, 0);
260 old_size
= SCM_SIMPLE_VECTOR_LENGTH (buckets
);
261 for (i
= 0; i
< old_size
; ++i
)
263 SCM ls
, cell
, handle
;
265 ls
= SCM_SIMPLE_VECTOR_REF (buckets
, i
);
266 SCM_SIMPLE_VECTOR_SET (buckets
, i
, SCM_EOL
);
268 while (scm_is_pair (ls
))
273 handle
= SCM_CAR (cell
);
276 if (SCM_WEAK_PAIR_DELETED_P (handle
))
277 /* HANDLE is a nullified weak pair: skip it. */
280 h
= hash_fn (SCM_CAR (handle
), new_size
, closure
);
282 scm_out_of_range (func_name
, scm_from_ulong (h
));
283 SCM_SETCDR (cell
, SCM_SIMPLE_VECTOR_REF (new_buckets
, h
));
284 SCM_SIMPLE_VECTOR_SET (new_buckets
, h
, cell
);
285 SCM_HASHTABLE_INCREMENT (table
);
292 hashtable_print (SCM exp
, SCM port
, scm_print_state
*pstate SCM_UNUSED
)
294 scm_puts ("#<", port
);
295 if (SCM_HASHTABLE_WEAK_KEY_P (exp
))
296 scm_puts ("weak-key-", port
);
297 else if (SCM_HASHTABLE_WEAK_VALUE_P (exp
))
298 scm_puts ("weak-value-", port
);
299 else if (SCM_HASHTABLE_DOUBLY_WEAK_P (exp
))
300 scm_puts ("doubly-weak-", port
);
301 scm_puts ("hash-table ", port
);
302 scm_uintprint (SCM_HASHTABLE_N_ITEMS (exp
), 10, port
);
303 scm_putc ('/', port
);
304 scm_uintprint (SCM_SIMPLE_VECTOR_LENGTH (SCM_HASHTABLE_VECTOR (exp
)),
306 scm_puts (">", port
);
312 scm_c_make_hash_table (unsigned long k
)
314 return make_hash_table (0, k
, "scm_c_make_hash_table");
317 SCM_DEFINE (scm_make_hash_table
, "make-hash-table", 0, 1, 0,
319 "Make a new abstract hash table object with minimum number of buckets @var{n}\n")
320 #define FUNC_NAME s_scm_make_hash_table
323 return make_hash_table (0, 0, FUNC_NAME
);
325 return make_hash_table (0, scm_to_ulong (n
), FUNC_NAME
);
329 SCM_DEFINE (scm_make_weak_key_hash_table
, "make-weak-key-hash-table", 0, 1, 0,
331 "@deffnx {Scheme Procedure} make-weak-value-hash-table size\n"
332 "@deffnx {Scheme Procedure} make-doubly-weak-hash-table size\n"
333 "Return a weak hash table with @var{size} buckets.\n"
335 "You can modify weak hash tables in exactly the same way you\n"
336 "would modify regular hash tables. (@pxref{Hash Tables})")
337 #define FUNC_NAME s_scm_make_weak_key_hash_table
340 return make_hash_table (SCM_HASHTABLEF_WEAK_CAR
, 0, FUNC_NAME
);
342 return make_hash_table (SCM_HASHTABLEF_WEAK_CAR
,
343 scm_to_ulong (n
), FUNC_NAME
);
348 SCM_DEFINE (scm_make_weak_value_hash_table
, "make-weak-value-hash-table", 0, 1, 0,
350 "Return a hash table with weak values with @var{size} buckets.\n"
351 "(@pxref{Hash Tables})")
352 #define FUNC_NAME s_scm_make_weak_value_hash_table
355 return make_hash_table (SCM_HASHTABLEF_WEAK_CDR
, 0, FUNC_NAME
);
358 return make_hash_table (SCM_HASHTABLEF_WEAK_CDR
,
359 scm_to_ulong (n
), FUNC_NAME
);
365 SCM_DEFINE (scm_make_doubly_weak_hash_table
, "make-doubly-weak-hash-table", 1, 0, 0,
367 "Return a hash table with weak keys and values with @var{size}\n"
368 "buckets. (@pxref{Hash Tables})")
369 #define FUNC_NAME s_scm_make_doubly_weak_hash_table
372 return make_hash_table (SCM_HASHTABLEF_WEAK_CAR
| SCM_HASHTABLEF_WEAK_CDR
,
377 return make_hash_table (SCM_HASHTABLEF_WEAK_CAR
| SCM_HASHTABLEF_WEAK_CDR
,
385 SCM_DEFINE (scm_hash_table_p
, "hash-table?", 1, 0, 0,
387 "Return @code{#t} if @var{obj} is an abstract hash table object.")
388 #define FUNC_NAME s_scm_hash_table_p
390 return scm_from_bool (SCM_HASHTABLE_P (obj
));
395 SCM_DEFINE (scm_weak_key_hash_table_p
, "weak-key-hash-table?", 1, 0, 0,
397 "@deffnx {Scheme Procedure} weak-value-hash-table? obj\n"
398 "@deffnx {Scheme Procedure} doubly-weak-hash-table? obj\n"
399 "Return @code{#t} if @var{obj} is the specified weak hash\n"
400 "table. Note that a doubly weak hash table is neither a weak key\n"
401 "nor a weak value hash table.")
402 #define FUNC_NAME s_scm_weak_key_hash_table_p
404 return scm_from_bool (SCM_HASHTABLE_P (obj
) && SCM_HASHTABLE_WEAK_KEY_P (obj
));
409 SCM_DEFINE (scm_weak_value_hash_table_p
, "weak-value-hash-table?", 1, 0, 0,
411 "Return @code{#t} if @var{obj} is a weak value hash table.")
412 #define FUNC_NAME s_scm_weak_value_hash_table_p
414 return scm_from_bool (SCM_HASHTABLE_P (obj
) && SCM_HASHTABLE_WEAK_VALUE_P (obj
));
419 SCM_DEFINE (scm_doubly_weak_hash_table_p
, "doubly-weak-hash-table?", 1, 0, 0,
421 "Return @code{#t} if @var{obj} is a doubly weak hash table.")
422 #define FUNC_NAME s_scm_doubly_weak_hash_table_p
424 return scm_from_bool (SCM_HASHTABLE_P (obj
) && SCM_HASHTABLE_DOUBLY_WEAK_P (obj
));
430 scm_hash_fn_get_handle (SCM table
, SCM obj
, unsigned long (*hash_fn
)(), SCM (*assoc_fn
)(), void * closure
)
431 #define FUNC_NAME "scm_hash_fn_get_handle"
435 SCM buckets
, alist
, h
;
437 if (SCM_HASHTABLE_P (table
))
438 buckets
= SCM_HASHTABLE_VECTOR (table
);
441 SCM_VALIDATE_VECTOR (1, table
);
445 if (SCM_SIMPLE_VECTOR_LENGTH (buckets
) == 0)
447 k
= hash_fn (obj
, SCM_SIMPLE_VECTOR_LENGTH (buckets
), closure
);
448 if (k
>= SCM_SIMPLE_VECTOR_LENGTH (buckets
))
449 scm_out_of_range ("hash_fn_get_handle", scm_from_ulong (k
));
451 weak
= IS_WEAK_THING (table
);
452 alist
= SCM_SIMPLE_VECTOR_REF (buckets
, k
);
455 START_WEAK_BUCKET_FIXUP (table
, buckets
, k
, alist
, hash_fn
);
457 h
= assoc_fn (obj
, alist
, closure
);
459 END_WEAK_BUCKET_FIXUP (table
, buckets
, k
, alist
, hash_fn
);
467 scm_hash_fn_create_handle_x (SCM table
, SCM obj
, SCM init
, unsigned long (*hash_fn
)(),
468 SCM (*assoc_fn
)(), void * closure
)
469 #define FUNC_NAME "scm_hash_fn_create_handle_x"
473 SCM buckets
, alist
, it
;
475 if (SCM_HASHTABLE_P (table
))
476 buckets
= SCM_HASHTABLE_VECTOR (table
);
479 SCM_ASSERT (scm_is_simple_vector (table
),
480 table
, SCM_ARG1
, "hash_fn_create_handle_x");
483 if (SCM_SIMPLE_VECTOR_LENGTH (buckets
) == 0)
484 SCM_MISC_ERROR ("void hashtable", SCM_EOL
);
486 k
= hash_fn (obj
, SCM_SIMPLE_VECTOR_LENGTH (buckets
), closure
);
487 if (k
>= SCM_SIMPLE_VECTOR_LENGTH (buckets
))
488 scm_out_of_range ("hash_fn_create_handle_x", scm_from_ulong (k
));
490 weak
= IS_WEAK_THING (table
);
491 alist
= SCM_SIMPLE_VECTOR_REF (buckets
, k
);
493 START_WEAK_BUCKET_FIXUP (table
, buckets
, k
, alist
, hash_fn
);
495 it
= assoc_fn (obj
, alist
, closure
);
497 END_WEAK_BUCKET_FIXUP (table
, buckets
, k
, alist
, hash_fn
);
499 if (scm_is_true (it
))
503 /* When this is a weak hashtable, running the GC can change it.
504 Thus, we must allocate the new cells first and can only then
505 access BUCKETS. Also, we need to fetch the bucket vector
506 again since the hashtable might have been rehashed. This
507 necessitates a new hash value as well.
509 SCM handle
, new_bucket
;
511 if ((SCM_HASHTABLE_P (table
)) && (SCM_HASHTABLE_WEAK_P (table
)))
513 /* FIXME: We don't support weak alist vectors. */
514 /* Use a weak cell. */
515 if (SCM_HASHTABLE_DOUBLY_WEAK_P (table
))
516 handle
= scm_doubly_weak_pair (obj
, init
);
517 else if (SCM_HASHTABLE_WEAK_KEY_P (table
))
518 handle
= scm_weak_car_pair (obj
, init
);
520 handle
= scm_weak_cdr_pair (obj
, init
);
523 /* Use a regular, non-weak cell. */
524 handle
= scm_cons (obj
, init
);
526 new_bucket
= scm_cons (handle
, SCM_EOL
);
528 if (!scm_is_eq (table
, buckets
)
529 && !scm_is_eq (SCM_HASHTABLE_VECTOR (table
), buckets
))
531 buckets
= SCM_HASHTABLE_VECTOR (table
);
532 k
= hash_fn (obj
, SCM_SIMPLE_VECTOR_LENGTH (buckets
), closure
);
533 if (k
>= SCM_SIMPLE_VECTOR_LENGTH (buckets
))
534 scm_out_of_range ("hash_fn_create_handle_x", scm_from_ulong (k
));
536 SCM_SETCDR (new_bucket
, SCM_SIMPLE_VECTOR_REF (buckets
, k
));
537 SCM_SIMPLE_VECTOR_SET (buckets
, k
, new_bucket
);
538 if (!scm_is_eq (table
, buckets
))
540 /* Update element count and maybe rehash the table. The
541 table might have too few entries here since weak hash
542 tables used with the hashx_* functions can not be
545 SCM_HASHTABLE_INCREMENT (table
);
546 if (SCM_HASHTABLE_N_ITEMS (table
) < SCM_HASHTABLE_LOWER (table
)
547 || SCM_HASHTABLE_N_ITEMS (table
) > SCM_HASHTABLE_UPPER (table
))
548 scm_i_rehash (table
, hash_fn
, closure
, FUNC_NAME
);
550 return SCM_CAR (new_bucket
);
557 scm_hash_fn_ref (SCM table
, SCM obj
, SCM dflt
, unsigned long (*hash_fn
)(),
558 SCM (*assoc_fn
)(), void * closure
)
560 SCM it
= scm_hash_fn_get_handle (table
, obj
, hash_fn
, assoc_fn
, closure
);
561 if (scm_is_pair (it
))
571 scm_hash_fn_set_x (SCM table
, SCM obj
, SCM val
, unsigned long (*hash_fn
)(),
572 SCM (*assoc_fn
)(), void * closure
)
576 it
= scm_hash_fn_create_handle_x (table
, obj
, SCM_BOOL_F
, hash_fn
, assoc_fn
, closure
);
577 SCM_SETCDR (it
, val
);
583 scm_hash_fn_remove_x (SCM table
, SCM obj
,
584 unsigned long (*hash_fn
)(),
590 SCM buckets
, alist
, h
;
592 if (SCM_HASHTABLE_P (table
))
593 buckets
= SCM_HASHTABLE_VECTOR (table
);
596 SCM_ASSERT (scm_is_simple_vector (table
), table
,
597 SCM_ARG1
, "hash_fn_remove_x");
600 if (SCM_SIMPLE_VECTOR_LENGTH (table
) == 0)
603 k
= hash_fn (obj
, SCM_SIMPLE_VECTOR_LENGTH (buckets
), closure
);
604 if (k
>= SCM_SIMPLE_VECTOR_LENGTH (buckets
))
605 scm_out_of_range ("hash_fn_remove_x", scm_from_ulong (k
));
607 weak
= IS_WEAK_THING (table
);
608 alist
= SCM_SIMPLE_VECTOR_REF (buckets
, k
);
610 START_WEAK_BUCKET_FIXUP (table
, buckets
, k
, alist
, hash_fn
);
612 h
= assoc_fn (obj
, alist
, closure
);
614 END_WEAK_BUCKET_FIXUP (table
, buckets
, k
, alist
, hash_fn
);
618 SCM_SIMPLE_VECTOR_SET
619 (buckets
, k
, scm_delq_x (h
, SCM_SIMPLE_VECTOR_REF (buckets
, k
)));
620 if (!scm_is_eq (table
, buckets
))
622 SCM_HASHTABLE_DECREMENT (table
);
623 if (SCM_HASHTABLE_N_ITEMS (table
) < SCM_HASHTABLE_LOWER (table
))
624 scm_i_rehash (table
, hash_fn
, closure
, "scm_hash_fn_remove_x");
630 SCM_DEFINE (scm_hash_clear_x
, "hash-clear!", 1, 0, 0,
632 "Remove all items from @var{table} (without triggering a resize).")
633 #define FUNC_NAME s_scm_hash_clear_x
635 if (SCM_HASHTABLE_P (table
))
637 scm_vector_fill_x (SCM_HASHTABLE_VECTOR (table
), SCM_EOL
);
638 SCM_SET_HASHTABLE_N_ITEMS (table
, 0);
641 scm_vector_fill_x (table
, SCM_EOL
);
642 return SCM_UNSPECIFIED
;
648 SCM_DEFINE (scm_hashq_get_handle
, "hashq-get-handle", 2, 0, 0,
649 (SCM table
, SCM key
),
650 "This procedure returns the @code{(key . value)} pair from the\n"
651 "hash table @var{table}. If @var{table} does not hold an\n"
652 "associated value for @var{key}, @code{#f} is returned.\n"
653 "Uses @code{eq?} for equality testing.")
654 #define FUNC_NAME s_scm_hashq_get_handle
656 return scm_hash_fn_get_handle (table
, key
, scm_ihashq
, scm_sloppy_assq
, 0);
661 SCM_DEFINE (scm_hashq_create_handle_x
, "hashq-create-handle!", 3, 0, 0,
662 (SCM table
, SCM key
, SCM init
),
663 "This function looks up @var{key} in @var{table} and returns its handle.\n"
664 "If @var{key} is not already present, a new handle is created which\n"
665 "associates @var{key} with @var{init}.")
666 #define FUNC_NAME s_scm_hashq_create_handle_x
668 return scm_hash_fn_create_handle_x (table
, key
, init
, scm_ihashq
, scm_sloppy_assq
, 0);
673 SCM_DEFINE (scm_hashq_ref
, "hashq-ref", 2, 1, 0,
674 (SCM table
, SCM key
, SCM dflt
),
675 "Look up @var{key} in the hash table @var{table}, and return the\n"
676 "value (if any) associated with it. If @var{key} is not found,\n"
677 "return @var{default} (or @code{#f} if no @var{default} argument\n"
678 "is supplied). Uses @code{eq?} for equality testing.")
679 #define FUNC_NAME s_scm_hashq_ref
681 if (SCM_UNBNDP (dflt
))
683 return scm_hash_fn_ref (table
, key
, dflt
, scm_ihashq
, scm_sloppy_assq
, 0);
689 SCM_DEFINE (scm_hashq_set_x
, "hashq-set!", 3, 0, 0,
690 (SCM table
, SCM key
, SCM val
),
691 "Find the entry in @var{table} associated with @var{key}, and\n"
692 "store @var{value} there. Uses @code{eq?} for equality testing.")
693 #define FUNC_NAME s_scm_hashq_set_x
695 return scm_hash_fn_set_x (table
, key
, val
, scm_ihashq
, scm_sloppy_assq
, 0);
701 SCM_DEFINE (scm_hashq_remove_x
, "hashq-remove!", 2, 0, 0,
702 (SCM table
, SCM key
),
703 "Remove @var{key} (and any value associated with it) from\n"
704 "@var{table}. Uses @code{eq?} for equality tests.")
705 #define FUNC_NAME s_scm_hashq_remove_x
707 return scm_hash_fn_remove_x (table
, key
, scm_ihashq
, scm_sloppy_assq
, 0);
714 SCM_DEFINE (scm_hashv_get_handle
, "hashv-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{eqv?} for equality testing.")
720 #define FUNC_NAME s_scm_hashv_get_handle
722 return scm_hash_fn_get_handle (table
, key
, scm_ihashv
, scm_sloppy_assv
, 0);
727 SCM_DEFINE (scm_hashv_create_handle_x
, "hashv-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_hashv_create_handle_x
734 return scm_hash_fn_create_handle_x (table
, key
, init
, scm_ihashv
,
740 SCM_DEFINE (scm_hashv_ref
, "hashv-ref", 2, 1, 0,
741 (SCM table
, SCM key
, SCM dflt
),
742 "Look up @var{key} in the hash table @var{table}, and return the\n"
743 "value (if any) associated with it. If @var{key} is not found,\n"
744 "return @var{default} (or @code{#f} if no @var{default} argument\n"
745 "is supplied). Uses @code{eqv?} for equality testing.")
746 #define FUNC_NAME s_scm_hashv_ref
748 if (SCM_UNBNDP (dflt
))
750 return scm_hash_fn_ref (table
, key
, dflt
, scm_ihashv
, scm_sloppy_assv
, 0);
756 SCM_DEFINE (scm_hashv_set_x
, "hashv-set!", 3, 0, 0,
757 (SCM table
, SCM key
, SCM val
),
758 "Find the entry in @var{table} associated with @var{key}, and\n"
759 "store @var{value} there. Uses @code{eqv?} for equality testing.")
760 #define FUNC_NAME s_scm_hashv_set_x
762 return scm_hash_fn_set_x (table
, key
, val
, scm_ihashv
, scm_sloppy_assv
, 0);
767 SCM_DEFINE (scm_hashv_remove_x
, "hashv-remove!", 2, 0, 0,
768 (SCM table
, SCM key
),
769 "Remove @var{key} (and any value associated with it) from\n"
770 "@var{table}. Uses @code{eqv?} for equality tests.")
771 #define FUNC_NAME s_scm_hashv_remove_x
773 return scm_hash_fn_remove_x (table
, key
, scm_ihashv
, scm_sloppy_assv
, 0);
779 SCM_DEFINE (scm_hash_get_handle
, "hash-get-handle", 2, 0, 0,
780 (SCM table
, SCM key
),
781 "This procedure returns the @code{(key . value)} pair from the\n"
782 "hash table @var{table}. If @var{table} does not hold an\n"
783 "associated value for @var{key}, @code{#f} is returned.\n"
784 "Uses @code{equal?} for equality testing.")
785 #define FUNC_NAME s_scm_hash_get_handle
787 return scm_hash_fn_get_handle (table
, key
, scm_ihash
, scm_sloppy_assoc
, 0);
792 SCM_DEFINE (scm_hash_create_handle_x
, "hash-create-handle!", 3, 0, 0,
793 (SCM table
, SCM key
, SCM init
),
794 "This function looks up @var{key} in @var{table} and returns its handle.\n"
795 "If @var{key} is not already present, a new handle is created which\n"
796 "associates @var{key} with @var{init}.")
797 #define FUNC_NAME s_scm_hash_create_handle_x
799 return scm_hash_fn_create_handle_x (table
, key
, init
, scm_ihash
, scm_sloppy_assoc
, 0);
804 SCM_DEFINE (scm_hash_ref
, "hash-ref", 2, 1, 0,
805 (SCM table
, SCM key
, SCM dflt
),
806 "Look up @var{key} in the hash table @var{table}, and return the\n"
807 "value (if any) associated with it. If @var{key} is not found,\n"
808 "return @var{default} (or @code{#f} if no @var{default} argument\n"
809 "is supplied). Uses @code{equal?} for equality testing.")
810 #define FUNC_NAME s_scm_hash_ref
812 if (SCM_UNBNDP (dflt
))
814 return scm_hash_fn_ref (table
, key
, dflt
, scm_ihash
, scm_sloppy_assoc
, 0);
820 SCM_DEFINE (scm_hash_set_x
, "hash-set!", 3, 0, 0,
821 (SCM table
, SCM key
, SCM val
),
822 "Find the entry in @var{table} associated with @var{key}, and\n"
823 "store @var{value} there. Uses @code{equal?} for equality\n"
825 #define FUNC_NAME s_scm_hash_set_x
827 return scm_hash_fn_set_x (table
, key
, val
, scm_ihash
, scm_sloppy_assoc
, 0);
833 SCM_DEFINE (scm_hash_remove_x
, "hash-remove!", 2, 0, 0,
834 (SCM table
, SCM key
),
835 "Remove @var{key} (and any value associated with it) from\n"
836 "@var{table}. Uses @code{equal?} for equality tests.")
837 #define FUNC_NAME s_scm_hash_remove_x
839 return scm_hash_fn_remove_x (table
, key
, scm_ihash
, scm_sloppy_assoc
, 0);
846 typedef struct scm_t_ihashx_closure
850 } scm_t_ihashx_closure
;
855 scm_ihashx (SCM obj
, unsigned long n
, scm_t_ihashx_closure
*closure
)
857 SCM answer
= scm_call_2 (closure
->hash
, obj
, scm_from_ulong (n
));
858 return scm_to_ulong (answer
);
864 scm_sloppy_assx (SCM obj
, SCM alist
, scm_t_ihashx_closure
*closure
)
866 return scm_call_2 (closure
->assoc
, obj
, alist
);
870 SCM_DEFINE (scm_hashx_get_handle
, "hashx-get-handle", 4, 0, 0,
871 (SCM hash
, SCM assoc
, SCM table
, SCM key
),
872 "This behaves the same way as the corresponding\n"
873 "@code{-get-handle} function, but uses @var{hash} as a hash\n"
874 "function and @var{assoc} to compare keys. @code{hash} must be\n"
875 "a function that takes two arguments, a key to be hashed and a\n"
876 "table size. @code{assoc} must be an associator function, like\n"
877 "@code{assoc}, @code{assq} or @code{assv}.")
878 #define FUNC_NAME s_scm_hashx_get_handle
880 scm_t_ihashx_closure closure
;
882 closure
.assoc
= assoc
;
883 return scm_hash_fn_get_handle (table
, key
, scm_ihashx
, scm_sloppy_assx
,
889 SCM_DEFINE (scm_hashx_create_handle_x
, "hashx-create-handle!", 5, 0, 0,
890 (SCM hash
, SCM assoc
, SCM table
, SCM key
, SCM init
),
891 "This behaves the same way as the corresponding\n"
892 "@code{-create-handle} function, but uses @var{hash} as a hash\n"
893 "function and @var{assoc} to compare keys. @code{hash} must be\n"
894 "a function that takes two arguments, a key to be hashed and a\n"
895 "table size. @code{assoc} must be an associator function, like\n"
896 "@code{assoc}, @code{assq} or @code{assv}.")
897 #define FUNC_NAME s_scm_hashx_create_handle_x
899 scm_t_ihashx_closure closure
;
901 closure
.assoc
= assoc
;
902 return scm_hash_fn_create_handle_x (table
, key
, init
, scm_ihashx
,
903 scm_sloppy_assx
, (void *)&closure
);
909 SCM_DEFINE (scm_hashx_ref
, "hashx-ref", 4, 1, 0,
910 (SCM hash
, SCM assoc
, SCM table
, SCM key
, SCM dflt
),
911 "This behaves the same way as the corresponding @code{ref}\n"
912 "function, but uses @var{hash} as a hash function and\n"
913 "@var{assoc} to compare keys. @code{hash} must be a function\n"
914 "that takes two arguments, a key to be hashed and a table size.\n"
915 "@code{assoc} must be an associator function, like @code{assoc},\n"
916 "@code{assq} or @code{assv}.\n"
918 "By way of illustration, @code{hashq-ref table key} is\n"
919 "equivalent to @code{hashx-ref hashq assq table key}.")
920 #define FUNC_NAME s_scm_hashx_ref
922 scm_t_ihashx_closure closure
;
923 if (SCM_UNBNDP (dflt
))
926 closure
.assoc
= assoc
;
927 return scm_hash_fn_ref (table
, key
, dflt
, scm_ihashx
, scm_sloppy_assx
,
935 SCM_DEFINE (scm_hashx_set_x
, "hashx-set!", 5, 0, 0,
936 (SCM hash
, SCM assoc
, SCM table
, SCM key
, SCM val
),
937 "This behaves the same way as the corresponding @code{set!}\n"
938 "function, but uses @var{hash} as a hash function and\n"
939 "@var{assoc} to compare keys. @code{hash} must be a function\n"
940 "that takes two arguments, a key to be hashed and a table size.\n"
941 "@code{assoc} must be an associator function, like @code{assoc},\n"
942 "@code{assq} or @code{assv}.\n"
944 " By way of illustration, @code{hashq-set! table key} is\n"
945 "equivalent to @code{hashx-set! hashq assq table key}.")
946 #define FUNC_NAME s_scm_hashx_set_x
948 scm_t_ihashx_closure closure
;
950 closure
.assoc
= assoc
;
951 return scm_hash_fn_set_x (table
, key
, val
, scm_ihashx
, scm_sloppy_assx
,
956 SCM_DEFINE (scm_hashx_remove_x
, "hashx-remove!", 4, 0, 0,
957 (SCM hash
, SCM assoc
, SCM table
, SCM obj
),
958 "This behaves the same way as the corresponding @code{remove!}\n"
959 "function, but uses @var{hash} as a hash function and\n"
960 "@var{assoc} to compare keys. @code{hash} must be a function\n"
961 "that takes two arguments, a key to be hashed and a table size.\n"
962 "@code{assoc} must be an associator function, like @code{assoc},\n"
963 "@code{assq} or @code{assv}.\n"
965 " By way of illustration, @code{hashq-remove! table key} is\n"
966 "equivalent to @code{hashx-remove! hashq assq #f table key}.")
967 #define FUNC_NAME s_scm_hashx_remove_x
969 scm_t_ihashx_closure closure
;
971 closure
.assoc
= assoc
;
972 return scm_hash_fn_remove_x (table
, obj
, scm_ihashx
, scm_sloppy_assx
,
977 /* Hash table iterators */
979 static const char s_scm_hash_fold
[];
982 scm_internal_hash_fold (SCM (*fn
) (), void *closure
, SCM init
, SCM table
)
985 SCM buckets
, result
= init
;
987 if (SCM_HASHTABLE_P (table
))
988 buckets
= SCM_HASHTABLE_VECTOR (table
);
990 /* Weak alist vector. */
993 n
= SCM_SIMPLE_VECTOR_LENGTH (buckets
);
994 for (i
= 0; i
< n
; ++i
)
998 for (prev
= SCM_BOOL_F
, ls
= SCM_SIMPLE_VECTOR_REF (buckets
, i
);
1000 prev
= ls
, ls
= SCM_CDR (ls
))
1004 if (!scm_is_pair (ls
))
1005 scm_wrong_type_arg (s_scm_hash_fold
, SCM_ARG3
, buckets
);
1007 handle
= SCM_CAR (ls
);
1008 if (!scm_is_pair (handle
))
1009 scm_wrong_type_arg (s_scm_hash_fold
, SCM_ARG3
, buckets
);
1011 if (IS_WEAK_THING (table
))
1013 if (SCM_WEAK_PAIR_DELETED_P (handle
))
1015 /* We hit a weak pair whose car/cdr has become
1016 unreachable: unlink it from the bucket. */
1017 if (prev
!= SCM_BOOL_F
)
1018 SCM_SETCDR (prev
, SCM_CDR (ls
));
1020 SCM_SIMPLE_VECTOR_SET (buckets
, i
, SCM_CDR (ls
));
1022 if (SCM_HASHTABLE_P (table
))
1023 /* Update the item count. */
1024 SCM_HASHTABLE_DECREMENT (table
);
1030 result
= fn (closure
, SCM_CAR (handle
), SCM_CDR (handle
), result
);
1037 /* The following redundant code is here in order to be able to support
1038 hash-for-each-handle. An alternative would have been to replace
1039 this code and scm_internal_hash_fold above with a single
1040 scm_internal_hash_fold_handles, but we don't want to promote such
1043 static const char s_scm_hash_for_each
[];
1046 scm_internal_hash_for_each_handle (SCM (*fn
) (), void *closure
, SCM table
)
1051 if (SCM_HASHTABLE_P (table
))
1052 buckets
= SCM_HASHTABLE_VECTOR (table
);
1056 n
= SCM_SIMPLE_VECTOR_LENGTH (buckets
);
1057 for (i
= 0; i
< n
; ++i
)
1059 SCM ls
= SCM_SIMPLE_VECTOR_REF (buckets
, i
), handle
;
1060 while (!scm_is_null (ls
))
1062 if (!scm_is_pair (ls
))
1063 scm_wrong_type_arg (s_scm_hash_for_each
, SCM_ARG3
, buckets
);
1064 handle
= SCM_CAR (ls
);
1065 if (!scm_is_pair (handle
))
1066 scm_wrong_type_arg (s_scm_hash_for_each
, SCM_ARG3
, buckets
);
1067 fn (closure
, handle
);
1073 SCM_DEFINE (scm_hash_fold
, "hash-fold", 3, 0, 0,
1074 (SCM proc
, SCM init
, SCM table
),
1075 "An iterator over hash-table elements.\n"
1076 "Accumulates and returns a result by applying PROC successively.\n"
1077 "The arguments to PROC are \"(key value prior-result)\" where key\n"
1078 "and value are successive pairs from the hash table TABLE, and\n"
1079 "prior-result is either INIT (for the first application of PROC)\n"
1080 "or the return value of the previous application of PROC.\n"
1081 "For example, @code{(hash-fold acons '() tab)} will convert a hash\n"
1082 "table into an a-list of key-value pairs.")
1083 #define FUNC_NAME s_scm_hash_fold
1085 SCM_VALIDATE_PROC (1, proc
);
1086 if (!SCM_HASHTABLE_P (table
))
1087 SCM_VALIDATE_VECTOR (3, table
);
1088 return scm_internal_hash_fold (scm_call_3
, (void *) SCM_UNPACK (proc
), init
, table
);
1093 for_each_proc (void *proc
, SCM handle
)
1095 return scm_call_2 (SCM_PACK (proc
), SCM_CAR (handle
), SCM_CDR (handle
));
1098 SCM_DEFINE (scm_hash_for_each
, "hash-for-each", 2, 0, 0,
1099 (SCM proc
, SCM table
),
1100 "An iterator over hash-table elements.\n"
1101 "Applies PROC successively on all hash table items.\n"
1102 "The arguments to PROC are \"(key value)\" where key\n"
1103 "and value are successive pairs from the hash table TABLE.")
1104 #define FUNC_NAME s_scm_hash_for_each
1106 SCM_VALIDATE_PROC (1, proc
);
1107 if (!SCM_HASHTABLE_P (table
))
1108 SCM_VALIDATE_VECTOR (2, table
);
1110 scm_internal_hash_for_each_handle (for_each_proc
,
1111 (void *) SCM_UNPACK (proc
),
1113 return SCM_UNSPECIFIED
;
1117 SCM_DEFINE (scm_hash_for_each_handle
, "hash-for-each-handle", 2, 0, 0,
1118 (SCM proc
, SCM table
),
1119 "An iterator over hash-table elements.\n"
1120 "Applies PROC successively on all hash table handles.")
1121 #define FUNC_NAME s_scm_hash_for_each_handle
1123 scm_t_trampoline_1 call
= scm_trampoline_1 (proc
);
1124 SCM_ASSERT (call
, proc
, 1, FUNC_NAME
);
1125 if (!SCM_HASHTABLE_P (table
))
1126 SCM_VALIDATE_VECTOR (2, table
);
1128 scm_internal_hash_for_each_handle (call
,
1129 (void *) SCM_UNPACK (proc
),
1131 return SCM_UNSPECIFIED
;
1136 map_proc (void *proc
, SCM key
, SCM data
, SCM value
)
1138 return scm_cons (scm_call_2 (SCM_PACK (proc
), key
, data
), value
);
1141 SCM_DEFINE (scm_hash_map_to_list
, "hash-map->list", 2, 0, 0,
1142 (SCM proc
, SCM table
),
1143 "An iterator over hash-table elements.\n"
1144 "Accumulates and returns as a list the results of applying PROC successively.\n"
1145 "The arguments to PROC are \"(key value)\" where key\n"
1146 "and value are successive pairs from the hash table TABLE.")
1147 #define FUNC_NAME s_scm_hash_map_to_list
1149 SCM_VALIDATE_PROC (1, proc
);
1150 if (!SCM_HASHTABLE_P (table
))
1151 SCM_VALIDATE_VECTOR (2, table
);
1152 return scm_internal_hash_fold (map_proc
,
1153 (void *) SCM_UNPACK (proc
),
1163 scm_hashtab_prehistory ()
1165 /* Initialize the hashtab SMOB type. */
1166 scm_tc16_hashtable
= scm_make_smob_type (s_hashtable
, 0);
1167 scm_set_smob_print (scm_tc16_hashtable
, hashtable_print
);
1173 #include "libguile/hashtab.x"