mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-08 21:20:19 +02:00
Code Activity

Move weak table implementation to Scheme

Browse source 
* libguile/weak-table.c:
* libguile/weak-table.h: Remove.

* libguile.h: Remove weak-table.h include.
* libguile/Makefile.am (libguile_@GUILE_EFFECTIVE_VERSION@_la_SOURCES):
(DOT_X_FILES):
(DOT_DOC_FILES):
(modinclude_HEADERS): Remove weak-table.[ch].

* libguile/evalext.c:
* libguile/fluids.c:
* libguile/hash.c:
* libguile/init.c:
* libguile/print.c:
* libguile/scm.h: Remove uses of weak-table.h and free up the tc7.

* libguile/hashtab.c:
* libguile/hashtab.h: Add deprecated shims to dispatch to (ice-9
weak-tables) when working on weak tables.

* module/ice-9/weak-tables.scm: New implementation.  Embeds the hash and
equality functions in the table itself.

* module/ice-9/object-properties.scm:
* module/ice-9/poe.scm:
* module/ice-9/popen.scm:
* module/ice-9/source-properties.scm:
* module/language/cps/compile-bytecode.scm:
* module/language/ecmascript/array.scm:
* module/language/ecmascript/function.scm:
* module/oop/goops/save.scm:
* module/srfi/srfi-18.scm:
* module/srfi/srfi-69.scm:
* module/system/base/types.scm:
* module/system/base/types/internal.scm:
* module/system/foreign.scm:
* module/system/vm/assembler.scm:
* test-suite/tests/gc.test:
* test-suite/tests/hash.test:
* test-suite/tests/srfi-69.test:
* test-suite/tests/types.test:
* test-suite/tests/weaks.test: Update to use new, non-deprecated weak
tables API.
This commit is contained in:
Andy Wingo 2025-05-13 14:57:31 +02:00
parent d457aaa57d
commit 8280c8485f
32 changed files with 1092 additions and 1167 deletions
Download patch file Download diff file Expand all files Collapse all files

1
libguile.h
View file

@ -114,7 +114,6 @@ extern "C" {
#include "libguile/vm.h"
#include "libguile/vports.h"
#include "libguile/weak-set.h"
#include "libguile/weak-table.h"
#include "libguile/backtrace.h"
#include "libguile/debug.h"
#include "libguile/stacks.h"

12
libguile/Makefile.am
View file

@ -237,8 +237,7 @@ libguile_@GUILE_EFFECTIVE_VERSION@_la_SOURCES = \
version.c \
vm.c \
vports.c \
weak-set.c \
weak-table.c
weak-set.c
if ENABLE_JIT
libguile_@GUILE_EFFECTIVE_VERSION@_la_SOURCES += $(lightening_c_files)
@ -347,8 +346,7 @@ DOT_X_FILES = \
vectors.x \
version.x \
vm.x \
weak-set.x \
weak-table.x
weak-set.x
EXTRA_DOT_X_FILES = @EXTRA_DOT_X_FILES@
@ -445,8 +443,7 @@ DOT_DOC_FILES = \
vectors.doc \
version.doc \
vports.doc \
weak-set.doc \
weak-table.doc
weak-set.doc
EXTRA_DOT_DOC_FILES = @EXTRA_DOT_DOC_FILES@
@ -706,8 +703,7 @@ modinclude_HEADERS = \
vm-expand.h \
vm.h \
vports.h \
weak-set.h \
weak-table.h
weak-set.h
nodist_modinclude_HEADERS = version.h scmconfig.h

1
libguile/evalext.c
View file

@ -80,7 +80,6 @@ SCM_DEFINE (scm_self_evaluating_p, "self-evaluating?", 1, 0, 0,
case scm_tc7_pointer:
case scm_tc7_hashtable:
case scm_tc7_weak_set:
case scm_tc7_weak_table:
case scm_tc7_fluid:
case scm_tc7_dynamic_state:
case scm_tc7_frame:

1
libguile/fluids.c
View file

@ -40,7 +40,6 @@
#include "print.h"
#include "threads.h"
#include "variable.h"
#include "weak-table.h"
#include "fluids.h"

1
libguile/hash.c
View file

@ -347,7 +347,6 @@ scm_raw_ihash (SCM obj, size_t depth)
case scm_tc7_program:
case scm_tc7_vm_cont:
case scm_tc7_weak_set:
case scm_tc7_weak_table:
case scm_tc7_port:
return scm_raw_ihashq (SCM_UNPACK (obj));

683
libguile/hashtab.c
View file

@ -1,4 +1,4 @@
/* Copyright 1995-1996,1998-2001,2003-2004,2006,2008-2013,2018
/* Copyright 1995-1996,1998-2001,2003-2004,2006,2008-2013,2018,2025
Free Software Foundation, Inc.
This file is part of Guile.
@ -30,21 +30,439 @@
#include "alist.h"
#include "bdw-gc.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 "weak-table.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.
@ -199,14 +617,18 @@ SCM_DEFINE (scm_make_hash_table, "make-hash-table", 0, 1, 0,
}
#undef FUNC_NAME
#define SCM_WEAK_TABLE_P(x) (scm_is_true (scm_weak_table_p (x)))
SCM_DEFINE (scm_hash_table_p, "hash-table?", 1, 0, 0,
(SCM obj),
"Return @code{#t} if @var{obj} is an abstract hash table object.")
"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) || SCM_WEAK_TABLE_P (obj));
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
@ -361,11 +783,17 @@ SCM_DEFINE (scm_hash_clear_x, "hash-clear!", 1, 0, 0,
"Remove all items from @var{table} (without triggering a resize).")
#define FUNC_NAME s_scm_hash_clear_x
{
if (SCM_WEAK_TABLE_P (table))
#if (SCM_ENABLE_DEPRECATED == 1)
if (!SCM_HASHTABLE_P (table))
{
scm_weak_table_clear_x (table);
return SCM_UNSPECIFIED;
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);
@ -420,8 +848,17 @@ SCM_DEFINE (scm_hashq_ref, "hashq-ref", 2, 1, 0,
if (SCM_UNBNDP (dflt))
dflt = SCM_BOOL_F;
if (SCM_WEAK_TABLE_P (table))
return scm_weak_table_refq (table, key, dflt);
#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,
@ -438,11 +875,17 @@ SCM_DEFINE (scm_hashq_set_x, "hashq-set!", 3, 0, 0,
"store @var{val} there. Uses @code{eq?} for equality testing.")
#define FUNC_NAME s_scm_hashq_set_x
{
if (SCM_WEAK_TABLE_P (table))
#if (SCM_ENABLE_DEPRECATED == 1)
if (!SCM_HASHTABLE_P (table))
{
scm_weak_table_putq_x (table, key, val);
return val;
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,
@ -459,15 +902,17 @@ SCM_DEFINE (scm_hashq_remove_x, "hashq-remove!", 2, 0, 0,
"@var{table}. Uses @code{eq?} for equality tests.")
#define FUNC_NAME s_scm_hashq_remove_x
{
if (SCM_WEAK_TABLE_P (table))
#if (SCM_ENABLE_DEPRECATED == 1)
if (!SCM_HASHTABLE_P (table))
{
scm_weak_table_remq_x (table, key);
/* This return value is for historical compatibility with
hash-remove!, which returns either the "handle" corresponding
to the entry, or #f. Since weak tables don't have handles, we
have to return #f. */
return SCM_BOOL_F;
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,
@ -510,12 +955,6 @@ SCM_DEFINE (scm_hashv_create_handle_x, "hashv-create-handle!", 3, 0, 0,
#undef FUNC_NAME
static int
assv_predicate (SCM k, SCM v, void *closure)
{
return scm_is_true (scm_eqv_p (k, SCM_PACK_POINTER (closure)));
}
SCM_DEFINE (scm_hashv_ref, "hashv-ref", 2, 1, 0,
(SCM table, SCM key, SCM dflt),
"Look up @var{key} in the hash table @var{table}, and return the\n"
@ -527,10 +966,17 @@ SCM_DEFINE (scm_hashv_ref, "hashv-ref", 2, 1, 0,
if (SCM_UNBNDP (dflt))
dflt = SCM_BOOL_F;
if (SCM_WEAK_TABLE_P (table))
return scm_c_weak_table_ref (table, scm_ihashv (key, -1),
assv_predicate,
(void *) SCM_UNPACK (key), dflt);
#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,
@ -547,13 +993,17 @@ SCM_DEFINE (scm_hashv_set_x, "hashv-set!", 3, 0, 0,
"store @var{value} there. Uses @code{eqv?} for equality testing.")
#define FUNC_NAME s_scm_hashv_set_x
{
if (SCM_WEAK_TABLE_P (table))
#if (SCM_ENABLE_DEPRECATED == 1)
if (!SCM_HASHTABLE_P (table))
{
scm_c_weak_table_put_x (table, scm_ihashv (key, -1),
assv_predicate, (void *) SCM_UNPACK (key),
key, val);
return val;
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,
@ -569,13 +1019,17 @@ SCM_DEFINE (scm_hashv_remove_x, "hashv-remove!", 2, 0, 0,
"@var{table}. Uses @code{eqv?} for equality tests.")
#define FUNC_NAME s_scm_hashv_remove_x
{
if (SCM_WEAK_TABLE_P (table))
#if (SCM_ENABLE_DEPRECATED == 1)
if (!SCM_HASHTABLE_P (table))
{
scm_c_weak_table_remove_x (table, scm_ihashv (key, -1),
assv_predicate, (void *) SCM_UNPACK (key));
/* See note in hashq-remove!. */
return SCM_BOOL_F;
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,
@ -617,12 +1071,6 @@ SCM_DEFINE (scm_hash_create_handle_x, "hash-create-handle!", 3, 0, 0,
#undef FUNC_NAME
static int
assoc_predicate (SCM k, SCM v, void *closure)
{
return scm_is_true (scm_equal_p (k, SCM_PACK_POINTER (closure)));
}
SCM_DEFINE (scm_hash_ref, "hash-ref", 2, 1, 0,
(SCM table, SCM key, SCM dflt),
"Look up @var{key} in the hash table @var{table}, and return the\n"
@ -634,10 +1082,17 @@ SCM_DEFINE (scm_hash_ref, "hash-ref", 2, 1, 0,
if (SCM_UNBNDP (dflt))
dflt = SCM_BOOL_F;
if (SCM_WEAK_TABLE_P (table))
return scm_c_weak_table_ref (table, scm_ihash (key, -1),
assoc_predicate,
(void *) SCM_UNPACK (key), dflt);
#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,
@ -655,13 +1110,17 @@ SCM_DEFINE (scm_hash_set_x, "hash-set!", 3, 0, 0,
"testing.")
#define FUNC_NAME s_scm_hash_set_x
{
if (SCM_WEAK_TABLE_P (table))
#if (SCM_ENABLE_DEPRECATED == 1)
if (!SCM_HASHTABLE_P (table))
{
scm_c_weak_table_put_x (table, scm_ihash (key, -1),
assoc_predicate, (void *) SCM_UNPACK (key),
key, val);
return val;
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,
@ -678,13 +1137,17 @@ SCM_DEFINE (scm_hash_remove_x, "hash-remove!", 2, 0, 0,
"@var{table}. Uses @code{equal?} for equality tests.")
#define FUNC_NAME s_scm_hash_remove_x
{
if (SCM_WEAK_TABLE_P (table))
#if (SCM_ENABLE_DEPRECATED == 1)
if (!SCM_HASHTABLE_P (table))
{
scm_c_weak_table_remove_x (table, scm_ihash (key, -1),
assoc_predicate, (void *) SCM_UNPACK (key));
/* See note in hashq-remove!. */
return SCM_BOOL_F;
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,
@ -719,21 +1182,6 @@ scm_sloppy_assx (SCM obj, SCM alist, void *arg)
return scm_call_2 (closure->assoc, obj, alist);
}
static int
assx_predicate (SCM k, SCM v, void *closure)
{
scm_t_ihashx_closure *c = (scm_t_ihashx_closure *) closure;
/* FIXME: The hashx interface is crazy. Hash tables have nothing to
do with alists in principle. Instead of getting an assoc proc,
hashx functions should use an equality predicate. Perhaps we can
change this before 2.2, but until then, add a terrible, terrible
hack. */
return scm_is_true (scm_call_2 (c->assoc, c->key, scm_acons (k, v, SCM_EOL)));
}
SCM_DEFINE (scm_hashx_get_handle, "hashx-get-handle", 4, 0, 0,
(SCM hash, SCM assoc, SCM table, SCM key),
"This behaves the same way as the corresponding\n"
@ -797,12 +1245,17 @@ SCM_DEFINE (scm_hashx_ref, "hashx-ref", 4, 1, 0,
closure.assoc = assoc;
closure.key = key;
if (SCM_WEAK_TABLE_P (table))
#if (SCM_ENABLE_DEPRECATED == 1)
if (!SCM_HASHTABLE_P (table))
{
unsigned long h = scm_to_ulong (scm_call_2 (hash, key,
scm_from_ulong (-1)));
return scm_c_weak_table_ref (table, h, assx_predicate, &closure, dflt);
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);
@ -830,13 +1283,17 @@ SCM_DEFINE (scm_hashx_set_x, "hashx-set!", 5, 0, 0,
closure.assoc = assoc;
closure.key = key;
if (SCM_WEAK_TABLE_P (table))
#if (SCM_ENABLE_DEPRECATED == 1)
if (!SCM_HASHTABLE_P (table))
{
unsigned long h = scm_to_ulong (scm_call_2 (hash, key,
scm_from_ulong (-1)));
scm_c_weak_table_put_x (table, h, assx_predicate, &closure, key, val);
return val;
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);
@ -861,14 +1318,17 @@ SCM_DEFINE (scm_hashx_remove_x, "hashx-remove!", 4, 0, 0,
closure.assoc = assoc;
closure.key = obj;
if (SCM_WEAK_TABLE_P (table))
#if (SCM_ENABLE_DEPRECATED == 1)
if (!SCM_HASHTABLE_P (table))
{
unsigned long h = scm_to_ulong (scm_call_2 (hash, obj,
scm_from_ulong (-1)));
scm_c_weak_table_remove_x (table, h, assx_predicate, &closure);
/* See note in hashq-remove!. */
return SCM_BOOL_F;
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);
@ -891,8 +1351,17 @@ SCM_DEFINE (scm_hash_fold, "hash-fold", 3, 0, 0,
{
SCM_VALIDATE_PROC (1, proc);
if (SCM_WEAK_TABLE_P (table))
return scm_weak_table_fold (proc, init, table);
#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,
@ -916,11 +1385,17 @@ SCM_DEFINE (scm_hash_for_each, "hash-for-each", 2, 0, 0,
{
SCM_VALIDATE_PROC (1, proc);
if (SCM_WEAK_TABLE_P (table))
#if (SCM_ENABLE_DEPRECATED == 1)
if (!SCM_HASHTABLE_P (table))
{
scm_weak_table_for_each (proc, table);
return SCM_UNSPECIFIED;
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);
@ -963,8 +1438,17 @@ SCM_DEFINE (scm_hash_map_to_list, "hash-map->list", 2, 0, 0,
{
SCM_VALIDATE_PROC (1, proc);
if (SCM_WEAK_TABLE_P (table))
return scm_weak_table_map_to_list (proc, table);
#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,
@ -1011,9 +1495,6 @@ scm_internal_hash_fold (scm_t_hash_fold_fn fn, void *closure,
long i, n;
SCM buckets, result = init;
if (SCM_WEAK_TABLE_P (table))
return scm_c_weak_table_fold (fn, closure, init, table);
SCM_VALIDATE_HASHTABLE (0, table);
buckets = SCM_HASHTABLE_VECTOR (table);

11
libguile/hashtab.h
View file

@ -1,7 +1,7 @@
#ifndef SCM_HASHTAB_H
#define SCM_HASHTAB_H
/* Copyright 1995-1996,1999-2001,2003-2004,2006,2008-2009,2011,2018
/* Copyright 1995-1996,1999-2001,2003-2004,2006,2008-2009,2011,2018,2025
Free Software Foundation, Inc.
This file is part of Guile.
@ -137,4 +137,13 @@ SCM_API SCM scm_hash_count (SCM hash, SCM pred);
SCM_INTERNAL void scm_i_hashtable_print (SCM exp, SCM port, scm_print_state *pstate);
SCM_INTERNAL void scm_init_hashtab (void);
#if (SCM_ENABLE_DEPRECATED == 1)
SCM_DEPRECATED SCM scm_make_weak_key_hash_table (SCM k);
SCM_DEPRECATED SCM scm_make_weak_value_hash_table (SCM k);
SCM_DEPRECATED SCM scm_make_doubly_weak_hash_table (SCM k);
SCM_DEPRECATED SCM scm_weak_key_hash_table_p (SCM h);
SCM_DEPRECATED SCM scm_weak_value_hash_table_p (SCM h);
SCM_DEPRECATED SCM scm_doubly_weak_hash_table_p (SCM h);
#endif
#endif /* SCM_HASHTAB_H */

4
libguile/init.c
View file

@ -146,7 +146,6 @@
#include "version.h"
#include "vm.h"
#include "weak-set.h"
#include "weak-table.h"
#include "init.h"
@ -354,8 +353,7 @@ scm_i_init_guile (struct gc_stack_addr base)
struct gc_mutator *mut = scm_storage_prehistory (base);
scm_threads_prehistory (mut, base); /* requires storage_prehistory */
scm_weak_table_prehistory (); /* requires storage_prehistory */
scm_symbols_prehistory (); /* requires weak_table_prehistory */
scm_symbols_prehistory ();
scm_modules_prehistory ();
scm_init_array_handle ();
scm_bootstrap_bytevectors (); /* Requires array-handle */

4
libguile/print.c
View file

@ -69,7 +69,6 @@
#include "vectors.h"
#include "vm.h"
#include "weak-set.h"
#include "weak-table.h"
#include "print.h"
@ -725,9 +724,6 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate)
case scm_tc7_weak_set:
scm_i_weak_set_print (exp, port, pstate);
break;
case scm_tc7_weak_table:
scm_i_weak_table_print (exp, port, pstate);
break;
case scm_tc7_fluid:
scm_i_fluid_print (exp, port, pstate);
break;

2
libguile/scm.h
View file

@ -495,7 +495,7 @@ typedef uintptr_t scm_t_bits;
#define scm_tc7_bytevector 0x4d
#define scm_tc7_thread 0x4f
#define scm_tc7_weak_set 0x55
#define scm_tc7_weak_table 0x57
#define scm_tc7_unused_57 0x57
#define scm_tc7_array 0x5d
#define scm_tc7_bitvector 0x5f
#define scm_tc7_finalizer 0x65

807
libguile/weak-table.c
View file

@ -1,807 +0,0 @@
/* Copyright 2011-2014,2017-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
<https://www.gnu.org/licenses/>. */
#ifdef HAVE_CONFIG_H
# include <config.h>
#endif
#include <assert.h>
#include "alist.h"
#include "bdw-gc.h"
#include "eval.h"
#include "extensions.h"
#include "finalizers.h"
#include "gsubr.h"
#include "hash.h"
#include "numbers.h"
#include "pairs.h"
#include "ports.h"
#include "procs.h"
#include "threads.h"
#include "version.h"
#include "weak-table.h"
#include <gc/gc_typed.h>
/* Weak Tables
This file implements weak hash tables. Weak hash tables are
generally used when you want to augment some object with additional
data, but when you don't have space to store the data in the object.
For example, procedure properties are implemented with weak tables.
This is a normal bucket-and-chain hash table, except that the chain
entries are allocated in such a way that the GC doesn't trace the
weak values. For doubly-weak tables, this means that the entries are
allocated as an "atomic" piece of memory. Key-weak and value-weak
tables use a special GC kind with a custom mark procedure. When
items are added weakly into table, a disappearing link is registered
to their locations. If the referent is collected, then that link
will be zeroed out.
An entry in the table consists of the key and the value, together
with the hash code of the key.
Note that since the weak references are stored in an atomic region
with disappearing links, they need to be accessed with the GC alloc
lock. `read_weak_entry' will do that for you. The hash code itself
can be read outside the lock, though.
*/
typedef struct scm_weak_entry scm_t_weak_entry;
struct scm_weak_entry {
unsigned long hash;
scm_t_weak_entry *next;
scm_t_bits key;
scm_t_bits value;
};
struct weak_entry_data {
scm_t_weak_entry *entry;
scm_t_bits key;
scm_t_bits value;
};
static void*
do_read_weak_entry (void *data)
{
struct weak_entry_data *e = data;
e->key = e->entry->key;
e->value = e->entry->value;
return NULL;
}
static void
read_weak_entry (scm_t_weak_entry *entry, scm_t_bits *key, scm_t_bits *value)
{
struct weak_entry_data data;
data.entry = entry;
GC_call_with_alloc_lock (do_read_weak_entry, &data);
*key = data.key;
*value = data.value;
}
static void
register_disappearing_links (scm_t_weak_entry *entry,
SCM k, SCM v,
scm_t_weak_table_kind kind)
{
if (SCM_UNPACK (k) && SCM_HEAP_OBJECT_P (k)
&& (kind == SCM_WEAK_TABLE_KIND_KEY
|| kind == SCM_WEAK_TABLE_KIND_BOTH))
SCM_I_REGISTER_DISAPPEARING_LINK ((void **) &entry->key,
SCM2PTR (k));
if (SCM_UNPACK (v) && SCM_HEAP_OBJECT_P (v)
&& (kind == SCM_WEAK_TABLE_KIND_VALUE
|| kind == SCM_WEAK_TABLE_KIND_BOTH))
SCM_I_REGISTER_DISAPPEARING_LINK ((void **) &entry->value,
SCM2PTR (v));
}
static void
unregister_disappearing_links (scm_t_weak_entry *entry,
scm_t_weak_table_kind kind)
{
if (kind == SCM_WEAK_TABLE_KIND_KEY || kind == SCM_WEAK_TABLE_KIND_BOTH)
GC_unregister_disappearing_link ((void **) &entry->key);
if (kind == SCM_WEAK_TABLE_KIND_VALUE || kind == SCM_WEAK_TABLE_KIND_BOTH)
GC_unregister_disappearing_link ((void **) &entry->value);
}
typedef struct {
scm_t_weak_entry **buckets; /* the data */
scm_i_pthread_mutex_t lock; /* the lock */
scm_t_weak_table_kind kind; /* what kind of table it is */
unsigned long n_buckets; /* total number of buckets. */
unsigned long n_items; /* number of items in table */
unsigned long lower; /* when to shrink */
unsigned long upper; /* when to grow */
int size_index; /* index into hashtable_size */
int min_size_index; /* minimum size_index */
GC_word last_gc_no;
} scm_t_weak_table;
#define SCM_WEAK_TABLE_P(x) (SCM_HAS_TYP7 (x, scm_tc7_weak_table))
#define SCM_VALIDATE_WEAK_TABLE(pos, arg) \
SCM_MAKE_VALIDATE_MSG (pos, arg, WEAK_TABLE_P, "weak-table")
#define SCM_WEAK_TABLE(x) ((scm_t_weak_table *) SCM_CELL_WORD_1 (x))
/* GC descriptors for the various kinds of scm_t_weak_entry. */
static GC_descr weak_key_descr;
static GC_descr weak_value_descr;
static GC_descr doubly_weak_descr;
static scm_t_weak_entry *
allocate_entry (scm_t_weak_table_kind kind)
{
scm_t_weak_entry *ret;
switch (kind)
{
case SCM_WEAK_TABLE_KIND_KEY:
ret = GC_malloc_explicitly_typed (sizeof (*ret), weak_key_descr);
break;
case SCM_WEAK_TABLE_KIND_VALUE:
ret = GC_malloc_explicitly_typed (sizeof (*ret), weak_value_descr);
break;
case SCM_WEAK_TABLE_KIND_BOTH:
ret = GC_malloc_explicitly_typed (sizeof (*ret), doubly_weak_descr);
break;
default:
abort ();
}
return ret;
}
static void
add_entry (scm_t_weak_table *table, scm_t_weak_entry *entry)
{
unsigned long bucket = entry->hash % table->n_buckets;
entry->next = table->buckets[bucket];
table->buckets[bucket] = entry;
table->n_items++;
}
/* Growing or shrinking 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, 28762081,
57524111, 115048217, 230096423
};
#define HASHTABLE_SIZE_N (sizeof(hashtable_size)/sizeof(unsigned long))
static void
resize_table (scm_t_weak_table *table)
{
scm_t_weak_entry **old_buckets, **new_buckets;
int new_size_index;
unsigned long old_n_buckets, new_n_buckets, old_k;
new_size_index = table->size_index;
if (table->n_items < table->lower)
{
/* Rehashing is not triggered when i <= min_size. */
do
new_size_index -= 1;
while (new_size_index > table->min_size_index
&& table->n_items < hashtable_size[new_size_index] / 4);
}
else if (table->n_items > table->upper)
{
new_size_index += 1;
if (new_size_index >= HASHTABLE_SIZE_N)
/* Limit max bucket count. */
return;
}
else
/* Nothing to do. */
return;
new_n_buckets = hashtable_size[new_size_index];
new_buckets = scm_gc_malloc (sizeof (*new_buckets) * new_n_buckets,
"weak table buckets");
old_buckets = table->buckets;
old_n_buckets = table->n_buckets;
table->size_index = new_size_index;
table->n_buckets = new_n_buckets;
if (new_size_index <= table->min_size_index)
table->lower = 0;
else
table->lower = new_n_buckets / 4;
table->upper = 9 * new_n_buckets / 10;
table->n_items = 0;
table->buckets = new_buckets;
for (old_k = 0; old_k < old_n_buckets; old_k++)
{
scm_t_weak_entry *entry = old_buckets[old_k];
while (entry)
{
scm_t_weak_entry *next = entry->next;
entry->next = NULL;
add_entry (table, entry);
entry = next;
}
}
}
/* Run after GC via do_vacuum_weak_table, this function runs over the
whole table, removing lost weak references, reshuffling the table as it
goes. It might resize the table if it reaps enough buckets. */
static void
vacuum_weak_table (scm_t_weak_table *table)
{
GC_word gc_no = GC_get_gc_no ();
unsigned long k;
if (gc_no == table->last_gc_no)
return;
table->last_gc_no = gc_no;
for (k = 0; k < table->n_buckets; k++)
{
scm_t_weak_entry **loc = table->buckets + k;
scm_t_weak_entry *entry;
for (entry = *loc; entry; entry = *loc)
{
scm_t_bits key, value;
read_weak_entry (entry, &key, &value);
if (!key || !value)
/* Lost weak reference; prune entry. */
{
*loc = entry->next;
table->n_items--;
entry->next = NULL;
unregister_disappearing_links (entry, table->kind);
}
else
loc = &entry->next;
}
}
if (table->n_items < table->lower)
resize_table (table);
}
static SCM
weak_table_ref (scm_t_weak_table *table, unsigned long hash,
scm_t_table_predicate_fn pred, void *closure,
SCM dflt)
{
unsigned long bucket = hash % table->n_buckets;
scm_t_weak_entry *entry;
for (entry = table->buckets[bucket]; entry; entry = entry->next)
{
if (entry->hash == hash)
{
scm_t_bits key, value;
read_weak_entry (entry, &key, &value);
if (key && value && pred (SCM_PACK (key), SCM_PACK (value), closure))
/* Found. */
return SCM_PACK (value);
}
}
return dflt;
}
static void
weak_table_put_x (scm_t_weak_table *table, unsigned long hash,
scm_t_table_predicate_fn pred, void *closure,
SCM key, SCM value)
{
unsigned long bucket = hash % table->n_buckets;
scm_t_weak_entry *entry;
for (entry = table->buckets[bucket]; entry; entry = entry->next)
{
if (entry->hash == hash)
{
scm_t_bits k, v;
read_weak_entry (entry, &k, &v);
if (k && v && pred (SCM_PACK (k), SCM_PACK (v), closure))
{
unregister_disappearing_links (entry, table->kind);
key = SCM_PACK (k);
entry->value = SCM_UNPACK (value);
register_disappearing_links (entry, key, value, table->kind);
return;
}
}
}
if (table->n_items > table->upper)
/* Full table, time to resize. */
resize_table (table);
entry = allocate_entry (table->kind);
entry->hash = hash;
entry->key = SCM_UNPACK (key);
entry->value = SCM_UNPACK (value);
register_disappearing_links (entry, key, value, table->kind);
add_entry (table, entry);
}
static void
weak_table_remove_x (scm_t_weak_table *table, unsigned long hash,
scm_t_table_predicate_fn pred, void *closure)
{
unsigned long bucket = hash % table->n_buckets;
scm_t_weak_entry **loc = table->buckets + bucket;
scm_t_weak_entry *entry;
for (entry = *loc; entry; entry = *loc)
{
if (entry->hash == hash)
{
scm_t_bits k, v;
read_weak_entry (entry, &k, &v);
if (k && v && pred (SCM_PACK (k), SCM_PACK (v), closure))
{
*loc = entry->next;
table->n_items--;
entry->next = NULL;
unregister_disappearing_links (entry, table->kind);
if (table->n_items < table->lower)
resize_table (table);
return;
}
}
loc = &entry->next;
}
return;
}
static SCM
make_weak_table (unsigned long k, scm_t_weak_table_kind kind)
{
scm_t_weak_table *table;
int i = 0, n = k ? k : 31;
while (i + 1 < HASHTABLE_SIZE_N && n > hashtable_size[i])
++i;
n = hashtable_size[i];
table = scm_gc_malloc (sizeof (*table), "weak-table");
table->buckets = scm_gc_malloc (sizeof (*table->buckets) * n,
"weak table buckets");
table->kind = kind;
table->n_items = 0;
table->n_buckets = n;
table->lower = 0;
table->upper = 9 * n / 10;
table->size_index = i;
table->min_size_index = i;
table->last_gc_no = GC_get_gc_no ();
scm_i_pthread_mutex_init (&table->lock, NULL);
return scm_cell (scm_tc7_weak_table, (scm_t_bits)table);
}
void
scm_i_weak_table_print (SCM exp, SCM port, scm_print_state *pstate)
{
scm_puts ("#<", port);
scm_puts ("weak-table ", port);
scm_uintprint (SCM_WEAK_TABLE (exp)->n_items, 10, port);
scm_putc ('/', port);
scm_uintprint (SCM_WEAK_TABLE (exp)->n_buckets, 10, port);
scm_puts (">", port);
}
SCM
scm_c_make_weak_table (unsigned long k, scm_t_weak_table_kind kind)
{
SCM ret;
ret = make_weak_table (k, kind);
return ret;
}
SCM
scm_weak_table_p (SCM obj)
{
return scm_from_bool (SCM_WEAK_TABLE_P (obj));
}
SCM
scm_c_weak_table_ref (SCM table, unsigned long raw_hash,
scm_t_table_predicate_fn pred,
void *closure, SCM dflt)
#define FUNC_NAME "weak-table-ref"
{
SCM ret;
scm_t_weak_table *t;
SCM_VALIDATE_WEAK_TABLE (1, table);
t = SCM_WEAK_TABLE (table);
scm_i_pthread_mutex_lock (&t->lock);
vacuum_weak_table (t);
ret = weak_table_ref (t, raw_hash, pred, closure, dflt);
scm_i_pthread_mutex_unlock (&t->lock);
return ret;
}
#undef FUNC_NAME
void
scm_c_weak_table_put_x (SCM table, unsigned long raw_hash,
scm_t_table_predicate_fn pred,
void *closure, SCM key, SCM value)
#define FUNC_NAME "weak-table-put!"
{
scm_t_weak_table *t;
SCM_VALIDATE_WEAK_TABLE (1, table);
t = SCM_WEAK_TABLE (table);
scm_i_pthread_mutex_lock (&t->lock);
vacuum_weak_table (t);
weak_table_put_x (t, raw_hash, pred, closure, key, value);
scm_i_pthread_mutex_unlock (&t->lock);
}
#undef FUNC_NAME
void
scm_c_weak_table_remove_x (SCM table, unsigned long raw_hash,
scm_t_table_predicate_fn pred,
void *closure)
#define FUNC_NAME "weak-table-remove!"
{
scm_t_weak_table *t;
SCM_VALIDATE_WEAK_TABLE (1, table);
t = SCM_WEAK_TABLE (table);
scm_i_pthread_mutex_lock (&t->lock);
vacuum_weak_table (t);
weak_table_remove_x (t, raw_hash, pred, closure);
scm_i_pthread_mutex_unlock (&t->lock);
}
#undef FUNC_NAME
static int
assq_predicate (SCM x, SCM y, void *closure)
{
return scm_is_eq (x, SCM_PACK_POINTER (closure));
}
SCM
scm_weak_table_refq (SCM table, SCM key, SCM dflt)
{
return scm_c_weak_table_ref (table, scm_ihashq (key, -1),
assq_predicate, SCM_UNPACK_POINTER (key),
dflt);
}
void
scm_weak_table_putq_x (SCM table, SCM key, SCM value)
{
scm_c_weak_table_put_x (table, scm_ihashq (key, -1),
assq_predicate, SCM_UNPACK_POINTER (key),
key, value);
}
void
scm_weak_table_remq_x (SCM table, SCM key)
{
scm_c_weak_table_remove_x (table, scm_ihashq (key, -1),
assq_predicate, SCM_UNPACK_POINTER (key));
}
void
scm_weak_table_clear_x (SCM table)
#define FUNC_NAME "weak-table-clear!"
{
scm_t_weak_table *t;
unsigned long k;
scm_t_weak_entry *entry;
SCM_VALIDATE_WEAK_TABLE (1, table);
t = SCM_WEAK_TABLE (table);
scm_i_pthread_mutex_lock (&t->lock);
t->last_gc_no = GC_get_gc_no ();
for (k = 0; k < t->n_buckets; k++)
{
for (entry = t->buckets[k]; entry; entry = entry->next)
unregister_disappearing_links (entry, t->kind);
t->buckets[k] = NULL;
}
t->n_items = 0;
scm_i_pthread_mutex_unlock (&t->lock);
}
#undef FUNC_NAME
SCM
scm_c_weak_table_fold (scm_t_table_fold_fn proc, void *closure,
SCM init, SCM table)
{
scm_t_weak_table *t;
unsigned long k;
SCM alist = SCM_EOL;
t = SCM_WEAK_TABLE (table);
scm_i_pthread_mutex_lock (&t->lock);
vacuum_weak_table (t);
for (k = 0; k < t->n_buckets; k++)
{
scm_t_weak_entry *entry;
for (entry = t->buckets[k]; entry; entry = entry->next)
{
scm_t_bits key, value;
read_weak_entry (entry, &key, &value);
if (key && value)
alist = scm_acons (SCM_PACK (key), SCM_PACK (value), alist);
}
}
scm_i_pthread_mutex_unlock (&t->lock);
/* Call the proc outside the lock. */
for (; !scm_is_null (alist); alist = scm_cdr (alist))
init = proc (closure, scm_caar (alist), scm_cdar (alist), init);
return init;
}
static SCM
fold_trampoline (void *closure, SCM k, SCM v, SCM init)
{
return scm_call_3 (SCM_PACK_POINTER (closure), k, v, init);
}
SCM
scm_weak_table_fold (SCM proc, SCM init, SCM table)
#define FUNC_NAME "weak-table-fold"
{
SCM_VALIDATE_WEAK_TABLE (3, table);
SCM_VALIDATE_PROC (1, proc);
return scm_c_weak_table_fold (fold_trampoline, SCM_UNPACK_POINTER (proc), init, table);
}
#undef FUNC_NAME
static SCM
for_each_trampoline (void *closure, SCM k, SCM v, SCM seed)
{
scm_call_2 (SCM_PACK_POINTER (closure), k, v);
return seed;
}
void
scm_weak_table_for_each (SCM proc, SCM table)
#define FUNC_NAME "weak-table-for-each"
{
SCM_VALIDATE_WEAK_TABLE (2, table);
SCM_VALIDATE_PROC (1, proc);
scm_c_weak_table_fold (for_each_trampoline, SCM_UNPACK_POINTER (proc), SCM_BOOL_F, table);
}
#undef FUNC_NAME
static SCM
map_trampoline (void *closure, SCM k, SCM v, SCM seed)
{
return scm_cons (scm_call_2 (SCM_PACK_POINTER (closure), k, v), seed);
}
SCM
scm_weak_table_map_to_list (SCM proc, SCM table)
#define FUNC_NAME "weak-table-map->list"
{
SCM_VALIDATE_WEAK_TABLE (2, table);
SCM_VALIDATE_PROC (1, proc);
return scm_c_weak_table_fold (map_trampoline, SCM_UNPACK_POINTER (proc), SCM_EOL, table);
}
#undef FUNC_NAME
/* Legacy interface. */
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
{
return scm_c_make_weak_table (SCM_UNBNDP (n) ? 0 : scm_to_ulong (n),
SCM_WEAK_TABLE_KIND_KEY);
}
#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
{
return scm_c_make_weak_table (SCM_UNBNDP (n) ? 0 : scm_to_ulong (n),
SCM_WEAK_TABLE_KIND_VALUE);
}
#undef FUNC_NAME
SCM_DEFINE (scm_make_doubly_weak_hash_table, "make-doubly-weak-hash-table", 0, 1, 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
{
return scm_c_make_weak_table (SCM_UNBNDP (n) ? 0 : scm_to_ulong (n),
SCM_WEAK_TABLE_KIND_BOTH);
}
#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_WEAK_TABLE_P (obj) &&
SCM_WEAK_TABLE (obj)->kind == SCM_WEAK_TABLE_KIND_KEY);
}
#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_WEAK_TABLE_P (obj) &&
SCM_WEAK_TABLE (obj)->kind == SCM_WEAK_TABLE_KIND_VALUE);
}
#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_WEAK_TABLE_P (obj) &&
SCM_WEAK_TABLE (obj)->kind == SCM_WEAK_TABLE_KIND_BOTH);
}
#undef FUNC_NAME
static void
scm_init_weak_tables (void*)
{
#include "weak-table.x"
}
void
scm_weak_table_prehistory (void)
{
GC_word weak_key_bitmap[GC_BITMAP_SIZE (scm_t_weak_entry)] = { 0 };
GC_word weak_value_bitmap[GC_BITMAP_SIZE (scm_t_weak_entry)] = { 0 };
GC_word doubly_weak_bitmap[GC_BITMAP_SIZE (scm_t_weak_entry)] = { 0 };
GC_set_bit (weak_key_bitmap, GC_WORD_OFFSET (scm_t_weak_entry, next));
GC_set_bit (weak_value_bitmap, GC_WORD_OFFSET (scm_t_weak_entry, next));
GC_set_bit (doubly_weak_bitmap, GC_WORD_OFFSET (scm_t_weak_entry, next));
GC_set_bit (weak_key_bitmap, GC_WORD_OFFSET (scm_t_weak_entry, value));
GC_set_bit (weak_value_bitmap, GC_WORD_OFFSET (scm_t_weak_entry, key));
weak_key_descr = GC_make_descriptor (weak_key_bitmap,
GC_WORD_LEN (scm_t_weak_entry));
weak_value_descr = GC_make_descriptor (weak_value_bitmap,
GC_WORD_LEN (scm_t_weak_entry));
doubly_weak_descr = GC_make_descriptor (doubly_weak_bitmap,
GC_WORD_LEN (scm_t_weak_entry));
scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION,
"scm_init_weak_tables", scm_init_weak_tables, NULL);
}

86
libguile/weak-table.h
View file

@ -1,86 +0,0 @@
#ifndef SCM_WEAK_TABLE_H
#define SCM_WEAK_TABLE_H
/* Copyright 2011-2012,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
<https://www.gnu.org/licenses/>. */
#include "libguile/scm.h"
/* The weak table API is currently only used internally. We could make it
public later, after some API review. */
typedef enum {
SCM_WEAK_TABLE_KIND_KEY,
SCM_WEAK_TABLE_KIND_VALUE,
SCM_WEAK_TABLE_KIND_BOTH,
} scm_t_weak_table_kind;
/* Function that returns nonzero if the given mapping is the one we are
looking for. */
typedef int (*scm_t_table_predicate_fn) (SCM k, SCM v, void *closure);
/* Function to fold over the elements of a set. */
typedef SCM (*scm_t_table_fold_fn) (void *closure, SCM k, SCM v, SCM result);
SCM_INTERNAL SCM scm_c_make_weak_table (unsigned long k,
scm_t_weak_table_kind kind);
SCM_INTERNAL SCM scm_weak_table_p (SCM h);
SCM_INTERNAL SCM scm_c_weak_table_ref (SCM table, unsigned long raw_hash,
scm_t_table_predicate_fn pred,
void *closure, SCM dflt);
SCM_INTERNAL void scm_c_weak_table_put_x (SCM table, unsigned long raw_hash,
scm_t_table_predicate_fn pred,
void *closure, SCM key, SCM value);
SCM_INTERNAL void scm_c_weak_table_remove_x (SCM table, unsigned long raw_hash,
scm_t_table_predicate_fn pred,
void *closure);
SCM_INTERNAL SCM scm_weak_table_refq (SCM table, SCM key, SCM dflt);
SCM_INTERNAL void scm_weak_table_putq_x (SCM table, SCM key, SCM value);
SCM_INTERNAL void scm_weak_table_remq_x (SCM table, SCM key);
SCM_INTERNAL void scm_weak_table_clear_x (SCM table);
SCM_INTERNAL SCM scm_c_weak_table_fold (scm_t_table_fold_fn proc, void *closure,
SCM init, SCM table);
SCM_INTERNAL SCM scm_weak_table_fold (SCM proc, SCM init, SCM table);
SCM_INTERNAL void scm_weak_table_for_each (SCM proc, SCM table);
SCM_INTERNAL SCM scm_weak_table_map_to_list (SCM proc, SCM table);
/* Legacy interface. */
SCM_API SCM scm_make_weak_key_hash_table (SCM k);
SCM_API SCM scm_make_weak_value_hash_table (SCM k);
SCM_API SCM scm_make_doubly_weak_hash_table (SCM k);
SCM_API SCM scm_weak_key_hash_table_p (SCM h);
SCM_API SCM scm_weak_value_hash_table_p (SCM h);
SCM_API SCM scm_doubly_weak_hash_table_p (SCM h);
SCM_INTERNAL void scm_i_weak_table_print (SCM exp, SCM port, scm_print_state *pstate);
SCM_INTERNAL void scm_weak_table_prehistory (void);
#endif /* SCM_WEAK_TABLE_H */

9
module/ice-9/object-properties.scm
View file

@ -45,17 +45,18 @@
;; Weak tables are thread-safe.
(let ((prop (make-weak-key-hash-table)))
(make-procedure-with-setter
(lambda (obj) (hashq-ref prop obj))
(lambda (obj val) (hashq-set! prop obj val)))))
(lambda (obj) (weak-key-hash-table-ref prop obj))
(lambda (obj val) (weak-key-hash-table-set! prop obj val)))))
;; FIXME: Deprecate these global properties.
(define global-properties (make-weak-key-hash-table))
(define (object-properties obj)
(hashq-ref global-properties obj '()))
(weak-key-hash-table-ref global-properties obj
#:default (lambda (k) '())))
(define (set-object-properties! obj props)
(hashq-set! global-properties obj props))
(weak-key-hash-table-set! global-properties obj props))
(define (object-property obj key)
(assq-ref (object-properties obj) key))

48
module/ice-9/poe.scm
View file

@ -19,6 +19,7 @@
(define-module (ice-9 poe)
#:use-module (ice-9 match)
#:use-module (ice-9 weak-tables)
#:export (pure-funcq perfect-funcq))
@ -53,17 +54,13 @@
(set! ring (cdr ring))
next)))
(define funcq-memo (make-weak-key-hash-table 523)) ; !!! randomly selected values
(define funcq-buffer (make-gc-buffer 256))
(define (funcq-hash arg-list n)
(let ((it (let loop ((x 0)
(arg-list arg-list))
(if (null? arg-list)
(modulo x n)
(loop (logior x (hashq (car arg-list) 4194303))
(cdr arg-list))))))
it))
(let loop ((x 0)
(arg-list arg-list))
(if (null? arg-list)
(modulo x n)
(loop (logior x (hashq (car arg-list) 4194303))
(cdr arg-list)))))
;; return true if lists X and Y are the same length and each element is `eq?'
(define (eq?-list x y)
@ -73,21 +70,27 @@
(eq? (car x) (car y))
(eq?-list (cdr x) (cdr y)))))
(define (funcq-assoc arg-list alist)
(if (null? alist)
#f
(if (eq?-list arg-list (caar alist))
(car alist)
(funcq-assoc arg-list (cdr alist)))))
(define (funcq-assoc args alist)
(match alist
(() #f)
((head . tail)
(if (eq?-list (car head) args)
head
tail))))
(define funcq-memo
(make-weak-key-hash-table #:equal? eq?-list
#:hash funcq-hash
#:initial-size 523)) ; !!! randomly selected values
(define funcq-buffer (make-gc-buffer 256))
(define not-found (list 'not-found))
(define (pure-funcq base-func)
(lambda args
(let* ((key (cons base-func args))
(cached (hashx-ref funcq-hash funcq-assoc funcq-memo key not-found)))
(cached (weak-key-hash-table-ref funcq-memo key
#:default (lambda (_) not-found))))
(if (not (eq? cached not-found))
(begin
(funcq-buffer key)
@ -95,7 +98,7 @@
(let ((val (apply base-func args)))
(funcq-buffer key)
(hashx-set! funcq-hash funcq-assoc funcq-memo key val)
(weak-key-hash-table-set! funcq-memo key val)
val)))))
@ -108,6 +111,13 @@
(define (perfect-funcq size base-func)
(define funcq-memo (make-hash-table size))
(define (funcq-assoc args alist)
(match alist
(() #f)
((head . tail)
(if (eq?-list (car head) args)
head
tail))))
(lambda args
(let* ((key (cons base-func args))

12
module/ice-9/popen.scm
View file

@ -25,7 +25,7 @@
#:use-module (ice-9 weak-tables)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-9)
#:export (port/pid-table open-pipe* open-pipe close-pipe open-input-pipe
#:export (open-pipe* open-pipe close-pipe open-input-pipe
open-output-pipe open-input-output-pipe pipeline))
(eval-when (expand load eval)
@ -80,12 +80,6 @@
;; an open pipe is gc'd or a close-port is used.
(define pipe-guardian (make-guardian))
;; a weak hash-table to store the process ids.
;; XXX use of this table is deprecated. It is no longer used here, and
;; is populated for backward compatibility only (since it is exported).
(define port/pid-table (make-weak-key-hash-table))
(define port/pid-table-mutex (make-mutex))
(define (pipe->fdes)
(let ((p (pipe)))
(cons (port->fdes (car p))
@ -146,10 +140,6 @@ port to the process is created: it should be the value of
(pipe-guardian pipe-info)
(%set-port-property! port 'popen-pipe-info pipe-info)
;; XXX populate port/pid-table for backward compatibility.
(with-mutex port/pid-table-mutex
(hashq-set! port/pid-table port pid))
port))))
(define (open-pipe command mode)

5
module/ice-9/source-properties.scm
View file

@ -54,7 +54,8 @@
(define (source-properties obj)
(if (supports-source-properties? obj)
(hashq-ref global-source-properties obj '())
(weak-key-hash-table-ref global-source-properties obj
#:default (lambda (k) '()))
'()))
(define (set-source-properties! obj props)
@ -62,7 +63,7 @@
(scm-error 'wrong-type-arg "set-source-properties!"
"Unexpected immediate value: ~S"
(list obj) #f))
(hashq-set! global-source-properties obj props))
(weak-key-hash-table-set! global-source-properties obj props))
(define (source-property obj key)
(and (supports-source-properties? obj)

362
module/ice-9/weak-tables.scm
View file

@ -21,15 +21,361 @@
(define-module (ice-9 weak-tables)
#:use-module (ice-9 ephemerons)
#:use-module (ice-9 match)
#:use-module (ice-9 threads)
#:use-module (srfi srfi-9)
;; FIXME: Change to #:export when deprecated code removed.
#:replace (make-weak-key-hash-table
make-weak-value-hash-table
make-doubly-weak-hash-table
weak-key-hash-table?
weak-value-hash-table?
doubly-weak-hash-table?))
(eval-when (expand load eval)
(load-extension (string-append "libguile-" (effective-version))
"scm_init_weak_tables"))
make-weak-value-hash-table
weak-value-hash-table?
make-doubly-weak-hash-table
doubly-weak-hash-table?)
#:export (weak-key-hash-table-ref
weak-key-hash-table-set!
weak-key-hash-table-remove!
weak-key-hash-table-clear!
weak-key-hash-table-fold
weak-key-hash-table-for-each
weak-key-hash-table-map->list
weak-value-hash-table-ref
weak-value-hash-table-set!
weak-value-hash-table-remove!
weak-value-hash-table-clear!
weak-value-hash-table-fold
weak-value-hash-table-for-each
weak-value-hash-table-map->list
doubly-weak-hash-table-ref
doubly-weak-hash-table-set!
doubly-weak-hash-table-remove!
doubly-weak-hash-table-clear!
doubly-weak-hash-table-fold
doubly-weak-hash-table-for-each
doubly-weak-hash-table-map->list))
;;;
;;; Weak key hash tables are a thin wrapper over ephemeron tables. They
;;; implement weak-key mappings whose values can be updated in place.
;;; They are concurrent and lock-free, but not yet resizable.
;;;
(define-record-type <weak-key-hash-table>
(%make-weak-key-hash-table find insert! buckets)
%weak-key-hash-table?
(find weak-key-hash-table-find)
(insert! weak-key-hash-table-insert!)
(buckets weak-key-hash-table-buckets))
(define-syntax-rule (primitive=? f prim)
(or (eq? f prim) (eq? f 'prim)))
(define make-weak-key-hash-table
(let ()
(define-syntax-rule (define-accessors find insert! equal? hash)
(begin
(define (find buckets k)
(let ((idx (hash k (ephemeron-table-length buckets))))
(let lp ((chain (ephemeron-table-ref buckets idx)))
(match chain
(#f #f)
(e (if (equal? (ephemeron-key e) k)
e
(lp (ephemeron-next e))))))))
(define (insert! buckets k e)
(let ((idx (hash k (ephemeron-table-length buckets))))
(let retry ((chain (ephemeron-table-ref buckets idx)))
(let walk ((link chain))
(cond
((not link)
;; Key was not in table when we started looking; try
;; to add it.
(let* ((prev (ephemeron-table-try-push! buckets idx e chain)))
(if (eq? prev chain)
;; Success.
(values e #t)
;; Lost a race with another inserter; retry.
(retry prev))))
((equal? (ephemeron-key link) k)
;; Found an existing association; return it.
(values link #f))
(else
;; Chain link for some other key; keep looking.
(walk (ephemeron-next link))))))))))
(define-accessors findq insertq! eq? hashq)
(define-accessors findv insertv! eqv? hashv)
(define-accessors find insert! equal? hash)
(define (compute-accessors %equal? %hash)
(cond
((and (primitive=? %equal? eq?) (primitive=? %hash hashq))
(values findq insertq!))
((and (primitive=? %equal? eqv?) (primitive=? %hash hashv))
(values findv insertv!))
((and (primitive=? %equal? equal?) (primitive=? %hash hash))
(values find insert!))
(else
(define-accessors find insert! %equal? %hash)
(values find insert!))))
(lambda* (#:optional (size 127)
#:key (equal? 'eq?) (hash 'hashq) (initial-size size))
(define-values (find insert!) (compute-accessors equal? hash))
(%make-weak-key-hash-table find insert!
(make-ephemeron-table initial-size)))))
(define* (weak-key-hash-table-ref table k #:key (default (lambda (k) #f)))
(match table
(($ <weak-key-hash-table> find insert! buckets)
(match (find buckets k)
(#f (default k))
(e (ephemeron-value e))))))
(define (weak-key-hash-table-set! table k v)
(match table
(($ <weak-key-hash-table> find insert! buckets)
(call-with-values (lambda () (insert! buckets k (make-ephemeron k v)))
(lambda (e inserted?)
(unless inserted?
(ephemeron-swap! e v))
(values))))))
(define (weak-key-hash-table-remove! table k)
(match table
(($ <weak-key-hash-table> find insert! buckets)
(match (find buckets k)
(#f #f)
(e
(ephemeron-mark-dead! e)
#t)))))
(define (weak-key-hash-table-clear! table)
(match table
(($ <weak-key-hash-table> find insert! buckets)
(let ((len (ephemeron-table-length buckets)))
(let lp ((i 0))
(when (< i len)
(ephemeron-table-clear! buckets i)
(lp (1+ i))))
(values)))))
(define (weak-key-hash-table-fold proc init table)
(match table
(($ <weak-key-hash-table> find insert! buckets)
(let ((len (ephemeron-table-length buckets)))
(let visit-bucket ((i 0) (seed init))
(cond
((< i len)
(let visit-chain ((chain (ephemeron-table-ref buckets i))
(seed seed))
(if chain
(let ((k (ephemeron-key chain))
(v (ephemeron-value chain)))
(visit-chain (ephemeron-next chain)
(if k
(proc k v seed)
seed)))
(visit-bucket (1+ i) seed))))
(else seed)))))))
(define* (weak-key-hash-table-for-each proc table)
(weak-key-hash-table-fold (lambda (k v seed) (proc k v) seed) #f table)
(values))
(define* (weak-key-hash-table-map->list proc table)
(weak-key-hash-table-fold (lambda (k v seed) (cons (proc k v) seed))
'() table))
;;;
;;; Weak value hash tables implement a key-value mapping, where each
;;; mapping is in place if and only if the value is otherwise reachable.
;;; They are implemented as a normal hash table whose values are
;;; ephemerons. Because normal hash tables are not concurrent, accesses
;;; to a weak value table are serialized through a lock. On the other
;;; hand, weak value tables are resizeable.
;;;
(define-record-type <weak-value-hash-table>
(%make-weak-value-hash-table lock find set! remove! store)
%weak-value-hash-table?
(lock weak-value-hash-table-lock)
(find %weak-value-hash-table-find)
(set! %weak-value-hash-table-set!)
(remove! %weak-value-hash-table-remove!)
(store weak-value-hash-table-store))
(define make-weak-value-hash-table
(let ()
(define (make-assoc equal?)
(lambda (alist k)
(let lp ((alist alist))
(match alist
(() #f)
((head . tail)
(if (equal? (car head) k)
head
(lp tail)))))))
(define (compute-accessors %equal? %hash)
(cond
((and (primitive=? %equal? eq?) (primitive=? %hash hashq))
(values hashq-get-handle hashq-set! hashq-remove!))
((and (primitive=? %equal? eqv?) (primitive=? %hash hashv))
(values hashv-get-handle hashv-set! hashv-remove!))
((and (primitive=? %equal? equal?) (primitive=? %hash hash))
(values hash-get-handle hash-set! hash-remove!))
(else
(define assoc (make-assoc %equal?))
(values
(lambda (table k)
(hashx-get-handle %hash assoc table k))
(lambda (table k v)
(hashx-set! %hash assoc table k v))
(lambda (table k)
(hashx-remove! %hash assoc table k))))))
(lambda* (#:optional (size 0)
#:key (equal? 'eq?) (hash 'hashq) (initial-size size))
(define-values (find set! remove!) (compute-accessors equal? hash))
(%make-weak-value-hash-table (make-mutex) find set! remove!
(make-hash-table initial-size)))))
(define* (weak-value-hash-table-ref table k #:key (default (lambda (k) #f)))
(match table
(($ <weak-value-hash-table> lock find set! remove! store)
(with-mutex lock
(match (find store k)
((k . e)
(or (ephemeron-key e)
(begin
;; Ephemeron is dead.
(remove! store k)
(default k))))
(#f (default k)))))))
(define (weak-value-hash-table-set! table k v)
(match table
(($ <weak-value-hash-table> lock find set! remove! store)
(with-mutex lock
(set! store k (make-ephemeron v #t))))))
(define (weak-value-hash-table-remove! table k)
(match table
(($ <weak-value-hash-table> lock find set! remove! store)
(with-mutex lock
(remove! store k))
(values))))
(define (weak-value-hash-table-clear! table)
(match table
(($ <weak-value-hash-table> lock find set! remove! store)
(with-mutex lock
(hash-clear! store))
(values))))
(define (weak-value-hash-table-fold proc init table)
(match table
(($ <weak-value-hash-table> lock find set! remove! store)
(with-mutex lock
(hash-fold (lambda (k v seed)
(let ((v (ephemeron-key v)))
(if v
(proc k v seed)
seed)))
init table)))))
(define* (weak-value-hash-table-for-each proc table)
(weak-value-hash-table-fold (lambda (k v seed) (proc k v) seed) #f table)
(values))
(define* (weak-value-hash-table-map->list proc table)
(weak-value-hash-table-fold (lambda (k v seed) (cons (proc k v) seed))
'() table))
;;;
;;; Doubly-weak hash tables implement a key-value mapping, where each
;;; mapping is in place if and only if both the key and the value are
;;; otherwise reachable. They are implemented as a weak key table whose
;;; values are ephemerons. They are concurrent and lock-free but not
;;; resizeable.
;;;
(define-record-type <doubly-weak-hash-table>
(%make-doubly-weak-hash-table store)
%doubly-weak-hash-table?
(store doubly-weak-hash-table-store))
(define* (make-doubly-weak-hash-table #:optional (size 127)
#:key (equal? 'eq?) (hash 'hashq)
(initial-size size))
(%make-doubly-weak-hash-table
(make-weak-key-hash-table #:equal? equal? #:hash hash
#:initial-size initial-size)))
(define* (doubly-weak-hash-table-ref table k #:key (default (lambda (k) #f)))
(match table
(($ <doubly-weak-hash-table> store)
(match (weak-key-hash-table-ref store k)
(#f (default k))
(e (or (ephemeron-key e)
(default k)))))))
(define* (doubly-weak-hash-table-set! table k v)
(match table
(($ <doubly-weak-hash-table> store)
(weak-key-hash-table-set! store k (make-ephemeron v #t)))))
(define* (doubly-weak-hash-table-remove! table k)
(match table
(($ <doubly-weak-hash-table> store)
(weak-key-hash-table-remove! store k))))
(define* (doubly-weak-hash-table-clear! table)
(match table
(($ <doubly-weak-hash-table> store)
(weak-key-hash-table-clear! store))))
(define (weak-value-hash-table-fold proc init table)
(match table
(($ <doubly-weak-hash-table> store)
(weak-key-hash-table-fold (lambda (k v seed)
(let ((v (ephemeron-key v)))
(if v
(proc k v seed)
seed)))
init store))))
(define* (doubly-weak-hash-table-for-each proc table)
(doubly-weak-hash-table-fold (lambda (k v seed) (proc k v) seed) #f table)
(values))
(define* (doubly-weak-hash-table-map->list proc table)
(doubly-weak-hash-table-fold (lambda (k v seed) (cons (proc k v) seed))
'() table))
;; Work around srfi-9's use of define-inlinable. FIXME: Simplify once
;; srfi-9 is simplified.
(define (weak-key-hash-table? x)
(%weak-key-hash-table? x))
(define (weak-value-hash-table? x)
(%weak-value-hash-table? x))
(define (doubly-weak-hash-table? x)
(%doubly-weak-hash-table? x))

1
module/language/cps/compile-bytecode.scm
View file

@ -506,7 +506,6 @@
(#('bytevector? #f (a)) (unary emit-bytevector? a))
(#('thread? #f (a)) (unary emit-thread? a))
(#('weak-set? #f (a)) (unary emit-weak-set? a))
(#('weak-table? #f (a)) (unary emit-weak-table? a))
(#('array? #f (a)) (unary emit-array? a))
(#('bitvector? #f (a)) (unary emit-bitvector? a))
(#('smob? #f (a)) (unary emit-smob? a))

5
module/language/ecmascript/array.scm
View file

@ -1,6 +1,6 @@
;;; ECMAScript for Guile
;; Copyright (C) 2009, 2010 Free Software Foundation, Inc.
;; Copyright (C) 2009, 2010, 2025 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
@ -22,6 +22,7 @@
#:use-module (oop goops)
#:use-module (language ecmascript base)
#:use-module (language ecmascript function)
#:use-module (ice-9 weak-tables)
#:export (*array-prototype* new-array))
@ -43,7 +44,7 @@
#:value new-array
#:constructor new-array))
(hashq-set! *program-wrappers* new-array *array-prototype*)
(doubly-weak-hash-table-set! *program-wrappers* new-array *array-prototype*)
(pput *array-prototype* 'prototype *array-prototype*)
(pput *array-prototype* 'constructor new-array)

10
module/language/ecmascript/function.scm
View file

@ -52,28 +52,28 @@
(apply (js-value this) args))))
(define-method (pget (o <applicable>) p)
(let ((wrapper (hashq-ref *program-wrappers* o)))
(let ((wrapper (doubly-weak-hash-table-ref *program-wrappers* o)))
(if wrapper
(pget wrapper p)
(pget *function-prototype* p))))
(define-method (pput (o <applicable>) p v)
(let ((wrapper (hashq-ref *program-wrappers* o)))
(let ((wrapper (doubly-weak-hash-table-ref *program-wrappers* o)))
(if wrapper
(pput wrapper p v)
(let ((wrapper (make <js-program-wrapper> #:value o #:class "Function"
#:prototype *function-prototype*)))
(hashq-set! *program-wrappers* o wrapper)
(doubly-weak-hash-table-set! *program-wrappers* o wrapper)
(pput wrapper p v)))))
(define-method (js-prototype (o <applicable>))
(let ((wrapper (hashq-ref *program-wrappers* o)))
(let ((wrapper (doubly-weak-hash-table-ref *program-wrappers* o)))
(if wrapper
(js-prototype wrapper)
#f)))
(define-method (js-constructor (o <applicable>))
(let ((wrapper (hashq-ref *program-wrappers* o)))
(let ((wrapper (doubly-weak-hash-table-ref *program-wrappers* o)))
(if wrapper
(js-constructor wrapper)
#f)))

8
module/oop/goops/save.scm
View file

@ -113,22 +113,22 @@
;;; Readables
;;;
(define readables (make-weak-key-hash-table 61))
(define readables (make-weak-key-hash-table #:initial-size 61))
(define-macro (readable exp)
`(make-readable ,exp ',(copy-tree exp)))
(define (make-readable obj expr)
(hashq-set! readables obj expr)
(weak-key-hash-table-set! readables obj expr)
obj)
(define (readable-expression obj)
`(readable ,(hashq-ref readables obj)))
`(readable ,(weak-key-hash-table-ref readables obj)))
;; FIXME: if obj is nil or false, this can return a false value. OTOH
;; usually this is only for non-immediates.
(define (readable? obj)
(hashq-ref readables obj))
(weak-key-hash-table-ref readables obj))
;;;
;;; Writer helpers

11
module/srfi/srfi-18.scm
View file

@ -184,10 +184,11 @@ object (absolute point in time), or #f."
(thunk)))
(lambda ()
(let ((thread (current-thread)))
(hash-for-each (lambda (mutex _)
(when (eq? (mutex-owner mutex) thread)
(abandon-mutex! mutex)))
mutexes))))))
(weak-key-hash-table-for-each
(lambda (mutex _)
(when (eq? (mutex-owner mutex) thread)
(abandon-mutex! mutex)))
mutexes))))))
(define* (make-thread thunk #:optional name)
(let* ((sm (make-mutex 'start-mutex))
@ -291,7 +292,7 @@ object (absolute point in time), or #f."
(define* (mutex-lock! mutex #:optional timeout (thread (current-thread)))
(let ((mutexes (thread-mutexes)))
(when mutexes
(hashq-set! mutexes mutex #t)))
(weak-key-hash-table-set! mutexes mutex #t)))
(cond
((threads:lock-mutex (mutex-prim mutex)
(timeout->absolute-time timeout))

5
module/srfi/srfi-69.scm
View file

@ -194,6 +194,11 @@ alist keys with EQUAL-PROC."
"Answer a new hash table using EQUAL-PROC as the comparison
function, and HASH-PROC as the hash function. See the reference
manual for specifics, of which there are many."
(when weak
(issue-deprecation-warning
"Making weak hash tables with the SRFI-69 interface is deprecated. "
"If Guile's SRFI-69 code is not updated before the next major "
"version, this facility will go away."))
(make-srfi-69-hash-table
(apply (guile-ht-ctor weak) (without-keyword-args guile-opts))
(equivalence-proc->associator equal-proc)

2
module/system/base/types.scm
View file

@ -463,8 +463,6 @@ using BACKEND."
(inferior-object 'vm-continuation address))
(((_ & #x7f = %tc7-weak-set))
(inferior-object 'weak-set address))
(((_ & #x7f = %tc7-weak-table))
(inferior-object 'weak-table address))
(((_ & #x7f = %tc7-array))
(inferior-object 'array address))
(((_ & #x7f = %tc7-bitvector))

3
module/system/base/types/internal.scm
View file

@ -52,7 +52,6 @@
%tc7-bytevector
%tc7-thread
%tc7-weak-set
%tc7-weak-table
%tc7-array
%tc7-bitvector
%tc7-port
@ -149,7 +148,7 @@
(bytevector bytevector? #b1111111 #b1001101)
(thread thread? #b1111111 #b1001111)
(weak-set weak-set? #b1111111 #b1010101)
(weak-table weak-table? #b1111111 #b1010111)
;;(unused unused #b1111111 #b1010111)
(array array? #b1111111 #b1011101)
(bitvector bitvector? #b1111111 #b1011111)
(finalizer finalizer? #b1111111 #b1100101)

8
module/system/foreign.scm
View file

@ -290,10 +290,12 @@ which does the reverse. PRINT must name a user-defined object printer."
(define wrap
;; Use a weak hash table to preserve pointer identity, i.e.,
;; PTR1 == PTR2 <-> (eq? (wrap PTR1) (wrap PTR2)).
(let ((ptr->obj (make-weak-value-hash-table 3000)))
(let ((ptr->obj (make-weak-value-hash-table
#:hash hash #:equal? equal?
#:initial-size 3000)))
(lambda (ptr)
(or (hash-ref ptr->obj ptr)
(or (weak-value-hash-table-ref ptr->obj ptr)
(let ((o (%wrap ptr)))
(hash-set! ptr->obj ptr o)
(weak-value-hash-table-set! ptr->obj ptr o)
o)))))
(set-record-type-printer! type-name print)))))))

1
module/system/vm/assembler.scm
View file

@ -133,7 +133,6 @@
emit-bytevector?
emit-thread?
emit-weak-set?
emit-weak-table?
emit-array?
emit-bitvector?
emit-ephemeron?

4
test-suite/tests/gc.test
View file

@ -50,9 +50,9 @@
(pass-if "weak-values versus records"
(let ((rec-type (make-record-type 'foo '()))
(h (make-weak-value-hash-table 61)))
(hash-set! h "foo" ((record-constructor rec-type)))
(weak-value-hash-table-set! h "foo" ((record-constructor rec-type)))
(gc)
(let ((x (hash-ref h "foo")))
(let ((x (weak-value-hash-table-ref h "foo")))
(or (not x)
((record-predicate rec-type) x)))))

5
test-suite/tests/hash.test
View file

@ -366,7 +366,8 @@
(with-test-prefix "weak key hash table"
(pass-if "hash-for-each after gc"
(let ((table (make-weak-key-hash-table)))
(hashq-set! table (list 'foo) 'bar)
(weak-key-hash-table-set! table (list 'foo) 'bar)
(gc)
;; Iterate over deleted weak ref without crashing.
(unspecified? (hash-for-each (lambda (key value) key) table)))))
(weak-key-hash-table-for-each (lambda (key value) key) table)
#t)))

6
test-suite/tests/srfi-69.test
View file

@ -1,6 +1,6 @@
;;;; srfi-69.test --- Test suite for SRFI 69 -*- scheme -*-
;;;;
;;;; Copyright (C) 2007 Free Software Foundation, Inc.
;;;; Copyright (C) 2007, 2025 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
@ -51,6 +51,8 @@ case-insensitive strings to `equal?'-tested values."
'(("xy" . 42) ("abc" . 54) ("qqq" . 100))
(hash-table->alist ht)))))
;; FIXME: Either revive or deprecate.
#;
(pass-if-exception "Bad weakness arg to mht signals an error"
'(misc-error . "^Invalid weak hash table type")
(make-hash-table equal? hash #:weak 'key-and-value))
@ -101,6 +103,8 @@ case-insensitive strings to `equal?'-tested values."
(and (= 1 (hash-table-size ht))
(lset= equal? '((b . 53)) (hash-table->alist ht)))))
;; FIXME: Either revive or deprecate.
#;
(pass-if "can use all arguments, including size"
(hash-table? (make-hash-table equal? hash #:weak 'key 31)))

3
test-suite/tests/types.test
View file

@ -101,9 +101,6 @@
((open-input-string "hello") port (? inferior-object?))
((lambda () #t) program _)
((make-variable 'foo) variable _)
((make-weak-key-hash-table) weak-table _)
((make-weak-value-hash-table) weak-table _)
((make-doubly-weak-hash-table) weak-table _)
(#2((1 2 3) (4 5 6)) array _)
(#*00000110 bitvector _)
((expt 2 70) bignum _)

138
test-suite/tests/weaks.test
View file

@ -130,7 +130,7 @@
;;;
;;; Weak hash tables & weak alist vectors.
;;; Weak hash tables.
;;;
(define (valid? value initial-value)
@ -140,23 +140,23 @@
(or (not value)
(equal? value initial-value)))
(let ((x (make-weak-key-hash-table 17))
(y (make-weak-value-hash-table 17))
(z (make-doubly-weak-hash-table 17))
(let ((x (make-weak-key-hash-table #:hash hash #:equal? equal?))
(y (make-weak-value-hash-table #:hash hash #:equal? equal?))
(z (make-doubly-weak-hash-table #:hash hash #:equal? equal?))
(test-key "foo")
(test-value "bar"))
(with-test-prefix
"weak-hash"
(pass-if "lives"
(begin
(hash-set! x test-key test-value)
(hash-set! y test-key test-value)
(hash-set! z test-key test-value)
(weak-key-hash-table-set! x test-key test-value)
(weak-value-hash-table-set! y test-key test-value)
(doubly-weak-hash-table-set! z test-key test-value)
(gc)
(gc)
(and (hash-ref x test-key)
(hash-ref y test-key)
(hash-ref z test-key)
(and (weak-key-hash-table-ref x test-key)
(weak-value-hash-table-ref y test-key)
(doubly-weak-hash-table-ref z test-key)
#t)))
;; In the tests below we use `string-copy' to avoid the risk of
@ -164,117 +164,105 @@
(pass-if "weak-key dies"
(begin
(hash-set! x (string-copy "this") "is")
(hash-set! x (string-copy "a") "test")
(hash-set! x (string-copy "of") "the")
(hash-set! x (string-copy "emergency") "weak")
(hash-set! x (string-copy "key") "hash system")
(weak-key-hash-table-set! x (string-copy "this") "is")
(weak-key-hash-table-set! x (string-copy "a") "test")
(weak-key-hash-table-set! x (string-copy "of") "the")
(weak-key-hash-table-set! x (string-copy "emergency") "weak")
(weak-key-hash-table-set! x (string-copy "key") "hash system")
(gc)
(let ((values (map (cut hash-ref x <>)
(let ((values (map (cut weak-key-hash-table-ref x <>)
'("this" "a" "of" "emergency" "key"))))
(and (every valid? values
'("is" "test" "the" "weak" "hash system"))
(any not values)
(hash-ref x test-key)
(weak-key-hash-table-ref x test-key)
#t))))
(pass-if "weak-value dies"
(begin
(hash-set! y "this" (string-copy "is"))
(hash-set! y "a" (string-copy "test"))
(hash-set! y "of" (string-copy "the"))
(hash-set! y "emergency" (string-copy "weak"))
(hash-set! y "value" (string-copy "hash system"))
(weak-value-hash-table-set! y "this" (string-copy "is"))
(weak-value-hash-table-set! y "a" (string-copy "test"))
(weak-value-hash-table-set! y "of" (string-copy "the"))
(weak-value-hash-table-set! y "emergency" (string-copy "weak"))
(weak-value-hash-table-set! y "value" (string-copy "hash system"))
(gc)
(let ((values (map (cut hash-ref y <>)
(let ((values (map (cut weak-value-hash-table-ref y <>)
'("this" "a" "of" "emergency" "key"))))
(and (every valid? values
'("is" "test" "the" "weak" "hash system"))
(any not values)
(hash-ref y test-key)
(weak-value-hash-table-ref y test-key)
#t))))
(pass-if "doubly-weak dies"
(begin
(hash-set! z (string-copy "this") (string-copy "is"))
(hash-set! z "a" (string-copy "test"))
(hash-set! z (string-copy "of") "the")
(hash-set! z "emergency" (string-copy "weak"))
(hash-set! z (string-copy "all") (string-copy "hash system"))
(doubly-weak-hash-table-set! z (string-copy "this") (string-copy "is"))
(doubly-weak-hash-table-set! z "a" (string-copy "test"))
(doubly-weak-hash-table-set! z (string-copy "of") "the")
(doubly-weak-hash-table-set! z "emergency" (string-copy "weak"))
(doubly-weak-hash-table-set! z (string-copy "all") (string-copy "hash system"))
(gc)
(let ((values (map (cut hash-ref z <>)
(let ((values (map (cut doubly-weak-hash-table-ref z <>)
'("this" "a" "of" "emergency" "key"))))
(and (every valid? values
'("is" "test" "the" "weak" "hash system"))
(any not values)
(hash-ref z test-key)
(doubly-weak-hash-table-ref z test-key)
#t))))
(pass-if "hash-set!, weak val, im -> im"
(let ((t (make-weak-value-hash-table)))
(hash-set! t "foo" 1)
(hash-set! t "foo" 2)
(equal? (hash-ref t "foo") 2)))
(pass-if "weak-value-hash-table-set!, weak val, im -> im"
(let ((t (make-weak-value-hash-table #:equal? equal? #:hash hash)))
(weak-value-hash-table-set! t "foo" 1)
(weak-value-hash-table-set! t "foo" 2)
(equal? (weak-value-hash-table-ref t "foo") 2)))
(pass-if "hash-set!, weak val, im -> nim"
(let ((t (make-weak-value-hash-table)))
(hash-set! t "foo" 1)
(hash-set! t "foo" "baz")
(equal? (hash-ref t "foo") "baz")))
(pass-if "weak-value-hash-table-set!, weak val, im -> nim"
(let ((t (make-weak-value-hash-table #:equal? equal? #:hash hash)))
(weak-value-hash-table-set! t "foo" 1)
(weak-value-hash-table-set! t "foo" "baz")
(equal? (weak-value-hash-table-ref t "foo") "baz")))
(pass-if "hash-set!, weak val, nim -> nim"
(let ((t (make-weak-value-hash-table)))
(hash-set! t "foo" "bar")
(hash-set! t "foo" "baz")
(equal? (hash-ref t "foo") "baz")))
(pass-if "weak-value-hash-table-set!, weak val, nim -> nim"
(let ((t (make-weak-value-hash-table #:equal? equal? #:hash hash)))
(weak-value-hash-table-set! t "foo" "bar")
(weak-value-hash-table-set! t "foo" "baz")
(equal? (weak-value-hash-table-ref t "foo") "baz")))
(pass-if "hash-set!, weak val, nim -> im"
(let ((t (make-weak-value-hash-table)))
(hash-set! t "foo" "bar")
(hash-set! t "foo" 1)
(equal? (hash-ref t "foo") 1)))
(pass-if "hash-set!, weak key, returns value"
(let ((t (make-weak-value-hash-table))
(val (string #\f #\o #\o)))
(eq? (hashq-set! t "bar" val)
(hashv-set! t "bar" val)
(hash-set! t "bar" val)
val)))
(pass-if "weak-value-hash-table-set!, weak val, nim -> im"
(let ((t (make-weak-value-hash-table #:equal? equal? #:hash hash)))
(weak-value-hash-table-set! t "foo" "bar")
(weak-value-hash-table-set! t "foo" 1)
(equal? (weak-value-hash-table-ref t "foo") 1)))
(pass-if "assoc can do anything"
;; Until 1.9.12, as hash table's custom ASSOC procedure was
;; called with the GC lock alloc held, which imposed severe
;; restrictions on what it could do (bug #29616). This test
;; makes sure this is no longer the case.
(let ((h (make-doubly-weak-hash-table 2))
(let ((h (make-doubly-weak-hash-table
#:initial-size 2
#:hash string-hash-ci
#:equal? (lambda (a b)
(make-list 123) ;; this should be possible
(gc) ;; this too
(string-ci=? a b))))
(c 123)
(k "GNU"))
(define (assoc-ci key bucket)
(make-list 123) ;; this should be possible
(gc) ;; this too
(find (lambda (p)
(string-ci=? key (car p)))
bucket))
(hashx-set! string-hash-ci assoc-ci h
(string-copy "hello") (string-copy "world"))
(hashx-set! string-hash-ci assoc-ci h
k "Guile")
(doubly-weak-hash-table-set! h (string-copy "hello")
(string-copy "world"))
(doubly-weak-hash-table-set! h k "Guile")
(and (every (cut valid? <> "Guile")
(unfold (cut >= <> c)
(lambda (_)
(hashx-ref string-hash-ci assoc-ci
h "gnu"))
(doubly-weak-hash-table-ref h "gnu"))
1+
0))
(every (cut valid? <> "world")
(unfold (cut >= <> c)
(lambda (_)
(hashx-ref string-hash-ci assoc-ci
h "HELLO"))
(doubly-weak-hash-table-ref h "HELLO"))
1+
0))
#t)))))