-/* Copyright (C) 1995,1996,1998,1999,2000,2001, 2003, 2004, 2006 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 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
\f
+#ifdef HAVE_CONFIG_H
+# include <config.h>
+#endif
+#include <alloca.h>
#include <stdio.h>
+#include <assert.h>
#include "libguile/_scm.h"
#include "libguile/alist.h"
#include "libguile/root.h"
#include "libguile/vectors.h"
#include "libguile/ports.h"
+#include "libguile/bdw-gc.h"
#include "libguile/validate.h"
#include "libguile/hashtab.h"
-#include <gc/gc.h>
-#include <gc/gc_typed.h>
-
\f
-/* NOTES
- *
- * 1. The current hash table implementation uses weak alist vectors
- * (implementation in weaks.c) internally, but we do the scanning
- * ourselves (in scan_weak_hashtables) because we need to update the
- * hash table structure when items are dropped during GC.
- *
- * 2. All hash table operations still work on alist vectors.
- *
- */
-
-/* Hash tables are either vectors of association lists or smobs
- * containing such vectors. Currently, the vector version represents
- * constant size tables while those wrapped in a smob represents
- * resizing tables.
+/* A hash table is a cell containing a vector of association lists.
*
* Growing or shrinking, with following rehashing, is triggered when
* the load factor
* 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.
*/
-scm_t_bits scm_tc16_hashtable;
-
static unsigned long hashtable_size[] = {
31, 61, 113, 223, 443, 883, 1759, 3517, 7027, 14051, 28099, 56197, 112363,
224717, 449419, 898823, 1797641, 3595271, 7190537, 14381041
-#if 0
- /* vectors are currently restricted to 2^24-1 = 16777215 elements. */
- 28762081, 57524111, 115048217, 230096423, 460192829
- /* larger values can't be represented as INUMs */
+#if SIZEOF_SCM_T_BITS > 4
+ /* vector lengths are stored in the first word of vectors, shifted by
+ 8 bits for the tc8, so for 32-bit we only get 2^24-1 = 16777215
+ elements. But we allow a few more sizes for 64-bit. */
+ , 28762081, 57524111, 115048217, 230096423, 460192829
#endif
};
static char *s_hashtable = "hashtable";
-SCM weak_hashtables = SCM_EOL;
-
\f
-/* Weak cells for use in weak alist vectors (aka. weak hash tables).
+/* Helper functions and macros to deal with weak pairs.
- We have weal-car cells, weak-cdr cells, and doubly weak cells. In weak
- cells, the weak component(s) are not scanned for pointers and are
- registered as disapperaring links; therefore, the weak component may be
- set to NULL by the garbage collector when no other reference to that word
- exist. Thus, we use `scm_fixup_weak_alist ()' to check for nullified weak
- cells and remove them. */
-
-
-/* Type descriptors for weak-c[ad]r cells. */
-static GC_descr wcar_cell_descr, wcdr_cell_descr;
+ 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_weak_car_cell (SCM car, SCM cdr)
+scm_fixup_weak_alist (SCM alist, size_t *removed_items)
{
- scm_t_cell *cell;
+ 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);
- cell = (scm_t_cell *)GC_malloc_explicitly_typed (sizeof (*cell),
- wcar_cell_descr);
+ 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));
- cell->word_0 = car;
- cell->word_1 = cdr;
+ (*removed_items)++;
- if (SCM_NIMP (car))
- {
- /* Weak car cells make sense iff the car is non-immediate. */
- GC_GENERAL_REGISTER_DISAPPEARING_LINK ((GC_PTR)&cell->word_0,
- (GC_PTR)SCM_UNPACK (car));
+ /* Leave PREV unchanged. */
+ }
+ else
+ prev = alist;
}
- return (SCM_PACK (cell));
+ return result;
}
-static SCM
-scm_weak_cdr_cell (SCM car, SCM cdr)
+static void
+vacuum_weak_hash_table (SCM table)
{
- scm_t_cell *cell;
-
- cell = (scm_t_cell *)GC_malloc_explicitly_typed (sizeof (*cell),
- wcdr_cell_descr);
-
- cell->word_0 = car;
- cell->word_1 = cdr;
+ SCM buckets = SCM_HASHTABLE_VECTOR (table);
+ unsigned long k = SCM_SIMPLE_VECTOR_LENGTH (buckets);
+ size_t len = SCM_HASHTABLE_N_ITEMS (table);
- if (SCM_NIMP (cdr))
+ while (k--)
{
- /* Weak cdr cells make sense iff the cdr is non-immediate. */
- GC_GENERAL_REGISTER_DISAPPEARING_LINK ((GC_PTR)&cell->word_1,
- (GC_PTR)SCM_UNPACK (cdr));
+ 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);
}
- return (SCM_PACK (cell));
+ SCM_SET_HASHTABLE_N_ITEMS (table, len);
}
-static SCM
-scm_doubly_weak_cell (SCM car, SCM cdr)
+
+/* 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)
{
- /* Doubly weak cells shall not be scanned at all for pointers. */
- scm_t_cell *cell = (scm_t_cell *)scm_gc_malloc_pointerless (sizeof (*cell),
- "weak cell");
+ struct t_fixup_args *args;
+ SCM pair, *copy;
- cell->word_0 = car;
- cell->word_1 = cdr;
+ args = (struct t_fixup_args *) data;
- if (SCM_NIMP (car))
- {
- GC_GENERAL_REGISTER_DISAPPEARING_LINK ((GC_PTR)&cell->word_0,
- (GC_PTR)SCM_UNPACK (car));
- }
- if (SCM_NIMP (cdr))
+ 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)
{
- GC_GENERAL_REGISTER_DISAPPEARING_LINK ((GC_PTR)&cell->word_1,
- (GC_PTR)SCM_UNPACK (cdr));
+ /* 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 (SCM_PACK (cell));
+ return args;
}
-/* Testing the weak component(s) of a cell for reachability. */
-#define SCM_WEAK_CELL_WORD_DELETED_P(_cell, _word) \
- (SCM_CELL_OBJECT ((_cell), (_word)) == SCM_PACK (NULL))
-#define SCM_WEAK_CELL_CAR_DELETED_P(_cell) \
- (SCM_WEAK_CELL_WORD_DELETED_P ((_cell), 0))
-#define SCM_WEAK_CELL_CDR_DELETED_P(_cell) \
- (SCM_WEAK_CELL_WORD_DELETED_P ((_cell), 1))
-
-/* Accessing the components of a weak cell. */
-#define SCM_WEAK_CELL_WORD(_cell, _word) \
- ((SCM_WEAK_CELL_WORD_DELETED_P ((_cell), (_word))) \
- ? SCM_BOOL_F : SCM_CAR (pair))
-#define SCM_WEAK_CELL_CAR(_cell) (SCM_WEAK_CELL_WORD ((_cell), 0))
-#define SCM_WEAK_CELL_CDR(_cell) (SCM_WEAK_CELL_WORD ((_cell), 1))
-
-
-/* Return a ``usable'' version of ALIST, an alist of weak pairs. By
- ``usable'', we mean that it contains only valid Scheme objects. On
- return, REMOVE_ITEMS is set to the number of pairs that have been
- deleted. */
+/* 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
-scm_fixup_weak_alist (SCM alist, size_t *removed_items)
+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 prev = SCM_EOL;
+ SCM bucket, *strong_refs;
+ struct t_fixup_args args;
- *removed_items = 0;
- for (result = alist;
- scm_is_pair (alist);
- prev = alist, alist = SCM_CDR (alist))
+ 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)
{
- SCM pair = SCM_CAR (alist);
+ /* Update TABLE's item count and optionally trigger a rehash. */
+ size_t remaining;
- if (scm_is_pair (pair))
- {
- if ((SCM_WEAK_CELL_CAR_DELETED_P (pair))
- || (SCM_WEAK_CELL_CDR_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)++;
- continue;
- }
- }
+ 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;
}
-/* Helper macros. */
-
-/* Return true if OBJ is either a weak hash table or a weak alist vector (as
- defined in `weaks.[ch]').
- FIXME: We should eventually keep only weah hash tables. Actually, the
- procs in `weaks.c' already no longer return vectors. */
-/* XXX: We assume that if OBJ is a vector, then it's a _weak_ alist vector. */
-#define IS_WEAK_THING(_obj) \
- ((SCM_HASHTABLE_P (table) && (SCM_HASHTABLE_WEAK_P (table))) \
- || (SCM_I_IS_VECTOR (table)))
-
-/* Fixup BUCKET, an alist part of weak hash table OBJ. BUCKETS is the full
- bucket vector for OBJ and IDX is the index of BUCKET within this
- vector. See also `scm_internal_hash_fold ()'. */
-#define START_WEAK_BUCKET_FIXUP(_obj, _buckets, _idx, _bucket) \
-do \
- { \
- size_t _removed; \
- \
- /* Disable the GC so that BUCKET remains valid until ASSOC_FN has \
- returned. */ \
- /* FIXME: We could maybe trigger a rehash here depending on whether \
- `scm_fixup_weak_alist ()' noticed some change. */ \
- GC_disable (); \
- (_bucket) = scm_fixup_weak_alist ((_bucket), &_removed); \
- SCM_SIMPLE_VECTOR_SET ((_buckets), (_idx), (_bucket)); \
- \
- if ((_removed) && (SCM_HASHTABLE_P (_obj))) \
- SCM_SET_HASHTABLE_N_ITEMS ((_obj), \
- SCM_HASHTABLE_N_ITEMS (_obj) - _removed); \
- } \
-while (0)
-
-/* Terminate a weak bucket fixup phase. */
-#define END_WEAK_BUCKET_FIXUP(_obj, _buckets, _idx, _bucket) \
- do { GC_enable (); } while (0)
+/* 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)
{
- SCM table, vector;
+ 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];
t->upper = 9 * n / 10;
t->flags = flags;
t->hash_fn = NULL;
- if (flags)
- {
- /* FIXME: We should eventually remove WEAK_HASHTABLES. */
- SCM_NEWSMOB3 (table, scm_tc16_hashtable, vector, t, weak_hashtables);
- weak_hashtables = table;
- }
- else
- SCM_NEWSMOB3 (table, scm_tc16_hashtable, vector, t, SCM_EOL);
- return table;
+
+ /* FIXME: we just need two words of storage, not three */
+ return scm_double_cell (scm_tc7_hashtable, SCM_UNPACK (vector),
+ (scm_t_bits)t, 0);
}
void
scm_i_rehash (SCM table,
- unsigned long (*hash_fn)(),
+ scm_t_hash_fn hash_fn,
void *closure,
const char* func_name)
{
unsigned long old_size;
unsigned long new_size;
- if (SCM_HASHTABLE_P (table) && SCM_HASHTABLE_WEAK_P (table))
- /* FIXME: We don't currently support weak hash table rehashing. In order
- to support it, we need to pay attention to NULL pairs, as in
- `scm_internal_hash_fold ()', `START_WEAK_BUCKET_FIXUP ()', et al. */
- return;
-
if (SCM_HASHTABLE_N_ITEMS (table) < SCM_HASHTABLE_LOWER (table))
{
/* rehashing is not triggered when i <= min_size */
while (scm_is_pair (ls))
{
unsigned long h;
+
cell = ls;
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));
}
-static int
-hashtable_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED)
+void
+scm_i_hashtable_print (SCM exp, SCM port, scm_print_state *pstate)
{
scm_puts ("#<", port);
if (SCM_HASHTABLE_WEAK_KEY_P (exp))
else if (SCM_HASHTABLE_DOUBLY_WEAK_P (exp))
scm_puts ("doubly-weak-", port);
scm_puts ("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_uintprint (SCM_SIMPLE_VECTOR_LENGTH (SCM_HASHTABLE_VECTOR (exp)),
10, port);
scm_puts (">", port);
- return 1;
-}
-
-/* keep track of hash tables that need to shrink after scan */
-static SCM to_rehash = SCM_EOL;
-
-
-static void *
-rehash_after_gc (void *dummy1 SCM_UNUSED,
- void *dummy2 SCM_UNUSED,
- void *dummy3 SCM_UNUSED)
-{
- if (!scm_is_null (to_rehash))
- {
- SCM first = to_rehash, last, h;
- /* important to clear to_rehash here so that we don't get stuck
- in an infinite loop if scm_i_rehash causes GC */
- to_rehash = SCM_EOL;
- h = first;
- do
- {
- /* Rehash only when we have a hash_fn.
- */
- if (SCM_HASHTABLE (h)->hash_fn)
- scm_i_rehash (h, SCM_HASHTABLE (h)->hash_fn, NULL,
- "rehash_after_gc");
- last = h;
- h = SCM_HASHTABLE_NEXT (h);
- } while (!scm_is_null (h));
- /* move tables back to weak_hashtables */
- SCM_SET_HASHTABLE_NEXT (last, weak_hashtables);
- weak_hashtables = first;
- }
- return 0;
}
}
#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"
"would modify regular hash tables. (@pxref{Hash Tables})")
#define FUNC_NAME s_scm_make_weak_key_hash_table
{
+ SCM ret;
+
if (SCM_UNBNDP (n))
- return make_hash_table (SCM_HASHTABLEF_WEAK_CAR, 0, FUNC_NAME);
+ ret = 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);
+ 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
"(@pxref{Hash Tables})")
#define FUNC_NAME s_scm_make_weak_value_hash_table
{
+ SCM ret;
+
if (SCM_UNBNDP (n))
- return make_hash_table (SCM_HASHTABLEF_WEAK_CDR, 0, FUNC_NAME);
+ ret = make_hash_table (SCM_HASHTABLEF_WEAK_CDR, 0, FUNC_NAME);
else
- {
- return make_hash_table (SCM_HASHTABLEF_WEAK_CDR,
- scm_to_ulong (n), FUNC_NAME);
- }
+ 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
"buckets. (@pxref{Hash Tables})")
#define FUNC_NAME s_scm_make_doubly_weak_hash_table
{
+ SCM ret;
+
if (SCM_UNBNDP (n))
- return make_hash_table (SCM_HASHTABLEF_WEAK_CAR | SCM_HASHTABLEF_WEAK_CDR,
- 0,
- FUNC_NAME);
+ ret = make_hash_table (SCM_HASHTABLEF_WEAK_CAR | SCM_HASHTABLEF_WEAK_CDR,
+ 0, FUNC_NAME);
else
- {
- return make_hash_table (SCM_HASHTABLEF_WEAK_CAR | SCM_HASHTABLEF_WEAK_CDR,
- scm_to_ulong (n),
- FUNC_NAME);
- }
+ 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;
}
#undef FUNC_NAME
#undef FUNC_NAME
+\f
+/* Accessing hash table entries. */
+
SCM
-scm_hash_fn_get_handle (SCM table, SCM obj, unsigned long (*hash_fn)(), SCM (*assoc_fn)(), void * closure)
+scm_hash_fn_get_handle (SCM table, SCM obj,
+ scm_t_hash_fn hash_fn, scm_t_assoc_fn assoc_fn,
+ void * closure)
#define FUNC_NAME "scm_hash_fn_get_handle"
{
- int weak = 0;
unsigned long k;
- SCM buckets, alist, h;
+ SCM buckets, h;
- if (SCM_HASHTABLE_P (table))
- buckets = SCM_HASHTABLE_VECTOR (table);
- else
- {
- SCM_VALIDATE_VECTOR (1, table);
- buckets = table;
- }
+ SCM_VALIDATE_HASHTABLE (SCM_ARG1, table);
+ buckets = SCM_HASHTABLE_VECTOR (table);
if (SCM_SIMPLE_VECTOR_LENGTH (buckets) == 0)
return SCM_BOOL_F;
k = hash_fn (obj, SCM_SIMPLE_VECTOR_LENGTH (buckets), closure);
if (k >= SCM_SIMPLE_VECTOR_LENGTH (buckets))
- scm_out_of_range ("hash_fn_get_handle", scm_from_ulong (k));
+ scm_out_of_range (FUNC_NAME, scm_from_ulong (k));
- weak = IS_WEAK_THING (table);
- alist = SCM_SIMPLE_VECTOR_REF (buckets, 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);
- if (weak)
- START_WEAK_BUCKET_FIXUP (table, buckets, k, alist);
+ return h;
+}
+#undef FUNC_NAME
- h = assoc_fn (obj, alist, closure);
- if (weak)
- END_WEAK_BUCKET_FIXUP (table, buckets, k, alist);
+
+/* 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;
+ }
+ }
return h;
}
SCM
-scm_hash_fn_create_handle_x (SCM table, SCM obj, SCM init, unsigned long (*hash_fn)(),
- SCM (*assoc_fn)(), void * closure)
+scm_hash_fn_create_handle_x (SCM table, SCM obj, SCM init,
+ scm_t_hash_fn hash_fn, scm_t_assoc_fn assoc_fn,
+ void * closure)
#define FUNC_NAME "scm_hash_fn_create_handle_x"
{
- int weak = 0;
unsigned long k;
- SCM buckets, alist, it;
+ SCM buckets, it;
+
+ SCM_VALIDATE_HASHTABLE (SCM_ARG1, table);
+ buckets = SCM_HASHTABLE_VECTOR (table);
- if (SCM_HASHTABLE_P (table))
- buckets = SCM_HASHTABLE_VECTOR (table);
- else
- {
- SCM_ASSERT (scm_is_simple_vector (table),
- table, SCM_ARG1, "hash_fn_create_handle_x");
- buckets = table;
- }
if (SCM_SIMPLE_VECTOR_LENGTH (buckets) == 0)
SCM_MISC_ERROR ("void hashtable", SCM_EOL);
if (k >= SCM_SIMPLE_VECTOR_LENGTH (buckets))
scm_out_of_range ("hash_fn_create_handle_x", scm_from_ulong (k));
- weak = IS_WEAK_THING (table);
- alist = SCM_SIMPLE_VECTOR_REF (buckets, k);
- if (weak)
- START_WEAK_BUCKET_FIXUP (table, buckets, k, alist);
-
- it = assoc_fn (obj, alist, closure);
- if (weak)
- END_WEAK_BUCKET_FIXUP (table, buckets, k, alist);
+ 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);
- if (scm_is_true (it))
+ if (scm_is_pair (it))
return it;
+ else if (scm_is_true (it))
+ scm_wrong_type_arg_msg (NULL, 0, it, "a pair");
else
{
/* When this is a weak hashtable, running the GC can change it.
*/
SCM handle, new_bucket;
- if ((SCM_HASHTABLE_P (table)) && (SCM_HASHTABLE_WEAK_P (table)))
+ 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_cell (obj, init);
+ handle = scm_doubly_weak_pair (obj, init);
else if (SCM_HASHTABLE_WEAK_KEY_P (table))
- handle = scm_weak_car_cell (obj, init);
+ handle = scm_weak_car_pair (obj, init);
else
- handle = scm_weak_cdr_cell (obj, init);
+ handle = scm_weak_cdr_pair (obj, init);
}
else
/* Use a regular, non-weak cell. */
new_bucket = scm_cons (handle, SCM_EOL);
- if (!scm_is_eq (table, buckets)
- && !scm_is_eq (SCM_HASHTABLE_VECTOR (table), buckets))
+ if (!scm_is_eq (SCM_HASHTABLE_VECTOR (table), buckets))
{
buckets = SCM_HASHTABLE_VECTOR (table);
k = hash_fn (obj, SCM_SIMPLE_VECTOR_LENGTH (buckets), closure);
}
SCM_SETCDR (new_bucket, SCM_SIMPLE_VECTOR_REF (buckets, k));
SCM_SIMPLE_VECTOR_SET (buckets, k, new_bucket);
- if (!scm_is_eq (table, buckets))
- {
- /* Update element count and maybe rehash the table. The
- table might have too few entries here since weak hash
- tables used with the hashx_* functions can not be
- rehashed after GC.
- */
- SCM_HASHTABLE_INCREMENT (table);
- if (SCM_HASHTABLE_N_ITEMS (table) < SCM_HASHTABLE_LOWER (table)
- || SCM_HASHTABLE_N_ITEMS (table) > SCM_HASHTABLE_UPPER (table))
- scm_i_rehash (table, hash_fn, closure, FUNC_NAME);
- }
+ SCM_HASHTABLE_INCREMENT (table);
+
+ /* Maybe rehash the table. */
+ if (SCM_HASHTABLE_N_ITEMS (table) < SCM_HASHTABLE_LOWER (table)
+ || SCM_HASHTABLE_N_ITEMS (table) > SCM_HASHTABLE_UPPER (table))
+ scm_i_rehash (table, hash_fn, closure, FUNC_NAME);
return SCM_CAR (new_bucket);
}
}
#undef FUNC_NAME
-SCM
-scm_hash_fn_ref (SCM table, SCM obj, SCM dflt, unsigned long (*hash_fn)(),
- SCM (*assoc_fn)(), void * closure)
+SCM
+scm_hash_fn_ref (SCM table, SCM obj, SCM dflt,
+ scm_t_hash_fn hash_fn, scm_t_assoc_fn assoc_fn,
+ void *closure)
{
SCM it = scm_hash_fn_get_handle (table, obj, hash_fn, assoc_fn, closure);
if (scm_is_pair (it))
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;
+}
-SCM
-scm_hash_fn_set_x (SCM table, SCM obj, SCM val, unsigned long (*hash_fn)(),
- SCM (*assoc_fn)(), void * closure)
+static SCM
+weak_pair_cdr (SCM x)
{
- SCM it;
+ struct weak_cdr_data data;
+
+ data.pair = x;
+ GC_call_with_alloc_lock (get_weak_cdr, &data);
- it = scm_hash_fn_create_handle_x (table, obj, SCM_BOOL_F, hash_fn, assoc_fn, closure);
- SCM_SETCDR (it, val);
+ 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,
+ void *closure)
+{
+ SCM pair;
+
+ pair = scm_hash_fn_create_handle_x (table, obj, 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 ((void **) SCM_CDRLOC (pair));
+ else
+ SCM_I_REGISTER_DISAPPEARING_LINK ((void **) SCM_CDRLOC (pair),
+ SCM2PTR (val));
+ }
+ else
+ SCM_SETCDR (pair, val);
+ }
+
return val;
}
SCM
scm_hash_fn_remove_x (SCM table, SCM obj,
- unsigned long (*hash_fn)(),
- SCM (*assoc_fn)(),
+ scm_t_hash_fn hash_fn,
+ scm_t_assoc_fn assoc_fn,
void *closure)
+#define FUNC_NAME "hash_fn_remove_x"
{
- int weak = 0;
unsigned long k;
- SCM buckets, alist, h;
+ SCM buckets, h;
- if (SCM_HASHTABLE_P (table))
- buckets = SCM_HASHTABLE_VECTOR (table);
- else
- {
- SCM_ASSERT (scm_is_simple_vector (table), table,
- SCM_ARG1, "hash_fn_remove_x");
- buckets = table;
- }
- if (SCM_SIMPLE_VECTOR_LENGTH (table) == 0)
+ SCM_VALIDATE_HASHTABLE (SCM_ARG1, table);
+
+ buckets = SCM_HASHTABLE_VECTOR (table);
+
+ if (SCM_SIMPLE_VECTOR_LENGTH (buckets) == 0)
return SCM_EOL;
k = hash_fn (obj, SCM_SIMPLE_VECTOR_LENGTH (buckets), closure);
if (k >= SCM_SIMPLE_VECTOR_LENGTH (buckets))
- scm_out_of_range ("hash_fn_remove_x", scm_from_ulong (k));
-
- weak = IS_WEAK_THING (table);
- alist = SCM_SIMPLE_VECTOR_REF (buckets, k);
- if (weak)
- START_WEAK_BUCKET_FIXUP (table, buckets, k, alist);
+ scm_out_of_range (FUNC_NAME, scm_from_ulong (k));
- h = assoc_fn (obj, alist, closure);
- if (weak)
- END_WEAK_BUCKET_FIXUP (table, buckets, k, alist);
+ 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);
if (scm_is_true (h))
{
SCM_SIMPLE_VECTOR_SET
(buckets, k, scm_delq_x (h, SCM_SIMPLE_VECTOR_REF (buckets, k)));
- if (!scm_is_eq (table, buckets))
- {
- SCM_HASHTABLE_DECREMENT (table);
- if (SCM_HASHTABLE_N_ITEMS (table) < SCM_HASHTABLE_LOWER (table))
- scm_i_rehash (table, hash_fn, closure, "scm_hash_fn_remove_x");
- }
+ SCM_HASHTABLE_DECREMENT (table);
+ if (SCM_HASHTABLE_N_ITEMS (table) < SCM_HASHTABLE_LOWER (table))
+ scm_i_rehash (table, hash_fn, closure, FUNC_NAME);
}
return h;
}
+#undef FUNC_NAME
SCM_DEFINE (scm_hash_clear_x, "hash-clear!", 1, 0, 0,
(SCM table),
"Remove all items from @var{table} (without triggering a resize).")
#define FUNC_NAME s_scm_hash_clear_x
{
- if (SCM_HASHTABLE_P (table))
- {
- scm_vector_fill_x (SCM_HASHTABLE_VECTOR (table), SCM_EOL);
- SCM_SET_HASHTABLE_N_ITEMS (table, 0);
- }
- else
- scm_vector_fill_x (table, SCM_EOL);
+ SCM_VALIDATE_HASHTABLE (SCM_ARG1, table);
+
+ scm_vector_fill_x (SCM_HASHTABLE_VECTOR (table), SCM_EOL);
+ SCM_SET_HASHTABLE_N_ITEMS (table, 0);
+
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
"Uses @code{eq?} for equality testing.")
#define FUNC_NAME s_scm_hashq_get_handle
{
- return scm_hash_fn_get_handle (table, key, scm_ihashq, scm_sloppy_assq, 0);
+ 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,
+ 0);
}
#undef FUNC_NAME
"associates @var{key} with @var{init}.")
#define FUNC_NAME s_scm_hashq_create_handle_x
{
- return scm_hash_fn_create_handle_x (table, key, init, scm_ihashq, scm_sloppy_assq, 0);
+ 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,
+ 0);
}
#undef FUNC_NAME
(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;
- return scm_hash_fn_ref (table, key, dflt, scm_ihashq, scm_sloppy_assq, 0);
+ return scm_hash_fn_ref (table, key, dflt,
+ (scm_t_hash_fn) scm_ihashq,
+ (scm_t_assoc_fn) scm_sloppy_assq,
+ 0);
}
#undef FUNC_NAME
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
{
- return scm_hash_fn_set_x (table, key, val, scm_ihashq, scm_sloppy_assq, 0);
+ return scm_hash_fn_set_x (table, key, val,
+ (scm_t_hash_fn) scm_ihashq,
+ (scm_t_assoc_fn) scm_sloppy_assq,
+ 0);
}
#undef FUNC_NAME
"@var{table}. Uses @code{eq?} for equality tests.")
#define FUNC_NAME s_scm_hashq_remove_x
{
- return scm_hash_fn_remove_x (table, key, scm_ihashq, scm_sloppy_assq, 0);
+ return scm_hash_fn_remove_x (table, key,
+ (scm_t_hash_fn) scm_ihashq,
+ (scm_t_assoc_fn) scm_sloppy_assq,
+ 0);
}
#undef FUNC_NAME
"Uses @code{eqv?} for equality testing.")
#define FUNC_NAME s_scm_hashv_get_handle
{
- return scm_hash_fn_get_handle (table, key, scm_ihashv, scm_sloppy_assv, 0);
+ 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,
+ 0);
}
#undef FUNC_NAME
"associates @var{key} with @var{init}.")
#define FUNC_NAME s_scm_hashv_create_handle_x
{
- return scm_hash_fn_create_handle_x (table, key, init, scm_ihashv,
- scm_sloppy_assv, 0);
+ 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,
+ 0);
}
#undef FUNC_NAME
(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;
- return scm_hash_fn_ref (table, key, dflt, scm_ihashv, scm_sloppy_assv, 0);
+ return scm_hash_fn_ref (table, key, dflt,
+ (scm_t_hash_fn) scm_ihashv,
+ (scm_t_assoc_fn) scm_sloppy_assv,
+ 0);
}
#undef FUNC_NAME
"store @var{value} there. Uses @code{eqv?} for equality testing.")
#define FUNC_NAME s_scm_hashv_set_x
{
- return scm_hash_fn_set_x (table, key, val, scm_ihashv, scm_sloppy_assv, 0);
+ return scm_hash_fn_set_x (table, key, val,
+ (scm_t_hash_fn) scm_ihashv,
+ (scm_t_assoc_fn) scm_sloppy_assv,
+ 0);
}
#undef FUNC_NAME
"@var{table}. Uses @code{eqv?} for equality tests.")
#define FUNC_NAME s_scm_hashv_remove_x
{
- return scm_hash_fn_remove_x (table, key, scm_ihashv, scm_sloppy_assv, 0);
+ return scm_hash_fn_remove_x (table, key,
+ (scm_t_hash_fn) scm_ihashv,
+ (scm_t_assoc_fn) scm_sloppy_assv,
+ 0);
}
#undef FUNC_NAME
"Uses @code{equal?} for equality testing.")
#define FUNC_NAME s_scm_hash_get_handle
{
- return scm_hash_fn_get_handle (table, key, scm_ihash, scm_sloppy_assoc, 0);
+ 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,
+ 0);
}
#undef FUNC_NAME
"associates @var{key} with @var{init}.")
#define FUNC_NAME s_scm_hash_create_handle_x
{
- return scm_hash_fn_create_handle_x (table, key, init, scm_ihash, scm_sloppy_assoc, 0);
+ 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,
+ 0);
}
#undef FUNC_NAME
(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;
- return scm_hash_fn_ref (table, key, dflt, scm_ihash, scm_sloppy_assoc, 0);
+ return scm_hash_fn_ref (table, key, dflt,
+ (scm_t_hash_fn) scm_ihash,
+ (scm_t_assoc_fn) scm_sloppy_assoc,
+ 0);
}
#undef FUNC_NAME
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
{
- return scm_hash_fn_set_x (table, key, val, scm_ihash, scm_sloppy_assoc, 0);
+ return scm_hash_fn_set_x (table, key, val,
+ (scm_t_hash_fn) scm_ihash,
+ (scm_t_assoc_fn) scm_sloppy_assoc,
+ 0);
}
#undef FUNC_NAME
"@var{table}. Uses @code{equal?} for equality tests.")
#define FUNC_NAME s_scm_hash_remove_x
{
- return scm_hash_fn_remove_x (table, key, scm_ihash, scm_sloppy_assoc, 0);
+ return scm_hash_fn_remove_x (table, key,
+ (scm_t_hash_fn) scm_ihash,
+ (scm_t_assoc_fn) scm_sloppy_assoc,
+ 0);
}
#undef FUNC_NAME
static unsigned long
-scm_ihashx (SCM obj, unsigned long n, scm_t_ihashx_closure *closure)
+scm_ihashx (SCM obj, unsigned long n, void *arg)
{
- SCM answer = scm_call_2 (closure->hash, obj, scm_from_ulong (n));
+ SCM answer;
+ scm_t_ihashx_closure *closure = (scm_t_ihashx_closure *) arg;
+ answer = scm_call_2 (closure->hash, obj, scm_from_ulong (n));
return scm_to_ulong (answer);
}
static SCM
-scm_sloppy_assx (SCM obj, SCM alist, scm_t_ihashx_closure *closure)
+scm_sloppy_assx (SCM obj, SCM alist, void *arg)
{
+ scm_t_ihashx_closure *closure = (scm_t_ihashx_closure *) arg;
return scm_call_2 (closure->assoc, obj, alist);
}
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);
+
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;
+
+ 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_ihashx,
scm_sloppy_assx, (void *)&closure);
}
/* Hash table iterators */
-static const char s_scm_hash_fold[];
-
-SCM
-scm_internal_hash_fold (SCM (*fn) (), void *closure, SCM init, SCM table)
-{
- long i, n;
- SCM buckets, result = init;
-
- if (SCM_HASHTABLE_P (table))
- buckets = SCM_HASHTABLE_VECTOR (table);
- else
- /* Weak alist vector. */
- buckets = table;
-
- n = SCM_SIMPLE_VECTOR_LENGTH (buckets);
- for (i = 0; i < n; ++i)
- {
- SCM prev, ls;
-
- for (prev = SCM_BOOL_F, ls = SCM_SIMPLE_VECTOR_REF (buckets, i);
- !scm_is_null (ls);
- prev = ls, ls = SCM_CDR (ls))
- {
- SCM handle;
-
- if (!scm_is_pair (ls))
- scm_wrong_type_arg (s_scm_hash_fold, SCM_ARG3, buckets);
-
- handle = SCM_CAR (ls);
- if (!scm_is_pair (handle))
- scm_wrong_type_arg (s_scm_hash_fold, SCM_ARG3, buckets);
-
- if (IS_WEAK_THING (table))
- {
- if ((SCM_CAR (handle) == SCM_PACK (NULL))
- || (SCM_CDR (handle) == SCM_PACK (NULL)))
- {
- /* 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));
-
- if (SCM_HASHTABLE_P (table))
- {
- /* Update the item count. */
- unsigned long items = SCM_HASHTABLE_N_ITEMS (table);
-
- if (items <= 0)
- abort ();
- SCM_SET_HASHTABLE_N_ITEMS (table, items - 1);
- }
-
- continue;
- }
- }
-
- result = fn (closure, SCM_CAR (handle), SCM_CDR (handle), result);
- }
- }
-
- return result;
-}
-
-/* The following redundant code is here in order to be able to support
- hash-for-each-handle. An alternative would have been to replace
- this code and scm_internal_hash_fold above with a single
- scm_internal_hash_fold_handles, but we don't want to promote such
- an API. */
-
-static const char s_scm_hash_for_each[];
-
-void
-scm_internal_hash_for_each_handle (SCM (*fn) (), void *closure, SCM table)
-{
- long i, n;
- SCM buckets;
-
- if (SCM_HASHTABLE_P (table))
- buckets = SCM_HASHTABLE_VECTOR (table);
- else
- buckets = table;
-
- n = SCM_SIMPLE_VECTOR_LENGTH (buckets);
- for (i = 0; i < n; ++i)
- {
- SCM ls = SCM_SIMPLE_VECTOR_REF (buckets, i), handle;
- while (!scm_is_null (ls))
- {
- if (!scm_is_pair (ls))
- scm_wrong_type_arg (s_scm_hash_for_each, SCM_ARG3, buckets);
- handle = SCM_CAR (ls);
- if (!scm_is_pair (handle))
- scm_wrong_type_arg (s_scm_hash_for_each, SCM_ARG3, buckets);
- fn (closure, handle);
- ls = SCM_CDR (ls);
- }
- }
-}
-
SCM_DEFINE (scm_hash_fold, "hash-fold", 3, 0, 0,
(SCM proc, SCM init, SCM table),
"An iterator over hash-table elements.\n"
#define FUNC_NAME s_scm_hash_fold
{
SCM_VALIDATE_PROC (1, proc);
- if (!SCM_HASHTABLE_P (table))
- SCM_VALIDATE_VECTOR (3, table);
- return scm_internal_hash_fold (scm_call_3, (void *) SCM_UNPACK (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);
}
#undef FUNC_NAME
#define FUNC_NAME s_scm_hash_for_each
{
SCM_VALIDATE_PROC (1, proc);
- if (!SCM_HASHTABLE_P (table))
- SCM_VALIDATE_VECTOR (2, table);
+ SCM_VALIDATE_HASHTABLE (2, table);
scm_internal_hash_for_each_handle (for_each_proc,
(void *) SCM_UNPACK (proc),
"Applies PROC successively on all hash table handles.")
#define FUNC_NAME s_scm_hash_for_each_handle
{
- scm_t_trampoline_1 call = scm_trampoline_1 (proc);
- SCM_ASSERT (call, proc, 1, FUNC_NAME);
- if (!SCM_HASHTABLE_P (table))
- SCM_VALIDATE_VECTOR (2, table);
+ SCM_ASSERT (scm_is_true (scm_procedure_p (proc)), proc, 1, FUNC_NAME);
+ SCM_VALIDATE_HASHTABLE (2, table);
- scm_internal_hash_for_each_handle (call,
+ 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);
return SCM_UNSPECIFIED;
#define FUNC_NAME s_scm_hash_map_to_list
{
SCM_VALIDATE_PROC (1, proc);
- if (!SCM_HASHTABLE_P (table))
- SCM_VALIDATE_VECTOR (2, table);
+ SCM_VALIDATE_HASHTABLE (2, table);
return scm_internal_hash_fold (map_proc,
(void *) SCM_UNPACK (proc),
SCM_EOL,
}
#undef FUNC_NAME
-\f
+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;
-void
-scm_hashtab_prehistory ()
+ 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
+scm_internal_hash_fold (scm_t_hash_fold_fn fn, void *closure,
+ SCM init, SCM table)
+#define FUNC_NAME s_scm_hash_fold
{
- /* Initialize weak cells. */
- GC_word wcar_cell_bitmap[GC_BITMAP_SIZE (scm_t_cell)] = { 0 };
- GC_word wcdr_cell_bitmap[GC_BITMAP_SIZE (scm_t_cell)] = { 0 };
+ long i, n;
+ SCM buckets, result = init;
+
+ SCM_VALIDATE_HASHTABLE (0, table);
+ buckets = SCM_HASHTABLE_VECTOR (table);
+
+ n = SCM_SIMPLE_VECTOR_LENGTH (buckets);
+ for (i = 0; i < n; ++i)
+ {
+ SCM ls, handle;
- /* In a weak-car cell, only the second word must be scanned for
- pointers. */
- GC_set_bit (wcar_cell_bitmap, GC_WORD_OFFSET (scm_t_cell, word_1));
- wcar_cell_descr = GC_make_descriptor (wcar_cell_bitmap,
- GC_WORD_LEN (scm_t_cell));
+ for (ls = SCM_SIMPLE_VECTOR_REF (buckets, i); !scm_is_null (ls);
+ ls = SCM_CDR (ls))
+ {
+ handle = SCM_CAR (ls);
- /* Conversely, in a weak-cdr cell, only the first word must be scanned for
- pointers. */
- GC_set_bit (wcdr_cell_bitmap, GC_WORD_OFFSET (scm_t_cell, word_0));
- wcdr_cell_descr = GC_make_descriptor (wcdr_cell_bitmap,
- GC_WORD_LEN (scm_t_cell));
+ 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);
+ }
+ }
+ return result;
+}
+#undef FUNC_NAME
- /* Initialize the hashtab SMOB type. */
- scm_tc16_hashtable = scm_make_smob_type (s_hashtable, 0);
- scm_set_smob_print (scm_tc16_hashtable, hashtable_print);
- scm_c_hook_add (&scm_after_gc_c_hook, rehash_after_gc, 0, 0);
+/* The following redundant code is here in order to be able to support
+ hash-for-each-handle. An alternative would have been to replace
+ this code and scm_internal_hash_fold above with a single
+ scm_internal_hash_fold_handles, but we don't want to promote such
+ an API. */
+
+void
+scm_internal_hash_for_each_handle (scm_t_hash_handle_fn fn, void *closure,
+ SCM table)
+#define FUNC_NAME s_scm_hash_for_each
+{
+ long i, n;
+ SCM buckets;
+
+ SCM_VALIDATE_HASHTABLE (0, table);
+ buckets = SCM_HASHTABLE_VECTOR (table);
+ n = SCM_SIMPLE_VECTOR_LENGTH (buckets);
+
+ for (i = 0; i < n; ++i)
+ {
+ SCM ls = SCM_SIMPLE_VECTOR_REF (buckets, i), handle;
+ while (!scm_is_null (ls))
+ {
+ 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);
+ fn (closure, handle);
+ ls = SCM_CDR (ls);
+ }
+ }
}
+#undef FUNC_NAME
+
+\f
+
void
scm_init_hashtab ()
HCoop / bpt / guile.git / blobdiff