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

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

Refactor PATHNAME implementation details to tighten existing semantics.

None of this should change the behavior of CL:PATHNAME, but it
prepares for that in subsequent patches to address problems in merging
when the defaults points to a JAR-PATHNAME.

Fix COMPILE-FILE to work with source located in jar archive.

Moved Utilities.getFile() to instance method of Pathname which makes
more logical sense. Moved Utilities.getPathnameDirectory() to static
instance classes. These functions no longer merge their argument with
*DEFAULT-PATHNAME-DEFAULTS*, as this should be done explictly at a
higher level in the Lisp calling into Java abstraction.

RENAME-FILE no longer on namestrings, but instead use the result of
TRUENAME invocation, as namestrings will not always roundtrip
exactly back to PATHNAMES.

POPULATE-ZIP-FASL no longer forms its argumentes by merging paths,
instead using MAKE-PATHNAME with controlled defaults.

SYSTEM:NEXT-CLASSFILE-NAME and SYSTEM:COMPUTE-CLASSFILE-NAME changed
to NEXT-CLASSFILE and COMPUTE-CLASSFILE returning PATHNAME objects
rather than namestrings.

Compiler now dumps pathname in alternate form that preserves DEVICE
:UNSPECIFIC.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Id
File size: 40.0 KB
Line 
1
2;;; compile-file.lisp
3;;;
4;;; Copyright (C) 2004-2006 Peter Graves
5;;; $Id: compile-file.lisp 14176 2012-10-11 11:33:19Z 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(defvar *debug-compile-from-stream* nil)
719(defun compile-from-stream (in output-file temp-file temp-file2
720                            extract-toplevel-funcs-and-macros
721                            functions-file macros-file exports-file)
722  (let* ((*compile-file-pathname* (make-pathname :defaults (pathname in)
723                                                 :version nil))
724         (*compile-file-truename* (make-pathname :defaults (truename in)
725                                                 :version nil))
726         (*source* *compile-file-truename*)
727         (*class-number* 0)
728         (namestring (namestring *compile-file-truename*))
729         (start (get-internal-real-time))
730         *fasl-uninterned-symbols*)
731    (setf *debug-compile-from-stream* 
732          (list :in in
733                :compile-file-pathname *compile-file-pathname*))
734    (when *compile-verbose*
735      (format t "; Compiling ~A ...~%" namestring))
736    (with-compilation-unit ()
737      (with-open-file (out temp-file
738                           :direction :output :if-exists :supersede
739                           :external-format *fasl-external-format*)
740        (let ((*readtable* *readtable*)
741              (*read-default-float-format* *read-default-float-format*)
742              (*read-base* *read-base*)
743              (*package* *package*)
744              (jvm::*functions-defined-in-current-file* '())
745              (*fbound-names* '())
746              (*fasl-stream* out)
747              *forms-for-output*)
748          (jvm::with-saved-compiler-policy
749            (jvm::with-file-compilation
750              (handler-bind
751                  ((style-warning 
752                    #'(lambda (c)
753                        (setf warnings-p t)
754                        ;; let outer handlers do their thing
755                        (signal c)
756                        ;; prevent the next handler
757                        ;; from running: we're a
758                        ;; WARNING subclass
759                        (continue)))
760                   ((or warning compiler-error)
761                    #'(lambda (c)
762                        (declare (ignore c))
763                        (setf warnings-p t
764                              failure-p t))))
765                (loop
766                   (let* ((*source-position* (file-position in))
767                          (jvm::*source-line-number* (stream-line-number in))
768                          (form (read in nil in))
769                          (*compiler-error-context* form))
770                     (when (eq form in)
771                       (return))
772                     (process-toplevel-form form out nil))))
773                    (finalize-fasl-output)
774                    (dolist (name *fbound-names*)
775                      (fmakunbound name)))))))
776        (when extract-toplevel-funcs-and-macros
777          (setf *toplevel-functions*
778                (remove-if-not (lambda (func-name)
779                                 (if (symbolp func-name)
780                                     (symbol-package func-name)
781                                     T))
782                               (remove-duplicates *toplevel-functions*)))
783          (when *toplevel-functions*
784            (with-open-file (f-out functions-file
785                                   :direction :output
786                                   :if-does-not-exist :create
787                                   :if-exists :supersede)
788
789              (let ((*package* (find-package :keyword)))
790                (write *toplevel-functions* :stream f-out))))
791          (setf *toplevel-macros*
792                (remove-if-not (lambda (mac-name)
793                                 (if (symbolp mac-name)
794                                     (symbol-package mac-name)
795                                     T))
796                               (remove-duplicates *toplevel-macros*)))
797          (when *toplevel-macros*
798            (with-open-file (m-out macros-file
799                                   :direction :output
800                                   :if-does-not-exist :create
801                                   :if-exists :supersede)
802              (let ((*package* (find-package :keyword)))
803                (write *toplevel-macros* :stream m-out))))
804          (setf *toplevel-exports*
805                (remove-if-not (lambda (sym)
806                                 (if (symbolp sym)
807                                     (symbol-package sym)
808                                     T))
809                               (remove-duplicates *toplevel-exports*)))
810          (when *toplevel-exports*
811            (with-open-file (e-out exports-file
812                                   :direction :output
813                                   :if-does-not-exist :create
814                                   :if-exists :supersede)
815              (let ((*package* (find-package :keyword)))
816                (write *toplevel-exports* :stream e-out)))))
817        (with-open-file (in temp-file :direction :input)
818          (with-open-file (out temp-file2 :direction :output
819                               :if-does-not-exist :create
820                               :if-exists :supersede)
821            (let ((*package* (find-package '#:cl))
822                  (*print-fasl* t)
823                  (*print-array* t)
824                  (*print-base* 10)
825                  (*print-case* :upcase)
826                  (*print-circle* nil)
827                  (*print-escape* t)
828                  (*print-gensym* t)
829                  (*print-length* nil)
830                  (*print-level* nil)
831                  (*print-lines* nil)
832                  (*print-pretty* nil)
833                  (*print-radix* nil)
834                  (*print-readably* t)
835                  (*print-right-margin* nil)
836                  (*print-structure* t)
837
838                  ;; make sure to write all floats with their exponent marker:
839                  ;; the dump-time default may not be the same at load-time
840
841                  (*read-default-float-format* nil))
842
843              ;; these values are also bound by WITH-STANDARD-IO-SYNTAX,
844              ;; but not used by our reader/printer, so don't bind them,
845              ;; for efficiency reasons.
846              ;;        (*read-eval* t)
847              ;;        (*read-suppress* nil)
848              ;;        (*print-miser-width* nil)
849              ;;        (*print-pprint-dispatch* (copy-pprint-dispatch nil))
850              ;;        (*read-base* 10)
851              ;;        (*read-default-float-format* 'single-float)
852              ;;        (*readtable* (copy-readtable nil))
853
854              (write-fasl-prologue out)
855              ;; copy remaining content
856              (loop for line = (read-line in nil :eof)
857                 while (not (eq line :eof))
858                 do (write-line line out)))))
859        (delete-file temp-file)
860        (when (find :windows *features*)
861          (remove-zip-cache-entry output-file))
862        (rename-file temp-file2 output-file)
863
864        (when *compile-file-zip*
865          (populate-zip-fasl output-file))
866
867        (when *compile-verbose*
868          (format t "~&; Wrote ~A (~A seconds)~%"
869                  (namestring output-file)
870                  (/ (- (get-internal-real-time) start) 1000.0)))) )
871
872(defun compile-file (input-file
873                     &key
874                     output-file
875                     ((:verbose *compile-verbose*) *compile-verbose*)
876                     ((:print *compile-print*) *compile-print*)
877                     (extract-toplevel-funcs-and-macros nil)
878                     external-format)
879  (declare (ignore external-format))    ; FIXME
880  (flet ((pathname-with-type (pathname type &optional suffix)
881           (when suffix
882             (setq type (concatenate 'string type suffix)))
883           (make-pathname :type type :defaults pathname)))
884    (unless (or (and (probe-file input-file)
885                     (not (file-directory-p input-file)))
886                (pathname-type input-file))
887      (let ((pathname (pathname-with-type input-file "lisp")))
888        (when (probe-file pathname)
889          (setf input-file pathname))))
890    (setf output-file
891          (make-pathname :defaults
892                         (if output-file
893                             (merge-pathnames output-file
894                                              *default-pathname-defaults*)
895                             (compile-file-pathname input-file))
896                         :version nil))
897    (let* ((*output-file-pathname* output-file)
898           (type (pathname-type output-file))
899           (temp-file (pathname-with-type output-file type "-tmp"))
900           (temp-file2 (pathname-with-type output-file type "-tmp2"))
901           (functions-file (pathname-with-type output-file "funcs"))
902           (macros-file (pathname-with-type output-file "macs"))
903           (exports-file (pathname-with-type output-file "exps"))
904           *toplevel-functions*
905           *toplevel-macros*
906           *toplevel-exports*
907           (warnings-p nil)
908           (failure-p nil))
909      (with-open-file (in input-file :direction :input)
910        (compile-from-stream in output-file temp-file temp-file2
911                             extract-toplevel-funcs-and-macros
912                             functions-file macros-file exports-file))
913      (values (truename output-file) warnings-p failure-p))))
914
915(defun compile-file-if-needed (input-file &rest allargs &key force-compile
916                               &allow-other-keys)
917  (setf input-file (truename input-file))
918  (cond (force-compile
919         (remf allargs :force-compile)
920         (apply 'compile-file input-file allargs))
921        (t
922         (let* ((source-write-time (file-write-date input-file))
923                (output-file       (or (getf allargs :output-file)
924                                       (compile-file-pathname input-file)))
925                (target-write-time (and (probe-file output-file)
926                                        (file-write-date output-file))))
927           (if (or (null target-write-time)
928                   (<= target-write-time source-write-time))
929               (apply #'compile-file input-file allargs)
930               output-file)))))
931
932(provide 'compile-file)
Note: See TracBrowser for help on using the repository browser.