diff options
| -rw-r--r-- | lisplib.c | 2 | ||||
| -rw-r--r-- | parser.c | 3 | ||||
| -rw-r--r-- | share/txr/stdlib/compiler.tl | 100 | ||||
| -rw-r--r-- | vm.c | 14 |
4 files changed, 106 insertions, 13 deletions
@@ -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 }; @@ -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)))))))) @@ -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)); |