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

Last change on this file since 14002 was 14002, checked in by Mark Evenson, 9 years ago

dmiles: SYS:*COMPILE-FILE-CLASS-EXTENSION* contains PATHNAME TYPE of compiled JVM artifacts.

The default "cls" of compiled JVM artifacts was chosen to easily
differentiate bewtween JVM artifacts not produced by ABCL and those
which are the JVM bytecode of the ABCL Java 5.0 compiler. During the
bootstrapping and subsequent debugging of the current compiler, this
distinction has proven more useful than giving ABCL produced artifacts
the default "class" CL:PATHNAME TYPE.

This change facilitates the bootstrapping of [running ABCL on the MSFT
.NET CLR underway by dmiles][abcl-ikvm]

[abcl-ikvm]: http://code.google.com/r/logicmoo-abcl-ikvm

dmiles: Implementation of ticket #34.

dmiles: It makes no change at first but makes implmentation satisfactory to my
initial request.

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