-/* Copyright (C) 1995,1996,1998,1999,2000,2001, 2003, 2004, 2006, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
- *
+/* Copyright (C) 1995, 1996, 1998, 1999, 2000, 2001, 2003, 2004, 2006,
+ * 2008, 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
+ *
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
* as published by the Free Software Foundation; either version 3 of
* The implementation stores the upper and lower number of items which
* trigger a resize in the hashtable object.
*
- * Weak hash tables use weak pairs in the bucket lists rather than
- * normal pairs.
- *
* Possible hash table sizes (primes) are stored in the array
* hashtable_size.
*/
static char *s_hashtable = "hashtable";
-
-\f
-/* Helper functions and macros to deal with weak pairs.
-
- Weak pairs need to be accessed very carefully since their components can
- be nullified by the GC when the object they refer to becomes unreachable.
- Hence the macros and functions below that detect such weak pairs within
- buckets and remove them. */
-
-
-/* Remove nullified weak pairs from ALIST such that the result contains only
- valid pairs. Set REMOVED_ITEMS to the number of pairs that have been
- deleted. */
static SCM
-scm_fixup_weak_alist (SCM alist, size_t *removed_items)
-{
- SCM result;
- SCM prev = SCM_EOL;
-
- *removed_items = 0;
- for (result = alist;
- scm_is_pair (alist);
- alist = SCM_CDR (alist))
- {
- SCM pair = SCM_CAR (alist);
-
- if (SCM_WEAK_PAIR_DELETED_P (pair))
- {
- /* Remove from ALIST weak pair PAIR whose car/cdr has been
- nullified by the GC. */
- if (prev == SCM_EOL)
- result = SCM_CDR (alist);
- else
- SCM_SETCDR (prev, SCM_CDR (alist));
-
- (*removed_items)++;
-
- /* Leave PREV unchanged. */
- }
- else
- prev = alist;
- }
-
- return result;
-}
-
-static void
-vacuum_weak_hash_table (SCM table)
-{
- SCM buckets = SCM_HASHTABLE_VECTOR (table);
- unsigned long k = SCM_SIMPLE_VECTOR_LENGTH (buckets);
- size_t len = SCM_HASHTABLE_N_ITEMS (table);
-
- while (k--)
- {
- size_t removed;
- SCM alist = SCM_SIMPLE_VECTOR_REF (buckets, k);
- alist = scm_fixup_weak_alist (alist, &removed);
- assert (removed <= len);
- len -= removed;
- SCM_SIMPLE_VECTOR_SET (buckets, k, alist);
- }
-
- SCM_SET_HASHTABLE_N_ITEMS (table, len);
-}
-
-
-/* Packed arguments for `do_weak_bucket_fixup'. */
-struct t_fixup_args
-{
- SCM bucket;
- SCM *bucket_copy;
- size_t removed_items;
-};
-
-static void *
-do_weak_bucket_fixup (void *data)
-{
- struct t_fixup_args *args;
- SCM pair, *copy;
-
- args = (struct t_fixup_args *) data;
-
- args->bucket = scm_fixup_weak_alist (args->bucket, &args->removed_items);
-
- for (pair = args->bucket, copy = args->bucket_copy;
- scm_is_pair (pair);
- pair = SCM_CDR (pair), copy += 2)
- {
- /* At this point, all weak pairs have been removed. */
- assert (!SCM_WEAK_PAIR_DELETED_P (SCM_CAR (pair)));
-
- /* Copy the key and value. */
- copy[0] = SCM_CAAR (pair);
- copy[1] = SCM_CDAR (pair);
- }
-
- return args;
-}
-
-/* Lookup OBJECT in weak hash table TABLE using ASSOC. OBJECT is searched
- for in the alist that is the BUCKET_INDEXth element of BUCKETS.
- Optionally update TABLE and rehash it. */
-static SCM
-weak_bucket_assoc (SCM table, SCM buckets, size_t bucket_index,
- scm_t_hash_fn hash_fn,
- scm_t_assoc_fn assoc, SCM object, void *closure)
-{
- SCM result;
- SCM bucket, *strong_refs;
- struct t_fixup_args args;
-
- bucket = SCM_SIMPLE_VECTOR_REF (buckets, bucket_index);
-
- /* Prepare STRONG_REFS as an array large enough to hold all the keys
- and values in BUCKET. */
- strong_refs = alloca (scm_ilength (bucket) * 2 * sizeof (SCM));
-
- args.bucket = bucket;
- args.bucket_copy = strong_refs;
-
- /* Fixup BUCKET. Do that with the allocation lock held to avoid
- seeing disappearing links pointing to objects that have already
- been reclaimed (this happens when the disappearing links that point
- to it haven't yet been cleared.)
-
- The `do_weak_bucket_fixup' call populates STRONG_REFS with a copy
- of BUCKET's entries after it's been fixed up. Thus, all the
- entries kept in BUCKET are still reachable when ASSOC sees
- them. */
- GC_call_with_alloc_lock (do_weak_bucket_fixup, &args);
-
- bucket = args.bucket;
- SCM_SIMPLE_VECTOR_SET (buckets, bucket_index, bucket);
-
- result = assoc (object, bucket, closure);
- assert (!scm_is_pair (result) ||
- !SCM_WEAK_PAIR_DELETED_P (GC_is_visible (result)));
-
- scm_remember_upto_here_1 (strong_refs);
-
- if (args.removed_items > 0)
- {
- /* Update TABLE's item count and optionally trigger a rehash. */
- size_t remaining;
-
- assert (SCM_HASHTABLE_N_ITEMS (table) >= args.removed_items);
-
- remaining = SCM_HASHTABLE_N_ITEMS (table) - args.removed_items;
- SCM_SET_HASHTABLE_N_ITEMS (table, remaining);
-
- if (remaining < SCM_HASHTABLE_LOWER (table))
- scm_i_rehash (table, hash_fn, closure, "weak_bucket_assoc");
- }
-
- return result;
-}
-
-
-/* Packed arguments for `weak_bucket_assoc_by_hash'. */
-struct assoc_by_hash_data
-{
- SCM alist;
- SCM ret;
- scm_t_hash_predicate_fn predicate;
- void *closure;
-};
-
-/* See scm_hash_fn_get_handle_by_hash below. */
-static void*
-weak_bucket_assoc_by_hash (void *args)
-{
- struct assoc_by_hash_data *data = args;
- SCM alist = data->alist;
-
- for (; scm_is_pair (alist); alist = SCM_CDR (alist))
- {
- SCM pair = SCM_CAR (alist);
-
- if (!SCM_WEAK_PAIR_DELETED_P (pair)
- && data->predicate (SCM_CAR (pair), data->closure))
- {
- data->ret = pair;
- break;
- }
- }
- return args;
-}
-
-
-\f
-static SCM
-make_hash_table (int flags, unsigned long k, const char *func_name)
+make_hash_table (unsigned long k, const char *func_name)
{
SCM vector;
scm_t_hashtable *t;
int i = 0, n = k ? k : 31;
- while (i < HASHTABLE_SIZE_N && n > hashtable_size[i])
+ while (i + 1 < HASHTABLE_SIZE_N && n > hashtable_size[i])
++i;
n = hashtable_size[i];
- /* In both cases, i.e., regardless of whether we are creating a weak hash
- table, we return a non-weak vector. This is because the vector itself
- is not weak in the case of a weak hash table: the alist pairs are. */
vector = scm_c_make_vector (n, SCM_EOL);
t = scm_gc_malloc_pointerless (sizeof (*t), s_hashtable);
t->n_items = 0;
t->lower = 0;
t->upper = 9 * n / 10;
- t->flags = flags;
- t->hash_fn = NULL;
/* FIXME: we just need two words of storage, not three */
return scm_double_cell (scm_tc7_hashtable, SCM_UNPACK (vector),
if (i >= HASHTABLE_SIZE_N)
/* don't rehash */
return;
-
- /* Remember HASH_FN for rehash_after_gc, but only when CLOSURE
- is not needed since CLOSURE can not be guaranteed to be valid
- after this function returns.
- */
- if (closure == NULL)
- SCM_HASHTABLE (table)->hash_fn = hash_fn;
}
SCM_HASHTABLE (table)->size_index = i;
new_buckets = scm_c_make_vector (new_size, SCM_EOL);
- /* When this is a weak hashtable, running the GC might change it.
- We need to cope with this while rehashing its elements. We do
- this by first installing the new, empty bucket vector. Then we
- remove the elements from the old bucket vector and insert them
- into the new one.
- */
-
SCM_SET_HASHTABLE_VECTOR (table, new_buckets);
SCM_SET_HASHTABLE_N_ITEMS (table, 0);
handle = SCM_CAR (cell);
ls = SCM_CDR (ls);
- if (SCM_WEAK_PAIR_DELETED_P (handle))
- /* HANDLE is a nullified weak pair: skip it. */
- continue;
-
h = hash_fn (SCM_CAR (handle), new_size, closure);
if (h >= new_size)
scm_out_of_range (func_name, scm_from_ulong (h));
void
scm_i_hashtable_print (SCM exp, SCM port, scm_print_state *pstate)
{
- scm_puts ("#<", port);
- if (SCM_HASHTABLE_WEAK_KEY_P (exp))
- scm_puts ("weak-key-", port);
- else if (SCM_HASHTABLE_WEAK_VALUE_P (exp))
- scm_puts ("weak-value-", port);
- else if (SCM_HASHTABLE_DOUBLY_WEAK_P (exp))
- scm_puts ("doubly-weak-", port);
- scm_puts ("hash-table ", port);
+ scm_puts_unlocked ("#<hash-table ", port);
+ scm_uintprint (SCM_UNPACK (exp), 16, port);
+ scm_putc (' ', port);
scm_uintprint (SCM_HASHTABLE_N_ITEMS (exp), 10, port);
- scm_putc ('/', port);
+ scm_putc_unlocked ('/', port);
scm_uintprint (SCM_SIMPLE_VECTOR_LENGTH (SCM_HASHTABLE_VECTOR (exp)),
10, port);
- scm_puts (">", port);
+ scm_puts_unlocked (">", port);
}
SCM
scm_c_make_hash_table (unsigned long k)
{
- return make_hash_table (0, k, "scm_c_make_hash_table");
+ return make_hash_table (k, "scm_c_make_hash_table");
}
SCM_DEFINE (scm_make_hash_table, "make-hash-table", 0, 1, 0,
"Make a new abstract hash table object with minimum number of buckets @var{n}\n")
#define FUNC_NAME s_scm_make_hash_table
{
- if (SCM_UNBNDP (n))
- return make_hash_table (0, 0, FUNC_NAME);
- else
- return make_hash_table (0, scm_to_ulong (n), FUNC_NAME);
-}
-#undef FUNC_NAME
-
-static void
-weak_gc_callback (void *ptr, void *data)
-{
- void **weak = ptr;
- void *val = *weak;
-
- if (val)
- {
- void (*callback) (SCM) = data;
-
- GC_REGISTER_FINALIZER_NO_ORDER (ptr, weak_gc_callback, data, NULL, NULL);
-
- callback (PTR2SCM (val));
- }
-}
-
-static void
-scm_c_register_weak_gc_callback (SCM obj, void (*callback) (SCM))
-{
- void **weak = GC_MALLOC_ATOMIC (sizeof (void**));
-
- *weak = SCM2PTR (obj);
- GC_GENERAL_REGISTER_DISAPPEARING_LINK (weak, SCM2PTR (obj));
-
- GC_REGISTER_FINALIZER_NO_ORDER (weak, weak_gc_callback, (void*)callback,
- NULL, NULL);
-}
-
-SCM_DEFINE (scm_make_weak_key_hash_table, "make-weak-key-hash-table", 0, 1, 0,
- (SCM n),
- "@deffnx {Scheme Procedure} make-weak-value-hash-table size\n"
- "@deffnx {Scheme Procedure} make-doubly-weak-hash-table size\n"
- "Return a weak hash table with @var{size} buckets.\n"
- "\n"
- "You can modify weak hash tables in exactly the same way you\n"
- "would modify regular hash tables. (@pxref{Hash Tables})")
-#define FUNC_NAME s_scm_make_weak_key_hash_table
-{
- if (SCM_UNBNDP (n))
- return make_hash_table (SCM_HASHTABLEF_WEAK_CAR, 0, FUNC_NAME);
- else
- return make_hash_table (SCM_HASHTABLEF_WEAK_CAR,
- scm_to_ulong (n), FUNC_NAME);
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_make_weak_value_hash_table, "make-weak-value-hash-table", 0, 1, 0,
- (SCM n),
- "Return a hash table with weak values with @var{size} buckets.\n"
- "(@pxref{Hash Tables})")
-#define FUNC_NAME s_scm_make_weak_value_hash_table
-{
- SCM ret;
-
- if (SCM_UNBNDP (n))
- ret = make_hash_table (SCM_HASHTABLEF_WEAK_CDR, 0, FUNC_NAME);
- else
- ret = make_hash_table (SCM_HASHTABLEF_WEAK_CDR,
- scm_to_ulong (n), FUNC_NAME);
-
- scm_c_register_weak_gc_callback (ret, vacuum_weak_hash_table);
-
- return ret;
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_make_doubly_weak_hash_table, "make-doubly-weak-hash-table", 1, 0, 0,
- (SCM n),
- "Return a hash table with weak keys and values with @var{size}\n"
- "buckets. (@pxref{Hash Tables})")
-#define FUNC_NAME s_scm_make_doubly_weak_hash_table
-{
- SCM ret;
-
- if (SCM_UNBNDP (n))
- ret = make_hash_table (SCM_HASHTABLEF_WEAK_CAR | SCM_HASHTABLEF_WEAK_CDR,
- 0, FUNC_NAME);
- else
- ret = make_hash_table (SCM_HASHTABLEF_WEAK_CAR | SCM_HASHTABLEF_WEAK_CDR,
- scm_to_ulong (n), FUNC_NAME);
-
- scm_c_register_weak_gc_callback (ret, vacuum_weak_hash_table);
-
- return ret;
+ return make_hash_table (SCM_UNBNDP (n) ? 0 : scm_to_ulong (n), FUNC_NAME);
}
#undef FUNC_NAME
+#define SCM_WEAK_TABLE_P(x) (scm_is_true (scm_weak_table_p (x)))
SCM_DEFINE (scm_hash_table_p, "hash-table?", 1, 0, 0,
(SCM obj),
"Return @code{#t} if @var{obj} is an abstract hash table object.")
#define FUNC_NAME s_scm_hash_table_p
{
- return scm_from_bool (SCM_HASHTABLE_P (obj));
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_weak_key_hash_table_p, "weak-key-hash-table?", 1, 0, 0,
- (SCM obj),
- "@deffnx {Scheme Procedure} weak-value-hash-table? obj\n"
- "@deffnx {Scheme Procedure} doubly-weak-hash-table? obj\n"
- "Return @code{#t} if @var{obj} is the specified weak hash\n"
- "table. Note that a doubly weak hash table is neither a weak key\n"
- "nor a weak value hash table.")
-#define FUNC_NAME s_scm_weak_key_hash_table_p
-{
- return scm_from_bool (SCM_HASHTABLE_P (obj) && SCM_HASHTABLE_WEAK_KEY_P (obj));
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (scm_weak_value_hash_table_p, "weak-value-hash-table?", 1, 0, 0,
- (SCM obj),
- "Return @code{#t} if @var{obj} is a weak value hash table.")
-#define FUNC_NAME s_scm_weak_value_hash_table_p
-{
- return scm_from_bool (SCM_HASHTABLE_P (obj) && SCM_HASHTABLE_WEAK_VALUE_P (obj));
+ return scm_from_bool (SCM_HASHTABLE_P (obj) || SCM_WEAK_TABLE_P (obj));
}
#undef FUNC_NAME
-SCM_DEFINE (scm_doubly_weak_hash_table_p, "doubly-weak-hash-table?", 1, 0, 0,
- (SCM obj),
- "Return @code{#t} if @var{obj} is a doubly weak hash table.")
-#define FUNC_NAME s_scm_doubly_weak_hash_table_p
-{
- return scm_from_bool (SCM_HASHTABLE_P (obj) && SCM_HASHTABLE_DOUBLY_WEAK_P (obj));
-}
-#undef FUNC_NAME
-
\f
/* Accessing hash table entries. */
if (k >= SCM_SIMPLE_VECTOR_LENGTH (buckets))
scm_out_of_range (FUNC_NAME, scm_from_ulong (k));
- if (SCM_HASHTABLE_WEAK_P (table))
- h = weak_bucket_assoc (table, buckets, k, hash_fn,
- assoc_fn, obj, closure);
- else
- h = assoc_fn (obj, SCM_SIMPLE_VECTOR_REF (buckets, k), closure);
-
- return h;
-}
-#undef FUNC_NAME
-
-
-/* This procedure implements three optimizations, with respect to the
- raw get_handle():
-
- 1. For weak tables, it's assumed that calling the predicate in the
- allocation lock is safe. In practice this means that the predicate
- cannot call arbitrary scheme functions.
-
- 2. We don't check for overflow / underflow and rehash.
-
- 3. We don't actually have to allocate a key -- instead we get the
- hash value directly. This is useful for, for example, looking up
- strings in the symbol table.
- */
-SCM
-scm_hash_fn_get_handle_by_hash (SCM table, unsigned long raw_hash,
- scm_t_hash_predicate_fn predicate_fn,
- void *closure)
-#define FUNC_NAME "scm_hash_fn_ref_by_hash"
-{
- unsigned long k;
- SCM buckets, alist, h = SCM_BOOL_F;
-
- SCM_VALIDATE_HASHTABLE (SCM_ARG1, table);
- buckets = SCM_HASHTABLE_VECTOR (table);
-
- if (SCM_SIMPLE_VECTOR_LENGTH (buckets) == 0)
- return SCM_BOOL_F;
-
- k = raw_hash % SCM_SIMPLE_VECTOR_LENGTH (buckets);
- alist = SCM_SIMPLE_VECTOR_REF (buckets, k);
-
- if (SCM_HASHTABLE_WEAK_P (table))
- {
- struct assoc_by_hash_data args;
-
- args.alist = alist;
- args.ret = SCM_BOOL_F;
- args.predicate = predicate_fn;
- args.closure = closure;
- GC_call_with_alloc_lock (weak_bucket_assoc_by_hash, &args);
- h = args.ret;
- }
- else
- for (; scm_is_pair (alist); alist = SCM_CDR (alist))
- {
- SCM pair = SCM_CAR (alist);
- if (predicate_fn (SCM_CAR (pair), closure))
- {
- h = pair;
- break;
- }
- }
+ h = assoc_fn (obj, SCM_SIMPLE_VECTOR_REF (buckets, k), closure);
return h;
}
if (k >= SCM_SIMPLE_VECTOR_LENGTH (buckets))
scm_out_of_range ("hash_fn_create_handle_x", scm_from_ulong (k));
- if (SCM_HASHTABLE_WEAK_P (table))
- it = weak_bucket_assoc (table, buckets, k, hash_fn,
- assoc_fn, obj, closure);
- else
- it = assoc_fn (obj, SCM_SIMPLE_VECTOR_REF (buckets, k), closure);
+ it = assoc_fn (obj, SCM_SIMPLE_VECTOR_REF (buckets, k), closure);
if (scm_is_pair (it))
return it;
scm_wrong_type_arg_msg (NULL, 0, it, "a pair");
else
{
- /* When this is a weak hashtable, running the GC can change it.
- Thus, we must allocate the new cells first and can only then
- access BUCKETS. Also, we need to fetch the bucket vector
- again since the hashtable might have been rehashed. This
- necessitates a new hash value as well.
- */
SCM handle, new_bucket;
- if (SCM_HASHTABLE_WEAK_P (table))
- {
- /* FIXME: We don't support weak alist vectors. */
- /* Use a weak cell. */
- if (SCM_HASHTABLE_DOUBLY_WEAK_P (table))
- handle = scm_doubly_weak_pair (obj, init);
- else if (SCM_HASHTABLE_WEAK_KEY_P (table))
- handle = scm_weak_car_pair (obj, init);
- else
- handle = scm_weak_cdr_pair (obj, init);
- }
- else
- /* Use a regular, non-weak cell. */
- handle = scm_cons (obj, init);
-
+ handle = scm_cons (obj, init);
new_bucket = scm_cons (handle, SCM_EOL);
if (!scm_is_eq (SCM_HASHTABLE_VECTOR (table), buckets))
return dflt;
}
-
-
-
SCM
scm_hash_fn_set_x (SCM table, SCM obj, SCM val,
scm_t_hash_fn hash_fn, scm_t_assoc_fn assoc_fn,
void *closure)
{
- SCM it;
+ SCM pair;
- it = scm_hash_fn_create_handle_x (table, obj, SCM_BOOL_F, hash_fn, assoc_fn, closure);
- SCM_SETCDR (it, val);
-
- if (SCM_HASHTABLE_WEAK_VALUE_P (table) && SCM_NIMP (val))
- /* IT is a weak-cdr pair. Register a disappearing link from IT's
- cdr to VAL like `scm_weak_cdr_pair' does. */
- SCM_I_REGISTER_DISAPPEARING_LINK ((void *) SCM_CDRLOC (it), SCM2PTR (val));
+ pair = scm_hash_fn_create_handle_x (table, obj, val,
+ hash_fn, assoc_fn, closure);
+ if (!scm_is_eq (SCM_CDR (pair), val))
+ SCM_SETCDR (pair, val);
+
return val;
}
if (k >= SCM_SIMPLE_VECTOR_LENGTH (buckets))
scm_out_of_range (FUNC_NAME, scm_from_ulong (k));
- if (SCM_HASHTABLE_WEAK_P (table))
- h = weak_bucket_assoc (table, buckets, k, hash_fn,
- assoc_fn, obj, closure);
- else
- h = assoc_fn (obj, SCM_SIMPLE_VECTOR_REF (buckets, k), closure);
+ h = assoc_fn (obj, SCM_SIMPLE_VECTOR_REF (buckets, k), closure);
if (scm_is_true (h))
{
"Remove all items from @var{table} (without triggering a resize).")
#define FUNC_NAME s_scm_hash_clear_x
{
+ if (SCM_WEAK_TABLE_P (table))
+ {
+ scm_weak_table_clear_x (table);
+ return SCM_UNSPECIFIED;
+ }
+
SCM_VALIDATE_HASHTABLE (SCM_ARG1, table);
scm_vector_fill_x (SCM_HASHTABLE_VECTOR (table), SCM_EOL);
(SCM table, SCM key, SCM dflt),
"Look up @var{key} in the hash table @var{table}, and return the\n"
"value (if any) associated with it. If @var{key} is not found,\n"
- "return @var{default} (or @code{#f} if no @var{default} argument\n"
+ "return @var{dflt} (or @code{#f} if no @var{dflt} argument\n"
"is supplied). Uses @code{eq?} for equality testing.")
#define FUNC_NAME s_scm_hashq_ref
{
if (SCM_UNBNDP (dflt))
dflt = SCM_BOOL_F;
+
+ if (SCM_WEAK_TABLE_P (table))
+ return scm_weak_table_refq (table, key, dflt);
+
return scm_hash_fn_ref (table, key, dflt,
(scm_t_hash_fn) scm_ihashq,
(scm_t_assoc_fn) scm_sloppy_assq,
SCM_DEFINE (scm_hashq_set_x, "hashq-set!", 3, 0, 0,
(SCM table, SCM key, SCM val),
"Find the entry in @var{table} associated with @var{key}, and\n"
- "store @var{value} there. Uses @code{eq?} for equality testing.")
+ "store @var{val} there. Uses @code{eq?} for equality testing.")
#define FUNC_NAME s_scm_hashq_set_x
{
+ if (SCM_WEAK_TABLE_P (table))
+ {
+ scm_weak_table_putq_x (table, key, val);
+ return val;
+ }
+
return scm_hash_fn_set_x (table, key, val,
(scm_t_hash_fn) scm_ihashq,
(scm_t_assoc_fn) scm_sloppy_assq,
"@var{table}. Uses @code{eq?} for equality tests.")
#define FUNC_NAME s_scm_hashq_remove_x
{
+ if (SCM_WEAK_TABLE_P (table))
+ {
+ scm_weak_table_remq_x (table, key);
+ /* This return value is for historical compatibility with
+ hash-remove!, which returns either the "handle" corresponding
+ to the entry, or #f. Since weak tables don't have handles, we
+ have to return #f. */
+ return SCM_BOOL_F;
+ }
+
return scm_hash_fn_remove_x (table, key,
(scm_t_hash_fn) scm_ihashq,
(scm_t_assoc_fn) scm_sloppy_assq,
#undef FUNC_NAME
+static int
+assv_predicate (SCM k, SCM v, void *closure)
+{
+ return scm_is_true (scm_eqv_p (k, SCM_PACK_POINTER (closure)));
+}
+
SCM_DEFINE (scm_hashv_ref, "hashv-ref", 2, 1, 0,
(SCM table, SCM key, SCM dflt),
"Look up @var{key} in the hash table @var{table}, and return the\n"
"value (if any) associated with it. If @var{key} is not found,\n"
- "return @var{default} (or @code{#f} if no @var{default} argument\n"
+ "return @var{dflt} (or @code{#f} if no @var{dflt} argument\n"
"is supplied). Uses @code{eqv?} for equality testing.")
#define FUNC_NAME s_scm_hashv_ref
{
if (SCM_UNBNDP (dflt))
dflt = SCM_BOOL_F;
+
+ if (SCM_WEAK_TABLE_P (table))
+ return scm_c_weak_table_ref (table, scm_ihashv (key, -1),
+ assv_predicate, SCM_PACK (key), dflt);
+
return scm_hash_fn_ref (table, key, dflt,
(scm_t_hash_fn) scm_ihashv,
(scm_t_assoc_fn) scm_sloppy_assv,
"store @var{value} there. Uses @code{eqv?} for equality testing.")
#define FUNC_NAME s_scm_hashv_set_x
{
+ if (SCM_WEAK_TABLE_P (table))
+ {
+ scm_c_weak_table_put_x (table, scm_ihashv (key, -1),
+ assv_predicate, SCM_PACK (key),
+ key, val);
+ return val;
+ }
+
return scm_hash_fn_set_x (table, key, val,
(scm_t_hash_fn) scm_ihashv,
(scm_t_assoc_fn) scm_sloppy_assv,
"@var{table}. Uses @code{eqv?} for equality tests.")
#define FUNC_NAME s_scm_hashv_remove_x
{
+ if (SCM_WEAK_TABLE_P (table))
+ {
+ scm_c_weak_table_remove_x (table, scm_ihashv (key, -1),
+ assv_predicate, SCM_PACK (key));
+ /* See note in hashq-remove!. */
+ return SCM_BOOL_F;
+ }
+
return scm_hash_fn_remove_x (table, key,
(scm_t_hash_fn) scm_ihashv,
(scm_t_assoc_fn) scm_sloppy_assv,
#undef FUNC_NAME
+static int
+assoc_predicate (SCM k, SCM v, void *closure)
+{
+ return scm_is_true (scm_equal_p (k, SCM_PACK_POINTER (closure)));
+}
+
SCM_DEFINE (scm_hash_ref, "hash-ref", 2, 1, 0,
(SCM table, SCM key, SCM dflt),
"Look up @var{key} in the hash table @var{table}, and return the\n"
"value (if any) associated with it. If @var{key} is not found,\n"
- "return @var{default} (or @code{#f} if no @var{default} argument\n"
+ "return @var{dflt} (or @code{#f} if no @var{dflt} argument\n"
"is supplied). Uses @code{equal?} for equality testing.")
#define FUNC_NAME s_scm_hash_ref
{
if (SCM_UNBNDP (dflt))
dflt = SCM_BOOL_F;
+
+ if (SCM_WEAK_TABLE_P (table))
+ return scm_c_weak_table_ref (table, scm_ihash (key, -1),
+ assoc_predicate, SCM_PACK (key), dflt);
+
return scm_hash_fn_ref (table, key, dflt,
(scm_t_hash_fn) scm_ihash,
(scm_t_assoc_fn) scm_sloppy_assoc,
SCM_DEFINE (scm_hash_set_x, "hash-set!", 3, 0, 0,
(SCM table, SCM key, SCM val),
"Find the entry in @var{table} associated with @var{key}, and\n"
- "store @var{value} there. Uses @code{equal?} for equality\n"
+ "store @var{val} there. Uses @code{equal?} for equality\n"
"testing.")
#define FUNC_NAME s_scm_hash_set_x
{
+ if (SCM_WEAK_TABLE_P (table))
+ {
+ scm_c_weak_table_put_x (table, scm_ihash (key, -1),
+ assoc_predicate, SCM_PACK (key),
+ key, val);
+ return val;
+ }
+
return scm_hash_fn_set_x (table, key, val,
(scm_t_hash_fn) scm_ihash,
(scm_t_assoc_fn) scm_sloppy_assoc,
"@var{table}. Uses @code{equal?} for equality tests.")
#define FUNC_NAME s_scm_hash_remove_x
{
+ if (SCM_WEAK_TABLE_P (table))
+ {
+ scm_c_weak_table_remove_x (table, scm_ihash (key, -1),
+ assoc_predicate, SCM_PACK (key));
+ /* See note in hashq-remove!. */
+ return SCM_BOOL_F;
+ }
+
return scm_hash_fn_remove_x (table, key,
(scm_t_hash_fn) scm_ihash,
(scm_t_assoc_fn) scm_sloppy_assoc,
{
SCM hash;
SCM assoc;
+ SCM key;
} scm_t_ihashx_closure;
-
-
static unsigned long
scm_ihashx (SCM obj, unsigned long n, void *arg)
{
return scm_to_ulong (answer);
}
-
-
static SCM
scm_sloppy_assx (SCM obj, SCM alist, void *arg)
{
return scm_call_2 (closure->assoc, obj, alist);
}
+static int
+assx_predicate (SCM k, SCM v, void *closure)
+{
+ scm_t_ihashx_closure *c = (scm_t_ihashx_closure *) closure;
+
+ /* FIXME: The hashx interface is crazy. Hash tables have nothing to
+ do with alists in principle. Instead of getting an assoc proc,
+ hashx functions should use an equality predicate. Perhaps we can
+ change this before 2.2, but until then, add a terrible, terrible
+ hack. */
+
+ return scm_is_true (scm_call_2 (c->assoc, c->key, scm_acons (k, v, SCM_EOL)));
+}
+
SCM_DEFINE (scm_hashx_get_handle, "hashx-get-handle", 4, 0, 0,
(SCM hash, SCM assoc, SCM table, SCM key),
scm_t_ihashx_closure closure;
closure.hash = hash;
closure.assoc = assoc;
+ closure.key = key;
+
return scm_hash_fn_get_handle (table, key, scm_ihashx, scm_sloppy_assx,
(void *) &closure);
}
scm_t_ihashx_closure closure;
closure.hash = hash;
closure.assoc = assoc;
+ closure.key = key;
+
return scm_hash_fn_create_handle_x (table, key, init, scm_ihashx,
scm_sloppy_assx, (void *)&closure);
}
dflt = SCM_BOOL_F;
closure.hash = hash;
closure.assoc = assoc;
+ closure.key = key;
+
+ if (SCM_WEAK_TABLE_P (table))
+ {
+ unsigned long h = scm_to_ulong (scm_call_2 (hash, key,
+ scm_from_ulong (-1)));
+ return scm_c_weak_table_ref (table, h, assx_predicate, &closure, dflt);
+ }
+
return scm_hash_fn_ref (table, key, dflt, scm_ihashx, scm_sloppy_assx,
(void *)&closure);
}
scm_t_ihashx_closure closure;
closure.hash = hash;
closure.assoc = assoc;
+ closure.key = key;
+
+ if (SCM_WEAK_TABLE_P (table))
+ {
+ unsigned long h = scm_to_ulong (scm_call_2 (hash, key,
+ scm_from_ulong (-1)));
+ scm_c_weak_table_put_x (table, h, assx_predicate, &closure, key, val);
+ return val;
+ }
+
return scm_hash_fn_set_x (table, key, val, scm_ihashx, scm_sloppy_assx,
(void *)&closure);
}
scm_t_ihashx_closure closure;
closure.hash = hash;
closure.assoc = assoc;
+ closure.key = obj;
+
+ if (SCM_WEAK_TABLE_P (table))
+ {
+ unsigned long h = scm_to_ulong (scm_call_2 (hash, obj,
+ scm_from_ulong (-1)));
+ scm_c_weak_table_remove_x (table, h, assx_predicate, &closure);
+ /* See note in hashq-remove!. */
+ return SCM_BOOL_F;
+ }
+
return scm_hash_fn_remove_x (table, obj, scm_ihashx, scm_sloppy_assx,
(void *) &closure);
}
#define FUNC_NAME s_scm_hash_fold
{
SCM_VALIDATE_PROC (1, proc);
+
+ if (SCM_WEAK_TABLE_P (table))
+ return scm_weak_table_fold (proc, init, table);
+
SCM_VALIDATE_HASHTABLE (3, table);
return scm_internal_hash_fold ((scm_t_hash_fold_fn) scm_call_3,
(void *) SCM_UNPACK (proc), init, table);
#define FUNC_NAME s_scm_hash_for_each
{
SCM_VALIDATE_PROC (1, proc);
+
+ if (SCM_WEAK_TABLE_P (table))
+ {
+ scm_weak_table_for_each (proc, table);
+ return SCM_UNSPECIFIED;
+ }
+
SCM_VALIDATE_HASHTABLE (2, table);
scm_internal_hash_for_each_handle (for_each_proc,
#define FUNC_NAME s_scm_hash_map_to_list
{
SCM_VALIDATE_PROC (1, proc);
+
+ if (SCM_WEAK_TABLE_P (table))
+ return scm_weak_table_map_to_list (proc, table);
+
SCM_VALIDATE_HASHTABLE (2, table);
return scm_internal_hash_fold (map_proc,
(void *) SCM_UNPACK (proc),
}
#undef FUNC_NAME
+static SCM
+count_proc (void *pred, SCM key, SCM data, SCM value)
+{
+ if (scm_is_false (scm_call_2 (SCM_PACK (pred), key, data)))
+ return value;
+ else
+ return scm_oneplus(value);
+}
+
+SCM_DEFINE (scm_hash_count, "hash-count", 2, 0, 0,
+ (SCM pred, SCM table),
+ "Return the number of elements in the given hash TABLE that\n"
+ "cause `(PRED KEY VALUE)' to return true. To quickly determine\n"
+ "the total number of elements, use `(const #t)' for PRED.")
+#define FUNC_NAME s_scm_hash_count
+{
+ SCM init;
+
+ SCM_VALIDATE_PROC (1, pred);
+ SCM_VALIDATE_HASHTABLE (2, table);
+
+ init = scm_from_int (0);
+ return scm_internal_hash_fold ((scm_t_hash_fold_fn) count_proc,
+ (void *) SCM_UNPACK (pred), init, table);
+}
+#undef FUNC_NAME
+
\f
SCM
long i, n;
SCM buckets, result = init;
+ if (SCM_WEAK_TABLE_P (table))
+ return scm_c_weak_table_fold (fn, closure, init, table);
+
SCM_VALIDATE_HASHTABLE (0, table);
buckets = SCM_HASHTABLE_VECTOR (table);
n = SCM_SIMPLE_VECTOR_LENGTH (buckets);
for (i = 0; i < n; ++i)
{
- SCM prev, ls;
+ SCM ls, handle;
- for (prev = SCM_BOOL_F, ls = SCM_SIMPLE_VECTOR_REF (buckets, i);
- !scm_is_null (ls);
- prev = ls, ls = SCM_CDR (ls))
+ for (ls = SCM_SIMPLE_VECTOR_REF (buckets, i); !scm_is_null (ls);
+ ls = SCM_CDR (ls))
{
- SCM handle;
-
- if (!scm_is_pair (ls))
- SCM_WRONG_TYPE_ARG (SCM_ARG3, buckets);
-
handle = SCM_CAR (ls);
- if (!scm_is_pair (handle))
- SCM_WRONG_TYPE_ARG (SCM_ARG3, buckets);
-
- if (SCM_HASHTABLE_WEAK_P (table))
- {
- if (SCM_WEAK_PAIR_DELETED_P (handle))
- {
- /* We hit a weak pair whose car/cdr has become
- unreachable: unlink it from the bucket. */
- if (prev != SCM_BOOL_F)
- SCM_SETCDR (prev, SCM_CDR (ls));
- else
- SCM_SIMPLE_VECTOR_SET (buckets, i, SCM_CDR (ls));
-
- /* Update the item count. */
- SCM_HASHTABLE_DECREMENT (table);
-
- continue;
- }
- }
-
- result = fn (closure, SCM_CAR (handle), SCM_CDR (handle), result);
+ result = fn (closure, SCM_CAR (handle), SCM_CDR (handle), result);
}
}
HCoop / bpt / guile.git / blobdiff