Context Navigation

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

Visit:

Last change on this file was 12761, checked in by ehuelsmann, 15 years ago
Fix compilation of toplevel MACROLET forms.
Property svn:eol-style set to `native` Property svn:keywords set to `Id`
File size: 32.4 KB

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

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

Download in other formats: