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

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

Fix COMPILE-FILE to use paths that have a printable representation.

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