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

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

compiler: don't signal conditions for fasl verification error and muffle diagnostics by default.

HEADS UP: problems seem to exist ANSI tests, which triggers the
attempt to load the fasl classfile to verify its integrity.

Don't signal problems just yet, until satisfied that the correct
diagnostic messages are being triggered.

Refactored diagnostics interface to use a new SYS::DIAG macro whose output is
directed to the value of SYS:*COMPILER-DIAGNOSTIC*. This should be
reconsidered in view of all the diagnostic frameworks when I
understand how they are to be used

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