diff options
Diffstat (limited to 'libguile/syntax.c')
-rw-r--r-- | libguile/syntax.c | 105 |
1 files changed, 97 insertions, 8 deletions
diff --git a/libguile/syntax.c b/libguile/syntax.c index 2da4e395e..2f416d173 100644 --- a/libguile/syntax.c +++ b/libguile/syntax.c @@ -1,4 +1,4 @@ -/* Copyright 2017-2018 +/* Copyright 2017-2018,2021 Free Software Foundation, Inc. This file is part of Guile. @@ -24,19 +24,39 @@ # include <config.h> #endif +#include "alist.h" #include "eval.h" #include "gsubr.h" #include "keywords.h" #include "modules.h" +#include "pairs.h" #include "ports.h" +#include "srcprop.h" #include "threads.h" #include "variable.h" +#include "vectors.h" #include "syntax.h" +/* The source field was added to syntax objects in Guile 3.0.6. However + there can be older syntax objects present in compiled files that + don't have the source field. If a syntax object has a source field, + its tag will have HAS_SOURCE_WORD_FLAG set. */ +#define HAS_SOURCE_WORD_FLAG 0x100 + +enum +{ + TAG_WORD, + EXPR_WORD, + WRAP_WORD, + MODULE_WORD, + SOURCE_WORD, + WORD_COUNT +}; + static int scm_is_syntax (SCM x) { @@ -56,13 +76,46 @@ SCM_DEFINE (scm_syntax_p, "syntax?", 1, 0, 0, } #undef FUNC_NAME -SCM_DEFINE (scm_make_syntax, "make-syntax", 3, 0, 0, - (SCM exp, SCM wrap, SCM module), +static SCM +sourcev_to_props (SCM v) +{ + SCM props = scm_acons (scm_sym_line, scm_c_vector_ref (v, 1), + scm_acons (scm_sym_column, scm_c_vector_ref (v, 2), + SCM_EOL)); + if (scm_is_true (scm_c_vector_ref (v, 0))) + props = scm_acons (scm_sym_filename, scm_c_vector_ref (v, 0), props); + return props; +} + +static SCM +props_to_sourcev (SCM props) +{ + SCM v = scm_c_make_vector (3, SCM_BOOL_F); + scm_c_vector_set_x (v, 0, scm_assq_ref (props, scm_sym_filename)); + scm_c_vector_set_x (v, 1, scm_assq_ref (props, scm_sym_line)); + scm_c_vector_set_x (v, 2, scm_assq_ref (props, scm_sym_column)); + return v; +} + +SCM_DEFINE (scm_make_syntax, "make-syntax", 3, 1, 0, + (SCM exp, SCM wrap, SCM module, SCM source), "Make a new syntax object.") #define FUNC_NAME s_scm_make_syntax { - return scm_double_cell (scm_tc7_syntax, SCM_UNPACK (exp), - SCM_UNPACK (wrap), SCM_UNPACK (module)); + if (SCM_UNBNDP (source)) + source = scm_source_properties (exp); + if (scm_is_pair (source)) + source = props_to_sourcev (source); + if (!scm_is_vector (source)) + source = SCM_BOOL_F; + + SCM ret = scm_words (scm_tc7_syntax | HAS_SOURCE_WORD_FLAG, WORD_COUNT); + SCM_SET_CELL_OBJECT (ret, EXPR_WORD, exp); + SCM_SET_CELL_OBJECT (ret, WRAP_WORD, wrap); + SCM_SET_CELL_OBJECT (ret, MODULE_WORD, module); + SCM_SET_CELL_OBJECT (ret, SOURCE_WORD, source); + + return ret; } #undef FUNC_NAME @@ -72,7 +125,7 @@ SCM_DEFINE (scm_syntax_expression, "syntax-expression", 1, 0, 0, #define FUNC_NAME s_scm_syntax_expression { SCM_VALIDATE_SYNTAX (1, obj); - return SCM_CELL_OBJECT_1 (obj); + return SCM_CELL_OBJECT (obj, EXPR_WORD); } #undef FUNC_NAME @@ -82,7 +135,7 @@ SCM_DEFINE (scm_syntax_wrap, "syntax-wrap", 1, 0, 0, #define FUNC_NAME s_scm_syntax_wrap { SCM_VALIDATE_SYNTAX (1, obj); - return SCM_CELL_OBJECT_2 (obj); + return SCM_CELL_OBJECT (obj, WRAP_WORD); } #undef FUNC_NAME @@ -92,7 +145,43 @@ SCM_DEFINE (scm_syntax_module, "syntax-module", 1, 0, 0, #define FUNC_NAME s_scm_syntax_module { SCM_VALIDATE_SYNTAX (1, obj); - return SCM_CELL_OBJECT_3 (obj); + return SCM_CELL_OBJECT (obj, MODULE_WORD); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_syntax_source, "syntax-source", 1, 0, 0, + (SCM obj), + "Return the source properties for syntax object @var{obj}, as\n" + "an alist possibly containing the keys @code{filename},\n" + "@code{line}, and @code{column}. Return @code{#f} if no\n" + "source properties are available.") +#define FUNC_NAME s_scm_syntax_source +{ + SCM_VALIDATE_SYNTAX (1, obj); + if (!(SCM_CELL_WORD (obj, TAG_WORD) & HAS_SOURCE_WORD_FLAG)) + return SCM_BOOL_F; + SCM src = SCM_CELL_OBJECT (obj, SOURCE_WORD); + if (scm_is_vector (src)) + src = sourcev_to_props (src); + return src; +} +#undef FUNC_NAME + +SCM_DEFINE (scm_syntax_sourcev, "syntax-sourcev", 1, 0, 0, + (SCM obj), + "Return the source location information for syntax object\n" + "@var{obj}, as a vector of @code{#(@var{filename} @var{line}\n" + "@var{column})}, or @code{#f} if no source properties are\n" + "available.") +#define FUNC_NAME s_scm_syntax_sourcev +{ + SCM_VALIDATE_SYNTAX (1, obj); + if (!(SCM_CELL_WORD (obj, TAG_WORD) & HAS_SOURCE_WORD_FLAG)) + return SCM_BOOL_F; + SCM src = SCM_CELL_OBJECT (obj, SOURCE_WORD); + if (scm_is_null (src) || scm_is_pair (src)) + src = props_to_sourcev (src); + return src; } #undef FUNC_NAME |