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