diff options
98 files changed, 1632 insertions, 1555 deletions
diff --git a/am/bootstrap.am b/am/bootstrap.am index df6d19bfe..4736d04b6 100644 --- a/am/bootstrap.am +++ b/am/bootstrap.am @@ -160,6 +160,7 @@ SOURCES = \ ice-9/match.scm \ ice-9/networking.scm \ ice-9/null.scm \ + ice-9/object-properties.scm \ ice-9/occam-channel.scm \ ice-9/optargs.scm \ ice-9/peg.scm \ @@ -190,6 +191,7 @@ SOURCES = \ ice-9/session.scm \ ice-9/slib.scm \ ice-9/soft-ports.scm \ + ice-9/source-properties.scm \ ice-9/stack-catch.scm \ ice-9/streams.scm \ ice-9/string-fun.scm \ @@ -200,6 +202,7 @@ SOURCES = \ ice-9/top-repl.scm \ ice-9/unicode.scm \ ice-9/vlist.scm \ + ice-9/weak-tables.scm \ ice-9/weak-vector.scm \ \ language/brainfuck/parse.scm \ diff --git a/libguile.h b/libguile.h index 6f152fef0..b7211f4f3 100644 --- a/libguile.h +++ b/libguile.h @@ -77,7 +77,6 @@ extern "C" { #include "libguile/modules.h" #include "libguile/net_db.h" #include "libguile/numbers.h" -#include "libguile/objprop.h" #include "libguile/options.h" #include "libguile/pairs.h" #include "libguile/ports.h" @@ -96,7 +95,6 @@ extern "C" { #include "libguile/snarf.h" #include "libguile/socket.h" #include "libguile/sort.h" -#include "libguile/srcprop.h" #include "libguile/stackchk.h" #include "libguile/stime.h" #include "libguile/strings.h" diff --git a/libguile/Makefile.am b/libguile/Makefile.am index f51c6be81..1cc0d34b8 100644 --- a/libguile/Makefile.am +++ b/libguile/Makefile.am @@ -195,7 +195,6 @@ libguile_@GUILE_EFFECTIVE_VERSION@_la_SOURCES = \ modules.c \ null-threads.c \ numbers.c \ - objprop.c \ options.c \ pairs.c \ poll.c \ @@ -215,7 +214,6 @@ libguile_@GUILE_EFFECTIVE_VERSION@_la_SOURCES = \ simpos.c \ smob.c \ sort.c \ - srcprop.c \ srfi-4.c \ srfi-13.c \ srfi-14.c \ @@ -309,7 +307,6 @@ DOT_X_FILES = \ memoize.x \ modules.x \ numbers.x \ - objprop.x \ options.x \ pairs.x \ ports.x \ @@ -328,7 +325,6 @@ DOT_X_FILES = \ simpos.x \ smob.x \ sort.x \ - srcprop.x \ srfi-4.x \ srfi-13.x \ srfi-14.x \ @@ -410,7 +406,6 @@ DOT_DOC_FILES = \ memoize.doc \ modules.doc \ numbers.doc \ - objprop.doc \ options.doc \ pairs.doc \ ports.doc \ @@ -428,7 +423,6 @@ DOT_DOC_FILES = \ simpos.doc \ smob.doc \ sort.doc \ - srcprop.doc \ srfi-4.doc \ srfi-13.doc \ srfi-14.doc \ @@ -662,7 +656,6 @@ modinclude_HEADERS = \ net_db.h \ null-threads.h \ numbers.h \ - objprop.h \ options.h \ pairs.h \ poll.h \ @@ -688,7 +681,6 @@ modinclude_HEADERS = \ snarf.h \ socket.h \ sort.h \ - srcprop.h \ srfi-4.h \ srfi-13.h \ srfi-14.h \ diff --git a/libguile/backtrace.c b/libguile/backtrace.c index 4a19d4b8a..73b80075e 100644 --- a/libguile/backtrace.c +++ b/libguile/backtrace.c @@ -1,6 +1,6 @@ /* Printing of backtraces and error messages - Copyright 1996-2001,2003-2004,2006,2009-2011,2014,2018 + Copyright 1996-2001,2003-2004,2006,2009-2011,2014,2018,2025 Free Software Foundation, Inc. This file is part of Guile. @@ -46,7 +46,6 @@ #include "ports.h" #include "posix.h" #include "private-options.h" -#include "srcprop.h" #include "stacks.h" #include "strings.h" #include "strports.h" diff --git a/libguile/debug.c b/libguile/debug.c index 8b6122642..d0978adf7 100644 --- a/libguile/debug.c +++ b/libguile/debug.c @@ -1,6 +1,6 @@ /* Debugging extensions for Guile - Copyright 1995-2003,2006,2008-2013,2018 + Copyright 1995-2003,2006,2008-2013,2018,2025 Free Software Foundation, Inc. This file is part of Guile. @@ -55,7 +55,6 @@ #include "programs.h" #include "read.h" #include "smob.h" -#include "srcprop.h" #include "stackchk.h" #include "strports.h" #include "struct.h" diff --git a/libguile/deprecated.c b/libguile/deprecated.c index 73720a5b8..8078b680d 100644 --- a/libguile/deprecated.c +++ b/libguile/deprecated.c @@ -28,6 +28,7 @@ #include "gsubr.h" #include "modules.h" #include "numbers.h" +#include "symbols.h" #include "threads.h" #include "variable.h" @@ -169,6 +170,141 @@ 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); } + + + +static SCM object_properties_var; +static SCM set_object_properties_var; +static SCM object_property_var; +static SCM set_object_property_var; + +static void +init_object_properties_vars (void) +{ + object_properties_var = + scm_c_public_lookup ("ice-9 object-properties", "object-properties"); + set_object_properties_var = + scm_c_public_lookup ("ice-9 object-properties", "set-object-properties!"); + object_property_var = + scm_c_public_lookup ("ice-9 object-properties", "object-property"); + set_object_property_var = + scm_c_public_lookup ("ice-9 object-properties", "set-object-property!"); +} + +static void +init_object_properties (void) +{ + static scm_i_pthread_once_t once = SCM_I_PTHREAD_ONCE_INIT; + scm_c_issue_deprecation_warning + ("The object properties C interface is deprecated. Invoke the Scheme " + "procedures from (ice-9 object-properties) instead."); + scm_i_pthread_once (&once, init_object_properties_vars); +} + +SCM +scm_object_properties (SCM obj) +{ + init_object_properties (); + return scm_call_1 (scm_variable_ref (object_properties_var), obj); +} + + +SCM +scm_set_object_properties_x (SCM obj, SCM alist) +{ + init_object_properties (); + return scm_call_2 (scm_variable_ref (set_object_properties_var), obj, alist); +} + +SCM +scm_object_property (SCM obj, SCM key) +{ + init_object_properties (); + return scm_call_2 (scm_variable_ref (object_property_var), obj, key); +} + +SCM +scm_set_object_property_x (SCM obj, SCM key, SCM value) +{ + init_object_properties (); + return scm_call_3 (scm_variable_ref (set_object_property_var), obj, key, value); +} + + + + +SCM_GLOBAL_SYMBOL (scm_sym_filename, "filename"); +SCM_GLOBAL_SYMBOL (scm_sym_line, "line"); +SCM_GLOBAL_SYMBOL (scm_sym_column, "column"); + +static SCM source_properties_var; +static SCM set_source_properties_var; +static SCM source_property_var; +static SCM set_source_property_var; +static SCM cons_source_var; + +static void +init_source_properties_vars (void) +{ + source_properties_var = + scm_c_public_lookup ("ice-9 source-properties", "source-properties"); + set_source_properties_var = + scm_c_public_lookup ("ice-9 source-properties", "set-source-properties!"); + source_property_var = + scm_c_public_lookup ("ice-9 source-properties", "source-property"); + set_source_property_var = + scm_c_public_lookup ("ice-9 source-properties", "set-source-property!"); + cons_source_var = + scm_c_public_lookup ("ice-9 source-properties", "cons-source"); +} + +static void +init_source_properties (void) +{ + static scm_i_pthread_once_t once = SCM_I_PTHREAD_ONCE_INIT; + scm_c_issue_deprecation_warning + ("The source properties C interface is deprecated. Invoke the Scheme " + "procedures from (ice-9 source-properties) instead."); + scm_i_pthread_once (&once, init_source_properties_vars); +} + +SCM +scm_source_properties (SCM obj) +{ + init_source_properties (); + return scm_call_1 (scm_variable_ref (source_properties_var), obj); +} + + +SCM +scm_set_source_properties_x (SCM obj, SCM alist) +{ + init_source_properties (); + return scm_call_2 (scm_variable_ref (set_source_properties_var), obj, alist); +} + +SCM +scm_source_property (SCM obj, SCM key) +{ + init_source_properties (); + return scm_call_2 (scm_variable_ref (source_property_var), obj, key); +} + +SCM +scm_set_source_property_x (SCM obj, SCM key, SCM value) +{ + init_source_properties (); + return scm_call_3 (scm_variable_ref (set_source_property_var), obj, key, value); +} + +SCM +scm_cons_source (SCM orig, SCM x, SCM y) +{ + init_source_properties (); + return scm_call_3 (scm_variable_ref (cons_source_var), orig, x, y); +} + + void diff --git a/libguile/deprecated.h b/libguile/deprecated.h index e7c63d47c..ab99d6581 100644 --- a/libguile/deprecated.h +++ b/libguile/deprecated.h @@ -41,6 +41,21 @@ 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); +SCM_DEPRECATED SCM scm_object_properties (SCM obj); +SCM_DEPRECATED SCM scm_set_object_properties_x (SCM obj, SCM plist); +SCM_DEPRECATED SCM scm_object_property (SCM obj, SCM key); +SCM_DEPRECATED SCM scm_set_object_property_x (SCM obj, SCM key, SCM val); + +SCM_DEPRECATED SCM scm_sym_filename; +SCM_DEPRECATED SCM scm_sym_line; +SCM_DEPRECATED SCM scm_sym_column; +SCM_DEPRECATED SCM scm_supports_source_properties_p (SCM obj); +SCM_DEPRECATED SCM scm_source_property (SCM obj, SCM key); +SCM_DEPRECATED SCM scm_set_source_property_x (SCM obj, SCM key, SCM datum); +SCM_DEPRECATED SCM scm_source_properties (SCM obj); +SCM_DEPRECATED SCM scm_set_source_properties_x (SCM obj, SCM props); +SCM_DEPRECATED SCM scm_cons_source (SCM xorig, SCM x, SCM y); + /* Deprecated declarations go here. */ void scm_i_init_deprecated (void); diff --git a/libguile/ephemerons.c b/libguile/ephemerons.c index 1eb179bc7..7a2f75076 100644 --- a/libguile/ephemerons.c +++ b/libguile/ephemerons.c @@ -33,6 +33,8 @@ #include "extensions.h" #include "gc-internal.h" #include "gsubr.h" +#include "hash.h" +#include "numbers.h" #include "ports.h" #include "threads.h" #include "version.h" @@ -44,11 +46,6 @@ -#define SCM_EPHEMERON_P(X) (SCM_HAS_TYP7 (X, scm_tc7_ephemeron)) - -#define SCM_VALIDATE_EPHEMERON(pos, x) \ - SCM_MAKE_VALIDATE_MSG (pos, x, EPHEMERON_P, "ephemeron") - static inline SCM ref_to_scm (struct gc_ref ref) { return SCM_PACK (gc_ref_value (ref)); @@ -58,6 +55,82 @@ static inline struct gc_ref scm_to_ref (SCM scm) return gc_ref (SCM_UNPACK (scm)); } + + +#define SCM_EPHEMERON_P(X) (SCM_HAS_TYP7 (X, scm_tc7_ephemeron)) + +struct gc_ephemeron* +scm_c_make_ephemeron (SCM key, SCM val) +{ + struct scm_thread *thread = SCM_I_CURRENT_THREAD; + struct gc_ephemeron *ephemeron = gc_allocate_ephemeron (thread->mutator); + SCM_SET_CELL_WORD_0 (PTR2SCM (ephemeron), scm_tc7_ephemeron); + gc_ephemeron_init (thread->mutator, ephemeron, scm_to_ref (key), + scm_to_ref (val)); + return ephemeron; +} + +static struct gc_ephemeron* +scm_as_ephemeron (SCM x) +{ + return (struct gc_ephemeron*) SCM_UNPACK_POINTER (x); +} + +SCM +scm_from_ephemeron (struct gc_ephemeron *e) +{ + return PTR2SCM (e); +} + +struct gc_ephemeron* +scm_to_ephemeron (SCM e) +{ + if (!SCM_EPHEMERON_P (e)) + abort (); + return scm_as_ephemeron (e); +} + +SCM +scm_c_ephemeron_key (struct gc_ephemeron *e) +{ + struct gc_ref ret = gc_ephemeron_key (e); + return gc_ref_is_null (ret) ? SCM_BOOL_F : ref_to_scm (ret); +} + +SCM +scm_c_ephemeron_value (struct gc_ephemeron *e) +{ + struct gc_ref ret = gc_ephemeron_value (e); + return gc_ref_is_null (ret) ? SCM_BOOL_F : ref_to_scm (ret); +} + +void +scm_c_ephemeron_mark_dead_x (struct gc_ephemeron *e) +{ + gc_ephemeron_mark_dead (e); +} + +SCM +scm_c_ephemeron_swap_x (struct gc_ephemeron *e, SCM new_val) +{ + struct gc_ref ret = + gc_ephemeron_swap_value (SCM_I_CURRENT_THREAD->mutator, e, + scm_to_ref (new_val)); + return gc_ref_is_null (ret) ? SCM_BOOL_F : ref_to_scm (ret); +} + +struct gc_ephemeron* +scm_c_ephemeron_next (struct gc_ephemeron *e) +{ + return gc_ephemeron_chain_next (e); +} + + + + +#define SCM_VALIDATE_EPHEMERON(pos, x) \ + SCM_MAKE_VALIDATE_MSG (pos, x, EPHEMERON_P, "ephemeron") + SCM_DEFINE_STATIC (scm_ephemeron_p, "ephemeron?", 1, 0, 0, (SCM x), "Return @code{#t} if @var{x} is an ephemeron, or " @@ -75,14 +148,7 @@ SCM_DEFINE_STATIC (scm_make_ephemeron, "make-ephemeron", 2, 0, 0, #define FUNC_NAME s_scm_make_ephemeron { SCM_MAKE_VALIDATE (1, key, HEAP_OBJECT_P); - - struct scm_thread *thread = SCM_I_CURRENT_THREAD; - struct gc_ephemeron *ephemeron = gc_allocate_ephemeron (thread->mutator); - SCM ret = SCM_PACK_POINTER (ephemeron); - SCM_SET_CELL_WORD_0 (ret, scm_tc7_ephemeron); - gc_ephemeron_init (thread->mutator, ephemeron, scm_to_ref (key), - scm_to_ref (val)); - return ret; + return PTR2SCM (scm_c_make_ephemeron (key, val)); } #undef FUNC_NAME @@ -93,10 +159,7 @@ SCM_DEFINE_STATIC (scm_ephemeron_key, "ephemeron-key", 1, 0, 0, #define FUNC_NAME s_scm_ephemeron_key { SCM_VALIDATE_EPHEMERON (1, ephemeron); - - struct gc_ephemeron *e = (struct gc_ephemeron*) SCM_UNPACK_POINTER (ephemeron); - struct gc_ref ret = gc_ephemeron_key (e); - return gc_ref_is_null (ret) ? SCM_BOOL_F : ref_to_scm (ret); + return scm_c_ephemeron_key (scm_as_ephemeron (ephemeron)); } #undef FUNC_NAME @@ -107,10 +170,18 @@ SCM_DEFINE_STATIC (scm_ephemeron_value, "ephemeron-value", 1, 0, 0, #define FUNC_NAME s_scm_ephemeron_value { SCM_VALIDATE_EPHEMERON (1, ephemeron); + return scm_c_ephemeron_value (scm_as_ephemeron (ephemeron)); +} +#undef FUNC_NAME - struct gc_ephemeron *e = (struct gc_ephemeron*) SCM_UNPACK_POINTER (ephemeron); - struct gc_ref ret = gc_ephemeron_value (e); - return gc_ref_is_null (ret) ? SCM_BOOL_F : ref_to_scm (ret); +SCM_DEFINE_STATIC (scm_ephemeron_swap_x, "ephemeron-swap!", 2, 0, 0, + (SCM ephemeron, SCM new_val), + "Update the value for this ephemeron, and return the " + "previous value.") +#define FUNC_NAME s_scm_ephemeron_swap_x +{ + SCM_VALIDATE_EPHEMERON (1, ephemeron); + return scm_c_ephemeron_swap_x (scm_as_ephemeron (ephemeron), new_val); } #undef FUNC_NAME @@ -120,14 +191,22 @@ SCM_DEFINE_STATIC (scm_ephemeron_mark_dead_x, "ephemeron-mark-dead!", 1, 0, 0, #define FUNC_NAME s_scm_ephemeron_mark_dead_x { SCM_VALIDATE_EPHEMERON (1, ephemeron); - - struct gc_ephemeron *e = (struct gc_ephemeron*) SCM_UNPACK_POINTER (ephemeron); - gc_ephemeron_mark_dead (e); - + scm_c_ephemeron_mark_dead_x (scm_as_ephemeron (ephemeron)); return SCM_UNSPECIFIED; } #undef FUNC_NAME +SCM_DEFINE_STATIC (scm_ephemeron_next, "ephemeron-next", 1, 0, 0, + (SCM ephemeron), + "Return the next ephemeron in a chain, or @code{#f} if none.") +#define FUNC_NAME s_scm_ephemeron_next +{ + SCM_VALIDATE_EPHEMERON (1, ephemeron); + struct gc_ephemeron *e = scm_c_ephemeron_next (scm_as_ephemeron (ephemeron)); + return e ? PTR2SCM (e) : SCM_BOOL_F; +} +#undef FUNC_NAME + int scm_i_print_ephemeron (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED) { @@ -140,6 +219,247 @@ scm_i_print_ephemeron (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED) +#define SCM_EPHEMERON_TABLE_P(X) (SCM_HAS_TYP7 (X, scm_tc7_ephemeron_table)) +#define SCM_VALIDATE_EPHEMERON_TABLE(pos, x) \ + SCM_MAKE_VALIDATE_MSG (pos, x, EPHEMERON_TABLE_P, "ephemeron table") + +static struct scm_ephemeron_table* +scm_as_ephemeron_table (SCM x) +{ + return (struct scm_ephemeron_table*) SCM_UNPACK_POINTER (x); +} + +SCM +scm_from_ephemeron_table (struct scm_ephemeron_table *et) +{ + return PTR2SCM (et); +} + +struct scm_ephemeron_table* +scm_to_ephemeron_table (SCM et) +{ + if (!SCM_EPHEMERON_TABLE_P (et)) + abort (); + return scm_as_ephemeron_table (et); +} + +struct scm_ephemeron_table +{ + scm_t_bits tag; + size_t size; + struct gc_ephemeron *contents[]; +}; + +struct scm_ephemeron_table* +scm_c_make_ephemeron_table (size_t size) +{ + size_t byte_size = sizeof (struct scm_ephemeron_table); + byte_size += sizeof (struct gc_ephemeron*) * size; + struct scm_ephemeron_table *table = scm_gc_malloc (byte_size, NULL); + table->tag = scm_tc7_ephemeron_table; + table->size = size; + return table; +} + +size_t +scm_c_ephemeron_table_length (struct scm_ephemeron_table *et) +{ + return et->size; +} + +struct gc_ephemeron* +scm_c_ephemeron_table_ref (struct scm_ephemeron_table *et, size_t idx) +{ + if (idx >= et->size) + abort(); + + return gc_ephemeron_chain_head (&et->contents[idx]); +} + +void +scm_c_ephemeron_table_push_x (struct scm_ephemeron_table *et, size_t idx, + struct gc_ephemeron *e) +{ + if (idx >= et->size) + abort(); + + gc_ephemeron_chain_push (&et->contents[idx], e); +} + +struct gc_ephemeron* +scm_c_ephemeron_table_try_push_x (struct scm_ephemeron_table *et, size_t idx, + struct gc_ephemeron *e, + struct gc_ephemeron *prev) +{ + if (idx >= et->size) + abort(); + + gc_ephemeron_chain_try_push (&et->contents[idx], e, &prev); + + return prev; +} + +struct scm_ephemeron_table* +scm_c_ephemeron_table_copy (struct scm_ephemeron_table *et) +{ + struct scm_ephemeron_table *ret = scm_c_make_ephemeron_table (et->size); + + for (size_t idx = 0; idx < ret->size; idx++) + for (struct gc_ephemeron *e = scm_c_ephemeron_table_ref (et, idx); + e; + e = scm_c_ephemeron_next (e)) + { + SCM key = scm_c_ephemeron_key (e); + SCM value = scm_c_ephemeron_value (e); + struct gc_ephemeron *copy = scm_c_make_ephemeron (key, value); + scm_c_ephemeron_table_push_x (ret, idx, copy); + } + + return ret; +} + +SCM_DEFINE_STATIC (scm_ephemeron_table_p, "ephemeron-table?", 1, 0, 0, + (SCM x), + "Return @code{#t} if @var{x} is an ephemeron table, or " + "@code{#f} otherwise.") +#define FUNC_NAME s_scm_ephemeron_table_p +{ + return scm_from_bool (SCM_EPHEMERON_TABLE_P (x)); +} +#undef FUNC_NAME + +SCM_DEFINE_STATIC (scm_make_ephemeron_table, "make-ephemeron-table", 1, 0, 0, + (SCM size), + "Make an ephemeron table of size @var{size}.") +#define FUNC_NAME s_scm_make_ephemeron_table +{ + return PTR2SCM (scm_c_make_ephemeron_table (scm_to_size_t (size))); +} +#undef FUNC_NAME + +SCM_DEFINE_STATIC (scm_ephemeron_table_length, "ephemeron-table-length", 1, 0, 0, + (SCM et), + "Return the length of the ephemeron table @var{et}.") +#define FUNC_NAME s_scm_ephemeron_table_length +{ + SCM_VALIDATE_EPHEMERON_TABLE (1, et); + + return scm_from_size_t + (scm_c_ephemeron_table_length (scm_as_ephemeron_table (et))); +} +#undef FUNC_NAME + +SCM_DEFINE_STATIC (scm_ephemeron_table_ref, "ephemeron-table-ref", 2, 0, 0, + (SCM et, SCM idx), + "Return the ephemeron in slot @var{idx} of the ephemeron " + "table @var{et}, or @code{#f} if the slot is empty.") +#define FUNC_NAME s_scm_ephemeron_table_ref +{ + SCM_VALIDATE_EPHEMERON_TABLE (1, et); + SCM_ASSERT_RANGE (2, idx, + scm_to_size_t (idx) < scm_as_ephemeron_table (et)->size); + struct gc_ephemeron *ret = + scm_c_ephemeron_table_ref (scm_as_ephemeron_table (et), + scm_to_size_t (idx)); + return ret ? PTR2SCM (ret) : SCM_BOOL_F; +} +#undef FUNC_NAME + +SCM_DEFINE_STATIC (scm_ephemeron_table_push_x, "ephemeron-table-push!", 3, 0, 0, + (SCM et, SCM idx, SCM e), + "Push the ephemeron @var{e} onto slot @var{idx} of the " + "ephemeron table @var{et}.") +#define FUNC_NAME s_scm_ephemeron_table_push_x +{ + SCM_VALIDATE_EPHEMERON_TABLE (1, et); + SCM_ASSERT_RANGE (2, idx, + scm_to_size_t (idx) < scm_as_ephemeron_table (et)->size); + SCM_VALIDATE_EPHEMERON (3, e); + scm_c_ephemeron_table_push_x (scm_as_ephemeron_table (et), + scm_to_size_t (idx), scm_as_ephemeron (e)); + return SCM_UNSPECIFIED; +} +#undef FUNC_NAME + +SCM_DEFINE_STATIC (scm_ephemeron_table_try_push_x, "ephemeron-table-try-push!", + 4, 0, 0, (SCM et, SCM idx, SCM e, SCM tail), + "Push the ephemeron @var{e} onto slot @var{idx} of the " + "ephemeron table @var{et}, whose current value is " + "@var{tail}. On success, return @var{tail}. On failure, " + "return the value of slot @var{idx}.") +#define FUNC_NAME s_scm_ephemeron_table_try_push_x +{ + SCM_VALIDATE_EPHEMERON_TABLE (1, et); + SCM_ASSERT_RANGE (2, idx, + scm_to_size_t (idx) < scm_as_ephemeron_table (et)->size); + SCM_VALIDATE_EPHEMERON (3, e); + struct gc_ephemeron *expected = NULL; + if (!scm_is_eq (tail, SCM_BOOL_F)) + { + SCM_VALIDATE_EPHEMERON (4, tail); + expected = scm_as_ephemeron (tail); + } + struct gc_ephemeron *res = + scm_c_ephemeron_table_try_push_x (scm_as_ephemeron_table (et), + scm_to_size_t (idx), + scm_as_ephemeron (e), + expected); + return res ? PTR2SCM (res) : SCM_BOOL_F; +} +#undef FUNC_NAME + +int +scm_i_print_ephemeron_table (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED) +{ + scm_puts ("#<ephemeron-table ", port); + scm_uintprint (SCM_UNPACK (exp), 16, port); + scm_puts (")>", port); + return 1; +} + + + + +SCM +scm_c_ephemeron_hash_table_refq (struct scm_ephemeron_table *et, SCM key, + SCM default_value) +{ + size_t idx = scm_ihashq (key, et->size); + + for (struct gc_ephemeron *e = scm_c_ephemeron_table_ref (et, idx); + e; + e = scm_c_ephemeron_next (e)) + if (scm_is_eq (key, scm_c_ephemeron_key (e))) + return scm_c_ephemeron_value (e); + + return default_value; +} + +void +scm_c_ephemeron_hash_table_setq_x (struct scm_ephemeron_table *et, SCM key, + SCM value) +{ + size_t idx = scm_ihashq (key, et->size); + + struct gc_ephemeron *prev = scm_c_ephemeron_table_ref (et, idx); + struct gc_ephemeron *chain; + do + { + chain = prev; + for (struct gc_ephemeron *e = chain; e; e = scm_c_ephemeron_next (e)) + if (scm_is_eq (key, scm_c_ephemeron_key (e))) + { + scm_c_ephemeron_swap_x (e, value); + return; + } + struct gc_ephemeron *new_head = scm_c_make_ephemeron (key, value); + prev = scm_c_ephemeron_table_try_push_x (et, idx, new_head, chain); + } while (prev != chain); +} + + + + static void scm_init_ephemerons (void) { diff --git a/libguile/ephemerons.h b/libguile/ephemerons.h index 4829ffd2e..d1eb9e548 100644 --- a/libguile/ephemerons.h +++ b/libguile/ephemerons.h @@ -25,8 +25,46 @@ +struct gc_ephemeron; +struct scm_ephemeron_table; + +SCM_INTERNAL struct gc_ephemeron* scm_c_make_ephemeron (SCM k, SCM v); +SCM_INTERNAL SCM scm_c_ephemeron_key (struct gc_ephemeron *e); +SCM_INTERNAL SCM scm_c_ephemeron_value (struct gc_ephemeron *e); +SCM_INTERNAL struct gc_ephemeron* scm_c_ephemeron_next (struct gc_ephemeron *e); +SCM_INTERNAL SCM scm_c_ephemeron_swap_x (struct gc_ephemeron *e, SCM new_val); +SCM_INTERNAL void scm_c_ephemeron_mark_dead_x (struct gc_ephemeron *e); SCM_INTERNAL int scm_i_print_ephemeron (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED); +SCM_INTERNAL struct gc_ephemeron* scm_to_ephemeron (SCM e); +SCM_INTERNAL SCM scm_from_ephemeron (struct gc_ephemeron *e); + +SCM_INTERNAL struct scm_ephemeron_table* scm_c_make_ephemeron_table (size_t count); +SCM_INTERNAL size_t scm_c_ephemeron_table_length (struct scm_ephemeron_table *et); +SCM_INTERNAL struct gc_ephemeron* +scm_c_ephemeron_table_ref (struct scm_ephemeron_table *et, size_t idx); +SCM_INTERNAL void scm_c_ephemeron_table_push_x (struct scm_ephemeron_table *et, + size_t idx, + struct gc_ephemeron * e); +SCM_INTERNAL struct gc_ephemeron* +scm_c_ephemeron_table_try_push_x (struct scm_ephemeron_table *et, + size_t idx, + struct gc_ephemeron * e, + struct gc_ephemeron *prev); +SCM_INTERNAL struct scm_ephemeron_table* +scm_c_ephemeron_table_copy (struct scm_ephemeron_table *et); +SCM_INTERNAL int scm_i_print_ephemeron_table (SCM exp, SCM port, + scm_print_state *pstate SCM_UNUSED); +SCM_INTERNAL struct scm_ephemeron_table* scm_to_ephemeron_table (SCM e); +SCM_INTERNAL SCM scm_from_ephemeron_table (struct scm_ephemeron_table *e); + +SCM_INTERNAL SCM +scm_c_ephemeron_hash_table_refq (struct scm_ephemeron_table *et, SCM k, + SCM default_value); +SCM_INTERNAL void +scm_c_ephemeron_hash_table_setq_x (struct scm_ephemeron_table *et, SCM k, SCM v); + + SCM_INTERNAL void scm_register_ephemerons (void); #endif /* SCM_EPHEMERONS_H */ diff --git a/libguile/eval.c b/libguile/eval.c index de62613b3..21b2e8c17 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -56,7 +56,6 @@ #include "procprop.h" #include "programs.h" #include "smob.h" -#include "srcprop.h" #include "stackchk.h" #include "strings.h" #include "symbols.h" diff --git a/libguile/evalext.c b/libguile/evalext.c index 779d93c1d..418b32261 100644 --- a/libguile/evalext.c +++ b/libguile/evalext.c @@ -96,6 +96,7 @@ SCM_DEFINE (scm_self_evaluating_p, "self-evaluating?", 1, 0, 0, case scm_tc7_bitvector: case scm_tc7_finalizer: case scm_tc7_ephemeron: + case scm_tc7_ephemeron_table: case scm_tc7_thread: case scm_tcs_struct: return SCM_BOOL_T; diff --git a/libguile/expand.c b/libguile/expand.c index a308b9518..be95578e3 100644 --- a/libguile/expand.c +++ b/libguile/expand.c @@ -1,4 +1,4 @@ -/* Copyright 1995-2014,2016,2018-2020 +/* Copyright 1995-2014,2016,2018-2020,2025 Free Software Foundation, Inc. This file is part of Guile. @@ -37,7 +37,6 @@ #include "pairs.h" #include "ports.h" #include "print.h" -#include "srcprop.h" #include "strings.h" #include "symbols.h" #include "throw.h" @@ -61,42 +60,42 @@ static const char** exp_field_names[SCM_NUM_EXPANDED_TYPES]; /* The trailing underscores on these first to are to avoid spurious conflicts with macros defined on MinGW. */ -#define VOID_(src) \ - SCM_MAKE_EXPANDED_VOID(src) -#define CONST_(src, exp) \ - SCM_MAKE_EXPANDED_CONST(src, exp) -#define PRIMITIVE_REF(src, name) \ - SCM_MAKE_EXPANDED_PRIMITIVE_REF(src, name) -#define LEXICAL_REF(src, name, gensym) \ - SCM_MAKE_EXPANDED_LEXICAL_REF(src, name, gensym) -#define LEXICAL_SET(src, name, gensym, exp) \ - SCM_MAKE_EXPANDED_LEXICAL_SET(src, name, gensym, exp) -#define MODULE_REF(src, mod, name, public) \ - SCM_MAKE_EXPANDED_MODULE_REF(src, mod, name, public) -#define MODULE_SET(src, mod, name, public, exp) \ - SCM_MAKE_EXPANDED_MODULE_SET(src, mod, name, public, exp) -#define TOPLEVEL_REF(src, mod, name) \ - SCM_MAKE_EXPANDED_TOPLEVEL_REF(src, mod, name) -#define TOPLEVEL_SET(src, mod, name, exp) \ - SCM_MAKE_EXPANDED_TOPLEVEL_SET(src, mod, name, exp) -#define TOPLEVEL_DEFINE(src, mod, name, exp) \ - SCM_MAKE_EXPANDED_TOPLEVEL_DEFINE(src, mod, name, exp) -#define CONDITIONAL(src, test, consequent, alternate) \ - SCM_MAKE_EXPANDED_CONDITIONAL(src, test, consequent, alternate) -#define PRIMCALL(src, name, exps) \ - SCM_MAKE_EXPANDED_PRIMCALL(src, name, exps) -#define CALL(src, proc, exps) \ - SCM_MAKE_EXPANDED_CALL(src, proc, exps) -#define SEQ(src, head, tail) \ - SCM_MAKE_EXPANDED_SEQ(src, head, tail) -#define LAMBDA(src, meta, body) \ - SCM_MAKE_EXPANDED_LAMBDA(src, meta, body) -#define LAMBDA_CASE(src, req, opt, rest, kw, inits, gensyms, body, alternate) \ - SCM_MAKE_EXPANDED_LAMBDA_CASE(src, req, opt, rest, kw, inits, gensyms, body, alternate) -#define LET(src, names, gensyms, vals, body) \ - SCM_MAKE_EXPANDED_LET(src, names, gensyms, vals, body) -#define LETREC(src, in_order_p, names, gensyms, vals, body) \ - SCM_MAKE_EXPANDED_LETREC(src, in_order_p, names, gensyms, vals, body) +#define VOID_() \ + SCM_MAKE_EXPANDED_VOID(SCM_BOOL_F) +#define CONST_(exp) \ + SCM_MAKE_EXPANDED_CONST(SCM_BOOL_F, exp) +#define PRIMITIVE_REF(name) \ + SCM_MAKE_EXPANDED_PRIMITIVE_REF(SCM_BOOL_F, name) +#define LEXICAL_REF(name, gensym) \ + SCM_MAKE_EXPANDED_LEXICAL_REF(SCM_BOOL_F, name, gensym) +#define LEXICAL_SET(name, gensym, exp) \ + SCM_MAKE_EXPANDED_LEXICAL_SET(SCM_BOOL_F, name, gensym, exp) +#define MODULE_REF(mod, name, public) \ + SCM_MAKE_EXPANDED_MODULE_REF(SCM_BOOL_F, mod, name, public) +#define MODULE_SET(mod, name, public, exp) \ + SCM_MAKE_EXPANDED_MODULE_SET(SCM_BOOL_F, mod, name, public, exp) +#define TOPLEVEL_REF(mod, name) \ + SCM_MAKE_EXPANDED_TOPLEVEL_REF(SCM_BOOL_F, mod, name) +#define TOPLEVEL_SET(mod, name, exp) \ + SCM_MAKE_EXPANDED_TOPLEVEL_SET(SCM_BOOL_F, mod, name, exp) +#define TOPLEVEL_DEFINE(mod, name, exp) \ + SCM_MAKE_EXPANDED_TOPLEVEL_DEFINE(SCM_BOOL_F, mod, name, exp) +#define CONDITIONAL(test, consequent, alternate) \ + SCM_MAKE_EXPANDED_CONDITIONAL(SCM_BOOL_F, test, consequent, alternate) +#define PRIMCALL(name, exps) \ + SCM_MAKE_EXPANDED_PRIMCALL(SCM_BOOL_F, name, exps) +#define CALL(proc, exps) \ + SCM_MAKE_EXPANDED_CALL(SCM_BOOL_F, proc, exps) +#define SEQ(head, tail) \ + SCM_MAKE_EXPANDED_SEQ(SCM_BOOL_F, head, tail) +#define LAMBDA(meta, body) \ + SCM_MAKE_EXPANDED_LAMBDA(SCM_BOOL_F, meta, body) +#define LAMBDA_CASE(req, opt, rest, kw, inits, gensyms, body, alternate) \ + SCM_MAKE_EXPANDED_LAMBDA_CASE(SCM_BOOL_F, req, opt, rest, kw, inits, gensyms, body, alternate) +#define LET(names, gensyms, vals, body) \ + SCM_MAKE_EXPANDED_LET(SCM_BOOL_F, names, gensyms, vals, body) +#define LETREC(in_order_p, names, gensyms, vals, body) \ + SCM_MAKE_EXPANDED_LETREC(SCM_BOOL_F, in_order_p, names, gensyms, vals, body) #define CAR(x) SCM_CAR(x) #define CDR(x) SCM_CDR(x) @@ -213,71 +212,22 @@ SCM_KEYWORD (kw_rest, "rest"); -/* Signal a syntax error. We distinguish between the form that caused the - * error and the enclosing expression. The error message will print out as - * shown in the following pattern. The file name and line number are only - * given when they can be determined from the erroneous form or from the - * enclosing expression. - * - * <filename>: In procedure memoization: - * <filename>: In file <name>, line <nr>: <error-message> in <expression>. */ - static void syntax_error (const char* const msg, const SCM form, const SCM expr) { SCM msg_string = scm_from_utf8_string (msg); - SCM filename = SCM_BOOL_F; - SCM linenr = SCM_BOOL_F; const char *format; SCM args; - if (scm_is_pair (form)) - { - filename = scm_source_property (form, scm_sym_filename); - linenr = scm_source_property (form, scm_sym_line); - } - - if (scm_is_false (filename) && scm_is_false (linenr) && scm_is_pair (expr)) - { - filename = scm_source_property (expr, scm_sym_filename); - linenr = scm_source_property (expr, scm_sym_line); - } - if (!SCM_UNBNDP (expr)) { - if (scm_is_true (filename)) - { - format = "In file ~S, line ~S: ~A ~S in expression ~S."; - args = scm_list_5 (filename, linenr, msg_string, form, expr); - } - else if (scm_is_true (linenr)) - { - format = "In line ~S: ~A ~S in expression ~S."; - args = scm_list_4 (linenr, msg_string, form, expr); - } - else - { - format = "~A ~S in expression ~S."; - args = scm_list_3 (msg_string, form, expr); - } + format = "~A ~S in expression ~S."; + args = scm_list_3 (msg_string, form, expr); } else { - if (scm_is_true (filename)) - { - format = "In file ~S, line ~S: ~A ~S."; - args = scm_list_4 (filename, linenr, msg_string, form); - } - else if (scm_is_true (linenr)) - { - format = "In line ~S: ~A ~S."; - args = scm_list_3 (linenr, msg_string, form); - } - else - { - format = "~A ~S."; - args = scm_list_2 (msg_string, form); - } + format = "~A ~S."; + args = scm_list_2 (msg_string, form); } scm_error (syntax_error_key, "memoization", format, args, SCM_BOOL_F); @@ -365,23 +315,22 @@ expand (SCM exp, SCM env) syntax_error ("expected a proper list", exp, SCM_UNDEFINED); if (SCM_EXPANDED_TYPE (proc) == SCM_EXPANDED_PRIMITIVE_REF) - return PRIMCALL (scm_source_properties (exp), - SCM_EXPANDED_REF (proc, PRIMITIVE_REF, NAME), + return PRIMCALL (SCM_EXPANDED_REF (proc, PRIMITIVE_REF, NAME), args); else - return CALL (scm_source_properties (exp), proc, args); + return CALL (proc, args); } } else if (scm_is_symbol (exp)) { SCM gensym = expand_env_lexical_gensym (env, exp); if (scm_is_true (gensym)) - return LEXICAL_REF (SCM_BOOL_F, exp, gensym); + return LEXICAL_REF (exp, gensym); else - return TOPLEVEL_REF (SCM_BOOL_F, SCM_BOOL_F, exp); + return TOPLEVEL_REF (SCM_BOOL_F, exp); } else - return CONST_ (SCM_BOOL_F, exp); + return CONST_ (exp); } static SCM @@ -402,8 +351,7 @@ expand_sequence (const SCM forms, const SCM env) if (scm_is_null (CDR (forms))) return expand (CAR (forms), env); else - return SEQ (scm_source_properties (forms), - expand (CAR (forms), env), + return SEQ (expand (CAR (forms), env), expand_sequence (CDR (forms), env)); } @@ -418,8 +366,7 @@ expand_at (SCM expr, SCM env SCM_UNUSED) ASSERT_SYNTAX (scm_ilength (CADR (expr)) > 0, s_bad_expression, expr); ASSERT_SYNTAX (scm_is_symbol (CADDR (expr)), s_bad_expression, expr); - return MODULE_REF (scm_source_properties (expr), - CADR (expr), CADDR (expr), SCM_BOOL_T); + return MODULE_REF (CADR (expr), CADDR (expr), SCM_BOOL_T); } static SCM @@ -429,11 +376,10 @@ expand_atat (SCM expr, SCM env SCM_UNUSED) ASSERT_SYNTAX (scm_is_symbol (CADDR (expr)), s_bad_expression, expr); if (scm_is_eq (CADR (expr), sym_primitive)) - return PRIMITIVE_REF (scm_source_properties (expr), CADDR (expr)); + return PRIMITIVE_REF (CADDR (expr)); ASSERT_SYNTAX (scm_ilength (CADR (expr)) > 0, s_bad_expression, expr); - return MODULE_REF (scm_source_properties (expr), - CADR (expr), CADDR (expr), SCM_BOOL_F); + return MODULE_REF (CADR (expr), CADDR (expr), SCM_BOOL_F); } static SCM @@ -442,17 +388,16 @@ expand_and (SCM expr, SCM env) const SCM cdr_expr = CDR (expr); if (scm_is_null (cdr_expr)) - return CONST_ (SCM_BOOL_F, SCM_BOOL_T); + return CONST_ (SCM_BOOL_T); ASSERT_SYNTAX (scm_is_pair (cdr_expr), s_bad_expression, expr); if (scm_is_null (CDR (cdr_expr))) return expand (CAR (cdr_expr), env); else - return CONDITIONAL (scm_source_properties (expr), - expand (CAR (cdr_expr), env), + return CONDITIONAL (expand (CAR (cdr_expr), env), expand_and (cdr_expr, env), - CONST_ (SCM_BOOL_F, SCM_BOOL_F)); + CONST_ (SCM_BOOL_F)); } static SCM @@ -480,7 +425,7 @@ expand_cond_clauses (SCM clause, SCM rest, int elp, int alp, SCM env) } if (scm_is_null (rest)) - rest = VOID_ (SCM_BOOL_F); + rest = VOID_ (); else rest = expand_cond_clauses (CAR (rest), CDR (rest), elp, alp, env); @@ -492,22 +437,17 @@ expand_cond_clauses (SCM clause, SCM rest, int elp, int alp, SCM env) SCM new_env = scm_acons (tmp, tmp, env); ASSERT_SYNTAX (length > 2, s_missing_recipient, clause); ASSERT_SYNTAX (length == 3, s_extra_expression, clause); - return LET (SCM_BOOL_F, - scm_list_1 (tmp), + return LET (scm_list_1 (tmp), scm_list_1 (tmp), scm_list_1 (expand (test, env)), - CONDITIONAL (SCM_BOOL_F, - LEXICAL_REF (SCM_BOOL_F, tmp, tmp), - CALL (SCM_BOOL_F, - expand (CADDR (clause), new_env), - scm_list_1 (LEXICAL_REF (SCM_BOOL_F, - tmp, tmp))), + CONDITIONAL (LEXICAL_REF (tmp, tmp), + CALL (expand (CADDR (clause), new_env), + scm_list_1 (LEXICAL_REF (tmp, tmp))), rest)); } /* FIXME length == 1 case */ else - return CONDITIONAL (SCM_BOOL_F, - expand (test, env), + return CONDITIONAL (expand (test, env), expand_sequence (CDR (clause), env), rest); } @@ -552,15 +492,14 @@ expand_define (SCM expr, SCM env) { ASSERT_SYNTAX_2 (scm_is_symbol (CAR (variable)), s_bad_variable, variable, expr); return TOPLEVEL_DEFINE - (scm_source_properties (expr), - SCM_BOOL_F, + (SCM_BOOL_F, CAR (variable), expand_lambda (scm_cons (scm_sym_lambda, scm_cons (CDR (variable), body)), env)); } ASSERT_SYNTAX_2 (scm_is_symbol (variable), s_bad_variable, variable, expr); ASSERT_SYNTAX (scm_ilength (body) == 1, s_expression, expr); - return TOPLEVEL_DEFINE (scm_source_properties (expr), SCM_BOOL_F, variable, + return TOPLEVEL_DEFINE (SCM_BOOL_F, variable, expand (CAR (body), env)); } @@ -574,7 +513,7 @@ expand_eval_when (SCM expr, SCM env) || scm_is_true (scm_memq (sym_load, CADR (expr)))) return expand_sequence (CDDR (expr), env); else - return VOID_ (scm_source_properties (expr)); + return VOID_ (); } static SCM @@ -583,12 +522,11 @@ expand_if (SCM expr, SCM env SCM_UNUSED) const SCM cdr_expr = CDR (expr); const long length = scm_ilength (cdr_expr); ASSERT_SYNTAX (length == 2 || length == 3, s_expression, expr); - return CONDITIONAL (scm_source_properties (expr), - expand (CADR (expr), env), + return CONDITIONAL (expand (CADR (expr), env), expand (CADDR (expr), env), ((length == 3) ? expand (CADDDR (expr), env) - : VOID_ (SCM_BOOL_F))); + : VOID_ ())); } /* A helper function for expand_lambda to support checking for duplicate @@ -666,15 +604,14 @@ expand_lambda_case (SCM clause, SCM alternate, SCM env) if (scm_is_true (alternate) && !(SCM_EXPANDED_P (alternate) && SCM_EXPANDED_TYPE (alternate) == SCM_EXPANDED_LAMBDA_CASE)) abort (); - return LAMBDA_CASE (SCM_BOOL_F, req, SCM_BOOL_F, rest, SCM_BOOL_F, + return LAMBDA_CASE (req, SCM_BOOL_F, rest, SCM_BOOL_F, SCM_EOL, vars, body, alternate); } static SCM expand_lambda (SCM expr, SCM env) { - return LAMBDA (scm_source_properties (expr), - SCM_EOL, + return LAMBDA (SCM_EOL, expand_lambda_case (CDR (expr), SCM_BOOL_F, env)); } @@ -777,7 +714,7 @@ expand_lambda_star_case (SCM clause, SCM alternate, SCM env) vars = scm_cons (scm_gensym (SCM_UNDEFINED), vars); env = scm_acons (x, CAR (vars), env); if (scm_is_symbol (x)) - inits = scm_cons (CONST_ (SCM_BOOL_F, SCM_BOOL_F), inits); + inits = scm_cons (CONST_ (SCM_BOOL_F), inits); else { ASSERT_SYNTAX (scm_ilength (x) == 2 && scm_is_symbol (CAR (x)), @@ -845,15 +782,14 @@ expand_lambda_star_case (SCM clause, SCM alternate, SCM env) inits = scm_reverse_x (inits, SCM_UNDEFINED); body = expand_sequence (body, env); - return LAMBDA_CASE (SCM_BOOL_F, req, opt, rest, kw, inits, vars, body, + return LAMBDA_CASE (req, opt, rest, kw, inits, vars, body, alternate); } static SCM expand_lambda_star (SCM expr, SCM env) { - return LAMBDA (scm_source_properties (expr), - SCM_EOL, + return LAMBDA (SCM_EOL, expand_lambda_star_case (CDR (expr), SCM_BOOL_F, env)); } @@ -875,8 +811,7 @@ expand_case_lambda (SCM expr, SCM env) { ASSERT_SYNTAX (scm_is_pair (CDR (expr)), s_missing_expression, expr); - return LAMBDA (scm_source_properties (expr), - SCM_EOL, + return LAMBDA (SCM_EOL, expand_case_lambda_clauses (CADR (expr), CDDR (expr), env)); } @@ -898,8 +833,7 @@ expand_case_lambda_star (SCM expr, SCM env) { ASSERT_SYNTAX (scm_is_pair (CDR (expr)), s_missing_expression, expr); - return LAMBDA (scm_source_properties (expr), - SCM_EOL, + return LAMBDA (SCM_EOL, expand_case_lambda_star_clauses (CADR (expr), CDDR (expr), env)); } @@ -973,16 +907,14 @@ expand_named_let (const SCM expr, SCM env) inner_env = expand_env_extend (inner_env, var_names, var_syms); return LETREC - (scm_source_properties (expr), SCM_BOOL_F, + (SCM_BOOL_F, scm_list_1 (name), scm_list_1 (name_sym), - scm_list_1 (LAMBDA (SCM_BOOL_F, - SCM_EOL, - LAMBDA_CASE (SCM_BOOL_F, var_names, SCM_EOL, SCM_BOOL_F, + scm_list_1 (LAMBDA (SCM_EOL, + LAMBDA_CASE (var_names, SCM_EOL, SCM_BOOL_F, SCM_BOOL_F, SCM_EOL, var_syms, expand_sequence (CDDDR (expr), inner_env), SCM_BOOL_F))), - CALL (SCM_BOOL_F, - LEXICAL_REF (SCM_BOOL_F, name, name_sym), + CALL (LEXICAL_REF (name, name_sym), expand_exprs (inits, env))); } @@ -1010,8 +942,7 @@ expand_let (SCM expr, SCM env) { SCM var_names, var_syms, inits; transform_bindings (bindings, expr, &var_names, &var_syms, &inits); - return LET (SCM_BOOL_F, - var_names, var_syms, expand_exprs (inits, env), + return LET (var_names, var_syms, expand_exprs (inits, env), expand_sequence (CDDR (expr), expand_env_extend (env, var_names, var_syms))); @@ -1037,7 +968,7 @@ expand_letrec_helper (SCM expr, SCM env, SCM in_order_p) SCM var_names, var_syms, inits; transform_bindings (bindings, expr, &var_names, &var_syms, &inits); env = expand_env_extend (env, var_names, var_syms); - return LETREC (SCM_BOOL_F, in_order_p, + return LETREC (in_order_p, var_names, var_syms, expand_exprs (inits, env), expand_sequence (CDDR (expr), env)); } @@ -1071,7 +1002,7 @@ expand_letstar_clause (SCM bindings, SCM body, SCM env SCM_UNUSED) sym = scm_gensym (SCM_UNDEFINED); init = CADR (bind); - return LET (SCM_BOOL_F, scm_list_1 (name), scm_list_1 (sym), + return LET (scm_list_1 (name), scm_list_1 (sym), scm_list_1 (expand (init, env)), expand_letstar_clause (CDR (bindings), body, scm_acons (name, sym, env))); @@ -1097,16 +1028,14 @@ expand_or (SCM expr, SCM env SCM_UNUSED) ASSERT_SYNTAX (length >= 0, s_bad_expression, expr); if (scm_is_null (CDR (expr))) - return CONST_ (SCM_BOOL_F, SCM_BOOL_F); + return CONST_ (SCM_BOOL_F); else { SCM tmp = scm_gensym (SCM_UNDEFINED); - return LET (SCM_BOOL_F, - scm_list_1 (tmp), scm_list_1 (tmp), + return LET (scm_list_1 (tmp), scm_list_1 (tmp), scm_list_1 (expand (CADR (expr), env)), - CONDITIONAL (SCM_BOOL_F, - LEXICAL_REF (SCM_BOOL_F, tmp, tmp), - LEXICAL_REF (SCM_BOOL_F, tmp, tmp), + CONDITIONAL (LEXICAL_REF (tmp, tmp), + LEXICAL_REF (tmp, tmp), expand_or (CDR (expr), scm_acons (tmp, tmp, env)))); } @@ -1121,7 +1050,7 @@ expand_quote (SCM expr, SCM env SCM_UNUSED) ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr); ASSERT_SYNTAX (scm_ilength (cdr_expr) == 1, s_expression, expr); quotee = CAR (cdr_expr); - return CONST_ (scm_source_properties (expr), quotee); + return CONST_ (quotee); } static SCM @@ -1139,18 +1068,15 @@ expand_set_x (SCM expr, SCM env) switch (SCM_EXPANDED_TYPE (vmem)) { case SCM_EXPANDED_LEXICAL_REF: - return LEXICAL_SET (scm_source_properties (expr), - SCM_EXPANDED_REF (vmem, LEXICAL_REF, NAME), + return LEXICAL_SET (SCM_EXPANDED_REF (vmem, LEXICAL_REF, NAME), SCM_EXPANDED_REF (vmem, LEXICAL_REF, GENSYM), expand (CADDR (expr), env)); case SCM_EXPANDED_TOPLEVEL_REF: - return TOPLEVEL_SET (scm_source_properties (expr), - SCM_EXPANDED_REF (vmem, TOPLEVEL_REF, MOD), + return TOPLEVEL_SET (SCM_EXPANDED_REF (vmem, TOPLEVEL_REF, MOD), SCM_EXPANDED_REF (vmem, TOPLEVEL_REF, NAME), expand (CADDR (expr), env)); case SCM_EXPANDED_MODULE_REF: - return MODULE_SET (scm_source_properties (expr), - SCM_EXPANDED_REF (vmem, MODULE_REF, MOD), + return MODULE_SET (SCM_EXPANDED_REF (vmem, MODULE_REF, MOD), SCM_EXPANDED_REF (vmem, MODULE_REF, NAME), SCM_EXPANDED_REF (vmem, MODULE_REF, PUBLIC), expand (CADDR (expr), env)); @@ -1282,27 +1208,25 @@ compute_assigned (SCM exp, SCM assigned) static SCM box_value (SCM exp) { - return PRIMCALL (SCM_BOOL_F, scm_from_latin1_symbol ("make-variable"), + return PRIMCALL (scm_from_latin1_symbol ("make-variable"), scm_list_1 (exp)); } static SCM box_lexical (SCM name, SCM sym) { - return LEXICAL_SET (SCM_BOOL_F, name, sym, - box_value (LEXICAL_REF (SCM_BOOL_F, name, sym))); + return LEXICAL_SET (name, sym, + box_value (LEXICAL_REF (name, sym))); } static SCM -init_if_unbound (SCM src, SCM name, SCM sym, SCM init) +init_if_unbound (SCM name, SCM sym, SCM init) { - return CONDITIONAL (src, - PRIMCALL (src, - scm_from_latin1_symbol ("eq?"), - scm_list_2 (LEXICAL_REF (src, name, sym), + return CONDITIONAL (PRIMCALL (scm_from_latin1_symbol ("eq?"), + scm_list_2 (LEXICAL_REF (name, sym), const_unbound)), - LEXICAL_SET (src, name, sym, init), - VOID_ (src)); + LEXICAL_SET (name, sym, init), + VOID_ ()); } static SCM @@ -1310,11 +1234,9 @@ init_boxes (SCM names, SCM syms, SCM vals, SCM body) { if (scm_is_null (names)) return body; - return SEQ (SCM_BOOL_F, - PRIMCALL - (SCM_BOOL_F, - scm_from_latin1_symbol ("variable-set!"), - scm_list_2 (LEXICAL_REF (SCM_BOOL_F, CAR (names), CAR (syms)), + return SEQ (PRIMCALL + (scm_from_latin1_symbol ("variable-set!"), + scm_list_2 (LEXICAL_REF (CAR (names), CAR (syms)), CAR (vals))), init_boxes (CDR (names), CDR (syms), CDR (vals), body)); } @@ -1347,100 +1269,87 @@ convert_assignment (SCM exp, SCM assigned) if (scm_is_true (scm_hashq_ref (assigned, sym, SCM_BOOL_F))) return PRIMCALL - (REF (exp, LEXICAL_REF, SRC), - scm_from_latin1_symbol ("variable-ref"), + (scm_from_latin1_symbol ("variable-ref"), scm_list_1 (exp)); return exp; } case SCM_EXPANDED_LEXICAL_SET: return PRIMCALL - (REF (exp, LEXICAL_SET, SRC), - scm_from_latin1_symbol ("variable-set!"), - scm_list_2 (LEXICAL_REF (REF (exp, LEXICAL_SET, SRC), - REF (exp, LEXICAL_SET, NAME), + (scm_from_latin1_symbol ("variable-set!"), + scm_list_2 (LEXICAL_REF (REF (exp, LEXICAL_SET, NAME), REF (exp, LEXICAL_SET, GENSYM)), convert_assignment (REF (exp, LEXICAL_SET, EXP), assigned))); case SCM_EXPANDED_MODULE_SET: return MODULE_SET - (REF (exp, MODULE_SET, SRC), - REF (exp, MODULE_SET, MOD), + (REF (exp, MODULE_SET, MOD), REF (exp, MODULE_SET, NAME), REF (exp, MODULE_SET, PUBLIC), convert_assignment (REF (exp, MODULE_SET, EXP), assigned)); case SCM_EXPANDED_TOPLEVEL_SET: return TOPLEVEL_SET - (REF (exp, TOPLEVEL_SET, SRC), - REF (exp, TOPLEVEL_SET, MOD), + (REF (exp, TOPLEVEL_SET, MOD), REF (exp, TOPLEVEL_SET, NAME), convert_assignment (REF (exp, TOPLEVEL_SET, EXP), assigned)); case SCM_EXPANDED_TOPLEVEL_DEFINE: return TOPLEVEL_DEFINE - (REF (exp, TOPLEVEL_DEFINE, SRC), - REF (exp, TOPLEVEL_DEFINE, MOD), + (REF (exp, TOPLEVEL_DEFINE, MOD), REF (exp, TOPLEVEL_DEFINE, NAME), convert_assignment (REF (exp, TOPLEVEL_DEFINE, EXP), assigned)); case SCM_EXPANDED_CONDITIONAL: return CONDITIONAL - (REF (exp, CONDITIONAL, SRC), - convert_assignment (REF (exp, CONDITIONAL, TEST), assigned), + (convert_assignment (REF (exp, CONDITIONAL, TEST), assigned), convert_assignment (REF (exp, CONDITIONAL, CONSEQUENT), assigned), convert_assignment (REF (exp, CONDITIONAL, ALTERNATE), assigned)); case SCM_EXPANDED_CALL: return CALL - (REF (exp, CALL, SRC), - convert_assignment (REF (exp, CALL, PROC), assigned), + (convert_assignment (REF (exp, CALL, PROC), assigned), convert_assignment (REF (exp, CALL, ARGS), assigned)); case SCM_EXPANDED_PRIMCALL: return PRIMCALL - (REF (exp, PRIMCALL, SRC), - REF (exp, PRIMCALL, NAME), + (REF (exp, PRIMCALL, NAME), convert_assignment (REF (exp, PRIMCALL, ARGS), assigned)); case SCM_EXPANDED_SEQ: return SEQ - (REF (exp, SEQ, SRC), - convert_assignment (REF (exp, SEQ, HEAD), assigned), + (convert_assignment (REF (exp, SEQ, HEAD), assigned), convert_assignment (REF (exp, SEQ, TAIL), assigned)); case SCM_EXPANDED_LAMBDA: return LAMBDA - (REF (exp, LAMBDA, SRC), - REF (exp, LAMBDA, META), + (REF (exp, LAMBDA, META), scm_is_false (REF (exp, LAMBDA, BODY)) /* Give a body to case-lambda with no clauses. */ - ? LAMBDA_CASE (SCM_BOOL_F, SCM_EOL, SCM_EOL, SCM_BOOL_F, SCM_BOOL_F, + ? LAMBDA_CASE (SCM_EOL, SCM_EOL, SCM_BOOL_F, SCM_BOOL_F, SCM_EOL, SCM_EOL, PRIMCALL - (SCM_BOOL_F, - scm_from_latin1_symbol ("throw"), - scm_list_5 (CONST_ (SCM_BOOL_F, scm_args_number_key), - CONST_ (SCM_BOOL_F, SCM_BOOL_F), - CONST_ (SCM_BOOL_F, scm_from_latin1_string + (scm_from_latin1_symbol ("throw"), + scm_list_5 (CONST_ (scm_args_number_key), + CONST_ (SCM_BOOL_F), + CONST_ (scm_from_latin1_string ("Wrong number of arguments")), - CONST_ (SCM_BOOL_F, SCM_EOL), - CONST_ (SCM_BOOL_F, SCM_BOOL_F))), + CONST_ (SCM_EOL), + CONST_ (SCM_BOOL_F))), SCM_BOOL_F) : convert_assignment (REF (exp, LAMBDA, BODY), assigned)); case SCM_EXPANDED_LAMBDA_CASE: { - SCM src, req, opt, rest, kw, inits, syms, body, alt; + SCM req, opt, rest, kw, inits, syms, body, alt; SCM namewalk, symwalk, new_inits, seq; /* Box assigned formals. Since initializers can capture previous formals, we convert initializers to be in the body instead of in the "header". */ - src = REF (exp, LAMBDA_CASE, SRC); req = REF (exp, LAMBDA_CASE, REQ); opt = REF (exp, LAMBDA_CASE, OPT); rest = REF (exp, LAMBDA_CASE, REST); @@ -1470,7 +1379,7 @@ convert_assignment (SCM exp, SCM assigned) inits = CDR (inits)) { SCM name = CAR (namewalk), sym = CAR (symwalk), init = CAR (inits); - seq = scm_cons (init_if_unbound (src, name, sym, init), seq); + seq = scm_cons (init_if_unbound (name, sym, init), seq); if (scm_is_true (scm_hashq_ref (assigned, sym, SCM_BOOL_F))) seq = scm_cons (box_lexical (name, sym), seq); } @@ -1489,23 +1398,22 @@ convert_assignment (SCM exp, SCM assigned) symwalk = CDR (symwalk), inits = CDR (inits)) { SCM sym = CAR (symwalk), init = CAR (inits); - seq = scm_cons (init_if_unbound (src, SCM_BOOL_F, sym, init), seq); + seq = scm_cons (init_if_unbound (SCM_BOOL_F, sym, init), seq); if (scm_is_true (scm_hashq_ref (assigned, sym, SCM_BOOL_F))) seq = scm_cons (box_lexical (SCM_BOOL_F, sym), seq); } for (; scm_is_pair (seq); seq = CDR (seq)) - body = SEQ (src, CAR (seq), body); + body = SEQ (CAR (seq), body); return LAMBDA_CASE - (src, req, opt, rest, kw, new_inits, syms, body, alt); + (req, opt, rest, kw, new_inits, syms, body, alt); } case SCM_EXPANDED_LET: { - SCM src, names, syms, vals, body, new_vals, walk; + SCM names, syms, vals, body, new_vals, walk; - src = REF (exp, LET, SRC); names = REF (exp, LET, NAMES); syms = REF (exp, LET, GENSYMS); vals = convert_assignment (REF (exp, LET, VALS), assigned); @@ -1523,28 +1431,26 @@ convert_assignment (SCM exp, SCM assigned) } new_vals = scm_reverse (new_vals); - return LET (src, names, syms, new_vals, body); + return LET (names, syms, new_vals, body); } case SCM_EXPANDED_LETREC: { - SCM src, names, syms, vals, empty_box, boxes, body; + SCM names, syms, vals, empty_box, boxes, body; - src = REF (exp, LETREC, SRC); names = REF (exp, LETREC, NAMES); syms = REF (exp, LETREC, GENSYMS); vals = convert_assignment (REF (exp, LETREC, VALS), assigned); body = convert_assignment (REF (exp, LETREC, BODY), assigned); empty_box = - PRIMCALL (SCM_BOOL_F, - scm_from_latin1_symbol ("make-undefined-variable"), + PRIMCALL (scm_from_latin1_symbol ("make-undefined-variable"), SCM_EOL); boxes = scm_make_list (scm_length (names), empty_box); if (scm_is_true (REF (exp, LETREC, IN_ORDER_P))) return LET - (src, names, syms, boxes, + (names, syms, boxes, init_boxes (names, syms, vals, body)); else { @@ -1554,17 +1460,16 @@ convert_assignment (SCM exp, SCM assigned) { SCM tmp = scm_gensym (SCM_UNDEFINED); tmps = scm_cons (tmp, tmps); - inits = scm_cons (LEXICAL_REF (SCM_BOOL_F, SCM_BOOL_F, tmp), + inits = scm_cons (LEXICAL_REF (SCM_BOOL_F, tmp), inits); } tmps = scm_reverse (tmps); inits = scm_reverse (inits); return LET - (src, names, syms, boxes, - SEQ (src, - LET (src, names, tmps, vals, - init_boxes (names, syms, inits, VOID_ (src))), + (names, syms, boxes, + SEQ (LET (names, tmps, vals, + init_boxes (names, syms, inits, VOID_ ())), body)); } } @@ -1654,7 +1559,7 @@ scm_init_expand () exp_vtable_list = scm_cons (exp_vtables[n], exp_vtable_list); const_unbound = - CONST_ (SCM_BOOL_F, scm_list_1 (scm_from_latin1_symbol ("unbound"))); + CONST_ (scm_list_1 (scm_from_latin1_symbol ("unbound"))); scm_c_define_gsubr ("convert-assignment", 1, 0, 0, scm_convert_assignment); diff --git a/libguile/fluids.c b/libguile/fluids.c index ebdb48fbc..a2fadbd8a 100644 --- a/libguile/fluids.c +++ b/libguile/fluids.c @@ -1,4 +1,4 @@ -/* Copyright 1996-1997,2000-2001,2004,2006-2013,2017-2018 +/* Copyright 1996-1997,2000-2001,2004,2006-2013,2017-2018,2025 Free Software Foundation, Inc. This file is part of Guile. @@ -30,6 +30,7 @@ #include "cache-internal.h" #include "deprecation.h" #include "dynwind.h" +#include "ephemerons.h" #include "eval.h" #include "gsubr.h" #include "hashtab.h" @@ -132,7 +133,7 @@ restore_dynamic_state (SCM saved, scm_t_dynamic_state *state) else entry->key = entry->value = 0; } - state->values = saved; + state->values = scm_to_ephemeron_table (saved); state->has_aliased_values = 1; } @@ -140,7 +141,7 @@ static inline SCM save_dynamic_state (scm_t_dynamic_state *state) { int slot; - SCM saved = state->values; + SCM saved = scm_from_ephemeron_table (state->values); for (slot = 0; slot < SCM_CACHE_SIZE; slot++) { struct scm_cache_entry *entry = &state->cache.entries[slot]; @@ -157,14 +158,14 @@ save_dynamic_state (scm_t_dynamic_state *state) cache. */ scm_hashq_set_x (state->thread_local_values, key, value); } - else if (!scm_is_eq (scm_weak_table_refq (state->values, key, - SCM_UNDEFINED), + else if (!scm_is_eq (scm_c_ephemeron_hash_table_refq (state->values, key, + SCM_UNDEFINED), value)) { if (state->has_aliased_values) saved = scm_acons (key, value, saved); else - scm_weak_table_putq_x (state->values, key, value); + scm_c_ephemeron_hash_table_setq_x (state->values, key, value); } } state->has_aliased_values = 1; @@ -178,21 +179,8 @@ saved_dynamic_state_ref (SCM saved, SCM fluid, SCM dflt) if (scm_is_eq (SCM_CAAR (saved), fluid)) return SCM_CDAR (saved); - return scm_weak_table_refq (saved, fluid, dflt); -} - -static SCM -add_entry (void *data, SCM k, SCM v, SCM result) -{ - scm_weak_table_putq_x (result, k, v); - return result; -} - -static SCM -copy_value_table (SCM tab) -{ - SCM ret = scm_c_make_weak_table (0, SCM_WEAK_TABLE_KIND_KEY); - return scm_c_weak_table_fold (add_entry, NULL, ret, tab); + return scm_c_ephemeron_hash_table_refq (scm_to_ephemeron_table (saved), + fluid, dflt); } @@ -329,15 +317,17 @@ fluid_set_x (scm_t_dynamic_state *dynamic_state, SCM fluid, SCM value) if (dynamic_state->has_aliased_values) { - if (scm_is_eq (scm_weak_table_refq (dynamic_state->values, - fluid, SCM_UNDEFINED), - value)) + SCM existing = + scm_c_ephemeron_hash_table_refq (dynamic_state->values, fluid, + SCM_UNDEFINED); + if (scm_is_eq (existing, value)) return; - dynamic_state->values = copy_value_table (dynamic_state->values); + dynamic_state->values = + scm_c_ephemeron_table_copy (dynamic_state->values); dynamic_state->has_aliased_values = 0; } - scm_weak_table_putq_x (dynamic_state->values, fluid, value); + scm_c_ephemeron_hash_table_setq_x (dynamic_state->values, fluid, value); } } @@ -356,8 +346,8 @@ fluid_ref (scm_t_dynamic_state *dynamic_state, SCM fluid) val = scm_hashq_ref (dynamic_state->thread_local_values, fluid, SCM_I_FLUID_DEFAULT (fluid)); else - val = scm_weak_table_refq (dynamic_state->values, fluid, - SCM_I_FLUID_DEFAULT (fluid)); + val = scm_c_ephemeron_hash_table_refq (dynamic_state->values, fluid, + SCM_I_FLUID_DEFAULT (fluid)); /* Cache this lookup. */ fluid_set_x (dynamic_state, fluid, val); @@ -420,8 +410,8 @@ SCM_DEFINE (scm_fluid_ref_star, "fluid-ref*", 2, 0, 0, ret = scm_hashq_ref (dynamic_state->thread_local_values, fluid, SCM_UNDEFINED); else - ret = scm_weak_table_refq (dynamic_state->values, fluid, - SCM_UNDEFINED); + ret = scm_c_ephemeron_hash_table_refq (dynamic_state->values, fluid, + SCM_UNDEFINED); if (SCM_UNBNDP (ret)) ret = SCM_I_FLUID_DEFAULT (fluid); @@ -581,8 +571,7 @@ SCM scm_i_make_initial_dynamic_state (void) { return scm_cell (scm_tc7_dynamic_state, - SCM_UNPACK (scm_c_make_weak_table - (0, SCM_WEAK_TABLE_KIND_KEY))); + (uintptr_t) scm_c_make_ephemeron_table (47)); } SCM_DEFINE (scm_dynamic_state_p, "dynamic-state?", 1, 0, 0, diff --git a/libguile/fluids.h b/libguile/fluids.h index ffcb48931..9153169d0 100644 --- a/libguile/fluids.h +++ b/libguile/fluids.h @@ -1,7 +1,7 @@ #ifndef SCM_FLUIDS_H #define SCM_FLUIDS_H -/* Copyright 1996,2000-2001,2006,2008-2013,2018 +/* Copyright 1996,2000-2001,2006,2008-2013,2018,2025 Free Software Foundation, Inc. This file is part of Guile. @@ -44,10 +44,11 @@ #ifdef BUILDING_LIBGUILE # include <libguile/cache-internal.h> +struct scm_ephemeron_table; struct scm_dynamic_state { SCM thread_local_values; - SCM values; + struct scm_ephemeron_table *values; uint8_t has_aliased_values; struct scm_cache cache; }; diff --git a/libguile/goops.c b/libguile/goops.c index 2f1dc7e5c..975c3dd29 100644 --- a/libguile/goops.c +++ b/libguile/goops.c @@ -33,6 +33,7 @@ #include "boolean.h" #include "chars.h" #include "dynwind.h" +#include "ephemerons.h" #include "eval.h" #include "extensions.h" #include "foreign.h" @@ -54,7 +55,6 @@ #include "variable.h" #include "vectors.h" #include "version.h" -#include "weak-table.h" #include "goops.h" @@ -136,8 +136,10 @@ static SCM class_thread; static SCM class_bitvector; static SCM class_finalizer; static SCM class_ephemeron; +static SCM class_ephemeron_table; -static SCM vtable_class_map = SCM_BOOL_F; +static struct scm_ephemeron_table *vtable_class_map; +static SCM pre_goops_vtables = SCM_EOL; /* SMOB classes. */ SCM scm_i_smob_class[SCM_I_MAX_SMOB_TYPE_COUNT]; @@ -262,6 +264,8 @@ SCM_DEFINE (scm_class_of, "class-of", 1, 0, 0, return class_finalizer; case scm_tc7_ephemeron: return class_ephemeron; + case scm_tc7_ephemeron_table: + return class_ephemeron_table; case scm_tc7_thread: return class_thread; case scm_tc7_string: @@ -776,15 +780,21 @@ scm_i_define_class_for_vtable (SCM vtable) { SCM class; - scm_i_pthread_mutex_lock (&scm_i_misc_mutex); - if (scm_is_false (vtable_class_map)) - vtable_class_map = scm_c_make_weak_table (0, SCM_WEAK_TABLE_KIND_KEY); - scm_i_pthread_mutex_unlock (&scm_i_misc_mutex); + if (!SCM_UNPACK (class_class)) + { + // FIXME: Race condition between one thread booting GOOPS + // (definining class_class) and another defining vtables. + scm_i_pthread_mutex_lock (&scm_i_misc_mutex); + pre_goops_vtables = scm_cons (vtable, pre_goops_vtables); + scm_i_pthread_mutex_unlock (&scm_i_misc_mutex); + return SCM_BOOL_F; + } if (scm_is_false (scm_struct_vtable_p (vtable))) abort (); - class = scm_weak_table_refq (vtable_class_map, vtable, SCM_BOOL_F); + class = scm_c_ephemeron_hash_table_refq (vtable_class_map, vtable, + SCM_BOOL_F); if (scm_is_false (class)) { @@ -827,27 +837,23 @@ scm_i_define_class_for_vtable (SCM vtable) /* Don't worry about races. This only happens when creating a vtable, which happens by definition in one thread. */ - scm_weak_table_putq_x (vtable_class_map, vtable, class); + scm_c_ephemeron_hash_table_setq_x (vtable_class_map, vtable, class); } return class; } -static SCM -make_struct_class (void *closure SCM_UNUSED, - SCM vtable, SCM data, SCM prev SCM_UNUSED) -{ - if (scm_is_false (data)) - scm_i_define_class_for_vtable (vtable); - return SCM_UNSPECIFIED; -} - static void create_struct_classes (void) { - /* FIXME: take the vtable_class_map while initializing goops? */ - scm_internal_hash_fold (make_struct_class, 0, SCM_BOOL_F, - vtable_class_map); + scm_i_pthread_mutex_lock (&scm_i_misc_mutex); + SCM vtables = pre_goops_vtables; + pre_goops_vtables = SCM_EOL; + vtable_class_map = scm_c_make_ephemeron_table (255); + scm_i_pthread_mutex_unlock (&scm_i_misc_mutex); + + for (; scm_is_pair (vtables); vtables = scm_cdr (vtables)) + scm_i_define_class_for_vtable (scm_car (vtables)); } @@ -958,6 +964,8 @@ SCM_DEFINE (scm_sys_goops_early_init, "%goops-early-init", 0, 0, 0, class_input_port = scm_variable_ref (scm_c_lookup ("<input-port>")); class_output_port = scm_variable_ref (scm_c_lookup ("<output-port>")); class_input_output_port = scm_variable_ref (scm_c_lookup ("<input-output-port>")); + class_ephemeron = scm_variable_ref (scm_c_lookup ("<ephemeron>")); + class_ephemeron_table = scm_variable_ref (scm_c_lookup ("<ephemeron-table>")); create_smob_classes (); create_struct_classes (); diff --git a/libguile/init.c b/libguile/init.c index 6ac140f0e..fc86a6145 100644 --- a/libguile/init.c +++ b/libguile/init.c @@ -99,7 +99,6 @@ #include "modules.h" #include "net_db.h" #include "numbers.h" -#include "objprop.h" #include "options.h" #include "pairs.h" #include "poll.h" @@ -125,7 +124,6 @@ #include "smob.h" #include "socket.h" #include "sort.h" -#include "srcprop.h" #include "srfi-13.h" #include "srfi-14.h" #include "srfi-4.h" @@ -401,7 +399,6 @@ scm_i_init_guile (struct gc_stack_addr base) scm_init_hash (); scm_init_hashtab (); scm_init_deprecation (); - scm_init_objprop (); scm_init_promises (); /* requires smob_prehistory */ scm_init_hooks (); /* Requires smob_prehistory */ scm_init_stime (); @@ -433,7 +430,6 @@ scm_i_init_guile (struct gc_stack_addr base) scm_init_socket (); #endif scm_init_sort (); - scm_init_srcprop (); /* requires smob_prehistory */ scm_init_stackchk (); scm_init_generalized_vectors (); @@ -458,7 +454,6 @@ scm_i_init_guile (struct gc_stack_addr base) scm_init_throw (); /* Requires smob_prehistory */ scm_init_version (); scm_init_weak_set (); - scm_init_weak_table (); scm_init_standard_ports (); /* Requires fports */ scm_init_expand (); /* Requires structs */ scm_init_memoize (); /* Requires smob_prehistory */ diff --git a/libguile/memoize.c b/libguile/memoize.c index d9e614f62..59a0ffd06 100644 --- a/libguile/memoize.c +++ b/libguile/memoize.c @@ -1,4 +1,4 @@ -/* Copyright 1995-2015,2018 +/* Copyright 1995-2015,2018,2025 Free Software Foundation, Inc. This file is part of Guile. @@ -40,7 +40,6 @@ #include "pairs.h" #include "ports.h" #include "print.h" -#include "srcprop.h" #include "strings.h" #include "symbols.h" #include "threads.h" diff --git a/libguile/objprop.c b/libguile/objprop.c deleted file mode 100644 index 0fffec75d..000000000 --- a/libguile/objprop.c +++ /dev/null @@ -1,105 +0,0 @@ -/* Copyright 1995-1996,2000-2001,2003,2006,2008-2011,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 - <https://www.gnu.org/licenses/>. */ - - - - -#ifdef HAVE_CONFIG_H -# include <config.h> -#endif - -#include "alist.h" -#include "async.h" -#include "gsubr.h" -#include "hashtab.h" -#include "pairs.h" -#include "weak-table.h" - -#include "objprop.h" - - - - -/* {Object Properties} - */ - -static SCM object_whash; - -SCM_DEFINE (scm_object_properties, "object-properties", 1, 0, 0, - (SCM obj), - "Return @var{obj}'s property list.") -#define FUNC_NAME s_scm_object_properties -{ - return scm_weak_table_refq (object_whash, obj, SCM_EOL); -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_set_object_properties_x, "set-object-properties!", 2, 0, 0, - (SCM obj, SCM alist), - "Set @var{obj}'s property list to @var{alist}.") -#define FUNC_NAME s_scm_set_object_properties_x -{ - scm_weak_table_putq_x (object_whash, obj, alist); - - return alist; -} -#undef FUNC_NAME - -SCM_DEFINE (scm_object_property, "object-property", 2, 0, 0, - (SCM obj, SCM key), - "Return the property of @var{obj} with name @var{key}.") -#define FUNC_NAME s_scm_object_property -{ - SCM assoc; - assoc = scm_assq (key, scm_object_properties (obj)); - return (scm_is_pair (assoc) ? SCM_CDR (assoc) : SCM_BOOL_F); -} -#undef FUNC_NAME - -SCM_DEFINE (scm_set_object_property_x, "set-object-property!", 3, 0, 0, - (SCM obj, SCM key, SCM value), - "In @var{obj}'s property list, set the property named @var{key}\n" - "to @var{value}.") -#define FUNC_NAME s_scm_set_object_property_x -{ - SCM alist; - SCM assoc; - - scm_i_pthread_mutex_lock (&scm_i_misc_mutex); - alist = scm_weak_table_refq (object_whash, obj, SCM_EOL); - assoc = scm_assq (key, alist); - if (scm_is_pair (assoc)) - SCM_SETCDR (assoc, value); - else - scm_weak_table_putq_x (object_whash, obj, scm_acons (key, value, alist)); - scm_i_pthread_mutex_unlock (&scm_i_misc_mutex); - - return value; -} -#undef FUNC_NAME - - -void -scm_init_objprop () -{ - object_whash = scm_c_make_weak_table (0, SCM_WEAK_TABLE_KIND_KEY); -#include "objprop.x" -} - diff --git a/libguile/objprop.h b/libguile/objprop.h deleted file mode 100644 index a40c9d370..000000000 --- a/libguile/objprop.h +++ /dev/null @@ -1,35 +0,0 @@ -#ifndef SCM_OBJPROP_H -#define SCM_OBJPROP_H - -/* Copyright 1995,2000-2001,2006,2008,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 - <https://www.gnu.org/licenses/>. */ - - - -#include "libguile/scm.h" - - - -SCM_API SCM scm_object_properties (SCM obj); -SCM_API SCM scm_set_object_properties_x (SCM obj, SCM plist); -SCM_API SCM scm_object_property (SCM obj, SCM key); -SCM_API SCM scm_set_object_property_x (SCM obj, SCM key, SCM val); -SCM_INTERNAL void scm_init_objprop (void); - -#endif /* SCM_OBJPROP_H */ diff --git a/libguile/print.c b/libguile/print.c index 17153ba8f..cd6e811e5 100644 --- a/libguile/print.c +++ b/libguile/print.c @@ -767,6 +767,9 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate) case scm_tc7_ephemeron: scm_i_print_ephemeron (exp, port, pstate); break; + case scm_tc7_ephemeron_table: + scm_i_print_ephemeron_table (exp, port, pstate); + break; case scm_tc7_thread: scm_i_print_thread (exp, port, pstate); break; diff --git a/libguile/procprop.c b/libguile/procprop.c index 89cc6c2f7..a86de57ed 100644 --- a/libguile/procprop.c +++ b/libguile/procprop.c @@ -1,4 +1,4 @@ -/* Copyright 1995-1996,1998,2000-2001,2003-2004,2006,2008-2013,2018 +/* Copyright 1995-1996,1998,2000-2001,2003-2004,2006,2008-2013,2018,2025 Free Software Foundation, Inc. This file is part of Guile. @@ -27,6 +27,7 @@ #include "alist.h" #include "boolean.h" #include "eval.h" +#include "ephemerons.h" #include "gsubr.h" #include "list.h" #include "numbers.h" @@ -38,7 +39,6 @@ #include "threads.h" #include "vectors.h" #include "vm-builtins.h" -#include "weak-table.h" #include "procprop.h" @@ -48,16 +48,16 @@ SCM_GLOBAL_SYMBOL (scm_sym_system_procedure, "system-procedure"); SCM_GLOBAL_SYMBOL (scm_sym_name, "name"); -static SCM overrides; +static struct scm_ephemeron_table *overrides; -static SCM arity_overrides; +static struct scm_ephemeron_table *arity_overrides; int scm_i_procedure_arity (SCM proc, int *req, int *opt, int *rest) { SCM o; - o = scm_weak_table_refq (arity_overrides, proc, SCM_BOOL_F); + o = scm_c_ephemeron_hash_table_refq (arity_overrides, proc, SCM_BOOL_F); if (scm_is_true (o)) { @@ -108,7 +108,8 @@ SCM_DEFINE (scm_set_procedure_minimum_arity_x, "set-procedure-minimum-arity!", SCM_VALIDATE_INT_COPY (3, opt, t); SCM_VALIDATE_BOOL (4, rest); - scm_weak_table_putq_x (arity_overrides, proc, scm_list_3 (req, opt, rest)); + scm_c_ephemeron_hash_table_setq_x (arity_overrides, proc, + scm_list_3 (req, opt, rest)); return SCM_UNDEFINED; } #undef FUNC_NAME @@ -147,7 +148,7 @@ SCM_DEFINE (scm_procedure_properties, "procedure-properties", 1, 0, 0, SCM_VALIDATE_PROC (1, proc); - user_props = scm_weak_table_refq (overrides, proc, SCM_BOOL_F); + user_props = scm_c_ephemeron_hash_table_refq (overrides, proc, SCM_BOOL_F); if (scm_is_pair (user_props) && scm_is_true (scm_car (user_props))) return scm_cdr (user_props); @@ -174,7 +175,8 @@ SCM_DEFINE (scm_set_procedure_properties_x, "set-procedure-properties!", 2, 0, 0 { SCM_VALIDATE_PROC (1, proc); - scm_weak_table_putq_x (overrides, proc, scm_cons (SCM_BOOL_T, alist)); + scm_c_ephemeron_hash_table_setq_x (overrides, proc, + scm_cons (SCM_BOOL_T, alist)); return SCM_UNSPECIFIED; } @@ -194,7 +196,7 @@ SCM_DEFINE (scm_procedure_property, "procedure-property", 2, 0, 0, if (scm_is_eq (key, scm_sym_documentation)) return scm_procedure_documentation (proc); - user_props = scm_weak_table_refq (overrides, proc, SCM_BOOL_F); + user_props = scm_c_ephemeron_hash_table_refq (overrides, proc, SCM_BOOL_F); if (scm_is_true (user_props)) { SCM pair = scm_assq (key, scm_cdr (user_props)); @@ -219,7 +221,7 @@ SCM_DEFINE (scm_set_procedure_property_x, "set-procedure-property!", 3, 0, 0, SCM_VALIDATE_PROC (1, proc); scm_i_pthread_mutex_lock (&scm_i_misc_mutex); - user_props = scm_weak_table_refq (overrides, proc, SCM_BOOL_F); + user_props = scm_c_ephemeron_hash_table_refq (overrides, proc, SCM_BOOL_F); if (scm_is_false (user_props)) { override_p = SCM_BOOL_F; @@ -230,9 +232,8 @@ SCM_DEFINE (scm_set_procedure_property_x, "set-procedure-property!", 3, 0, 0, override_p = scm_car (user_props); user_props = scm_cdr (user_props); } - scm_weak_table_putq_x (overrides, proc, - scm_cons (override_p, - scm_assq_set_x (user_props, key, val))); + SCM props = scm_cons (override_p, scm_assq_set_x (user_props, key, val)); + scm_c_ephemeron_hash_table_setq_x (overrides, proc, props); scm_i_pthread_mutex_unlock (&scm_i_misc_mutex); return SCM_UNSPECIFIED; @@ -254,7 +255,7 @@ SCM_DEFINE (scm_procedure_name, "procedure-name", 1, 0, 0, SCM_VALIDATE_PROC (1, proc); - user_props = scm_weak_table_refq (overrides, proc, SCM_BOOL_F); + user_props = scm_c_ephemeron_hash_table_refq (overrides, proc, SCM_BOOL_F); if (scm_is_true (user_props)) { SCM pair = scm_assq (scm_sym_name, scm_cdr (user_props)); @@ -291,7 +292,7 @@ SCM_DEFINE (scm_procedure_documentation, "procedure-documentation", 1, 0, 0, while (SCM_STRUCTP (proc) && SCM_STRUCT_APPLICABLE_P (proc)) proc = SCM_STRUCT_PROCEDURE (proc); - user_props = scm_weak_table_refq (overrides, proc, SCM_BOOL_F); + user_props = scm_c_ephemeron_hash_table_refq (overrides, proc, SCM_BOOL_F); if (scm_is_true (user_props)) { SCM pair = scm_assq (scm_sym_documentation, scm_cdr (user_props)); @@ -339,8 +340,8 @@ SCM_DEFINE (scm_procedure_source, "procedure-source", 1, 0, 0, void scm_init_procprop () { - overrides = scm_c_make_weak_table (0, SCM_WEAK_TABLE_KIND_KEY); - arity_overrides = scm_c_make_weak_table (0, SCM_WEAK_TABLE_KIND_KEY); + overrides = scm_c_make_ephemeron_table (1001); + arity_overrides = scm_c_make_ephemeron_table (113); #include "procprop.x" scm_init_vm_builtin_properties (); } diff --git a/libguile/promises.c b/libguile/promises.c index c47bd9086..415842570 100644 --- a/libguile/promises.c +++ b/libguile/promises.c @@ -1,4 +1,4 @@ -/* Copyright 1995-2011,2018 +/* Copyright 1995-2011,2018,2025 Free Software Foundation, Inc. This file is part of Guile. @@ -49,7 +49,6 @@ #include "procs.h" #include "programs.h" #include "smob.h" -#include "srcprop.h" #include "stackchk.h" #include "strings.h" #include "threads.h" diff --git a/libguile/read.c b/libguile/read.c index 3030b27ed..506fd2e21 100644 --- a/libguile/read.c +++ b/libguile/read.c @@ -1,4 +1,4 @@ -/* Copyright 1995-1997,1999-2001,2003-2004,2006-2012,2014-2021 +/* Copyright 1995-1997,1999-2001,2003-2004,2006-2012,2014-2021,2025 Free Software Foundation, Inc. This file is part of Guile. @@ -54,7 +54,6 @@ #include "ports.h" #include "private-options.h" #include "procs.h" -#include "srcprop.h" #include "srfi-13.h" #include "srfi-4.h" #include "strings.h" diff --git a/libguile/scm.h b/libguile/scm.h index 97b38d61c..6408bfeb7 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_unused_0f 0x0f +#define scm_tc7_ephemeron_table 0x0f #define scm_tc7_string 0x15 #define scm_tc7_number 0x17 #define scm_tc7_hashtable 0x1d diff --git a/libguile/srcprop.c b/libguile/srcprop.c deleted file mode 100644 index 4c2a77b54..000000000 --- a/libguile/srcprop.c +++ /dev/null @@ -1,326 +0,0 @@ -/* Copyright 1995-2002,2006,2008-2012,2018,2020 - 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 <errno.h> - -#include "alist.h" -#include "async.h" -#include "debug.h" -#include "gc.h" -#include "gsubr.h" -#include "hash.h" -#include "hashtab.h" -#include "keywords.h" -#include "list.h" -#include "modules.h" -#include "numbers.h" -#include "pairs.h" -#include "ports.h" -#include "private-options.h" -#include "smob.h" -#include "symbols.h" -#include "weak-table.h" - -#include "srcprop.h" - - - -/* {Source Properties} - * - * Properties of source list expressions. - * Three of these have special meaning: - * - * filename The name of the source file. - * line The source code line number. - * column The source code column number. - * - * Most properties above can be set by the reader. - * - */ - -SCM_GLOBAL_SYMBOL (scm_sym_filename, "filename"); -SCM_GLOBAL_SYMBOL (scm_sym_line, "line"); -SCM_GLOBAL_SYMBOL (scm_sym_column, "column"); - -static SCM scm_source_whash; - - -/* - * Source properties are stored as double cells with the - * following layout: - - * car = tag | col (untagged) - * cbr = line - * ccr = filename - * cdr = alist - */ - -static scm_t_bits tc16_srcprops; - -#define SRCPROPSP(p) (SCM_SMOB_PREDICATE (tc16_srcprops, (p))) -#define SRCPROPCOL(p) (scm_from_int (SCM_SMOB_FLAGS (p))) -#define SRCPROPLINE(p) (SCM_SMOB_OBJECT_1 (p)) -#define SRCPROPFNAME(p) (SCM_SMOB_OBJECT_2 (p)) -#define SRCPROPALIST(p) (SCM_SMOB_OBJECT_3 (p)) -#define SETSRCPROPCOL(p, c) (SCM_SET_SMOB_FLAGS (p, scm_to_int (c))) -#define SETSRCPROPLINE(p, l) (SCM_SET_SMOB_OBJECT_1 (p, l)) -#define SETSRCPROPFNAME(p, x) (SCM_SET_SMOB_OBJECT_2 (p, x)) -#define SETSRCPROPALIST(p, x) (SCM_SET_SMOB_OBJECT_3 (p, x)) - - -static SCM scm_srcprops_to_alist (SCM obj); - - - -static int -supports_source_props (SCM obj) -{ - return SCM_NIMP (obj) && !scm_is_symbol (obj) && !scm_is_keyword (obj); -} - - -static int -srcprops_print (SCM obj, SCM port, scm_print_state *pstate) -{ - int writingp = SCM_WRITINGP (pstate); - scm_puts ("#<srcprops ", port); - SCM_SET_WRITINGP (pstate, 1); - scm_iprin1 (scm_srcprops_to_alist (obj), port, pstate); - SCM_SET_WRITINGP (pstate, writingp); - scm_putc ('>', port); - return 1; -} - - -SCM -scm_i_make_srcprops (SCM line, SCM col, SCM filename, SCM alist) -{ - SCM_RETURN_NEWSMOB3 (tc16_srcprops | (scm_to_int (col) << 16), - SCM_UNPACK (line), - SCM_UNPACK (filename), - SCM_UNPACK (alist)); -} - -static SCM -scm_srcprops_to_alist (SCM obj) -{ - SCM alist = SRCPROPALIST (obj); - if (scm_is_true (SRCPROPFNAME (obj))) - alist = scm_acons (scm_sym_filename, SRCPROPFNAME (obj), alist); - alist = scm_acons (scm_sym_column, SRCPROPCOL (obj), alist); - alist = scm_acons (scm_sym_line, SRCPROPLINE (obj), alist); - return alist; -} - -SCM_DEFINE (scm_supports_source_properties_p, "supports-source-properties?", 1, 0, 0, - (SCM obj), - "Return #t if @var{obj} supports adding source properties,\n" - "otherwise return #f.") -#define FUNC_NAME s_scm_supports_source_properties_p -{ - return scm_from_bool (supports_source_props (obj)); -} -#undef FUNC_NAME - -SCM_DEFINE (scm_source_properties, "source-properties", 1, 0, 0, - (SCM obj), - "Return the source property association list of @var{obj}.") -#define FUNC_NAME s_scm_source_properties -{ - if (SCM_IMP (obj)) - return SCM_EOL; - else - { - SCM p = scm_weak_table_refq (scm_source_whash, obj, SCM_EOL); - - if (SRCPROPSP (p)) - return scm_srcprops_to_alist (p); - else - /* list from set-source-properties!, or SCM_EOL for not found */ - return p; - } -} -#undef FUNC_NAME - -#define SCM_VALIDATE_NIM(pos, scm) \ - SCM_MAKE_VALIDATE_MSG (pos, scm, NIMP, "non-immediate") - -/* Perhaps this procedure should look through an alist - and try to make a srcprops-object...? */ -SCM_DEFINE (scm_set_source_properties_x, "set-source-properties!", 2, 0, 0, - (SCM obj, SCM alist), - "Install the association list @var{alist} as the source property\n" - "list for @var{obj}.") -#define FUNC_NAME s_scm_set_source_properties_x -{ - SCM_VALIDATE_NIM (1, obj); - - scm_weak_table_putq_x (scm_source_whash, obj, alist); - - return alist; -} -#undef FUNC_NAME - -int -scm_i_has_source_properties (SCM obj) -#define FUNC_NAME "%set-source-properties" -{ - if (SCM_IMP (obj)) - return 0; - else - return scm_is_true (scm_weak_table_refq (scm_source_whash, obj, SCM_BOOL_F)); -} -#undef FUNC_NAME - - -void -scm_i_set_source_properties_x (SCM obj, SCM line, SCM col, SCM fname) -#define FUNC_NAME "%set-source-properties" -{ - SCM_VALIDATE_NIM (1, obj); - - scm_weak_table_putq_x (scm_source_whash, obj, - scm_i_make_srcprops (line, col, fname, SCM_EOL)); -} -#undef FUNC_NAME - -SCM_DEFINE (scm_source_property, "source-property", 2, 0, 0, - (SCM obj, SCM key), - "Return the source property specified by @var{key} from\n" - "@var{obj}'s source property list.") -#define FUNC_NAME s_scm_source_property -{ - SCM p; - - if (SCM_IMP (obj)) - return SCM_BOOL_F; - - p = scm_weak_table_refq (scm_source_whash, obj, SCM_EOL); - - if (!SRCPROPSP (p)) - goto alist; - if (scm_is_eq (scm_sym_line, key)) - return SRCPROPLINE (p); - else if (scm_is_eq (scm_sym_column, key)) - return SRCPROPCOL (p); - else if (scm_is_eq (scm_sym_filename, key)) - return SRCPROPFNAME (p); - else - { - p = SRCPROPALIST (p); - alist: - p = scm_assoc (key, p); - return (scm_is_pair (p) ? SCM_CDR (p) : SCM_BOOL_F); - } -} -#undef FUNC_NAME - -static scm_i_pthread_mutex_t source_mutex = SCM_I_PTHREAD_MUTEX_INITIALIZER; - -SCM_DEFINE (scm_set_source_property_x, "set-source-property!", 3, 0, 0, - (SCM obj, SCM key, SCM datum), - "Set the source property of object @var{obj}, which is specified by\n" - "@var{key} to @var{datum}. Normally, the key will be a symbol.") -#define FUNC_NAME s_scm_set_source_property_x -{ - SCM p; - SCM_VALIDATE_NIM (1, obj); - - scm_i_pthread_mutex_lock (&source_mutex); - p = scm_weak_table_refq (scm_source_whash, obj, SCM_EOL); - - if (scm_is_eq (scm_sym_line, key)) - { - if (SRCPROPSP (p)) - SETSRCPROPLINE (p, datum); - else - scm_weak_table_putq_x (scm_source_whash, obj, - scm_i_make_srcprops (datum, SCM_INUM0, - SCM_BOOL_F, p)); - } - else if (scm_is_eq (scm_sym_column, key)) - { - if (SRCPROPSP (p)) - SETSRCPROPCOL (p, datum); - else - scm_weak_table_putq_x (scm_source_whash, obj, - scm_i_make_srcprops (SCM_INUM0, datum, - SCM_BOOL_F, p)); - } - else if (scm_is_eq (scm_sym_filename, key)) - { - if (SRCPROPSP (p)) - SETSRCPROPFNAME (p, datum); - else - scm_weak_table_putq_x (scm_source_whash, obj, - scm_i_make_srcprops (SCM_INUM0, SCM_INUM0, - datum, p)); - } - else - { - if (SRCPROPSP (p)) - SETSRCPROPALIST (p, scm_acons (key, datum, SRCPROPALIST (p))); - else - scm_weak_table_putq_x (scm_source_whash, obj, - scm_acons (key, datum, p)); - } - scm_i_pthread_mutex_unlock (&source_mutex); - - return SCM_UNSPECIFIED; -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_cons_source, "cons-source", 3, 0, 0, - (SCM xorig, SCM x, SCM y), - "Create and return a new pair whose car and cdr are @var{x} and @var{y}.\n" - "Any source properties associated with @var{xorig} are also associated\n" - "with the new pair.") -#define FUNC_NAME s_scm_cons_source -{ - SCM p, z; - z = scm_cons (x, y); - /* Copy source properties possibly associated with xorig. */ - p = scm_weak_table_refq (scm_source_whash, xorig, SCM_BOOL_F); - if (scm_is_true (p)) - scm_weak_table_putq_x (scm_source_whash, z, p); - return z; -} -#undef FUNC_NAME - - -void -scm_init_srcprop () -{ - tc16_srcprops = scm_make_smob_type ("srcprops", 0); - scm_set_smob_print (tc16_srcprops, srcprops_print); - - scm_source_whash = scm_c_make_weak_table (0, SCM_WEAK_TABLE_KIND_KEY); - scm_c_define ("source-whash", scm_source_whash); - -#include "srcprop.x" -} - diff --git a/libguile/srcprop.h b/libguile/srcprop.h deleted file mode 100644 index ea1631bbf..000000000 --- a/libguile/srcprop.h +++ /dev/null @@ -1,53 +0,0 @@ -#ifndef SCM_SRCPROP_H -#define SCM_SRCPROP_H - -/* Copyright 1995-1996,2000-2001,2006,2008-2012,2018,2020 - 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/boolean.h" - - - -/* {Source properties} - */ - -SCM_API SCM scm_sym_filename; -SCM_API SCM scm_sym_line; -SCM_API SCM scm_sym_column; - - - -SCM_API SCM scm_supports_source_properties_p (SCM obj); -SCM_API SCM scm_source_property (SCM obj, SCM key); -SCM_API SCM scm_set_source_property_x (SCM obj, SCM key, SCM datum); -SCM_API SCM scm_source_properties (SCM obj); -SCM_API SCM scm_set_source_properties_x (SCM obj, SCM props); - -SCM_INTERNAL SCM scm_i_make_srcprops (SCM line, SCM col, SCM fname, SCM alist); -SCM_INTERNAL int scm_i_has_source_properties (SCM obj); -SCM_INTERNAL void scm_i_set_source_properties_x (SCM obj, SCM line, SCM col, - SCM fname); - -SCM_API SCM scm_cons_source (SCM xorig, SCM x, SCM y); -SCM_INTERNAL void scm_init_srcprop (void); - - -#endif /* SCM_SRCPROP_H */ diff --git a/libguile/syntax.c b/libguile/syntax.c index 2f416d173..6e298e5e9 100644 --- a/libguile/syntax.c +++ b/libguile/syntax.c @@ -1,4 +1,4 @@ -/* Copyright 2017-2018,2021 +/* Copyright 2017-2018,2021,2025 Free Software Foundation, Inc. This file is part of Guile. @@ -31,7 +31,6 @@ #include "modules.h" #include "pairs.h" #include "ports.h" -#include "srcprop.h" #include "threads.h" #include "variable.h" #include "vectors.h" @@ -41,12 +40,6 @@ -/* The source field was added to syntax objects in Guile 3.0.6. However - there can be older syntax objects present in compiled files that - don't have the source field. If a syntax object has a source field, - its tag will have HAS_SOURCE_WORD_FLAG set. */ -#define HAS_SOURCE_WORD_FLAG 0x100 - enum { TAG_WORD, @@ -76,40 +69,17 @@ SCM_DEFINE (scm_syntax_p, "syntax?", 1, 0, 0, } #undef FUNC_NAME -static SCM -sourcev_to_props (SCM v) -{ - SCM props = scm_acons (scm_sym_line, scm_c_vector_ref (v, 1), - scm_acons (scm_sym_column, scm_c_vector_ref (v, 2), - SCM_EOL)); - if (scm_is_true (scm_c_vector_ref (v, 0))) - props = scm_acons (scm_sym_filename, scm_c_vector_ref (v, 0), props); - return props; -} - -static SCM -props_to_sourcev (SCM props) -{ - SCM v = scm_c_make_vector (3, SCM_BOOL_F); - scm_c_vector_set_x (v, 0, scm_assq_ref (props, scm_sym_filename)); - scm_c_vector_set_x (v, 1, scm_assq_ref (props, scm_sym_line)); - scm_c_vector_set_x (v, 2, scm_assq_ref (props, scm_sym_column)); - return v; -} - SCM_DEFINE (scm_make_syntax, "make-syntax", 3, 1, 0, (SCM exp, SCM wrap, SCM module, SCM source), "Make a new syntax object.") #define FUNC_NAME s_scm_make_syntax { if (SCM_UNBNDP (source)) - source = scm_source_properties (exp); - if (scm_is_pair (source)) - source = props_to_sourcev (source); - if (!scm_is_vector (source)) source = SCM_BOOL_F; + else if (!scm_is_eq (source, SCM_BOOL_F)) + SCM_VALIDATE_VECTOR (1, source); - SCM ret = scm_words (scm_tc7_syntax | HAS_SOURCE_WORD_FLAG, WORD_COUNT); + SCM ret = scm_words (scm_tc7_syntax, WORD_COUNT); SCM_SET_CELL_OBJECT (ret, EXPR_WORD, exp); SCM_SET_CELL_OBJECT (ret, WRAP_WORD, wrap); SCM_SET_CELL_OBJECT (ret, MODULE_WORD, module); @@ -158,30 +128,7 @@ SCM_DEFINE (scm_syntax_source, "syntax-source", 1, 0, 0, #define FUNC_NAME s_scm_syntax_source { SCM_VALIDATE_SYNTAX (1, obj); - if (!(SCM_CELL_WORD (obj, TAG_WORD) & HAS_SOURCE_WORD_FLAG)) - return SCM_BOOL_F; - SCM src = SCM_CELL_OBJECT (obj, SOURCE_WORD); - if (scm_is_vector (src)) - src = sourcev_to_props (src); - return src; -} -#undef FUNC_NAME - -SCM_DEFINE (scm_syntax_sourcev, "syntax-sourcev", 1, 0, 0, - (SCM obj), - "Return the source location information for syntax object\n" - "@var{obj}, as a vector of @code{#(@var{filename} @var{line}\n" - "@var{column})}, or @code{#f} if no source properties are\n" - "available.") -#define FUNC_NAME s_scm_syntax_sourcev -{ - SCM_VALIDATE_SYNTAX (1, obj); - if (!(SCM_CELL_WORD (obj, TAG_WORD) & HAS_SOURCE_WORD_FLAG)) - return SCM_BOOL_F; - SCM src = SCM_CELL_OBJECT (obj, SOURCE_WORD); - if (scm_is_null (src) || scm_is_pair (src)) - src = props_to_sourcev (src); - return src; + return SCM_CELL_OBJECT (obj, SOURCE_WORD); } #undef FUNC_NAME diff --git a/libguile/syntax.h b/libguile/syntax.h index d860a355e..02da14808 100644 --- a/libguile/syntax.h +++ b/libguile/syntax.h @@ -1,7 +1,7 @@ #ifndef SCM_SYNTAX_H #define SCM_SYNTAX_H -/* Copyright 2017-2018,2021 +/* Copyright 2017-2018,2021,2025 Free Software Foundation, Inc. This file is part of Guile. @@ -28,7 +28,6 @@ SCM_INTERNAL SCM scm_syntax_expression (SCM obj); SCM_INTERNAL SCM scm_syntax_wrap (SCM obj); SCM_INTERNAL SCM scm_syntax_module (SCM obj); SCM_INTERNAL SCM scm_syntax_source (SCM obj); -SCM_INTERNAL SCM scm_syntax_sourcev (SCM obj); SCM_INTERNAL void scm_i_syntax_print (SCM obj, SCM port, scm_print_state *pstate); diff --git a/libguile/threads.c b/libguile/threads.c index bf9997ed7..380864f6f 100644 --- a/libguile/threads.c +++ b/libguile/threads.c @@ -108,6 +108,10 @@ scm_trace_thread (struct scm_thread *thread, scm_trace_dynstack (&thread->dynstack, trace_edge, heap, trace_data); trace_edge (gc_edge (&thread->continuation_root), heap, trace_data); + + trace_edge (gc_edge (&thread->join_cond), heap, trace_data); + trace_edge (gc_edge (&thread->join_lock), heap, trace_data); + trace_edge (gc_edge (&thread->join_results), heap, trace_data); } /* Guile-level thread objects are themselves GC-allocated. A thread @@ -413,6 +417,8 @@ guilify_self_1 (struct gc_mutator *mut, struct gc_stack_addr base, t->base = (SCM_STACKITEM *) gc_stack_addr_as_pointer (base); t->continuation_root = SCM_EOL; t->continuation_base = t->base; + t->join_cond = t->join_lock = t->join_results = SCM_BOOL_F; + scm_i_pthread_cond_init (&t->sleep_cond, NULL); scm_i_vm_prepare_stack (&t->vm); @@ -840,6 +846,56 @@ scm_cancel_thread (SCM thread) static SCM join_thread_var; +SCM_DEFINE_STATIC (thread_join_cond, "%thread-join-cond", 1, 0, 0, + (SCM thread), "") +#define FUNC_NAME s_thread_join_cond +{ + SCM_VALIDATE_THREAD (1, thread); + return SCM_I_THREAD_DATA (thread)->join_cond; +} +#undef FUNC_NAME + +SCM_DEFINE_STATIC (thread_join_lock, "%thread-join-lock", 1, 0, 0, + (SCM thread), "") +#define FUNC_NAME s_thread_join_lock +{ + SCM_VALIDATE_THREAD (1, thread); + return SCM_I_THREAD_DATA (thread)->join_lock; +} +#undef FUNC_NAME + +SCM_DEFINE_STATIC (thread_join_results, "%thread-join-results", 1, 0, 0, + (SCM thread), "") +#define FUNC_NAME s_thread_join_results +{ + SCM_VALIDATE_THREAD (1, thread); + return SCM_I_THREAD_DATA (thread)->join_results; +} +#undef FUNC_NAME + +SCM_DEFINE_STATIC (thread_init_joinable_x, "%thread-init-joinable!", 3, 0, 0, + (SCM thread, SCM cond, SCM lock), "") +#define FUNC_NAME s_thread_init_joinable_x +{ + SCM_VALIDATE_THREAD (1, thread); + SCM_VALIDATE_CONDVAR (2, cond); + SCM_VALIDATE_MUTEX (3, lock); + SCM_I_THREAD_DATA (thread)->join_cond = cond; + SCM_I_THREAD_DATA (thread)->join_lock = lock; + return SCM_UNSPECIFIED; +} +#undef FUNC_NAME + +SCM_DEFINE_STATIC (thread_set_join_results_x, "%thread-set-join-results!", + 2, 0, 0, (SCM thread, SCM results), "") +#define FUNC_NAME s_thread_set_join_results_x +{ + SCM_VALIDATE_THREAD (1, thread); + SCM_I_THREAD_DATA (thread)->join_results = results; + return SCM_UNSPECIFIED; +} +#undef FUNC_NAME + SCM scm_join_thread (SCM thread) { diff --git a/libguile/threads.h b/libguile/threads.h index 2e184391c..918e87c41 100644 --- a/libguile/threads.h +++ b/libguile/threads.h @@ -123,6 +123,12 @@ struct scm_thread { SCM_STACKITEM *auxiliary_stack_base; #endif + /* For joinable threads, a cond to wait on joining, and a lock to + protect the results. #f if not joinable. */ + SCM join_cond; + SCM join_lock; + SCM join_results; + /* JIT state; NULL until this thread needs to JIT-compile something. */ struct scm_jit_state *jit_state; }; diff --git a/libguile/weak-table.c b/libguile/weak-table.c index 5a4c68b6b..06f2cafdd 100644 --- a/libguile/weak-table.c +++ b/libguile/weak-table.c @@ -29,6 +29,7 @@ #include "alist.h" #include "bdw-gc.h" #include "eval.h" +#include "extensions.h" #include "finalizers.h" #include "gsubr.h" #include "hash.h" @@ -37,6 +38,7 @@ #include "ports.h" #include "procs.h" #include "threads.h" +#include "version.h" #include "weak-table.h" @@ -772,6 +774,12 @@ SCM_DEFINE (scm_doubly_weak_hash_table_p, "doubly-weak-hash-table?", 1, 0, 0, +static void +scm_init_weak_tables (void*) +{ +#include "weak-table.x" +} + void scm_weak_table_prehistory (void) { @@ -792,10 +800,8 @@ scm_weak_table_prehistory (void) GC_WORD_LEN (scm_t_weak_entry)); doubly_weak_descr = GC_make_descriptor (doubly_weak_bitmap, GC_WORD_LEN (scm_t_weak_entry)); -} -void -scm_init_weak_table () -{ -#include "weak-table.x" + 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 index bcbc94e3f..f7e6c7cae 100644 --- a/libguile/weak-table.h +++ b/libguile/weak-table.h @@ -1,7 +1,7 @@ #ifndef SCM_WEAK_TABLE_H #define SCM_WEAK_TABLE_H -/* Copyright 2011-2012,2018 +/* Copyright 2011-2012,2018,2025 Free Software Foundation, Inc. This file is part of Guile. @@ -82,6 +82,5 @@ 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); -SCM_INTERNAL void scm_init_weak_table (void); #endif /* SCM_WEAK_TABLE_H */ diff --git a/libguile/whippet/src/bdw.c b/libguile/whippet/src/bdw.c index a50994d7c..e6b3f4ef5 100644 --- a/libguile/whippet/src/bdw.c +++ b/libguile/whippet/src/bdw.c @@ -52,7 +52,6 @@ #define GC_INLINE_FREELIST_COUNT (256U / GC_INLINE_GRANULE_BYTES) struct gc_heap { - struct gc_heap *freelist; // see mark_heap struct gc_heap_roots *roots; struct gc_mutator *mutators; struct gc_event_listener event_listener; @@ -315,7 +314,7 @@ mark_ephemeron(GC_word *addr, struct GC_ms_entry *mark_stack_ptr, struct gc_ephemeron *ephemeron = (struct gc_ephemeron*) addr; - // If this ephemeron is on a freelist, its first word will be a + // If this ephemeron is on a freelist, its first word will be a possibly-null // freelist link and everything else will be NULL. if (!gc_ref_value(gc_edge_ref(gc_ephemeron_value_edge(ephemeron)))) { bdw_mark_edge(gc_edge(addr), NULL, &state); @@ -344,7 +343,7 @@ mark_finalizer(GC_word *addr, struct GC_ms_entry *mark_stack_ptr, struct gc_finalizer *finalizer = (struct gc_finalizer*) addr; - // If this ephemeron is on a freelist, its first word will be a + // If this ephemeron is on a freelist, its first word will be a possibly-null // freelist link and everything else will be NULL. if (!gc_ref_value(gc_finalizer_object(finalizer))) { bdw_mark_edge(gc_edge(addr), NULL, &state); @@ -366,13 +365,10 @@ mark_heap(GC_word *addr, struct GC_ms_entry *mark_stack_ptr, struct gc_heap *heap = (struct gc_heap*) addr; - // If this heap is on a freelist... well probably we are screwed, BDW - // isn't really made to do multiple heaps in a process. But still, in - // this case, the first word is the freelist and the rest are null. - if (heap->freelist) { - bdw_mark_edge(gc_edge(addr), NULL, &state); + // If this heap is not __the_bdw_gc_heap, either it is on a freelist, or the + // heap object is still under construction. In either case, ignore it. + if (heap != __the_bdw_gc_heap) return state.mark_stack_ptr; - } if (heap->roots) gc_trace_heap_roots(heap->roots, bdw_mark_edge, heap, &state); @@ -397,9 +393,12 @@ mark_mutator(GC_word *addr, struct GC_ms_entry *mark_stack_ptr, struct gc_mutator *mut = (struct gc_mutator*) addr; - // If this mutator is on a freelist, its first word will be a - // freelist link and everything else will be NULL. - if (!mut->heap) { + // A mutator is valid and initialized if its "heap" member points to + // __the_bdw_gc_heap. Otherwise it could be on a freelist, in which case its + // first word will be a possibly-null freelist link, or it could be under + // construction, or it could be exited already. In any case, mark the free + // list link and finish. + if (mut->heap != __the_bdw_gc_heap) { bdw_mark_edge(gc_edge(addr), NULL, &state); return state.mark_stack_ptr; } @@ -420,7 +419,6 @@ mark_mutator(GC_word *addr, struct GC_ms_entry *mark_stack_ptr, static inline struct gc_mutator *add_mutator(struct gc_heap *heap) { struct gc_mutator *ret = GC_generic_malloc(sizeof(struct gc_mutator), mutator_gc_kind); - ret->heap = heap; ret->event_listener_data = heap->event_listener.mutator_added(heap->event_listener_data); @@ -430,6 +428,7 @@ static inline struct gc_mutator *add_mutator(struct gc_heap *heap) { if (ret->next) ret->next->prev = &ret->next; heap->mutators = ret; + ret->heap = heap; GC_alloc_unlock(); return ret; diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm index 5443b2fb6..101a2755a 100644 --- a/module/ice-9/boot-9.scm +++ b/module/ice-9/boot-9.scm @@ -548,23 +548,23 @@ If returning early, return the return value of F." (let ((seen (fold (lambda (datum seen) + (define raw (syntax->datum datum)) (define (warn-datum type) ((@ (system base message) warning) type - (append (source-properties datum) - (source-properties - (syntax->datum #'test))) - datum + (or (syntax-source datum) + (syntax-source #'test)) + raw (syntax->datum clause) (syntax->datum whole-expr))) - (when (memv datum seen) + (when (memv raw seen) (warn-datum 'duplicate-case-datum)) - (when (or (pair? datum) (array? datum)) + (when (or (pair? raw) (array? raw)) (warn-datum 'bad-case-datum)) - (cons datum seen)) + (cons raw seen)) seen - (map syntax->datum #'(datums ...))))) + #'(datums ...)))) (values (lambda (tail) #`((if (memv key '(datums ...)) clause-expr @@ -687,8 +687,17 @@ If returning early, return the return value of F." (lambda (x) (syntax-case x () ((_) - (with-syntax ((s (datum->syntax x (syntax-source x)))) - #''s))))) + (cond + ((syntax-source x) + => (lambda (v) + (with-syntax ((f (vector-ref v 0)) + (l (vector-ref v 1)) + (c (vector-ref v 2))) + #''((filename . f) + (line . l) + (column . c))))) + (else + #'#f)))))) ;; We provide this accessor out of convenience. current-line and ;; current-column aren't so interesting, because they distort what they @@ -699,8 +708,11 @@ If returning early, return the return value of F." "A macro that expands to the current filename: the filename that the (current-filename) form appears in. Expands to #f if this information is unavailable." - (false-if-exception - (canonicalize-path (assq-ref (syntax-source x) 'filename))))) + (and=> (syntax-source x) + (lambda (v) + (and=> (vector-ref v 0) + (lambda (filename) + (false-if-exception (canonicalize-path filename)))))))) (define-syntax-rule (define-once sym val) (define sym @@ -825,30 +837,6 @@ VALUE." -;;; {General Properties} -;;; - -;; Properties are a lispy way to associate random info with random objects. -;; Traditionally properties are implemented as an alist or a plist actually -;; pertaining to the object in question. -;; -;; These "object properties" have the advantage that they can be associated with -;; any object, even if the object has no plist. Object properties are good when -;; you are extending pre-existing objects in unexpected ways. They also present -;; a pleasing, uniform procedure-with-setter interface. But if you have a data -;; type that always has properties, it's often still best to store those -;; properties within the object itself. - -(define (make-object-property) - ;; 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))))) - - - - ;;; {Arrays} ;;; @@ -2291,9 +2279,6 @@ name extensions listed in %load-extensions." ;;; - observers: a list of procedures that get called when the module is ;;; modified. ;;; -;;; - weak-observers: a weak-key hash table of procedures that get called -;;; when the module is modified. See `module-observe-weak' for details. -;;; ;;; In addition, the module may (must?) contain a binding for ;;; `%module-public-interface'. This variable should be bound to a module ;;; representing the exported interface of a module. See the @@ -2486,7 +2471,6 @@ name extensions listed in %load-extensions." duplicates-handlers (import-obarray #:no-setter) observers - (weak-observers #:no-setter) version submodules submodule-binder @@ -2514,7 +2498,7 @@ initial uses list, or binding procedure." #f #f #f (make-hash-table) '() - (make-weak-key-hash-table) #f + #f (make-hash-table) #f #f #f 0 (make-hash-table) #f)) @@ -2528,24 +2512,10 @@ initial uses list, or binding procedure." (set-module-observers! module (cons proc (module-observers module))) (cons module proc)) -(define* (module-observe-weak module observer-id #:optional (proc observer-id)) - "Register PROC as an observer of MODULE under name OBSERVER-ID (which can -be any Scheme object). PROC is invoked and passed MODULE any time -MODULE is modified. PROC gets unregistered when OBSERVER-ID gets GC'd -(thus, it is never unregistered if OBSERVER-ID is an immediate value, -for instance). - -The two-argument version is kept for backward compatibility: when called -with two arguments, the observer gets unregistered when closure PROC -gets GC'd (making it impossible to use an anonymous lambda for PROC)." - (hashq-set! (module-weak-observers module) observer-id proc)) - (define (module-unobserve token) (let ((module (car token)) (id (cdr token))) - (if (integer? id) - (hash-remove! (module-weak-observers module) id) - (set-module-observers! module (delq1! id (module-observers module))))) + (set-module-observers! module (delq1! id (module-observers module)))) *unspecified*) ;; Hash table of module -> #t indicating modules that changed while @@ -2577,12 +2547,7 @@ gets GC'd (making it impossible to use an anonymous lambda for PROC)." changed)))))))) (define (module-call-observers m) - (for-each (lambda (proc) (proc m)) (module-observers m)) - - ;; We assume that weak observers don't (un)register themselves as they are - ;; called since this would preclude proper iteration over the hash table - ;; elements. - (hash-for-each (lambda (id proc) (proc m)) (module-weak-observers m))) + (for-each (lambda (proc) (proc m)) (module-observers m))) @@ -3459,7 +3424,7 @@ error if selected binding does not exist in the used module." (error "binding not presentin module" name sym)))) #:warning "Failed to autoload ~a in ~a:\n" sym name)))) (module-constructor (make-hash-table 0) '() b #f #f name 'autoload #f - (make-hash-table 0) '() (make-weak-value-hash-table) #f + (make-hash-table 0) '() #f (make-hash-table 0) #f #f #f 0 (make-hash-table 0) #f))) (define (module-autoload! module . args) @@ -3884,9 +3849,11 @@ but it fails to load." ;; this hack is to work around a case in which ;; port-filename returns a symbol (`socket') for ;; sockets. - (filename (let ((f (assq-ref (or (syntax-source x) '()) - 'filename))) - (and (string? f) f)))) + (filename (and=> (syntax-source x) + (lambda (v) + (and=> (vector-ref v 0) + (lambda (f) + (and (string? f) f))))))) #'(eval-when (expand load eval) (let ((m (define-module* '(name name* ...) #:filename filename quoted-arg ...))) @@ -4373,7 +4340,7 @@ when none is available, reading FILE-NAME with READER." (make-variable-transformer (lambda (x) (let* ((src (syntax-source x)) - (file (and src (assq-ref src 'filename))) + (file (and src (vector-ref src 0))) (dir (and (string? file) (dirname file)))) ;; A module that uses `load' is not declarative. (when (module-declarative? (current-module)) @@ -4612,14 +4579,6 @@ R7RS." -;;; {Deprecated stuff} -;;; - -(begin-deprecated - (module-use! the-scm-module (resolve-interface '(ice-9 deprecated)))) - - - ;;; {Ports} ;;; @@ -4646,6 +4605,44 @@ R7RS." +;;; A few identifiers that need to be defined in this file are really +;;; internal implementation details. We shove them off into internal +;;; modules, removing them from the (guile) module. +;;; + +(let ((syntax-internal (define-module* '(system syntax internal)))) + (define (steal-bindings! from to ids) + (for-each + (lambda (sym) + (let ((v (module-local-variable from sym))) + (module-remove! from sym) + (module-add! to sym v))) + ids) + (module-export! to ids)) + + (steal-bindings! the-root-module + syntax-internal + '(syntax? + syntax-local-binding + %syntax-module + syntax-locally-bound-identifiers + syntax-session-id + make-syntax + syntax-expression + syntax-wrap + syntax-module))) + + + + +;;; {Deprecated stuff} +;;; + +(begin-deprecated + (module-use! the-scm-module (resolve-interface '(ice-9 deprecated)))) + + + ;;; {Threads} ;;; @@ -4685,38 +4682,6 @@ R7RS." -;;; A few identifiers that need to be defined in this file are really -;;; internal implementation details. We shove them off into internal -;;; modules, removing them from the (guile) module. -;;; - -(define-module (system syntax internal)) - -(let () - (define (steal-bindings! from to ids) - (for-each - (lambda (sym) - (let ((v (module-local-variable from sym))) - (module-remove! from sym) - (module-add! to sym v))) - ids) - (module-export! to ids)) - - (steal-bindings! the-root-module (resolve-module '(system syntax internal)) - '(syntax? - syntax-local-binding - %syntax-module - syntax-locally-bound-identifiers - syntax-session-id - make-syntax - syntax-expression - syntax-wrap - syntax-module - syntax-sourcev))) - - - - ;;; Place the user in the guile-user module. ;;; diff --git a/module/ice-9/buffered-input.scm b/module/ice-9/buffered-input.scm index 56b1d87cb..767dadab0 100644 --- a/module/ice-9/buffered-input.scm +++ b/module/ice-9/buffered-input.scm @@ -1,6 +1,6 @@ ;;;; buffered-input.scm --- construct a port from a buffered input reader ;;;; -;;;; Copyright (C) 2001, 2006, 2010 Free Software Foundation, Inc. +;;;; Copyright (C) 2001, 2006, 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 @@ -17,6 +17,7 @@ ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA (define-module (ice-9 buffered-input) + #:use-module (ice-9 object-properties) #:export (make-buffered-input-port make-line-buffered-input-port set-buffered-input-continuation?!)) diff --git a/module/ice-9/deprecated.scm b/module/ice-9/deprecated.scm index 4d87e8fb3..6ff24c4c6 100644 --- a/module/ice-9/deprecated.scm +++ b/module/ice-9/deprecated.scm @@ -17,7 +17,24 @@ (define-module (ice-9 deprecated) #:use-module (ice-9 guardians) - #:export ((make-guardian* . make-guardian))) + #:use-module (ice-9 object-properties) + #:use-module (ice-9 source-properties) + #:use-module (ice-9 weak-tables) + #:export ((make-guardian* . make-guardian) + module-observe-weak + (make-object-property* . make-object-property) + (make-weak-key-hash-table* . make-weak-key-hash-table) + (make-weak-value-hash-table* . make-weak-value-hash-table) + (make-doubly-weak-hash-table* . make-doubly-weak-hash-table) + (weak-key-hash-table?* . weak-key-hash-table?) + (weak-value-hash-table?* . weak-value-hash-table?) + (doubly-weak-hash-table?* . doubly-weak-hash-table?) + (supports-source-properties?* . supports-source-properties?) + (source-properties* . source-properties) + (set-source-properties!* . set-source-properties!) + (source-property* . source-property) + (set-source-properties* . set-source-property!) + (cons-source* . cons-source))) #; (define-syntax-rule (define-deprecated name message exp) @@ -34,3 +51,110 @@ "make-guardian in the default environment is deprecated. Import it from (ice-9 guardians) instead.") (make-guardian)) + +(define* (module-observe-weak module observer-id #:optional (proc observer-id)) + (issue-deprecation-warning + "module-observe-weak is deprecated. Use module-observe instead.") + (module-observe module proc)) + +(define (make-object-property*) + (issue-deprecation-warning + "make-object-property in the default environment is deprecated. Import +it from (ice-9 object-properties) instead.") + (make-object-property)) + +(define (object-properties* obj) + (issue-deprecation-warning + "object-properties in the default environment is deprecated. Import +it from (ice-9 object-properties) instead.") + (object-properties obj)) + +(define (set-object-properties!* obj props) + (issue-deprecation-warning + "set-object-properties! in the default environment is deprecated. Import +it from (ice-9 object-properties) instead.") + (set-object-properties! obj props)) + +(define (object-property* obj key) + (issue-deprecation-warning + "object-property in the default environment is deprecated. Import +it from (ice-9 object-properties) instead.") + (object-property obj key)) + +(define (set-object-property!* obj key value) + (issue-deprecation-warning + "set-object-properties! in the default environment is deprecated. Import +it from (ice-9 object-properties) instead.") + (set-object-property! obj key value)) + +(define* (make-weak-key-hash-table* #:optional (n 0)) + (issue-deprecation-warning + "make-weak-key-hash-table in the default environment is deprecated. +Import it from (ice-9 weak-tables) instead.") + (make-weak-key-hash-table)) + +(define* (make-weak-value-hash-table* #:optional (n 0)) + (issue-deprecation-warning + "make-weak-value-hash-table in the default environment is deprecated. +Import it from (ice-9 weak-tables) instead.") + (make-weak-value-hash-table)) + +(define* (make-doubly-weak-hash-table* #:optional (n 0)) + (issue-deprecation-warning + "make-weak-key-hash-table in the default environment is deprecated. +Import it from (ice-9 weak-tables) instead.") + (make-doubly-weak-hash-table)) + +(define (weak-key-hash-table?* x) + (issue-deprecation-warning + "weak-key-hash-table? in the default environment is deprecated. +Import it from (ice-9 weak-tables) instead.") + (weak-key-hash-table? x)) + +(define (weak-value-hash-table?* x) + (issue-deprecation-warning + "weak-value-hash-table? in the default environment is deprecated. +Import it from (ice-9 weak-tables) instead.") + (weak-value-hash-table? x)) + +(define (doubly-weak-hash-table?* x) + (issue-deprecation-warning + "doubly-weak-hash-table? in the default environment is deprecated. +Import it from (ice-9 weak-tables) instead.") + (doubly-weak-hash-table? x)) + +(define (supports-source-properties?* x) + (issue-deprecation-warning + "supports-source-properties? in the default environment is deprecated. +Import it from (ice-9 source-properties) instead.") + (supports-source-properties? x)) + +(define (source-properties* x) + (issue-deprecation-warning + "source-properties in the default environment is deprecated. +Import it from (ice-9 source-properties) instead.") + (source-properties x)) + +(define (set-source-properties!* x alist) + (issue-deprecation-warning + "set-source-properties! in the default environment is deprecated. +Import it from (ice-9 source-properties) instead.") + (set-source-properties! x alist)) + +(define (source-property* x k) + (issue-deprecation-warning + "source-property in the default environment is deprecated. +Import it from (ice-9 source-properties) instead.") + (source-property x k)) + +(define (set-source-property!* x k v) + (issue-deprecation-warning + "set-source-property! in the default environment is deprecated. +Import it from (ice-9 source-properties) instead.") + (set-source-property! x k v)) + +(define (cons-source* orig x y) + (issue-deprecation-warning + "cons-source in the default environment is deprecated. +Import it from (ice-9 source-properties) instead.") + (cons-source orig x y)) diff --git a/module/ice-9/documentation.scm b/module/ice-9/documentation.scm index 5698bd653..2b6511d9a 100644 --- a/module/ice-9/documentation.scm +++ b/module/ice-9/documentation.scm @@ -1,5 +1,5 @@ ;;; documentation.scm --- Run-time documentation facility -;;; Copyright (C) 2000-2003,2006,2009,2010,2024 Free Software Foundation, Inc. +;;; Copyright (C) 2000-2003,2006,2009,2010,2024,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 License as @@ -79,6 +79,7 @@ ;;; Code: (define-module (ice-9 documentation) + #:use-module (ice-9 object-properties) #:use-module (ice-9 rdelim) #:use-module (ice-9 regex) #:use-module (ice-9 match) diff --git a/module/ice-9/ephemerons.scm b/module/ice-9/ephemerons.scm index a48b4127f..a15062f9a 100644 --- a/module/ice-9/ephemerons.scm +++ b/module/ice-9/ephemerons.scm @@ -25,7 +25,17 @@ make-ephemeron ephemeron-key ephemeron-value - ephemeron-mark-dead!)) + ephemeron-swap! + ephemeron-mark-dead! + ephemeron-next + + make-ephemeron-table + ephemeron-table? + ephemeron-table-length + + ephemeron-table-ref + ephemeron-table-push! + ephemeron-table-try-push!)) (eval-when (expand load eval) (load-extension (string-append "libguile-" (effective-version)) diff --git a/module/ice-9/hcons.scm b/module/ice-9/hcons.scm index 7275cf476..cddbbf8fe 100644 --- a/module/ice-9/hcons.scm +++ b/module/ice-9/hcons.scm @@ -1,6 +1,6 @@ ;;; installed-scm-file -;;;; Copyright (C) 1995, 1996, 1998, 2001, 2003, 2006 Free Software Foundation, Inc. +;;;; Copyright (C) 1995, 1996, 1998, 2001, 2003, 2006, 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,9 +19,10 @@ (define-module (ice-9 hcons) - :export (hashq-cons-hash hashq-cons-assoc hashq-cons-get-handle - hashq-cons-create-handle! hashq-cons-ref hashq-cons-set! hashq-cons - hashq-conser make-gc-buffer)) + #:use-module (ice-9 weak-tables) + #:export (hashq-cons-hash hashq-cons-assoc hashq-cons-get-handle + hashq-cons-create-handle! hashq-cons-ref hashq-cons-set! hashq-cons + hashq-conser make-gc-buffer)) ;;; {Eq? hash-consing} diff --git a/module/ice-9/object-properties.scm b/module/ice-9/object-properties.scm new file mode 100644 index 000000000..c587262b2 --- /dev/null +++ b/module/ice-9/object-properties.scm @@ -0,0 +1,64 @@ +;;; Copyright (C) 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 License as +;;; published by the Free Software Foundation, either version 3 of the +;;; License, or (at your option) any later version. +;;; +;;; This library is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; Lesser General Public License for more details. +;;; +;;; You should have received a copy of the GNU Lesser General Public +;;; License along with this program. If not, see +;;; <http://www.gnu.org/licenses/>. + +;;; Commentary: +;;; +;;; Properties are a lispy way to associate random info with random +;;; objects. Traditionally properties are implemented as an alist or a +;;; plist actually pertaining to the object in question. +;;; +;;; These "object properties" have the advantage that they can be +;;; associated with any object, even if the object has no plist. Object +;;; properties are good when you are extending pre-existing objects in +;;; unexpected ways. They also present a pleasing, uniform +;;; procedure-with-setter interface. But if you have a data type that +;;; always has properties, it's often still best to store those +;;; properties within the object itself. +;;; +;;; Code: + + +(define-module (ice-9 object-properties) + #:use-module (ice-9 weak-tables) + ;; FIXME: Change to #:export when deprecated bindings removed. + #:replace (make-object-property + + object-properties + set-object-properties! + object-property + set-object-property!)) + +(define (make-object-property) + ;; 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))))) + +;; FIXME: Deprecate these global properties. +(define global-properties (make-weak-key-hash-table)) + +(define (object-properties obj) + (hashq-ref global-properties obj '())) + +(define (set-object-properties! obj props) + (hashq-set! global-properties obj props)) + +(define (object-property obj key) + (assq-ref (object-properties obj) key)) + +(define (set-object-property! obj key value) + (set-object-properties! obj (assq-set! (object-properties obj) key value))) diff --git a/module/ice-9/poe.scm b/module/ice-9/poe.scm index c19a760b2..5d99bf9c8 100644 --- a/module/ice-9/poe.scm +++ b/module/ice-9/poe.scm @@ -1,6 +1,6 @@ ;;; installed-scm-file -;;;; Copyright (C) 1996, 2001, 2006, 2011 Free Software Foundation, Inc. +;;;; Copyright (C) 1996, 2001, 2006, 2011, 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,8 +19,9 @@ (define-module (ice-9 poe) - :use-module (ice-9 hcons) - :export (pure-funcq perfect-funcq)) + #:use-module (ice-9 hcons) + #:use-module (ice-9 weak-tables) + #:export (pure-funcq perfect-funcq)) diff --git a/module/ice-9/popen.scm b/module/ice-9/popen.scm index befa528ab..0cc7d16ba 100644 --- a/module/ice-9/popen.scm +++ b/module/ice-9/popen.scm @@ -22,6 +22,7 @@ #:use-module (ice-9 binary-ports) #:use-module (ice-9 guardians) #:use-module (ice-9 threads) + #: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 diff --git a/module/ice-9/psyntax-pp.scm b/module/ice-9/psyntax-pp.scm index d5b428d8c..687d1f6cf 100644 --- a/module/ice-9/psyntax-pp.scm +++ b/module/ice-9/psyntax-pp.scm @@ -5,8 +5,7 @@ (make-syntax (module-ref (current-module) 'make-syntax)) (syntax-expression (module-ref (current-module) 'syntax-expression)) (syntax-wrap (module-ref (current-module) 'syntax-wrap)) - (syntax-module (module-ref (current-module) 'syntax-module)) - (syntax-sourcev (module-ref (current-module) 'syntax-sourcev))) + (syntax-module (module-ref (current-module) 'syntax-module))) (letrec* ((make-void (lambda (src) (make-struct/simple (vector-ref %expanded-vtables 0) src))) (make-const (lambda (src exp) (make-struct/simple (vector-ref %expanded-vtables 1) src exp))) (make-primitive-ref (lambda (src name) (make-struct/simple (vector-ref %expanded-vtables 2) src name))) @@ -177,11 +176,7 @@ (if (null? v) body-exp (fk))))) (gen-lexical (lambda (id) (module-gensym (symbol->string id)))) (no-source #f) - (datum-sourcev - (lambda (datum) - (let ((props (source-properties datum))) - (and (pair? props) (vector (assq-ref props 'filename) (assq-ref props 'line) (assq-ref props 'column)))))) - (source-annotation (lambda (x) (if (syntax? x) (syntax-sourcev x) (datum-sourcev x)))) + (source-annotation (lambda (x) (and (syntax? x) (syntax-source x)))) (binding-type (lambda (x) (car x))) (binding-value (lambda (x) (cdr x))) (null-env '()) @@ -667,8 +662,7 @@ (if (null? v) #f (fk))))) (wrap (lambda (x w defmod) (source-wrap x w #f defmod))) (wrap-syntax - (lambda (x w defmod) - (make-syntax (syntax-expression x) w (or (syntax-module x) defmod) (syntax-sourcev x)))) + (lambda (x w defmod) (make-syntax (syntax-expression x) w (or (syntax-module x) defmod) (syntax-source x)))) (source-wrap (lambda (x w s defmod) (cond @@ -1141,11 +1135,11 @@ (source-wrap e w (wrap-subst w) mod) x)) (else (decorate-source x)))))) - (let* ((t-680b775fb37a463-c45 transformer-environment) - (t-680b775fb37a463-c46 (lambda (k) (k e r w s rib mod)))) + (let* ((t-680b775fb37a463-c30 transformer-environment) + (t-680b775fb37a463-c31 (lambda (k) (k e r w s rib mod)))) (with-fluid* - t-680b775fb37a463-c45 - t-680b775fb37a463-c46 + t-680b775fb37a463-c30 + t-680b775fb37a463-c31 (lambda () (rebuild-macro-output (p (source-wrap e (anti-mark w) s mod)) (new-mark)))))))) (expand-body (lambda (body outer-form r w mod) @@ -1676,11 +1670,11 @@ s mod get-formals - (map (lambda (tmp-680b775fb37a463-ece - tmp-680b775fb37a463-ecd - tmp-680b775fb37a463-ecc) - (cons tmp-680b775fb37a463-ecc - (cons tmp-680b775fb37a463-ecd tmp-680b775fb37a463-ece))) + (map (lambda (tmp-680b775fb37a463-eb9 + tmp-680b775fb37a463-eb8 + tmp-680b775fb37a463-eb7) + (cons tmp-680b775fb37a463-eb7 + (cons tmp-680b775fb37a463-eb8 tmp-680b775fb37a463-eb9))) e2* e1* args*))) @@ -1691,17 +1685,11 @@ tmp-1) (syntax-violation #f "source expression failed to match any pattern" tmp)))))))) (strip (lambda (x) - (letrec* ((annotate - (lambda (proc datum) - (let ((s (proc x))) - (if (and s (supports-source-properties? datum)) - (set-source-properties! datum (sourcev->alist s))) - datum)))) - (cond - ((syntax? x) (annotate syntax-sourcev (strip (syntax-expression x)))) - ((pair? x) (cons (strip (car x)) (strip (cdr x)))) - ((vector? x) (list->vector (strip (vector->list x)))) - (else x))))) + (cond + ((syntax? x) (strip (syntax-expression x))) + ((pair? x) (cons (strip (car x)) (strip (cdr x)))) + ((vector? x) (list->vector (strip (vector->list x)))) + (else x)))) (gen-var (lambda (id) (let ((id (if (syntax? id) (syntax-expression id) id))) (gen-lexical id)))) (lambda-var-list (lambda (vars) @@ -1995,11 +1983,11 @@ (apply (lambda (docstring args e1 e2) (build-it (list (cons 'documentation (syntax->datum docstring))) - (map (lambda (tmp-680b775fb37a463-117f - tmp-680b775fb37a463-117e - tmp-680b775fb37a463-117d) - (cons tmp-680b775fb37a463-117d - (cons tmp-680b775fb37a463-117e tmp-680b775fb37a463-117f))) + (map (lambda (tmp-680b775fb37a463-115f + tmp-680b775fb37a463-115e + tmp-680b775fb37a463-115d) + (cons tmp-680b775fb37a463-115d + (cons tmp-680b775fb37a463-115e tmp-680b775fb37a463-115f))) e2 e1 args))) @@ -2016,7 +2004,7 @@ '#{ $sc-ellipsis }# (syntax-wrap dots) (syntax-module dots) - (syntax-sourcev dots))))) + (syntax-source dots))))) (let ((ids (list id)) (labels (list (gen-label))) (bindings (list (cons 'ellipsis (source-wrap dots w s mod))))) @@ -2166,7 +2154,7 @@ (remodulate (syntax-expression x) mod) (syntax-wrap x) mod - (syntax-sourcev x))) + (syntax-source x))) ((vector? x) (let* ((n (vector-length x)) (v (make-vector n))) (let loop ((i 0)) @@ -2449,27 +2437,7 @@ (global-extend 'core 'syntax-case expand-syntax-case) (set! macroexpand (lambda* (x #:optional (m 'e) (esew '(eval))) - (letrec* ((unstrip - (lambda (x) - (letrec* ((annotate - (lambda (result) - (let ((props (source-properties x))) - (if (pair? props) (datum->syntax #f result #:source props) result))))) - (cond - ((pair? x) (annotate (cons (unstrip (car x)) (unstrip (cdr x))))) - ((vector? x) - (let ((v (make-vector (vector-length x)))) - (annotate (list->vector (map unstrip (vector->list x)))))) - ((syntax? x) x) - (else (annotate x))))))) - (expand-top-sequence - (list (unstrip x)) - null-env - top-wrap - #f - m - esew - (cons 'hygiene (module-name (current-module))))))) + (expand-top-sequence (list x) null-env top-wrap #f m esew (cons 'hygiene (module-name (current-module)))))) (set! identifier? (lambda (x) (nonsymbol-id? x))) (set! datum->syntax (lambda* (id datum #:key (source #f #:source)) @@ -2482,10 +2450,10 @@ (if id (syntax-wrap id) empty-wrap) (and id (syntax-module id)) (cond - ((not source) (props->sourcev (source-properties datum))) + ((not source) #f) ((and (list? source) (and-map pair? source)) (props->sourcev source)) ((and (vector? source) (= 3 (vector-length source))) source) - (else (syntax-sourcev source))))))) + (else (syntax-source source))))))) (set! syntax->datum (lambda (x) (strip x))) (set! generate-temporaries (lambda (ls) @@ -2822,9 +2790,9 @@ #f k '() - (map (lambda (tmp-680b775fb37a463-145d tmp-680b775fb37a463-145c tmp-680b775fb37a463-145b) - (list (cons tmp-680b775fb37a463-145b tmp-680b775fb37a463-145c) - tmp-680b775fb37a463-145d)) + (map (lambda (tmp-680b775fb37a463-143d tmp-680b775fb37a463-143c tmp-680b775fb37a463-143b) + (list (cons tmp-680b775fb37a463-143b tmp-680b775fb37a463-143c) + tmp-680b775fb37a463-143d)) template pattern keyword))) @@ -2852,11 +2820,11 @@ dots k '() - (map (lambda (tmp-680b775fb37a463-148f - tmp-680b775fb37a463-148e - tmp-680b775fb37a463-148d) - (list (cons tmp-680b775fb37a463-148d tmp-680b775fb37a463-148e) - tmp-680b775fb37a463-148f)) + (map (lambda (tmp-680b775fb37a463-146f + tmp-680b775fb37a463-146e + tmp-680b775fb37a463-146d) + (list (cons tmp-680b775fb37a463-146d tmp-680b775fb37a463-146e) + tmp-680b775fb37a463-146f)) template pattern keyword))) @@ -2872,11 +2840,11 @@ dots k (list docstring) - (map (lambda (tmp-680b775fb37a463-14ae - tmp-680b775fb37a463-14ad - tmp-680b775fb37a463-14ac) - (list (cons tmp-680b775fb37a463-14ac tmp-680b775fb37a463-14ad) - tmp-680b775fb37a463-14ae)) + (map (lambda (tmp-680b775fb37a463-148e + tmp-680b775fb37a463-148d + tmp-680b775fb37a463-148c) + (list (cons tmp-680b775fb37a463-148c tmp-680b775fb37a463-148d) + tmp-680b775fb37a463-148e)) template pattern keyword))) @@ -3004,9 +2972,9 @@ (apply (lambda (p) (if (= lev 0) (quasilist* - (map (lambda (tmp-680b775fb37a463-155b) + (map (lambda (tmp-680b775fb37a463-153b) (list "value" - tmp-680b775fb37a463-155b)) + tmp-680b775fb37a463-153b)) p) (quasi q lev)) (quasicons @@ -3091,8 +3059,8 @@ (apply (lambda (p) (if (= lev 0) (quasiappend - (map (lambda (tmp-680b775fb37a463-157b) - (list "value" tmp-680b775fb37a463-157b)) + (map (lambda (tmp-680b775fb37a463-155b) + (list "value" tmp-680b775fb37a463-155b)) p) (vquasi q lev)) (quasicons @@ -3174,8 +3142,8 @@ (let ((tmp-1 ls)) (let ((tmp ($sc-dispatch tmp-1 'each-any))) (if tmp - (apply (lambda (t-680b775fb37a463-15c4) - (cons "vector" t-680b775fb37a463-15c4)) + (apply (lambda (t-680b775fb37a463-15a4) + (cons "vector" t-680b775fb37a463-15a4)) tmp) (syntax-violation #f @@ -3185,8 +3153,8 @@ (let ((tmp-1 ($sc-dispatch tmp '(#(atom "quote") each-any)))) (if tmp-1 (apply (lambda (y) - (k (map (lambda (tmp-680b775fb37a463-15d0) - (list "quote" tmp-680b775fb37a463-15d0)) + (k (map (lambda (tmp-680b775fb37a463-15b0) + (list "quote" tmp-680b775fb37a463-15b0)) y))) tmp-1) (let ((tmp-1 ($sc-dispatch tmp '(#(atom "list") . each-any)))) @@ -3197,8 +3165,8 @@ (apply (lambda (y z) (f z (lambda (ls) (k (append y ls))))) tmp-1) (let ((else tmp)) (let ((tmp x)) - (let ((t-680b775fb37a463-15df tmp)) - (list "list->vector" t-680b775fb37a463-15df))))))))))))))))) + (let ((t-680b775fb37a463-15bf tmp)) + (list "list->vector" t-680b775fb37a463-15bf))))))))))))))))) (emit (lambda (x) (let ((tmp x)) (let ((tmp-1 ($sc-dispatch tmp '(#(atom "quote") any)))) @@ -3210,9 +3178,9 @@ (let ((tmp-1 (map emit x))) (let ((tmp ($sc-dispatch tmp-1 'each-any))) (if tmp - (apply (lambda (t-680b775fb37a463-15ee) + (apply (lambda (t-680b775fb37a463-15ce) (cons (make-syntax 'list '((top)) '(hygiene guile)) - t-680b775fb37a463-15ee)) + t-680b775fb37a463-15ce)) tmp) (syntax-violation #f @@ -3228,13 +3196,14 @@ (let ((tmp-1 (list (emit (car x*)) (f (cdr x*))))) (let ((tmp ($sc-dispatch tmp-1 '(any any)))) (if tmp - (apply (lambda (t-680b775fb37a463-1 t-680b775fb37a463) + (apply (lambda (t-680b775fb37a463-15e2 + t-680b775fb37a463-15e1) (list (make-syntax 'cons '((top)) '(hygiene guile)) - t-680b775fb37a463-1 - t-680b775fb37a463)) + t-680b775fb37a463-15e2 + t-680b775fb37a463-15e1)) tmp) (syntax-violation #f @@ -3247,12 +3216,12 @@ (let ((tmp-1 (map emit x))) (let ((tmp ($sc-dispatch tmp-1 'each-any))) (if tmp - (apply (lambda (t-680b775fb37a463-160e) + (apply (lambda (t-680b775fb37a463-15ee) (cons (make-syntax 'append '((top)) '(hygiene guile)) - t-680b775fb37a463-160e)) + t-680b775fb37a463-15ee)) tmp) (syntax-violation #f @@ -3265,12 +3234,12 @@ (let ((tmp-1 (map emit x))) (let ((tmp ($sc-dispatch tmp-1 'each-any))) (if tmp - (apply (lambda (t-680b775fb37a463-161a) + (apply (lambda (t-680b775fb37a463-15fa) (cons (make-syntax 'vector '((top)) '(hygiene guile)) - t-680b775fb37a463-161a)) + t-680b775fb37a463-15fa)) tmp) (syntax-violation #f @@ -3305,7 +3274,7 @@ (define call-with-include-port (let ((syntax-dirname (lambda (stx) - (letrec* ((src (syntax-source stx)) (filename (if src (assq-ref src 'filename) #f))) + (letrec* ((src (syntax-source stx)) (filename (if src (vector-ref src 0) #f))) (if (string? filename) (dirname filename) #f))))) (lambda* (filename proc #:key (dirname (syntax-dirname filename) #:dirname)) "Like @code{call-with-input-file}, except relative paths are\nsearched relative to the @var{dirname} instead of the current working\ndirectory. Also, @var{filename} can be a syntax object; in that case,\nand if @var{dirname} is not specified, the @code{syntax-source} of\n@var{filename} is used to obtain a base directory for relative file\nnames." diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm index 84fcd7262..da2fe8978 100644 --- a/module/ice-9/psyntax.scm +++ b/module/ice-9/psyntax.scm @@ -1,6 +1,6 @@ ;;;; -*-scheme-*- ;;;; -;;;; Copyright (C) 1997-1998,2000-2003,2005-2006,2008-2013,2015-2022,2024 +;;;; Copyright (C) 1997-1998,2000-2003,2005-2006,2008-2013,2015-2022,2024,2025 ;;;; Free Software Foundation, Inc. ;;;; ;;;; This library is free software: you can redistribute it and/or modify @@ -74,8 +74,7 @@ (make-syntax (module-ref (current-module) 'make-syntax)) (syntax-expression (module-ref (current-module) 'syntax-expression)) (syntax-wrap (module-ref (current-module) 'syntax-wrap)) - (syntax-module (module-ref (current-module) 'syntax-module)) - (syntax-sourcev (module-ref (current-module) 'syntax-sourcev))) + (syntax-module (module-ref (current-module) 'syntax-module))) (define-syntax define-expansion-constructors (lambda (x) @@ -303,17 +302,8 @@ (define no-source #f) - (define (datum-sourcev datum) - (let ((props (source-properties datum))) - (and (pair? props) - (vector (assq-ref props 'filename) - (assq-ref props 'line) - (assq-ref props 'column))))) - (define (source-annotation x) - (if (syntax? x) - (syntax-sourcev x) - (datum-sourcev x))) + (and (syntax? x) (syntax-source x))) (define-syntax-rule (arg-check pred? e who) (let ((x e)) @@ -898,7 +888,7 @@ (make-syntax (syntax-expression x) w (or (syntax-module x) defmod) - (syntax-sourcev x))) + (syntax-source x))) (define (source-wrap x w s defmod) (cond ((and (null? (wrap-marks w)) @@ -1863,14 +1853,9 @@ ;; strips syntax objects, recursively. (define (strip x) - (define (annotate proc datum) - (let ((s (proc x))) - (when (and s (supports-source-properties? datum)) - (set-source-properties! datum (sourcev->alist s))) - datum)) (cond ((syntax? x) - (annotate syntax-sourcev (strip (syntax-expression x)))) + (strip (syntax-expression x))) ((pair? x) (cons (strip (car x)) (strip (cdr x)))) ((vector? x) @@ -2179,7 +2164,7 @@ (make-syntax '#{ $sc-ellipsis }# (syntax-wrap #'dots) (syntax-module #'dots) - (syntax-sourcev #'dots))))) + (syntax-source #'dots))))) (let ((ids (list id)) (labels (list (gen-label))) (bindings (list (make-binding 'ellipsis (source-wrap #'dots w s mod))))) @@ -2327,7 +2312,7 @@ (syntax-wrap x) ;; hither the remodulation mod - (syntax-sourcev x))) + (syntax-source x))) ((vector? x) (let* ((n (vector-length x)) (v (make-vector n))) (do ((i 0 (1+ i))) @@ -2592,21 +2577,7 @@ ;; expanded, and the expanded definitions are also residualized into ;; the object file if we are compiling a file. (define*/override (macroexpand x #:optional (m 'e) (esew '(eval))) - (define (unstrip x) - (define (annotate result) - (let ((props (source-properties x))) - (if (pair? props) - (datum->syntax #f result #:source props) - result))) - (cond - ((pair? x) - (annotate (cons (unstrip (car x)) (unstrip (cdr x))))) - ((vector? x) - (let ((v (make-vector (vector-length x)))) - (annotate (list->vector (map unstrip (vector->list x)))))) - ((syntax? x) x) - (else (annotate x)))) - (expand-top-sequence (list (unstrip x)) null-env top-wrap #f m esew + (expand-top-sequence (list x) null-env top-wrap #f m esew (cons 'hygiene (module-name (current-module))))) (define/override (identifier? x) @@ -2626,13 +2597,12 @@ (syntax-module id) #f) (cond - ((not source) - (props->sourcev (source-properties datum))) + ((not source) #f) ((and (list? source) (and-map pair? source)) (props->sourcev source)) ((and (vector? source) (= 3 (vector-length source))) source) - (else (syntax-sourcev source))))) + (else (syntax-source source))))) (define/override (syntax->datum x) ;; accepts any object, since syntax objects may consist partially @@ -3086,7 +3056,7 @@ (define call-with-include-port (let ((syntax-dirname (lambda (stx) (define src (syntax-source stx)) - (define filename (and src (assq-ref src 'filename))) + (define filename (and src (vector-ref src 0))) (and (string? filename) (dirname filename))))) (lambda* (filename proc #:key (dirname (syntax-dirname filename))) diff --git a/module/ice-9/read.scm b/module/ice-9/read.scm index 283933064..b77d85552 100644 --- a/module/ice-9/read.scm +++ b/module/ice-9/read.scm @@ -1,5 +1,5 @@ ;;; Scheme reader -;;; Copyright (C) 1995-1997,1999-2001,2003-2004,2006-2012,2014-2021 +;;; Copyright (C) 1995-1997,1999-2001,2003-2004,2006-2012,2014-2021,2025 ;;; Free Software Foundation, Inc. ;;; ;;; This library is free software: you can redistribute it and/or modify @@ -857,24 +857,7 @@ (define* (read #:optional (port (current-input-port))) (define filename (port-filename port)) - (define annotate - (if (memq 'positions (read-options)) - (lambda (line column datum) - (when (and (supports-source-properties? datum) - ;; Line or column can be invalid via - ;; set-port-column! or ungetting chars beyond start - ;; of line. - (<= 0 line) - (<= 1 column)) - ;; We always capture the column after one char of lookahead; - ;; subtract off that lookahead value. - (set-source-properties! datum - `((filename . ,filename) - (line . ,line) - (column . ,(1- column))))) - datum) - (lambda (line column datum) - datum))) + (define (annotate line column datum) datum) (%read port annotate identity)) (define* (read-syntax #:optional (port (current-input-port))) diff --git a/module/ice-9/sandbox.scm b/module/ice-9/sandbox.scm index 601485cce..c17e53282 100644 --- a/module/ice-9/sandbox.scm +++ b/module/ice-9/sandbox.scm @@ -1,6 +1,6 @@ ;;; Sandboxed evaluation of Scheme code -;;; Copyright (C) 2017, 2018 Free Software Foundation, Inc. +;;; Copyright (C) 2017, 2018, 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 @@ -845,7 +845,6 @@ allocation limit is exceeded, an exception will be thrown to the (define hash-bindings '(((guile) - doubly-weak-hash-table? hash hash-count hash-fold @@ -863,8 +862,10 @@ allocation limit is exceeded, an exception will be thrown to the hashv-ref hashx-get-handle hashx-ref + make-hash-table) + ((ice-9 weak-tables) + doubly-weak-hash-table? make-doubly-weak-hash-table - make-hash-table make-weak-key-hash-table make-weak-value-hash-table weak-key-hash-table? diff --git a/module/ice-9/source-properties.scm b/module/ice-9/source-properties.scm new file mode 100644 index 000000000..0fa5336a6 --- /dev/null +++ b/module/ice-9/source-properties.scm @@ -0,0 +1,107 @@ +;;; Copyright (C) 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 License as +;;; published by the Free Software Foundation, either version 3 of the +;;; License, or (at your option) any later version. +;;; +;;; This library is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; Lesser General Public License for more details. +;;; +;;; You should have received a copy of the GNU Lesser General Public +;;; License along with this program. If not, see +;;; <http://www.gnu.org/licenses/>. + +;;; Commentary: +;;; +;;; Code: + + +(define-module (ice-9 source-properties) + #:use-module (ice-9 weak-tables) + #:use-module (system syntax internal) + #:use-module (ice-9 match) + ;; FIXME: Change to #:export when deprecated bindings removed. + #:replace (supports-source-properties? + source-property + set-source-property! + source-properties + set-source-properties! + read)) + +(define global-source-properties (make-weak-key-hash-table)) + +(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 (supports-source-properties? x) + (cond + ((immediate? x) #f) + ((symbol? x) #f) + ((keyword? x) #f) + (else #t))) + +(define (source-properties obj) + (if (supports-source-properties? obj) + (hashq-ref global-source-properties obj '()) + '())) + +(define (set-source-properties! obj props) + (unless (supports-source-properties? obj) + (scm-error 'wrong-type-arg "set-source-properties!" + "Unexpected immediate value: ~S" + (list obj) #f)) + (hashq-set! global-source-properties obj props)) + +(define (source-property obj key) + (and (supports-source-properties? obj) + (assq-ref (source-properties obj) key))) + +(define (set-source-property! obj key value) + (unless (supports-source-properties? obj) + (scm-error 'wrong-type-arg "set-source-properties!" + "Unexpected immediate value: ~S" + (list obj) #f)) + (set-source-properties! obj (assq-set! (source-properties obj) key value))) + +(define (cons-source orig x y) + (let ((pair (cons x y)) + (src (source-properties orig))) + (when (pair? src) + (set-source-properties! pair src)) + pair)) + +(define* (read #:optional (port (current-input-port))) + (define (annotate x src) + (when (supports-source-properties? x) + (match src + (#(filename line column) + (set-source-properties! x `((filename . ,filename) + (line . ,line) + (column . ,column)))) + (#f (values)))) + x) + (define (strip-and-annotate x) + (cond + ((syntax? x) + (annotate (strip-and-annotate (syntax-expression x)) + (syntax-source x))) + ((pair? x) + (cons (strip-and-annotate (car x)) + (strip-and-annotate (cdr x)))) + ((vector? x) + (list->vector (map strip-and-annotate (vector->list x)))) + (else + x))) + (strip-and-annotate (read-syntax port))) diff --git a/module/ice-9/threads.scm b/module/ice-9/threads.scm index 0d3880d69..dec380c38 100644 --- a/module/ice-9/threads.scm +++ b/module/ice-9/threads.scm @@ -102,9 +102,6 @@ no-op." (error "thread cancellation failed, throwing error instead???")))) thread)) -(define thread-join-data (make-object-property)) -(define %thread-results (make-object-property)) - (define* (call-with-new-thread thunk #:optional handler) "Call @code{thunk} in a new thread and with a new dynamic state, returning a new thread object representing the thread. The procedure @@ -146,15 +143,7 @@ Once @var{thunk} or @var{handler} returns, the return value is made the (lambda () (lock-mutex mutex) (set! thread (current-thread)) - ;; Rather than use the 'set!' syntax here, we use the - ;; underlying 'setter' generic function to set the - ;; 'thread-join-data' property on 'thread'. This is - ;; because 'set!' will try to resolve 'setter' in the - ;; '(guile)' module, which means acquiring the - ;; 'autoload' mutex. If the calling thread is - ;; already holding that mutex, this will result in - ;; deadlock. See <https://bugs.gnu.org/62691>. - ((setter thread-join-data) thread (cons cv mutex)) + (%thread-init-joinable! thread cv mutex) (signal-condition-variable cv) (unlock-mutex mutex) (call-with-unblocked-asyncs @@ -163,16 +152,7 @@ Once @var{thunk} or @var{handler} returns, the return value is made the (apply values args)))) (lambda vals (lock-mutex mutex) - ;; Probably now you're wondering why we are going to use - ;; the cond variable as the key into the thread results - ;; object property. It's because there is a possibility - ;; that the thread object itself ends up as part of the - ;; result, and if that happens we create a cycle whereby - ;; the strong reference to a thread in the value of the - ;; weak-key hash table used by the object property prevents - ;; the thread from ever being collected. So instead we use - ;; the cv as the key. Weak-key hash tables, amirite? - (set! (%thread-results cv) vals) + (%thread-set-join-results! thread vals) (broadcast-condition-variable cv) (unlock-mutex mutex) (apply values vals))))) @@ -185,23 +165,24 @@ Once @var{thunk} or @var{handler} returns, the return value is made the (define* (join-thread thread #:optional timeout timeoutval) "Suspend execution of the calling thread until the target @var{thread} terminates, unless the target @var{thread} has already terminated." - (match (thread-join-data thread) - (#f (error "foreign thread cannot be joined" thread)) - ((cv . mutex) - (lock-mutex mutex) - (let lp () - (cond - ((%thread-results cv) - => (lambda (results) - (unlock-mutex mutex) - (apply values results))) - ((if timeout - (wait-condition-variable cv mutex timeout) - (wait-condition-variable cv mutex)) - (lp)) - (else - (unlock-mutex mutex) - timeoutval)))))) + (define cv (%thread-join-cond thread)) + (define mutex (%thread-join-lock thread)) + (unless cv + (error "foreign thread cannot be joined" thread)) + (lock-mutex mutex) + (let lp () + (cond + ((%thread-join-results thread) + => (lambda (results) + (unlock-mutex mutex) + (apply values results))) + ((if timeout + (wait-condition-variable cv mutex timeout) + (wait-condition-variable cv mutex)) + (lp)) + (else + (unlock-mutex mutex) + timeoutval)))) (define* (try-mutex mutex) "Try to lock @var{mutex}. If the mutex is already locked, return diff --git a/module/ice-9/weak-tables.scm b/module/ice-9/weak-tables.scm new file mode 100644 index 000000000..924ceec23 --- /dev/null +++ b/module/ice-9/weak-tables.scm @@ -0,0 +1,35 @@ +;;; Copyright (C) 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 License as +;;; published by the Free Software Foundation, either version 3 of the +;;; License, or (at your option) any later version. +;;; +;;; This library is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; Lesser General Public License for more details. +;;; +;;; You should have received a copy of the GNU Lesser General Public +;;; License along with this program. If not, see +;;; <http://www.gnu.org/licenses/>. + +;;; Commentary: +;;; +;;; +;;; Code: + + +(define-module (ice-9 weak-tables) + ;; FIXME: Change to #:export when deprecated code removed. + #:replace (make-weak-key-hash-table + make-weak-value-hash-table + make-doubly-weak-hash-table + + weak-key-hash-table? + weak-value-hash-table? + doubly-weak-hash-table?)) + +(eval-when (expand load eval) + (load-extension (string-append "libguile-" (effective-version)) + "scm_init_weak_tables")) diff --git a/module/language/cps.scm b/module/language/cps.scm index 42ebb0fe6..aefb68e0e 100644 --- a/module/language/cps.scm +++ b/module/language/cps.scm @@ -1,6 +1,6 @@ ;;; Continuation-passing style (CPS) intermediate language (IL) -;; Copyright (C) 2013-2015,2017-2018,2020,2021 Free Software Foundation, Inc. +;; Copyright (C) 2013-2015,2017-2018,2020,2021,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 @@ -116,6 +116,7 @@ (define-module (language cps) #:use-module (ice-9 match) + #:use-module (ice-9 source-properties) #:use-module (srfi srfi-9) #:use-module (srfi srfi-9 gnu) #:use-module (srfi srfi-11) diff --git a/module/language/cps/spec.scm b/module/language/cps/spec.scm index 5864203cb..780b982e0 100644 --- a/module/language/cps/spec.scm +++ b/module/language/cps/spec.scm @@ -1,6 +1,6 @@ ;;; Continuation-passing style (CPS) intermediate language (IL) -;; Copyright (C) 2015 Free Software Foundation, Inc. +;; Copyright (C) 2015, 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 @@ -20,6 +20,7 @@ (define-module (language cps spec) #:use-module (ice-9 match) + #:use-module (ice-9 source-properties) #:use-module (system base language) #:use-module (language cps) #:use-module (language cps intmap) diff --git a/module/language/ecmascript/compile-tree-il.scm b/module/language/ecmascript/compile-tree-il.scm index d61f7120d..6acdd3b4f 100644 --- a/module/language/ecmascript/compile-tree-il.scm +++ b/module/language/ecmascript/compile-tree-il.scm @@ -1,6 +1,6 @@ ;;; ECMAScript for Guile -;; Copyright (C) 2009, 2011, 2016 Free Software Foundation, Inc. +;; Copyright (C) 2009, 2011, 2016, 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 @@ -21,6 +21,7 @@ (define-module (language ecmascript compile-tree-il) #:use-module (language tree-il) #:use-module (ice-9 receive) + #:use-module (ice-9 source-properties) #:use-module (system base pmatch) #:use-module (srfi srfi-1) #:export (compile-tree-il)) diff --git a/module/language/ecmascript/function.scm b/module/language/ecmascript/function.scm index 72edc4e61..a4669ae17 100644 --- a/module/language/ecmascript/function.scm +++ b/module/language/ecmascript/function.scm @@ -1,6 +1,6 @@ ;;; ECMAScript for Guile -;; Copyright (C) 2009 Free Software Foundation, Inc. +;; Copyright (C) 2009, 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,7 @@ ;;; Code: (define-module (language ecmascript function) + #:use-module (ice-9 weak-tables) #:use-module (oop goops) #:use-module (language ecmascript base) #:export (*function-prototype* *program-wrappers*)) diff --git a/module/language/elisp/boot.el b/module/language/elisp/boot.el index f55722a9a..608c7c960 100644 --- a/module/language/elisp/boot.el +++ b/module/language/elisp/boot.el @@ -1,6 +1,6 @@ ;;; Guile Emacs Lisp -*- lexical-binding: t -*- -;;; Copyright (C) 2011 Free Software Foundation, Inc. +;;; Copyright (C) 2011, 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 License as @@ -505,7 +505,8 @@ (defun lax-plist-put (plist property value) (%plist-put plist property value #'equal)) -(defvar plist-function (funcall (@ (guile) make-object-property))) +(defvar plist-function + (funcall (@ (ice-9 object-properties) make-object-property))) (defun symbol-plist (symbol) (funcall plist-function symbol)) diff --git a/module/language/elisp/compile-tree-il.scm b/module/language/elisp/compile-tree-il.scm index adbeb2005..81211a0a1 100644 --- a/module/language/elisp/compile-tree-il.scm +++ b/module/language/elisp/compile-tree-il.scm @@ -1,6 +1,6 @@ ;;; Guile Emacs Lisp -;; Copyright (C) 2009-2011, 2013, 2018 Free Software Foundation, Inc. +;; Copyright (C) 2009-2011, 2013, 2018, 2025 Free Software Foundation, Inc. ;; This program is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by @@ -20,6 +20,7 @@ ;;; Code: (define-module (language elisp compile-tree-il) + #:use-module (ice-9 source-properties) #:use-module (language elisp bindings) #:use-module (language elisp runtime) #:use-module (language tree-il) @@ -69,7 +70,9 @@ (and (pair? x) (let ((props (source-properties x))) (and (not (null? props)) - props)))) + (vector (assq-ref props 'filename) + (assq-ref props 'line) + (assq-ref props 'column)))))) ;;; Values to use for Elisp's nil and t. diff --git a/module/language/elisp/lexer.scm b/module/language/elisp/lexer.scm index 5a0e6b3ff..f77f0c1c2 100644 --- a/module/language/elisp/lexer.scm +++ b/module/language/elisp/lexer.scm @@ -1,6 +1,6 @@ ;;; Guile Emacs Lisp -;;; Copyright (C) 2009, 2010, 2013 Free Software Foundation, Inc. +;;; Copyright (C) 2009, 2010, 2013, 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 @@ -20,6 +20,7 @@ (define-module (language elisp lexer) #:use-module (ice-9 regex) + #:use-module (ice-9 source-properties) #:export (get-lexer get-lexer/1)) ;;; This is the lexical analyzer for the elisp reader. It is diff --git a/module/language/elisp/parser.scm b/module/language/elisp/parser.scm index a7aeff014..586abbf7e 100644 --- a/module/language/elisp/parser.scm +++ b/module/language/elisp/parser.scm @@ -1,6 +1,6 @@ ;;; Guile Emacs Lisp -;;; 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 @@ -19,6 +19,7 @@ ;;; Code: (define-module (language elisp parser) + #:use-module (ice-9 source-properties) #:use-module (language elisp lexer) #:export (read-elisp)) diff --git a/module/language/tree-il.scm b/module/language/tree-il.scm index 9ff7158b8..43f5f985e 100644 --- a/module/language/tree-il.scm +++ b/module/language/tree-il.scm @@ -1,4 +1,4 @@ -;;;; Copyright (C) 2009-2014,2017-2020,2022-2023 Free Software Foundation, Inc. +;;;; Copyright (C) 2009-2014,2017-2020,2022-2023,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 @@ -20,9 +20,9 @@ #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) #:use-module (ice-9 match) + #:use-module (ice-9 source-properties) #:use-module (system base syntax) - #:export ((tree-il-src/ensure-alist . tree-il-src) - (tree-il-src . tree-il-srcv) + #:export (tree-il-src <void> void? make-void void-src <const> const? make-const const-src const-exp <primitive-ref> primitive-ref? make-primitive-ref primitive-ref-src primitive-ref-name @@ -136,19 +136,6 @@ (<prompt> escape-only? tag body handler) (<abort> tag args tail)) -(define tree-il-src/ensure-alist - (make-procedure-with-setter - (lambda (tree) - "Return the source location of TREE as a source property alist." - ;; psyntax gives us "source vectors"; convert them lazily to reduce - ;; allocations. - (match (tree-il-src tree) - (#(file line column) - `((filename . ,file) (line . ,line) (column . ,column))) - (src - src))) - (lambda (tree src) - (set! (tree-il-src tree) src)))) @@ -166,7 +153,10 @@ (define (location x) (and (pair? x) (let ((props (source-properties x))) - (and (pair? props) props)))) + (and (pair? props) + (vector (assq-ref props 'filename) + (assq-ref props 'line) + (assq-ref props 'column)))))) (define (parse-tree-il exp) (let ((loc (location exp)) diff --git a/module/language/tree-il/analyze.scm b/module/language/tree-il/analyze.scm index 418a7ccb0..c081c8844 100644 --- a/module/language/tree-il/analyze.scm +++ b/module/language/tree-il/analyze.scm @@ -71,7 +71,7 @@ given `tree-il' element." (cdr results)))))) ;; Extending and shrinking the location stack. - (define (extend-locs x locs) (cons (tree-il-srcv x) locs)) + (define (extend-locs x locs) (cons (tree-il-src x) locs)) (define (shrink-locs x locs) (cdr locs)) (let ((results @@ -114,7 +114,7 @@ given `tree-il' element." ;; accordingly. (let ((refs (binding-info-refs info)) (vars (binding-info-vars info)) - (src (tree-il-srcv x))) + (src (tree-il-src x))) (define (extend inner-vars inner-names) (fold (lambda (var name vars) (vhash-consq var (list name src) vars)) @@ -525,7 +525,7 @@ given `tree-il' element." (match (vhash-assq name defs) ((_ . previous-definition) (warning 'shadowed-toplevel src name - (tree-il-srcv previous-definition)) + (tree-il-src previous-definition)) defs) (#f (vhash-consq name x defs)))) @@ -926,7 +926,7 @@ given `tree-il' element." (values #f #f)))))))) (let ((args (call-args call)) - (src (tree-il-srcv call))) + (src (tree-il-src call))) (call-with-values (lambda () (arities proc)) (lambda (name arities) (define matches? diff --git a/module/language/tree-il/compile-bytecode.scm b/module/language/tree-il/compile-bytecode.scm index a581b7f6c..947715ca6 100644 --- a/module/language/tree-il/compile-bytecode.scm +++ b/module/language/tree-il/compile-bytecode.scm @@ -1,6 +1,6 @@ ;;; Lightweight compiler directly from Tree-IL to bytecode -;; Copyright (C) 2020-2021,2023 Free Software Foundation, Inc. +;; Copyright (C) 2020-2021,2023,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 License as published by @@ -604,7 +604,7 @@ (() (let () (define x-thunk - (let ((src (tree-il-srcv exp))) + (let ((src (tree-il-src exp))) (make-lambda src '() (make-lambda-case src '() #f #f #f '() '() exp #f)))) (values (cons (make-closure 'init x-thunk #f '()) diff --git a/module/language/tree-il/compile-cps.scm b/module/language/tree-il/compile-cps.scm index ea5be8aa8..6dcb16963 100644 --- a/module/language/tree-il/compile-cps.scm +++ b/module/language/tree-il/compile-cps.scm @@ -1,6 +1,6 @@ ;;; Continuation-passing style (CPS) intermediate language (IL) -;; Copyright (C) 2013-2015,2017-2021,2023 Free Software Foundation, Inc. +;; Copyright (C) 2013-2015,2017-2021,2023,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 @@ -1309,7 +1309,7 @@ use as the proc slot." (define (init-default-value cps name sym subst init body) (match (hashq-ref subst sym) ((orig-var subst-var box?) - (let ((src (tree-il-srcv init))) + (let ((src (tree-il-src init))) (define (maybe-box cps k make-body) (if box? (with-cps cps @@ -1964,10 +1964,10 @@ use as the proc slot." (lambda (cps thunk) (with-cps cps (letk kbody ($kargs () () - ($continue krest (tree-il-srcv body) + ($continue krest (tree-il-src body) ($primcall 'call-thunk/no-inline #f (thunk))))) - (build-term ($prompt kbody khargs (tree-il-srcv body) + (build-term ($prompt kbody khargs (tree-il-src body) #f tag))))))) (with-cps cps (letv prim vals apply) @@ -2223,7 +2223,7 @@ integer." (letk kclause ($kclause ('() '() #f '() #f) kbody #f)) ($ ((lambda (cps) (let ((init (build-cont - ($kfun (tree-il-srcv exp) '() init ktail kclause)))) + ($kfun (tree-il-src exp) '() init ktail kclause)))) (with-cps (persistent-intmap (intmap-replace! cps kinit init)) kinit)))))))) diff --git a/module/language/tree-il/debug.scm b/module/language/tree-il/debug.scm index 2dec39bd0..cf55196fb 100644 --- a/module/language/tree-il/debug.scm +++ b/module/language/tree-il/debug.scm @@ -244,7 +244,7 @@ (visit tail env)) (_ (error "unexpected tree-il" exp))) - (match (tree-il-srcv exp) + (match (tree-il-src exp) (#f #t) (#((or #f (? string?)) (? exact-integer?) (? exact-integer?)) #t) (src (error "bad src" src))) diff --git a/module/language/tree-il/letrectify.scm b/module/language/tree-il/letrectify.scm index 0f9c6aa3c..3b79d24fa 100644 --- a/module/language/tree-il/letrectify.scm +++ b/module/language/tree-il/letrectify.scm @@ -1,6 +1,6 @@ ;;; transformation of top-level bindings into letrec* -;; Copyright (C) 2019-2021,2023 Free Software Foundation, Inc. +;; Copyright (C) 2019-2021,2023,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 @@ -190,7 +190,7 @@ (cons name names) (cons var vars) (cons val vals) tail)) (_ - (make-letrec (tree-il-srcv tail) #t + (make-letrec (tree-il-src tail) #t (list name) (list var) (list val) tail)))) diff --git a/module/language/tree-il/peval.scm b/module/language/tree-il/peval.scm index 27a0acbcb..5940c00f0 100644 --- a/module/language/tree-il/peval.scm +++ b/module/language/tree-il/peval.scm @@ -1,6 +1,6 @@ ;;; Tree-IL partial evaluator -;; Copyright (C) 2011-2014,2017,2019-2024 Free Software Foundation, Inc. +;; Copyright (C) 2011-2014,2017,2019-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 @@ -110,7 +110,7 @@ "Discard all but the first value of X." (if (singly-valued-expression? x) x - (make-primcall (tree-il-srcv x) 'values (list x)))) + (make-primcall (tree-il-src x) 'values (list x)))) ;; Peval will do a one-pass analysis on the source program to determine ;; the set of assigned lexicals, and to identify unreferenced and diff --git a/module/language/tree-il/spec.scm b/module/language/tree-il/spec.scm index 05decf1a9..57f67bc9b 100644 --- a/module/language/tree-il/spec.scm +++ b/module/language/tree-il/spec.scm @@ -1,6 +1,6 @@ ;;; Tree Intermediate Language -;; Copyright (C) 2009-2011,2013,2015,2020 Free Software Foundation, Inc. +;; Copyright (C) 2009-2011,2013,2015,2020,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 @@ -21,6 +21,7 @@ (define-module (language tree-il spec) #:use-module (system base language) #:use-module (ice-9 match) + #:use-module (ice-9 source-properties) #:use-module (language tree-il) #:use-module ((language tree-il analyze) #:select (make-analyzer)) #:use-module ((language tree-il optimize) #:select (make-lowerer)) diff --git a/module/language/wisp.scm b/module/language/wisp.scm index d53a886a1..97bb508a6 100644 --- a/module/language/wisp.scm +++ b/module/language/wisp.scm @@ -1,6 +1,6 @@ ;;; Wisp -;; Copyright (C) 2013, 2017, 2018, 2020, 2024 Free Software Foundation, Inc. +;; Copyright (C) 2013, 2017, 2018, 2020, 2024, 2025, 2025 Free Software Foundation, Inc. ;; Copyright (C) 2014--2023 Arne Babenhauserheide. ;; Copyright (C) 2023 Maxime Devos <maximedevos@telenet.be> @@ -37,6 +37,7 @@ #:use-module (srfi srfi-1) #:use-module (srfi srfi-11); for let-values #:use-module (srfi srfi-9); for records + #:use-module (ice-9 source-properties) #:use-module (ice-9 rw); for write-string/partial #:use-module (ice-9 match)) diff --git a/module/oop/goops.scm b/module/oop/goops.scm index 34888f7b5..19eb7362b 100644 --- a/module/oop/goops.scm +++ b/module/oop/goops.scm @@ -70,7 +70,7 @@ <vector> <bytevector> <uvec> <foreign> <hashtable> <fluid> <dynamic-state> <frame> <vm> <vm-continuation> <keyword> <syntax> <atomic-box> <thread> <bitvector> - <finalizer> <ephemeron> + <finalizer> <ephemeron> <ephemeron-table> ;; Numbers. <number> <complex> <real> <integer> <fraction> @@ -1081,6 +1081,7 @@ slots as we go." (define-standard-class <bitvector> (<top>)) (define-standard-class <finalizer> (<top>)) (define-standard-class <ephemeron> (<top>)) +(define-standard-class <ephemeron-table> (<top>)) (define-standard-class <thread> (<top>)) (define-standard-class <number> (<top>)) (define-standard-class <complex> (<number>)) diff --git a/module/oop/goops/save.scm b/module/oop/goops/save.scm index 5f0d6457e..caa725500 100644 --- a/module/oop/goops/save.scm +++ b/module/oop/goops/save.scm @@ -1,6 +1,6 @@ ;;; installed-scm-file -;;;; Copyright (C) 2000,2001,2002, 2006, 2009, 2010, 2013, 2015, 2020 Free Software Foundation, Inc. +;;;; Copyright (C) 2000,2001,2002, 2006, 2009, 2010, 2013, 2015, 2020, 2025, 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 @@ -20,6 +20,7 @@ (define-module (oop goops save) #:use-module (ice-9 copy-tree) + #:use-module (ice-9 weak-tables) #:use-module (oop goops internal) #:export (make-unbound save-objects load-objects restore enumerate! enumerate-component! diff --git a/module/scripts/api-diff.scm b/module/scripts/api-diff.scm index 7e04937ba..8fe0c9c73 100644 --- a/module/scripts/api-diff.scm +++ b/module/scripts/api-diff.scm @@ -1,6 +1,6 @@ ;;; api-diff --- diff guile-api.alist files -;; Copyright (C) 2002, 2006, 2011 Free Software Foundation, Inc. +;; Copyright (C) 2002, 2006, 2011, 2025 Free Software Foundation, Inc. ;; ;; This program is free software; you can redistribute it and/or ;; modify it under the terms of the GNU Lesser General Public License @@ -40,11 +40,12 @@ ;;; Code: (define-module (scripts api-diff) - :use-module (ice-9 common-list) - :use-module (ice-9 format) - :use-module (ice-9 getopt-long) - :autoload (srfi srfi-13) (string-tokenize) - :export (api-diff)) + #:use-module (ice-9 common-list) + #:use-module (ice-9 format) + #:use-module (ice-9 getopt-long) + #:use-module (ice-9 object-properties) + #:autoload (srfi srfi-13) (string-tokenize) + #:export (api-diff)) (define %include-in-guild-list #f) (define %summary "Show differences between two scan-api files.") @@ -54,7 +55,7 @@ (lambda () (read)))) (define put set-object-property!) -(define get object-property) +(define get yobject-property) (define (read-api-alist-file file) (let* ((alist (read-alist-file file)) diff --git a/module/scripts/frisk.scm b/module/scripts/frisk.scm index ae636d82d..81bbe6378 100644 --- a/module/scripts/frisk.scm +++ b/module/scripts/frisk.scm @@ -1,6 +1,6 @@ ;;; frisk --- Grok the module interfaces of a body of files -;; Copyright (C) 2002, 2006, 2010, 2011, 2020 Free Software Foundation, Inc. +;; Copyright (C) 2002, 2006, 2010, 2011, 2020, 2025 Free Software Foundation, Inc. ;; ;; This program is free software; you can redistribute it and/or ;; modify it under the terms of the GNU Lesser General Public License @@ -97,6 +97,7 @@ (define-module (scripts frisk) #:use-module (ice-9 getopt-long) + #:use-module (ice-9 object-properties) #:use-module ((srfi srfi-1) :select (filter remove)) #:export (frisk make-frisker diff --git a/module/scripts/read-text-outline.scm b/module/scripts/read-text-outline.scm index d0933bb0b..e2d76b37b 100644 --- a/module/scripts/read-text-outline.scm +++ b/module/scripts/read-text-outline.scm @@ -1,6 +1,6 @@ ;;; read-text-outline --- Read a text outline and display it as a sexp -;; Copyright (C) 2002, 2006, 2011 Free Software Foundation, Inc. +;; Copyright (C) 2002, 2006, 2011, 2025 Free Software Foundation, Inc. ;; ;; This program is free software; you can redistribute it and/or ;; modify it under the terms of the GNU Lesser General Public License @@ -115,6 +115,7 @@ read-text-outline-silently make-text-outline-reader) :use-module (ice-9 regex) + :use-module (ice-9 object-properties) :autoload (ice-9 rdelim) (read-line) :autoload (ice-9 getopt-long) (getopt-long)) diff --git a/module/scripts/scan-api.scm b/module/scripts/scan-api.scm index 86d07fc3e..c2b65057f 100644 --- a/module/scripts/scan-api.scm +++ b/module/scripts/scan-api.scm @@ -1,6 +1,6 @@ ;;; scan-api --- Scan and group interpreter and libguile interface elements -;; Copyright (C) 2002, 2006, 2011 Free Software Foundation, Inc. +;; Copyright (C) 2002, 2006, 2011, 2025 Free Software Foundation, Inc. ;; ;; This program is free software; you can redistribute it and/or ;; modify it under the terms of the GNU Lesser General Public License @@ -60,10 +60,11 @@ ;;; Code: (define-module (scripts scan-api) - :use-module (ice-9 popen) - :use-module (ice-9 rdelim) - :use-module (ice-9 regex) - :export (scan-api)) + #:use-module (ice-9 object-properties) + #:use-module (ice-9 popen) + #:use-module (ice-9 rdelim) + #:use-module (ice-9 regex) + #:export (scan-api)) (define %include-in-guild-list #f) (define %summary "Generate an API description for a Guile extension.") diff --git a/module/scripts/summarize-guile-TODO.scm b/module/scripts/summarize-guile-TODO.scm index 8b119e0ec..789baa190 100644 --- a/module/scripts/summarize-guile-TODO.scm +++ b/module/scripts/summarize-guile-TODO.scm @@ -1,6 +1,6 @@ ;;; summarize-guile-TODO --- Display Guile TODO list in various ways -;; Copyright (C) 2002, 2006, 2010, 2011 Free Software Foundation, Inc. +;; Copyright (C) 2002, 2006, 2010, 2011, 2025 Free Software Foundation, Inc. ;; ;; This program is free software; you can redistribute it and/or ;; modify it under the terms of the GNU Lesser General Public License @@ -66,12 +66,13 @@ (debug-enable 'backtrace) (define-module (scripts summarize-guile-TODO) - :use-module (scripts read-text-outline) - :use-module (ice-9 getopt-long) - :autoload (srfi srfi-13) (string-tokenize) ; string library - :autoload (srfi srfi-14) (char-set) ; string library - :autoload (ice-9 common-list) (remove-if-not) - :export (summarize-guile-TODO)) + #:use-module (scripts read-text-outline) + #:use-module (ice-9 getopt-long) + #:use-module (ice-9 object-properties) + #:autoload (srfi srfi-13) (string-tokenize) ; string library + #:autoload (srfi srfi-14) (char-set) ; string library + #:autoload (ice-9 common-list) (remove-if-not) + #:export (summarize-guile-TODO)) (define %include-in-guild-list #f) (define %summary "A quaint relic of the past.") diff --git a/module/srfi/srfi-18.scm b/module/srfi/srfi-18.scm index 79aedb8d1..60f8d4c47 100644 --- a/module/srfi/srfi-18.scm +++ b/module/srfi/srfi-18.scm @@ -1,6 +1,6 @@ ;;; srfi-18.scm --- Multithreading support -;; Copyright (C) 2008, 2009, 2010, 2012, 2014, 2018 Free Software Foundation, Inc. +;; Copyright (C) 2008, 2009, 2010, 2012, 2014, 2018, 2025, 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 @@ -34,6 +34,7 @@ #:use-module (ice-9 exceptions) #:use-module ((ice-9 threads) #:prefix threads:) #:use-module (ice-9 match) + #:use-module (ice-9 weak-tables) #:use-module (srfi srfi-9) #:export (;; Threads make-thread diff --git a/module/srfi/srfi-64.scm b/module/srfi/srfi-64.scm index 98fcef645..9f55e35a6 100644 --- a/module/srfi/srfi-64.scm +++ b/module/srfi/srfi-64.scm @@ -1,4 +1,4 @@ -;;; Copyright (C) 2024 Tomas Volf <~@wolfsden.cz> +;;; Copyright (C) 2024, 2025 Tomas Volf <~@wolfsden.cz> ;; ;; This library is free software; you can redistribute it and/or @@ -27,6 +27,7 @@ #:use-module (ice-9 exceptions) #:use-module (ice-9 format) #:use-module (ice-9 match) + #:use-module (ice-9 object-properties) #:use-module (ice-9 pretty-print) #:use-module (srfi srfi-1) #:use-module (srfi srfi-9) @@ -627,8 +628,8 @@ the @var{cleanup-form}. The latter shall be executed even if one of a "Extract properties of syntax @var{form} and return them as a alist with keys compatible with Guile's SRFI-64 implementation." (let* ((source (syntax-source form)) - (file (and=> source (cut assq-ref <> 'filename))) - (line (and=> source (cut assq-ref <> 'line))) + (file (and source (vector-ref source 0))) + (line (and source (vector-ref source 1))) ;; I do not care about column. Tests are not nested enough. (file-alist (if file `((source-file . ,file)) diff --git a/module/srfi/srfi-69.scm b/module/srfi/srfi-69.scm index 91bcc77db..efdc59bd4 100644 --- a/module/srfi/srfi-69.scm +++ b/module/srfi/srfi-69.scm @@ -1,6 +1,6 @@ ;;; srfi-69.scm --- Basic hash tables -;; 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 @@ -71,6 +71,7 @@ #:use-module (srfi srfi-9) #:use-module (srfi srfi-13) ;string-hash,string-hash-ci #:use-module (ice-9 optargs) + #:use-module (ice-9 weak-tables) #:export (;; Type constructors & predicate make-hash-table hash-table? alist->hash-table ;; Reflective queries diff --git a/module/system/base/lalr.scm b/module/system/base/lalr.scm index 49e7e8d46..55e5e6c87 100644 --- a/module/system/base/lalr.scm +++ b/module/system/base/lalr.scm @@ -1,6 +1,6 @@ ;;; -*- mode: scheme; coding: utf-8; -*- ;;; -;;; Copyright (C) 2010 Free Software Foundation, Inc. +;;; Copyright (C) 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 License as published by @@ -21,6 +21,7 @@ ;; compiler) complains about `lexical-token' being unbound when expanding ;; `(define-record-type lexical-token ...)' if we omit it. #:use-module (srfi srfi-9) + #:use-module (ice-9 source-properties) #:export (lalr-parser print-states diff --git a/module/system/base/types.scm b/module/system/base/types.scm index c1899bdb0..fd35a09f2 100644 --- a/module/system/base/types.scm +++ b/module/system/base/types.scm @@ -454,14 +454,11 @@ using BACKEND." (make-pointer address)) (((_ & #x7f = %tc7-keyword) symbol) (symbol->keyword (cell->object symbol backend))) - (((_ & #x7f = %tc7-syntax) expression wrap module) - (cond-expand - (guile-2.2 - (make-syntax (cell->object expression backend) - (cell->object wrap backend) - (cell->object module backend))) - (else - (inferior-object 'syntax address)))) + (((_ & #x7f = %tc7-syntax) expression wrap module source) + (make-syntax (cell->object expression backend) + (cell->object wrap backend) + (cell->object module backend) + (cell->object source backend))) (((_ & #x7f = %tc7-vm-continuation)) (inferior-object 'vm-continuation address)) (((_ & #x7f = %tc7-weak-set)) diff --git a/module/system/foreign.scm b/module/system/foreign.scm index a75c37da1..fe068a471 100644 --- a/module/system/foreign.scm +++ b/module/system/foreign.scm @@ -1,4 +1,4 @@ -;;; Copyright (C) 2010-2011,2013-2014,2024 Free Software Foundation, Inc. +;;; Copyright (C) 2010-2011,2013-2014,2024,2025,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 License as @@ -17,6 +17,7 @@ (define-module (system foreign) #:use-module (ice-9 match) + #:use-module (ice-9 weak-tables) #:use-module (rnrs bytevectors) #:use-module (srfi srfi-1) #:use-module (srfi srfi-9) diff --git a/module/system/syntax.scm b/module/system/syntax.scm index 6d8c96748..970b8c86b 100644 --- a/module/system/syntax.scm +++ b/module/system/syntax.scm @@ -1,6 +1,6 @@ ;;; Syntax utilities -;;; Copyright (C) 2017, 2021 Free Software Foundation, Inc. +;;; Copyright (C) 2017, 2021, 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 @@ -24,14 +24,19 @@ syntax-local-binding (%syntax-module . syntax-module) syntax-locally-bound-identifiers - syntax-session-id - syntax-sourcev)) + syntax-session-id)) + +(begin-deprecated + (define-public (syntax-sourcev x) + (issue-deprecation-warning + "syntax-sourcev is deprecated. Use syntax-source instead.") + (syntax-source x))) ;; Used by syntax.c. (define (print-syntax obj port) ;; FIXME: Use syntax->datum instad of syntax-expression, when ;; syntax->datum can operate on new syntax objects. - (let ((src (syntax-sourcev obj))) + (let ((src (syntax-source obj))) (if src (format port "#<syntax:~a:~a:~a ~s>" (cond diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm index 8b228d2e3..7fc15b9f2 100644 --- a/module/system/vm/assembler.scm +++ b/module/system/vm/assembler.scm @@ -582,7 +582,7 @@ N-byte unit." ;; A list of (pos . source) pairs, indicating source information. POS ;; is relative to the beginning of the text section, and SOURCE is in - ;; the same format that source-properties returns. + ;; the same format that syntax-source returns. ;; (sources asm-sources set-asm-sources!) @@ -1301,7 +1301,7 @@ table, its existing label is used directly." (patch! 1 (syntax-expression obj)) (patch! 2 (syntax-wrap obj)) (patch! 3 (syntax-module obj)) - (patch! 4 (syntax-sourcev obj))) + (patch! 4 (syntax-source obj))) ((stringbuf? obj)) ((static-procedure? obj) ;; Special case, as we can't load the procedure's code using @@ -1862,7 +1862,6 @@ should be .data or .rodata), and return the resulting linker object. (define stringbuf-wide-flag #x400) (define tc7-syntax #x3d) - (define syntax-has-source-flag #x100) (define tc7-program #x45) @@ -2011,11 +2010,10 @@ should be .data or .rodata), and return the resulting linker object. (write-placeholder asm buf pos)) ((syntax? obj) - (let ((tag (logior tc7-syntax syntax-has-source-flag))) - (case word-size - ((4) (bytevector-u32-set! buf pos tag endianness)) - ((8) (bytevector-u64-set! buf pos tag endianness)) - (else (error "bad word size")))) + (case word-size + ((4) (bytevector-u32-set! buf pos tc7-syntax endianness)) + ((8) (bytevector-u64-set! buf pos tc7-syntax endianness)) + (else (error "bad word size"))) (write-constant-reference buf (+ pos (* 1 word-size)) (syntax-expression obj)) (write-constant-reference buf (+ pos (* 2 word-size)) @@ -2023,7 +2021,7 @@ should be .data or .rodata), and return the resulting linker object. (write-constant-reference buf (+ pos (* 3 word-size)) (syntax-module obj)) (write-constant-reference buf (+ pos (* 4 word-size)) - (syntax-sourcev obj))) + (syntax-source obj))) ((number? obj) (write-placeholder asm buf pos)) @@ -2900,26 +2898,17 @@ procedure with label @var{rw-init}. @var{rw-init} may be false. If (let lp ((sources (asm-sources asm)) (out '())) (match sources - (((pc . location) . sources) - (let-values (((file line col) - ;; Usually CPS records contain a "source - ;; vector" coming from tree-il, but some might - ;; contain a source property alist. - (match location - (#(file line col) (values file line col)) - (lst (values (assq-ref lst 'filename) - (assq-ref lst 'line) - (assq-ref lst 'column)))))) - (lp sources - ;; Guile line and column numbers are 0-indexed, but - ;; they are 1-indexed for DWARF. - (if (and line col) - (cons (list pc - (if (string? file) (intern-file file) 0) - (1+ line) - (1+ col)) - out) - out)))) + (((pc . #(file line col)) . sources) + (lp sources + ;; Guile line and column numbers are 0-indexed, but + ;; they are 1-indexed for DWARF. + (if (and line col) + (cons (list pc + (if (string? file) (intern-file file) 0) + (1+ line) + (1+ col)) + out) + out))) (() ;; Compilation unit header for .debug_line. We write in ;; DWARF 2 format because more tools understand it than DWARF diff --git a/module/web/http.scm b/module/web/http.scm index b65fa91c1..9270cd0f9 100644 --- a/module/web/http.scm +++ b/module/web/http.scm @@ -1,6 +1,6 @@ ;;; HTTP messages -;; Copyright (C) 2010-2017, 2023 Free Software Foundation, Inc. +;; Copyright (C) 2010-2017, 2023, 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 @@ -30,13 +30,14 @@ ;;; Code: (define-module (web http) - #:use-module (srfi srfi-9) - #:use-module (srfi srfi-19) - #:use-module (ice-9 rdelim) - #:use-module (ice-9 match) #:use-module (ice-9 binary-ports) - #:use-module (ice-9 textual-ports) #:use-module (ice-9 exceptions) + #:use-module (ice-9 match) + #:use-module (ice-9 object-properties) + #:use-module (ice-9 rdelim) + #:use-module (ice-9 textual-ports) + #:use-module (srfi srfi-19) + #:use-module (srfi srfi-9) #:use-module (web uri) #:export (string->header header->string diff --git a/test-suite/tests/compiler.test b/test-suite/tests/compiler.test index 0b47d0e32..cf0ea52de 100644 --- a/test-suite/tests/compiler.test +++ b/test-suite/tests/compiler.test @@ -1,5 +1,5 @@ ;;;; compiler.test --- tests for the compiler -*- scheme -*- -;;;; Copyright (C) 2008-2014, 2018, 2021-2022, 2024 Free Software Foundation, Inc. +;;;; Copyright (C) 2008-2014, 2018, 2021-2022, 2024, 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 @@ -75,14 +75,11 @@ (eq? round (module-ref m 'round)))) (pass-if-equal "syntax-source with read-hash-extend" - '((filename . "sample.scm") (line . 2) (column . 5)) - ;; In Guile 3.0.8, psyntax would dismiss source properties added by - ;; read hash extensions on data they return. - ;; See <https://issues.guix.gnu.org/54003> + #("sample.scm" 2 5) (with-fluids ((%read-hash-procedures (fluid-ref %read-hash-procedures))) (read-hash-extend #\~ (lambda (chr port) - (list 'magic (read port)))) + (list 'magic (read-syntax port)))) (tree-il-src (car (call-args @@ -156,20 +153,26 @@ ;; with IP 0 of a VM program, which corresponds to the entry point. See ;; also <http://savannah.gnu.org/bugs/?29817> for details. + (define (compile-string str) + (call-with-input-string str + (lambda (port) + (read-and-compile port #:to 'value)))) + (pass-if "lambda" - (let ((s (program-sources (compile '(lambda (x) x))))) + (let ((s (program-sources (compile-string "(lambda (x) x)")))) (not (not (memv 0 (map source:addr s)))))) (pass-if "lambda*" (let ((s (program-sources - (compile '(lambda* (x #:optional y) x))))) + (compile-string "(lambda* (x #:optional y) x)")))) (not (not (memv 0 (map source:addr s)))))) (pass-if "case-lambda" (let ((s (program-sources - (compile '(case-lambda (() #t) - ((y) y) - ((y z) (list y z))))))) + (compile-string + "(case-lambda (() #t) + ((y) y) + ((y z) (list y z)))")))) (not (not (memv 0 (map source:addr s)))))))) (with-test-prefix "case-lambda" diff --git a/test-suite/tests/coverage.test b/test-suite/tests/coverage.test index 5f393b6b0..d1b954cd5 100644 --- a/test-suite/tests/coverage.test +++ b/test-suite/tests/coverage.test @@ -1,6 +1,6 @@ ;;;; coverage.test --- Code coverage. -*- mode: scheme; coding: utf-8; -*- ;;;; -;;;; Copyright (C) 2010, 2011, 2012, 2013, 2014, 2015, 2017 Free Software Foundation, Inc. +;;;; Copyright (C) 2010, 2011, 2012, 2013, 2014, 2015, 2017, 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 @@ -30,8 +30,7 @@ ((_ filename snippet) (let ((input (open-input-string snippet))) (set-port-filename! input filename) - (read-enable 'positions) - (compile (read input)))))) + (compile (read-syntax input)))))) (define test-procedure (compile '(lambda (x) diff --git a/test-suite/tests/elisp-reader.test b/test-suite/tests/elisp-reader.test index cf7c15c52..f6d385a27 100644 --- a/test-suite/tests/elisp-reader.test +++ b/test-suite/tests/elisp-reader.test @@ -1,6 +1,7 @@ +;;;; -*- scheme -*- ;;;; elisp-reader.test --- Test the reader used by the Elisp compiler. ;;;; -;;;; Copyright (C) 2009 Free Software Foundation, Inc. +;;;; Copyright (C) 2009, 2025 Free Software Foundation, Inc. ;;;; Daniel Kraft ;;;; ;;;; This library is free software; you can redistribute it and/or @@ -18,9 +19,10 @@ ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA (define-module (test-elisp-reader) - :use-module (test-suite lib) - :use-module (language elisp lexer) - :use-module (language elisp parser)) + #:use-module (test-suite lib) + #:use-module (ice-9 source-properties) + #:use-module (language elisp lexer) + #:use-module (language elisp parser)) ; ============================================================================== diff --git a/test-suite/tests/ephemerons.test b/test-suite/tests/ephemerons.test index af8108a59..fa08c2448 100644 --- a/test-suite/tests/ephemerons.test +++ b/test-suite/tests/ephemerons.test @@ -44,8 +44,42 @@ (pass-if (ephemeron? e)) (pass-if (eq? x (ephemeron-key e))) (pass-if-equal 100 (ephemeron-value e)) + (pass-if-equal 100 (ephemeron-swap! e 'qux)) + (pass-if-equal 'qux (ephemeron-value e)) (ephemeron-mark-dead! e) (pass-if (ephemeron? e)) (pass-if-equal #f (ephemeron-key e)) (pass-if-equal #f (ephemeron-value e)))) + +(with-test-prefix "ephemeron tables" + + (define et (make-ephemeron-table 47)) + (pass-if (ephemeron-table? et)) + + (define keys (map list (iota 47))) + + (for-each (lambda (idx) + (pass-if (not (ephemeron-table-ref et idx)))) + (iota 47)) + (for-each (lambda (idx key) + (ephemeron-table-push! et idx (make-ephemeron key #t))) + (iota 47) keys) + (for-each (lambda (idx) + (define head (ephemeron-table-ref et idx)) + (pass-if (ephemeron? head)) + (pass-if-equal (list idx) (ephemeron-key head)) + (pass-if (ephemeron-value head)) + (pass-if (not (ephemeron-next head)))) + (iota 47)) + + (define prev (ephemeron-table-ref et 42)) + (pass-if-equal prev + (ephemeron-table-try-push! et 42 (make-ephemeron 'hey 'qux) #f)) + (pass-if-equal prev + (ephemeron-table-try-push! et 42 (make-ephemeron 'hey 'qux) prev)) + (pass-if-equal 'hey (ephemeron-key (ephemeron-table-ref et 42))) + (pass-if-equal prev (ephemeron-next (ephemeron-table-ref et 42))) + (pass-if-equal (list 42) + (ephemeron-key (ephemeron-next (ephemeron-table-ref et 42)))) + (pass-if (not (ephemeron-next (ephemeron-next (ephemeron-table-ref et 42)))))) diff --git a/test-suite/tests/eval-string.test b/test-suite/tests/eval-string.test index 33068a272..a48718a10 100644 --- a/test-suite/tests/eval-string.test +++ b/test-suite/tests/eval-string.test @@ -1,5 +1,5 @@ ;;;; eval-string.test --- tests for (ice-9 eval-string) -*- scheme -*- -;;;; Copyright (C) 2011 Free Software Foundation, Inc. +;;;; Copyright (C) 2011, 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 @@ -17,7 +17,8 @@ (define-module (test-suite test-eval-string) #:use-module (test-suite lib) - #:use-module (ice-9 eval-string)) + #:use-module (ice-9 eval-string) + #:use-module (ice-9 match)) (with-test-prefix "basic" @@ -53,7 +54,12 @@ list) '(1 2))) - (pass-if-equal "source properties" - '((filename . "test.scm") (line . 3) (column . 42)) - (source-properties - (eval-string "'(1 2)" #:file "test.scm" #:line 3 #:column 41)))) + (pass-if-equal "source locations" "test.scm:4:41" + (match (string-split + (object->string + (eval-string "(lambda () 42)" + #:file "test.scm" #:line 3 #:column 41 + #:compile? #t)) + #\space) + (("#<procedure" addr "at" loc "()>") + loc)))) diff --git a/test-suite/tests/gc.test b/test-suite/tests/gc.test index ab710f28d..98367fac5 100644 --- a/test-suite/tests/gc.test +++ b/test-suite/tests/gc.test @@ -19,6 +19,7 @@ (define-module (tests gc) #:use-module (ice-9 documentation) #:use-module (ice-9 guardians) + #:use-module (ice-9 weak-tables) #:use-module (test-suite lib) #:use-module ((system base compile) #:select (compile))) diff --git a/test-suite/tests/hash.test b/test-suite/tests/hash.test index 779043c9a..fe75d7b05 100644 --- a/test-suite/tests/hash.test +++ b/test-suite/tests/hash.test @@ -1,7 +1,7 @@ ;;;; hash.test --- test guile hashing -*- scheme -*- ;;;; ;;;; Copyright (C) 2004, 2005, 2006, 2008, 2011, 2012, -;;;; 2014, 2020 Free Software Foundation, Inc. +;;;; 2014, 2020, 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 @@ -20,7 +20,8 @@ (define-module (test-suite test-numbers) #:use-module (test-suite lib) #:use-module (ice-9 documentation) - #:use-module (ice-9 hash-table)) + #:use-module (ice-9 hash-table) + #:use-module (ice-9 weak-tables)) ;;; ;;; hash diff --git a/test-suite/tests/modules.test b/test-suite/tests/modules.test index de595c02d..2a309a470 100644 --- a/test-suite/tests/modules.test +++ b/test-suite/tests/modules.test @@ -1,6 +1,6 @@ ;;;; modules.test --- exercise some of guile's module stuff -*- scheme -*- -;;;; Copyright (C) 2006, 2007, 2009-2011, 2014, 2019 Free Software Foundation, Inc. +;;;; Copyright (C) 2006, 2007, 2009-2011, 2014, 2019, 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 @@ -212,49 +212,16 @@ (with-test-prefix "observers" - (pass-if "weak observer invoked" + (pass-if "observer invoked" (let* ((m (make-module)) (invoked 0)) - (module-observe-weak m (lambda (mod) - (if (eq? mod m) - (set! invoked (+ invoked 1))))) + (module-observe m (lambda (mod) + (if (eq? mod m) + (set! invoked (+ invoked 1))))) (module-define! m 'something 2) (module-define! m 'something-else 1) (= invoked 2))) - (pass-if "all weak observers invoked" - ;; With the two-argument `module-observe-weak' available in previous - ;; versions, the observer would get unregistered as soon as the observing - ;; closure gets GC'd, making it impossible to use an anonymous lambda as - ;; the observing procedure. - - (let* ((m (make-module)) - (observer-count 500) - (observer-ids (let loop ((i observer-count) - (ids '())) - (if (= i 0) - ids - (loop (- i 1) (cons (make-module) ids))))) - (observers-invoked (make-hash-table observer-count))) - - ;; register weak observers - (for-each (lambda (id) - (module-observe-weak m id - (lambda (m) - (hashq-set! observers-invoked - id #t)))) - observer-ids) - - (gc) - - ;; invoke them - (module-call-observers m) - - ;; make sure all of them were invoked - (->bool (every (lambda (id) - (hashq-ref observers-invoked id)) - observer-ids)))) - (pass-if "imported bindings updated" (let ((m (make-module)) (imported (make-module))) diff --git a/test-suite/tests/reader.test b/test-suite/tests/reader.test index 27daf6106..8d2a3d415 100644 --- a/test-suite/tests/reader.test +++ b/test-suite/tests/reader.test @@ -1,6 +1,6 @@ ;;;; reader.test --- Reader test. -*- coding: iso-8859-1; mode: scheme -*- ;;;; -;;;; Copyright (C) 1999, 2001-2003, 2007-2011, 2013-2015, 2020-2022 +;;;; Copyright (C) 1999, 2001-2003, 2007-2011, 2013-2015, 2020-2022, 2025 ;;;; Free Software Foundation, Inc. ;;;; ;;;; Jim Blandy <jimb@red-bean.com> @@ -20,6 +20,7 @@ ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA (define-module (test-suite reader) + #:use-module (ice-9 source-properties) #:use-module (srfi srfi-1) #:use-module (test-suite lib) #:use-module (system syntax internal)) @@ -304,30 +305,18 @@ (with-read-options '(keywords postfix) (lambda () (read-string ":"))))) - (pass-if "no positions" - (let ((sexp (with-read-options '() - (lambda () - (read-string "(+ 1 2 3)"))))) - (and (not (source-property sexp 'line)) - (not (source-property sexp 'column))))) (pass-if "positions" - (let ((sexp (with-read-options '(positions) - (lambda () - (read-string "(+ 1 2 3)"))))) + (let ((sexp (read-string "(+ 1 2 3)"))) (and (equal? (source-property sexp 'line) 0) (equal? (source-property sexp 'column) 0)))) (pass-if "positions on quote" - (let ((sexp (with-read-options '(positions) - (lambda () - (read-string "'abcde"))))) + (let ((sexp (read-string "'abcde"))) (and (equal? (source-property sexp 'line) 0) (equal? (source-property sexp 'column) 0)))) (pass-if "position of SCSH block comment" ;; In Guile 2.0.0 the reader would not update the port's position ;; when reading an SCSH block comment. - (let ((sexp (with-read-options '(positions) - (lambda () - (read-string "#!foo\nbar\nbaz\n!#\n(hello world)\n"))))) + (let ((sexp (read-string "#!foo\nbar\nbaz\n!#\n(hello world)\n"))) (= 4 (source-property sexp 'line)))) (with-test-prefix "r6rs-hex-escapes" @@ -558,7 +547,7 @@ read-syntax))) (pass-if-equal "syntax-source" - '((filename . "sample.scm") (line . 2) (column . 3)) + #("sample.scm" 2 3) (syntax-source (call-with-input-string "\ ;; first line diff --git a/test-suite/tests/srcprop.test b/test-suite/tests/srcprop.test index 4afc31802..d5f27744f 100644 --- a/test-suite/tests/srcprop.test +++ b/test-suite/tests/srcprop.test @@ -1,6 +1,6 @@ ;;;; srcprop.test --- test Guile source properties -*- scheme -*- ;;;; -;;;; Copyright (C) 2003, 2006, 2009 Free Software Foundation, Inc. +;;;; Copyright (C) 2003, 2006, 2009, 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 @@ -17,7 +17,8 @@ ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA (define-module (test-suite test-srcprop) - :use-module (test-suite lib)) + #:use-module (ice-9 source-properties) + #:use-module (test-suite lib)) ;;; @@ -29,7 +30,6 @@ (pass-if "no props" (null? (source-properties (list 1 2 3)))) - (read-enable 'positions) (with-test-prefix "read properties" (define (reads-with-srcprops? str) (let ((x (read (open-input-string str)))) @@ -76,8 +76,6 @@ ;;; (with-test-prefix "set-source-property!" - (read-enable 'positions) - (pass-if "setting the breakpoint property works" (let ((s (read (open-input-string "(+ 3 4)")))) (throw 'unresolved) @@ -100,8 +98,6 @@ ;;; (with-test-prefix "set-source-properties!" - (read-enable 'positions) - (pass-if "setting the breakpoint property works" (let ((s (read (open-input-string "(+ 3 4)")))) (throw 'unresolved) diff --git a/test-suite/tests/srfi-105.test b/test-suite/tests/srfi-105.test index 34ea47b55..201a6b824 100644 --- a/test-suite/tests/srfi-105.test +++ b/test-suite/tests/srfi-105.test @@ -1,6 +1,6 @@ ;;;; srfi-105.test --- Test suite for Guile's SRFI-105 reader. -*- scheme -*- ;;;; -;;;; Copyright (C) 2012, 2013 Free Software Foundation, Inc. +;;;; Copyright (C) 2012, 2013, 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 @@ -18,6 +18,7 @@ (define-module (test-srfi-105) #:use-module (test-suite lib) + #:use-module (ice-9 source-properties) #:use-module (srfi srfi-1)) (define (read-string s) @@ -139,50 +140,22 @@ (pass-if (equal? '{e[1 2]} '($bracket-apply$ e 1 2))) (pass-if (equal? '{e[1 . 2]} '($bracket-apply$ e 1 . 2))) - ;; Verify that source position information is not recorded if not - ;; asked for. - (with-test-prefix "no positions" - (pass-if "simple curly-infix list" - (let ((sexp (with-read-options '(curly-infix) - (lambda () - (read-string " {1 + 2 + 3}"))))) - (and (not (source-property sexp 'line)) - (not (source-property sexp 'column))))) - (pass-if "mixed curly-infix list" - (let ((sexp (with-read-options '(curly-infix) - (lambda () - (read-string " {1 + 2 * 3}"))))) - (and (not (source-property sexp 'line)) - (not (source-property sexp 'column))))) - (pass-if "singleton curly-infix list" - (let ((sexp (with-read-options '(curly-infix) - (lambda () - (read-string " { 1.0 }"))))) - (and (not (source-property sexp 'line)) - (not (source-property sexp 'column))))) - (pass-if "neoteric expression" - (let ((sexp (with-read-options '(curly-infix) - (lambda () - (read-string " { f(x) }"))))) - (and (not (source-property sexp 'line)) - (not (source-property sexp 'column)))))) - ;; Verify that source position information is properly recorded. (with-test-prefix "positions" (pass-if "simple curly-infix list" - (let ((sexp (with-read-options '(curly-infix positions) + (let ((sexp (with-read-options '(curly-infix) (lambda () (read-string " {1 + 2 + 3}"))))) (and (equal? (source-property sexp 'line) 0) (equal? (source-property sexp 'column) 1)))) (pass-if "mixed curly-infix list" - (let ((sexp (with-read-options '(curly-infix positions) + (let ((sexp (with-read-options '(curly-infix) (lambda () (read-string " {1 + 2 * 3}"))))) (and (equal? (source-property sexp 'line) 0) (equal? (source-property sexp 'column) 1)))) (pass-if "singleton curly-infix list" - (let ((sexp (with-read-options '(curly-infix positions) + (let ((sexp (with-read-options '(curly-infix) (lambda () (read-string " { 1.0 }"))))) (and (equal? (source-property sexp 'line) 0) @@ -191,7 +164,7 @@ ((3) #t) (else #f))))) (pass-if "neoteric expression" - (let ((sexp (with-read-options '(curly-infix positions) + (let ((sexp (with-read-options '(curly-infix) (lambda () (read-string " { f(x) }"))))) (and (equal? (source-property sexp 'line) 0) diff --git a/test-suite/tests/srfi-119.test b/test-suite/tests/srfi-119.test index 5390a25b3..f52f9d8bc 100644 --- a/test-suite/tests/srfi-119.test +++ b/test-suite/tests/srfi-119.test @@ -1,6 +1,6 @@ ;;;; srfi-119.test --- Test suite for Guile's SRFI-119 reader. -*- scheme -*- ;;;; -;;;; Copyright (C) 2023 Free Software Foundation, Inc. +;;;; Copyright (C) 2023, 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 @@ -20,20 +20,12 @@ #:use-module (test-suite lib) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) ;; cut + #:use-module (ice-9 source-properties) #:use-module (language wisp)) (define (read-string s) (with-input-from-string s read)) -(define (with-read-options opts thunk) - (let ((saved-options (read-options))) - (dynamic-wind - (lambda () - (read-options opts)) - thunk - (lambda () - (read-options saved-options))))) - (define (wisp->list str) (wisp-scheme-read-string str)) @@ -97,14 +89,18 @@ _ display \"hello\n\" (pass-if-equal '((1 . 2)(3 4 (5 . 6))) (wisp->list "1 . 2\n3 4\n 5 . 6"))) +(define (source-line props) + (or (assq 'line props) (error "expected a line" props))) + (with-test-prefix "wisp-source-properties" ;; has properties (pass-if (every pair? (map source-properties (wisp->list "1 . 2\n3 4\n 5 . 6")))) (pass-if (every pair? (map source-properties (wisp->list "1 2\n3 4\n 5 6")))) ;; has the same properties (pass-if-equal - (map source-properties (scheme->list "(1 . 2)\n(3 4\n (5 . 6))\n(1 4)\n\n(7 8)")) - (map (cut cons '(filename . #f) <>) + (map source-line + (map source-properties (scheme->list "(1 . 2)\n(3 4\n (5 . 6))\n(1 4)\n\n(7 8)"))) + (map source-line (map source-properties (wisp->list "1 . 2\n3 4\n 5 . 6\n1 4\n\n7 8"))))) (with-test-prefix "btest" diff --git a/test-suite/tests/syntax.test b/test-suite/tests/syntax.test index 4872866ab..b5b1088e0 100644 --- a/test-suite/tests/syntax.test +++ b/test-suite/tests/syntax.test @@ -1,7 +1,7 @@ ;;;; syntax.test --- test suite for Guile's syntactic forms -*- scheme -*- ;;;; ;;;; Copyright (C) 2001, 2003, 2004, 2005, 2006, 2009, 2010, -;;;; 2011, 2012, 2013, 2014, 2021, 2024 Free Software Foundation, Inc. +;;;; 2011, 2012, 2013, 2014, 2021, 2024, 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 @@ -119,7 +119,7 @@ (eval (call-with-input-string "\n (let foo bar)" (lambda (port) (set-port-filename! port "example.scm") - (read port))) + (read-syntax port))) (interaction-environment))) (lambda (key proc message properties form subform . rest) properties))) diff --git a/test-suite/tests/tree-il.test b/test-suite/tests/tree-il.test index dd2e707b2..2ec41864a 100644 --- a/test-suite/tests/tree-il.test +++ b/test-suite/tests/tree-il.test @@ -1,7 +1,7 @@ ;;;; tree-il.test --- test suite for compiling tree-il -*- scheme -*- ;;;; Andy Wingo <wingo@pobox.com> --- May 2009 ;;;; -;;;; Copyright (C) 2009-2014,2018-2021,2023 Free Software Foundation, Inc. +;;;; Copyright (C) 2009-2014,2018-2021,2023,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 @@ -442,48 +442,44 @@ #:opts %opts-w-unused-module)))) (pass-if "definitely unused" - (let* ((defmod '(define-module (foo) - #:use-module (ice-9 vlist) - #:use-module (ice-9 popen) - #:export (proc))) - (w (call-with-warnings + (match (call-with-input-string + "(begin + (define-module (foo) + #:use-module (ice-9 vlist) + #:use-module (ice-9 popen) + #:export (proc)) + (define (frob x) + (vlist-cons x vlist-null)))" + (lambda (port) + (set-port-filename! port "foo.scm") + (call-with-warnings (lambda () - (set-source-properties! defmod - '((filename . "foo.scm") - (line . 0) - (column . 0))) - (compile `(begin - ,defmod - (define (frob x) - (vlist-cons x vlist-null))) - #:env (make-fresh-user-module) - #:opts %opts-w-unused-module))))) - (and (= (length w) 1) - (string-prefix? "foo.scm:1:0" (car w)) - (number? (string-contains (car w) - "unused module (ice-9 popen)"))))) + (read-and-compile port + #:env (make-fresh-user-module) + #:opts %opts-w-unused-module))))) + ((w) + (and (string-prefix? "foo.scm:2:18" w) + (number? (string-contains w "unused module (ice-9 popen)")))) + (warnings #f))) (pass-if "definitely unused, use-modules" - (let* ((usemod '(use-modules (rnrs bytevectors) - (ice-9 q))) - (w (call-with-warnings + (match (call-with-input-string + "(begin + (use-modules (rnrs bytevectors) (ice-9 q)) + (define (square x) + (* x x)))" + (lambda (port) + (set-port-filename! port "bar.scm") + (call-with-warnings (lambda () - (set-source-properties! usemod - '((filename . "bar.scm") - (line . 5) - (column . 0))) - (compile `(begin - ,usemod - (define (square x) - (* x x))) - #:env (make-fresh-user-module) - #:opts %opts-w-unused-module))))) - (and (= (length w) 2) - (string-prefix? "bar.scm:6:0" (car w)) - (number? (string-contains (car w) - "unused module (rnrs bytevectors)")) - (number? (string-contains (cadr w) - "unused module (ice-9 q)"))))) + (read-and-compile port + #:env (make-fresh-user-module) + #:opts %opts-w-unused-module))))) + ((w1 w2) + (and (string-prefix? "bar.scm:2:18" w1) + (number? (string-contains w1 "unused module (rnrs bytevectors)")) + (number? (string-contains w2 "unused module (ice-9 q)")))) + (warnings #f))) (pass-if "definitely unused, local binding shadows imported one" (let ((w (call-with-warnings diff --git a/test-suite/tests/types.test b/test-suite/tests/types.test index 778aaa6bd..1ebf19bad 100644 --- a/test-suite/tests/types.test +++ b/test-suite/tests/types.test @@ -22,6 +22,7 @@ #:use-module (rnrs io ports) #:use-module (ice-9 match) #:use-module (ice-9 regex) + #:use-module (ice-9 weak-tables) #:use-module (srfi srfi-1) #:use-module (srfi srfi-9) #:use-module (system foreign) diff --git a/test-suite/tests/weaks.test b/test-suite/tests/weaks.test index 21c8ddcc4..3663f39ec 100644 --- a/test-suite/tests/weaks.test +++ b/test-suite/tests/weaks.test @@ -1,5 +1,5 @@ ;;;; weaks.test --- tests guile's weaks -*- scheme -*- -;;;; Copyright (C) 1999, 2001, 2003, 2006, 2009, 2010, 2011, 2012, 2014 +;;;; Copyright (C) 1999, 2001, 2003, 2006, 2009, 2010, 2011, 2012, 2014, 2025 ;;;; Free Software Foundation, Inc. ;;;; ;;;; This library is free software; you can redistribute it and/or @@ -37,6 +37,7 @@ (define-module (test-weaks) #:use-module (test-suite lib) #:use-module (ice-9 weak-vector) + #:use-module (ice-9 weak-tables) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26)) |