Context Navigation

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

Visit:

Last change on this file was 13604, checked in by ehuelsmann, 14 years ago
Bump FASL format because of the now supported circularity: even though we're backward compatible, older versions aren't forward compatible.
Property svn:eol-style set to `native` Property svn:keywords set to `Id`
File size: 34.0 KB

Line
1	;;; compile-file.lisp
2	;;;
3	;;; Copyright (C) 2004-2006 Peter Graves
4	;;; $Id: compile-file.lisp 13604 2011-09-20 20:26:31Z 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	(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) note-toplevel-form))
98	(defun note-toplevel-form (form)
99	(when compile-print
100	(fresh-line)
101	(princ "; ")
102	(let ((print-length 2)
103	(print-level 2)
104	(print-pretty nil))
105	(prin1 form))
106	(terpri)))
107
108	(defun output-form (form)
109	(if binary-fasls
110	(push form forms-for-output)
111	(progn
112	(dump-form form fasl-stream)
113	(%stream-terpri fasl-stream))))
114
115	(defun finalize-fasl-output ()
116	(when binary-fasls
117	(let ((package (find-package :keyword))
118	(double-colon-package-separators T))
119	(dump-form (convert-toplevel-form (list* 'PROGN
120	(nreverse forms-for-output))
121	t)
122	fasl-stream))
123	(%stream-terpri fasl-stream)))
124
125
126	(declaim (ftype (function (t) t) simple-toplevel-form-p))
127	(defun simple-toplevel-form-p (form)
128	"Returns NIL if the form is too complex to become an
129	interpreted toplevel form, non-NIL if it is 'simple enough'."
130	(and (consp form)
131	(every #'(lambda (arg)
132	(or (and (atom arg)
133	(not (and (symbolp arg)
134	(symbol-macro-p arg))))
135	(and (consp arg)
136	(eq 'QUOTE (car arg)))))
137	(cdr form))))
138
139	(declaim (ftype (function (t t) t) convert-toplevel-form))
140	(defun convert-toplevel-form (form declare-inline)
141	(when (or (simple-toplevel-form-p form)
142	(and (eq (car form) 'SETQ)
143	;; for SETQ, look at the evaluated part
144	(simple-toplevel-form-p (third form))))
145	;; single form with simple or constant arguments
146	;; Without this exception, toplevel function calls
147	;; will be compiled into lambdas which get compiled to
148	;; compiled-functions. Those need to be loaded.
149	;; Conclusion: Top level interpreting the function call
150	;; and its arguments may be (and should be) more efficient.
151	(return-from convert-toplevel-form
152	(precompiler:precompile-form form nil compile-file-environment)))
153	(let* ((expr `(lambda () ,form))
154	(saved-class-number class-number)
155	(classfile (next-classfile-name))
156	(result
157	(with-open-file
158	(f classfile
159	:direction :output
160	:element-type '(unsigned-byte 8)
161	:if-exists :supersede)
162	(report-error (jvm:compile-defun nil
163	expr compile-file-environment
164	classfile f declare-inline))))
165	(compiled-function (verify-load classfile)))
166	(declare (ignore result))
167	(setf form
168	(if compiled-function
169	`(funcall (sys::get-fasl-function fasl-loader
170	,saved-class-number))
171	(precompiler:precompile-form form nil
172	compile-file-environment)))))
173
174
175
176
177	(declaim (ftype (function (t stream t) t) process-progn))
178	(defun process-progn (forms stream compile-time-too)
179	(dolist (form forms)
180	(process-toplevel-form form stream compile-time-too))
181	nil)
182
183
184	(declaim (ftype (function (t t t) t) process-toplevel-form))
185	(defun precompile-toplevel-form (form stream compile-time-too)
186	(declare (ignore stream))
187	(let ((form (precompiler:precompile-form form nil
188	compile-file-environment)))
189	(when compile-time-too
190	(eval form))
191	form))
192
193
194
195	(defun process-toplevel-macrolet (form stream compile-time-too)
196	(let ((compile-file-environment
197	(make-environment compile-file-environment)))
198	(dolist (definition (cadr form))
199	(environment-add-macro-definition compile-file-environment
200	(car definition)
201	(make-macro (car definition)
202	(make-expander-for-macrolet definition))))
203	(dolist (body-form (cddr form))
204	(process-toplevel-form body-form stream compile-time-too)))
205	nil)
206
207	(declaim (ftype (function (t t t) t) process-toplevel-defconstant))
208	(defun process-toplevel-defconstant (form stream compile-time-too)
209	(declare (ignore stream compile-time-too))
210	;; "If a DEFCONSTANT form appears as a top level form, the compiler
211	;; must recognize that [the] name names a constant variable. An
212	;; implementation may choose to evaluate the value-form at compile
213	;; time, load time, or both. Therefore, users must ensure that the
214	;; initial-value can be evaluated at compile time (regardless of
215	;; whether or not references to name appear in the file) and that
216	;; it always evaluates to the same value."
217	(note-toplevel-form form)
218	(eval form)
219	form)
220
221	(declaim (ftype (function (t t t) t) process-toplevel-quote))
222	(defun process-toplevel-quote (form stream compile-time-too)
223	(declare (ignore stream))
224	(when compile-time-too
225	(eval form))
226	nil)
227
228
229	(declaim (ftype (function (t t t) t) process-toplevel-import))
230	(defun process-toplevel-import (form stream compile-time-too)
231	(declare (ignore stream))
232	(let ((form (precompiler:precompile-form form nil
233	compile-file-environment)))
234	(let ((package +keyword-package+))
235	(output-form form))
236	(when compile-time-too
237	(eval form)))
238	nil)
239
240	(declaim (ftype (function (t t t) t) process-toplevel-mop.ensure-method))
241	(defun process-toplevel-mop.ensure-method (form stream compile-time-too)
242	(declare (ignore stream))
243	(flet ((convert-ensure-method (form key)
244	(let* ((tail (cddr form))
245	(function-form (getf tail key)))
246	(when (and function-form (consp function-form)
247	(eq (%car function-form) 'FUNCTION))
248	(let ((lambda-expression (cadr function-form)))
249	(jvm::with-saved-compiler-policy
250	(let* ((saved-class-number class-number)
251	(classfile (next-classfile-name))
252	(result
253	(with-open-file
254	(f classfile
255	:direction :output
256	:element-type '(unsigned-byte 8)
257	:if-exists :supersede)
258	(report-error
259	(jvm:compile-defun nil lambda-expression
260	compile-file-environment
261	classfile f nil))))
262	(compiled-function (verify-load classfile)))
263	(declare (ignore result))
264	(cond
265	(compiled-function
266	(setf (getf tail key)
267	`(sys::get-fasl-function fasl-loader
268	,saved-class-number)))
269	(t
270	;; FIXME This should be a warning or error of some sort...
271	(format error-output "; Unable to compile method~%"))))))))))
272
273
274	(when compile-time-too
275	(let* ((copy-form (copy-tree form))
276	;; ### Ideally, the precompiler would leave the forms alone
277	;; and copy them where required, instead of forcing us to
278	;; do a deep copy in advance
279	(precompiled-form (precompiler:precompile-form copy-form nil
280	compile-file-environment)))
281	(eval precompiled-form)))
282	(convert-ensure-method form :function)
283	(convert-ensure-method form :fast-function))
284	(precompiler:precompile-form form nil compile-file-environment))
285
286	(declaim (ftype (function (t t t) t) process-toplevel-defvar/defparameter))
287	(defun process-toplevel-defvar/defparameter (form stream compile-time-too)
288	(declare (ignore stream))
289	(note-toplevel-form form)
290	(if compile-time-too
291	(eval form)
292	;; "If a DEFVAR or DEFPARAMETER form appears as a top level form,
293	;; the compiler must recognize that the name has been proclaimed
294	;; special. However, it must neither evaluate the initial-value
295	;; form nor assign the dynamic variable named NAME at compile
296	;; time."
297	(let ((name (second form)))
298	(%defvar name)))
299	form)
300
301	(declaim (ftype (function (t t t) t) process-toplevel-defpackage/in-package))
302	(defun process-toplevel-defpackage/in-package (form stream compile-time-too)
303	(declare (ignore stream compile-time-too))
304	(note-toplevel-form form)
305	(setf form
306	(precompiler:precompile-form form nil compile-file-environment))
307	(eval form)
308	;; Force package prefix to be used when dumping form.
309	(let ((package +keyword-package+))
310	(output-form form))
311	nil)
312
313	(declaim (ftype (function (t t t) t) process-toplevel-declare))
314	(defun process-toplevel-declare (form stream compile-time-too)
315	(declare (ignore stream compile-time-too))
316	(compiler-style-warn "Misplaced declaration: ~S" form)
317	nil)
318
319	(declaim (ftype (function (t t t) t) process-toplevel-progn))
320	(defun process-toplevel-progn (form stream compile-time-too)
321	(process-progn (cdr form) stream compile-time-too)
322	nil)
323
324	(declaim (ftype (function (t t t) t) process-toplevel-deftype))
325	(defun process-toplevel-deftype (form stream compile-time-too)
326	(declare (ignore stream compile-time-too))
327	(note-toplevel-form form)
328	(eval form)
329	form)
330
331	(declaim (ftype (function (t t t) t) process-toplevel-eval-when))
332	(defun process-toplevel-eval-when (form stream compile-time-too)
333	(flet ((parse-eval-when-situations (situations)
334	"Parse an EVAL-WHEN situations list, returning three flags,
335	(VALUES COMPILE-TOPLEVEL LOAD-TOPLEVEL EXECUTE), indicating
336	the types of situations present in the list."
337	; Adapted from SBCL.
338	(when (or (not (listp situations))
339	(set-difference situations
340	'(:compile-toplevel
341	compile
342	:load-toplevel
343	load
344	:execute
345	eval)))
346	(error "Bad EVAL-WHEN situation list: ~S." situations))
347	(values (intersection '(:compile-toplevel compile) situations)
348	(intersection '(:load-toplevel load) situations)
349	(intersection '(:execute eval) situations))))
350	(multiple-value-bind (ct lt e)
351	(parse-eval-when-situations (cadr form))
352	(let ((new-compile-time-too (or ct (and compile-time-too e)))
353	(body (cddr form)))
354	(if lt
355	(process-progn body stream new-compile-time-too)
356	(when new-compile-time-too
357	(eval `(progn ,@body)))))))
358	nil)
359
360
361	(declaim (ftype (function (t t t) t) process-toplevel-defmethod/defgeneric))
362	(defun process-toplevel-defmethod/defgeneric (form stream compile-time-too)
363	(note-toplevel-form form)
364	(note-name-defined (second form))
365	(let ((compile-print nil))
366	(process-toplevel-form (macroexpand-1 form compile-file-environment)
367	stream compile-time-too))
368	nil)
369
370	(declaim (ftype (function (t t t) t) process-toplevel-locally))
371	(defun process-toplevel-locally (form stream compile-time-too)
372	(jvm::with-saved-compiler-policy
373	(multiple-value-bind (forms decls)
374	(parse-body (cdr form) nil)
375	(process-optimization-declarations decls)
376	(let* ((jvm::visible-variables jvm::visible-variables)
377	(specials (jvm::process-declarations-for-vars (cdr form)
378	nil nil)))
379	(dolist (special specials)
380	(push special jvm::visible-variables))
381	(process-progn forms stream compile-time-too))))
382	nil)
383
384	(declaim (ftype (function (t t t) t) process-toplevel-defmacro))
385	(defun process-toplevel-defmacro (form stream compile-time-too)
386	(declare (ignore stream compile-time-too))
387	(note-toplevel-form form)
388	(let ((name (second form)))
389	(eval form)
390	(let* ((expr (function-lambda-expression (macro-function name)))
391	(saved-class-number class-number)
392	(classfile (next-classfile-name)))
393	(with-open-file
394	(f classfile
395	:direction :output
396	:element-type '(unsigned-byte 8)
397	:if-exists :supersede)
398	(ignore-errors
399	(jvm:compile-defun nil expr compile-file-environment
400	classfile f nil)))
401	(when (null (verify-load classfile))
402	;; FIXME error or warning
403	(format error-output "; Unable to compile macro ~A~%" name)
404	(return-from process-toplevel-defmacro form))
405
406	(if (special-operator-p name)
407	`(put ',name 'macroexpand-macro
408	(make-macro ',name
409	(sys::get-fasl-function fasl-loader
410	,saved-class-number)))
411	`(fset ',name
412	(make-macro ',name
413	(sys::get-fasl-function fasl-loader
414	,saved-class-number))
415	,source-position
416	',(third form))))))
417
418	(declaim (ftype (function (t t t) t) process-toplevel-defun))
419	(defun process-toplevel-defun (form stream compile-time-too)
420	(declare (ignore stream))
421	(note-toplevel-form form)
422	(let* ((name (second form))
423	(block-name (fdefinition-block-name name))
424	(lambda-list (third form))
425	(body (nthcdr 3 form)))
426	(jvm::with-saved-compiler-policy
427	(multiple-value-bind (body decls doc)
428	(parse-body body)
429	(let* ((expr `(lambda ,lambda-list
430	,@decls (block ,block-name ,@body)))
431	(saved-class-number class-number)
432	(classfile (next-classfile-name))
433	(internal-compiler-errors nil)
434	(result (with-open-file
435	(f classfile
436	:direction :output
437	:element-type '(unsigned-byte 8)
438	:if-exists :supersede)
439	(handler-bind
440	((internal-compiler-error
441	#'(lambda (e)
442	(push e internal-compiler-errors)
443	(continue))))
444	(report-error
445	(jvm:compile-defun name expr compile-file-environment
446	classfile f nil)))))
447	(compiled-function (if (not internal-compiler-errors)
448	(verify-load classfile)
449	nil)))
450	(declare (ignore result))
451	(cond
452	((and (not internal-compiler-errors)
453	compiled-function)
454	(when compile-time-too
455	(eval form))
456	(setf form
457	`(fset ',name
458	(sys::get-fasl-function fasl-loader
459	,saved-class-number)
460	,source-position
461	',lambda-list
462	,doc)))
463	(t
464	(compiler-warn "Unable to compile function ~A. Using interpreted form instead.~%" name)
465	(when internal-compiler-errors
466	(dolist (e internal-compiler-errors)
467	(format error-output
468	"; ~A~%" e)))
469	(let ((precompiled-function
470	(precompiler:precompile-form expr nil
471	compile-file-environment)))
472	(setf form
473	`(fset ',name
474	,precompiled-function
475	,source-position
476	',lambda-list
477	,doc)))
478	(when compile-time-too
479	(eval form)))))
480	(when (and (symbolp name) (eq (get name '%inline) 'INLINE))
481	;; FIXME Need to support SETF functions too!
482	(setf (inline-expansion name)
483	(jvm::generate-inline-expansion block-name
484	lambda-list body))
485	(output-form `(setf (inline-expansion ',name)
486	',(inline-expansion name))))))
487	(push name jvm::functions-defined-in-current-file)
488	(note-name-defined name)
489	;; If NAME is not fbound, provide a dummy definition so that
490	;; getSymbolFunctionOrDie() will succeed when we try to verify that
491	;; functions defined later in the same file can be loaded correctly.
492	(unless (fboundp name)
493	(setf (fdefinition name) #'dummy)
494	(push name fbound-names)))
495	form)
496
497
498	;; toplevel handlers
499	;; each toplevel handler takes a form and stream as input
500
501	(defun install-toplevel-handler (symbol handler)
502	(setf (get symbol 'toplevel-handler) handler))
503
504	(dolist (pair '((COMPILER-DEFSTRUCT precompile-toplevel-form)
505	(DECLARE process-toplevel-declare)
506	(DEFCONSTANT process-toplevel-defconstant)
507	(DEFGENERIC process-toplevel-defmethod/defgeneric)
508	(DEFMACRO process-toplevel-defmacro)
509	(DEFMETHOD process-toplevel-defmethod/defgeneric)
510	(DEFPACKAGE process-toplevel-defpackage/in-package)
511	(DEFPARAMETER process-toplevel-defvar/defparameter)
512	(DEFTYPE process-toplevel-deftype)
513	(DEFUN process-toplevel-defun)
514	(DEFVAR process-toplevel-defvar/defparameter)
515	(EVAL-WHEN process-toplevel-eval-when)
516	(EXPORT precompile-toplevel-form)
517	(IMPORT process-toplevel-import)
518	(IN-PACKAGE process-toplevel-defpackage/in-package)
519	(LOCALLY process-toplevel-locally)
520	(MACROLET process-toplevel-macrolet)
521	(PROCLAIM precompile-toplevel-form)
522	(PROGN process-toplevel-progn)
523	(PROVIDE precompile-toplevel-form)
524	(PUT precompile-toplevel-form)
525	(QUOTE process-toplevel-quote)
526	(REQUIRE precompile-toplevel-form)
527	(SHADOW precompile-toplevel-form)
528	(%SET-FDEFINITION precompile-toplevel-form)
529	(MOP::ENSURE-METHOD process-toplevel-mop.ensure-method)))
530	(install-toplevel-handler (car pair) (cadr pair)))
531
532	(declaim (ftype (function (t stream t) t) process-toplevel-form))
533	(defun process-toplevel-form (form stream compile-time-too)
534	(unless (atom form)
535	(let* ((operator (%car form))
536	(handler (get operator 'toplevel-handler)))
537	(when handler
538	(let ((out-form (funcall handler form stream compile-time-too)))
539	(when out-form
540	(output-form out-form)))
541	(return-from process-toplevel-form))
542	(when (and (symbolp operator)
543	(macro-function operator compile-file-environment))
544	(note-toplevel-form form)
545	;; Note that we want MACROEXPAND-1 and not MACROEXPAND here, in
546	;; case the form being expanded expands into something that needs
547	;; special handling by PROCESS-TOPLEVEL-FORM (e.g. DEFMACRO).
548	(let ((compile-print nil))
549	(process-toplevel-form (macroexpand-1 form compile-file-environment)
550	stream compile-time-too))
551	(return-from process-toplevel-form))
552
553	(cond
554	((and (symbolp operator)
555	(not (special-operator-p operator))
556	(null (cdr form)))
557	(setf form (precompiler:precompile-form form nil
558	compile-file-environment)))
559	(t
560	(note-toplevel-form form)
561	(setf form (convert-toplevel-form form nil)))))
562	(when (consp form)
563	(output-form form)))
564	;; Make sure the compiled-function loader knows where
565	;; to load the compiled functions. Note that this trickery
566	;; was already used in verify-load before I used it,
567	;; however, binding load-truename isn't fully compliant, I think.
568	(when compile-time-too
569	(let ((load-truename output-file-pathname)
570	(fasl-loader (make-fasl-class-loader
571	(concatenate 'string
572	"org.armedbear.lisp." (base-classname)))))
573	(eval form))))
574
575	(defun populate-zip-fasl (output-file)
576	(let* ((type ;; Don't use ".zip", it'll result in an extension
577	;; with a dot, which is rejected by NAMESTRING
578	(%format nil "~A~A" (pathname-type output-file) "-zip"))
579	(zipfile (namestring
580	(merge-pathnames (make-pathname :type type)
581	output-file)))
582	(pathnames nil)
583	(fasl-loader (namestring (merge-pathnames
584	(make-pathname :name (fasl-loader-classname)
585	:type "cls")
586	output-file))))
587	(when (probe-file fasl-loader)
588	(push fasl-loader pathnames))
589	(dotimes (i class-number)
590	(let ((truename (probe-file (compute-classfile-name (1+ i)))))
591	(when truename
592	(push truename pathnames)
593	;;; XXX it would be better to just use the recorded number
594	;;; of class constants, but probing for the first at least
595	;;; makes this subjectively bearable.
596	(when (probe-file
597	(make-pathname :name (format nil "~A_0"
598	(pathname-name truename))
599	:type "clc"
600	:defaults truename))
601	(dolist (resource (directory
602	(make-pathname :name (format nil "~A_*"
603	(pathname-name truename))
604	:type "clc"
605	:defaults truename)))
606	(push resource pathnames))))))
607	(setf pathnames (nreverse (remove nil pathnames)))
608	(let ((load-file (merge-pathnames (make-pathname :type "_")
609	output-file)))
610	(rename-file output-file load-file)
611	(push load-file pathnames))
612	(zip zipfile pathnames)
613	(dolist (pathname pathnames)
614	(ignore-errors (delete-file pathname)))
615	(rename-file zipfile output-file)))
616
617	(defun write-fasl-prologue (stream)
618	(let ((out stream))
619	;; write header
620	(write "; -- Mode: Lisp --" :escape nil :stream out)
621	(%stream-terpri out)
622	(write (list 'init-fasl :version fasl-version) :stream out)
623	(%stream-terpri out)
624	(write (list 'setq 'source compile-file-truename) :stream out)
625	(%stream-terpri out)
626
627	;; Note: Beyond this point, you can't use DUMP-FORM,
628	;; because the list of uninterned symbols has been fixed now.
629	(when fasl-uninterned-symbols
630	(write (list 'setq 'fasl-uninterned-symbols
631	(coerce (mapcar #'car (nreverse fasl-uninterned-symbols))
632	'vector))
633	:stream out :length nil))
634	(%stream-terpri out)
635
636	(when (> class-number 0)
637	(write (list 'setq 'fasl-loader
638	`(sys::make-fasl-class-loader
639	,(concatenate 'string "org.armedbear.lisp."
640	(base-classname))))
641	:stream out))
642	(%stream-terpri out)))
643
644
645
646	(defvar binary-fasls nil)
647	(defvar forms-for-output nil)
648	(defvar fasl-stream nil)
649
650	(defun compile-file (input-file
651	&key
652	output-file
653	((:verbose compile-verbose) compile-verbose)
654	((:print compile-print) compile-print)
655	external-format)
656	(declare (ignore external-format)) ; FIXME
657	(unless (or (and (probe-file input-file) (not (file-directory-p input-file)))
658	(pathname-type input-file))
659	(let ((pathname (merge-pathnames (make-pathname :type "lisp") input-file)))
660	(when (probe-file pathname)
661	(setf input-file pathname))))
662	(setf output-file (make-pathname
663	:defaults (if output-file
664	(merge-pathnames output-file
665	default-pathname-defaults)
666	(compile-file-pathname input-file))
667	:version nil))
668	(let* ((output-file-pathname output-file)
669	(type (pathname-type output-file))
670	(temp-file (merge-pathnames (make-pathname :type (concatenate 'string type "-tmp"))
671	output-file))
672	(temp-file2 (merge-pathnames (make-pathname :type (concatenate 'string type "-tmp2"))
673	output-file))
674	(warnings-p nil)
675	(failure-p nil))
676	(with-open-file (in input-file :direction :input)
677	(let* ((compile-file-pathname (make-pathname :defaults (pathname in)
678	:version nil))
679	(compile-file-truename (make-pathname :defaults (truename in)
680	:version nil))
681	(source compile-file-truename)
682	(class-number 0)
683	(namestring (namestring compile-file-truename))
684	(start (get-internal-real-time))
685	fasl-uninterned-symbols)
686	(when compile-verbose
687	(format t "; Compiling ~A ...~%" namestring))
688	(with-compilation-unit ()
689	(with-open-file (out temp-file
690	:direction :output :if-exists :supersede
691	:external-format fasl-external-format)
692	(let ((readtable readtable)
693	(read-default-float-format read-default-float-format)
694	(read-base read-base)
695	(package package)
696	(jvm::functions-defined-in-current-file '())
697	(fbound-names '())
698	(fasl-stream out)
699	forms-for-output)
700	(jvm::with-saved-compiler-policy
701	(jvm::with-file-compilation
702	(handler-bind
703	((style-warning
704	#'(lambda (c)
705	(setf warnings-p t)
706	;; let outer handlers do their thing
707	(signal c)
708	;; prevent the next handler
709	;; from running: we're a
710	;; WARNING subclass
711	(continue)))
712	((or warning compiler-error)
713	#'(lambda (c)
714	(declare (ignore c))
715	(setf warnings-p t
716	failure-p t))))
717	(loop
718	(let* ((source-position (file-position in))
719	(jvm::source-line-number (stream-line-number in))
720	(form (read in nil in))
721	(compiler-error-context form))
722	(when (eq form in)
723	(return))
724	(process-toplevel-form form out nil))))
725	(finalize-fasl-output)
726	(dolist (name fbound-names)
727	(fmakunbound name)))))))
728	(with-open-file (in temp-file :direction :input)
729	(with-open-file (out temp-file2 :direction :output
730	:if-does-not-exist :create
731	:if-exists :supersede)
732	(let ((package (find-package '#:cl))
733	(print-fasl t)
734	(print-array t)
735	(print-base 10)
736	(print-case :upcase)
737	(print-circle nil)
738	(print-escape t)
739	(print-gensym t)
740	(print-length nil)
741	(print-level nil)
742	(print-lines nil)
743	(print-pretty nil)
744	(print-radix nil)
745	(print-readably t)
746	(print-right-margin nil)
747	(print-structure t)
748
749	;; make sure to write all floats with their exponent marker:
750	;; the dump-time default may not be the same at load-time
751
752	(read-default-float-format nil))
753
754	;; these values are also bound by WITH-STANDARD-IO-SYNTAX,
755	;; but not used by our reader/printer, so don't bind them,
756	;; for efficiency reasons.
757	;; (read-eval t)
758	;; (read-suppress nil)
759	;; (print-miser-width nil)
760	;; (print-pprint-dispatch (copy-pprint-dispatch nil))
761	;; (read-base 10)
762	;; (read-default-float-format 'single-float)
763	;; (readtable (copy-readtable nil))
764
765	(write-fasl-prologue out)
766	;; copy remaining content
767	(loop for line = (read-line in nil :eof)
768	while (not (eq line :eof))
769	do (write-line line out)))))
770	(delete-file temp-file)
771	(remove-zip-cache-entry output-file) ;; Necessary under windows
772	(rename-file temp-file2 output-file)
773
774	(when compile-file-zip
775	(populate-zip-fasl output-file))
776
777	(when compile-verbose
778	(format t "~&; Wrote ~A (~A seconds)~%"
779	(namestring output-file)
780	(/ (- (get-internal-real-time) start) 1000.0)))))
781	(values (truename output-file) warnings-p failure-p)))
782
783	(defun compile-file-if-needed (input-file &rest allargs &key force-compile
784	&allow-other-keys)
785	(setf input-file (truename input-file))
786	(cond (force-compile
787	(remf allargs :force-compile)
788	(apply 'compile-file input-file allargs))
789	(t
790	(let* ((source-write-time (file-write-date input-file))
791	(output-file (or (getf allargs :output-file)
792	(compile-file-pathname input-file)))
793	(target-write-time (and (probe-file output-file)
794	(file-write-date output-file))))
795	(if (or (null target-write-time)
796	(<= target-write-time source-write-time))
797	(apply 'compile-file input-file allargs)
798	output-file)))))
799
800	(provide 'compile-file)

Note: See TracBrowser for help on using the repository browser.

Download in other formats: