mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-06-06 12:10:28 +02:00
Move source properties out to a module
* module/ice-9/source-properties.scm: New file, providing the source-properties API, as well as a replacement for `read' that always attaches source properties, regardless of the 'positions option on the port. * am/bootstrap.am (SOURCES): Add the new file. * libguile/srcprop.c: * libguile/srcprop.h: Remove. * libguile/Makefile.am (libguile_@GUILE_EFFECTIVE_VERSION@_la_SOURCES): (DOT_X_FILES): (DOT_DOC_FILES): (modinclude_HEADERS): * libguile.h: Remove srcprop.h. * libguile/deprecated.c: * libguile/deprecated.h: Add deprecation shims for srcprop.h interface. * libguile/backtrace.c: * libguile/debug.c: * libguile/eval.c: * libguile/init.c: * libguile/memoize.c: * libguile/promises.c: * libguile/read.c: * libguile/syntax.c: Remove needless srcprop.h includes. * module/ice-9/boot-9.scm: Reorder some definitions so that deprecated modules can use the (system syntax internal) module. * module/ice-9/deprecated.scm: Add shims for Scheme source-properties interface. * module/ice-9/read.scm (read): Never attach source properties. Users that want source can use read-syntax. * module/language/cps.scm: * module/language/cps/spec.scm: * module/language/ecmascript/compile-tree-il.scm: * module/language/elisp/compile-tree-il.scm: * module/language/elisp/lexer.scm: * module/language/elisp/parser.scm: * module/language/tree-il.scm: * module/language/tree-il/spec.scm: * module/language/wisp.scm: * module/system/base/lalr.scm: * test-suite/tests/elisp-reader.test: * test-suite/tests/reader.test: * test-suite/tests/srcprop.test: * test-suite/tests/srfi-105.test: * test-suite/tests/srfi-119.test: Use the (ice-9 source-properties) module to get access to source properties.
This commit is contained in:
Andy Wingo
parent
b6b6f62548
commit
e3b743dc72
34 changed files with 327 additions and 536 deletions
|
|
@ -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 \
|
||||
|
|
|
|||
|
|
@ -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"
|
||||
|
|
|
|||
|
|
@ -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 \
|
||||
|
|
|
|||
|
|
@ -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"
|
||||
|
|
|
|||
|
|
@ -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"
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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);
|
||||
|
|
|
|||
|
|
@ -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"
|
||||
|
|
|
|||
|
|
@ -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 ();
|
||||
|
|
|
|||
|
|
@ -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"
|
||||
|
|
|
|||
|
|
@ -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"
|
||||
|
|
|
|||
|
|
@ -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"
|
||||
|
|
|
|||
|
|
@ -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"
|
||||
}
|
||||
|
||||
|
|
@ -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 */
|
||||
|
|
@ -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"
|
||||
|
|
|
|||
|
|
@ -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.
|
||||
;;;
|
||||
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -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)))
|
||||
|
|
|
|||
107
module/ice-9/source-properties.scm
Normal file
107
module/ice-9/source-properties.scm
Normal file
|
|
@ -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)))
|
||||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
||||
|
|
|
|||
|
|
@ -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> void? make-void void-src
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
||||
|
||||
; ==============================================================================
|
||||
|
|
|
|||
|
|
@ -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"
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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"
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue