From c63f9101f8e6e02a1f034e202d8caa50183992d2 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Mon, 5 May 2025 16:07:30 +0200 Subject: Reimplement weak vectors in Scheme using ephemerons * module/ice-9/weak-vector.scm: New implementation, same interface. * doc/ref/api-memory.texi (Weak vectors): Default weak vector value was documented as empty list when it was actually unspecified, but #f is most useful, so we change documentation and code to match. * libguile/Makefile.am (libguile_@GUILE_EFFECTIVE_VERSION@_la_SOURCES): (DOT_X_FILES): (DOT_DOC_FILES): (noinst_HEADERS): (modinclude_HEADERS): * libguile.h: * libguile/deprecated.c: * libguile/deprecated.h: * libguile/init.c: * libguile/weak-vector.c: * libguile/weak-vector.h: Remove C weak vector implementation, replaced with deprecation stubs that call out to Scheme. * libguile/weak-set.c: * libguile/weak-table.c: * libguile/weak-list.h: Remove unused internal header. * libguile/eq.c: * libguile/evalext.c: * libguile/goops.c: * libguile/hash.c: * libguile/scm.h: * module/system/base/types.scm: * module/system/base/types/internal.scm: * module/system/vm/assembler.scm: Remove wvect tc7. --- doc/ref/api-memory.texi | 7 +- libguile.h | 1 - libguile/Makefile.am | 13 +- libguile/deprecated.c | 111 ++++++++++++++ libguile/deprecated.h | 16 ++ libguile/eq.c | 3 +- libguile/evalext.c | 1 - libguile/goops.c | 1 - libguile/hash.c | 3 +- libguile/init.c | 2 - libguile/print.c | 20 +-- libguile/scm.h | 2 +- libguile/weak-list.h | 66 -------- libguile/weak-set.c | 2 - libguile/weak-table.c | 1 - libguile/weak-vector.c | 273 ---------------------------------- libguile/weak-vector.h | 48 ------ module/ice-9/weak-vector.scm | 59 +++++++- module/system/base/types.scm | 2 - module/system/base/types/internal.scm | 3 +- module/system/vm/assembler.scm | 1 - test-suite/tests/types.test | 2 - 22 files changed, 199 insertions(+), 438 deletions(-) delete mode 100644 libguile/weak-list.h delete mode 100644 libguile/weak-vector.c delete mode 100644 libguile/weak-vector.h diff --git a/doc/ref/api-memory.texi b/doc/ref/api-memory.texi index 6d9d5dc39..ddfe3d9db 100644 --- a/doc/ref/api-memory.texi +++ b/doc/ref/api-memory.texi @@ -316,10 +316,9 @@ nor a weak value hash table. @deffn {Scheme Procedure} make-weak-vector size [fill] @deffnx {C Function} scm_make_weak_vector (size, fill) -Return a weak vector with @var{size} elements. If the optional -argument @var{fill} is given, all entries in the vector will be -set to @var{fill}. The default value for @var{fill} is the -empty list. +Return a weak vector with @var{size} elements. If the optional argument +@var{fill} is given, all entries in the vector will be set to +@var{fill}. The default value for @var{fill} is @code{#f}. @end deffn @deffn {Scheme Procedure} weak-vector elem @dots{} diff --git a/libguile.h b/libguile.h index 75554c0c1..6f152fef0 100644 --- a/libguile.h +++ b/libguile.h @@ -117,7 +117,6 @@ extern "C" { #include "libguile/vports.h" #include "libguile/weak-set.h" #include "libguile/weak-table.h" -#include "libguile/weak-vector.h" #include "libguile/backtrace.h" #include "libguile/debug.h" #include "libguile/stacks.h" diff --git a/libguile/Makefile.am b/libguile/Makefile.am index 5ea566da2..f51c6be81 100644 --- a/libguile/Makefile.am +++ b/libguile/Makefile.am @@ -240,8 +240,7 @@ libguile_@GUILE_EFFECTIVE_VERSION@_la_SOURCES = \ vm.c \ vports.c \ weak-set.c \ - weak-table.c \ - weak-vector.c + weak-table.c if ENABLE_JIT libguile_@GUILE_EFFECTIVE_VERSION@_la_SOURCES += $(lightening_c_files) @@ -353,8 +352,7 @@ DOT_X_FILES = \ version.x \ vm.x \ weak-set.x \ - weak-table.x \ - weak-vector.x + weak-table.x EXTRA_DOT_X_FILES = @EXTRA_DOT_X_FILES@ @@ -454,8 +452,7 @@ DOT_DOC_FILES = \ version.doc \ vports.doc \ weak-set.doc \ - weak-table.doc \ - weak-vector.doc + weak-table.doc EXTRA_DOT_DOC_FILES = @EXTRA_DOT_DOC_FILES@ @@ -547,7 +544,6 @@ noinst_HEADERS = custom-ports.h \ ports-internal.h \ syntax.h \ trace.h \ - weak-list.h \ whippet-embedder.h # vm instructions @@ -719,8 +715,7 @@ modinclude_HEADERS = \ vm.h \ vports.h \ weak-set.h \ - weak-table.h \ - weak-vector.h + weak-table.h nodist_modinclude_HEADERS = version.h scmconfig.h diff --git a/libguile/deprecated.c b/libguile/deprecated.c index c3ba0a9eb..73720a5b8 100644 --- a/libguile/deprecated.c +++ b/libguile/deprecated.c @@ -27,6 +27,7 @@ #include "eval.h" #include "gsubr.h" #include "modules.h" +#include "numbers.h" #include "threads.h" #include "variable.h" @@ -60,6 +61,116 @@ scm_make_guardian (void) +static SCM make_weak_vector_var; +static SCM weak_vector_var; +static SCM weak_vector_p_var; +static SCM weak_vector_length_var; +static SCM weak_vector_ref_var; +static SCM weak_vector_set_x_var; + +static void +init_weak_vector_vars (void) +{ + make_weak_vector_var = + scm_c_public_lookup ("ice-9 weak-vector", "make-weak-vector"); + weak_vector_var = + scm_c_public_lookup ("ice-9 weak-vector", "weak-vector"); + weak_vector_p_var = + scm_c_public_lookup ("ice-9 weak-vector", "weak-vector?"); + weak_vector_length_var = + scm_c_public_lookup ("ice-9 weak-vector", "weak-vector-length"); + weak_vector_ref_var = + scm_c_public_lookup ("ice-9 weak-vector", "weak-vector-ref"); + weak_vector_set_x_var = + scm_c_public_lookup ("ice-9 weak-vector", "weak-vector-set!"); +} + +static void +init_weak_vectors (void) +{ + static scm_i_pthread_once_t once = SCM_I_PTHREAD_ONCE_INIT; + scm_c_issue_deprecation_warning + ("The weak vector C interface is deprecated. Invoke the Scheme " + "procedures from (ice-9 weak-vector) instead."); + scm_i_pthread_once (&once, init_weak_vector_vars); +} + +SCM +scm_make_weak_vector (SCM len, SCM fill) +{ + init_weak_vectors (); + return scm_call_2 (scm_variable_ref (make_weak_vector_var), len, + SCM_UNBNDP (fill) ? SCM_BOOL_F : fill); +} + +SCM +scm_weak_vector (SCM l) +{ + init_weak_vectors (); + return scm_call_1 (scm_variable_ref (weak_vector_var), l); +} + +SCM +scm_weak_vector_p (SCM x) +{ + init_weak_vectors (); + return scm_call_1 (scm_variable_ref (weak_vector_p_var), x); +} + +SCM +scm_weak_vector_length (SCM v) +{ + init_weak_vectors (); + return scm_call_1 (scm_variable_ref (weak_vector_length_var), v); +} + +SCM +scm_weak_vector_ref (SCM v, SCM k) +{ + init_weak_vectors (); + return scm_call_2 (scm_variable_ref (weak_vector_ref_var), v, k); +} + +SCM +scm_weak_vector_set_x (SCM v, SCM k, SCM x) +{ + init_weak_vectors (); + scm_call_3 (scm_variable_ref (weak_vector_set_x_var), v, k, x); + return SCM_UNSPECIFIED; +} + +SCM +scm_c_make_weak_vector (size_t len, SCM fill) +{ + return scm_make_weak_vector (scm_from_size_t (len), fill); +} + +int +scm_is_weak_vector (SCM obj) +{ + return scm_is_true (scm_weak_vector_p (obj)); +} + +size_t +scm_c_weak_vector_length (SCM vec) +{ + return scm_to_size_t (scm_weak_vector_length (vec)); +} + +SCM +scm_c_weak_vector_ref (SCM v, size_t k) +{ + return scm_weak_vector_ref (v, scm_from_size_t (k)); +} + +void +scm_c_weak_vector_set_x (SCM v, size_t k, SCM x) +{ + scm_weak_vector_set_x (v, scm_from_size_t (k), x); +} + + + void scm_i_init_deprecated () { diff --git a/libguile/deprecated.h b/libguile/deprecated.h index dbe2e4ce2..e7c63d47c 100644 --- a/libguile/deprecated.h +++ b/libguile/deprecated.h @@ -25,6 +25,22 @@ #if (SCM_ENABLE_DEPRECATED == 1) SCM_DEPRECATED SCM scm_make_guardian (void); + +#define SCM_I_WVECTP(x) (scm_is_weak_vector (x)) + +SCM_DEPRECATED SCM scm_make_weak_vector (SCM len, SCM fill); +SCM_DEPRECATED SCM scm_weak_vector (SCM l); +SCM_DEPRECATED SCM scm_weak_vector_p (SCM x); +SCM_DEPRECATED SCM scm_weak_vector_length (SCM v); +SCM_DEPRECATED SCM scm_weak_vector_ref (SCM v, SCM k); +SCM_DEPRECATED SCM scm_weak_vector_set_x (SCM v, SCM k, SCM x); + +SCM_DEPRECATED SCM scm_c_make_weak_vector (size_t len, SCM fill); +SCM_DEPRECATED int scm_is_weak_vector (SCM obj); +SCM_DEPRECATED size_t scm_c_weak_vector_length (SCM vec); +SCM_DEPRECATED SCM scm_c_weak_vector_ref (SCM v, size_t k); +SCM_DEPRECATED void scm_c_weak_vector_set_x (SCM v, size_t k, SCM x); + /* Deprecated declarations go here. */ void scm_i_init_deprecated (void); diff --git a/libguile/eq.c b/libguile/eq.c index 6870613c1..d4d51a05e 100644 --- a/libguile/eq.c +++ b/libguile/eq.c @@ -1,4 +1,4 @@ -/* Copyright 1995-1998,2000-2001,2003-2004,2006,2009-2011,2017-2018,2022 +/* Copyright 1995-1998,2000-2001,2003-2004,2006,2009-2011,2017-2018,2022,2025 Free Software Foundation, Inc. This file is part of Guile. @@ -371,7 +371,6 @@ scm_equal_p (SCM x, SCM y) case scm_tc7_bitvector: return scm_i_bitvector_equal_p (x, y); case scm_tc7_vector: - case scm_tc7_wvect: return scm_i_vector_equal_p (x, y); case scm_tc7_syntax: if (scm_is_false (scm_equal_p (scm_syntax_wrap (x), diff --git a/libguile/evalext.c b/libguile/evalext.c index 3d92cf10d..779d93c1d 100644 --- a/libguile/evalext.c +++ b/libguile/evalext.c @@ -77,7 +77,6 @@ SCM_DEFINE (scm_self_evaluating_p, "self-evaluating?", 1, 0, 0, switch (SCM_TYP7 (obj)) { case scm_tc7_vector: - case scm_tc7_wvect: case scm_tc7_pointer: case scm_tc7_hashtable: case scm_tc7_weak_set: diff --git a/libguile/goops.c b/libguile/goops.c index d5770bc99..2f1dc7e5c 100644 --- a/libguile/goops.c +++ b/libguile/goops.c @@ -230,7 +230,6 @@ SCM_DEFINE (scm_class_of, "class-of", 1, 0, 0, case scm_tc7_symbol: return class_symbol; case scm_tc7_vector: - case scm_tc7_wvect: return class_vector; case scm_tc7_pointer: return class_foreign; diff --git a/libguile/hash.c b/libguile/hash.c index b7ad03309..a076213a2 100644 --- a/libguile/hash.c +++ b/libguile/hash.c @@ -1,4 +1,4 @@ -/* Copyright 1995-1997,2000-2001,2003-2004,2006,2008-2015,2017-2018,2020,2023 +/* Copyright 1995-1997,2000-2001,2003-2004,2006,2008-2015,2017-2018,2020,2023,2025 Free Software Foundation, Inc. This file is part of Guile. @@ -317,7 +317,6 @@ scm_raw_ihash (SCM obj, size_t depth) return SCM_I_KEYWORD_HASH (obj); case scm_tc7_pointer: return scm_raw_ihashq ((uintptr_t) SCM_POINTER_VALUE (obj)); - case scm_tc7_wvect: case scm_tc7_vector: { size_t len = SCM_SIMPLE_VECTOR_LENGTH (obj); diff --git a/libguile/init.c b/libguile/init.c index 049e18f9a..6ac140f0e 100644 --- a/libguile/init.c +++ b/libguile/init.c @@ -149,7 +149,6 @@ #include "vm.h" #include "weak-set.h" #include "weak-table.h" -#include "weak-vector.h" #include "init.h" @@ -460,7 +459,6 @@ scm_i_init_guile (struct gc_stack_addr base) scm_init_version (); scm_init_weak_set (); scm_init_weak_table (); - scm_init_weak_vectors (); scm_init_standard_ports (); /* Requires fports */ scm_init_expand (); /* Requires structs */ scm_init_memoize (); /* Requires smob_prehistory */ diff --git a/libguile/print.c b/libguile/print.c index 937454158..17153ba8f 100644 --- a/libguile/print.c +++ b/libguile/print.c @@ -70,7 +70,6 @@ #include "vm.h" #include "weak-set.h" #include "weak-table.h" -#include "weak-vector.h" #include "print.h" @@ -564,8 +563,8 @@ scm_iprin1 (SCM exp, SCM port, scm_print_state *pstate) } static void -print_vector_or_weak_vector (SCM v, size_t len, SCM (*ref) (SCM, size_t), - SCM port, scm_print_state *pstate) +print_vector (SCM v, size_t len, SCM (*ref) (SCM, size_t), + SCM port, scm_print_state *pstate) { long i; long last = len - 1; @@ -710,8 +709,8 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate) break; case scm_tc7_values: scm_puts ("#", port); break; case scm_tc7_program: @@ -771,18 +770,11 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate) case scm_tc7_thread: scm_i_print_thread (exp, port, pstate); break; - case scm_tc7_wvect: - ENTER_NESTED_DATA (pstate, exp, circref); - scm_puts ("#w(", port); - print_vector_or_weak_vector (exp, scm_c_weak_vector_length (exp), - scm_c_weak_vector_ref, port, pstate); - EXIT_NESTED_DATA (pstate); - break; case scm_tc7_vector: ENTER_NESTED_DATA (pstate, exp, circref); scm_puts ("#(", port); - print_vector_or_weak_vector (exp, SCM_SIMPLE_VECTOR_LENGTH (exp), - scm_c_vector_ref, port, pstate); + print_vector (exp, SCM_SIMPLE_VECTOR_LENGTH (exp), scm_c_vector_ref, + port, pstate); EXIT_NESTED_DATA (pstate); break; case scm_tc7_port: diff --git a/libguile/scm.h b/libguile/scm.h index 75f02e7ce..97b38d61c 100644 --- a/libguile/scm.h +++ b/libguile/scm.h @@ -477,7 +477,7 @@ typedef uintptr_t scm_t_bits; #define scm_tc7_symbol 0x05 #define scm_tc7_variable 0x07 #define scm_tc7_vector 0x0d -#define scm_tc7_wvect 0x0f +#define scm_tc7_unused_0f 0x0f #define scm_tc7_string 0x15 #define scm_tc7_number 0x17 #define scm_tc7_hashtable 0x1d diff --git a/libguile/weak-list.h b/libguile/weak-list.h deleted file mode 100644 index 158a43033..000000000 --- a/libguile/weak-list.h +++ /dev/null @@ -1,66 +0,0 @@ -#ifndef SCM_WEAK_LIST_H -#define SCM_WEAK_LIST_H - -/* Copyright 2016,2018 - 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 - . */ - - - -#include "libguile/pairs.h" -#include "libguile/weak-vector.h" - - - -static inline SCM -scm_i_weak_cons (SCM car, SCM cdr) -{ - return scm_cons (scm_c_make_weak_vector (1, car), cdr); -} - -static inline SCM -scm_i_weak_car (SCM pair) -{ - return scm_c_weak_vector_ref (scm_car (pair), 0); -} - -static inline void -scm_i_visit_weak_list (SCM *list_loc, void (*visit) (SCM)) -{ - SCM in = *list_loc, out = SCM_EOL; - - while (scm_is_pair (in)) - { - SCM car = scm_i_weak_car (in); - SCM cdr = scm_cdr (in); - - if (!scm_is_eq (car, SCM_BOOL_F)) - { - scm_set_cdr_x (in, out); - out = in; - visit (car); - } - - in = cdr; - } - - *list_loc = out; -} - - -#endif /* SCM_WEAK_LIST_H */ diff --git a/libguile/weak-set.c b/libguile/weak-set.c index 1a5bc1577..ef6a5231d 100644 --- a/libguile/weak-set.c +++ b/libguile/weak-set.c @@ -36,8 +36,6 @@ #include "threads.h" #include "weak-set.h" -#include "weak-list.h" - /* Weak Sets diff --git a/libguile/weak-table.c b/libguile/weak-table.c index 571511256..5a4c68b6b 100644 --- a/libguile/weak-table.c +++ b/libguile/weak-table.c @@ -37,7 +37,6 @@ #include "ports.h" #include "procs.h" #include "threads.h" -#include "weak-list.h" #include "weak-table.h" diff --git a/libguile/weak-vector.c b/libguile/weak-vector.c deleted file mode 100644 index 533a07ff0..000000000 --- a/libguile/weak-vector.c +++ /dev/null @@ -1,273 +0,0 @@ -/* Copyright 1995-1996,1998,2000-2001,2003,2006,2008-2014,2018,2025 - Free Software Foundation, Inc. - - This file is part of Guile. - - Guile is free software: you can redistribute it and/or modify it - under the terms of the GNU Lesser General Public License as published - by the Free Software Foundation, either version 3 of the License, or - (at your option) any later version. - - Guile is distributed in the hope that it will be useful, but WITHOUT - ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or - FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public - License for more details. - - You should have received a copy of the GNU Lesser General Public - License along with Guile. If not, see - . */ - - - -#ifdef HAVE_CONFIG_H -# include -#endif - -#include -#include - -#include "bdw-gc.h" -#include "boolean.h" -#include "extensions.h" -#include "gsubr.h" -#include "list.h" -#include "pairs.h" -#include "vectors.h" -#include "version.h" - -#include "weak-vector.h" - - - - -/* {Weak Vectors} - */ - -#define VECTOR_MAX_LENGTH (SCM_T_BITS_MAX >> 8) - -SCM -scm_c_make_weak_vector (size_t len, SCM fill) -#define FUNC_NAME "make-weak-vector" -{ - SCM wv; - size_t j; - - SCM_ASSERT_RANGE (1, scm_from_size_t (len), len <= VECTOR_MAX_LENGTH); - - if (SCM_UNBNDP (fill)) - fill = SCM_UNSPECIFIED; - - wv = SCM_PACK_POINTER (scm_gc_malloc_pointerless ((len + 1) * sizeof (SCM), - "weak vector")); - - SCM_SET_CELL_WORD_0 (wv, (len << 8) | scm_tc7_wvect); - - if (SCM_HEAP_OBJECT_P (fill)) - { - memset (SCM_I_VECTOR_WELTS (wv), 0, len * sizeof (SCM)); - for (j = 0; j < len; j++) - scm_c_weak_vector_set_x (wv, j, fill); - } - else - for (j = 0; j < len; j++) - SCM_SIMPLE_VECTOR_SET (wv, j, fill); - - return wv; -} -#undef FUNC_NAME - -SCM_DEFINE (scm_make_weak_vector, "make-weak-vector", 1, 1, 0, - (SCM size, SCM fill), - "Return a weak vector with @var{size} elements. If the optional\n" - "argument @var{fill} is given, all entries in the vector will be\n" - "set to @var{fill}. The default value for @var{fill} is the\n" - "empty list.") -#define FUNC_NAME s_scm_make_weak_vector -{ - return scm_c_make_weak_vector (scm_to_size_t (size), fill); -} -#undef FUNC_NAME - - -SCM_REGISTER_PROC(s_list_to_weak_vector, "list->weak-vector", 1, 0, 0, scm_weak_vector); - -SCM_DEFINE (scm_weak_vector, "weak-vector", 0, 0, 1, - (SCM lst), - "@deffnx {Scheme Procedure} list->weak-vector lst\n" - "Construct a weak vector from a list: @code{weak-vector} uses\n" - "the list of its arguments while @code{list->weak-vector} uses\n" - "its only argument @var{l} (a list) to construct a weak vector\n" - "the same way @code{list->vector} would.") -#define FUNC_NAME s_scm_weak_vector -{ - SCM wv; - size_t i; - long c_size; - - SCM_VALIDATE_LIST_COPYLEN (SCM_ARG1, lst, c_size); - - wv = scm_c_make_weak_vector ((size_t) c_size, SCM_BOOL_F); - - for (i = 0; scm_is_pair (lst); lst = SCM_CDR (lst), i++) - scm_c_weak_vector_set_x (wv, i, SCM_CAR (lst)); - - return wv; -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_weak_vector_p, "weak-vector?", 1, 0, 0, - (SCM obj), - "Return @code{#t} if @var{obj} is a weak vector. Note that all\n" - "weak hashes are also weak vectors.") -#define FUNC_NAME s_scm_weak_vector_p -{ - return scm_from_bool (scm_is_weak_vector (obj)); -} -#undef FUNC_NAME - - -int -scm_is_weak_vector (SCM obj) -#define FUNC_NAME s_scm_weak_vector_p -{ - return SCM_I_WVECTP (obj); -} -#undef FUNC_NAME - - -#define SCM_VALIDATE_WEAK_VECTOR(pos, var) \ - SCM_I_MAKE_VALIDATE_MSG2 (pos, var, SCM_I_WVECTP, "weak vector") - - -SCM_DEFINE (scm_weak_vector_length, "weak-vector-length", 1, 0, 0, - (SCM wvect), - "Like @code{vector-length}, but for weak vectors.") -#define FUNC_NAME s_scm_weak_vector_length -{ - return scm_from_size_t (scm_c_weak_vector_length (wvect)); -} -#undef FUNC_NAME - - -size_t -scm_c_weak_vector_length (SCM wvect) -#define FUNC_NAME s_scm_weak_vector_length -{ - SCM_VALIDATE_WEAK_VECTOR (1, wvect); - return SCM_I_VECTOR_LENGTH (wvect); -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_weak_vector_ref, "weak-vector-ref", 2, 0, 0, - (SCM wvect, SCM k), - "Like @code{vector-ref}, but for weak vectors.") -#define FUNC_NAME s_scm_weak_vector_ref -{ - return scm_c_weak_vector_ref (wvect, scm_to_size_t (k)); -} -#undef FUNC_NAME - - -struct weak_vector_ref_data -{ - SCM wv; - size_t k; -}; - -static void* -weak_vector_ref (void *data) -{ - struct weak_vector_ref_data *d = data; - - return (void *) SCM_UNPACK (SCM_SIMPLE_VECTOR_REF (d->wv, d->k)); -} - -SCM -scm_c_weak_vector_ref (SCM wv, size_t k) -#define FUNC_NAME s_scm_weak_vector_ref -{ - struct weak_vector_ref_data d; - void *ret; - - SCM_VALIDATE_WEAK_VECTOR (1, wv); - - d.wv = wv; - d.k = k; - - if (k >= SCM_I_VECTOR_LENGTH (wv)) - scm_out_of_range ("weak-vector-ref", scm_from_size_t (k)); - - ret = GC_call_with_alloc_lock (weak_vector_ref, &d); - - if (ret) - return SCM_PACK_POINTER (ret); - else - return SCM_BOOL_F; -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_weak_vector_set_x, "weak-vector-set!", 3, 0, 0, - (SCM wvect, SCM k, SCM obj), - "Like @code{vector-set!}, but for weak vectors.") -#define FUNC_NAME s_scm_weak_vector_set_x -{ - scm_c_weak_vector_set_x (wvect, scm_to_size_t (k), obj); - - return SCM_UNSPECIFIED; -} -#undef FUNC_NAME - - -void -scm_c_weak_vector_set_x (SCM wv, size_t k, SCM x) -#define FUNC_NAME s_scm_weak_vector_set_x -{ - SCM *elts; - struct weak_vector_ref_data d; - void *prev; - - SCM_VALIDATE_WEAK_VECTOR (1, wv); - - d.wv = wv; - d.k = k; - - if (k >= SCM_I_VECTOR_LENGTH (wv)) - scm_out_of_range ("weak-vector-set!", scm_from_size_t (k)); - - prev = GC_call_with_alloc_lock (weak_vector_ref, &d); - - elts = SCM_I_VECTOR_WELTS (wv); - - if (prev && SCM_HEAP_OBJECT_P (SCM_PACK_POINTER (prev))) - GC_unregister_disappearing_link ((void **) &elts[k]); - - elts[k] = x; - - if (SCM_HEAP_OBJECT_P (x)) - SCM_I_REGISTER_DISAPPEARING_LINK ((void **) &elts[k], - SCM2PTR (x)); -} -#undef FUNC_NAME - - - -static void -scm_init_weak_vector_builtins (void) -{ -#ifndef SCM_MAGIC_SNARFER -#include "weak-vector.x" -#endif -} - -void -scm_init_weak_vectors () -{ - scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION, - "scm_init_weak_vector_builtins", - (scm_t_extension_init_func)scm_init_weak_vector_builtins, - NULL); -} - diff --git a/libguile/weak-vector.h b/libguile/weak-vector.h deleted file mode 100644 index e22f63c8b..000000000 --- a/libguile/weak-vector.h +++ /dev/null @@ -1,48 +0,0 @@ -#ifndef SCM_WEAK_VECTOR_H -#define SCM_WEAK_VECTOR_H - -/* Copyright 1995-1996,2000-2001,2003,2006,2008-2009,2011,2014,2018 - 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 - . */ - - - -#include "libguile/scm.h" - - -/* Weak vectors. */ - -#define SCM_I_WVECTP(x) (SCM_HAS_TYP7 (x, scm_tc7_wvect)) - -SCM_API SCM scm_make_weak_vector (SCM len, SCM fill); -SCM_API SCM scm_weak_vector (SCM l); -SCM_API SCM scm_weak_vector_p (SCM x); -SCM_API SCM scm_weak_vector_length (SCM v); -SCM_API SCM scm_weak_vector_ref (SCM v, SCM k); -SCM_API SCM scm_weak_vector_set_x (SCM v, SCM k, SCM x); - -SCM_API SCM scm_c_make_weak_vector (size_t len, SCM fill); -SCM_API int scm_is_weak_vector (SCM obj); -SCM_API size_t scm_c_weak_vector_length (SCM vec); -SCM_API SCM scm_c_weak_vector_ref (SCM v, size_t k); -SCM_API void scm_c_weak_vector_set_x (SCM v, size_t k, SCM x); - -SCM_INTERNAL void scm_init_weak_vectors (void); - - -#endif /* SCM_WEAK_VECTOR_H */ diff --git a/module/ice-9/weak-vector.scm b/module/ice-9/weak-vector.scm index 0df8e1a45..5a89e6831 100644 --- a/module/ice-9/weak-vector.scm +++ b/module/ice-9/weak-vector.scm @@ -1,6 +1,6 @@ ;;; installed-scm-file -;;;; Copyright (C) 2003, 2006, 2011, 2014 Free Software Foundation, Inc. +;;;; Copyright (C) 2003, 2006, 2011, 2014, 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 @@ -19,6 +19,9 @@ (define-module (ice-9 weak-vector) + #:use-module (ice-9 ephemerons) + #:use-module (ice-9 match) + #:use-module (srfi srfi-9) #:export (make-weak-vector list->weak-vector weak-vector @@ -26,6 +29,54 @@ weak-vector-ref weak-vector-set!)) -(eval-when (load eval compile) - (load-extension (string-append "libguile-" (effective-version)) - "scm_init_weak_vector_builtins")) +(define (immediate? x) + (cond + ((exact-integer? x) (<= most-negative-fixnum x most-positive-fixnum)) + ((char? x) #t) + ((eq? x #f) #t) + ((eq? x #nil) #t) + ((eq? x '()) #t) + ((eq? x #t) #t) + ((unspecified? x) #t) + ((eof-object? x) #t) + (else #f))) + +(define-record-type + (%make-weak-vector weaks) + weak-vector? + (weaks weak-vector-weaks)) + +(define* (make-weak-vector size #:optional (fill #f)) + (let ((wv (%make-weak-vector (make-vector size #f)))) + (let lp ((i 0)) + (when (< i size) + (weak-vector-set! wv i fill) + (lp (1+ i)))) + wv)) + +(define (make-weak val) + (if (immediate? val) + val + (make-ephemeron val #t))) + +(define (weak-vector-set! wv idx val) + (vector-set! (weak-vector-weaks wv) idx (make-weak val)) + (values)) + +(define (weak-vector-ref wv idx) + (let ((weak (vector-ref (weak-vector-weaks wv) idx))) + (if (ephemeron? weak) + (ephemeron-key weak) + weak))) + +(define (list->weak-vector ls) + (let ((wv (make-weak-vector (length ls) #f))) + (let lp ((ls ls) (idx 0)) + (match ls + (() wv) + ((elt . ls) + (weak-vector-set! wv idx elt) + (lp ls (1+ idx))))))) + +(define (weak-vector . elts) + (list->weak-vector elts)) diff --git a/module/system/base/types.scm b/module/system/base/types.scm index 75235ea07..c1899bdb0 100644 --- a/module/system/base/types.scm +++ b/module/system/base/types.scm @@ -431,8 +431,6 @@ using BACKEND." (bytevector->uint-list words (native-endianness) %word-size))) vector))) - (((_ & #x7f = %tc7-weak-vector)) - (inferior-object 'weak-vector address)) ; TODO: show elements (((_ & #x7f = %tc7-fluid) init-value) (inferior-object 'fluid address)) (((_ & #x7f = %tc7-dynamic-state)) diff --git a/module/system/base/types/internal.scm b/module/system/base/types/internal.scm index 6b774a48c..b739f9a9a 100644 --- a/module/system/base/types/internal.scm +++ b/module/system/base/types/internal.scm @@ -36,7 +36,6 @@ %tc7-vector %tc8-immutable-vector %tc8-mutable-vector - %tc7-weak-vector %tc7-string %tc7-heap-number %tc7-hash-table @@ -132,7 +131,7 @@ (vector vector? #b1111111 #b0001101) (immutable-vector immutable-vector? #b11111111 #b10001101) (mutable-vector mutable-vector? #b11111111 #b00001101) - (weak-vector weak-vector? #b1111111 #b0001111) + ;;(unused unused #b1111111 #b0001111) (string string? #b1111111 #b0010101) (heap-number heap-number? #b1111111 #b0010111) (hash-table hash-table? #b1111111 #b0011101) diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm index a1d748df7..8b228d2e3 100644 --- a/module/system/vm/assembler.scm +++ b/module/system/vm/assembler.scm @@ -118,7 +118,6 @@ emit-vector? emit-mutable-vector? emit-immutable-vector? - emit-weak-vector? emit-string? emit-heap-number? emit-hash-table? diff --git a/test-suite/tests/types.test b/test-suite/tests/types.test index 03dbea83a..778aaa6bd 100644 --- a/test-suite/tests/types.test +++ b/test-suite/tests/types.test @@ -22,7 +22,6 @@ #:use-module (rnrs io ports) #:use-module (ice-9 match) #:use-module (ice-9 regex) - #:use-module (ice-9 weak-vector) #:use-module (srfi srfi-1) #:use-module (srfi srfi-9) #:use-module (system foreign) @@ -101,7 +100,6 @@ ((open-input-string "hello") port (? inferior-object?)) ((lambda () #t) program _) ((make-variable 'foo) variable _) - ((make-weak-vector 3 #t) weak-vector _) ((make-weak-key-hash-table) weak-table _) ((make-weak-value-hash-table) weak-table _) ((make-doubly-weak-hash-table) weak-table _) -- cgit v1.2.3