mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-30 03:40:34 +02:00
Code Activity

Clean up srcprops implementation

Browse source 
* libguile/deprecated.c (scm_sym_copy, scm_make_srcprops): Deprecate.
* libguile/deprecated.h (scm_tc16_srcprops)
  (SCM_SOURCE_PROPERTY_FLAG_BREAK): Deprecate.
* libguile/private-options.h (SCM_COPY_SOURCE_P): Remove.
* libguile/read.c (struct t_read_opts, scm_read_options): Remove useless
  copy read option.
  (maybe_annotate_source): Change line and column to be tagged, and
  subtract off lookahead here.  Change all callers.
  (READ_OPTION_COPY_SOURCE_P): Remove, renumbering other options.
  (init_read_options): Remove copy option.
* libguile/srcprop.c: Change to put filename inline in source
  properties.  Update private implementation.
* libguile/srcprop.h (SCM_PROCTRACEP): Remove.  Unusable given that
  scm_sym_trace was undefined.
This commit is contained in:
Andy Wingo 2020-09-03 22:55:08 +02:00
parent 837580587b
commit 6f6abb3bb5
6 changed files with 137 additions and 163 deletions
Download patch file Download diff file Expand all files Collapse all files

17
libguile/deprecated.c
View file

@ -27,13 +27,17 @@
#define SCM_BUILDING_DEPRECATED_CODE #define SCM_BUILDING_DEPRECATED_CODE
#include "alist.h"
#include "boolean.h" #include "boolean.h"
#include "bitvectors.h" #include "bitvectors.h"
#include "deprecation.h" #include "deprecation.h"
#include "gc.h" #include "gc.h"
#include "gsubr.h" #include "gsubr.h"
#include "procprop.h"
#include "srcprop.h"
#include "srfi-4.h" #include "srfi-4.h"
#include "strings.h" #include "strings.h"
#include "symbols.h"
#include "deprecated.h" #include "deprecated.h"
@ -569,6 +573,19 @@ scm_istr2bve (SCM str)
return res; return res;
} }
SCM_GLOBAL_SYMBOL (scm_sym_copy, "copy");
SCM
scm_make_srcprops (long line, int col, SCM filename, SCM copy, SCM alist)
{
scm_c_issue_deprecation_warning
("scm_make_srcprops is deprecated; use set-source-properties! instead");
alist = SCM_UNBNDP (copy) ? alist : scm_acons (scm_sym_copy, copy, alist);
return scm_i_make_srcprops (scm_from_long (line), scm_from_int (col),
filename, alist);
}

7
libguile/deprecated.h
View file

@ -131,6 +131,13 @@ SCM_DEPRECATED SCM scm_bit_position (SCM item, SCM v, SCM k);
SCM_DEPRECATED SCM scm_bit_set_star_x (SCM v, SCM kv, SCM obj); SCM_DEPRECATED SCM scm_bit_set_star_x (SCM v, SCM kv, SCM obj);
SCM_DEPRECATED SCM scm_istr2bve (SCM str); SCM_DEPRECATED SCM scm_istr2bve (SCM str);
#define SCM_SOURCE_PROPERTY_FLAG_BREAK 1
SCM_DEPRECATED scm_t_bits scm_tc16_srcprops;
SCM_DEPRECATED SCM scm_sym_copy;
SCM_DEPRECATED SCM scm_make_srcprops (long line, int col, SCM filename,
SCM copy, SCM alist);
void scm_i_init_deprecated (void); void scm_i_init_deprecated (void);
#endif #endif

21
libguile/private-options.h
View file

@ -1,4 +1,4 @@
/* Copyright 2007,2009-2011,2014,2018 /* Copyright 2007,2009-2011,2014,2018,2020
Free Software Foundation, Inc. Free Software Foundation, Inc.
This file is part of Guile. This file is part of Guile.
@ -56,16 +56,15 @@ SCM_INTERNAL scm_t_option scm_print_opts[];
*/ */
SCM_INTERNAL scm_t_option scm_read_opts[]; SCM_INTERNAL scm_t_option scm_read_opts[];
#define SCM_COPY_SOURCE_P scm_read_opts[0].val #define SCM_RECORD_POSITIONS_P scm_read_opts[0].val
#define SCM_RECORD_POSITIONS_P scm_read_opts[1].val #define SCM_CASE_INSENSITIVE_P scm_read_opts[1].val
#define SCM_CASE_INSENSITIVE_P scm_read_opts[2].val #define SCM_KEYWORD_STYLE scm_read_opts[2].val
#define SCM_KEYWORD_STYLE scm_read_opts[3].val #define SCM_R6RS_ESCAPES_P scm_read_opts[3].val
#define SCM_R6RS_ESCAPES_P scm_read_opts[4].val #define SCM_SQUARE_BRACKETS_P scm_read_opts[4].val
#define SCM_SQUARE_BRACKETS_P scm_read_opts[5].val #define SCM_HUNGRY_EOL_ESCAPES_P scm_read_opts[5].val
#define SCM_HUNGRY_EOL_ESCAPES_P scm_read_opts[6].val #define SCM_CURLY_INFIX_P scm_read_opts[6].val
#define SCM_CURLY_INFIX_P scm_read_opts[7].val #define SCM_R7RS_SYMBOLS_P scm_read_opts[7].val
#define SCM_R7RS_SYMBOLS_P scm_read_opts[8].val
#define SCM_N_READ_OPTIONS 9 #define SCM_N_READ_OPTIONS 8
#endif /* PRIVATE_OPTIONS */ #endif /* PRIVATE_OPTIONS */

94
libguile/read.c
View file

@ -81,8 +81,6 @@ SCM_SYMBOL (sym_bracket_apply, "$bracket-apply$");
scm_t_option scm_read_opts[] = scm_t_option scm_read_opts[] =
{ {
{ SCM_OPTION_BOOLEAN, "copy", 0,
"Copy source code expressions." },
{ SCM_OPTION_BOOLEAN, "positions", 1, { SCM_OPTION_BOOLEAN, "positions", 1,
"Record positions of source code expressions." }, "Record positions of source code expressions." },
{ SCM_OPTION_BOOLEAN, "case-insensitive", 0, { SCM_OPTION_BOOLEAN, "case-insensitive", 0,
@ -116,7 +114,6 @@ enum t_keyword_style
struct t_read_opts struct t_read_opts
{ {
enum t_keyword_style keyword_style; enum t_keyword_style keyword_style;
unsigned int copy_source_p : 1;
unsigned int record_positions_p : 1; unsigned int record_positions_p : 1;
unsigned int case_insensitive_p : 1; unsigned int case_insensitive_p : 1;
unsigned int r6rs_escapes_p : 1; unsigned int r6rs_escapes_p : 1;
@ -178,12 +175,7 @@ SCM_DEFINE (scm_read_options, "read-options-interface", 0, 1, 0,
"@code{read-disable}, @code{read-set!} and @code{read-options}.") "@code{read-disable}, @code{read-set!} and @code{read-options}.")
#define FUNC_NAME s_scm_read_options #define FUNC_NAME s_scm_read_options
{ {
SCM ans = scm_options (setting, return scm_options (setting, scm_read_opts, FUNC_NAME);
scm_read_opts,
FUNC_NAME);
if (SCM_COPY_SOURCE_P)
SCM_RECORD_POSITIONS_P = 1;
return ans;
} }
#undef FUNC_NAME #undef FUNC_NAME
@ -413,20 +405,26 @@ flush_ws (SCM port, scm_t_read_opts *opts, const char *eoferr)
static SCM scm_read_expression (SCM port, scm_t_read_opts *opts); static SCM scm_read_expression (SCM port, scm_t_read_opts *opts);
static SCM scm_read_sharp (int chr, SCM port, scm_t_read_opts *opts, static SCM scm_read_sharp (int chr, SCM port, scm_t_read_opts *opts,
long line, int column); SCM line, SCM column);
static SCM static SCM
maybe_annotate_source (SCM x, SCM port, scm_t_read_opts *opts, maybe_annotate_source (SCM x, SCM port, scm_t_read_opts *opts,
long line, int column) SCM line, SCM column)
{ {
if ((SCM_I_INUMP (line) && SCM_I_INUM (line) < 0)
|| (SCM_I_INUMP (column) && SCM_I_INUM (column) < 1))
/* This condition can be caused by a user calling /* This condition can be caused by a user calling
set-port-column!. */ set-port-column!. */
if (line < 0 || column < 0)
return x; return x;
if (opts->record_positions_p) if (opts->record_positions_p)
{
/* We always capture the column after one char of lookahead;
subtract off that lookahead value. */
column = scm_oneminus (column);
scm_i_set_source_properties_x (x, line, column, SCM_FILENAME (port)); scm_i_set_source_properties_x (x, line, column, SCM_FILENAME (port));
}
return x; return x;
} }
@ -442,8 +440,8 @@ scm_read_sexp (scm_t_wchar chr, SCM port, scm_t_read_opts *opts)
: ')')); : ')'));
/* Need to capture line and column numbers here. */ /* Need to capture line and column numbers here. */
long line = scm_to_long (scm_port_line (port)); SCM line = scm_port_line (port);
int column = scm_to_int (scm_port_column (port)) - 1; SCM column = scm_port_column (port);
c = flush_ws (port, opts, FUNC_NAME); c = flush_ws (port, opts, FUNC_NAME);
if (terminating_char == c) if (terminating_char == c)
@ -620,8 +618,8 @@ scm_read_string_like_syntax (int chr, SCM port, scm_t_read_opts *opts)
scm_t_wchar c, c_str[READER_STRING_BUFFER_SIZE]; scm_t_wchar c, c_str[READER_STRING_BUFFER_SIZE];
/* Need to capture line and column numbers here. */ /* Need to capture line and column numbers here. */
long line = scm_to_long (scm_port_line (port)); SCM line = scm_port_line (port);
int column = scm_to_int (scm_port_column (port)) - 1; SCM column = scm_port_column (port);
while (chr != (c = scm_getc (port))) while (chr != (c = scm_getc (port)))
{ {
@ -747,8 +745,8 @@ scm_read_number (scm_t_wchar chr, SCM port, scm_t_read_opts *opts)
size_t bytes_read; size_t bytes_read;
/* Need to capture line and column numbers here. */ /* Need to capture line and column numbers here. */
long line = scm_to_long (scm_port_line (port)); SCM line = scm_port_line (port);
int column = scm_to_int (scm_port_column (port)) - 1; SCM column = scm_port_column (port);
scm_ungetc (chr, port); scm_ungetc (chr, port);
buffer = read_complete_token (port, opts, local_buffer, sizeof local_buffer, buffer = read_complete_token (port, opts, local_buffer, sizeof local_buffer,
@ -874,8 +872,8 @@ static SCM
scm_read_quote (int chr, SCM port, scm_t_read_opts *opts) scm_read_quote (int chr, SCM port, scm_t_read_opts *opts)
{ {
SCM p; SCM p;
long line = scm_to_long (scm_port_line (port)); SCM line = scm_port_line (port);
int column = scm_to_int (scm_port_column (port)) - 1; SCM column = scm_port_column (port);
switch (chr) switch (chr)
{ {
@ -921,8 +919,8 @@ static SCM
scm_read_syntax (int chr, SCM port, scm_t_read_opts *opts) scm_read_syntax (int chr, SCM port, scm_t_read_opts *opts)
{ {
SCM p; SCM p;
long line = scm_to_long (scm_port_line (port)); SCM line = scm_port_line (port);
int column = scm_to_int (scm_port_column (port)) - 1; SCM column = scm_port_column (port);
switch (chr) switch (chr)
{ {
@ -1177,7 +1175,7 @@ scm_read_keyword (int chr, SCM port, scm_t_read_opts *opts)
static SCM static SCM
scm_read_vector (int chr, SCM port, scm_t_read_opts *opts, scm_read_vector (int chr, SCM port, scm_t_read_opts *opts,
long line, int column) SCM line, SCM column)
{ {
/* Note: We call `scm_read_sexp ()' rather than READER here in order to /* Note: We call `scm_read_sexp ()' rather than READER here in order to
guarantee that it's going to do what we want. After all, this is an guarantee that it's going to do what we want. After all, this is an
@ -1222,7 +1220,7 @@ read_decimal_integer (SCM port, int c, ssize_t *resp)
C is the first character read after the '#'. */ C is the first character read after the '#'. */
static SCM static SCM
scm_read_array (int c, SCM port, scm_t_read_opts *opts, long line, int column) scm_read_array (int c, SCM port, scm_t_read_opts *opts, SCM line, SCM column)
{ {
ssize_t rank; ssize_t rank;
scm_t_wchar tag_buf[8]; scm_t_wchar tag_buf[8];
@ -1353,14 +1351,14 @@ scm_read_array (int c, SCM port, scm_t_read_opts *opts, long line, int column)
static SCM static SCM
scm_read_srfi4_vector (int chr, SCM port, scm_t_read_opts *opts, scm_read_srfi4_vector (int chr, SCM port, scm_t_read_opts *opts,
long line, int column) SCM line, SCM column)
{ {
return scm_read_array (chr, port, opts, line, column); return scm_read_array (chr, port, opts, line, column);
} }
static SCM static SCM
scm_read_bytevector (scm_t_wchar chr, SCM port, scm_t_read_opts *opts, scm_read_bytevector (scm_t_wchar chr, SCM port, scm_t_read_opts *opts,
long line, int column) SCM line, SCM column)
{ {
chr = scm_getc (port); chr = scm_getc (port);
if (chr != 'u') if (chr != 'u')
@ -1387,7 +1385,7 @@ scm_read_bytevector (scm_t_wchar chr, SCM port, scm_t_read_opts *opts,
static SCM static SCM
scm_read_guile_bit_vector (scm_t_wchar chr, SCM port, scm_t_read_opts *opts, scm_read_guile_bit_vector (scm_t_wchar chr, SCM port, scm_t_read_opts *opts,
long line, int column) SCM line, SCM column)
{ {
/* Read the `#*10101'-style read syntax for bit vectors in Guile. This is /* Read the `#*10101'-style read syntax for bit vectors in Guile. This is
terribly inefficient but who cares? */ terribly inefficient but who cares? */
@ -1655,8 +1653,8 @@ scm_read_sharp_extension (int chr, SCM port, scm_t_read_opts *opts)
proc = scm_get_hash_procedure (chr); proc = scm_get_hash_procedure (chr);
if (scm_is_true (scm_procedure_p (proc))) if (scm_is_true (scm_procedure_p (proc)))
{ {
long line = scm_to_long (scm_port_line (port)); SCM line = scm_port_line (port);
int column = scm_to_int (scm_port_column (port)) - 2; SCM column = scm_oneminus (scm_port_column (port));
SCM got; SCM got;
got = scm_call_2 (proc, SCM_MAKE_CHAR (chr), port); got = scm_call_2 (proc, SCM_MAKE_CHAR (chr), port);
@ -1675,7 +1673,7 @@ scm_read_sharp_extension (int chr, SCM port, scm_t_read_opts *opts)
among the above token readers. */ among the above token readers. */
static SCM static SCM
scm_read_sharp (scm_t_wchar chr, SCM port, scm_t_read_opts *opts, scm_read_sharp (scm_t_wchar chr, SCM port, scm_t_read_opts *opts,
long line, int column) SCM line, SCM column)
#define FUNC_NAME "scm_lreadr" #define FUNC_NAME "scm_lreadr"
{ {
SCM result; SCM result;
@ -1808,8 +1806,8 @@ read_inner_expression (SCM port, scm_t_read_opts *opts)
be part of an unescaped symbol. We might as well do be part of an unescaped symbol. We might as well do
something useful with it, so we adopt Kawa's convention: something useful with it, so we adopt Kawa's convention:
[...] => ($bracket-list$ ...) */ [...] => ($bracket-list$ ...) */
long line = scm_to_long (scm_port_line (port)); SCM line = scm_port_line (port);
int column = scm_to_int (scm_port_column (port)) - 1; SCM column = scm_port_column (port);
return maybe_annotate_source return maybe_annotate_source
(scm_cons (sym_bracket_list, scm_read_sexp (chr, port, opts)), (scm_cons (sym_bracket_list, scm_read_sexp (chr, port, opts)),
port, opts, line, column); port, opts, line, column);
@ -1831,8 +1829,8 @@ read_inner_expression (SCM port, scm_t_read_opts *opts)
return (scm_read_quote (chr, port, opts)); return (scm_read_quote (chr, port, opts));
case '#': case '#':
{ {
long line = scm_to_long (scm_port_line (port)); SCM line = scm_port_line (port);
int column = scm_to_int (scm_port_column (port)) - 1; SCM column = scm_port_column (port);
SCM result = scm_read_sharp (chr, port, opts, line, column); SCM result = scm_read_sharp (chr, port, opts, line, column);
if (scm_is_eq (result, SCM_UNSPECIFIED)) if (scm_is_eq (result, SCM_UNSPECIFIED))
/* We read a comment or some such. */ /* We read a comment or some such. */
@ -1880,8 +1878,8 @@ scm_read_expression (SCM port, scm_t_read_opts *opts)
return read_inner_expression (port, opts); return read_inner_expression (port, opts);
else else
{ {
long line = 0; SCM line = SCM_INUM0;
int column = 0; SCM column = SCM_INUM1;
SCM expr; SCM expr;
if (opts->record_positions_p) if (opts->record_positions_p)
@ -1896,8 +1894,8 @@ scm_read_expression (SCM port, scm_t_read_opts *opts)
if (c == EOF) if (c == EOF)
return SCM_EOF_VAL; return SCM_EOF_VAL;
scm_ungetc (c, port); scm_ungetc (c, port);
line = scm_to_long (scm_port_line (port)); line = scm_port_line (port);
column = scm_to_int (scm_port_column (port)); column = scm_port_column (port);
} }
expr = read_inner_expression (port, opts); expr = read_inner_expression (port, opts);
@ -2250,18 +2248,17 @@ SCM_DEFINE (scm_file_encoding, "file-encoding", 1, 0, 0,
SCM_SYMBOL (sym_port_read_options, "port-read-options"); SCM_SYMBOL (sym_port_read_options, "port-read-options");
/* Offsets of bit fields for each per-port override */ /* Offsets of bit fields for each per-port override */
#define READ_OPTION_COPY_SOURCE_P 0 #define READ_OPTION_RECORD_POSITIONS_P 0
#define READ_OPTION_RECORD_POSITIONS_P 2 #define READ_OPTION_CASE_INSENSITIVE_P 2
#define READ_OPTION_CASE_INSENSITIVE_P 4 #define READ_OPTION_KEYWORD_STYLE 4
#define READ_OPTION_KEYWORD_STYLE 6 #define READ_OPTION_R6RS_ESCAPES_P 6
#define READ_OPTION_R6RS_ESCAPES_P 8 #define READ_OPTION_SQUARE_BRACKETS_P 8
#define READ_OPTION_SQUARE_BRACKETS_P 10 #define READ_OPTION_HUNGRY_EOL_ESCAPES_P 10
#define READ_OPTION_HUNGRY_EOL_ESCAPES_P 12 #define READ_OPTION_CURLY_INFIX_P 12
#define READ_OPTION_CURLY_INFIX_P 14 #define READ_OPTION_R7RS_SYMBOLS_P 14
#define READ_OPTION_R7RS_SYMBOLS_P 16
/* The total width in bits of the per-port overrides */ /* The total width in bits of the per-port overrides */
#define READ_OPTIONS_NUM_BITS 18 #define READ_OPTIONS_NUM_BITS 16
#define READ_OPTIONS_INHERIT_ALL ((1UL << READ_OPTIONS_NUM_BITS) - 1) #define READ_OPTIONS_INHERIT_ALL ((1UL << READ_OPTIONS_NUM_BITS) - 1)
#define READ_OPTIONS_MAX_VALUE READ_OPTIONS_INHERIT_ALL #define READ_OPTIONS_MAX_VALUE READ_OPTIONS_INHERIT_ALL
@ -2377,7 +2374,6 @@ init_read_options (SCM port, scm_t_read_opts *opts)
} \ } \
while (0) while (0)
RESOLVE_BOOLEAN_OPTION (COPY_SOURCE_P, copy_source_p);
RESOLVE_BOOLEAN_OPTION (RECORD_POSITIONS_P, record_positions_p); RESOLVE_BOOLEAN_OPTION (RECORD_POSITIONS_P, record_positions_p);
RESOLVE_BOOLEAN_OPTION (CASE_INSENSITIVE_P, case_insensitive_p); RESOLVE_BOOLEAN_OPTION (CASE_INSENSITIVE_P, case_insensitive_p);
RESOLVE_BOOLEAN_OPTION (R6RS_ESCAPES_P, r6rs_escapes_p); RESOLVE_BOOLEAN_OPTION (R6RS_ESCAPES_P, r6rs_escapes_p);

140
libguile/srcprop.c
View file

@ -1,4 +1,4 @@
/* Copyright 1995-2002,2006,2008-2012,2018 /* Copyright 1995-2002,2006,2008-2012,2018,2020
Free Software Foundation, Inc. Free Software Foundation, Inc.
This file is part of Guile. This file is part of Guile.
@ -51,19 +51,17 @@
/* {Source Properties} /* {Source Properties}
* *
* Properties of source list expressions. * Properties of source list expressions.
* Four of these have special meaning: * Three of these have special meaning:
* *
* filename string The name of the source file. * filename The name of the source file.
* copy list A copy of the list expression. * line The source code line number.
* line integer The source code line number. * column The source code column number.
* column integer The source code column number.
* *
* Most properties above can be set by the reader. * Most properties above can be set by the reader.
* *
*/ */
SCM_GLOBAL_SYMBOL (scm_sym_filename, "filename"); SCM_GLOBAL_SYMBOL (scm_sym_filename, "filename");
SCM_GLOBAL_SYMBOL (scm_sym_copy, "copy");
SCM_GLOBAL_SYMBOL (scm_sym_line, "line"); SCM_GLOBAL_SYMBOL (scm_sym_line, "line");
SCM_GLOBAL_SYMBOL (scm_sym_column, "column"); SCM_GLOBAL_SYMBOL (scm_sym_column, "column");
@ -74,31 +72,28 @@ static SCM scm_source_whash;
* Source properties are stored as double cells with the * Source properties are stored as double cells with the
* following layout: * following layout:
* car = tag * car = tag | col (untagged)
* cbr = pos * cbr = line
* ccr = copy * ccr = filename
* cdr = alist * cdr = alist
*/ */
#define SRCPROPSP(p) (SCM_SMOB_PREDICATE (scm_tc16_srcprops, (p))) static scm_t_bits tc16_srcprops;
#define SRCPROPPOS(p) (SCM_SMOB_DATA(p))
#define SRCPROPLINE(p) (SRCPROPPOS(p) >> 12) #define SRCPROPSP(p) (SCM_SMOB_PREDICATE (tc16_srcprops, (p)))
#define SRCPROPCOL(p) (SRCPROPPOS(p) & 0x0fffL) #define SRCPROPCOL(p) (scm_from_int (SCM_SMOB_FLAGS (p)))
#define SRCPROPCOPY(p) (SCM_SMOB_OBJECT_2(p)) #define SRCPROPLINE(p) (SCM_SMOB_OBJECT_1 (p))
#define SRCPROPALIST(p) (SCM_SMOB_OBJECT_3(p)) #define SRCPROPFNAME(p) (SCM_SMOB_OBJECT_2 (p))
#define SRCPROPMAKPOS(l, c) (((l) << 12) + (c)) #define SRCPROPALIST(p) (SCM_SMOB_OBJECT_3 (p))
#define SETSRCPROPPOS(p, l, c) (SCM_SET_SMOB_DATA_1 (p, SRCPROPMAKPOS (l, c))) #define SETSRCPROPCOL(p, c) (SCM_SET_SMOB_FLAGS (p, scm_to_int (c)))
#define SETSRCPROPLINE(p, l) SETSRCPROPPOS (p, l, SRCPROPCOL (p)) #define SETSRCPROPLINE(p, l) (SCM_SET_SMOB_OBJECT_1 (p, l))
#define SETSRCPROPCOL(p, c) SETSRCPROPPOS (p, SRCPROPLINE (p), c) #define SETSRCPROPFNAME(p, x) (SCM_SET_SMOB_OBJECT_2 (p, x))
#define SETSRCPROPCOPY(p, c) (SCM_SET_SMOB_OBJECT_2 (p, c)) #define SETSRCPROPALIST(p, x) (SCM_SET_SMOB_OBJECT_3 (p, x))
#define SETSRCPROPALIST(p, l) (SCM_SET_SMOB_OBJECT_3 (p, l))
static SCM scm_srcprops_to_alist (SCM obj); static SCM scm_srcprops_to_alist (SCM obj);
scm_t_bits scm_tc16_srcprops;
static int static int
supports_source_props (SCM obj) supports_source_props (SCM obj)
@ -120,56 +115,23 @@ srcprops_print (SCM obj, SCM port, scm_print_state *pstate)
} }
/*
* We remember the last file name settings, so we can share that alist
* entry. This works because scm_set_source_property_x does not use
* assoc-set! for modifying the alist.
*
* This variable contains a protected cons, whose cdr is the cached
* alist
*/
static SCM scm_last_alist_filename;
SCM SCM
scm_make_srcprops (long line, int col, SCM filename, SCM copy, SCM alist) scm_i_make_srcprops (SCM line, SCM col, SCM filename, SCM alist)
{ {
if (!SCM_UNBNDP (filename)) SCM_RETURN_NEWSMOB3 (tc16_srcprops | (scm_to_int (col) << 16),
{ SCM_UNPACK (line),
SCM old_alist = alist; SCM_UNPACK (filename),
/*
have to extract the acons, and operate on that, for
thread safety.
*/
SCM last_acons = SCM_CDR (scm_last_alist_filename);
if (scm_is_null (old_alist)
&& scm_is_eq (SCM_CDAR (last_acons), filename))
{
alist = last_acons;
}
else
{
alist = scm_acons (scm_sym_filename, filename, alist);
if (scm_is_null (old_alist))
scm_set_cdr_x (scm_last_alist_filename, alist);
}
}
SCM_RETURN_NEWSMOB3 (scm_tc16_srcprops,
SRCPROPMAKPOS (line, col),
SCM_UNPACK (copy),
SCM_UNPACK (alist)); SCM_UNPACK (alist));
} }
static SCM static SCM
scm_srcprops_to_alist (SCM obj) scm_srcprops_to_alist (SCM obj)
{ {
SCM alist = SRCPROPALIST (obj); SCM alist = SRCPROPALIST (obj);
if (!SCM_UNBNDP (SRCPROPCOPY (obj))) if (scm_is_true (SRCPROPFNAME (obj)))
alist = scm_acons (scm_sym_copy, SRCPROPCOPY (obj), alist); alist = scm_acons (scm_sym_filename, SRCPROPFNAME (obj), alist);
alist = scm_acons (scm_sym_column, scm_from_int (SRCPROPCOL (obj)), alist); alist = scm_acons (scm_sym_column, SRCPROPCOL (obj), alist);
alist = scm_acons (scm_sym_line, scm_from_int (SRCPROPLINE (obj)), alist); alist = scm_acons (scm_sym_line, SRCPROPLINE (obj), alist);
return alist; return alist;
} }
@ -235,17 +197,13 @@ scm_i_has_source_properties (SCM obj)
void void
scm_i_set_source_properties_x (SCM obj, long line, int col, SCM fname) scm_i_set_source_properties_x (SCM obj, SCM line, SCM col, SCM fname)
#define FUNC_NAME "%set-source-properties" #define FUNC_NAME "%set-source-properties"
{ {
SCM_VALIDATE_NIM (1, obj); SCM_VALIDATE_NIM (1, obj);
scm_weak_table_putq_x (scm_source_whash, obj, scm_weak_table_putq_x (scm_source_whash, obj,
scm_make_srcprops (line, col, fname, scm_i_make_srcprops (line, col, fname, SCM_EOL));
SCM_COPY_SOURCE_P
? scm_copy_tree (obj)
: SCM_UNDEFINED,
SCM_EOL));
} }
#undef FUNC_NAME #undef FUNC_NAME
@ -265,11 +223,11 @@ SCM_DEFINE (scm_source_property, "source-property", 2, 0, 0,
if (!SRCPROPSP (p)) if (!SRCPROPSP (p))
goto alist; goto alist;
if (scm_is_eq (scm_sym_line, key)) if (scm_is_eq (scm_sym_line, key))
return scm_from_int (SRCPROPLINE (p)); return SRCPROPLINE (p);
else if (scm_is_eq (scm_sym_column, key)) else if (scm_is_eq (scm_sym_column, key))
return scm_from_int (SRCPROPCOL (p)); return SRCPROPCOL (p);
else if (scm_is_eq (scm_sym_copy, key)) else if (scm_is_eq (scm_sym_filename, key))
return SRCPROPCOPY (p); return SRCPROPFNAME (p);
else else
{ {
p = SRCPROPALIST (p); p = SRCPROPALIST (p);
@ -280,6 +238,8 @@ SCM_DEFINE (scm_source_property, "source-property", 2, 0, 0,
} }
#undef FUNC_NAME #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_DEFINE (scm_set_source_property_x, "set-source-property!", 3, 0, 0,
(SCM obj, SCM key, SCM datum), (SCM obj, SCM key, SCM datum),
"Set the source property of object @var{obj}, which is specified by\n" "Set the source property of object @var{obj}, which is specified by\n"
@ -289,34 +249,35 @@ SCM_DEFINE (scm_set_source_property_x, "set-source-property!", 3, 0, 0,
SCM p; SCM p;
SCM_VALIDATE_NIM (1, obj); SCM_VALIDATE_NIM (1, obj);
scm_i_pthread_mutex_lock (&scm_i_misc_mutex); scm_i_pthread_mutex_lock (&source_mutex);
p = scm_weak_table_refq (scm_source_whash, obj, SCM_EOL); p = scm_weak_table_refq (scm_source_whash, obj, SCM_EOL);
if (scm_is_eq (scm_sym_line, key)) if (scm_is_eq (scm_sym_line, key))
{ {
if (SRCPROPSP (p)) if (SRCPROPSP (p))
SETSRCPROPLINE (p, scm_to_int (datum)); SETSRCPROPLINE (p, datum);
else else
scm_weak_table_putq_x (scm_source_whash, obj, scm_weak_table_putq_x (scm_source_whash, obj,
scm_make_srcprops (scm_to_int (datum), 0, scm_i_make_srcprops (datum, SCM_INUM0,
SCM_UNDEFINED, SCM_UNDEFINED, p)); SCM_BOOL_F, p));
} }
else if (scm_is_eq (scm_sym_column, key)) else if (scm_is_eq (scm_sym_column, key))
{ {
if (SRCPROPSP (p)) if (SRCPROPSP (p))
SETSRCPROPCOL (p, scm_to_int (datum)); SETSRCPROPCOL (p, datum);
else else
scm_weak_table_putq_x (scm_source_whash, obj, scm_weak_table_putq_x (scm_source_whash, obj,
scm_make_srcprops (0, scm_to_int (datum), scm_i_make_srcprops (SCM_INUM0, datum,
SCM_UNDEFINED, SCM_UNDEFINED, p)); SCM_BOOL_F, p));
} }
else if (scm_is_eq (scm_sym_copy, key)) else if (scm_is_eq (scm_sym_filename, key))
{ {
if (SRCPROPSP (p)) if (SRCPROPSP (p))
SETSRCPROPCOPY (p, datum); SETSRCPROPFNAME (p, datum);
else else
scm_weak_table_putq_x (scm_source_whash, obj, scm_weak_table_putq_x (scm_source_whash, obj,
scm_make_srcprops (0, 0, SCM_UNDEFINED, datum, p)); scm_i_make_srcprops (SCM_INUM0, SCM_INUM0,
datum, p));
} }
else else
{ {
@ -326,7 +287,7 @@ SCM_DEFINE (scm_set_source_property_x, "set-source-property!", 3, 0, 0,
scm_weak_table_putq_x (scm_source_whash, obj, scm_weak_table_putq_x (scm_source_whash, obj,
scm_acons (key, datum, p)); scm_acons (key, datum, p));
} }
scm_i_pthread_mutex_unlock (&scm_i_misc_mutex); scm_i_pthread_mutex_unlock (&source_mutex);
return SCM_UNSPECIFIED; return SCM_UNSPECIFIED;
} }
@ -354,15 +315,12 @@ SCM_DEFINE (scm_cons_source, "cons-source", 3, 0, 0,
void void
scm_init_srcprop () scm_init_srcprop ()
{ {
scm_tc16_srcprops = scm_make_smob_type ("srcprops", 0); tc16_srcprops = scm_make_smob_type ("srcprops", 0);
scm_set_smob_print (scm_tc16_srcprops, srcprops_print); scm_set_smob_print (tc16_srcprops, srcprops_print);
scm_source_whash = scm_c_make_weak_table (0, SCM_WEAK_TABLE_KIND_KEY); scm_source_whash = scm_c_make_weak_table (0, SCM_WEAK_TABLE_KIND_KEY);
scm_c_define ("source-whash", scm_source_whash); scm_c_define ("source-whash", scm_source_whash);
scm_last_alist_filename = scm_cons (SCM_EOL,
scm_acons (SCM_EOL, SCM_EOL, SCM_EOL));
#include "srcprop.x" #include "srcprop.x"
} }

13
libguile/srcprop.h
View file

@ -1,7 +1,7 @@
#ifndef SCM_SRCPROP_H #ifndef SCM_SRCPROP_H
#define SCM_SRCPROP_H #define SCM_SRCPROP_H
/* Copyright 1995-1996,2000-2001,2006,2008-2012,2018 /* Copyright 1995-1996,2000-2001,2006,2008-2012,2018,2020
Free Software Foundation, Inc. Free Software Foundation, Inc.
This file is part of Guile. This file is part of Guile.
@ -28,27 +28,24 @@
/* {Source properties} /* {Source properties}
*/ */
#define SCM_PROCTRACEP(x) (scm_is_true (scm_procedure_property (x, scm_sym_trace)))
#define SCM_SOURCE_PROPERTY_FLAG_BREAK 1
SCM_API scm_t_bits scm_tc16_srcprops;
SCM_API SCM scm_sym_filename; SCM_API SCM scm_sym_filename;
SCM_API SCM scm_sym_copy;
SCM_API SCM scm_sym_line; SCM_API SCM scm_sym_line;
SCM_API SCM scm_sym_column; SCM_API SCM scm_sym_column;
SCM_API SCM scm_supports_source_properties_p (SCM obj); SCM_API SCM scm_supports_source_properties_p (SCM obj);
SCM_API SCM scm_make_srcprops (long line, int col, SCM fname, SCM copy, SCM plist);
SCM_API SCM scm_source_property (SCM obj, SCM key); 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_set_source_property_x (SCM obj, SCM key, SCM datum);
SCM_API SCM scm_source_properties (SCM obj); SCM_API SCM scm_source_properties (SCM obj);
SCM_API SCM scm_set_source_properties_x (SCM obj, SCM props); 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 int scm_i_has_source_properties (SCM obj);
SCM_INTERNAL void scm_i_set_source_properties_x (SCM obj, long line, int col, SCM_INTERNAL void scm_i_set_source_properties_x (SCM obj, SCM line, SCM col,
SCM fname); SCM fname);
SCM_API SCM scm_cons_source (SCM xorig, SCM x, SCM y); SCM_API SCM scm_cons_source (SCM xorig, SCM x, SCM y);
SCM_INTERNAL void scm_init_srcprop (void); SCM_INTERNAL void scm_init_srcprop (void);