diff options
Diffstat (limited to 'libguile/hashtab.c')
-rw-r--r-- | libguile/hashtab.c | 708 |
1 files changed, 140 insertions, 568 deletions
diff --git a/libguile/hashtab.c b/libguile/hashtab.c index c4f2b5eb0..4091afeb9 100644 --- a/libguile/hashtab.c +++ b/libguile/hashtab.c @@ -53,9 +53,6 @@ * 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. */ @@ -75,201 +72,8 @@ static unsigned long hashtable_size[] = { static char *s_hashtable = "hashtable"; - - -/* 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 (scm_is_null (prev)) - 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); - - /* If we got a result, it should not have NULL fields. */ - if (scm_is_pair (result) && SCM_WEAK_PAIR_DELETED_P (result)) - abort (); - - 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; -} - - - -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; @@ -278,9 +82,6 @@ make_hash_table (int flags, unsigned long k, const char *func_name) ++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); @@ -288,8 +89,6 @@ make_hash_table (int flags, unsigned long k, const char *func_name) 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), @@ -322,13 +121,6 @@ scm_i_rehash (SCM table, 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; @@ -342,13 +134,6 @@ scm_i_rehash (SCM table, 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); @@ -368,10 +153,6 @@ scm_i_rehash (SCM table, 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)); @@ -386,26 +167,19 @@ scm_i_rehash (SCM table, 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_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, @@ -413,171 +187,18 @@ 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 - -/* The before-gc C hook only runs if GC_set_start_callback is available, - so if not, fall back on a finalizer-based implementation. */ -static int -weak_gc_callback (void **weak) -{ - void *val = weak[0]; - void (*callback) (SCM) = weak[1]; - - if (!val) - return 0; - - callback (PTR2SCM (val)); - - return 1; -} - -#ifdef HAVE_GC_SET_START_CALLBACK -static void* -weak_gc_hook (void *hook_data, void *fn_data, void *data) -{ - if (!weak_gc_callback (fn_data)) - scm_c_hook_remove (&scm_before_gc_c_hook, weak_gc_hook, fn_data); - - return NULL; -} -#else -static void -weak_gc_finalizer (void *ptr, void *data) -{ - if (weak_gc_callback (ptr)) - GC_REGISTER_FINALIZER_NO_ORDER (ptr, weak_gc_finalizer, data, NULL, NULL); -} -#endif - -static void -scm_c_register_weak_gc_callback (SCM obj, void (*callback) (SCM)) -{ - void **weak = GC_MALLOC_ATOMIC (sizeof (void*) * 2); - - weak[0] = SCM2PTR (obj); - weak[1] = (void*)callback; - GC_GENERAL_REGISTER_DISAPPEARING_LINK (weak, SCM2PTR (obj)); - -#ifdef HAVE_GC_SET_START_CALLBACK - scm_c_hook_add (&scm_before_gc_c_hook, weak_gc_hook, weak, 0); -#else - GC_REGISTER_FINALIZER_NO_ORDER (weak, weak_gc_finalizer, NULL, NULL, NULL); -#endif -} - -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 -{ - SCM ret; - - if (SCM_UNBNDP (n)) - ret = make_hash_table (SCM_HASHTABLEF_WEAK_CAR, 0, FUNC_NAME); - else - ret = make_hash_table (SCM_HASHTABLEF_WEAK_CAR, - 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_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)); -} -#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)); + return scm_from_bool (SCM_HASHTABLE_P (obj) || SCM_WEAK_TABLE_P (obj)); } #undef FUNC_NAME @@ -602,69 +223,7 @@ scm_hash_fn_get_handle (SCM table, SCM obj, 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; } @@ -690,11 +249,7 @@ scm_hash_fn_create_handle_x (SCM table, SCM obj, SCM init, 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; @@ -702,29 +257,9 @@ scm_hash_fn_create_handle_x (SCM table, SCM obj, SCM init, 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)) @@ -760,36 +295,6 @@ scm_hash_fn_ref (SCM table, SCM obj, SCM dflt, return dflt; } -struct weak_cdr_data -{ - SCM pair; - SCM cdr; -}; - -static void* -get_weak_cdr (void *data) -{ - struct weak_cdr_data *d = data; - - if (SCM_WEAK_PAIR_CDR_DELETED_P (d->pair)) - d->cdr = SCM_BOOL_F; - else - d->cdr = SCM_CDR (d->pair); - - return NULL; -} - -static SCM -weak_pair_cdr (SCM x) -{ - struct weak_cdr_data data; - - data.pair = x; - GC_call_with_alloc_lock (get_weak_cdr, &data); - - return data.cdr; -} - SCM scm_hash_fn_set_x (SCM table, SCM obj, SCM val, scm_t_hash_fn hash_fn, scm_t_assoc_fn assoc_fn, @@ -801,24 +306,7 @@ scm_hash_fn_set_x (SCM table, SCM obj, SCM val, hash_fn, assoc_fn, closure); if (!scm_is_eq (SCM_CDR (pair), val)) - { - if (SCM_UNLIKELY (SCM_HASHTABLE_WEAK_VALUE_P (table))) - { - /* If the former value was on the heap, we need to unregister - the weak link. */ - SCM prev = weak_pair_cdr (pair); - - SCM_SETCDR (pair, val); - - if (SCM_NIMP (prev) && !SCM_NIMP (val)) - GC_unregister_disappearing_link ((GC_PTR) SCM_CDRLOC (pair)); - else - SCM_I_REGISTER_DISAPPEARING_LINK ((GC_PTR) SCM_CDRLOC (pair), - (GC_PTR) SCM2PTR (val)); - } - else - SCM_SETCDR (pair, val); - } + SCM_SETCDR (pair, val); return val; } @@ -845,11 +333,7 @@ scm_hash_fn_remove_x (SCM table, SCM obj, 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)) { @@ -868,6 +352,9 @@ SCM_DEFINE (scm_hash_clear_x, "hash-clear!", 1, 0, 0, "Remove all items from @var{table} (without triggering a resize).") #define FUNC_NAME s_scm_hash_clear_x { + if (SCM_WEAK_TABLE_P (table)) + return scm_weak_table_clear_x (table); + SCM_VALIDATE_HASHTABLE (SCM_ARG1, table); scm_vector_fill_x (SCM_HASHTABLE_VECTOR (table), SCM_EOL); @@ -887,9 +374,6 @@ SCM_DEFINE (scm_hashq_get_handle, "hashq-get-handle", 2, 0, 0, "Uses @code{eq?} for equality testing.") #define FUNC_NAME s_scm_hashq_get_handle { - if (SCM_UNLIKELY (SCM_HASHTABLE_P (table) && SCM_HASHTABLE_WEAK_P (table))) - SCM_MISC_ERROR ("Handle access not permitted on weak table", SCM_EOL); - return scm_hash_fn_get_handle (table, key, (scm_t_hash_fn) scm_ihashq, (scm_t_assoc_fn) scm_sloppy_assq, @@ -905,9 +389,6 @@ SCM_DEFINE (scm_hashq_create_handle_x, "hashq-create-handle!", 3, 0, 0, "associates @var{key} with @var{init}.") #define FUNC_NAME s_scm_hashq_create_handle_x { - if (SCM_UNLIKELY (SCM_HASHTABLE_P (table) && SCM_HASHTABLE_WEAK_P (table))) - SCM_MISC_ERROR ("Handle access not permitted on weak table", SCM_EOL); - return scm_hash_fn_create_handle_x (table, key, init, (scm_t_hash_fn) scm_ihashq, (scm_t_assoc_fn) scm_sloppy_assq, @@ -926,6 +407,10 @@ SCM_DEFINE (scm_hashq_ref, "hashq-ref", 2, 1, 0, { 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, @@ -941,6 +426,9 @@ SCM_DEFINE (scm_hashq_set_x, "hashq-set!", 3, 0, 0, "store @var{value} there. Uses @code{eq?} for equality testing.") #define FUNC_NAME s_scm_hashq_set_x { + if (SCM_WEAK_TABLE_P (table)) + return scm_weak_table_putq_x (table, key, val); + return scm_hash_fn_set_x (table, key, val, (scm_t_hash_fn) scm_ihashq, (scm_t_assoc_fn) scm_sloppy_assq, @@ -956,6 +444,9 @@ SCM_DEFINE (scm_hashq_remove_x, "hashq-remove!", 2, 0, 0, "@var{table}. Uses @code{eq?} for equality tests.") #define FUNC_NAME s_scm_hashq_remove_x { + if (SCM_WEAK_TABLE_P (table)) + return scm_weak_table_remq_x (table, key); + return scm_hash_fn_remove_x (table, key, (scm_t_hash_fn) scm_ihashq, (scm_t_assoc_fn) scm_sloppy_assq, @@ -974,9 +465,6 @@ SCM_DEFINE (scm_hashv_get_handle, "hashv-get-handle", 2, 0, 0, "Uses @code{eqv?} for equality testing.") #define FUNC_NAME s_scm_hashv_get_handle { - if (SCM_UNLIKELY (SCM_HASHTABLE_P (table) && SCM_HASHTABLE_WEAK_P (table))) - SCM_MISC_ERROR ("Handle access not permitted on weak table", SCM_EOL); - return scm_hash_fn_get_handle (table, key, (scm_t_hash_fn) scm_ihashv, (scm_t_assoc_fn) scm_sloppy_assv, @@ -992,9 +480,6 @@ SCM_DEFINE (scm_hashv_create_handle_x, "hashv-create-handle!", 3, 0, 0, "associates @var{key} with @var{init}.") #define FUNC_NAME s_scm_hashv_create_handle_x { - if (SCM_UNLIKELY (SCM_HASHTABLE_P (table) && SCM_HASHTABLE_WEAK_P (table))) - SCM_MISC_ERROR ("Handle access not permitted on weak table", SCM_EOL); - return scm_hash_fn_create_handle_x (table, key, init, (scm_t_hash_fn) scm_ihashv, (scm_t_assoc_fn) scm_sloppy_assv, @@ -1003,6 +488,12 @@ SCM_DEFINE (scm_hashv_create_handle_x, "hashv-create-handle!", 3, 0, 0, #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" @@ -1013,6 +504,11 @@ SCM_DEFINE (scm_hashv_ref, "hashv-ref", 2, 1, 0, { 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, @@ -1028,6 +524,14 @@ SCM_DEFINE (scm_hashv_set_x, "hashv-set!", 3, 0, 0, "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 SCM_UNSPECIFIED; + } + return scm_hash_fn_set_x (table, key, val, (scm_t_hash_fn) scm_ihashv, (scm_t_assoc_fn) scm_sloppy_assv, @@ -1042,6 +546,13 @@ SCM_DEFINE (scm_hashv_remove_x, "hashv-remove!", 2, 0, 0, "@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)); + return SCM_UNSPECIFIED; + } + return scm_hash_fn_remove_x (table, key, (scm_t_hash_fn) scm_ihashv, (scm_t_assoc_fn) scm_sloppy_assv, @@ -1059,9 +570,6 @@ SCM_DEFINE (scm_hash_get_handle, "hash-get-handle", 2, 0, 0, "Uses @code{equal?} for equality testing.") #define FUNC_NAME s_scm_hash_get_handle { - if (SCM_UNLIKELY (SCM_HASHTABLE_P (table) && SCM_HASHTABLE_WEAK_P (table))) - SCM_MISC_ERROR ("Handle access not permitted on weak table", SCM_EOL); - return scm_hash_fn_get_handle (table, key, (scm_t_hash_fn) scm_ihash, (scm_t_assoc_fn) scm_sloppy_assoc, @@ -1077,9 +585,6 @@ SCM_DEFINE (scm_hash_create_handle_x, "hash-create-handle!", 3, 0, 0, "associates @var{key} with @var{init}.") #define FUNC_NAME s_scm_hash_create_handle_x { - if (SCM_UNLIKELY (SCM_HASHTABLE_P (table) && SCM_HASHTABLE_WEAK_P (table))) - SCM_MISC_ERROR ("Handle access not permitted on weak table", SCM_EOL); - return scm_hash_fn_create_handle_x (table, key, init, (scm_t_hash_fn) scm_ihash, (scm_t_assoc_fn) scm_sloppy_assoc, @@ -1088,6 +593,12 @@ SCM_DEFINE (scm_hash_create_handle_x, "hash-create-handle!", 3, 0, 0, #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" @@ -1098,6 +609,11 @@ SCM_DEFINE (scm_hash_ref, "hash-ref", 2, 1, 0, { 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, @@ -1114,6 +630,14 @@ SCM_DEFINE (scm_hash_set_x, "hash-set!", 3, 0, 0, "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 SCM_UNSPECIFIED; + } + return scm_hash_fn_set_x (table, key, val, (scm_t_hash_fn) scm_ihash, (scm_t_assoc_fn) scm_sloppy_assoc, @@ -1129,6 +653,13 @@ SCM_DEFINE (scm_hash_remove_x, "hash-remove!", 2, 0, 0, "@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)); + return SCM_UNSPECIFIED; + } + return scm_hash_fn_remove_x (table, key, (scm_t_hash_fn) scm_ihash, (scm_t_assoc_fn) scm_sloppy_assoc, @@ -1143,10 +674,9 @@ typedef struct scm_t_ihashx_closure { SCM hash; SCM assoc; + SCM key; } scm_t_ihashx_closure; - - static unsigned long scm_ihashx (SCM obj, unsigned long n, void *arg) { @@ -1156,8 +686,6 @@ 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) { @@ -1165,6 +693,20 @@ 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), @@ -1179,9 +721,7 @@ SCM_DEFINE (scm_hashx_get_handle, "hashx-get-handle", 4, 0, 0, scm_t_ihashx_closure closure; closure.hash = hash; closure.assoc = assoc; - - if (SCM_UNLIKELY (SCM_HASHTABLE_P (table) && SCM_HASHTABLE_WEAK_P (table))) - SCM_MISC_ERROR ("Handle access not permitted on weak table", SCM_EOL); + closure.key = key; return scm_hash_fn_get_handle (table, key, scm_ihashx, scm_sloppy_assx, (void *) &closure); @@ -1202,9 +742,7 @@ SCM_DEFINE (scm_hashx_create_handle_x, "hashx-create-handle!", 5, 0, 0, scm_t_ihashx_closure closure; closure.hash = hash; closure.assoc = assoc; - - if (SCM_UNLIKELY (SCM_HASHTABLE_P (table) && SCM_HASHTABLE_WEAK_P (table))) - SCM_MISC_ERROR ("Handle access not permitted on weak table", SCM_EOL); + closure.key = key; return scm_hash_fn_create_handle_x (table, key, init, scm_ihashx, scm_sloppy_assx, (void *)&closure); @@ -1231,6 +769,15 @@ SCM_DEFINE (scm_hashx_ref, "hashx-ref", 4, 1, 0, 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); } @@ -1255,6 +802,16 @@ SCM_DEFINE (scm_hashx_set_x, "hashx-set!", 5, 0, 0, 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 SCM_UNSPECIFIED; + } + return scm_hash_fn_set_x (table, key, val, scm_ihashx, scm_sloppy_assx, (void *)&closure); } @@ -1276,6 +833,16 @@ SCM_DEFINE (scm_hashx_remove_x, "hashx-remove!", 4, 0, 0, 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); + return SCM_UNSPECIFIED; + } + return scm_hash_fn_remove_x (table, obj, scm_ihashx, scm_sloppy_assx, (void *) &closure); } @@ -1296,6 +863,10 @@ SCM_DEFINE (scm_hash_fold, "hash-fold", 3, 0, 0, #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); @@ -1317,6 +888,10 @@ SCM_DEFINE (scm_hash_for_each, "hash-for-each", 2, 0, 0, #define FUNC_NAME s_scm_hash_for_each { SCM_VALIDATE_PROC (1, proc); + + if (SCM_WEAK_TABLE_P (table)) + return scm_weak_table_for_each (proc, table); + SCM_VALIDATE_HASHTABLE (2, table); scm_internal_hash_for_each_handle (for_each_proc, @@ -1335,9 +910,6 @@ SCM_DEFINE (scm_hash_for_each_handle, "hash-for-each-handle", 2, 0, 0, SCM_ASSERT (scm_is_true (scm_procedure_p (proc)), proc, 1, FUNC_NAME); SCM_VALIDATE_HASHTABLE (2, table); - if (SCM_UNLIKELY (SCM_HASHTABLE_WEAK_P (table))) - SCM_MISC_ERROR ("Handle access not permitted on weak table", SCM_EOL); - scm_internal_hash_for_each_handle ((scm_t_hash_handle_fn) scm_call_1, (void *) SCM_UNPACK (proc), table); @@ -1360,6 +932,10 @@ SCM_DEFINE (scm_hash_map_to_list, "hash-map->list", 2, 0, 0, #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), @@ -1378,6 +954,9 @@ scm_internal_hash_fold (scm_t_hash_fold_fn fn, void *closure, 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); @@ -1390,14 +969,7 @@ scm_internal_hash_fold (scm_t_hash_fold_fn fn, void *closure, ls = SCM_CDR (ls)) { handle = SCM_CAR (ls); - - if (SCM_HASHTABLE_WEAK_P (table) && SCM_WEAK_PAIR_DELETED_P (handle)) - /* Don't try to unlink this weak pair, as we're not within - the allocation lock. Instead rely on - vacuum_weak_hash_table to do its job. */ - continue; - else - result = fn (closure, SCM_CAR (handle), SCM_CDR (handle), result); + result = fn (closure, SCM_CAR (handle), SCM_CDR (handle), result); } } |