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

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

Eliminate style warnings for variables LOCALLY DECLAREd SPECIAL,
by letting the compiler know about the declaration.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Id
File size: 23.7 KB
Line 
1;;; compile-file.lisp
2;;;
3;;; Copyright (C) 2004-2006 Peter Graves
4;;; $Id: compile-file.lisp 11848 2009-05-09 18:01:56Z 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
36(defvar *fbound-names*)
37
38(defvar *class-number*)
39
40(defvar *output-file-pathname*)
41
42(declaim (ftype (function (t) t) compute-classfile-name))
43(defun compute-classfile-name (n &optional (output-file-pathname
44                                            *output-file-pathname*))
45  "Computes the name of the class file associated with number `n'."
46  (let ((name
47         (%format nil "~A-~D"
48                  (substitute #\_ #\.
49                              (pathname-name output-file-pathname)) n)))
50    (namestring (merge-pathnames (make-pathname :name name :type "cls")
51                                 output-file-pathname))))
52
53(declaim (ftype (function () t) next-classfile-name))
54(defun next-classfile-name ()
55  (compute-classfile-name (incf *class-number*)))
56
57(defmacro report-error (&rest forms)
58  `(handler-case (progn ,@forms)
59     (compiler-unsupported-feature-error (condition)
60       (fresh-line)
61       (%format t "; UNSUPPORTED-FEATURE: ~A~%" condition)
62       (values nil condition))))
63
64;; Dummy function. Should never be called.
65(defun dummy (&rest ignored)
66  (declare (ignore ignored))
67  (assert nil))
68
69(declaim (ftype (function (t) t) verify-load))
70(defun verify-load (classfile)
71  (and classfile
72       (let ((*load-truename* *output-file-pathname*))
73         (report-error
74          (load-compiled-function classfile)))))
75
76(declaim (ftype (function (t stream) t) process-defconstant))
77(defun process-defconstant (form stream)
78  ;; "If a DEFCONSTANT form appears as a top level form, the compiler
79  ;; must recognize that [the] name names a constant variable. An
80  ;; implementation may choose to evaluate the value-form at compile
81  ;; time, load time, or both. Therefore, users must ensure that the
82  ;; initial-value can be evaluated at compile time (regardless of
83  ;; whether or not references to name appear in the file) and that
84  ;; it always evaluates to the same value."
85  (eval form)
86  (dump-form form stream)
87  (%stream-terpri stream))
88
89(declaim (ftype (function (t) t) note-toplevel-form))
90(defun note-toplevel-form (form)
91  (when *compile-print*
92    (fresh-line)
93    (princ "; ")
94    (let ((*print-length* 2)
95          (*print-level* 2)
96          (*print-pretty* nil))
97      (prin1 form))
98    (terpri)))
99
100(declaim (ftype (function (t stream t) t) process-toplevel-form))
101(defun process-toplevel-form (form stream compile-time-too)
102  (if (atom form)
103      (when compile-time-too
104        (eval form))
105    (progn
106      (let ((operator (%car form)))
107        (case operator
108          (MACROLET
109           (process-toplevel-macrolet form stream compile-time-too)
110           (return-from process-toplevel-form))
111          ((IN-PACKAGE DEFPACKAGE)
112           (note-toplevel-form form)
113           (setf form (precompile-form form nil))
114           (eval form)
115           ;; Force package prefix to be used when dumping form.
116           (let ((*package* +keyword-package+))
117             (dump-form form stream))
118           (%stream-terpri stream)
119           (return-from process-toplevel-form))
120          ((DEFVAR DEFPARAMETER)
121           (note-toplevel-form form)
122           (if compile-time-too
123               (eval form)
124               ;; "If a DEFVAR or DEFPARAMETER form appears as a top level form,
125               ;; the compiler must recognize that the name has been proclaimed
126               ;; special. However, it must neither evaluate the initial-value
127               ;; form nor assign the dynamic variable named NAME at compile
128               ;; time."
129               (let ((name (second form)))
130                 (%defvar name))))
131          (DEFCONSTANT
132           (note-toplevel-form form)
133           (process-defconstant form stream)
134           (return-from process-toplevel-form))
135          (DEFUN
136           (note-toplevel-form form)
137           (let* ((name (second form))
138                  (block-name (fdefinition-block-name name))
139                  (lambda-list (third form))
140                  (body (nthcdr 3 form)))
141             (jvm::with-saved-compiler-policy
142               (multiple-value-bind (body decls doc)
143                   (parse-body body)
144                 (let* ((expr `(lambda ,lambda-list
145                                 ,@decls (block ,block-name ,@body)))
146                        (classfile-name (next-classfile-name))
147                        (classfile (report-error
148                                    (jvm:compile-defun name expr nil
149                                                       classfile-name)))
150                        (compiled-function (verify-load classfile)))
151                   (cond
152                     (compiled-function
153                      (setf form
154                            `(fset ',name
155                                   (load-compiled-function ,(file-namestring classfile))
156                                   ,*source-position*
157                                   ',lambda-list
158                                   ,doc))
159                      (when compile-time-too
160                        (fset name compiled-function)))
161                     (t
162                      ;; FIXME Should be a warning or error of some sort...
163                      (format *error-output*
164                              "; Unable to compile function ~A~%" name)
165                      (let ((precompiled-function (precompile-form expr nil)))
166                        (setf form
167                              `(fset ',name
168                                     ,precompiled-function
169                                     ,*source-position*
170                                     ',lambda-list
171                                     ,doc)))
172                      (when compile-time-too
173                        (eval form)))))
174                 (when (and (symbolp name) (eq (get name '%inline) 'INLINE))
175                 ;; FIXME Need to support SETF functions too!
176                   (setf (inline-expansion name)
177                         (jvm::generate-inline-expansion block-name
178                                                         lambda-list body))
179                   (dump-form `(setf (inline-expansion ',name)
180                                     ',(inline-expansion name))
181                              stream)
182                   (%stream-terpri stream))))
183             (push name jvm::*functions-defined-in-current-file*)
184             (note-name-defined name)
185             ;; If NAME is not fbound, provide a dummy definition so that
186             ;; getSymbolFunctionOrDie() will succeed when we try to verify that
187             ;; functions defined later in the same file can be loaded correctly.
188             (unless (fboundp name)
189               (setf (fdefinition name) #'dummy)
190               (push name *fbound-names*))))
191          ((DEFGENERIC DEFMETHOD)
192           (note-toplevel-form form)
193           (note-name-defined (second form))
194           (let ((*compile-print* nil))
195             (process-toplevel-form (macroexpand-1 form *compile-file-environment*)
196                                    stream compile-time-too))
197             (return-from process-toplevel-form))
198          (DEFMACRO
199           (note-toplevel-form form)
200           (let ((name (second form)))
201             (eval form)
202             (let* ((expr (function-lambda-expression (macro-function name)))
203                    (classfile-name (next-classfile-name))
204                    (classfile
205                     (ignore-errors
206                       (jvm:compile-defun nil expr nil classfile-name))))
207               (if (null (verify-load classfile))
208                   ;; FIXME error or warning
209                   (format *error-output* "; Unable to compile macro ~A~%" name)
210                 (progn
211                   (setf form
212                         (if (special-operator-p name)
213                             `(put ',name 'macroexpand-macro
214                                   (make-macro ',name
215                                               (load-compiled-function
216                                                ,(file-namestring classfile))))
217                             `(fset ',name
218                                    (make-macro ',name
219                                                (load-compiled-function
220                                                 ,(file-namestring classfile)))
221                                    ,*source-position*
222                                    ',(third form)))))))))
223          (DEFTYPE
224           (note-toplevel-form form)
225           (eval form))
226          (EVAL-WHEN
227           (multiple-value-bind (ct lt e)
228               (parse-eval-when-situations (cadr form))
229             (let ((new-compile-time-too (or ct (and compile-time-too e)))
230                   (body (cddr form)))
231               (if lt
232                   (process-toplevel-progn body stream new-compile-time-too)
233                 (when new-compile-time-too
234                   (eval `(progn ,@body)))))
235           (return-from process-toplevel-form)))
236          (LOCALLY
237           ;; FIXME Need to handle special declarations too!
238           (jvm::with-saved-compiler-policy
239             (multiple-value-bind (forms decls)
240                 (parse-body (cdr form) nil)
241               (process-optimization-declarations decls)
242               (let* ((jvm::*visible-variables* jvm::*visible-variables*)
243                      (specials (process-special-declarations decls)))
244                 (dolist (special specials)
245                   (push (jvm::make-variable :name special :special-p t)
246                         jvm::*visible-variables*))
247                 (process-toplevel-progn forms stream compile-time-too))
248               (return-from process-toplevel-form))))
249          (PROGN
250           (process-toplevel-progn (cdr form) stream compile-time-too)
251           (return-from process-toplevel-form))
252          (DECLARE
253           (compiler-style-warn "Misplaced declaration: ~S" form))
254          (t
255           (when (and (symbolp operator)
256                      (macro-function operator *compile-file-environment*))
257             (note-toplevel-form form)
258             ;; Note that we want MACROEXPAND-1 and not MACROEXPAND here, in
259             ;; case the form being expanded expands into something that needs
260             ;; special handling by PROCESS-TOPLEVEL-FORM (e.g. DEFMACRO).
261             (let ((*compile-print* nil))
262               (process-toplevel-form (macroexpand-1 form *compile-file-environment*)
263                                      stream compile-time-too))
264             (return-from process-toplevel-form))
265
266           (cond ((eq operator 'QUOTE)
267;;;                      (setf form (precompile-form form nil))
268                  (when compile-time-too
269                    (eval form))
270                  (return-from process-toplevel-form))
271                 ((eq operator 'PUT)
272                  (setf form (precompile-form form nil)))
273                 ((eq operator 'COMPILER-DEFSTRUCT)
274                  (setf form (precompile-form form nil)))
275                 ((eq operator 'PROCLAIM)
276                  (setf form (precompile-form form nil)))
277                 ((and (memq operator '(EXPORT REQUIRE PROVIDE SHADOW))
278                       (or (keywordp (second form))
279                           (and (listp (second form))
280                                (eq (first (second form)) 'QUOTE))))
281                  (setf form (precompile-form form nil)))
282                 ((eq operator 'IMPORT)
283                  (setf form (precompile-form form nil))
284                  ;; Make sure package prefix is printed when symbols are imported.
285                  (let ((*package* +keyword-package+))
286                    (dump-form form stream))
287                  (%stream-terpri stream)
288                  (when compile-time-too
289                    (eval form))
290                  (return-from process-toplevel-form))
291                 ((and (eq operator '%SET-FDEFINITION)
292                       (eq (car (second form)) 'QUOTE)
293                       (consp (third form))
294                       (eq (%car (third form)) 'FUNCTION)
295                       (symbolp (cadr (third form))))
296                  (setf form (precompile-form form nil)))
297;;;                     ((memq operator '(LET LET*))
298;;;                      (let ((body (cddr form)))
299;;;                        (if (dolist (subform body nil)
300;;;                              (when (and (consp subform) (eq (%car subform) 'DEFUN))
301;;;                                (return t)))
302;;;                            (setf form (convert-toplevel-form form))
303;;;                            (setf form (precompile-form form nil)))))
304                 ((eq operator 'mop::ensure-method)
305                  (setf form (convert-ensure-method form)))
306                 ((and (symbolp operator)
307                       (not (special-operator-p operator))
308                       (null (cdr form)))
309                  (setf form (precompile-form form nil)))
310                 (t
311;;;                      (setf form (precompile-form form nil))
312                  (note-toplevel-form form)
313                  (setf form (convert-toplevel-form form)))))))))
314  (when (consp form)
315    (dump-form form stream)
316    (%stream-terpri stream))
317  ;; Make sure the compiled-function loader knows where
318  ;; to load the compiled functions. Note that this trickery
319  ;; was already used in verify-load before I used it,
320  ;; however, binding *load-truename* isn't fully compliant, I think.
321  (let ((*load-truename* *output-file-pathname*))
322    (when compile-time-too
323      (eval form))))
324
325(declaim (ftype (function (t) t) convert-ensure-method))
326(defun convert-ensure-method (form)
327  (c-e-m-1 form :function)
328  (c-e-m-1 form :fast-function)
329  (precompile-form form nil))
330
331(declaim (ftype (function (t t) t) c-e-m-1))
332(defun c-e-m-1 (form key)
333  (let* ((tail (cddr form))
334         (function-form (getf tail key)))
335    (when (and function-form (consp function-form)
336               (eq (%car function-form) 'FUNCTION))
337      (let ((lambda-expression (cadr function-form)))
338        (jvm::with-saved-compiler-policy
339          (let* ((classfile-name (next-classfile-name))
340                 (classfile (report-error
341                             (jvm:compile-defun nil lambda-expression nil classfile-name)))
342                 (compiled-function (verify-load classfile)))
343            (cond (compiled-function
344                   (setf (getf tail key)
345                         `(load-compiled-function ,(file-namestring classfile))))
346                  (t
347                   ;; FIXME This should be a warning or error of some sort...
348                   (format *error-output* "; Unable to compile method~%")))))))))
349
350(declaim (ftype (function (t) t) convert-toplevel-form))
351(defun convert-toplevel-form (form)
352  (let* ((expr `(lambda () ,form))
353         (classfile-name (next-classfile-name))
354         (classfile (report-error (jvm:compile-defun nil expr nil classfile-name)))
355         (compiled-function (verify-load classfile)))
356    (setf form
357          (if compiled-function
358              `(funcall (load-compiled-function ,(file-namestring classfile)))
359              (precompile-form form nil)))))
360
361
362(defun process-toplevel-macrolet (form stream compile-time-too)
363  (let ((*compile-file-environment* (make-environment *compile-file-environment*)))
364    (dolist (definition (cadr form))
365      (environment-add-macro-definition *compile-file-environment*
366                                        (car definition)
367                                        (make-macro (car definition)
368                                                    (make-expander-for-macrolet definition))))
369    (dolist (body-form (cddr form))
370      (process-toplevel-form body-form stream compile-time-too))))
371
372(declaim (ftype (function (t stream t) t) process-toplevel-progn))
373(defun process-toplevel-progn (forms stream compile-time-too)
374  (dolist (form forms)
375    (process-toplevel-form form stream compile-time-too)))
376
377;;; Adapted from SBCL.
378;;; Parse an EVAL-WHEN situations list, returning three flags,
379;;; (VALUES COMPILE-TOPLEVEL LOAD-TOPLEVEL EXECUTE), indicating
380;;; the types of situations present in the list.
381(defun parse-eval-when-situations (situations)
382  (when (or (not (listp situations))
383      (set-difference situations
384          '(:compile-toplevel
385            compile
386            :load-toplevel
387            load
388            :execute
389            eval)))
390    (error "Bad EVAL-WHEN situation list: ~S." situations))
391  (values (intersection '(:compile-toplevel compile) situations)
392    (intersection '(:load-toplevel load) situations)
393    (intersection '(:execute eval) situations)))
394
395(defun compile-file (input-file
396                     &key
397                     output-file
398                     ((:verbose *compile-verbose*) *compile-verbose*)
399                     ((:print *compile-print*) *compile-print*)
400                     external-format)
401  (declare (ignore external-format)) ; FIXME
402  (unless (or (and (probe-file input-file) (not (file-directory-p input-file)))
403              (pathname-type input-file))
404    (let ((pathname (merge-pathnames (make-pathname :type "lisp") input-file)))
405      (when (probe-file pathname)
406        (setf input-file pathname))))
407  (setf output-file (if output-file
408                        (merge-pathnames output-file *default-pathname-defaults*)
409                        (compile-file-pathname input-file)))
410  (let* ((*output-file-pathname* output-file)
411         (type (pathname-type output-file))
412         (temp-file (merge-pathnames (make-pathname :type (concatenate 'string type "-tmp"))
413                                     output-file))
414         (warnings-p nil)
415         (failure-p nil))
416    (with-open-file (in input-file :direction :input)
417      (let* ((*compile-file-pathname* (pathname in))
418             (*compile-file-truename* (truename in))
419             (*source* *compile-file-truename*)
420             (*class-number* 0)
421             (namestring (namestring *compile-file-truename*))
422             (start (get-internal-real-time))
423             elapsed)
424        (when *compile-verbose*
425          (format t "; Compiling ~A ...~%" namestring))
426        (with-compilation-unit ()
427          (with-open-file (out temp-file
428                               :direction :output :if-exists :supersede)
429            (let ((*readtable* *readtable*)
430                  (*read-default-float-format* *read-default-float-format*)
431                  (*read-base* *read-base*)
432                  (*package* *package*)
433                  (jvm::*functions-defined-in-current-file* '())
434                  (*fbound-names* '())
435                  (*fasl-anonymous-package* (%make-package)))
436              (jvm::with-saved-compiler-policy
437                (jvm::with-file-compilation
438                  (write "; -*- Mode: Lisp -*-" :escape nil :stream out)
439                  (%stream-terpri out)
440                  (let ((*package* (find-package '#:cl)))
441                    (write (list 'init-fasl :version *fasl-version*)
442                           :stream out)
443                    (%stream-terpri out)
444                    (write (list 'setq '*source* *compile-file-truename*)
445                           :stream out)
446                    (%stream-terpri out))
447                  (handler-bind ((style-warning #'(lambda (c)
448                                                    (declare (ignore c))
449                                                    (setf warnings-p t)
450                                                    nil))
451                                 ((or warning
452                                      compiler-error) #'(lambda (c)
453                                                          (declare (ignore c))
454                                                          (setf warnings-p t
455                                                                failure-p t)
456                                                          nil)))
457                    (loop
458                       (let* ((*source-position* (file-position in))
459                              (jvm::*source-line-number* (stream-line-number in))
460                              (form (read in nil in))
461                              (*compiler-error-context* form))
462                         (when (eq form in)
463                           (return))
464                         (process-toplevel-form form out nil))))
465                  (dolist (name *fbound-names*)
466                    (fmakunbound name)))))))
467        (rename-file temp-file output-file)
468
469        (when *compile-file-zip*
470          (let* ((type ;; Don't use ".zip", it'll result in an extension
471                  ;;  with a dot, which is rejected by NAMESTRING
472                  (%format nil "~A~A" (pathname-type output-file) "-zip"))
473                 (zipfile (namestring
474                           (merge-pathnames (make-pathname :type type)
475                                            output-file)))
476                 (pathnames ()))
477            (dotimes (i *class-number*)
478              (let* ((pathname (compute-classfile-name (1+ i))))
479                (when (probe-file pathname)
480                  (push pathname pathnames))))
481            (setf pathnames (nreverse pathnames))
482            (let ((load-file (merge-pathnames (make-pathname :type "_")
483                                              output-file)))
484              (rename-file output-file load-file)
485              (push load-file pathnames))
486            (zip zipfile pathnames)
487            (dolist (pathname pathnames)
488              (let ((truename (probe-file pathname)))
489                (when truename
490                  (delete-file truename))))
491            (rename-file zipfile output-file)))
492
493        (setf elapsed (/ (- (get-internal-real-time) start) 1000.0))
494        (when *compile-verbose*
495          (format t "~&; Wrote ~A (~A seconds)~%"
496                  (namestring output-file) elapsed))))
497    (values (truename output-file) warnings-p failure-p)))
498
499(defun compile-file-if-needed (input-file &rest allargs &key force-compile
500                               &allow-other-keys)
501  (setf input-file (truename input-file))
502  (cond (force-compile
503         (remf allargs :force-compile)
504         (apply 'compile-file input-file allargs))
505        (t
506         (let* ((source-write-time (file-write-date input-file))
507                (output-file       (or (getf allargs :output-file)
508                                       (compile-file-pathname input-file)))
509                (target-write-time (and (probe-file output-file)
510                                        (file-write-date output-file))))
511           (if (or (null target-write-time)
512                   (<= target-write-time source-write-time))
513               (apply 'compile-file input-file allargs)
514               output-file)))))
515
516(provide 'compile-file)
Note: See TracBrowser for help on using the repository browser.