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

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

Add infrastructure to record toplevel names of functions and macros.

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