From 50bdb7f059559f30346def9a7898360c6b69d6e9 Mon Sep 17 00:00:00 2001 From: Kaz Kylheku Date: Sun, 22 Dec 2019 22:47:49 -0800 Subject: New function: compile-update-file. The new function only compiles a file if the output file doesn't exist or is out of date. In addition, both compile-file now deletes the output file if compilation fails, and has a documented return value. * lisplib.c (compiler_set_entries): Add autoload entry fro compile-update-file. (open-compile-streams): Accepts a third argument: a function to test the input stream against the output path. The output file is opened, and the streams are returned, only if that test function returns true. Also, a third element is returned: the output path. This lets the caller to know what to delete, if the output file must be deleted. (compile-file-conditionally): New internal function, formed from compile-file. Takes an extra argument, the test function to pass to open-compile-streams. Compilation is skipped if open-compile-streams returns nil. Internals reshuffled a bit. If compilation doesn't set the success flag, then the with-resources logic now removes the output file in addition to closing the output stream. Prior to setting the success flag, we flush the output stream. * txr.1: Documented new function, all return values, and deletion of output file on unsuccessful compilation. --- lisplib.c | 3 +- share/txr/stdlib/compiler.tl | 130 ++++++++++++++++++++++++------------------- txr.1 | 33 ++++++++++- 3 files changed, 107 insertions(+), 59 deletions(-) diff --git a/lisplib.c b/lisplib.c index 78d6c024..d143ab2d 100644 --- a/lisplib.c +++ b/lisplib.c @@ -716,7 +716,8 @@ static val compiler_set_entries(val dlt, val fun) nil }; val name[] = { - lit("compile-toplevel"), lit("compile-file"), lit("compile"), + lit("compile-toplevel"), lit("compile"), lit("compile-file"), + lit("compile-update-file"), lit("with-compilation-unit"), lit("dump-compiled-objects"), nil }; diff --git a/share/txr/stdlib/compiler.tl b/share/txr/stdlib/compiler.tl index 82fe9638..58e8cd33 100644 --- a/share/txr/stdlib/compiler.tl +++ b/share/txr/stdlib/compiler.tl @@ -1650,7 +1650,7 @@ intern unintern rehome-sym use-sym unuse-sym)) -(defun open-compile-streams (in-path out-path) +(defun open-compile-streams (in-path out-path test-fn) (let* ((parent (or *load-path* "")) (sep [path-sep-chars 0]) (in-path (if (pure-rel-path-p in-path) @@ -1674,13 +1674,17 @@ (unless in-stream (error "~s: unable to open input file ~s" 'compile-file in-path)) + (unless [test-fn in-stream out-path] + (close-stream in-stream) + (return-from open-compile-streams nil)) + (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))) + (list in-stream out-stream out-path))) (defun list-from-vm-desc (vd) (list (sys:vm-desc-nlevels vd) @@ -1708,62 +1712,74 @@ [mapdo (op prinl @1 out-stream) out-forms] (delete-package *package*))) +(defun compile-file-conditionally (in-path out-path test-fn) + (whenlet ((success nil) + (streams (open-compile-streams in-path out-path test-fn))) + (with-resources ((in-stream (car streams) (close-stream in-stream)) + (out-stream (cadr streams) (progn + (close-stream out-stream) + (unless success + (remove-path (caddr streams)))))) + (let* ((err-ret (gensym)) + (*package* *package*) + (*emit* t) + (*eval* t) + (*load-path* (stream-get-prop (car streams) :name)) + (*rec-source-loc* t) + (out (new list-builder))) + (with-compilation-unit + (iflet ((line (get-line in-stream)) + ((starts-with "#!" line))) + (progn + (set line `@line `) + (upd line (regsub #/--lisp[^\-]/ (ret `--compiled@[@1 -1]`))) + (put-line (butlast line) out-stream)) + (seek-stream in-stream 0 :from-start)) + (labels ((compile-form (unex-form) + (let* ((form (macroexpand unex-form)) + (sym (if (consp form) (car form)))) + (caseq sym + (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)])) + (sys:load-time-lit + (if (cadr form) + (compile-form ^(quote ,(caddr form))) + (compile-form (caddr form)))) + (t (when (and (or *eval* *emit*) + (not (constantp form))) + (let* ((vm-desc (compile-toplevel form)) + (flat-vd (list-from-vm-desc vm-desc)) + (fence (member sym %package-manip%))) + (when *eval* + (let ((pa *package-alist*)) + (sys:vm-execute-toplevel vm-desc) + (when (neq pa *package-alist*) + (set fence t)))) + (when (and *emit* (consp form)) + out.(add flat-vd) + (when fence + out.(add :fence)))))))))) + (unwind-protect + (whilet ((obj (read in-stream *stderr* err-ret)) + ((neq obj err-ret))) + (compile-form obj)) + (dump-to-tlo out-stream out)) + + (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))))) + (flush-stream out-stream) + (set success t)))))) + (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* (stream-get-prop (car streams) :name)) - (*rec-source-loc* t)) - (with-compilation-unit - (with-resources ((in-stream (car streams) (close-stream in-stream)) - (out-stream (cadr streams) (close-stream out-stream)) - (out (new list-builder))) - (iflet ((line (get-line in-stream)) - ((starts-with "#!" line))) - (progn - (set line `@line `) - (upd line (regsub #/--lisp[^\-]/ (ret `--compiled@[@1 -1]`))) - (put-line (butlast line) out-stream)) - (seek-stream in-stream 0 :from-start)) - (labels ((compile-form (unex-form) - (let* ((form (macroexpand unex-form)) - (sym (if (consp form) (car form)))) - (caseq sym - (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)])) - (sys:load-time-lit - (if (cadr form) - (compile-form ^(quote ,(caddr form))) - (compile-form (caddr form)))) - (t (when (and (or *eval* *emit*) - (not (constantp form))) - (let* ((vm-desc (compile-toplevel form)) - (flat-vd (list-from-vm-desc vm-desc)) - (fence (member sym %package-manip%))) - (when *eval* - (let ((pa *package-alist*)) - (sys:vm-execute-toplevel vm-desc) - (when (neq pa *package-alist*) - (set fence t)))) - (when (and *emit* (consp form)) - out.(add flat-vd) - (when fence - out.(add :fence)))))))))) - (unwind-protect - (whilet ((obj (read in-stream *stderr* err-ret)) - ((neq obj err-ret))) - (compile-form obj)) - (dump-to-tlo out-stream out)) - - (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))))))))) + [compile-file-conditionally in-path out-path tf]) + +(defun usr:compile-update-file (in-path : out-path) + [compile-file-conditionally in-path out-path [mapf path-newer fstat identity]]) (defun usr:dump-compiled-objects (out-stream . compiled-objs) (symacrolet ((self 'dump-compiled-object)) diff --git a/txr.1 b/txr.1 index 4487cbf6..61801b87 100644 --- a/txr.1 +++ b/txr.1 @@ -69426,9 +69426,10 @@ In all cases, the return value of .code compile is the compiled function. -.coNP Function @ compile-file +.coNP Functions @ compile-file and @ compile-update-file .synb .mets (compile-file < input-path <> [ output-path ]) +.mets (compile-update-file < input-path <> [ output-path ]) .syne .desc The @@ -69521,6 +69522,36 @@ after the compilation completes. Compilation proceeds according to the File Compilation Model. +If the compilation process fails to produce a successful translation +for each form in the input file, the output file is removed. + +The +.code compile-update-file +function differs from +.code compile-file +in the following regard: compilation is performed only if the input +file is newer than the output file, or else if the output file doesn't +exist. + +The +.code compile-file +always returns +.code t +if it terminates normally, which occurs if it successfully translates +every form in the input file, depositing the translation into the output +file. If compilation fails, +.code compile-file +terminates by throwing an exception. + +The +.code compile-update-file +function returns +.code t +if it successfully compiles, similarly to +.codn compile-file . +If compilation is skipped, the function returns +.codn nil . + .coNP Macro @ with-compilation-unit .synb .mets (with-compilation-unit << form *) -- cgit v1.2.3