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

Last change on this file since 14020 was 14020, checked in by ehuelsmann, 9 years ago

Document what I've explained to Mark this morning.

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