compiler: first cut compile-file implementation.

* lisplib.c (compiler_set_entries): Autoload on compile-file.

* parser.c (parse_init): Expose get-parser, parser-errors and
parser-eof intrinsics in system package.

* share/txr/stdlib/compiler.tl (compiler): Wrap defstruct form
in compile-only. What this means is that when we invoke
comile-file on compiler.tl, the compiler will only compile
this defstruct and not evaluate it. I.e. it will not try to
redefine the structure. Redefining the core structure of the
compiler while it is compiling itself wreaks havoc on the
compilation.
(%fille-suff-rx%, *emit*, *eval*): New variables.
(open-compile-streams, list-from-vm-desc, usr:compile-file):
New functions.

* vm.c (vm_desc_nlevels, vm_desc_nregs): New static functions.
(vm_init): Register new intrinsics vm-desc-nlevels and
vn-desc-nregs in system package.

4 files changed, 106 insertions, 13 deletions

diff --git a/lisplib.c b/lisplib.c
index a7250185..47213227 100644
--- a/lisplib.c
+++ b/lisplib.c
@@ -658,7 +658,7 @@ static val compiler_set_entries(val dlt, val fun)
     nil
   };
   val name[] = {
-    lit("compile-toplevel"),
+    lit("compile-toplevel"), lit("compile-file"),
     nil
   };
 
diff --git a/parser.c b/parser.c
index cbd2f4fe..0d0151d5 100644
--- a/parser.c
+++ b/parser.c
@@ -1386,4 +1386,7 @@ void parse_init(void)
   reg_var(listener_greedy_eval_s, nil);
   reg_var(rec_source_loc_s, nil);
   reg_fun(circref_s, func_n1(circref));
+  reg_fun(intern(lit("get-parser"), system_package), func_n1(get_parser));
+  reg_fun(intern(lit("parser-errors"), system_package), func_n1(parser_errors));
+  reg_fun(intern(lit("parser-eof"), system_package), func_n1(parser_eof));
 }
diff --git a/share/txr/stdlib/compiler.tl b/share/txr/stdlib/compiler.tl
index 4fdd76ca..aafbf5f0 100644
--- a/share/txr/stdlib/compiler.tl
+++ b/share/txr/stdlib/compiler.tl
@@ -105,18 +105,19 @@
       (let ((lev (ssucc (cadr reg))))
         (< me.lev lev)))))
 
-(defstruct compiler nil
-  (treg-cntr 1)
-  (dreg-cntr 0)
-  (fidx-cntr 0)
-  (nlev 2)
-  (nreg 1)
-  (tregs nil)
-  (dreg (hash :eql-based))
-  (data (hash :eql-based))
-  (fidx (hash :eql-based))
-  (ftab (hash :eql-based))
-  last-form)
+(compile-only
+  (defstruct compiler nil
+    (treg-cntr 1)
+    (dreg-cntr 0)
+    (fidx-cntr 0)
+    (nlev 2)
+    (nreg 1)
+    (tregs nil)
+    (dreg (hash :eql-based))
+    (data (hash :eql-based))
+    (fidx (hash :eql-based))
+    (ftab (hash :eql-based))
+    last-form))
 
 (defvarl %gcall-op% (relate '(apply usr:apply call) '(gapply gapply gcall)))
 
@@ -1309,3 +1310,78 @@
       co.(check-treg-leak)
       as.(asm ^(,*frag.code (end ,frag.oreg)))
       (vm-make-desc co.nlev co.treg-cntr as.buf co.(get-datavec) co.(get-funvec)))))
+
+(defvarl %file-suff-rx% #/[.][^\\\/.]+/)
+
+(defvar *emit*)
+
+(defvar *eval*)
+
+(defun open-compile-streams (in-path out-path)
+  (let* ((rsuff (r$ %file-suff-rx% in-path))
+         (suff (if rsuff [in-path rsuff]))
+         (ip-nosuff (if rsuff [in-path 0..(from rsuff)] in-path))
+         in-stream out-stream)
+    (cond
+      ((equal suff ".txr")
+       (error "~s: cannot compile TXR files" 'compile-file))
+      ((null suff)
+       (set in-stream (or (ignerr (open-file ip-nosuff))
+                          (ignerr (open-file `@{ip-nosuff}.tl`)))))
+      (t
+       (set in-stream (ignerr (open-file in-path)))))
+
+    (unless in-stream
+      (error "~s: unable to open input file ~s" 'compile-file in-path))
+
+    (unless out-path
+      (set out-path `@{ip-nosuff}.tlo`))
+
+    (set out-stream (ignerr (open-file out-path "w")))
+
+    (unless out-stream
+      (close-stream in-stream)
+      (error "~s: unable to open output file ~s" 'compile-file in-stream))
+
+    (list in-stream out-stream)))
+
+(defun list-from-vm-desc (vd)
+  (list (sys:vm-desc-nlevels vd)
+        (sys:vm-desc-nregs vd)
+        (sys:vm-desc-bytecode vd)
+        (sys:vm-desc-datavec vd)
+        (sys:vm-desc-funvec vd)))
+
+(defun usr:compile-file (in-path : out-path)
+  (let ((streams (open-compile-streams in-path out-path))
+        (err-ret (gensym))
+        (*package* *package*)
+        (*emit* t)
+        (*eval* t)
+        (*load-path* in-path)
+        (sys:*load-recursive* t))
+    (with-resources ((in-stream (car streams) (close-stream in-stream))
+                     (out-stream (cadr streams) (close-stream out-stream)))
+      (labels ((compile-form (form)
+                 (unless (atom form)
+                   (caseq (car form)
+                     (progn [mapdo compile-form (cdr form)])
+                     (compile-only (let ((*eval* nil))
+                                     [mapdo compile-form (cdr form)]))
+                     (eval-only (let ((*emit* nil))
+                                  [mapdo compile-form (cdr form)]))
+                     (t (when (or *eval* *emit*)
+                          (let* ((vm-desc (compile-toplevel form))
+                                 (flat-vd (list-from-vm-desc vm-desc)))
+                            (when *eval*
+                              (sys:vm-execute-toplevel vm-desc))
+                            (when *emit*
+                              (let ((*print-circle* t))
+                                (prinl flat-vd out-stream))))))))))
+        (whilet ((obj (read in-stream *stderr* err-ret))
+                 ((neq obj err-ret)))
+          (compile-form (sys:expand* obj)))
+        (let ((parser (sys:get-parser in-stream)))
+          (when (> (sys:parser-errors parser) 0)
+            (error "~s: compilation of ~s failed" 'compile-file
+                   (stream-get-prop in-stream :name))))))))
diff --git a/vm.c b/vm.c
index 4d041fce..bb88ef8f 100644
--- a/vm.c
+++ b/vm.c
@@ -171,6 +171,18 @@ val vm_make_desc(val nlevels, val nregs, val bytecode,
   }
 }
 
+static val vm_desc_nlevels(val desc)
+{
+  struct vm_desc *vd = vm_desc_struct(desc);
+  return num(vd->nlvl);
+}
+
+static val vm_desc_nregs(val desc)
+{
+  struct vm_desc *vd = vm_desc_struct(desc);
+  return num(vd->nreg);
+}
+
 static val vm_desc_bytecode(val desc)
 {
   struct vm_desc *vd = vm_desc_struct(desc);
@@ -1050,6 +1062,8 @@ void vm_init(void)
   vm_desc_s = intern(lit("vm-desc"), system_package);
   vm_closure_s = intern(lit("vm-closure"), system_package);
   reg_fun(intern(lit("vm-make-desc"), system_package), func_n5(vm_make_desc));
+  reg_fun(intern(lit("vm-desc-nlevels"), system_package), func_n1(vm_desc_nlevels));
+  reg_fun(intern(lit("vm-desc-nregs"), system_package), func_n1(vm_desc_nregs));
   reg_fun(intern(lit("vm-desc-bytecode"), system_package), func_n1(vm_desc_bytecode));
   reg_fun(intern(lit("vm-desc-datavec"), system_package), func_n1(vm_desc_datavec));
   reg_fun(intern(lit("vm-desc-funvec"), system_package), func_n1(vm_desc_funvec));