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

Last change on this file since 15483 was 15483, checked in by Mark Evenson, 2 years ago

Fix compiling/loading using packages which don't USE :CL

Explicitly scope all symbols used in our fasl loader. Probably not
strictly necessary in all cases, but it makes things clearer to the
reader.

Use the (find-package :keyword) idiom where it works. One can't
reliably use +keyword-package+ when bootstrapping the compiler (?!?).

The last fasl prologue Lisp form in the loader init._ forms is now
an IN-PACKAGE to the COMPILE-FILE value used when creating the fasl.

Normalize whitespace and comments.

Fixes <https://abcl.org/trac/ticket/475>.

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