wingo pushed a commit to branch wip-whippet
in repository guile.
commit 8280c8485fde0d347f0d9fa5c5740b62a8509fe1
Author: Andy Wingo <wi...@pobox.com>
AuthorDate: Tue May 13 14:57:31 2025 +0200
Move weak table implementation to Scheme
* 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.
---
libguile.h | 1 -
libguile/Makefile.am | 12 +-
libguile/evalext.c | 1 -
libguile/fluids.c | 1 -
libguile/hash.c | 1 -
libguile/hashtab.c | 683 ++++++++++++++++++++++----
libguile/hashtab.h | 11 +-
libguile/init.c | 4 +-
libguile/print.c | 4 -
libguile/scm.h | 2 +-
libguile/weak-table.c | 807 -------------------------------
libguile/weak-table.h | 86 ----
module/ice-9/object-properties.scm | 9 +-
module/ice-9/poe.scm | 50 +-
module/ice-9/popen.scm | 12 +-
module/ice-9/source-properties.scm | 5 +-
module/ice-9/weak-tables.scm | 358 +++++++++++++-
module/language/cps/compile-bytecode.scm | 1 -
module/language/ecmascript/array.scm | 5 +-
module/language/ecmascript/function.scm | 10 +-
module/oop/goops/save.scm | 8 +-
module/srfi/srfi-18.scm | 11 +-
module/srfi/srfi-69.scm | 5 +
module/system/base/types.scm | 2 -
module/system/base/types/internal.scm | 3 +-
module/system/foreign.scm | 8 +-
module/system/vm/assembler.scm | 1 -
test-suite/tests/gc.test | 4 +-
test-suite/tests/hash.test | 5 +-
test-suite/tests/srfi-69.test | 6 +-
test-suite/tests/types.test | 3 -
test-suite/tests/weaks.test | 144 +++---
32 files changed, 1094 insertions(+), 1169 deletions(-)
diff --git a/libguile.h b/libguile.h
index b7211f4f3..9bcc32402 100644
--- a/libguile.h
+++ b/libguile.h
@@ -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"
diff --git a/libguile/Makefile.am b/libguile/Makefile.am
index 1cc0d34b8..68bda9160 100644
--- a/libguile/Makefile.am
+++ b/libguile/Makefile.am
@@ -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
diff --git a/libguile/evalext.c b/libguile/evalext.c
index 418b32261..07c9a0239 100644
--- a/libguile/evalext.c
+++ b/libguile/evalext.c
@@ -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:
diff --git a/libguile/fluids.c b/libguile/fluids.c
index a2fadbd8a..6de7b83f7 100644
--- a/libguile/fluids.c
+++ b/libguile/fluids.c
@@ -40,7 +40,6 @@
#include "print.h"
#include "threads.h"
#include "variable.h"
-#include "weak-table.h"
#include "fluids.h"
diff --git a/libguile/hash.c b/libguile/hash.c
index a076213a2..b30d7750e 100644
--- a/libguile/hash.c
+++ b/libguile/hash.c
@@ -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));
diff --git a/libguile/hashtab.c b/libguile/hashtab.c
index b4f004c1d..09738436c 100644
--- a/libguile/hashtab.c
+++ b/libguile/hashtab.c
@@ -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,23 +30,441 @@
#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.
*
* Growing or shrinking, with following rehashing, is triggered when
@@ -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);
diff --git a/libguile/hashtab.h b/libguile/hashtab.h
index 61e81b341..8c9e45e25 100644
--- a/libguile/hashtab.h
+++ b/libguile/hashtab.h
@@ -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 */
diff --git a/libguile/init.c b/libguile/init.c
index fc86a6145..7348a9916 100644
--- a/libguile/init.c
+++ b/libguile/init.c
@@ -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 */
diff --git a/libguile/print.c b/libguile/print.c
index cd6e811e5..98150ff8c 100644
--- a/libguile/print.c
+++ b/libguile/print.c
@@ -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;
diff --git a/libguile/scm.h b/libguile/scm.h
index 6408bfeb7..fde767174 100644
--- a/libguile/scm.h
+++ b/libguile/scm.h
@@ -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
diff --git a/libguile/weak-table.c b/libguile/weak-table.c
deleted file mode 100644
index 06f2cafdd..000000000
--- a/libguile/weak-table.c
+++ /dev/null
@@ -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);
-}
-
diff --git a/libguile/weak-table.h b/libguile/weak-table.h
deleted file mode 100644
index f7e6c7cae..000000000
--- a/libguile/weak-table.h
+++ /dev/null
@@ -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 */
diff --git a/module/ice-9/object-properties.scm
b/module/ice-9/object-properties.scm
index c587262b2..9b40be4dc 100644
--- a/module/ice-9/object-properties.scm
+++ b/module/ice-9/object-properties.scm
@@ -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))
diff --git a/module/ice-9/poe.scm b/module/ice-9/poe.scm
index d72a4cafa..76585152c 100644
--- a/module/ice-9/poe.scm
+++ b/module/ice-9/poe.scm
@@ -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))
diff --git a/module/ice-9/popen.scm b/module/ice-9/popen.scm
index 0cc7d16ba..43b5d2f62 100644
--- a/module/ice-9/popen.scm
+++ b/module/ice-9/popen.scm
@@ -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)
diff --git a/module/ice-9/source-properties.scm
b/module/ice-9/source-properties.scm
index 0fa5336a6..b8abc276e 100644
--- a/module/ice-9/source-properties.scm
+++ b/module/ice-9/source-properties.scm
@@ -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)
diff --git a/module/ice-9/weak-tables.scm b/module/ice-9/weak-tables.scm
index 924ceec23..59864f5a7 100644
--- a/module/ice-9/weak-tables.scm
+++ b/module/ice-9/weak-tables.scm
@@ -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
+ weak-key-hash-table?
+
make-weak-value-hash-table
+ weak-value-hash-table?
+
make-doubly-weak-hash-table
+ doubly-weak-hash-table?)
- weak-key-hash-table?
- weak-value-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))
+
+
+
-(eval-when (expand load eval)
- (load-extension (string-append "libguile-" (effective-version))
- "scm_init_weak_tables"))
+;; 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))
diff --git a/module/language/cps/compile-bytecode.scm
b/module/language/cps/compile-bytecode.scm
index bb530c7c6..8ff16cfa5 100644
--- a/module/language/cps/compile-bytecode.scm
+++ b/module/language/cps/compile-bytecode.scm
@@ -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))
diff --git a/module/language/ecmascript/array.scm
b/module/language/ecmascript/array.scm
index 997034584..ea9b9ace1 100644
--- a/module/language/ecmascript/array.scm
+++ b/module/language/ecmascript/array.scm
@@ -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)
diff --git a/module/language/ecmascript/function.scm
b/module/language/ecmascript/function.scm
index a4669ae17..0d5c24852 100644
--- a/module/language/ecmascript/function.scm
+++ b/module/language/ecmascript/function.scm
@@ -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)))
diff --git a/module/oop/goops/save.scm b/module/oop/goops/save.scm
index caa725500..6dda93eac 100644
--- a/module/oop/goops/save.scm
+++ b/module/oop/goops/save.scm
@@ -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
diff --git a/module/srfi/srfi-18.scm b/module/srfi/srfi-18.scm
index 60f8d4c47..d4aac8ef7 100644
--- a/module/srfi/srfi-18.scm
+++ b/module/srfi/srfi-18.scm
@@ -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))
diff --git a/module/srfi/srfi-69.scm b/module/srfi/srfi-69.scm
index efdc59bd4..a14ed8f22 100644
--- a/module/srfi/srfi-69.scm
+++ b/module/srfi/srfi-69.scm
@@ -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)
diff --git a/module/system/base/types.scm b/module/system/base/types.scm
index fd35a09f2..9347dcc51 100644
--- a/module/system/base/types.scm
+++ b/module/system/base/types.scm
@@ -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))
diff --git a/module/system/base/types/internal.scm
b/module/system/base/types/internal.scm
index b739f9a9a..a0370eddc 100644
--- a/module/system/base/types/internal.scm
+++ b/module/system/base/types/internal.scm
@@ -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)
diff --git a/module/system/foreign.scm b/module/system/foreign.scm
index fe068a471..4fb9f6628 100644
--- a/module/system/foreign.scm
+++ b/module/system/foreign.scm
@@ -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)))))))
diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm
index 7fc15b9f2..d931dcd78 100644
--- a/module/system/vm/assembler.scm
+++ b/module/system/vm/assembler.scm
@@ -133,7 +133,6 @@
emit-bytevector?
emit-thread?
emit-weak-set?
- emit-weak-table?
emit-array?
emit-bitvector?
emit-ephemeron?
diff --git a/test-suite/tests/gc.test b/test-suite/tests/gc.test
index 98367fac5..380690733 100644
--- a/test-suite/tests/gc.test
+++ b/test-suite/tests/gc.test
@@ -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)))))
diff --git a/test-suite/tests/hash.test b/test-suite/tests/hash.test
index fe75d7b05..f95ec0281 100644
--- a/test-suite/tests/hash.test
+++ b/test-suite/tests/hash.test
@@ -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)))
diff --git a/test-suite/tests/srfi-69.test b/test-suite/tests/srfi-69.test
index e99b76c6d..f9f6c3f33 100644
--- a/test-suite/tests/srfi-69.test
+++ b/test-suite/tests/srfi-69.test
@@ -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)))
diff --git a/test-suite/tests/types.test b/test-suite/tests/types.test
index 1ebf19bad..eeede1308 100644
--- a/test-suite/tests/types.test
+++ b/test-suite/tests/types.test
@@ -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 _)
diff --git a/test-suite/tests/weaks.test b/test-suite/tests/weaks.test
index 3663f39ec..0541208ae 100644
--- a/test-suite/tests/weaks.test
+++ b/test-suite/tests/weaks.test
@@ -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 "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 "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 "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, 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 "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 "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 "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)))))
