source: branches/less-reflection/abcl/src/org/armedbear/lisp/compile-file.lisp @ 12698

Last change on this file since 12698 was 12698, checked in by astalla, 11 years ago

Load class bytes on demand for disassemble.

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