summaryrefslogtreecommitdiff
path: root/libguile/syntax.c
diff options
context:
space:
mode:
Diffstat (limited to 'libguile/syntax.c')
-rw-r--r--libguile/syntax.c105
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