/* Copyright 1995-1996,1998-2001,2003-2004,2006,2008-2013,2018,2025
Free Software Foundation, Inc.
This file is part of Guile.
Guile is free software: you can redistribute it and/or modify it
under the terms of the GNU Lesser General Public License as published
by the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
Guile 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 Guile. If not, see
. */
#ifdef HAVE_CONFIG_H
# include
#endif
#include
#include
#include
#include "alist.h"
#include "boolean.h"
#include "deprecation.h"
#include "eq.h"
#include "eval.h"
#include "gsubr.h"
#include "hash.h"
#include "list.h"
#include "modules.h"
#include "numbers.h"
#include "pairs.h"
#include "ports.h"
#include "procs.h"
#include "threads.h"
#include "variable.h"
#include "vectors.h"
#include "hashtab.h"
#if (SCM_ENABLE_DEPRECATED == 1)
/* In versions 3.0 and prior, the hash table interface could also access
weak tables. This is now deprecated. */
static SCM make_weak_key_hash_table_var;
static SCM weak_key_hash_table_p_var;
static SCM weak_key_hash_table_ref_var;
static SCM weak_key_hash_table_set_x_var;
static SCM weak_key_hash_table_remove_x_var;
static SCM weak_key_hash_table_clear_x_var;
static SCM weak_key_hash_table_fold_var;
static SCM weak_key_hash_table_for_each_var;
static SCM weak_key_hash_table_map_to_list_var;
static SCM make_weak_value_hash_table_var;
static SCM weak_value_hash_table_p_var;
static SCM weak_value_hash_table_ref_var;
static SCM weak_value_hash_table_set_x_var;
static SCM weak_value_hash_table_remove_x_var;
static SCM weak_value_hash_table_clear_x_var;
static SCM weak_value_hash_table_fold_var;
static SCM weak_value_hash_table_for_each_var;
static SCM weak_value_hash_table_map_to_list_var;
static SCM make_doubly_weak_hash_table_var;
static SCM doubly_weak_hash_table_p_var;
static SCM doubly_weak_hash_table_ref_var;
static SCM doubly_weak_hash_table_set_x_var;
static SCM doubly_weak_hash_table_remove_x_var;
static SCM doubly_weak_hash_table_clear_x_var;
static SCM doubly_weak_hash_table_fold_var;
static SCM doubly_weak_hash_table_for_each_var;
static SCM doubly_weak_hash_table_map_to_list_var;
static void
init_weak_hash_table_constructor_vars (void)
{
make_weak_key_hash_table_var =
scm_c_public_lookup ("ice-9 weak-tables", "make-weak-key-hash-table");
make_weak_value_hash_table_var =
scm_c_public_lookup ("ice-9 weak-tables", "make-weak-value-hash-table");
make_doubly_weak_hash_table_var =
scm_c_public_lookup ("ice-9 weak-tables", "make-doubly-weak-hash-table");
}
static void
init_weak_hash_table_predicate_vars (void)
{
weak_key_hash_table_p_var =
scm_c_public_lookup ("ice-9 weak-tables", "weak-key-hash-table?");
weak_value_hash_table_p_var =
scm_c_public_lookup ("ice-9 weak-tables", "weak-value-hash-table?");
doubly_weak_hash_table_p_var =
scm_c_public_lookup ("ice-9 weak-tables", "doubly-weak-hash-table?");
}
static void
init_weak_hash_table_accessor_vars (void)
{
weak_key_hash_table_ref_var =
scm_c_public_lookup ("ice-9 weak-tables", "weak-key-hash-table-ref");
weak_key_hash_table_set_x_var =
scm_c_public_lookup ("ice-9 weak-tables", "weak-key-hash-table-set!");
weak_key_hash_table_remove_x_var =
scm_c_public_lookup ("ice-9 weak-tables", "weak-key-hash-table-remove!");
weak_key_hash_table_clear_x_var =
scm_c_public_lookup ("ice-9 weak-tables", "weak-key-hash-table-clear!");
weak_value_hash_table_ref_var =
scm_c_public_lookup ("ice-9 weak-tables", "weak-value-hash-table-ref");
weak_value_hash_table_set_x_var =
scm_c_public_lookup ("ice-9 weak-tables", "weak-value-hash-table-set!");
weak_value_hash_table_remove_x_var =
scm_c_public_lookup ("ice-9 weak-tables", "weak-value-hash-table-remove!");
weak_value_hash_table_clear_x_var =
scm_c_public_lookup ("ice-9 weak-tables", "weak-value-hash-table-clear!");
doubly_weak_hash_table_ref_var =
scm_c_public_lookup ("ice-9 weak-tables", "doubly-weak-hash-table-ref");
doubly_weak_hash_table_set_x_var =
scm_c_public_lookup ("ice-9 weak-tables", "doubly-weak-hash-table-set!");
doubly_weak_hash_table_remove_x_var =
scm_c_public_lookup ("ice-9 weak-tables", "doubly-weak-hash-table-remove!");
doubly_weak_hash_table_clear_x_var =
scm_c_public_lookup ("ice-9 weak-tables", "doubly-weak-hash-table-clear!");
}
static void
init_weak_hash_table_iteration_vars (void)
{
weak_key_hash_table_fold_var =
scm_c_public_lookup ("ice-9 weak-tables", "weak-key-hash-table-fold");
weak_key_hash_table_for_each_var =
scm_c_public_lookup ("ice-9 weak-tables", "weak-key-hash-table-for-each");
weak_key_hash_table_map_to_list_var =
scm_c_public_lookup ("ice-9 weak-tables", "weak-key-hash-table-map->list");
weak_value_hash_table_fold_var =
scm_c_public_lookup ("ice-9 weak-tables", "weak-value-hash-table-fold");
weak_value_hash_table_for_each_var =
scm_c_public_lookup ("ice-9 weak-tables", "weak-value-hash-table-for-each");
weak_value_hash_table_map_to_list_var =
scm_c_public_lookup ("ice-9 weak-tables", "weak-value-hash-table-map->list");
doubly_weak_hash_table_fold_var =
scm_c_public_lookup ("ice-9 weak-tables", "doubly-weak-hash-table-fold");
doubly_weak_hash_table_for_each_var =
scm_c_public_lookup ("ice-9 weak-tables", "doubly-weak-hash-table-for-each");
doubly_weak_hash_table_map_to_list_var =
scm_c_public_lookup ("ice-9 weak-tables", "doubly-weak-hash-table-map->list");
}
static void
init_weak_table_constructors (void)
{
static scm_i_pthread_once_t once = SCM_I_PTHREAD_ONCE_INIT;
scm_c_issue_deprecation_warning
("Creating weak hash tables from C is deprecated. Invoke "
"make-weak-key-hash-table, etc. from (ice-9 weak-tables) instead.");
scm_i_pthread_once (&once, init_weak_hash_table_constructor_vars);
}
static void
init_weak_table_predicates (void)
{
static scm_i_pthread_once_t once = SCM_I_PTHREAD_ONCE_INIT;
scm_i_pthread_once (&once, init_weak_hash_table_predicate_vars);
}
static void
init_weak_table_accessors (void)
{
static scm_i_pthread_once_t once = SCM_I_PTHREAD_ONCE_INIT;
scm_c_issue_deprecation_warning
("Accessing weak hash tables via hashq-ref, hashq-set!, and so on is "
"deprecated. Invoke the weak-table-specific procedures from (ice-9 "
"weak-tables) instead.");
scm_i_pthread_once (&once, init_weak_hash_table_accessor_vars);
}
static void
init_weak_table_iterators (void)
{
static scm_i_pthread_once_t once = SCM_I_PTHREAD_ONCE_INIT;
scm_c_issue_deprecation_warning
("Iterating weak hash tables via hash-fold, hash-for-each, and so on is "
"deprecated. Invoke the weak-table-specific procedures from (ice-9 "
"weak-tables) instead.");
scm_i_pthread_once (&once, init_weak_hash_table_iteration_vars);
}
static int
is_weak_key_hash_table (SCM x)
{
init_weak_table_predicates ();
return scm_is_true
(scm_call_1 (scm_variable_ref (weak_key_hash_table_p_var), x));
}
static int
is_weak_value_hash_table (SCM x)
{
init_weak_table_predicates ();
return scm_is_true
(scm_call_1 (scm_variable_ref (weak_value_hash_table_p_var), x));
}
static int
is_doubly_weak_hash_table (SCM x)
{
init_weak_table_predicates ();
return scm_is_true
(scm_call_1 (scm_variable_ref (doubly_weak_hash_table_p_var), x));
}
static SCM
weak_key_hash_table_ref (SCM table, SCM key, SCM dflt)
{
init_weak_table_accessors ();
// FIXME: #:default-value
SCM ret = scm_call_2 (scm_variable_ref (weak_key_hash_table_ref_var),
table, key);
return scm_is_false (ret) ? dflt : ret;
}
static SCM
weak_key_hash_table_set_x (SCM table, SCM key, SCM value)
{
init_weak_table_accessors ();
scm_call_3 (scm_variable_ref (weak_key_hash_table_set_x_var),
table, key, value);
return value;
}
static SCM
weak_key_hash_table_remove_x (SCM table, SCM key)
{
init_weak_table_accessors ();
scm_call_2 (scm_variable_ref (weak_key_hash_table_remove_x_var),
table, key);
return SCM_BOOL_F;
}
static SCM
weak_key_hash_table_clear_x (SCM table)
{
init_weak_table_accessors ();
scm_call_1 (scm_variable_ref (weak_key_hash_table_clear_x_var), table);
return SCM_UNSPECIFIED;
}
static SCM
weak_key_hash_table_fold (SCM proc, SCM init, SCM table)
{
init_weak_table_iterators ();
return scm_call_3 (scm_variable_ref (weak_key_hash_table_fold_var),
proc, init, table);
}
static SCM
weak_key_hash_table_for_each (SCM proc, SCM table)
{
init_weak_table_iterators ();
scm_call_2 (scm_variable_ref (weak_key_hash_table_for_each_var),
proc, table);
return SCM_UNSPECIFIED;
}
static SCM
weak_key_hash_table_map_to_list (SCM proc, SCM table)
{
init_weak_table_iterators ();
return scm_call_2 (scm_variable_ref (weak_key_hash_table_map_to_list_var),
proc, table);
}
static SCM
weak_value_hash_table_ref (SCM table, SCM key, SCM dflt)
{
init_weak_table_accessors ();
// FIXME: #:default-value
SCM ret = scm_call_2 (scm_variable_ref (weak_value_hash_table_ref_var),
table, key);
return scm_is_false (ret) ? dflt : ret;
}
static SCM
weak_value_hash_table_set_x (SCM table, SCM key, SCM value)
{
init_weak_table_accessors ();
scm_call_3 (scm_variable_ref (weak_value_hash_table_set_x_var),
table, key, value);
return value;
}
static SCM
weak_value_hash_table_remove_x (SCM table, SCM key)
{
init_weak_table_accessors ();
scm_call_2 (scm_variable_ref (weak_value_hash_table_remove_x_var),
table, key);
return SCM_BOOL_F;
}
static SCM
weak_value_hash_table_clear_x (SCM table)
{
init_weak_table_accessors ();
scm_call_1 (scm_variable_ref (weak_value_hash_table_clear_x_var), table);
return SCM_UNSPECIFIED;
}
static SCM
weak_value_hash_table_fold (SCM proc, SCM init, SCM table)
{
init_weak_table_iterators ();
return scm_call_3 (scm_variable_ref (weak_value_hash_table_fold_var),
proc, init, table);
}
static SCM
weak_value_hash_table_for_each (SCM proc, SCM table)
{
init_weak_table_iterators ();
scm_call_2 (scm_variable_ref (weak_value_hash_table_for_each_var),
proc, table);
return SCM_UNSPECIFIED;
}
static SCM
weak_value_hash_table_map_to_list (SCM proc, SCM table)
{
init_weak_table_iterators ();
return scm_call_2 (scm_variable_ref (weak_value_hash_table_map_to_list_var),
proc, table);
}
static SCM
doubly_weak_hash_table_ref (SCM table, SCM key, SCM dflt)
{
init_weak_table_accessors ();
// FIXME: #:default-value
SCM ret = scm_call_2 (scm_variable_ref (doubly_weak_hash_table_ref_var),
table, key);
return scm_is_false (ret) ? dflt : ret;
}
static SCM
doubly_weak_hash_table_set_x (SCM table, SCM key, SCM value)
{
init_weak_table_accessors ();
scm_call_3 (scm_variable_ref (doubly_weak_hash_table_set_x_var),
table, key, value);
return value;
}
static SCM
doubly_weak_hash_table_remove_x (SCM table, SCM key)
{
init_weak_table_accessors ();
scm_call_2 (scm_variable_ref (doubly_weak_hash_table_remove_x_var),
table, key);
return SCM_BOOL_F;
}
static SCM
doubly_weak_hash_table_clear_x (SCM table)
{
init_weak_table_accessors ();
scm_call_1 (scm_variable_ref (doubly_weak_hash_table_clear_x_var), table);
return SCM_UNSPECIFIED;
}
static SCM
doubly_weak_hash_table_fold (SCM proc, SCM init, SCM table)
{
init_weak_table_iterators ();
return scm_call_3 (scm_variable_ref (doubly_weak_hash_table_fold_var),
proc, init, table);
}
static SCM
doubly_weak_hash_table_for_each (SCM proc, SCM table)
{
init_weak_table_iterators ();
scm_call_2 (scm_variable_ref (doubly_weak_hash_table_for_each_var),
proc, table);
return SCM_UNSPECIFIED;
}
static SCM
doubly_weak_hash_table_map_to_list (SCM proc, SCM table)
{
init_weak_table_iterators ();
return scm_call_2 (scm_variable_ref (doubly_weak_hash_table_map_to_list_var),
proc, table);
}
SCM
scm_make_weak_key_hash_table (SCM unused)
{
init_weak_table_constructors ();
return scm_call_0 (scm_variable_ref (make_weak_key_hash_table_var));
}
SCM
scm_make_weak_value_hash_table (SCM unused)
{
init_weak_table_constructors ();
return scm_call_0 (scm_variable_ref (make_weak_value_hash_table_var));
}
SCM
scm_make_doubly_weak_hash_table (SCM unused)
{
init_weak_table_constructors ();
return scm_call_0 (scm_variable_ref (make_doubly_weak_hash_table_var));
}
SCM
scm_weak_key_hash_table_p (SCM x)
{
init_weak_table_predicates ();
scm_c_issue_deprecation_warning
("scm_weak_key_hash_table_p is deprecated. Use weak-key-hash-table? "
"from (ice-9 weak-tables) instead.");
return scm_from_bool (is_weak_key_hash_table (x));
}
SCM
scm_weak_value_hash_table_p (SCM x)
{
init_weak_table_predicates ();
scm_c_issue_deprecation_warning
("scm_weak_value_hash_table_p is deprecated. Use weak-value-hash-table? "
"from (ice-9 weak-tables) instead.");
return scm_from_bool (is_weak_value_hash_table (x));
}
SCM
scm_doubly_weak_hash_table_p (SCM x)
{
init_weak_table_predicates ();
scm_c_issue_deprecation_warning
("scm_doubly_weak_hash_table_p is deprecated. Use doubly-weak-hash-table? "
"from (ice-9 weak-tables) instead.");
return scm_from_bool (is_doubly_weak_hash_table (x));
}
#endif // SCM_ENABLE_DEPRECATED == 1
/* A hash table is a cell containing a vector of association lists.
*
* 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.
*/
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 SIZEOF_UINTPTR_T > 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
};
#define HASHTABLE_SIZE_N (sizeof(hashtable_size)/sizeof(unsigned long))
static char *s_hashtable = "hashtable";
static SCM
make_hash_table (unsigned long k, const char *func_name)
{
SCM vector;
scm_t_hashtable *t;
int i = 0, n = k ? k : 31;
while (i + 1 < HASHTABLE_SIZE_N && n > hashtable_size[i])
++i;
n = hashtable_size[i];
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;
t->lower = 0;
t->upper = 9 * n / 10;
/* 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,
scm_t_hash_fn 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;
}
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);
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);
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);
}
}
}
void
scm_i_hashtable_print (SCM exp, SCM port, scm_print_state *pstate)
{
scm_puts ("#", port);
}
SCM
scm_c_make_hash_table (unsigned long k)
{
return make_hash_table (k, "scm_c_make_hash_table");
}
SCM_DEFINE (scm_make_hash_table, "make-hash-table", 0, 1, 0,
(SCM n),
"Make a new abstract hash table object with minimum number of buckets @var{n}\n")
#define FUNC_NAME s_scm_make_hash_table
{
return make_hash_table (SCM_UNBNDP (n) ? 0 : scm_to_ulong (n), FUNC_NAME);
}
#undef FUNC_NAME
SCM_DEFINE (scm_hash_table_p, "hash-table?", 1, 0, 0,
(SCM obj),
"Return @code{#t} if @var{obj} is an hash table.")
#define FUNC_NAME s_scm_hash_table_p
{
return scm_from_bool (SCM_HASHTABLE_P (obj)
#if (SCM_ENABLE_DEPRECATED == 1)
|| is_weak_key_hash_table (obj)
|| is_weak_value_hash_table (obj)
|| is_doubly_weak_hash_table (obj)
#endif
);
}
#undef FUNC_NAME
/* Accessing hash table entries. */
SCM
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"
{
unsigned long k;
SCM buckets, h;
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 (FUNC_NAME, scm_from_ulong (k));
h = assoc_fn (obj, SCM_SIMPLE_VECTOR_REF (buckets, k), closure);
return h;
}
#undef FUNC_NAME
SCM
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"
{
unsigned long k;
SCM buckets, it;
SCM_VALIDATE_HASHTABLE (SCM_ARG1, table);
buckets = SCM_HASHTABLE_VECTOR (table);
if (SCM_SIMPLE_VECTOR_LENGTH (buckets) == 0)
SCM_MISC_ERROR ("void hashtable", 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_create_handle_x", scm_from_ulong (k));
it = assoc_fn (obj, SCM_SIMPLE_VECTOR_REF (buckets, k), closure);
if (scm_is_pair (it))
return it;
else if (scm_is_true (it))
scm_wrong_type_arg_msg (NULL, 0, it, "a pair");
else
{
SCM handle, new_bucket;
handle = scm_cons (obj, init);
new_bucket = scm_cons (handle, SCM_EOL);
if (!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);
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,
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 SCM_CDR (it);
else
return dflt;
}
SCM
scm_hash_fn_set_x (SCM table, SCM obj, SCM val,
scm_t_hash_fn hash_fn, scm_t_assoc_fn assoc_fn,
void *closure)
{
SCM pair;
pair = scm_hash_fn_create_handle_x (table, obj, val,
hash_fn, assoc_fn, closure);
if (!scm_is_eq (SCM_CDR (pair), val))
SCM_SETCDR (pair, val);
return val;
}
SCM
scm_hash_fn_remove_x (SCM table, SCM obj,
scm_t_hash_fn hash_fn,
scm_t_assoc_fn assoc_fn,
void *closure)
#define FUNC_NAME "hash_fn_remove_x"
{
unsigned long k;
SCM buckets, h;
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 (FUNC_NAME, scm_from_ulong (k));
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)));
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_ENABLE_DEPRECATED == 1)
if (!SCM_HASHTABLE_P (table))
{
if (is_weak_key_hash_table (table))
return weak_key_hash_table_clear_x (table);
if (is_weak_value_hash_table (table))
return weak_value_hash_table_clear_x (table);
if (is_doubly_weak_hash_table (table))
return doubly_weak_hash_table_clear_x (table);
}
#endif
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
SCM_DEFINE (scm_hashq_get_handle, "hashq-get-handle", 2, 0, 0,
(SCM table, SCM key),
"This procedure returns the @code{(key . value)} pair from the\n"
"hash table @var{table}. If @var{table} does not hold an\n"
"associated value for @var{key}, @code{#f} is returned.\n"
"Uses @code{eq?} for equality testing.")
#define FUNC_NAME s_scm_hashq_get_handle
{
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
SCM_DEFINE (scm_hashq_create_handle_x, "hashq-create-handle!", 3, 0, 0,
(SCM table, SCM key, SCM init),
"This function looks up @var{key} in @var{table} and returns its handle.\n"
"If @var{key} is not already present, a new handle is created which\n"
"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_t_hash_fn) scm_ihashq,
(scm_t_assoc_fn) scm_sloppy_assq,
0);
}
#undef FUNC_NAME
SCM_DEFINE (scm_hashq_ref, "hashq-ref", 2, 1, 0,
(SCM table, SCM key, SCM dflt),
"Look up @var{key} in the hash table @var{table}, and return the\n"
"value (if any) associated with it. If @var{key} is not found,\n"
"return @var{dflt} (or @code{#f} if no @var{dflt} argument\n"
"is supplied). Uses @code{eq?} for equality testing.")
#define FUNC_NAME s_scm_hashq_ref
{
if (SCM_UNBNDP (dflt))
dflt = SCM_BOOL_F;
#if (SCM_ENABLE_DEPRECATED == 1)
if (!SCM_HASHTABLE_P (table))
{
if (is_weak_key_hash_table (table))
return weak_key_hash_table_ref (table, key, dflt);
if (is_weak_value_hash_table (table))
return weak_value_hash_table_ref (table, key, dflt);
if (is_doubly_weak_hash_table (table))
return doubly_weak_hash_table_ref (table, key, dflt);
}
#endif
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{val} there. Uses @code{eq?} for equality testing.")
#define FUNC_NAME s_scm_hashq_set_x
{
#if (SCM_ENABLE_DEPRECATED == 1)
if (!SCM_HASHTABLE_P (table))
{
if (is_weak_key_hash_table (table))
return weak_key_hash_table_set_x (table, key, val);
if (is_weak_value_hash_table (table))
return weak_value_hash_table_set_x (table, key, val);
if (is_doubly_weak_hash_table (table))
return doubly_weak_hash_table_set_x (table, key, val);
}
#endif
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
SCM_DEFINE (scm_hashq_remove_x, "hashq-remove!", 2, 0, 0,
(SCM table, SCM key),
"Remove @var{key} (and any value associated with it) from\n"
"@var{table}. Uses @code{eq?} for equality tests.")
#define FUNC_NAME s_scm_hashq_remove_x
{
#if (SCM_ENABLE_DEPRECATED == 1)
if (!SCM_HASHTABLE_P (table))
{
if (is_weak_key_hash_table (table))
return weak_key_hash_table_remove_x (table, key);
if (is_weak_value_hash_table (table))
return weak_value_hash_table_remove_x (table, key);
if (is_doubly_weak_hash_table (table))
return doubly_weak_hash_table_remove_x (table, key);
}
#endif
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
SCM_DEFINE (scm_hashv_get_handle, "hashv-get-handle", 2, 0, 0,
(SCM table, SCM key),
"This procedure returns the @code{(key . value)} pair from the\n"
"hash table @var{table}. If @var{table} does not hold an\n"
"associated value for @var{key}, @code{#f} is returned.\n"
"Uses @code{eqv?} for equality testing.")
#define FUNC_NAME s_scm_hashv_get_handle
{
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
SCM_DEFINE (scm_hashv_create_handle_x, "hashv-create-handle!", 3, 0, 0,
(SCM table, SCM key, SCM init),
"This function looks up @var{key} in @var{table} and returns its handle.\n"
"If @var{key} is not already present, a new handle is created which\n"
"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_t_hash_fn) scm_ihashv,
(scm_t_assoc_fn) scm_sloppy_assv,
0);
}
#undef FUNC_NAME
SCM_DEFINE (scm_hashv_ref, "hashv-ref", 2, 1, 0,
(SCM table, SCM key, SCM dflt),
"Look up @var{key} in the hash table @var{table}, and return the\n"
"value (if any) associated with it. If @var{key} is not found,\n"
"return @var{dflt} (or @code{#f} if no @var{dflt} argument\n"
"is supplied). Uses @code{eqv?} for equality testing.")
#define FUNC_NAME s_scm_hashv_ref
{
if (SCM_UNBNDP (dflt))
dflt = SCM_BOOL_F;
#if (SCM_ENABLE_DEPRECATED == 1)
if (!SCM_HASHTABLE_P (table))
{
if (is_weak_key_hash_table (table))
return weak_key_hash_table_ref (table, key, dflt);
if (is_weak_value_hash_table (table))
return weak_value_hash_table_ref (table, key, dflt);
if (is_doubly_weak_hash_table (table))
return doubly_weak_hash_table_ref (table, key, dflt);
}
#endif
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
SCM_DEFINE (scm_hashv_set_x, "hashv-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{eqv?} for equality testing.")
#define FUNC_NAME s_scm_hashv_set_x
{
#if (SCM_ENABLE_DEPRECATED == 1)
if (!SCM_HASHTABLE_P (table))
{
if (is_weak_key_hash_table (table))
return weak_key_hash_table_set_x (table, key, val);
if (is_weak_value_hash_table (table))
return weak_value_hash_table_set_x (table, key, val);
if (is_doubly_weak_hash_table (table))
return doubly_weak_hash_table_set_x (table, key, val);
}
#endif
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
SCM_DEFINE (scm_hashv_remove_x, "hashv-remove!", 2, 0, 0,
(SCM table, SCM key),
"Remove @var{key} (and any value associated with it) from\n"
"@var{table}. Uses @code{eqv?} for equality tests.")
#define FUNC_NAME s_scm_hashv_remove_x
{
#if (SCM_ENABLE_DEPRECATED == 1)
if (!SCM_HASHTABLE_P (table))
{
if (is_weak_key_hash_table (table))
return weak_key_hash_table_remove_x (table, key);
if (is_weak_value_hash_table (table))
return weak_value_hash_table_remove_x (table, key);
if (is_doubly_weak_hash_table (table))
return doubly_weak_hash_table_remove_x (table, key);
}
#endif
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
SCM_DEFINE (scm_hash_get_handle, "hash-get-handle", 2, 0, 0,
(SCM table, SCM key),
"This procedure returns the @code{(key . value)} pair from the\n"
"hash table @var{table}. If @var{table} does not hold an\n"
"associated value for @var{key}, @code{#f} is returned.\n"
"Uses @code{equal?} for equality testing.")
#define FUNC_NAME s_scm_hash_get_handle
{
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
SCM_DEFINE (scm_hash_create_handle_x, "hash-create-handle!", 3, 0, 0,
(SCM table, SCM key, SCM init),
"This function looks up @var{key} in @var{table} and returns its handle.\n"
"If @var{key} is not already present, a new handle is created which\n"
"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_t_hash_fn) scm_ihash,
(scm_t_assoc_fn) scm_sloppy_assoc,
0);
}
#undef FUNC_NAME
SCM_DEFINE (scm_hash_ref, "hash-ref", 2, 1, 0,
(SCM table, SCM key, SCM dflt),
"Look up @var{key} in the hash table @var{table}, and return the\n"
"value (if any) associated with it. If @var{key} is not found,\n"
"return @var{dflt} (or @code{#f} if no @var{dflt} argument\n"
"is supplied). Uses @code{equal?} for equality testing.")
#define FUNC_NAME s_scm_hash_ref
{
if (SCM_UNBNDP (dflt))
dflt = SCM_BOOL_F;
#if (SCM_ENABLE_DEPRECATED == 1)
if (!SCM_HASHTABLE_P (table))
{
if (is_weak_key_hash_table (table))
return weak_key_hash_table_ref (table, key, dflt);
if (is_weak_value_hash_table (table))
return weak_value_hash_table_ref (table, key, dflt);
if (is_doubly_weak_hash_table (table))
return doubly_weak_hash_table_ref (table, key, dflt);
}
#endif
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{val} there. Uses @code{equal?} for equality\n"
"testing.")
#define FUNC_NAME s_scm_hash_set_x
{
#if (SCM_ENABLE_DEPRECATED == 1)
if (!SCM_HASHTABLE_P (table))
{
if (is_weak_key_hash_table (table))
return weak_key_hash_table_set_x (table, key, val);
if (is_weak_value_hash_table (table))
return weak_value_hash_table_set_x (table, key, val);
if (is_doubly_weak_hash_table (table))
return doubly_weak_hash_table_set_x (table, key, val);
}
#endif
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
SCM_DEFINE (scm_hash_remove_x, "hash-remove!", 2, 0, 0,
(SCM table, SCM key),
"Remove @var{key} (and any value associated with it) from\n"
"@var{table}. Uses @code{equal?} for equality tests.")
#define FUNC_NAME s_scm_hash_remove_x
{
#if (SCM_ENABLE_DEPRECATED == 1)
if (!SCM_HASHTABLE_P (table))
{
if (is_weak_key_hash_table (table))
return weak_key_hash_table_remove_x (table, key);
if (is_weak_value_hash_table (table))
return weak_value_hash_table_remove_x (table, key);
if (is_doubly_weak_hash_table (table))
return doubly_weak_hash_table_remove_x (table, key);
}
#endif
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
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)
{
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, void *arg)
{
scm_t_ihashx_closure *closure = (scm_t_ihashx_closure *) arg;
return scm_call_2 (closure->assoc, obj, alist);
}
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"
"@code{-get-handle} function, but uses @var{hash} as a hash\n"
"function and @var{assoc} to compare keys. @code{hash} must be\n"
"a function that takes two arguments, a key to be hashed and a\n"
"table size. @code{assoc} must be an associator function, like\n"
"@code{assoc}, @code{assq} or @code{assv}.")
#define FUNC_NAME s_scm_hashx_get_handle
{
scm_t_ihashx_closure closure;
closure.hash = hash;
closure.assoc = assoc;
closure.key = key;
return scm_hash_fn_get_handle (table, key, scm_ihashx, scm_sloppy_assx,
(void *) &closure);
}
#undef FUNC_NAME
SCM_DEFINE (scm_hashx_create_handle_x, "hashx-create-handle!", 5, 0, 0,
(SCM hash, SCM assoc, SCM table, SCM key, SCM init),
"This behaves the same way as the corresponding\n"
"@code{-create-handle} function, but uses @var{hash} as a hash\n"
"function and @var{assoc} to compare keys. @code{hash} must be\n"
"a function that takes two arguments, a key to be hashed and a\n"
"table size. @code{assoc} must be an associator function, like\n"
"@code{assoc}, @code{assq} or @code{assv}.")
#define FUNC_NAME s_scm_hashx_create_handle_x
{
scm_t_ihashx_closure closure;
closure.hash = hash;
closure.assoc = assoc;
closure.key = key;
return scm_hash_fn_create_handle_x (table, key, init, scm_ihashx,
scm_sloppy_assx, (void *)&closure);
}
#undef FUNC_NAME
SCM_DEFINE (scm_hashx_ref, "hashx-ref", 4, 1, 0,
(SCM hash, SCM assoc, SCM table, SCM key, SCM dflt),
"This behaves the same way as the corresponding @code{ref}\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-ref table key} is\n"
"equivalent to @code{hashx-ref hashq assq table key}.")
#define FUNC_NAME s_scm_hashx_ref
{
scm_t_ihashx_closure closure;
if (SCM_UNBNDP (dflt))
dflt = SCM_BOOL_F;
closure.hash = hash;
closure.assoc = assoc;
closure.key = key;
#if (SCM_ENABLE_DEPRECATED == 1)
if (!SCM_HASHTABLE_P (table))
{
if (is_weak_key_hash_table (table))
return weak_key_hash_table_ref (table, key, dflt);
if (is_weak_value_hash_table (table))
return weak_value_hash_table_ref (table, key, dflt);
if (is_doubly_weak_hash_table (table))
return doubly_weak_hash_table_ref (table, key, dflt);
}
#endif
return scm_hash_fn_ref (table, key, dflt, scm_ihashx, scm_sloppy_assx,
(void *)&closure);
}
#undef FUNC_NAME
SCM_DEFINE (scm_hashx_set_x, "hashx-set!", 5, 0, 0,
(SCM hash, SCM assoc, SCM table, SCM key, SCM val),
"This behaves the same way as the corresponding @code{set!}\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-set! table key} is\n"
"equivalent to @code{hashx-set! hashq assq table key}.")
#define FUNC_NAME s_scm_hashx_set_x
{
scm_t_ihashx_closure closure;
closure.hash = hash;
closure.assoc = assoc;
closure.key = key;
#if (SCM_ENABLE_DEPRECATED == 1)
if (!SCM_HASHTABLE_P (table))
{
if (is_weak_key_hash_table (table))
return weak_key_hash_table_set_x (table, key, val);
if (is_weak_value_hash_table (table))
return weak_value_hash_table_set_x (table, key, val);
if (is_doubly_weak_hash_table (table))
return doubly_weak_hash_table_set_x (table, key, val);
}
#endif
return scm_hash_fn_set_x (table, key, val, scm_ihashx, scm_sloppy_assx,
(void *)&closure);
}
#undef FUNC_NAME
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.key = obj;
#if (SCM_ENABLE_DEPRECATED == 1)
if (!SCM_HASHTABLE_P (table))
{
if (is_weak_key_hash_table (table))
return weak_key_hash_table_remove_x (table, obj);
if (is_weak_value_hash_table (table))
return weak_value_hash_table_remove_x (table, obj);
if (is_doubly_weak_hash_table (table))
return doubly_weak_hash_table_remove_x (table, obj);
}
#endif
return scm_hash_fn_remove_x (table, obj, scm_ihashx, scm_sloppy_assx,
(void *) &closure);
}
#undef FUNC_NAME
/* Hash table iterators */
SCM_DEFINE (scm_hash_fold, "hash-fold", 3, 0, 0,
(SCM proc, SCM init, SCM table),
"An iterator over hash-table elements.\n"
"Accumulates and returns a result by applying PROC successively.\n"
"The arguments to PROC are \"(key value prior-result)\" where key\n"
"and value are successive pairs from the hash table TABLE, and\n"
"prior-result is either INIT (for the first application of PROC)\n"
"or the return value of the previous application of PROC.\n"
"For example, @code{(hash-fold acons '() tab)} will convert a hash\n"
"table into an a-list of key-value pairs.")
#define FUNC_NAME s_scm_hash_fold
{
SCM_VALIDATE_PROC (1, proc);
#if (SCM_ENABLE_DEPRECATED == 1)
if (!SCM_HASHTABLE_P (table))
{
if (is_weak_key_hash_table (table))
return weak_key_hash_table_fold (proc, init, table);
if (is_weak_value_hash_table (table))
return weak_value_hash_table_fold (proc, init, table);
if (is_doubly_weak_hash_table (table))
return doubly_weak_hash_table_fold (proc, init, table);
}
#endif
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
static SCM
for_each_proc (void *proc, SCM handle)
{
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_ENABLE_DEPRECATED == 1)
if (!SCM_HASHTABLE_P (table))
{
if (is_weak_key_hash_table (table))
return weak_key_hash_table_for_each (proc, table);
if (is_weak_value_hash_table (table))
return weak_value_hash_table_for_each (proc, table);
if (is_doubly_weak_hash_table (table))
return doubly_weak_hash_table_for_each (proc, table);
}
#endif
SCM_VALIDATE_HASHTABLE (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_ASSERT (scm_is_true (scm_procedure_p (proc)), proc, 1, FUNC_NAME);
SCM_VALIDATE_HASHTABLE (2, table);
scm_internal_hash_for_each_handle ((scm_t_hash_handle_fn) scm_call_1,
(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_ENABLE_DEPRECATED == 1)
if (!SCM_HASHTABLE_P (table))
{
if (is_weak_key_hash_table (table))
return weak_key_hash_table_map_to_list (proc, table);
if (is_weak_value_hash_table (table))
return weak_value_hash_table_map_to_list (proc, table);
if (is_doubly_weak_hash_table (table))
return doubly_weak_hash_table_map_to_list (proc, table);
}
#endif
SCM_VALIDATE_HASHTABLE (2, table);
return scm_internal_hash_fold (map_proc,
(void *) SCM_UNPACK (proc),
SCM_EOL,
table);
}
#undef FUNC_NAME
static SCM
count_proc (void *pred, SCM key, SCM data, SCM value)
{
if (scm_is_false (scm_call_2 (SCM_PACK (pred), key, data)))
return value;
else
return scm_oneplus(value);
}
SCM_DEFINE (scm_hash_count, "hash-count", 2, 0, 0,
(SCM pred, SCM table),
"Return the number of elements in the given hash TABLE that\n"
"cause `(PRED KEY VALUE)' to return true. To quickly determine\n"
"the total number of elements, use `(const #t)' for PRED.")
#define FUNC_NAME s_scm_hash_count
{
SCM init;
SCM_VALIDATE_PROC (1, pred);
SCM_VALIDATE_HASHTABLE (2, table);
init = scm_from_int (0);
return scm_internal_hash_fold ((scm_t_hash_fold_fn) count_proc,
(void *) SCM_UNPACK (pred), init, table);
}
#undef FUNC_NAME
SCM
scm_internal_hash_fold (scm_t_hash_fold_fn fn, void *closure,
SCM init, SCM table)
#define FUNC_NAME s_scm_hash_fold
{
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;
for (ls = SCM_SIMPLE_VECTOR_REF (buckets, i); !scm_is_null (ls);
ls = SCM_CDR (ls))
{
handle = SCM_CAR (ls);
result = fn (closure, SCM_CAR (handle), SCM_CDR (handle), result);
}
}
return result;
}
#undef FUNC_NAME
/* 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
void
scm_init_hashtab ()
{
#include "hashtab.x"
}