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

Last change on this file since 14163 was 14163, checked in by ehuelsmann, 8 years ago

Fix LML load regression.

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