summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--am/bootstrap.am3
-rw-r--r--libguile.h2
-rw-r--r--libguile/Makefile.am8
-rw-r--r--libguile/backtrace.c3
-rw-r--r--libguile/debug.c3
-rw-r--r--libguile/deprecated.c136
-rw-r--r--libguile/deprecated.h15
-rw-r--r--libguile/ephemerons.c368
-rw-r--r--libguile/ephemerons.h38
-rw-r--r--libguile/eval.c1
-rw-r--r--libguile/evalext.c1
-rw-r--r--libguile/expand.c355
-rw-r--r--libguile/fluids.c53
-rw-r--r--libguile/fluids.h5
-rw-r--r--libguile/goops.c48
-rw-r--r--libguile/init.c5
-rw-r--r--libguile/memoize.c3
-rw-r--r--libguile/objprop.c105
-rw-r--r--libguile/objprop.h35
-rw-r--r--libguile/print.c3
-rw-r--r--libguile/procprop.c35
-rw-r--r--libguile/promises.c3
-rw-r--r--libguile/read.c3
-rw-r--r--libguile/scm.h2
-rw-r--r--libguile/srcprop.c326
-rw-r--r--libguile/srcprop.h53
-rw-r--r--libguile/syntax.c63
-rw-r--r--libguile/syntax.h3
-rw-r--r--libguile/threads.c56
-rw-r--r--libguile/threads.h6
-rw-r--r--libguile/weak-table.c16
-rw-r--r--libguile/weak-table.h3
-rw-r--r--libguile/whippet/src/bdw.c25
-rw-r--r--module/ice-9/boot-9.scm179
-rw-r--r--module/ice-9/buffered-input.scm3
-rw-r--r--module/ice-9/deprecated.scm126
-rw-r--r--module/ice-9/documentation.scm3
-rw-r--r--module/ice-9/ephemerons.scm12
-rw-r--r--module/ice-9/hcons.scm9
-rw-r--r--module/ice-9/object-properties.scm64
-rw-r--r--module/ice-9/poe.scm7
-rw-r--r--module/ice-9/popen.scm1
-rw-r--r--module/ice-9/psyntax-pp.scm153
-rw-r--r--module/ice-9/psyntax.scm52
-rw-r--r--module/ice-9/read.scm21
-rw-r--r--module/ice-9/sandbox.scm7
-rw-r--r--module/ice-9/source-properties.scm107
-rw-r--r--module/ice-9/threads.scm59
-rw-r--r--module/ice-9/weak-tables.scm35
-rw-r--r--module/language/cps.scm3
-rw-r--r--module/language/cps/spec.scm3
-rw-r--r--module/language/ecmascript/compile-tree-il.scm3
-rw-r--r--module/language/ecmascript/function.scm3
-rw-r--r--module/language/elisp/boot.el5
-rw-r--r--module/language/elisp/compile-tree-il.scm7
-rw-r--r--module/language/elisp/lexer.scm3
-rw-r--r--module/language/elisp/parser.scm3
-rw-r--r--module/language/tree-il.scm24
-rw-r--r--module/language/tree-il/analyze.scm8
-rw-r--r--module/language/tree-il/compile-bytecode.scm4
-rw-r--r--module/language/tree-il/compile-cps.scm10
-rw-r--r--module/language/tree-il/debug.scm2
-rw-r--r--module/language/tree-il/letrectify.scm4
-rw-r--r--module/language/tree-il/peval.scm4
-rw-r--r--module/language/tree-il/spec.scm3
-rw-r--r--module/language/wisp.scm3
-rw-r--r--module/oop/goops.scm3
-rw-r--r--module/oop/goops/save.scm3
-rw-r--r--module/scripts/api-diff.scm15
-rw-r--r--module/scripts/frisk.scm3
-rw-r--r--module/scripts/read-text-outline.scm3
-rw-r--r--module/scripts/scan-api.scm11
-rw-r--r--module/scripts/summarize-guile-TODO.scm15
-rw-r--r--module/srfi/srfi-18.scm3
-rw-r--r--module/srfi/srfi-64.scm7
-rw-r--r--module/srfi/srfi-69.scm3
-rw-r--r--module/system/base/lalr.scm3
-rw-r--r--module/system/base/types.scm13
-rw-r--r--module/system/foreign.scm3
-rw-r--r--module/system/syntax.scm13
-rw-r--r--module/system/vm/assembler.scm47
-rw-r--r--module/web/http.scm13
-rw-r--r--test-suite/tests/compiler.test25
-rw-r--r--test-suite/tests/coverage.test5
-rw-r--r--test-suite/tests/elisp-reader.test10
-rw-r--r--test-suite/tests/ephemerons.test34
-rw-r--r--test-suite/tests/eval-string.test18
-rw-r--r--test-suite/tests/gc.test1
-rw-r--r--test-suite/tests/hash.test5
-rw-r--r--test-suite/tests/modules.test43
-rw-r--r--test-suite/tests/reader.test23
-rw-r--r--test-suite/tests/srcprop.test10
-rw-r--r--test-suite/tests/srfi-105.test39
-rw-r--r--test-suite/tests/srfi-119.test20
-rw-r--r--test-suite/tests/syntax.test4
-rw-r--r--test-suite/tests/tree-il.test74
-rw-r--r--test-suite/tests/types.test1
-rw-r--r--test-suite/tests/weaks.test3
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))