diff --git a/am/bootstrap.am b/am/bootstrap.am
index f38a98032..4736d04b6 100644
--- a/am/bootstrap.am
+++ b/am/bootstrap.am
@@ -191,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 \
diff --git a/libguile.h b/libguile.h
index fedaff9a3..b7211f4f3 100644
--- a/libguile.h
+++ b/libguile.h
@@ -95,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 6a615ab1d..1cc0d34b8 100644
--- a/libguile/Makefile.am
+++ b/libguile/Makefile.am
@@ -214,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 \
@@ -326,7 +325,6 @@ DOT_X_FILES = \
simpos.x \
smob.x \
sort.x \
- srcprop.x \
srfi-4.x \
srfi-13.x \
srfi-14.x \
@@ -425,7 +423,6 @@ DOT_DOC_FILES = \
simpos.doc \
smob.doc \
sort.doc \
- srcprop.doc \
srfi-4.doc \
srfi-13.doc \
srfi-14.doc \
@@ -684,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 b2f941912..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"
@@ -230,6 +231,80 @@ scm_set_object_property_x (SCM obj, SCM key, SCM 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 df785d871..ab99d6581 100644
--- a/libguile/deprecated.h
+++ b/libguile/deprecated.h
@@ -46,6 +46,16 @@ 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/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/init.c b/libguile/init.c
index 4653b5d87..fc86a6145 100644
--- a/libguile/init.c
+++ b/libguile/init.c
@@ -124,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"
@@ -431,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 ();
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/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/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
- . */
-
-
-
-
-#ifdef HAVE_CONFIG_H
-# include
-#endif
-
-#include
-
-#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 ("#', 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
- . */
-
-
-
-#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 c68b01963..6e298e5e9 100644
--- a/libguile/syntax.c
+++ b/libguile/syntax.c
@@ -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"
diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm
index 2e8e25970..101a2755a 100644
--- a/module/ice-9/boot-9.scm
+++ b/module/ice-9/boot-9.scm
@@ -4579,14 +4579,6 @@ R7RS."
-;;; {Deprecated stuff}
-;;;
-
-(begin-deprecated
- (module-use! the-scm-module (resolve-interface '(ice-9 deprecated))))
-
-
-
;;; {Ports}
;;;
@@ -4613,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}
;;;
@@ -4652,37 +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)))
-
-
-
-
;;; Place the user in the guile-user module.
;;;
diff --git a/module/ice-9/deprecated.scm b/module/ice-9/deprecated.scm
index 71414b570..6ff24c4c6 100644
--- a/module/ice-9/deprecated.scm
+++ b/module/ice-9/deprecated.scm
@@ -18,6 +18,7 @@
(define-module (ice-9 deprecated)
#:use-module (ice-9 guardians)
#: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
@@ -27,7 +28,13 @@
(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?)))
+ (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)
@@ -115,3 +122,39 @@ Import it from (ice-9 weak-tables) instead.")
"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/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/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
+;;; .
+
+;;; 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/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/elisp/compile-tree-il.scm b/module/language/elisp/compile-tree-il.scm
index 431d42bdc..81211a0a1 100644
--- a/module/language/elisp/compile-tree-il.scm
+++ b/module/language/elisp/compile-tree-il.scm
@@ -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)
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 78c08c200..43f5f985e 100644
--- a/module/language/tree-il.scm
+++ b/module/language/tree-il.scm
@@ -20,6 +20,7 @@
#: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
void? make-void void-src
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
@@ -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/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/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/reader.test b/test-suite/tests/reader.test
index c0f424e9a..8d2a3d415 100644
--- a/test-suite/tests/reader.test
+++ b/test-suite/tests/reader.test
@@ -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"
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"