From 274cb70971d6a2cebcd887350b4b8602b32743d7 Mon Sep 17 00:00:00 2001
From: Kaz Kylheku <kaz@kylheku.com>
Date: Wed, 4 Apr 2018 20:01:02 -0700
Subject: Implement compiled file loading.

* eval.c (load): If open_txr_file indicates compiled file by
setting txr_lisp_p to character #\o, use read_compiled_file.

* match.c (v_load): Likewise.

* parser.c (open_txr_file): Recognize the .tlo suffix, and
also try to open a .tlo version of an unsuffixed file before
trying it as .tl. Indicate a .tlo file by setting txr_lisp_p
to the character #\o rather than t.
(read_file_common): New static function, made from contents of
read_eval_stream. Will either evaluate forms or load compiled
code by instantiating virtual machine descriptions and
performing their top-level execution.
(read_eval_stream): Now a wrapper for read_file_common.
(read_compiled_file): New function.

* parser.h (read_compiled_file): Declared.

* txr.c (help): List new --compiled option.
(txr_main): If --compiled is specified, set txr_lisp_p to #\o
to load as compiled code. Update error message that -c is
not compatible with --lisp or --compiled.
If txr_lisp_p is #\o, then use read_compiled_file.
---
 eval.c   |  8 +++++++-
 match.c  |  6 +++++-
 parser.c | 48 +++++++++++++++++++++++++++++++++++++++++-------
 parser.h |  1 +
 txr.c    | 12 ++++++++++--
 5 files changed, 64 insertions(+), 11 deletions(-)

diff --git a/eval.c b/eval.c
index e16e8075..152006f3 100644
--- a/eval.c
+++ b/eval.c
@@ -4157,11 +4157,17 @@ val load(val target)
   env_vbind(dyn_env, load_recursive_s, t);
   env_vbind(dyn_env, package_s, cur_package);
 
-  if (txr_lisp_p) {
+  if (txr_lisp_p == t) {
     if (!read_eval_stream(stream, std_error)) {
       close_stream(stream, nil);
       uw_throwf(error_s, lit("load: ~a contains errors"), path, nao);
     }
+  } else if (txr_lisp_p == chr('o')) {
+    if (!read_compiled_file(stream, std_error)) {
+      close_stream(stream, nil);
+      uw_throwf(error_s, lit("load: unable to load compiled file ~a"),
+                path, nao);
+    }
   } else {
     int gc = gc_state(0);
     parser_t parser;
diff --git a/match.c b/match.c
index 10fd1770..15bb7e79 100644
--- a/match.c
+++ b/match.c
@@ -4310,7 +4310,11 @@ static val v_load(match_files_ctx *c)
     } else {
       uw_set_match_context(cons(c->spec, c->bindings));
 
-      if (!read_eval_stream(stream, std_error)){
+      if (txr_lisp_p == chr('o') && !read_compiled_file(stream, std_error)) {
+        close_stream(stream, nil);
+        uw_throwf(error_s, lit("load: unable to load compiled file ~a"),
+                  path, nao);
+      } else if (!read_eval_stream(stream, std_error)) {
         close_stream(stream, nil);
         sem_error(specline, lit("load: ~a contains errors"), path, nao);
       }
diff --git a/parser.c b/parser.c
index 0d0151d5..a5109a18 100644
--- a/parser.c
+++ b/parser.c
@@ -55,6 +55,7 @@
 #include "cadr.h"
 #include "struct.h"
 #include "parser.h"
+#include "vm.h"
 #include "txr.h"
 #if HAVE_TERMIOS
 #include "linenoise/linenoise.h"
@@ -411,12 +412,14 @@ val parser_circ_ref(parser_t *p, val num)
 
 void open_txr_file(val spec_file, val *txr_lisp_p, val *name, val *stream)
 {
-  enum { none, tl, txr } suffix;
+  enum { none, tl, tlo, txr } suffix;
 
   if (match_str(spec_file, lit(".txr"), negone))
     suffix = txr;
   else if (match_str(spec_file, lit(".tl"), negone))
     suffix = tl;
+  else if (match_str(spec_file, lit(".tlo"), negone))
+    suffix = tlo;
   else
     suffix = none;
 
@@ -431,6 +434,9 @@ void open_txr_file(val spec_file, val *txr_lisp_p, val *name, val *stream)
       case tl:
         *txr_lisp_p = t;
         break;
+      case tlo:
+        *txr_lisp_p = chr('o');
+        break;
       case txr:
         *txr_lisp_p = nil;
         break;
@@ -456,10 +462,17 @@ void open_txr_file(val spec_file, val *txr_lisp_p, val *name, val *stream)
     }
 
 
-    if (suffix == none && in == 0) {
-      spec_file_try = scat(lit("."), spec_file, lit("tl"), nao);
-      in = w_fopen(c_str(spec_file_try), L"r");
-      *txr_lisp_p = t;
+    if (suffix == none) {
+      if (in == 0) {
+        spec_file_try = scat(lit("."), spec_file, lit("tlo"), nao);
+        in = w_fopen(c_str(spec_file_try), L"r");
+        *txr_lisp_p = chr('o');
+      }
+      if (in == 0) {
+        spec_file_try = scat(lit("."), spec_file, lit("tl"), nao);
+        in = w_fopen(c_str(spec_file_try), L"r");
+        *txr_lisp_p = t;
+      }
     }
 
     if (in == 0) {
@@ -592,7 +605,7 @@ val iread(val source_in, val error_stream, val error_return_val,
                          name_in, lineno);
 }
 
-val read_eval_stream(val stream, val error_stream)
+static val read_file_common(val stream, val error_stream, val compiled)
 {
   val error_val = gensym(nil);
   val name = stream_get_prop(stream, name_k);
@@ -609,7 +622,18 @@ val read_eval_stream(val stream, val error_stream)
       continue;
     }
 
-    (void) eval_intrinsic(form, nil);
+    if (compiled) {
+      val nlevels = pop(&form);
+      val nregs = pop(&form);
+      val bytecode = pop(&form);
+      val dv_raw = pop(&form);
+      val datavec = if3(consp(dv_raw), vec_list(cadr(dv_raw)), dv_raw);
+      val funvec = car(form);
+      val desc = vm_make_desc(nlevels, nregs, bytecode, datavec, funvec);
+      (void) vm_execute_toplevel(desc);
+    } else {
+      (void) eval_intrinsic(form, nil);
+    }
 
     if (parser_eof(parser))
       break;
@@ -618,6 +642,16 @@ val read_eval_stream(val stream, val error_stream)
   return t;
 }
 
+val read_eval_stream(val stream, val error_stream)
+{
+  return read_file_common(stream, error_stream, nil);
+}
+
+val read_compiled_file(val stream, val error_stream)
+{
+  return read_file_common(stream, error_stream, t);
+}
+
 #if HAVE_TERMIOS
 
 static void load_rcfile(val name)
diff --git a/parser.h b/parser.h
index 33b22d00..12378631 100644
--- a/parser.h
+++ b/parser.h
@@ -121,6 +121,7 @@ val nread(val source_in, val error_stream, val error_return_val,
 val iread(val source_in, val error_stream, val error_return_val,
           val name_in, val lineno);
 val read_eval_stream(val stream, val error_stream);
+val read_compiled_file(val stream, val error_stream);
 #if HAVE_TERMIOS
 val repl(val bindings, val in_stream, val out_stream);
 #endif
diff --git a/txr.c b/txr.c
index 30f5c8ae..14cc6642 100644
--- a/txr.c
+++ b/txr.c
@@ -139,6 +139,7 @@ static void help(void)
 "                       Use of txr implies agreement with the disclaimer\n"
 "                       section at the bottom of the license.\n"
 "--lisp                 Treat unsuffixed query files as TXR Lisp.\n"
+"--compiled             Treat unsuffixed query files as compiled TXR Lisp.\n"
 "--lisp-bindings        Synonym for -l\n"
 "--debugger             Synonym for -d\n"
 "--noninteractive       Synonym for -n\n"
@@ -677,6 +678,9 @@ int txr_main(int argc, char **argv)
       } else if (equal(opt, lit("lisp"))) {
         txr_lisp_p = t;
         continue;
+      } else if (equal(opt, lit("compiled"))) {
+        txr_lisp_p = chr('o');
+        continue;
 #if HAVE_FORK_STUFF
       } else if (equal(opt, lit("reexec"))) {
         exec_wrap(prog_path, arg_list);
@@ -787,7 +791,7 @@ int txr_main(int argc, char **argv)
       case 'c':
         if (txr_lisp_p) {
           format(std_error,
-                 lit("~a: -c not compatible with --lisp; use -e\n"),
+                 lit("~a: -c not compatible with --lisp or --compiled; use -e\n"),
                  prog_string, nao);
           return EXIT_FAILURE;
         }
@@ -1036,7 +1040,11 @@ int txr_main(int argc, char **argv)
     reg_varl(car(binding), cdr(binding));
   }
 
-  {
+  if (txr_lisp_p == chr('o')) {
+    val result = read_compiled_file(parse_stream, std_error);
+    if (!enter_repl)
+      return result ? 0 : EXIT_FAILURE;
+  } else {
     val result = read_eval_stream_noerr(parse_stream, spec_file_str,
                                         std_error);
 
-- 
cgit v1.2.3