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

Last change on this file since 12306 was 12306, checked in by ehuelsmann, 12 years ago

Land fast-boot-preloading branch on trunk.

Note: things to do include

  1. Applying the same strategy to macro functions
  2. Applying the same strategy to functions which get loaded during

EVAL-WHEN when compiling

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