From fbc0c5f3e63411714c2dd9620f7f130751d8eaef Mon Sep 17 00:00:00 2001
From: Kaz Kylheku <kaz@kylheku.com>
Date: Thu, 2 Apr 2020 06:25:02 -0700
Subject: New function: txr-parse.

txr-parse provides a way for Lisp code to programmatically
parse the TXR language and obtain the Lisp represenation.
This has hitherto not been available.

* eval.c (eval_init): Register txr-parse intrinsic.

* parser.c (txr_parse): New function.

* parser.h (txr_parse): Declared.
---
 eval.c   |  1 +
 parser.c | 41 +++++++++++++++++++++++++++++++++++++++++
 parser.h |  2 ++
 txr.1    | 50 ++++++++++++++++++++++++++++++++++++++++++++++++++
 4 files changed, 94 insertions(+)

diff --git a/eval.c b/eval.c
index 805805b3..d9dd0b3d 100644
--- a/eval.c
+++ b/eval.c
@@ -6623,6 +6623,7 @@ void eval_init(void)
   reg_fun(intern(lit("lisp-parse"), user_package), func_n5o(nread, 0));
   reg_fun(intern(lit("read"), user_package), func_n5o(nread, 0));
   reg_fun(intern(lit("iread"), user_package), func_n5o(iread, 0));
+  reg_fun(intern(lit("txr-parse"), user_package), func_n4o(txr_parse, 0));
   reg_fun(intern(lit("load"), user_package), func_n1(load));
   reg_var(load_path_s, nil);
   reg_symacro(intern(lit("self-load-path"), user_package), load_path_s);
diff --git a/parser.c b/parser.c
index 4da0b150..4979ad0d 100644
--- a/parser.c
+++ b/parser.c
@@ -783,6 +783,47 @@ val read_compiled_file(val self, val stream, val error_stream)
   return read_file_common(self, stream, error_stream, t);
 }
 
+val txr_parse(val source_in, val error_stream,
+              val error_return_val, val name_in)
+{
+  uses_or2;
+  val self = lit("txr-parse");
+  val source = default_null_arg(source_in);
+  val input_stream = if3(stringp(source),
+                         make_string_byte_input_stream(source),
+                         or2(source, std_input));
+  val name = or2(default_null_arg(name_in),
+                 if3(stringp(source),
+                     lit("string"),
+                     stream_get_prop(input_stream, name_k)));
+  int gc = gc_state(0);
+  val saved_dyn = dyn_env;
+  val parser_obj = ensure_parser(input_stream, name);
+  parser_t *pi = parser_get_impl(self, parser_obj);
+
+  dyn_env = make_env(nil, nil, dyn_env);
+  error_stream = default_null_arg(error_stream);
+  error_stream = if3(error_stream == t, std_output, or2(error_stream, std_null));
+  class_check (self, error_stream, stream_s);
+
+  parse_once(self, input_stream, name);
+
+  dyn_env = saved_dyn;
+  gc_state(gc);
+
+  if (pi->errors || pi->syntax_tree == nao) {
+    if (missingp(error_return_val))
+      uw_throwf(syntax_error_s, lit("~a: ~a: ~a"), self, name,
+                if3(pi->syntax_tree == nao,
+                    lit("end of input reached without seeing object"),
+                    lit("errors encountered")), nao);
+
+    return error_return_val;
+  }
+
+  return pi->syntax_tree;
+}
+
 #if HAVE_TERMIOS
 
 static void load_rcfile(val name)
diff --git a/parser.h b/parser.h
index 337dca9b..85bfca2f 100644
--- a/parser.h
+++ b/parser.h
@@ -123,6 +123,8 @@ val iread(val source_in, val error_stream, val error_return_val,
           val name_in, val lineno);
 val read_eval_stream(val self, val stream, val error_stream);
 val read_compiled_file(val self, val stream, val error_stream);
+val txr_parse(val source, val error_stream,
+              val error_return_val, val name_in);
 #if HAVE_TERMIOS
 val repl(val bindings, val in_stream, val out_stream, val env);
 #endif
diff --git a/txr.1 b/txr.1
index 72466bf5..36daace0 100644
--- a/txr.1
+++ b/txr.1
@@ -63810,6 +63810,56 @@ otherwise the forms are evaluated in order and the value of the last
 one specifies the result of
 .codn txr-case .
 
+.coNP Function @ txr-parse
+.synb
+.mets (txr-parse >> [ source >> [ error-stream
+.mets \ \ \ \ \ \ \ \ \ \ \  >> [ error-retval <> [ name ]]]])
+.syne
+.desc
+The
+.code txr-parse
+function converts textual \*(TX query syntax into a Lisp data
+structure representation.
+
+The
+.meta source
+argument may be either a character
+string, or a stream.  If it is omitted, then
+.code *stdin*
+is used as the stream.
+
+The
+.meta source
+must provide the text representation of one complete \*(TX query.
+
+The optional
+.meta error-stream
+argument can be used to specify a stream to which
+parse errors diagnostics are sent. If absent, the diagnostics are suppressed.
+
+The optional
+.meta name
+argument can be used to specify the file name which is used for reporting
+errors. If this argument is missing, the name is taken from the name
+property of the
+.meta source
+argument if it is a stream, or else the word
+.code string
+is used as the name if
+.meta source
+is a string.
+
+If there are no parse errors, the function returns the parsed data
+structure. If there are parse errors, and the
+.meta error-retval
+parameter is
+present, its value is returned. If the
+.meta error-retval
+parameter
+is not present, then an exception of type
+.code syntax-error
+is thrown.
+
 .SS* Debugging Functions
 .coNP Functions @ source-loc and @ source-loc-str
 .synb
-- 
cgit v1.2.3