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

Last change on this file since 13912 was 13912, checked in by Mark Evenson, 10 years ago

compiler: refuse to load zero-length JVM fasls; added diagnostics.

Additionally, if for the ANSI compiler proclamations the condition (>
*DEBUG* *SAFETY*) is true, actually load the compiled fasl in the
executing JVM. This is a potentially slow operation, but it certainly
makes further execution safer.

If the ANSI proclamination *DEBUG* is non-zero, set the appropiate
plists of symbols containing values of the associatioed compiled
representation.

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