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

Last change on this file since 11568 was 11568, checked in by ehuelsmann, 13 years ago

Restore *read-base* and *read-default-float-format* after compiling a file.

They could have been changed (and in our case the latter *is*) during file compilation.

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