;;; compile-file.lisp ;;; ;;; Copyright (C) 2004-2006 Peter Graves ;;; $Id$ ;;; ;;; This program is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU General Public License ;;; as published by the Free Software Foundation; either version 2 ;;; of the License, or (at your option) any later version. ;;; ;;; This program is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; You should have received a copy of the GNU General Public License ;;; along with this program; if not, write to the Free Software ;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. ;;; ;;; As a special exception, the copyright holders of this library give you ;;; permission to link this library with independent modules to produce an ;;; executable, regardless of the license terms of these independent ;;; modules, and to copy and distribute the resulting executable under ;;; terms of your choice, provided that you also meet, for each linked ;;; independent module, the terms and conditions of the license of that ;;; module. An independent module is a module which is not derived from ;;; or based on this library. If you modify this library, you may extend ;;; this exception to your version of the library, but you are not ;;; obligated to do so. If you do not wish to do so, delete this ;;; exception statement from your version. (in-package #:system) (require "COMPILER-PASS2") (export 'compile-file-if-needed) (defvar *fbound-names*) (defvar *class-number*) (defvar *output-file-pathname*) (defvar *toplevel-functions*) (defvar *toplevel-macros*) (defvar *toplevel-exports*) (defvar *toplevel-setf-expanders*) (defvar *toplevel-setf-functions*) (defun base-classname (&optional (output-file-pathname *output-file-pathname*)) (sanitize-class-name (pathname-name output-file-pathname))) (defun fasl-loader-classname (&optional (output-file-pathname *output-file-pathname*)) (%format nil "~A_0" (base-classname output-file-pathname))) (declaim (ftype (function (t) t) compute-classfile)) (defun compute-classfile (n &optional (output-file-pathname *output-file-pathname*)) "Computes the pathname of the class file associated with number `n'." (let ((name (sanitize-class-name (%format nil "~A_~D" (pathname-name output-file-pathname) n)))) (merge-pathnames (make-pathname :name name :type *compile-file-class-extension*) output-file-pathname))) (defun sanitize-class-name (name) (let ((name (copy-seq name))) (dotimes (i (length name)) (declare (type fixnum i)) (when (or (char= (char name i) #\-) (char= (char name i) #\.) (char= (char name i) #\Space)) (setf (char name i) #\_))) name)) (declaim (ftype (function () t) next-classfile)) (defun next-classfile () (compute-classfile (incf *class-number*))) (defmacro report-error (&rest forms) `(handler-case (progn ,@forms) (compiler-unsupported-feature-error (condition) (fresh-line) (%format t "; UNSUPPORTED-FEATURE: ~A~%" condition) (values nil condition)))) ;; Dummy function. Should never be called. (defun dummy (&rest ignored) (declare (ignore ignored)) (assert nil)) ;;; ??? rename to something shorter? (defparameter *compiler-diagnostic* nil "The stream to emit compiler diagnostic messages to, or nil to muffle output.") (export '*compiler-diagnostic*) (defmacro diag (fmt &rest args) `(format *compiler-diagnostic* "~&SYSTEM::*COMPILER-DIAGNOSTIC* ~A~&" (format nil ,fmt ,@args))) (declaim (ftype (function (t) t) verify-load)) (defun verify-load (classfile &key (force nil)) "Return whether the file at the path denoted by CLASSFILE is a loadable JVM artifact." (declare (ignore force)) (unless classfile (diag "Nil classfile argument passed to verify-load.") (return-from verify-load nil)) (with-open-file (cf classfile :direction :input) (when (= 0 (file-length cf)) ;;; TODO hook into a real ABCL compiler condition hierarchy (diag "Internal compiler error detected: Fasl contains ~ zero-length jvm classfile corresponding to ~A." classfile) (return-from verify-load nil))) ;; ### FIXME ;; The section below can't work, because we have ;; circular references between classes of outer- and innerscoped ;; functions. We need the class loader to resolve these circular ;; references for us. Our FASL class loader does exactly that, ;; so we need a class loader here which knows how to find ;; all the .cls files related to the current scope being loaded. #+nil (when (or force (> *safety* *speed*)) (diag "Testing compiled bytecode by loading classfile into JVM.") (let ((*load-truename* *output-file-pathname*)) ;; load-compiled-function used to be wrapped via report-error (return-from verify-load (load-compiled-function classfile)))) t) (declaim (ftype (function (t) t) note-toplevel-form)) (defun note-toplevel-form (form) (when *compile-print* (fresh-line) (princ "; ") (let ((*print-length* 2) (*print-level* 2) (*print-pretty* nil)) (prin1 form)) (terpri))) (defun output-form (form) (if *binary-fasls* (push form *forms-for-output*) (progn (dump-form form *fasl-stream*) (%stream-terpri *fasl-stream*)))) (defun finalize-fasl-output () (when *binary-fasls* (let ((*package* (find-package :keyword)) (*double-colon-package-separators* T)) (dump-form (convert-toplevel-form (list* 'PROGN (nreverse *forms-for-output*)) t) *fasl-stream*)) (%stream-terpri *fasl-stream*))) (declaim (ftype (function (t) t) simple-toplevel-form-p)) (defun simple-toplevel-form-p (form) "Returns NIL if the form is too complex to become an interpreted toplevel form, non-NIL if it is 'simple enough'." (and (consp form) (every #'(lambda (arg) (or (and (atom arg) (not (and (symbolp arg) (symbol-macro-p arg)))) (and (consp arg) (eq 'QUOTE (car arg))))) (cdr form)))) (declaim (ftype (function (t t) t) convert-toplevel-form)) (defun convert-toplevel-form (form declare-inline) (when (or (simple-toplevel-form-p form) (and (eq (car form) 'SETQ) ;; for SETQ, look at the evaluated part (simple-toplevel-form-p (third form)))) ;; single form with simple or constant arguments ;; Without this exception, toplevel function calls ;; will be compiled into lambdas which get compiled to ;; compiled-functions. Those need to be loaded. ;; Conclusion: Top level interpreting the function call ;; and its arguments may be (and should be) more efficient. (return-from convert-toplevel-form (precompiler:precompile-form form nil *compile-file-environment*))) (let* ((toplevel-form (third form)) (expr `(lambda () ,form)) (saved-class-number *class-number*) (classfile (next-classfile)) (result (with-open-file (f classfile :direction :output :element-type '(unsigned-byte 8) :if-exists :supersede) (report-error (jvm:compile-defun nil expr *compile-file-environment* classfile f declare-inline)))) (compiled-function (verify-load classfile))) (declare (ignore toplevel-form result)) (progn #+nil (when (> *debug* 0) ;; TODO (annotate form toplevel-form classfile compiled-function fasl-class-number) ;;; ??? define an API by perhaps exporting these symbols? (setf (getf form 'form-source) toplevel-form (getf form 'classfile) classfile (getf form 'compiled-function) compiled-function (getf form 'class-number) saved-class-number)) (setf form (if compiled-function `(funcall (sys::get-fasl-function *fasl-loader* ,saved-class-number)) (precompiler:precompile-form form nil *compile-file-environment*)))))) (declaim (ftype (function (t stream t) t) process-progn)) (defun process-progn (forms stream compile-time-too) (dolist (form forms) (process-toplevel-form form stream compile-time-too)) nil) (declaim (ftype (function (t t t) t) process-toplevel-form)) (defun precompile-toplevel-form (form stream compile-time-too) (declare (ignore stream)) (let ((form (precompiler:precompile-form form nil *compile-file-environment*))) (when compile-time-too (eval form)) form)) (defun process-toplevel-macrolet (form stream compile-time-too) (let ((*compile-file-environment* (make-environment *compile-file-environment*))) (dolist (definition (cadr form)) (environment-add-macro-definition *compile-file-environment* (car definition) (make-macro (car definition) (make-macro-expander definition)))) (dolist (body-form (cddr form)) (process-toplevel-form body-form stream compile-time-too))) nil) (declaim (ftype (function (t t t) t) process-toplevel-defconstant)) (defun process-toplevel-defconstant (form stream compile-time-too) (declare (ignore stream compile-time-too)) ;; "If a DEFCONSTANT form appears as a top level form, the compiler ;; must recognize that [the] name names a constant variable. An ;; implementation may choose to evaluate the value-form at compile ;; time, load time, or both. Therefore, users must ensure that the ;; initial-value can be evaluated at compile time (regardless of ;; whether or not references to name appear in the file) and that ;; it always evaluates to the same value." (note-toplevel-form form) (eval form) form) (declaim (ftype (function (t t t) t) process-toplevel-quote)) (defun process-toplevel-quote (form stream compile-time-too) (declare (ignore stream)) (when compile-time-too (eval form)) nil) (declaim (ftype (function (t t t) t) process-toplevel-import)) (defun process-toplevel-import (form stream compile-time-too) (declare (ignore stream)) (let ((form (precompiler:precompile-form form nil *compile-file-environment*))) (let ((*package* +keyword-package+)) (output-form form)) (when compile-time-too (eval form))) nil) (declaim (ftype (function (t t t) t) process-toplevel-export)) (defun process-toplevel-export (form stream compile-time-too) (when (and (listp (second form)) (eq (car (second form)) 'QUOTE)) ;; constant export list (let ((sym-or-syms (second (second form)))) (setf *toplevel-exports* (append *toplevel-exports* (if (listp sym-or-syms) sym-or-syms (list sym-or-syms)))))) (precompile-toplevel-form form stream compile-time-too)) (declaim (ftype (function (t t t) t) process-toplevel-mop.ensure-method)) (defun process-toplevel-mop.ensure-method (form stream compile-time-too) (declare (ignore stream)) (flet ((convert-ensure-method (form key) (let* ((tail (cddr form)) (function-form (getf tail key))) (when (and function-form (consp function-form) (eq (%car function-form) 'FUNCTION)) (let ((lambda-expression (cadr function-form))) (jvm::with-saved-compiler-policy (let* ((saved-class-number *class-number*) (classfile (next-classfile)) (result (with-open-file (f classfile :direction :output :element-type '(unsigned-byte 8) :if-exists :supersede) (report-error (jvm:compile-defun nil lambda-expression *compile-file-environment* classfile f nil)))) (compiled-function (verify-load classfile))) (declare (ignore result)) (cond (compiled-function (setf (getf tail key) `(sys::get-fasl-function *fasl-loader* ,saved-class-number))) (t ;; FIXME This should be a warning or error of some sort... (format *error-output* "; Unable to compile method~%")))))))))) (when compile-time-too (let* ((copy-form (copy-tree form)) ;; ### Ideally, the precompiler would leave the forms alone ;; and copy them where required, instead of forcing us to ;; do a deep copy in advance (precompiled-form (precompiler:precompile-form copy-form nil *compile-file-environment*))) (eval precompiled-form))) (convert-ensure-method form :function) (convert-ensure-method form :fast-function)) (precompiler:precompile-form form nil *compile-file-environment*)) (declaim (ftype (function (t t t) t) process-toplevel-defvar/defparameter)) (defun process-toplevel-defvar/defparameter (form stream compile-time-too) (declare (ignore stream)) (note-toplevel-form form) (if compile-time-too (eval form) ;; "If a DEFVAR or DEFPARAMETER form appears as a top level form, ;; the compiler must recognize that the name has been proclaimed ;; special. However, it must neither evaluate the initial-value ;; form nor assign the dynamic variable named NAME at compile ;; time." (let ((name (second form))) (%defvar name))) form) (declaim (ftype (function (t t t) t) process-toplevel-defpackage/in-package)) (defun process-toplevel-defpackage/in-package (form stream compile-time-too) (declare (ignore stream compile-time-too)) (note-toplevel-form form) (setf form (precompiler:precompile-form form nil *compile-file-environment*)) (eval form) ;; Force package prefix to be used when dumping form. (let ((*package* +keyword-package+)) (output-form form)) nil) (declaim (ftype (function (t t t) t) process-toplevel-declare)) (defun process-toplevel-declare (form stream compile-time-too) (declare (ignore stream compile-time-too)) (compiler-style-warn "Misplaced declaration: ~S" form) nil) (declaim (ftype (function (t t t) t) process-toplevel-progn)) (defun process-toplevel-progn (form stream compile-time-too) (process-progn (cdr form) stream compile-time-too) nil) (declaim (ftype (function (t t t) t) process-toplevel-deftype)) (defun process-toplevel-deftype (form stream compile-time-too) (declare (ignore stream compile-time-too)) (note-toplevel-form form) (eval form) form) (declaim (ftype (function (t t t) t) process-toplevel-eval-when)) (defun process-toplevel-eval-when (form stream compile-time-too) (flet ((parse-eval-when-situations (situations) "Parse an EVAL-WHEN situations list, returning three flags, (VALUES COMPILE-TOPLEVEL LOAD-TOPLEVEL EXECUTE), indicating the types of situations present in the list." ; Adapted from SBCL. (when (or (not (listp situations)) (set-difference situations '(:compile-toplevel compile :load-toplevel load :execute eval))) (error "Bad EVAL-WHEN situation list: ~S." situations)) (values (intersection '(:compile-toplevel compile) situations) (intersection '(:load-toplevel load) situations) (intersection '(:execute eval) situations)))) (multiple-value-bind (ct lt e) (parse-eval-when-situations (cadr form)) (let ((new-compile-time-too (or ct (and compile-time-too e))) (body (cddr form))) (if lt (process-progn body stream new-compile-time-too) (when new-compile-time-too (eval `(progn ,@body))))))) nil) (declaim (ftype (function (t t t) t) process-toplevel-defmethod/defgeneric)) (defun process-toplevel-defmethod/defgeneric (form stream compile-time-too) (note-toplevel-form form) (note-name-defined (second form)) (push (second form) *toplevel-functions*) (when (and (consp (second form)) (eq 'setf (first (second form)))) (push (second (second form)) *toplevel-setf-functions*)) (let ((*compile-print* nil)) (process-toplevel-form (macroexpand-1 form *compile-file-environment*) stream compile-time-too)) nil) (declaim (ftype (function (t t t) t) process-toplevel-locally)) (defun process-toplevel-locally (form stream compile-time-too) (jvm::with-saved-compiler-policy (multiple-value-bind (forms decls) (parse-body (cdr form) nil) (process-optimization-declarations decls) (let* ((jvm::*visible-variables* jvm::*visible-variables*) (specials (jvm::process-declarations-for-vars (cdr form) nil nil))) (dolist (special specials) (push special jvm::*visible-variables*)) (process-progn forms stream compile-time-too)))) nil) (declaim (ftype (function (t t t) t) process-toplevel-defmacro)) (defun process-toplevel-defmacro (form stream compile-time-too) (declare (ignore stream compile-time-too)) (note-toplevel-form form) (let ((name (second form))) (eval form) (push name *toplevel-macros*) (let* ((expr (function-lambda-expression (macro-function name))) (saved-class-number *class-number*) (classfile (next-classfile))) (with-open-file (f classfile :direction :output :element-type '(unsigned-byte 8) :if-exists :supersede) (ignore-errors (jvm:compile-defun nil expr *compile-file-environment* classfile f nil))) (when (null (verify-load classfile)) ;; FIXME error or warning (format *error-output* "; Unable to compile macro ~A~%" name) (return-from process-toplevel-defmacro form)) (if (special-operator-p name) `(put ',name 'macroexpand-macro (make-macro ',name (sys::get-fasl-function *fasl-loader* ,saved-class-number))) `(fset ',name (make-macro ',name (sys::get-fasl-function *fasl-loader* ,saved-class-number)) ,*source-position* ',(third form)))))) (declaim (ftype (function (t t t) t) process-toplevel-defun)) (defun process-toplevel-defun (form stream compile-time-too) (declare (ignore stream)) (note-toplevel-form form) (let* ((name (second form)) (block-name (fdefinition-block-name name)) (lambda-list (third form)) (body (nthcdr 3 form))) (jvm::with-saved-compiler-policy (multiple-value-bind (body decls doc) (parse-body body) (let* ((expr `(lambda ,lambda-list ,@decls (block ,block-name ,@body))) (saved-class-number *class-number*) (classfile (next-classfile)) (internal-compiler-errors nil) (result (with-open-file (f classfile :direction :output :element-type '(unsigned-byte 8) :if-exists :supersede) (handler-bind ((internal-compiler-error #'(lambda (e) (push e internal-compiler-errors) (continue)))) (report-error (jvm:compile-defun name expr *compile-file-environment* classfile f nil))))) (compiled-function (if (not internal-compiler-errors) (verify-load classfile) nil))) (declare (ignore result)) (cond ((and (not internal-compiler-errors) compiled-function) (when compile-time-too (eval form)) (setf form `(fset ',name (sys::get-fasl-function *fasl-loader* ,saved-class-number) ,*source-position* ',lambda-list ,doc))) (t (compiler-warn "Unable to compile function ~A. Using interpreted form instead.~%" name) (when internal-compiler-errors (dolist (e internal-compiler-errors) (format *error-output* "; ~A~%" e))) (let ((precompiled-function (precompiler:precompile-form expr nil *compile-file-environment*))) (setf form `(fset ',name ,precompiled-function ,*source-position* ',lambda-list ,doc))) (when compile-time-too (eval form))))) (when (and (symbolp name) (eq (get name '%inline) 'INLINE)) ;; FIXME Need to support SETF functions too! (setf (inline-expansion name) (jvm::generate-inline-expansion block-name lambda-list (append decls body))) (output-form `(setf (inline-expansion ',name) ',(inline-expansion name)))))) (push name jvm::*functions-defined-in-current-file*) (note-name-defined name) (push name *toplevel-functions*) (when (and (consp name) (eq 'setf (first name))) (push (second name) *toplevel-setf-functions*)) ;; If NAME is not fbound, provide a dummy definition so that ;; getSymbolFunctionOrDie() will succeed when we try to verify that ;; functions defined later in the same file can be loaded correctly. (unless (fboundp name) (setf (fdefinition name) #'dummy) (push name *fbound-names*))) form) ;; toplevel handlers ;; each toplevel handler takes a form and stream as input (defun install-toplevel-handler (symbol handler) (setf (get symbol 'toplevel-handler) handler)) (dolist (pair '((COMPILER-DEFSTRUCT precompile-toplevel-form) (DECLARE process-toplevel-declare) (DEFCONSTANT process-toplevel-defconstant) (DEFGENERIC process-toplevel-defmethod/defgeneric) (DEFMACRO process-toplevel-defmacro) (DEFMETHOD process-toplevel-defmethod/defgeneric) (DEFPACKAGE process-toplevel-defpackage/in-package) (DEFPARAMETER process-toplevel-defvar/defparameter) (DEFTYPE process-toplevel-deftype) (DEFUN process-toplevel-defun) (DEFVAR process-toplevel-defvar/defparameter) (EVAL-WHEN process-toplevel-eval-when) (EXPORT process-toplevel-export) (IMPORT process-toplevel-import) (IN-PACKAGE process-toplevel-defpackage/in-package) (LOCALLY process-toplevel-locally) (MACROLET process-toplevel-macrolet) (PROCLAIM precompile-toplevel-form) (PROGN process-toplevel-progn) (PROVIDE precompile-toplevel-form) (PUT precompile-toplevel-form) (QUOTE process-toplevel-quote) (REQUIRE precompile-toplevel-form) (SHADOW precompile-toplevel-form) (%SET-FDEFINITION precompile-toplevel-form) (MOP::ENSURE-METHOD process-toplevel-mop.ensure-method))) (install-toplevel-handler (car pair) (cadr pair))) (declaim (ftype (function (t stream t) t) process-toplevel-form)) (defun process-toplevel-form (form stream compile-time-too) (unless (atom form) (let* ((operator (%car form)) (handler (get operator 'toplevel-handler))) (when handler (let ((out-form (funcall handler form stream compile-time-too))) (when out-form (output-form out-form))) (return-from process-toplevel-form)) (when (and (symbolp operator) (macro-function operator *compile-file-environment*)) (when (eq operator 'define-setf-expander) ;; ??? what if the symbol is package qualified? (push (second form) *toplevel-setf-expanders*)) (when (and (eq operator 'defsetf) ;; ??? what if the symbol is package qualified? (consp (third form))) ;; long form of DEFSETF (push (second form) *toplevel-setf-expanders*)) (note-toplevel-form form) ;; Note that we want MACROEXPAND-1 and not MACROEXPAND here, in ;; case the form being expanded expands into something that needs ;; special handling by PROCESS-TOPLEVEL-FORM (e.g. DEFMACRO). (let ((*compile-print* nil)) (process-toplevel-form (macroexpand-1 form *compile-file-environment*) stream compile-time-too)) (return-from process-toplevel-form)) (cond ((and (symbolp operator) (not (special-operator-p operator)) (null (cdr form))) (setf form (precompiler:precompile-form form nil *compile-file-environment*))) (t (note-toplevel-form form) (setf form (convert-toplevel-form form nil))))) (when (consp form) (output-form form))) ;; Make sure the compiled-function loader knows where ;; to load the compiled functions. Note that this trickery ;; was already used in verify-load before I used it, ;; however, binding *load-truename* isn't fully compliant, I think. (when compile-time-too (let ((*load-truename* *output-file-pathname*) (*fasl-loader* (make-fasl-class-loader (concatenate 'string "org.armedbear.lisp." (base-classname))))) (eval form)))) (defun populate-zip-fasl (output-file) (let* ((type ;; Don't use ".zip", it'll result in an extension with ;; a dot, which is rejected by NAMESTRING (%format nil "~A~A" (pathname-type output-file) "-zip")) (output-file (if (logical-pathname-p output-file) (translate-logical-pathname output-file) output-file)) (zipfile (if (find :windows *features*) (make-pathname :defaults output-file :type type) (make-pathname :defaults output-file :type type :device :unspecific))) (pathnames nil) (fasl-loader (make-pathname :defaults output-file :name (fasl-loader-classname) :type *compile-file-class-extension*))) (when (probe-file fasl-loader) (push fasl-loader pathnames)) (dotimes (i *class-number*) (let ((truename (probe-file (compute-classfile (1+ i))))) (when truename (push truename pathnames) ;;; XXX it would be better to just use the recorded number ;;; of class constants, but probing for the first at least ;;; makes this subjectively bearable. (when (probe-file (make-pathname :name (format nil "~A_0" (pathname-name truename)) :type "clc" :defaults truename)) (dolist (resource (directory (make-pathname :name (format nil "~A_*" (pathname-name truename)) :type "clc" :defaults truename))) (push resource pathnames)))))) (setf pathnames (nreverse (remove nil pathnames))) (let ((load-file (make-pathname :defaults output-file :name "__loader__" :type "_"))) (rename-file output-file load-file) (push load-file pathnames)) (zip zipfile pathnames) (dolist (pathname pathnames) (ignore-errors (delete-file pathname))) (rename-file zipfile output-file))) (defun write-fasl-prologue (stream) (let ((out stream)) ;; write header (write "; -*- Mode: Lisp -*-" :escape nil :stream out) (%stream-terpri out) (write (list 'init-fasl :version *fasl-version*) :stream out) (%stream-terpri out) (write (list 'setq '*source* *compile-file-truename*) :stream out) (%stream-terpri out) ;; Note: Beyond this point, you can't use DUMP-FORM, ;; because the list of uninterned symbols has been fixed now. (when *fasl-uninterned-symbols* (write (list 'setq '*fasl-uninterned-symbols* (coerce (mapcar #'car (nreverse *fasl-uninterned-symbols*)) 'vector)) :stream out :length nil)) (%stream-terpri out) (when (> *class-number* 0) (write (list 'setq '*fasl-loader* `(sys::make-fasl-class-loader ,(concatenate 'string "org.armedbear.lisp." (base-classname)))) :stream out)) (%stream-terpri out))) (defvar *binary-fasls* nil) (defvar *forms-for-output* nil) (defvar *fasl-stream* nil) (defun compile-from-stream (in output-file temp-file temp-file2 extract-toplevel-funcs-and-macros functions-file macros-file exports-file setf-functions-file setf-expanders-file) (let* ((*compile-file-pathname* (make-pathname :defaults (pathname in) :version nil)) (*compile-file-truename* (make-pathname :defaults (truename in) :version nil)) (*source* *compile-file-truename*) (*class-number* 0) (namestring (namestring *compile-file-truename*)) (start (get-internal-real-time)) *fasl-uninterned-symbols* (warnings-p nil) (failure-p nil)) (when *compile-verbose* (format t "; Compiling ~A ...~%" namestring)) (with-compilation-unit () (with-open-file (out temp-file :direction :output :if-exists :supersede :external-format *fasl-external-format*) (let ((*readtable* *readtable*) (*read-default-float-format* *read-default-float-format*) (*read-base* *read-base*) (*package* *package*) (jvm::*functions-defined-in-current-file* '()) (*fbound-names* '()) (*fasl-stream* out) *forms-for-output*) (jvm::with-saved-compiler-policy (jvm::with-file-compilation (handler-bind ((style-warning #'(lambda (c) (setf warnings-p t) ;; let outer handlers do their thing (signal c) ;; prevent the next handler ;; from running: we're a ;; WARNING subclass (continue))) ((or warning compiler-error) #'(lambda (c) (declare (ignore c)) (setf warnings-p t failure-p t)))) (loop (let* ((*source-position* (file-position in)) (jvm::*source-line-number* (stream-line-number in)) (form (read in nil in)) (*compiler-error-context* form)) (when (eq form in) (return)) (process-toplevel-form form out nil)))) (finalize-fasl-output) (dolist (name *fbound-names*) (fmakunbound name))))))) (when extract-toplevel-funcs-and-macros (setf *toplevel-functions* (remove-if-not (lambda (func-name) (if (symbolp func-name) (symbol-package func-name) T)) (remove-duplicates *toplevel-functions*))) (when *toplevel-functions* (with-open-file (f-out functions-file :direction :output :if-does-not-exist :create :if-exists :supersede) (let ((*package* (find-package :keyword))) (write *toplevel-functions* :stream f-out)))) (setf *toplevel-macros* (remove-if-not (lambda (mac-name) (if (symbolp mac-name) (symbol-package mac-name) T)) (remove-duplicates *toplevel-macros*))) (when *toplevel-macros* (with-open-file (m-out macros-file :direction :output :if-does-not-exist :create :if-exists :supersede) (let ((*package* (find-package :keyword))) (write *toplevel-macros* :stream m-out)))) (setf *toplevel-exports* (remove-if-not (lambda (sym) (if (symbolp sym) (symbol-package sym) T)) (remove-duplicates *toplevel-exports*))) (when *toplevel-exports* (with-open-file (e-out exports-file :direction :output :if-does-not-exist :create :if-exists :supersede) (let ((*package* (find-package :keyword))) (write *toplevel-exports* :stream e-out)))) (setf *toplevel-setf-functions* (remove-if-not (lambda (sym) (if (symbolp sym) (symbol-package sym) T)) (remove-duplicates *toplevel-setf-functions*))) (when *toplevel-setf-functions* (with-open-file (e-out setf-functions-file :direction :output :if-does-not-exist :create :if-exists :supersede) (let ((*package* (find-package :keyword))) (write *toplevel-setf-functions* :stream e-out)))) (setf *toplevel-setf-expanders* (remove-if-not (lambda (sym) (if (symbolp sym) (symbol-package sym) T)) (remove-duplicates *toplevel-setf-expanders*))) (when *toplevel-setf-expanders* (with-open-file (e-out setf-expanders-file :direction :output :if-does-not-exist :create :if-exists :supersede) (let ((*package* (find-package :keyword))) (write *toplevel-setf-expanders* :stream e-out))))) (with-open-file (in temp-file :direction :input :external-format *fasl-external-format*) (with-open-file (out temp-file2 :direction :output :if-does-not-exist :create :if-exists :supersede :external-format *fasl-external-format*) (let ((*package* (find-package '#:cl)) (*print-fasl* t) (*print-array* t) (*print-base* 10) (*print-case* :upcase) (*print-circle* nil) (*print-escape* t) (*print-gensym* t) (*print-length* nil) (*print-level* nil) (*print-lines* nil) (*print-pretty* nil) (*print-radix* nil) (*print-readably* t) (*print-right-margin* nil) (*print-structure* t) ;; make sure to write all floats with their exponent marker: ;; the dump-time default may not be the same at load-time (*read-default-float-format* nil)) ;; these values are also bound by WITH-STANDARD-IO-SYNTAX, ;; but not used by our reader/printer, so don't bind them, ;; for efficiency reasons. ;; (*read-eval* t) ;; (*read-suppress* nil) ;; (*print-miser-width* nil) ;; (*print-pprint-dispatch* (copy-pprint-dispatch nil)) ;; (*read-base* 10) ;; (*read-default-float-format* 'single-float) ;; (*readtable* (copy-readtable nil)) (write-fasl-prologue out) ;; copy remaining content (loop for line = (read-line in nil :eof) while (not (eq line :eof)) do (write-line line out))))) (delete-file temp-file) (when (find :windows *features*) (remove-zip-cache-entry output-file)) (rename-file temp-file2 output-file) (when *compile-file-zip* (populate-zip-fasl output-file)) (when *compile-verbose* (format t "~&; Wrote ~A (~A seconds)~%" (namestring output-file) (/ (- (get-internal-real-time) start) 1000.0))) (values (truename output-file) warnings-p failure-p))) (defun compile-file (input-file &key output-file ((:verbose *compile-verbose*) *compile-verbose*) ((:print *compile-print*) *compile-print*) (extract-toplevel-funcs-and-macros nil) (external-format :utf-8)) (flet ((pathname-with-type (pathname type &optional suffix) (when suffix (setq type (concatenate 'string type suffix))) (make-pathname :type type :defaults pathname))) (unless (or (and (probe-file input-file) (not (file-directory-p input-file))) (pathname-type input-file)) (let ((pathname (pathname-with-type input-file "lisp"))) (when (probe-file pathname) (setf input-file pathname)))) (setf output-file (make-pathname :defaults (if output-file (merge-pathnames output-file *default-pathname-defaults*) (compile-file-pathname input-file)) :version nil)) (let* ((*output-file-pathname* output-file) (type (pathname-type output-file)) (temp-file (pathname-with-type output-file type "-tmp")) (temp-file2 (pathname-with-type output-file type "-tmp2")) (functions-file (pathname-with-type output-file "funcs")) (macros-file (pathname-with-type output-file "macs")) (exports-file (pathname-with-type output-file "exps")) (setf-functions-file (pathname-with-type output-file "setf-functions")) (setf-expanders-file (pathname-with-type output-file "setf-expanders")) *toplevel-functions* *toplevel-macros* *toplevel-exports* *toplevel-setf-functions* *toplevel-setf-expanders*) (with-open-file (in input-file :direction :input :external-format external-format) (multiple-value-bind (output-file-truename warnings-p failure-p) (compile-from-stream in output-file temp-file temp-file2 extract-toplevel-funcs-and-macros functions-file macros-file exports-file setf-functions-file setf-expanders-file) (values (truename output-file) warnings-p failure-p)))))) (defun compile-file-if-needed (input-file &rest allargs &key force-compile &allow-other-keys) (setf input-file (truename input-file)) (cond (force-compile (remf allargs :force-compile) (apply 'compile-file input-file allargs)) (t (let* ((source-write-time (file-write-date input-file)) (output-file (or (getf allargs :output-file) (compile-file-pathname input-file))) (target-write-time (and (probe-file output-file) (file-write-date output-file)))) (if (or (null target-write-time) (<= target-write-time source-write-time)) (apply #'compile-file input-file allargs) output-file))))) (provide 'compile-file)