From 07f63cf4f3282234fae83f9e9690e87e3b2d9ed4 Mon Sep 17 00:00:00 2001
From: Andy Wingo <wingo@pobox.com>
Date: Thu, 25 Feb 2021 15:15:03 +0100
Subject: [PATCH] Add syntax-sourcev

* libguile/syntax.c (sourcev_to_props, props_to_sourcev)
(scm_syntax_source, scm_syntax_sourcev): Add alternate source
representation for syntax objects.
---
 libguile/syntax.c | 55 ++++++++++++++++++++++++++++++++++++++++++++---
 libguile/syntax.h |  1 +
 2 files changed, 53 insertions(+), 3 deletions(-)

diff --git a/libguile/syntax.c b/libguile/syntax.c
index 649e36449..2f416d173 100644
--- a/libguile/syntax.c
+++ b/libguile/syntax.c
@@ -24,6 +24,7 @@
 # include <config.h>
 #endif
 
+#include "alist.h"
 #include "eval.h"
 #include "gsubr.h"
 #include "keywords.h"
@@ -33,6 +34,7 @@
 #include "srcprop.h"
 #include "threads.h"
 #include "variable.h"
+#include "vectors.h"
 
 #include "syntax.h"
 
@@ -74,6 +76,27 @@ SCM_DEFINE (scm_syntax_p, "syntax?", 1, 0, 0,
 }
 #undef FUNC_NAME
 
+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.")
@@ -81,7 +104,9 @@ SCM_DEFINE (scm_make_syntax, "make-syntax", 3, 1, 0,
 {
   if (SCM_UNBNDP (source))
     source = scm_source_properties (exp);
-  if (!scm_is_pair (source))
+  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);
@@ -126,13 +151,37 @@ SCM_DEFINE (scm_syntax_module, "syntax-module", 1, 0, 0,
 
 SCM_DEFINE (scm_syntax_source, "syntax-source", 1, 0, 0,
 	    (SCM obj),
-	    "Return the source location information for syntax object @var{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;
-  return SCM_CELL_OBJECT (obj, SOURCE_WORD);
+  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
 
diff --git a/libguile/syntax.h b/libguile/syntax.h
index 8a98c1db4..d860a355e 100644
--- a/libguile/syntax.h
+++ b/libguile/syntax.h
@@ -28,6 +28,7 @@ SCM_INTERNAL SCM scm_syntax_expression (SCM obj);
 SCM_INTERNAL SCM scm_syntax_wrap (SCM obj);
 SCM_INTERNAL SCM scm_syntax_module (SCM obj);
 SCM_INTERNAL SCM scm_syntax_source (SCM obj);
+SCM_INTERNAL SCM scm_syntax_sourcev (SCM obj);
 
 SCM_INTERNAL void scm_i_syntax_print (SCM obj, SCM port,
                                       scm_print_state *pstate);