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.

1 files changed, 88 insertions, 12 deletions

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))))))))