-/* Copyright (C) 1995,1996,1998,1999,2000,2001, 2003 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1998,1999,2000,2001, 2003, 2004, 2006 Free Software Foundation, Inc.
*
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program 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 General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
- * Boston, MA 02111-1307 USA
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
- *
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
+ * 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.
*
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
+ * 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.
*
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice. */
+ * 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
+ */
\f
+#include <stdio.h>
+
#include "libguile/_scm.h"
#include "libguile/alist.h"
#include "libguile/hash.h"
#include "libguile/root.h"
#include "libguile/vectors.h"
#include "libguile/ports.h"
-#include "libguile/weaks.h"
#include "libguile/validate.h"
#include "libguile/hashtab.h"
+
+
\f
-/* 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.
+/* 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.
+ *
*/
-/*fixme* Decrement and rehash when removing elemnts from a table.
+/* 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.
+ *
+ * Growing or shrinking, with following rehashing, is triggered when
+ * the load factor
+ *
+ * L = N / S (N: number of items in table, S: bucket vector length)
+ *
+ * passes an upper limit of 0.9 or a lower limit of 0.25.
+ *
+ * The implementation stores the upper and lower number of items which
+ * trigger a resize in the hashtable object.
+ *
+ * Possible hash table sizes (primes) are stored in the array
+ * hashtable_size.
*/
-/*fixme* Update n_items correctly for weak tables. This can be done
- by representing such tables with ordinary vectors and adding a scan
- function to the before sweep hook similarly to what is done in weaks.c.
- */
+scm_t_bits scm_tc16_hashtable;
-#define SCM_HASHTABLE_P(x) SCM_TYP16_PREDICATE (scm_tc16_hashtable, x)
-#define SCM_HASHTABLE_VECTOR(x) SCM_CELL_OBJECT_1 (x)
-#define SCM_SET_HASHTABLE_VECTOR(x, v) SCM_SET_CELL_OBJECT_1 (x, v)
-#define SCM_HASHTABLE(x) ((scm_t_hashtable *) SCM_CELL_WORD_2 (x))
-#define SCM_HASHTABLE_N_ITEMS(x) (SCM_HASHTABLE (x)->n_items)
-#define SCM_HASHTABLE_INCREMENT(x) (SCM_HASHTABLE_N_ITEMS(x)++)
-#define SCM_HASHTABLE_DECREMENT(x) (SCM_HASHTABLE_N_ITEMS(x)--)
-#define SCM_HASHTABLE_UPPER(x) (SCM_HASHTABLE (x)->upper)
-#define SCM_HASHTABLE_LOWER(x) (SCM_HASHTABLE (x)->lower)
+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 */
+#endif
+};
-scm_t_bits scm_tc16_hashtable;
+#define HASHTABLE_SIZE_N (sizeof(hashtable_size)/sizeof(unsigned long))
-typedef struct scm_t_hashtable {
- unsigned long n_items;
- unsigned long lower;
- unsigned long upper;
- int size_index;
- scm_t_mutex mutex;
-} scm_t_hashtable;
+static char *s_hashtable = "hashtable";
-#define HASHTABLE_SIZE_N 23
-unsigned long hashtable_size[] = {
- 37, 73, 139, 293, 587, 1181, 2357, 4733, 9467, 18919, 37879, 75773,
- 151549, 303097, 606181, 1212401, 2424827, 4849651, 9699323, 19398647,
- 38797303, 77594599, 155189239
-};
+\f
+/* Helper functions and macros to deal with weak pairs.
-static scm_t_mutex common_hashtable_mutex;
+ 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. */
-/* Turn an empty vector hash table into an opaque resizable one. */
-static char *s_hashtable = "hashtable";
+/* 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. */
+static SCM
+scm_fixup_weak_alist (SCM alist, size_t *removed_items)
+{
+ SCM result;
+ SCM prev = SCM_EOL;
-SCM
-scm_vector_to_hash_table (SCM vector) {
- SCM table;
- scm_t_hashtable *t = scm_gc_malloc (sizeof (*t), s_hashtable);
- int i = 0, len = SCM_VECTOR_LENGTH (vector);
- while (i < HASHTABLE_SIZE_N && len > hashtable_size[i])
+ *removed_items = 0;
+ for (result = alist;
+ scm_is_pair (alist);
+ prev = alist, alist = SCM_CDR (alist))
+ {
+ SCM pair = SCM_CAR (alist);
+
+ if (scm_is_pair (pair))
+ {
+ 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)++;
+ continue;
+ }
+ }
+ }
+
+ 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, _hashfn) \
+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); \
+ scm_i_rehash ((_obj), (_hashfn), \
+ NULL, "START_WEAK_BUCKET_FIXUP"); \
+ } \
+ } \
+while (0)
+
+/* Terminate a weak bucket fixup phase. */
+#define END_WEAK_BUCKET_FIXUP(_obj, _buckets, _idx, _bucket, _hashfn) \
+ do { GC_enable (); } while (0)
+
+
+\f
+static SCM
+make_hash_table (int flags, unsigned long k, const char *func_name)
+{
+ SCM table, vector;
+ scm_t_hashtable *t;
+ int i = 0, n = k ? k : 31;
+ while (i < HASHTABLE_SIZE_N && n > hashtable_size[i])
++i;
- if (i > 0)
- i = i - 1;
- t->size_index = 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->min_size_index = t->size_index = i;
t->n_items = 0;
- if (i == 0)
- t->lower = 0;
- else
- t->lower = hashtable_size[i] / 4;
- t->upper = 9 * hashtable_size[i] / 10;
- scm_i_plugin_mutex_init (&t->mutex, &scm_i_plugin_mutex);
+ t->lower = 0;
+ t->upper = 9 * n / 10;
+ t->flags = flags;
+ t->hash_fn = NULL;
+
SCM_NEWSMOB2 (table, scm_tc16_hashtable, vector, t);
+
return table;
}
+void
+scm_i_rehash (SCM table,
+ unsigned long (*hash_fn)(),
+ void *closure,
+ const char* func_name)
+{
+ SCM buckets, new_buckets;
+ int i;
+ unsigned long old_size;
+ unsigned long new_size;
+
+ if (SCM_HASHTABLE_N_ITEMS (table) < SCM_HASHTABLE_LOWER (table))
+ {
+ /* rehashing is not triggered when i <= min_size */
+ i = SCM_HASHTABLE (table)->size_index;
+ do
+ --i;
+ while (i > SCM_HASHTABLE (table)->min_size_index
+ && SCM_HASHTABLE_N_ITEMS (table) < hashtable_size[i] / 4);
+ }
+ else
+ {
+ i = SCM_HASHTABLE (table)->size_index + 1;
+ 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_size = hashtable_size[i];
+ if (i <= SCM_HASHTABLE (table)->min_size_index)
+ SCM_HASHTABLE (table)->lower = 0;
+ else
+ SCM_HASHTABLE (table)->lower = new_size / 4;
+ SCM_HASHTABLE (table)->upper = 9 * new_size / 10;
+ buckets = SCM_HASHTABLE_VECTOR (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);
+
+ old_size = SCM_SIMPLE_VECTOR_LENGTH (buckets);
+ for (i = 0; i < old_size; ++i)
+ {
+ SCM ls, cell, handle;
+
+ ls = SCM_SIMPLE_VECTOR_REF (buckets, i);
+ SCM_SIMPLE_VECTOR_SET (buckets, i, SCM_EOL);
+
+ 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));
+ SCM_SETCDR (cell, SCM_SIMPLE_VECTOR_REF (new_buckets, h));
+ SCM_SIMPLE_VECTOR_SET (new_buckets, h, cell);
+ SCM_HASHTABLE_INCREMENT (table);
+ }
+ }
+}
+
+
static int
hashtable_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED)
{
- scm_t_hashtable *t = SCM_HASHTABLE (exp);
- scm_puts ("#<resizing-hash-table ", port);
- scm_intprint ((unsigned long)t->n_items, 10, port);
+ 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_uintprint (SCM_HASHTABLE_N_ITEMS (exp), 10, port);
scm_putc ('/', port);
- scm_intprint ((unsigned long) SCM_VECTOR_LENGTH (SCM_HASHTABLE_VECTOR (exp)),
- 10, port);
+ scm_uintprint (SCM_SIMPLE_VECTOR_LENGTH (SCM_HASHTABLE_VECTOR (exp)),
+ 10, port);
scm_puts (">", port);
return 1;
}
-static size_t
-hashtable_free (SCM obj)
-{
- scm_gc_free (SCM_HASHTABLE (obj), sizeof (scm_t_hashtable), s_hashtable);
- return 0;
-}
-
SCM
scm_c_make_hash_table (unsigned long k)
{
- return scm_c_make_vector (k, SCM_EOL);
-}
-
-SCM
-scm_c_make_resizing_hash_table ()
-{
- return scm_vector_to_hash_table (scm_c_make_vector (37, SCM_EOL));
+ return make_hash_table (0, k, "scm_c_make_hash_table");
}
SCM_DEFINE (scm_make_hash_table, "make-hash-table", 0, 1, 0,
(SCM n),
- "Make a hash table with constant number of buckets @var{n}\n"
- "If called with zero arguments, create a resizing hash table.")
+ "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 scm_c_make_resizing_hash_table ();
+ return make_hash_table (0, 0, FUNC_NAME);
else
- {
- int k;
- SCM_VALIDATE_INUM_COPY (1, n, k);
- return scm_c_make_hash_table (k);
- }
+ return make_hash_table (0, scm_to_ulong (n), FUNC_NAME);
}
#undef FUNC_NAME
-static void
-rehash (SCM table, unsigned long (*hash_fn)(), void *closure)
+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 buckets, new_buckets;
- int i;
- unsigned long old_size;
- unsigned long new_size;
- if (SCM_HASHTABLE_N_ITEMS (table) < SCM_HASHTABLE_LOWER (table))
- i = --SCM_HASHTABLE (table)->size_index;
- else
- i = ++SCM_HASHTABLE (table)->size_index;
- new_size = hashtable_size[i];
- if (i == 0)
- SCM_HASHTABLE (table)->lower = 0;
+ if (SCM_UNBNDP (n))
+ return make_hash_table (SCM_HASHTABLEF_WEAK_CAR, 0, FUNC_NAME);
else
- SCM_HASHTABLE (table)->lower = new_size / 4;
- SCM_HASHTABLE (table)->upper = 9 * new_size / 10;
- buckets = SCM_HASHTABLE_VECTOR (table);
-
- if (SCM_VECTORP (buckets))
- new_buckets = scm_c_make_vector (new_size, SCM_EOL);
+ 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
+{
+ if (SCM_UNBNDP (n))
+ return make_hash_table (SCM_HASHTABLEF_WEAK_CDR, 0, FUNC_NAME);
else
- switch (SCM_WVECT_TYPE (buckets)) {
- case 1:
- new_buckets = scm_make_weak_key_hash_table (SCM_MAKINUM (new_size));
- break;
- case 2:
- new_buckets = scm_make_weak_value_hash_table (SCM_MAKINUM (new_size));
- break;
- case 3:
- new_buckets = scm_make_doubly_weak_hash_table (SCM_MAKINUM (new_size));
- break;
- default:
- abort (); /* never reached */
+ {
+ return make_hash_table (SCM_HASHTABLEF_WEAK_CDR,
+ scm_to_ulong (n), FUNC_NAME);
}
+}
+#undef FUNC_NAME
- old_size = SCM_VECTOR_LENGTH (buckets);
- for (i = 0; i < old_size; ++i)
+
+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
+{
+ if (SCM_UNBNDP (n))
+ return make_hash_table (SCM_HASHTABLEF_WEAK_CAR | SCM_HASHTABLEF_WEAK_CDR,
+ 0,
+ FUNC_NAME);
+ else
{
- SCM ls = SCM_VELTS (buckets)[i], handle;
- while (!SCM_NULLP (ls))
- {
- unsigned long h;
- if (!SCM_CONSP (ls))
- break;
- handle = SCM_CAR (ls);
- if (!SCM_CONSP (handle))
- continue;
- h = hash_fn (SCM_CAR (handle), new_size, closure);
- if (h >= new_size)
- {
- scm_mutex_unlock (&SCM_HASHTABLE (table)->mutex);
- scm_out_of_range ("hash_fn_create_handle_x",
- scm_ulong2num (h));
- }
- SCM_VECTOR_SET (new_buckets, h,
- scm_cons (handle, SCM_VELTS (new_buckets)[h]));
- ls = SCM_CDR (ls);
- }
+ return make_hash_table (SCM_HASHTABLEF_WEAK_CAR | SCM_HASHTABLEF_WEAK_CDR,
+ scm_to_ulong (n),
+ FUNC_NAME);
}
- SCM_SET_HASHTABLE_VECTOR (table, new_buckets);
}
+#undef FUNC_NAME
+
+
+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));
+}
+#undef FUNC_NAME
+
SCM
scm_hash_fn_get_handle (SCM table, SCM obj, unsigned long (*hash_fn)(), SCM (*assoc_fn)(), void * closure)
#define FUNC_NAME "scm_hash_fn_get_handle"
{
+ int weak = 0;
unsigned long k;
- SCM h;
- scm_t_mutex *m;
+ SCM buckets, alist, h;
if (SCM_HASHTABLE_P (table))
- {
- m = &SCM_HASHTABLE (table)->mutex;
- table = SCM_HASHTABLE_VECTOR (table);
- }
+ buckets = SCM_HASHTABLE_VECTOR (table);
else
{
SCM_VALIDATE_VECTOR (1, table);
- m = &common_hashtable_mutex;
+ buckets = table;
}
- if (SCM_VECTOR_LENGTH (table) == 0)
+
+ if (SCM_SIMPLE_VECTOR_LENGTH (buckets) == 0)
return SCM_BOOL_F;
- scm_mutex_lock (m);
- k = hash_fn (obj, SCM_VECTOR_LENGTH (table), closure);
- if (k >= SCM_VECTOR_LENGTH (table))
- {
- scm_mutex_unlock (m);
- scm_out_of_range ("hash_fn_get_handle", scm_ulong2num (k));
- }
- h = assoc_fn (obj, SCM_VELTS (table)[k], closure);
- scm_mutex_unlock (m);
+ 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));
+
+ weak = IS_WEAK_THING (table);
+ alist = SCM_SIMPLE_VECTOR_REF (buckets, k);
+
+ if (weak)
+ START_WEAK_BUCKET_FIXUP (table, buckets, k, alist, hash_fn);
+
+ h = assoc_fn (obj, alist, closure);
+ if (weak)
+ END_WEAK_BUCKET_FIXUP (table, buckets, k, alist, hash_fn);
+
return h;
}
#undef FUNC_NAME
SCM (*assoc_fn)(), void * closure)
#define FUNC_NAME "scm_hash_fn_create_handle_x"
{
+ int weak = 0;
unsigned long k;
- SCM buckets, it;
- scm_t_mutex *m;
+ SCM buckets, alist, it;
if (SCM_HASHTABLE_P (table))
- {
- buckets = SCM_HASHTABLE_VECTOR (table);
- m = &SCM_HASHTABLE (table)->mutex;
- }
+ buckets = SCM_HASHTABLE_VECTOR (table);
else
{
- SCM_ASSERT (SCM_VECTORP (table),
+ SCM_ASSERT (scm_is_simple_vector (table),
table, SCM_ARG1, "hash_fn_create_handle_x");
buckets = table;
- m = &common_hashtable_mutex;
}
- if (SCM_VECTOR_LENGTH (buckets) == 0)
+ if (SCM_SIMPLE_VECTOR_LENGTH (buckets) == 0)
SCM_MISC_ERROR ("void hashtable", SCM_EOL);
- scm_mutex_lock (m);
- k = hash_fn (obj, SCM_VECTOR_LENGTH (buckets), closure);
- if (k >= SCM_VECTOR_LENGTH (buckets))
- {
- scm_mutex_unlock (m);
- scm_out_of_range ("hash_fn_create_handle_x", scm_ulong2num (k));
- }
- it = assoc_fn (obj, SCM_VELTS (buckets)[k], closure);
- if (!SCM_FALSEP (it))
- {
- scm_mutex_unlock (m);
- return it;
- }
+ k = hash_fn (obj, SCM_SIMPLE_VECTOR_LENGTH (buckets), closure);
+ 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, hash_fn);
+
+ it = assoc_fn (obj, alist, closure);
+ if (weak)
+ END_WEAK_BUCKET_FIXUP (table, buckets, k, alist, hash_fn);
+
+ if (scm_is_true (it))
+ return it;
else
{
- SCM new_bucket;
- SCM old_bucket;
- if (table != buckets)
+ /* 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_P (table)) && (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);
+
+ new_bucket = scm_cons (handle, SCM_EOL);
+
+ if (!scm_is_eq (table, buckets)
+ && !scm_is_eq (SCM_HASHTABLE_VECTOR (table), buckets))
+ {
+ buckets = SCM_HASHTABLE_VECTOR (table);
+ k = hash_fn (obj, SCM_SIMPLE_VECTOR_LENGTH (buckets), closure);
+ if (k >= SCM_SIMPLE_VECTOR_LENGTH (buckets))
+ scm_out_of_range ("hash_fn_create_handle_x", scm_from_ulong (k));
+ }
+ 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_UPPER (table))
- {
- rehash (table, hash_fn, closure);
- buckets = SCM_HASHTABLE_VECTOR (table);
- k = hash_fn (obj, SCM_VECTOR_LENGTH (buckets), closure);
- if (k >= SCM_VECTOR_LENGTH (buckets))
- {
- scm_mutex_unlock (m);
- scm_out_of_range ("hash_fn_create_handle_x",
- scm_ulong2num (k));
- }
- }
+ 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);
}
- old_bucket = SCM_VELTS (buckets)[k];
- new_bucket = scm_acons (obj, init, old_bucket);
- SCM_VECTOR_SET (buckets, k, new_bucket);
- scm_mutex_unlock (m);
return SCM_CAR (new_bucket);
}
}
SCM (*assoc_fn)(), void * closure)
{
SCM it = scm_hash_fn_get_handle (table, obj, hash_fn, assoc_fn, closure);
- if (SCM_CONSP (it))
+ if (scm_is_pair (it))
return SCM_CDR (it);
else
return dflt;
}
-
-
-
-SCM
-scm_hash_fn_remove_x (SCM table, SCM obj, unsigned long (*hash_fn)(), SCM (*assoc_fn)(),
- SCM (*delete_fn)(), void * closure)
+SCM
+scm_hash_fn_remove_x (SCM table, SCM obj,
+ unsigned long (*hash_fn)(),
+ SCM (*assoc_fn)(),
+ void *closure)
{
+ int weak = 0;
unsigned long k;
- SCM h;
+ SCM buckets, alist, h;
- SCM_ASSERT (SCM_VECTORP (table), table, SCM_ARG1, "hash_fn_remove_x");
- if (SCM_VECTOR_LENGTH (table) == 0)
+ 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)
return SCM_EOL;
- k = hash_fn (obj, SCM_VECTOR_LENGTH (table), closure);
- if (k >= SCM_VECTOR_LENGTH (table))
- scm_out_of_range ("hash_fn_remove_x", scm_ulong2num (k));
- h = assoc_fn (obj, SCM_VELTS (table)[k], closure);
- SCM_VECTOR_SET (table, k, delete_fn (h, SCM_VELTS(table)[k]));
+
+ 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, hash_fn);
+
+ h = assoc_fn (obj, alist, closure);
+ if (weak)
+ END_WEAK_BUCKET_FIXUP (table, buckets, k, alist, hash_fn);
+
+ 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");
+ }
+ }
return h;
}
+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);
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
\f
"@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,
- scm_delq_x, 0);
+ return scm_hash_fn_remove_x (table, key, scm_ihashq, scm_sloppy_assq, 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,
- scm_delv_x, 0);
+ return scm_hash_fn_remove_x (table, key, scm_ihashv, scm_sloppy_assv, 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,
- scm_delete_x, 0);
+ return scm_hash_fn_remove_x (table, key, scm_ihash, scm_sloppy_assoc, 0);
}
#undef FUNC_NAME
{
SCM hash;
SCM assoc;
- SCM delete;
} scm_t_ihashx_closure;
static unsigned long
scm_ihashx (SCM obj, unsigned long n, scm_t_ihashx_closure *closure)
{
- SCM answer;
- SCM_DEFER_INTS;
- answer = scm_call_2 (closure->hash, obj, scm_ulong2num ((unsigned long) n));
- SCM_ALLOW_INTS;
- return SCM_INUM (answer);
+ SCM 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 answer;
- SCM_DEFER_INTS;
- answer = scm_call_2 (closure->assoc, obj, alist);
- SCM_ALLOW_INTS;
- return answer;
+ return scm_call_2 (closure->assoc, obj, alist);
}
-
-
-static SCM
-scm_delx_x (SCM obj, SCM alist, scm_t_ihashx_closure *closure)
-{
- SCM answer;
- SCM_DEFER_INTS;
- answer = scm_call_2 (closure->delete, obj, alist);
- SCM_ALLOW_INTS;
- return answer;
-}
-
-
-
SCM_DEFINE (scm_hashx_get_handle, "hashx-get-handle", 4, 0, 0,
(SCM hash, SCM assoc, SCM table, SCM key),
"This behaves the same way as the corresponding\n"
closure.hash = hash;
closure.assoc = assoc;
return scm_hash_fn_get_handle (table, key, scm_ihashx, scm_sloppy_assx,
- (void *)&closure);
+ (void *) &closure);
}
#undef FUNC_NAME
}
#undef FUNC_NAME
-
-
-SCM
-scm_hashx_remove_x (SCM hash, SCM assoc, SCM delete, SCM table, SCM obj)
+SCM_DEFINE (scm_hashx_remove_x, "hashx-remove!", 4, 0, 0,
+ (SCM hash, SCM assoc, SCM table, SCM obj),
+ "This behaves the same way as the corresponding @code{remove!}\n"
+ "function, but uses @var{hash} as a hash function and\n"
+ "@var{assoc} to compare keys. @code{hash} must be a function\n"
+ "that takes two arguments, a key to be hashed and a table size.\n"
+ "@code{assoc} must be an associator function, like @code{assoc},\n"
+ "@code{assq} or @code{assv}.\n"
+ "\n"
+ " By way of illustration, @code{hashq-remove! table key} is\n"
+ "equivalent to @code{hashx-remove! hashq assq #f table key}.")
+#define FUNC_NAME s_scm_hashx_remove_x
{
scm_t_ihashx_closure closure;
closure.hash = hash;
closure.assoc = assoc;
- closure.delete = delete;
- return scm_hash_fn_remove_x (table, obj, scm_ihashx, scm_sloppy_assx, scm_delx_x, 0);
+ return scm_hash_fn_remove_x (table, obj, scm_ihashx, scm_sloppy_assx,
+ (void *) &closure);
}
+#undef FUNC_NAME
-static SCM
-fold_proc (void *proc, SCM key, SCM data, SCM value)
+/* Hash table iterators */
+
+static const char s_scm_hash_fold[];
+
+SCM
+scm_internal_hash_fold (SCM (*fn) (), void *closure, SCM init, SCM table)
{
- return scm_call_3 (SCM_PACK (proc), key, data, value);
+ 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_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));
+
+ if (SCM_HASHTABLE_P (table))
+ /* Update the item count. */
+ SCM_HASHTABLE_DECREMENT (table);
+
+ 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,
#define FUNC_NAME s_scm_hash_fold
{
SCM_VALIDATE_PROC (1, proc);
- SCM_VALIDATE_VECTOR (3, table);
- return scm_internal_hash_fold (fold_proc, (void *) SCM_UNPACK (proc), init, table);
+ if (!SCM_HASHTABLE_P (table))
+ SCM_VALIDATE_VECTOR (3, table);
+ return scm_internal_hash_fold (scm_call_3, (void *) SCM_UNPACK (proc), init, table);
}
#undef FUNC_NAME
-SCM
-scm_internal_hash_fold (SCM (*fn) (), void *closure, SCM init, SCM table)
+static SCM
+for_each_proc (void *proc, SCM handle)
{
- long i, n = SCM_VECTOR_LENGTH (table);
- SCM result = init;
- for (i = 0; i < n; ++i)
- {
- SCM ls = SCM_VELTS (table)[i], handle;
- while (!SCM_NULLP (ls))
- {
- SCM_ASSERT (SCM_CONSP (ls),
- table, SCM_ARG3, s_scm_hash_fold);
- handle = SCM_CAR (ls);
- SCM_ASSERT (SCM_CONSP (handle),
- table, SCM_ARG3, s_scm_hash_fold);
- result = fn (closure, SCM_CAR (handle), SCM_CDR (handle), result);
- ls = SCM_CDR (ls);
- }
- }
- return result;
+ return scm_call_2 (SCM_PACK (proc), SCM_CAR (handle), SCM_CDR (handle));
+}
+
+SCM_DEFINE (scm_hash_for_each, "hash-for-each", 2, 0, 0,
+ (SCM proc, SCM table),
+ "An iterator over hash-table elements.\n"
+ "Applies PROC successively on all hash table items.\n"
+ "The arguments to PROC are \"(key value)\" where key\n"
+ "and value are successive pairs from the hash table TABLE.")
+#define FUNC_NAME s_scm_hash_for_each
+{
+ SCM_VALIDATE_PROC (1, proc);
+ if (!SCM_HASHTABLE_P (table))
+ SCM_VALIDATE_VECTOR (2, table);
+
+ scm_internal_hash_for_each_handle (for_each_proc,
+ (void *) SCM_UNPACK (proc),
+ table);
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_hash_for_each_handle, "hash-for-each-handle", 2, 0, 0,
+ (SCM proc, SCM table),
+ "An iterator over hash-table elements.\n"
+ "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_internal_hash_for_each_handle (call,
+ (void *) SCM_UNPACK (proc),
+ table);
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+static SCM
+map_proc (void *proc, SCM key, SCM data, SCM value)
+{
+ return scm_cons (scm_call_2 (SCM_PACK (proc), key, data), value);
+}
+
+SCM_DEFINE (scm_hash_map_to_list, "hash-map->list", 2, 0, 0,
+ (SCM proc, SCM table),
+ "An iterator over hash-table elements.\n"
+ "Accumulates and returns as a list the results of applying PROC successively.\n"
+ "The arguments to PROC are \"(key value)\" where key\n"
+ "and value are successive pairs from the hash table TABLE.")
+#define FUNC_NAME s_scm_hash_map_to_list
+{
+ SCM_VALIDATE_PROC (1, proc);
+ if (!SCM_HASHTABLE_P (table))
+ SCM_VALIDATE_VECTOR (2, table);
+ return scm_internal_hash_fold (map_proc,
+ (void *) SCM_UNPACK (proc),
+ SCM_EOL,
+ table);
}
+#undef FUNC_NAME
\f
void
-scm_init_hashtab ()
+scm_hashtab_prehistory ()
{
+ /* Initialize the hashtab SMOB type. */
scm_tc16_hashtable = scm_make_smob_type (s_hashtable, 0);
- scm_set_smob_mark (scm_tc16_hashtable, scm_markcdr);
scm_set_smob_print (scm_tc16_hashtable, hashtable_print);
- scm_set_smob_free (scm_tc16_hashtable, hashtable_free);
- scm_i_plugin_mutex_init (&common_hashtable_mutex, &scm_i_plugin_mutex);
+}
+
+void
+scm_init_hashtab ()
+{
#include "libguile/hashtab.x"
}
HCoop / bpt / guile.git / blobdiff