source: branches/0.20.x/abcl/src/org/armedbear/lisp/compile-file.lisp

Last change on this file was 12650, checked in by ehuelsmann, 16 years ago

Fix #79: Equally named -but different- uninterned symbols coalesced into
one in FASLs.

This commit removes the *FASL-ANONYMOUS-PACKAGE*: it's replaced by
*FASL-UNINTERNED-SYMBOLS* and a dispatch macro function which resolves
symbols by index instead of by name.
  • Property svn:eol-style set to native
  • Property svn:keywords set to Id
File size: 30.0 KB
Line 
1;;; compile-file.lisp
2;;;
3;;; Copyright (C) 2004-2006 Peter Graves
4;;; $Id: compile-file.lisp 12650 2010-05-02 19:58:56Z 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(declaim (ftype (function (t) t) compute-classfile-name))
44(defun compute-classfile-name (n &optional (output-file-pathname
45                                            *output-file-pathname*))
46  "Computes the name of the class file associated with number `n'."
47  (let ((name
48         (%format nil "~A-~D"
49                  (substitute #\_ #\.
50                              (pathname-name output-file-pathname)) n)))
51    (namestring (merge-pathnames (make-pathname :name name :type "cls")
52                                 output-file-pathname))))
53
54(declaim (ftype (function () t) next-classfile-name))
55(defun next-classfile-name ()
56  (compute-classfile-name (incf *class-number*)))
57
58(defmacro report-error (&rest forms)
59  `(handler-case (progn ,@forms)
60     (compiler-unsupported-feature-error (condition)
61       (fresh-line)
62       (%format t "; UNSUPPORTED-FEATURE: ~A~%" condition)
63       (values nil condition))))
64
65;; Dummy function. Should never be called.
66(defun dummy (&rest ignored)
67  (declare (ignore ignored))
68  (assert nil))
69
70(declaim (ftype (function (t) t) verify-load))
71(defun verify-load (classfile)
72  (if (> *safety* 0)
73    (and classfile
74         (let ((*load-truename* *output-file-pathname*))
75           (report-error
76            (load-compiled-function classfile))))
77    t))
78
79(declaim (ftype (function (t) t) process-defconstant))
80(defun process-defconstant (form)
81  ;; "If a DEFCONSTANT form appears as a top level form, the compiler
82  ;; must recognize that [the] name names a constant variable. An
83  ;; implementation may choose to evaluate the value-form at compile
84  ;; time, load time, or both. Therefore, users must ensure that the
85  ;; initial-value can be evaluated at compile time (regardless of
86  ;; whether or not references to name appear in the file) and that
87  ;; it always evaluates to the same value."
88  (eval form)
89  (output-form form))
90
91(declaim (ftype (function (t) t) note-toplevel-form))
92(defun note-toplevel-form (form)
93  (when *compile-print*
94    (fresh-line)
95    (princ "; ")
96    (let ((*print-length* 2)
97          (*print-level* 2)
98          (*print-pretty* nil))
99      (prin1 form))
100    (terpri)))
101
102(declaim (ftype (function (t stream t) t) process-toplevel-form))
103(defun process-toplevel-form (form stream compile-time-too)
104  (if (atom form)
105      (when compile-time-too
106        (eval form))
107    (progn
108      (let ((operator (%car form)))
109        (case operator
110          (MACROLET
111           (process-toplevel-macrolet form stream compile-time-too)
112           (return-from process-toplevel-form))
113          ((IN-PACKAGE DEFPACKAGE)
114           (note-toplevel-form form)
115           (setf form (precompiler:precompile-form form nil *compile-file-environment*))
116           (eval form)
117           ;; Force package prefix to be used when dumping form.
118           (let ((*package* +keyword-package+))
119             (output-form form))
120           (return-from process-toplevel-form))
121          ((DEFVAR DEFPARAMETER)
122           (note-toplevel-form form)
123           (if compile-time-too
124               (eval form)
125               ;; "If a DEFVAR or DEFPARAMETER form appears as a top level form,
126               ;; the compiler must recognize that the name has been proclaimed
127               ;; special. However, it must neither evaluate the initial-value
128               ;; form nor assign the dynamic variable named NAME at compile
129               ;; time."
130               (let ((name (second form)))
131                 (%defvar name))))
132          (DEFCONSTANT
133           (note-toplevel-form form)
134           (process-defconstant form)
135           (return-from process-toplevel-form))
136          (DEFUN
137           (note-toplevel-form form)
138           (let* ((name (second form))
139                  (block-name (fdefinition-block-name name))
140                  (lambda-list (third form))
141                  (body (nthcdr 3 form)))
142             (jvm::with-saved-compiler-policy
143               (multiple-value-bind (body decls doc)
144                   (parse-body body)
145                 (let* ((expr `(lambda ,lambda-list
146                                 ,@decls (block ,block-name ,@body)))
147                        (classfile (next-classfile-name))
148                        (internal-compiler-errors nil)
149                        (result (with-open-file
150            (f classfile
151               :direction :output
152               :element-type '(unsigned-byte 8)
153               :if-exists :supersede)
154                                  (handler-bind 
155                                      ((internal-compiler-error
156                                        #'(lambda (e)
157                                            (push e internal-compiler-errors)
158                                            (continue))))
159                                    (report-error
160                                     (jvm:compile-defun name expr nil
161                                                        classfile f nil)))))
162                        (compiled-function (if (not internal-compiler-errors)
163                                               (verify-load classfile)
164                                               nil)))
165       (declare (ignore result))
166                   (cond
167                     ((and (not internal-compiler-errors)
168                           compiled-function)
169                      (setf form
170                            `(fset ',name
171                                   (proxy-preloaded-function ',name ,(file-namestring classfile))
172                                   ,*source-position*
173                                   ',lambda-list
174                                   ,doc))
175                      (when compile-time-too
176                        (fset name compiled-function)))
177                     (t
178                      ;; Add this warning when the stock ABCL compiles
179                      ;; again, as all warnings in COMPILE-SYSTEM
180                      ;; produce a non-zero exit status that stops
181                      ;; build.xml in its tracks.
182                      #+nil
183                      (compiler-warn "Unable to compile function ~A.  Using interpreted form instead.~%" name)
184                      (format *error-output*
185                              "; Unable to compile function ~A.  Using interpreted form instead.~%" name)
186                      (when internal-compiler-errors
187                        (dolist (e internal-compiler-errors)
188                          (format *error-output*
189                                  "; ~A~%" e)))
190                      (let ((precompiled-function
191                             (precompiler:precompile-form expr nil
192                                              *compile-file-environment*)))
193                        (setf form
194                              `(fset ',name
195                                     ,precompiled-function
196                                     ,*source-position*
197                                     ',lambda-list
198                                     ,doc)))
199                      (when compile-time-too
200                        (eval form)))))
201                 (when (and (symbolp name) (eq (get name '%inline) 'INLINE))
202                 ;; FIXME Need to support SETF functions too!
203                   (setf (inline-expansion name)
204                         (jvm::generate-inline-expansion block-name
205                                                         lambda-list body))
206                   (output-form `(setf (inline-expansion ',name)
207                                       ',(inline-expansion name))))))
208             (push name jvm::*functions-defined-in-current-file*)
209             (note-name-defined name)
210             ;; If NAME is not fbound, provide a dummy definition so that
211             ;; getSymbolFunctionOrDie() will succeed when we try to verify that
212             ;; functions defined later in the same file can be loaded correctly.
213             (unless (fboundp name)
214               (setf (fdefinition name) #'dummy)
215               (push name *fbound-names*))))
216          ((DEFGENERIC DEFMETHOD)
217           (note-toplevel-form form)
218           (note-name-defined (second form))
219           (let ((*compile-print* nil))
220             (process-toplevel-form (macroexpand-1 form *compile-file-environment*)
221                                    stream compile-time-too))
222             (return-from process-toplevel-form))
223          (DEFMACRO
224           (note-toplevel-form form)
225           (let ((name (second form)))
226             (eval form)
227             (let* ((expr (function-lambda-expression (macro-function name)))
228                    (classfile (next-classfile-name)))
229         (with-open-file
230       (f classfile
231          :direction :output
232          :element-type '(unsigned-byte 8)
233          :if-exists :supersede)
234     (ignore-errors
235       (jvm:compile-defun nil expr nil classfile f nil)))
236               (if (null (verify-load classfile))
237                   ;; FIXME error or warning
238                   (format *error-output* "; Unable to compile macro ~A~%" name)
239                 (progn
240                   (setf form
241                         (if (special-operator-p name)
242                             `(put ',name 'macroexpand-macro
243                                   (make-macro ',name
244                                               (proxy-preloaded-function
245                                                '(macro-function ,name)
246                                                ,(file-namestring classfile))))
247                             `(fset ',name
248                                    (make-macro ',name
249                                                (proxy-preloaded-function
250                                                 '(macro-function ,name)
251                                                 ,(file-namestring classfile)))
252                                    ,*source-position*
253                                    ',(third form)))))))))
254          (DEFTYPE
255           (note-toplevel-form form)
256           (eval form))
257          (EVAL-WHEN
258           (multiple-value-bind (ct lt e)
259               (parse-eval-when-situations (cadr form))
260             (let ((new-compile-time-too (or ct (and compile-time-too e)))
261                   (body (cddr form)))
262               (if lt
263                   (process-toplevel-progn body stream new-compile-time-too)
264                 (when new-compile-time-too
265                   (eval `(progn ,@body)))))
266           (return-from process-toplevel-form)))
267          (LOCALLY
268           ;; FIXME Need to handle special declarations too!
269           (jvm::with-saved-compiler-policy
270             (multiple-value-bind (forms decls)
271                 (parse-body (cdr form) nil)
272               (process-optimization-declarations decls)
273               (let* ((jvm::*visible-variables* jvm::*visible-variables*)
274                      (specials (jvm::process-declarations-for-vars (cdr form)
275                                                                    nil nil)))
276                 (dolist (special specials)
277                   (push special jvm::*visible-variables*))
278                 (process-toplevel-progn forms stream compile-time-too))
279               (return-from process-toplevel-form))))
280          (PROGN
281           (process-toplevel-progn (cdr form) stream compile-time-too)
282           (return-from process-toplevel-form))
283          (DECLARE
284           (compiler-style-warn "Misplaced declaration: ~S" form))
285          (t
286           (when (and (symbolp operator)
287                      (macro-function operator *compile-file-environment*))
288             (note-toplevel-form form)
289             ;; Note that we want MACROEXPAND-1 and not MACROEXPAND here, in
290             ;; case the form being expanded expands into something that needs
291             ;; special handling by PROCESS-TOPLEVEL-FORM (e.g. DEFMACRO).
292             (let ((*compile-print* nil))
293               (process-toplevel-form (macroexpand-1 form *compile-file-environment*)
294                                      stream compile-time-too))
295             (return-from process-toplevel-form))
296
297           (cond ((eq operator 'QUOTE)
298;;;                      (setf form (precompiler:precompile-form form nil
299;;;                                                  *compile-file-environment*))
300                  (when compile-time-too
301                    (eval form))
302                  (return-from process-toplevel-form))
303                 ((eq operator 'PUT)
304                  (setf form (precompiler:precompile-form form nil *compile-file-environment*)))
305                 ((eq operator 'COMPILER-DEFSTRUCT)
306                  (setf form (precompiler:precompile-form form nil *compile-file-environment*)))
307                 ((eq operator 'PROCLAIM)
308                  (setf form (precompiler:precompile-form form nil *compile-file-environment*)))
309                 ((and (memq operator '(EXPORT REQUIRE PROVIDE SHADOW))
310                       (or (keywordp (second form))
311                           (and (listp (second form))
312                                (eq (first (second form)) 'QUOTE))))
313                  (setf form (precompiler:precompile-form form nil *compile-file-environment*)))
314                 ((eq operator 'IMPORT)
315                  (setf form (precompiler:precompile-form form nil *compile-file-environment*))
316                  ;; Make sure package prefix is printed when symbols are imported.
317                  (let ((*package* +keyword-package+))
318                    (output-form form))
319                  (when compile-time-too
320                    (eval form))
321                  (return-from process-toplevel-form))
322                 ((and (eq operator '%SET-FDEFINITION)
323                       (eq (car (second form)) 'QUOTE)
324                       (consp (third form))
325                       (eq (%car (third form)) 'FUNCTION)
326                       (symbolp (cadr (third form))))
327                  (setf form (precompiler:precompile-form form nil *compile-file-environment*)))
328;;;                     ((memq operator '(LET LET*))
329;;;                      (let ((body (cddr form)))
330;;;                        (if (dolist (subform body nil)
331;;;                              (when (and (consp subform) (eq (%car subform) 'DEFUN))
332;;;                                (return t)))
333;;;                            (setf form (convert-toplevel-form form))
334;;;                            (setf form (precompiler:precompile-form form nil)))))
335                 ((eq operator 'mop::ensure-method)
336                  (setf form (convert-ensure-method form)))
337                 ((and (symbolp operator)
338                       (not (special-operator-p operator))
339                       (null (cdr form)))
340                  (setf form (precompiler:precompile-form form nil *compile-file-environment*)))
341                 (t
342;;;                      (setf form (precompiler:precompile-form form nil))
343                  (note-toplevel-form form)
344                  (setf form (convert-toplevel-form form nil)))))))))
345  (when (consp form)
346    (output-form form))
347  ;; Make sure the compiled-function loader knows where
348  ;; to load the compiled functions. Note that this trickery
349  ;; was already used in verify-load before I used it,
350  ;; however, binding *load-truename* isn't fully compliant, I think.
351  (let ((*load-truename* *output-file-pathname*))
352    (when compile-time-too
353      (eval form))))
354
355(declaim (ftype (function (t) t) convert-ensure-method))
356(defun convert-ensure-method (form)
357  (c-e-m-1 form :function)
358  (c-e-m-1 form :fast-function)
359  (precompiler:precompile-form form nil *compile-file-environment*))
360
361(declaim (ftype (function (t t) t) c-e-m-1))
362(defun c-e-m-1 (form key)
363  (let* ((tail (cddr form))
364         (function-form (getf tail key)))
365    (when (and function-form (consp function-form)
366               (eq (%car function-form) 'FUNCTION))
367      (let ((lambda-expression (cadr function-form)))
368        (jvm::with-saved-compiler-policy
369          (let* ((classfile (next-classfile-name))
370                 (result
371      (with-open-file
372          (f classfile
373       :direction :output
374       :element-type '(unsigned-byte 8)
375       :if-exists :supersede)
376        (report-error
377         (jvm:compile-defun nil lambda-expression nil classfile f nil))))
378                 (compiled-function (verify-load classfile)))
379      (declare (ignore result))
380            (cond (compiled-function
381                   (setf (getf tail key)
382                         `(load-compiled-function ,(file-namestring classfile))))
383                  (t
384                   ;; FIXME This should be a warning or error of some sort...
385                   (format *error-output* "; Unable to compile method~%")))))))))
386
387(declaim (ftype (function (t) t) simple-toplevel-form-p))
388(defun simple-toplevel-form-p (form)
389  "Returns NIL if the form is too complex to become an
390interpreted toplevel form, non-NIL if it is 'simple enough'."
391  (and (consp form)
392             (every #'(lambda (arg)
393                        (or (and (atom arg)
394                                 (not (and (symbolp arg)
395                                           (symbol-macro-p arg))))
396                            (and (consp arg)
397                                 (eq 'QUOTE (car arg)))))
398              (cdr form))))
399
400(declaim (ftype (function (t t) t) convert-toplevel-form))
401(defun convert-toplevel-form (form declare-inline)
402  (when (or (simple-toplevel-form-p form)
403            (and (eq (car form) 'SETQ)
404                 ;; for SETQ, look at the evaluated part
405                 (simple-toplevel-form-p (third form))))
406    ;; single form with simple or constant arguments
407    ;; Without this exception, toplevel function calls
408    ;; will be compiled into lambdas which get compiled to
409    ;; compiled-functions. Those need to be loaded.
410    ;; Conclusion: Top level interpreting the function call
411    ;;  and its arguments may be (and should be) more efficient.
412    (return-from convert-toplevel-form
413      (precompiler:precompile-form form nil *compile-file-environment*)))
414  (let* ((expr `(lambda () ,form))
415         (classfile (next-classfile-name))
416         (result
417    (with-open-file
418        (f classfile
419     :direction :output
420     :element-type '(unsigned-byte 8)
421     :if-exists :supersede)
422      (report-error (jvm:compile-defun nil expr nil classfile
423                                             f declare-inline))))
424         (compiled-function (verify-load classfile)))
425    (declare (ignore result))
426    (setf form
427          (if compiled-function
428              `(funcall (load-compiled-function ,(file-namestring classfile)))
429              (precompiler:precompile-form form nil *compile-file-environment*)))))
430
431
432(defun process-toplevel-macrolet (form stream compile-time-too)
433  (let ((*compile-file-environment* (make-environment *compile-file-environment*)))
434    (dolist (definition (cadr form))
435      (environment-add-macro-definition *compile-file-environment*
436                                        (car definition)
437                                        (make-macro (car definition)
438                                                    (make-expander-for-macrolet definition))))
439    (dolist (body-form (cddr form))
440      (process-toplevel-form body-form stream compile-time-too))))
441
442(declaim (ftype (function (t stream t) t) process-toplevel-progn))
443(defun process-toplevel-progn (forms stream compile-time-too)
444  (dolist (form forms)
445    (process-toplevel-form form stream compile-time-too)))
446
447;;; Adapted from SBCL.
448;;; Parse an EVAL-WHEN situations list, returning three flags,
449;;; (VALUES COMPILE-TOPLEVEL LOAD-TOPLEVEL EXECUTE), indicating
450;;; the types of situations present in the list.
451(defun parse-eval-when-situations (situations)
452  (when (or (not (listp situations))
453      (set-difference situations
454          '(:compile-toplevel
455            compile
456            :load-toplevel
457            load
458            :execute
459            eval)))
460    (error "Bad EVAL-WHEN situation list: ~S." situations))
461  (values (intersection '(:compile-toplevel compile) situations)
462    (intersection '(:load-toplevel load) situations)
463    (intersection '(:execute eval) situations)))
464
465
466(defvar *binary-fasls* nil)
467(defvar *forms-for-output* nil)
468(defvar *fasl-stream* nil)
469
470(defun output-form (form)
471  (if *binary-fasls*
472      (push form *forms-for-output*)
473      (progn
474        (dump-form form *fasl-stream*)
475        (%stream-terpri *fasl-stream*))))
476
477(defun finalize-fasl-output ()
478  (when *binary-fasls*
479    (let ((*package* (find-package :keyword))
480          (*double-colon-package-separators* T))
481      (dump-form (convert-toplevel-form (list* 'PROGN
482                                               (nreverse *forms-for-output*))
483                                        t)
484                 *fasl-stream*))
485    (%stream-terpri *fasl-stream*)))
486
487(defun compile-file (input-file
488                     &key
489                     output-file
490                     ((:verbose *compile-verbose*) *compile-verbose*)
491                     ((:print *compile-print*) *compile-print*)
492                     external-format)
493  (declare (ignore external-format))    ; FIXME
494  (unless (or (and (probe-file input-file) (not (file-directory-p input-file)))
495              (pathname-type input-file))
496    (let ((pathname (merge-pathnames (make-pathname :type "lisp") input-file)))
497      (when (probe-file pathname)
498        (setf input-file pathname))))
499  (setf output-file (if output-file
500                        (merge-pathnames output-file *default-pathname-defaults*)
501                        (compile-file-pathname input-file)))
502  (let* ((*output-file-pathname* output-file)
503         (type (pathname-type output-file))
504         (temp-file (merge-pathnames (make-pathname :type (concatenate 'string type "-tmp"))
505                                     output-file))
506         (temp-file2 (merge-pathnames (make-pathname :type (concatenate 'string type "-tmp2"))
507                                     output-file))
508         (warnings-p nil)
509         (failure-p nil))
510    (with-open-file (in input-file :direction :input)
511      (let* ((*compile-file-pathname* (pathname in))
512             (*compile-file-truename* (truename in))
513             (*source* *compile-file-truename*)
514             (*class-number* 0)
515             (namestring (namestring *compile-file-truename*))
516             (start (get-internal-real-time))
517             elapsed
518             *fasl-uninterned-symbols*)
519        (when *compile-verbose*
520          (format t "; Compiling ~A ...~%" namestring))
521        (with-compilation-unit ()
522          (with-open-file (out temp-file
523                               :direction :output :if-exists :supersede
524                               :external-format *fasl-external-format*)
525            (let ((*readtable* *readtable*)
526                  (*read-default-float-format* *read-default-float-format*)
527                  (*read-base* *read-base*)
528                  (*package* *package*)
529                  (jvm::*functions-defined-in-current-file* '())
530                  (*fbound-names* '())
531                  (*fasl-stream* out)
532                  *forms-for-output*)
533              (jvm::with-saved-compiler-policy
534                (jvm::with-file-compilation
535                    (handler-bind ((style-warning 
536                                    #'(lambda (c)
537                                        (setf warnings-p t)
538                                        ;; let outer handlers do their thing
539                                        (signal c)
540                                        ;; prevent the next handler
541                                        ;; from running: we're a
542                                        ;; WARNING subclass
543                                        (continue)))
544                                   ((or warning 
545                                        compiler-error)
546                                    #'(lambda (c)
547                                        (declare (ignore c))
548                                        (setf warnings-p t
549                                              failure-p t))))
550                      (loop
551                         (let* ((*source-position* (file-position in))
552                                (jvm::*source-line-number* (stream-line-number in))
553                                (form (read in nil in))
554                                (*compiler-error-context* form))
555                           (when (eq form in)
556                             (return))
557                           (process-toplevel-form form out nil))))
558                    (finalize-fasl-output)
559                    (dolist (name *fbound-names*)
560                      (fmakunbound name)))))))
561        (with-open-file (in temp-file :direction :input)
562          (with-open-file (out temp-file2 :direction :output
563                               :if-does-not-exist :create
564                               :if-exists :supersede)
565            ;; write header
566            (write "; -*- Mode: Lisp -*-" :escape nil :stream out)
567            (%stream-terpri out)
568            (let ((*package* (find-package '#:cl)))
569              (write (list 'init-fasl :version *fasl-version*)
570                     :stream out)
571              (%stream-terpri out)
572              (write (list 'setq '*source* *compile-file-truename*)
573                     :stream out)
574              (%stream-terpri out)
575              ;; Note: Beyond this point, you can't use DUMP-FORM,
576              ;; because the list of uninterned symbols has been fixed now.
577              (when *fasl-uninterned-symbols*
578                (write (list 'setq '*fasl-uninterned-symbols*
579                             (coerce (mapcar #'car
580                                             (nreverse *fasl-uninterned-symbols*))
581                                     'vector))
582                       :stream out))
583              (%stream-terpri out)
584              ;; we work with a fixed variable name here to work around the
585              ;; lack of availability of the circle reader in the fasl reader
586              ;; but it's a toplevel form anyway
587              (write `(dotimes (i ,*class-number*)
588                        (function-preload
589                         (%format nil "~A-~D.cls"
590                                  ,(substitute #\_ #\. (pathname-name output-file))
591                                  (1+ i))))
592                     :stream out
593                     :circle t)
594              (%stream-terpri out))
595
596
597            ;; copy remaining content
598            (loop for line = (read-line in nil :eof)
599               while (not (eq line :eof))
600               do (write-line line out))))
601        (delete-file temp-file)
602  (remove-zip-cache-entry output-file) ;; Necessary under windows
603        (rename-file temp-file2 output-file)
604
605        (when *compile-file-zip*
606          (let* ((type ;; Don't use ".zip", it'll result in an extension
607                  ;;  with a dot, which is rejected by NAMESTRING
608                  (%format nil "~A~A" (pathname-type output-file) "-zip"))
609                 (zipfile (namestring
610                           (merge-pathnames (make-pathname :type type)
611                                            output-file)))
612                 (pathnames ()))
613            (dotimes (i *class-number*)
614              (let* ((pathname (compute-classfile-name (1+ i))))
615                (when (probe-file pathname)
616                  (push pathname pathnames))))
617            (setf pathnames (nreverse pathnames))
618            (let ((load-file (merge-pathnames (make-pathname :type "_")
619                                              output-file)))
620              (rename-file output-file load-file)
621              (push load-file pathnames))
622            (zip zipfile pathnames)
623            (dolist (pathname pathnames)
624              (let ((truename (probe-file pathname)))
625                (when truename
626                  (delete-file truename))))
627            (rename-file zipfile output-file)))
628
629        (setf elapsed (/ (- (get-internal-real-time) start) 1000.0))
630        (when *compile-verbose*
631          (format t "~&; Wrote ~A (~A seconds)~%"
632                  (namestring output-file) elapsed))))
633    (values (truename output-file) warnings-p failure-p)))
634
635(defun compile-file-if-needed (input-file &rest allargs &key force-compile
636                               &allow-other-keys)
637  (setf input-file (truename input-file))
638  (cond (force-compile
639         (remf allargs :force-compile)
640         (apply 'compile-file input-file allargs))
641        (t
642         (let* ((source-write-time (file-write-date input-file))
643                (output-file       (or (getf allargs :output-file)
644                                       (compile-file-pathname input-file)))
645                (target-write-time (and (probe-file output-file)
646                                        (file-write-date output-file))))
647           (if (or (null target-write-time)
648                   (<= target-write-time source-write-time))
649               (apply 'compile-file input-file allargs)
650               output-file)))))
651
652(provide 'compile-file)
Note: See TracBrowser for help on using the repository browser.