source: trunk/abcl/src/org/armedbear/lisp/compile-file.lisp @ 13604

Last change on this file since 13604 was 13604, checked in by ehuelsmann, 10 years ago

Bump FASL format because of the now supported circularity: even though
we're backward compatible, older versions aren't forward compatible.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Id
File size: 34.0 KB
Line 
1;;; compile-file.lisp
2;;;
3;;; Copyright (C) 2004-2006 Peter Graves
4;;; $Id: compile-file.lisp 13604 2011-09-20 20:26:31Z ehuelsmann $
5;;;
6;;; This program is free software; you can redistribute it and/or
7;;; modify it under the terms of the GNU General Public License
8;;; as published by the Free Software Foundation; either version 2
9;;; of the License, or (at your option) any later version.
10;;;
11;;; This program is distributed in the hope that it will be useful,
12;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
13;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
14;;; GNU General Public License for more details.
15;;;
16;;; You should have received a copy of the GNU General Public License
17;;; along with this program; if not, write to the Free Software
18;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
19;;;
20;;; As a special exception, the copyright holders of this library give you
21;;; permission to link this library with independent modules to produce an
22;;; executable, regardless of the license terms of these independent
23;;; modules, and to copy and distribute the resulting executable under
24;;; terms of your choice, provided that you also meet, for each linked
25;;; independent module, the terms and conditions of the license of that
26;;; module.  An independent module is a module which is not derived from
27;;; or based on this library.  If you modify this library, you may extend
28;;; this exception to your version of the library, but you are not
29;;; obligated to do so.  If you do not wish to do so, delete this
30;;; exception statement from your version.
31
32(in-package #:system)
33
34(require "JVM")
35;; (require "COMPILER-ERROR") already made accessible through JVM
36
37(defvar *fbound-names*)
38
39(defvar *class-number*)
40
41(defvar *output-file-pathname*)
42
43(defun base-classname (&optional (output-file-pathname *output-file-pathname*))
44  (sanitize-class-name (pathname-name output-file-pathname)))
45
46(defun fasl-loader-classname (&optional (output-file-pathname *output-file-pathname*))
47  (%format nil "~A_0" (base-classname output-file-pathname)))
48
49(declaim (ftype (function (t) t) compute-classfile-name))
50(defun compute-classfile-name (n &optional (output-file-pathname
51                                            *output-file-pathname*))
52  "Computes the name of the class file associated with number `n'."
53  (let ((name
54         (sanitize-class-name
55    (%format nil "~A_~D" (pathname-name output-file-pathname) n))))
56    (namestring (merge-pathnames (make-pathname :name name :type "cls")
57                                 output-file-pathname))))
58
59(defun sanitize-class-name (name)
60  (let ((name (copy-seq name)))
61    (dotimes (i (length name))
62      (declare (type fixnum i))
63      (when (or (char= (char name i) #\-)
64    (char= (char name i) #\.)
65    (char= (char name i) #\Space))
66        (setf (char name i) #\_)))
67    name))
68 
69
70(declaim (ftype (function () t) next-classfile-name))
71(defun next-classfile-name ()
72  (compute-classfile-name (incf *class-number*)))
73
74(defmacro report-error (&rest forms)
75  `(handler-case (progn ,@forms)
76     (compiler-unsupported-feature-error (condition)
77       (fresh-line)
78       (%format t "; UNSUPPORTED-FEATURE: ~A~%" condition)
79       (values nil condition))))
80
81;; Dummy function. Should never be called.
82(defun dummy (&rest ignored)
83  (declare (ignore ignored))
84  (assert nil))
85
86(declaim (ftype (function (t) t) verify-load))
87(defun verify-load (classfile)
88  #|(if (> *safety* 0)
89      (and classfile
90         (let ((*load-truename* *output-file-pathname*))
91           (report-error
92            (load-compiled-function classfile))))
93    t)|#
94  (declare (ignore classfile))
95  t)
96
97(declaim (ftype (function (t) t) note-toplevel-form))
98(defun note-toplevel-form (form)
99  (when *compile-print*
100    (fresh-line)
101    (princ "; ")
102    (let ((*print-length* 2)
103          (*print-level* 2)
104          (*print-pretty* nil))
105      (prin1 form))
106    (terpri)))
107
108(defun output-form (form)
109  (if *binary-fasls*
110      (push form *forms-for-output*)
111      (progn
112        (dump-form form *fasl-stream*)
113        (%stream-terpri *fasl-stream*))))
114
115(defun finalize-fasl-output ()
116  (when *binary-fasls*
117    (let ((*package* (find-package :keyword))
118          (*double-colon-package-separators* T))
119      (dump-form (convert-toplevel-form (list* 'PROGN
120                                               (nreverse *forms-for-output*))
121                                        t)
122                 *fasl-stream*))
123    (%stream-terpri *fasl-stream*)))
124
125
126(declaim (ftype (function (t) t) simple-toplevel-form-p))
127(defun simple-toplevel-form-p (form)
128  "Returns NIL if the form is too complex to become an
129interpreted toplevel form, non-NIL if it is 'simple enough'."
130  (and (consp form)
131       (every #'(lambda (arg)
132                  (or (and (atom arg)
133                           (not (and (symbolp arg)
134                                     (symbol-macro-p arg))))
135                      (and (consp arg)
136                           (eq 'QUOTE (car arg)))))
137              (cdr form))))
138
139(declaim (ftype (function (t t) t) convert-toplevel-form))
140(defun convert-toplevel-form (form declare-inline)
141  (when (or (simple-toplevel-form-p form)
142            (and (eq (car form) 'SETQ)
143                 ;; for SETQ, look at the evaluated part
144                 (simple-toplevel-form-p (third form))))
145    ;; single form with simple or constant arguments
146    ;; Without this exception, toplevel function calls
147    ;; will be compiled into lambdas which get compiled to
148    ;; compiled-functions. Those need to be loaded.
149    ;; Conclusion: Top level interpreting the function call
150    ;;  and its arguments may be (and should be) more efficient.
151    (return-from convert-toplevel-form
152      (precompiler:precompile-form form nil *compile-file-environment*)))
153  (let* ((expr `(lambda () ,form))
154         (saved-class-number *class-number*)
155         (classfile (next-classfile-name))
156         (result
157          (with-open-file
158              (f classfile
159                 :direction :output
160                 :element-type '(unsigned-byte 8)
161                 :if-exists :supersede)
162            (report-error (jvm:compile-defun nil
163                                             expr *compile-file-environment*
164                                             classfile f declare-inline))))
165         (compiled-function (verify-load classfile)))
166    (declare (ignore result))
167    (setf form
168          (if compiled-function
169              `(funcall (sys::get-fasl-function *fasl-loader*
170                                                ,saved-class-number))
171              (precompiler:precompile-form form nil
172                                           *compile-file-environment*)))))
173
174
175
176
177(declaim (ftype (function (t stream t) t) process-progn))
178(defun process-progn (forms stream compile-time-too)
179  (dolist (form forms)
180    (process-toplevel-form form stream compile-time-too))
181  nil)
182
183
184(declaim (ftype (function (t t t) t) process-toplevel-form))
185(defun precompile-toplevel-form (form stream compile-time-too)
186  (declare (ignore stream))
187  (let ((form (precompiler:precompile-form form nil
188                                           *compile-file-environment*)))
189    (when compile-time-too
190      (eval form))
191    form))
192
193
194
195(defun process-toplevel-macrolet (form stream compile-time-too)
196  (let ((*compile-file-environment*
197         (make-environment *compile-file-environment*)))
198    (dolist (definition (cadr form))
199      (environment-add-macro-definition *compile-file-environment*
200                                        (car definition)
201                                        (make-macro (car definition)
202                                                    (make-expander-for-macrolet definition))))
203    (dolist (body-form (cddr form))
204      (process-toplevel-form body-form stream compile-time-too)))
205  nil)
206
207(declaim (ftype (function (t t t) t) process-toplevel-defconstant))
208(defun process-toplevel-defconstant (form stream compile-time-too)
209  (declare (ignore stream compile-time-too))
210  ;; "If a DEFCONSTANT form appears as a top level form, the compiler
211  ;; must recognize that [the] name names a constant variable. An
212  ;; implementation may choose to evaluate the value-form at compile
213  ;; time, load time, or both. Therefore, users must ensure that the
214  ;; initial-value can be evaluated at compile time (regardless of
215  ;; whether or not references to name appear in the file) and that
216  ;; it always evaluates to the same value."
217  (note-toplevel-form form)
218  (eval form)
219  form)
220
221(declaim (ftype (function (t t t) t) process-toplevel-quote))
222(defun process-toplevel-quote (form stream compile-time-too)
223  (declare (ignore stream))
224  (when compile-time-too
225    (eval form))
226  nil)
227
228
229(declaim (ftype (function (t t t) t) process-toplevel-import))
230(defun process-toplevel-import (form stream compile-time-too)
231  (declare (ignore stream))
232  (let ((form (precompiler:precompile-form form nil
233                                           *compile-file-environment*)))
234    (let ((*package* +keyword-package+))
235      (output-form form))
236    (when compile-time-too
237      (eval form)))
238  nil)
239
240(declaim (ftype (function (t t t) t) process-toplevel-mop.ensure-method))
241(defun process-toplevel-mop.ensure-method (form stream compile-time-too)
242  (declare (ignore stream))
243  (flet ((convert-ensure-method (form key)
244           (let* ((tail (cddr form))
245                  (function-form (getf tail key)))
246             (when (and function-form (consp function-form)
247               (eq (%car function-form) 'FUNCTION))
248               (let ((lambda-expression (cadr function-form)))
249                 (jvm::with-saved-compiler-policy
250                     (let* ((saved-class-number *class-number*)
251                            (classfile (next-classfile-name))
252                            (result
253                             (with-open-file
254                                 (f classfile
255                                    :direction :output
256                                    :element-type '(unsigned-byte 8)
257                                    :if-exists :supersede)
258                               (report-error
259                                (jvm:compile-defun nil lambda-expression
260                                                   *compile-file-environment*
261                                                   classfile f nil))))
262                            (compiled-function (verify-load classfile)))
263                       (declare (ignore result))
264                       (cond
265                         (compiled-function
266                          (setf (getf tail key)
267                                `(sys::get-fasl-function *fasl-loader*
268                                                         ,saved-class-number)))
269                         (t
270                          ;; FIXME This should be a warning or error of some sort...
271                          (format *error-output* "; Unable to compile method~%"))))))))))
272
273
274    (when compile-time-too
275      (let* ((copy-form (copy-tree form))
276             ;; ### Ideally, the precompiler would leave the forms alone
277             ;;  and copy them where required, instead of forcing us to
278             ;;  do a deep copy in advance
279             (precompiled-form (precompiler:precompile-form copy-form nil
280                                                            *compile-file-environment*)))
281        (eval precompiled-form)))
282    (convert-ensure-method form :function)
283    (convert-ensure-method form :fast-function))
284  (precompiler:precompile-form form nil *compile-file-environment*))
285
286(declaim (ftype (function (t t t) t) process-toplevel-defvar/defparameter))
287(defun process-toplevel-defvar/defparameter (form stream compile-time-too)
288  (declare (ignore stream))
289  (note-toplevel-form form)
290  (if compile-time-too
291      (eval form)
292      ;; "If a DEFVAR or DEFPARAMETER form appears as a top level form,
293      ;; the compiler must recognize that the name has been proclaimed
294      ;; special. However, it must neither evaluate the initial-value
295      ;; form nor assign the dynamic variable named NAME at compile
296      ;; time."
297      (let ((name (second form)))
298        (%defvar name)))
299  form)
300
301(declaim (ftype (function (t t t) t) process-toplevel-defpackage/in-package))
302(defun process-toplevel-defpackage/in-package (form stream compile-time-too)
303  (declare (ignore stream compile-time-too))
304  (note-toplevel-form form)
305  (setf form
306        (precompiler:precompile-form form nil *compile-file-environment*))
307  (eval form)
308  ;; Force package prefix to be used when dumping form.
309  (let ((*package* +keyword-package+))
310    (output-form form))
311  nil)
312
313(declaim (ftype (function (t t t) t) process-toplevel-declare))
314(defun process-toplevel-declare (form stream compile-time-too)
315  (declare (ignore stream compile-time-too))
316  (compiler-style-warn "Misplaced declaration: ~S" form)
317  nil)
318
319(declaim (ftype (function (t t t) t) process-toplevel-progn))
320(defun process-toplevel-progn (form stream compile-time-too)
321  (process-progn (cdr form) stream compile-time-too)
322  nil)
323
324(declaim (ftype (function (t t t) t) process-toplevel-deftype))
325(defun process-toplevel-deftype (form stream compile-time-too)
326  (declare (ignore stream compile-time-too))
327  (note-toplevel-form form)
328  (eval form)
329  form)
330
331(declaim (ftype (function (t t t) t) process-toplevel-eval-when))
332(defun process-toplevel-eval-when (form stream compile-time-too)
333  (flet ((parse-eval-when-situations (situations)
334           "Parse an EVAL-WHEN situations list, returning three flags,
335            (VALUES COMPILE-TOPLEVEL LOAD-TOPLEVEL EXECUTE), indicating
336            the types of situations present in the list."
337            ; Adapted from SBCL.
338           (when (or (not (listp situations))
339                     (set-difference situations
340                                     '(:compile-toplevel
341                                       compile
342                                       :load-toplevel
343                                       load
344                                       :execute
345                                       eval)))
346             (error "Bad EVAL-WHEN situation list: ~S." situations))
347           (values (intersection '(:compile-toplevel compile) situations)
348                   (intersection '(:load-toplevel load) situations)
349                   (intersection '(:execute eval) situations))))
350    (multiple-value-bind (ct lt e)
351        (parse-eval-when-situations (cadr form))
352      (let ((new-compile-time-too (or ct (and compile-time-too e)))
353            (body (cddr form)))
354        (if lt
355            (process-progn body stream new-compile-time-too)
356            (when new-compile-time-too
357              (eval `(progn ,@body)))))))
358  nil)
359
360
361(declaim (ftype (function (t t t) t) process-toplevel-defmethod/defgeneric))
362(defun process-toplevel-defmethod/defgeneric (form stream compile-time-too)
363  (note-toplevel-form form)
364  (note-name-defined (second form))
365  (let ((*compile-print* nil))
366    (process-toplevel-form (macroexpand-1 form *compile-file-environment*)
367                           stream compile-time-too))
368  nil)
369
370(declaim (ftype (function (t t t) t) process-toplevel-locally))
371(defun process-toplevel-locally (form stream compile-time-too)
372  (jvm::with-saved-compiler-policy
373      (multiple-value-bind (forms decls)
374          (parse-body (cdr form) nil)
375        (process-optimization-declarations decls)
376        (let* ((jvm::*visible-variables* jvm::*visible-variables*)
377               (specials (jvm::process-declarations-for-vars (cdr form)
378                                                             nil nil)))
379          (dolist (special specials)
380            (push special jvm::*visible-variables*))
381          (process-progn forms stream compile-time-too))))
382  nil)
383
384(declaim (ftype (function (t t t) t) process-toplevel-defmacro))
385(defun process-toplevel-defmacro (form stream compile-time-too)
386  (declare (ignore stream compile-time-too))
387  (note-toplevel-form form)
388  (let ((name (second form)))
389    (eval form)
390    (let* ((expr (function-lambda-expression (macro-function name)))
391           (saved-class-number *class-number*)
392           (classfile (next-classfile-name)))
393      (with-open-file
394          (f classfile
395             :direction :output
396             :element-type '(unsigned-byte 8)
397             :if-exists :supersede)
398        (ignore-errors
399          (jvm:compile-defun nil expr *compile-file-environment*
400                             classfile f nil)))
401      (when (null (verify-load classfile))
402        ;; FIXME error or warning
403        (format *error-output* "; Unable to compile macro ~A~%" name)
404        (return-from process-toplevel-defmacro form))
405
406      (if (special-operator-p name)
407          `(put ',name 'macroexpand-macro
408                (make-macro ',name
409                            (sys::get-fasl-function *fasl-loader*
410                                                    ,saved-class-number)))
411          `(fset ',name
412                 (make-macro ',name
413                             (sys::get-fasl-function *fasl-loader*
414                                                     ,saved-class-number))
415                 ,*source-position*
416                 ',(third form))))))
417
418(declaim (ftype (function (t t t) t) process-toplevel-defun))
419(defun process-toplevel-defun (form stream compile-time-too)
420  (declare (ignore stream))
421  (note-toplevel-form form)
422  (let* ((name (second form))
423         (block-name (fdefinition-block-name name))
424         (lambda-list (third form))
425         (body (nthcdr 3 form)))
426    (jvm::with-saved-compiler-policy
427        (multiple-value-bind (body decls doc)
428            (parse-body body)
429          (let* ((expr `(lambda ,lambda-list
430                          ,@decls (block ,block-name ,@body)))
431                 (saved-class-number *class-number*)
432                 (classfile (next-classfile-name))
433                 (internal-compiler-errors nil)
434                 (result (with-open-file
435                             (f classfile
436                                :direction :output
437                                :element-type '(unsigned-byte 8)
438                                :if-exists :supersede)
439                           (handler-bind
440                               ((internal-compiler-error
441                                 #'(lambda (e)
442                                     (push e internal-compiler-errors)
443                                     (continue))))
444                             (report-error
445                              (jvm:compile-defun name expr *compile-file-environment*
446                                                 classfile f nil)))))
447                 (compiled-function (if (not internal-compiler-errors)
448                                        (verify-load classfile)
449                                        nil)))
450            (declare (ignore result))
451            (cond
452              ((and (not internal-compiler-errors)
453                    compiled-function)
454               (when compile-time-too
455                 (eval form))
456               (setf form
457                     `(fset ',name
458                            (sys::get-fasl-function *fasl-loader*
459                                                    ,saved-class-number)
460                            ,*source-position*
461                            ',lambda-list
462                            ,doc)))
463              (t
464               (compiler-warn "Unable to compile function ~A.  Using interpreted form instead.~%" name)
465               (when internal-compiler-errors
466                 (dolist (e internal-compiler-errors)
467                   (format *error-output*
468                           "; ~A~%" e)))
469               (let ((precompiled-function
470                      (precompiler:precompile-form expr nil
471                                                   *compile-file-environment*)))
472                 (setf form
473                       `(fset ',name
474                              ,precompiled-function
475                              ,*source-position*
476                              ',lambda-list
477                              ,doc)))
478               (when compile-time-too
479                 (eval form)))))
480          (when (and (symbolp name) (eq (get name '%inline) 'INLINE))
481            ;; FIXME Need to support SETF functions too!
482            (setf (inline-expansion name)
483                  (jvm::generate-inline-expansion block-name
484                                                  lambda-list body))
485            (output-form `(setf (inline-expansion ',name)
486                                ',(inline-expansion name))))))
487    (push name jvm::*functions-defined-in-current-file*)
488    (note-name-defined name)
489    ;; If NAME is not fbound, provide a dummy definition so that
490    ;; getSymbolFunctionOrDie() will succeed when we try to verify that
491    ;; functions defined later in the same file can be loaded correctly.
492    (unless (fboundp name)
493      (setf (fdefinition name) #'dummy)
494      (push name *fbound-names*)))
495  form)
496
497
498;; toplevel handlers
499;;   each toplevel handler takes a form and stream as input
500
501(defun install-toplevel-handler (symbol handler)
502  (setf (get symbol 'toplevel-handler) handler))
503
504(dolist (pair '((COMPILER-DEFSTRUCT precompile-toplevel-form)
505                (DECLARE process-toplevel-declare)
506                (DEFCONSTANT process-toplevel-defconstant)
507                (DEFGENERIC process-toplevel-defmethod/defgeneric)
508                (DEFMACRO process-toplevel-defmacro)
509                (DEFMETHOD process-toplevel-defmethod/defgeneric)
510                (DEFPACKAGE process-toplevel-defpackage/in-package)
511                (DEFPARAMETER process-toplevel-defvar/defparameter)
512                (DEFTYPE process-toplevel-deftype)
513                (DEFUN process-toplevel-defun)
514                (DEFVAR process-toplevel-defvar/defparameter)
515                (EVAL-WHEN process-toplevel-eval-when)
516                (EXPORT precompile-toplevel-form)
517                (IMPORT process-toplevel-import)
518                (IN-PACKAGE process-toplevel-defpackage/in-package)
519                (LOCALLY process-toplevel-locally)
520                (MACROLET process-toplevel-macrolet)
521                (PROCLAIM precompile-toplevel-form)
522                (PROGN process-toplevel-progn)
523                (PROVIDE precompile-toplevel-form)
524                (PUT precompile-toplevel-form)
525                (QUOTE process-toplevel-quote)
526                (REQUIRE precompile-toplevel-form)
527                (SHADOW precompile-toplevel-form)
528                (%SET-FDEFINITION precompile-toplevel-form)
529                (MOP::ENSURE-METHOD process-toplevel-mop.ensure-method)))
530  (install-toplevel-handler (car pair) (cadr pair)))
531
532(declaim (ftype (function (t stream t) t) process-toplevel-form))
533(defun process-toplevel-form (form stream compile-time-too)
534  (unless (atom form)
535    (let* ((operator (%car form))
536           (handler (get operator 'toplevel-handler)))
537      (when handler
538        (let ((out-form (funcall handler form stream compile-time-too)))
539          (when out-form
540            (output-form out-form)))
541        (return-from process-toplevel-form))
542      (when (and (symbolp operator)
543                 (macro-function operator *compile-file-environment*))
544        (note-toplevel-form form)
545        ;; Note that we want MACROEXPAND-1 and not MACROEXPAND here, in
546        ;; case the form being expanded expands into something that needs
547        ;; special handling by PROCESS-TOPLEVEL-FORM (e.g. DEFMACRO).
548        (let ((*compile-print* nil))
549          (process-toplevel-form (macroexpand-1 form *compile-file-environment*)
550                                 stream compile-time-too))
551        (return-from process-toplevel-form))
552
553      (cond
554        ((and (symbolp operator)
555              (not (special-operator-p operator))
556              (null (cdr form)))
557         (setf form (precompiler:precompile-form form nil
558                                                 *compile-file-environment*)))
559        (t
560         (note-toplevel-form form)
561         (setf form (convert-toplevel-form form nil)))))
562    (when (consp form)
563      (output-form form)))
564  ;; Make sure the compiled-function loader knows where
565  ;; to load the compiled functions. Note that this trickery
566  ;; was already used in verify-load before I used it,
567  ;; however, binding *load-truename* isn't fully compliant, I think.
568  (when compile-time-too
569    (let ((*load-truename* *output-file-pathname*)
570          (*fasl-loader* (make-fasl-class-loader
571                          (concatenate 'string
572                                       "org.armedbear.lisp." (base-classname)))))
573      (eval form))))
574
575(defun populate-zip-fasl (output-file)
576  (let* ((type ;; Don't use ".zip", it'll result in an extension
577          ;;  with a dot, which is rejected by NAMESTRING
578          (%format nil "~A~A" (pathname-type output-file) "-zip"))
579         (zipfile (namestring
580                   (merge-pathnames (make-pathname :type type)
581                                    output-file)))
582         (pathnames nil)
583         (fasl-loader (namestring (merge-pathnames
584                                   (make-pathname :name (fasl-loader-classname)
585                                                  :type "cls")
586                                   output-file))))
587    (when (probe-file fasl-loader)
588      (push fasl-loader pathnames))
589    (dotimes (i *class-number*)
590      (let ((truename (probe-file (compute-classfile-name (1+ i)))))
591        (when truename
592          (push truename pathnames)
593          ;;; XXX it would be better to just use the recorded number
594          ;;; of class constants, but probing for the first at least
595          ;;; makes this subjectively bearable.
596          (when (probe-file
597                 (make-pathname :name (format nil "~A_0"
598                                              (pathname-name truename))
599                                :type "clc"
600                                :defaults truename))
601            (dolist (resource (directory
602                               (make-pathname :name (format nil "~A_*"
603                                                            (pathname-name truename))
604                                              :type "clc"
605                                              :defaults truename)))
606              (push resource pathnames))))))
607    (setf pathnames (nreverse (remove nil pathnames)))
608    (let ((load-file (merge-pathnames (make-pathname :type "_")
609                                      output-file)))
610      (rename-file output-file load-file)
611      (push load-file pathnames))
612    (zip zipfile pathnames)
613    (dolist (pathname pathnames)
614      (ignore-errors (delete-file pathname)))
615    (rename-file zipfile output-file)))
616
617(defun write-fasl-prologue (stream)
618  (let ((out stream))
619    ;; write header
620    (write "; -*- Mode: Lisp -*-" :escape nil :stream out)
621    (%stream-terpri out)
622    (write (list 'init-fasl :version *fasl-version*) :stream out)
623    (%stream-terpri out)
624    (write (list 'setq '*source* *compile-file-truename*) :stream out)
625    (%stream-terpri out)
626
627    ;; Note: Beyond this point, you can't use DUMP-FORM,
628    ;; because the list of uninterned symbols has been fixed now.
629    (when *fasl-uninterned-symbols*
630      (write (list 'setq '*fasl-uninterned-symbols*
631                   (coerce (mapcar #'car (nreverse *fasl-uninterned-symbols*))
632                           'vector))
633             :stream out :length nil))
634    (%stream-terpri out)
635
636    (when (> *class-number* 0)
637      (write (list 'setq '*fasl-loader*
638                   `(sys::make-fasl-class-loader
639                     ,(concatenate 'string "org.armedbear.lisp."
640                                   (base-classname))))
641             :stream out))
642    (%stream-terpri out)))
643
644
645
646(defvar *binary-fasls* nil)
647(defvar *forms-for-output* nil)
648(defvar *fasl-stream* nil)
649
650(defun compile-file (input-file
651                     &key
652                     output-file
653                     ((:verbose *compile-verbose*) *compile-verbose*)
654                     ((:print *compile-print*) *compile-print*)
655                     external-format)
656  (declare (ignore external-format))    ; FIXME
657  (unless (or (and (probe-file input-file) (not (file-directory-p input-file)))
658              (pathname-type input-file))
659    (let ((pathname (merge-pathnames (make-pathname :type "lisp") input-file)))
660      (when (probe-file pathname)
661        (setf input-file pathname))))
662  (setf output-file (make-pathname 
663         :defaults (if output-file
664           (merge-pathnames output-file 
665                *default-pathname-defaults*)
666           (compile-file-pathname input-file))
667         :version nil))
668  (let* ((*output-file-pathname* output-file)
669         (type (pathname-type output-file))
670         (temp-file (merge-pathnames (make-pathname :type (concatenate 'string type "-tmp"))
671                                     output-file))
672         (temp-file2 (merge-pathnames (make-pathname :type (concatenate 'string type "-tmp2"))
673                                     output-file))
674         (warnings-p nil)
675         (failure-p nil))
676    (with-open-file (in input-file :direction :input)
677      (let* ((*compile-file-pathname* (make-pathname :defaults (pathname in)
678                 :version nil))
679             (*compile-file-truename* (make-pathname :defaults (truename in)
680                                                     :version nil))
681             (*source* *compile-file-truename*)
682             (*class-number* 0)
683             (namestring (namestring *compile-file-truename*))
684             (start (get-internal-real-time))
685             *fasl-uninterned-symbols*)
686        (when *compile-verbose*
687          (format t "; Compiling ~A ...~%" namestring))
688        (with-compilation-unit ()
689          (with-open-file (out temp-file
690                               :direction :output :if-exists :supersede
691                               :external-format *fasl-external-format*)
692            (let ((*readtable* *readtable*)
693                  (*read-default-float-format* *read-default-float-format*)
694                  (*read-base* *read-base*)
695                  (*package* *package*)
696                  (jvm::*functions-defined-in-current-file* '())
697                  (*fbound-names* '())
698                  (*fasl-stream* out)
699                  *forms-for-output*)
700              (jvm::with-saved-compiler-policy
701                (jvm::with-file-compilation
702                    (handler-bind
703                        ((style-warning 
704                          #'(lambda (c)
705                              (setf warnings-p t)
706                              ;; let outer handlers do their thing
707                              (signal c)
708                              ;; prevent the next handler
709                              ;; from running: we're a
710                              ;; WARNING subclass
711                              (continue)))
712                         ((or warning compiler-error)
713                          #'(lambda (c)
714                              (declare (ignore c))
715                              (setf warnings-p t
716                                    failure-p t))))
717                      (loop
718                         (let* ((*source-position* (file-position in))
719                                (jvm::*source-line-number* (stream-line-number in))
720                                (form (read in nil in))
721                                (*compiler-error-context* form))
722                           (when (eq form in)
723                             (return))
724                           (process-toplevel-form form out nil))))
725                    (finalize-fasl-output)
726                    (dolist (name *fbound-names*)
727                      (fmakunbound name)))))))
728        (with-open-file (in temp-file :direction :input)
729          (with-open-file (out temp-file2 :direction :output
730                               :if-does-not-exist :create
731                               :if-exists :supersede)
732            (let ((*package* (find-package '#:cl))
733                  (*print-fasl* t)
734                  (*print-array* t)
735                  (*print-base* 10)
736                  (*print-case* :upcase)
737                  (*print-circle* nil)
738                  (*print-escape* t)
739                  (*print-gensym* t)
740                  (*print-length* nil)
741                  (*print-level* nil)
742                  (*print-lines* nil)
743                  (*print-pretty* nil)
744                  (*print-radix* nil)
745                  (*print-readably* t)
746                  (*print-right-margin* nil)
747                  (*print-structure* t)
748
749                  ;; make sure to write all floats with their exponent marker:
750                  ;; the dump-time default may not be the same at load-time
751
752                  (*read-default-float-format* nil))
753
754              ;; these values are also bound by WITH-STANDARD-IO-SYNTAX,
755              ;; but not used by our reader/printer, so don't bind them,
756              ;; for efficiency reasons.
757              ;;        (*read-eval* t)
758              ;;        (*read-suppress* nil)
759              ;;        (*print-miser-width* nil)
760              ;;        (*print-pprint-dispatch* (copy-pprint-dispatch nil))
761              ;;        (*read-base* 10)
762              ;;        (*read-default-float-format* 'single-float)
763              ;;        (*readtable* (copy-readtable nil))
764
765              (write-fasl-prologue out)
766              ;; copy remaining content
767              (loop for line = (read-line in nil :eof)
768                 while (not (eq line :eof))
769                 do (write-line line out)))))
770        (delete-file temp-file)
771        (remove-zip-cache-entry output-file) ;; Necessary under windows
772        (rename-file temp-file2 output-file)
773
774        (when *compile-file-zip*
775          (populate-zip-fasl output-file))
776
777        (when *compile-verbose*
778          (format t "~&; Wrote ~A (~A seconds)~%"
779                  (namestring output-file)
780                  (/ (- (get-internal-real-time) start) 1000.0)))))
781    (values (truename output-file) warnings-p failure-p)))
782
783(defun compile-file-if-needed (input-file &rest allargs &key force-compile
784                               &allow-other-keys)
785  (setf input-file (truename input-file))
786  (cond (force-compile
787         (remf allargs :force-compile)
788         (apply 'compile-file input-file allargs))
789        (t
790         (let* ((source-write-time (file-write-date input-file))
791                (output-file       (or (getf allargs :output-file)
792                                       (compile-file-pathname input-file)))
793                (target-write-time (and (probe-file output-file)
794                                        (file-write-date output-file))))
795           (if (or (null target-write-time)
796                   (<= target-write-time source-write-time))
797               (apply 'compile-file input-file allargs)
798               output-file)))))
799
800(provide 'compile-file)
Note: See TracBrowser for help on using the repository browser.