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

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

Uncomment file-compilation of IMPORT forms.

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