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

Last change on this file since 14212 was 14212, checked in by Mark Evenson, 8 years ago

Fixes #255 so that COMPILE-FILE now handles :EXTERNAL-FORMAT correctly.

Remove debugging code from previous work.

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