source: trunk/j/src/org/armedbear/lisp/compile-file.lisp @ 8549

Last change on this file since 8549 was 8549, checked in by piso, 16 years ago

Work in progress.

File size: 12.8 KB
Line 
1;;; compile-file.lisp
2;;;
3;;; Copyright (C) 2004-2005 Peter Graves
4;;; $Id: compile-file.lisp,v 1.55 2005-02-12 03:49:03 piso Exp $
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(in-package #:system)
21
22(require 'jvm)
23
24(defvar *fbound-names*)
25
26(defvar *class-number*)
27
28(defvar *output-file-pathname*)
29
30(defvar *source-position*)
31
32(defun next-classfile-name ()
33  (let ((name (%format nil "~A-~D"
34                       (pathname-name *compile-file-pathname*)
35                       (incf *class-number*))))
36    (namestring (merge-pathnames (make-pathname :name name :type "cls")
37                                 *output-file-pathname*))))
38
39(defmacro report-error (&rest forms)
40  `(handler-case (progn ,@forms)
41     (compiler-unsupported-feature-error (condition)
42       (fresh-line)
43       (%format t "; UNSUPPORTED-FEATURE: ~A~%" condition)
44       (values nil condition))
45     #+nil
46     (error (condition)
47       (fresh-line)
48       (%format t "~A Note: ~A~%" (jvm::load-verbose-prefix) condition)
49       (values nil condition))
50     ))
51
52;; Dummy function. Should never be called.
53(defun dummy (&rest ignored)
54  (assert nil))
55
56(defun verify-load (classfile)
57  (and classfile
58       (let ((*default-pathname-defaults* *output-file-pathname*))
59         (report-error
60          (load-compiled-function classfile)))))
61
62(defun process-toplevel-form (form stream compile-time-too)
63  (cond ((atom form)
64         (when compile-time-too
65           (eval form)))
66        (t
67         (case (car form)
68           (MACROLET
69            (let ((new-form (precompiler::precompile-macrolet form)))
70              (process-toplevel-form new-form stream compile-time-too)
71              (return-from process-toplevel-form)))
72           ((IN-PACKAGE DEFPACKAGE)
73            (eval form))
74           ((DEFVAR DEFPARAMETER)
75            (if compile-time-too
76                (eval form)
77                ;; "If a DEFVAR or DEFPARAMETER form appears as a top level form,
78                ;; the compiler must recognize that the name has been proclaimed
79                ;; special. However, it must neither evaluate the initial-value
80                ;; form nor assign the dynamic variable named NAME at compile
81                ;; time."
82                (let ((name (second form)))
83                  (%defvar name))))
84           (DEFCONSTANT
85            ;; "If a DEFCONSTANT form appears as a top level form, the compiler
86            ;; must recognize that [the] name names a constant variable. An
87            ;; implementation may choose to evaluate the value-form at compile
88            ;; time, load time, or both. Therefore, users must ensure that the
89            ;; initial-value can be evaluated at compile time (regardless of
90            ;; whether or not references to name appear in the file) and that
91            ;; it always evaluates to the same value."
92            (eval form))
93           (DEFUN
94            (let ((name (second form)))
95              (%format t "; Processing function ~A~%" name)
96              (let* ((lambda-list (third form))
97                     (body (nthcdr 3 form))
98                     (jvm::*speed* jvm::*speed*)
99                     (jvm::*safety* jvm::*safety*)
100                     (jvm::*debug* jvm::*debug*))
101                (jvm::process-optimization-declarations body)
102                (multiple-value-bind (body decls)
103                    (parse-body body)
104                  (let* ((expr `(lambda ,lambda-list ,@decls (block ,name ,@body)))
105                         (classfile-name (next-classfile-name))
106                         (classfile (report-error
107                                     (jvm:compile-defun name expr nil classfile-name)))
108                         (compiled-function (verify-load classfile)))
109                    (cond (compiled-function
110                           (%format t ";  ~A => ~A.cls~%" name
111                                    (pathname-name (pathname classfile-name)))
112                           (setf form
113                                 `(fset ',name
114                                        (load-compiled-function ,(file-namestring classfile))
115                                        ,*source-position*
116                                        ',lambda-list))
117                           (when compile-time-too
118                             (fset name compiled-function)))
119                          (t
120                           (%format t ";  Unable to compile function ~A~%" name)
121                           (let ((precompiled-function (precompile-form expr nil)))
122                             (setf form
123                                   `(fset ',name
124                                          ,precompiled-function
125                                          ,*source-position*
126                                          ',lambda-list)))
127                           (when compile-time-too
128                             (eval form))))))
129                (push name jvm::*functions-defined-in-current-file*)
130                (jvm::note-name-defined name)
131                ;; If NAME is not fbound, provide a dummy definition so that
132                ;; getSymbolFunctionOrDie() will succeed when we try to verify that
133                ;; functions defined later in the same file can be loaded correctly.
134                (unless (fboundp name)
135                  (setf (fdefinition name) #'dummy)
136                  (push name *fbound-names*)))))
137           ((DEFGENERIC DEFMETHOD)
138            (jvm::note-name-defined (second form))
139            (process-toplevel-form (macroexpand-1 form) stream compile-time-too)
140            (return-from process-toplevel-form))
141           (DEFMACRO
142            (let ((name (second form)))
143              (%format t "; Processing macro ~A~%" name)
144              (eval form)
145              (let* ((expr (function-lambda-expression (macro-function name)))
146                     (classfile-name (next-classfile-name))
147                     (classfile
148                      (ignore-errors
149                       (jvm:compile-defun nil expr nil classfile-name))))
150                (if (verify-load classfile)
151                    (progn
152                      (%format t ";  Macro ~A => ~A.cls~%" name
153                               (pathname-name (pathname classfile-name)))
154                      (setf form
155                            (if (special-operator-p name)
156                                `(%put ',name 'macroexpand-macro
157                                       (make-macro ',name
158                                                   (load-compiled-function
159                                                    ,(file-namestring classfile))))
160                                `(fset ',name
161                                       (make-macro ',name
162                                                   (load-compiled-function
163                                                    ,(file-namestring classfile)))
164                                       ,*source-position*
165                                       ',(third form)))))
166                    (%format t ";  Unable to compile macro ~A~%" name)))))
167           (DEFTYPE
168            (eval form))
169           (EVAL-WHEN
170            (multiple-value-bind (ct lt e) (parse-eval-when-situations (cadr form))
171              (let ((new-compile-time-too (or ct
172                                              (and compile-time-too e)))
173                    (body (cddr form)))
174                (cond (lt
175                       (process-toplevel-progn body stream new-compile-time-too))
176                      (new-compile-time-too
177                       (eval `(progn ,@body)))))
178              (return-from process-toplevel-form)))
179           (LOCALLY
180            ;; FIXME Need to handle special declarations too!
181            (let ((jvm:*speed* jvm:*speed*)
182                  (jvm:*safety* jvm:*safety*)
183                  (jvm:*debug* jvm:*debug*))
184              (jvm::process-optimization-declarations (cdr form))
185              (process-toplevel-progn (cdr form) stream compile-time-too)
186              (return-from process-toplevel-form)))
187           (PROGN
188            (process-toplevel-progn (cdr form) stream compile-time-too)
189            (return-from process-toplevel-form))
190           (t
191            (when (and (symbolp (car form))
192                       (macro-function (car form)))
193              (process-toplevel-form (macroexpand-1 form) stream compile-time-too)
194              (return-from process-toplevel-form))
195            (when compile-time-too
196              (eval form))))))
197  (when (and (consp form) (neq (car form) 'QUOTE))
198    (let ((*print-fasl* t)
199          (*print-level* nil)
200          (*print-length* nil)
201          (*print-circle* nil))
202      (if (eq (car form) 'IMPORT)
203          ;; Make sure package prefix is printed when symbols are imported.
204          (let ((*package* (find-package "COMMON-LISP")))
205            (write form :stream stream))
206          (write form :stream stream)))
207    (terpri stream)))
208
209(defun process-toplevel-progn (forms stream compile-time-too)
210  (dolist (form forms)
211    (process-toplevel-form form stream compile-time-too)))
212
213;;; Adapted from SBCL.
214;;; Parse an EVAL-WHEN situations list, returning three flags,
215;;; (VALUES COMPILE-TOPLEVEL LOAD-TOPLEVEL EXECUTE), indicating
216;;; the types of situations present in the list.
217(defun parse-eval-when-situations (situations)
218  (when (or (not (listp situations))
219      (set-difference situations
220          '(:compile-toplevel
221            compile
222            :load-toplevel
223            load
224            :execute
225            eval)))
226    (error "Bad EVAL-WHEN situation list: ~S." situations))
227  (values (intersection '(:compile-toplevel compile) situations)
228    (intersection '(:load-toplevel load) situations)
229    (intersection '(:execute eval) situations)))
230
231(defun compile-file (input-file &key output-file verbose print external-format)
232  (unless (or (and (probe-file input-file) (not (file-directory-p input-file)))
233              (pathname-type input-file))
234    (let ((pathname (merge-pathnames (make-pathname :type "lisp") input-file)))
235      (when (probe-file pathname)
236        (setf input-file pathname))))
237  (unless output-file
238    (setf output-file (compile-file-pathname input-file)))
239  (let* ((*output-file-pathname* output-file)
240         (type (pathname-type output-file))
241         (temp-file (merge-pathnames (make-pathname :type (concatenate 'string type "-tmp"))
242                                     output-file))
243         (warnings-p t)
244         (failure-p t))
245    (with-open-file (in input-file :direction :input)
246      (let* ((*compile-file-pathname* (pathname in))
247             (*compile-file-truename* (truename in))
248             (*class-number* 0)
249             (namestring (namestring *compile-file-truename*))
250             (start (get-internal-real-time))
251             elapsed)
252        (%format t "; Compiling ~A ...~%" namestring)
253        (with-compilation-unit ()
254          (with-open-file (out temp-file :direction :output :if-exists :supersede)
255            (let ((*readtable* *readtable*)
256                  (*package* *package*)
257                  (jvm:*speed* jvm:*speed*)
258                  (jvm:*safety* jvm:*safety*)
259                  (jvm:*debug* jvm:*debug*)
260                  (jvm::*functions-defined-in-current-file* '())
261                  (*fbound-names* '()))
262              (write "; -*- Mode: Lisp -*-" :escape nil :stream out)
263              (terpri out)
264              (let ((*package* (find-package '#:cl)))
265                (write (list 'init-fasl :version *fasl-version*) :stream out)
266                (terpri out)
267                (write (list 'setq '*fasl-source* *compile-file-truename*) :stream out)
268                (terpri out))
269              (loop
270                (let* ((*source-position* (file-position in))
271                       (form (read in nil in)))
272                  (when (eq form in)
273                    (return))
274                  (process-toplevel-form form out nil)))
275              (dolist (name *fbound-names*)
276                (fmakunbound name))))
277          (cond ((zerop (+ jvm::*errors* jvm::*warnings* jvm::*style-warnings*))
278                 (setf warnings-p nil failure-p nil))
279                ((zerop (+ jvm::*errors* jvm::*warnings*))
280                 (setf failure-p nil))))
281        (setf elapsed (/ (- (get-internal-real-time) start) 1000.0))
282        (rename-file temp-file output-file)
283        (%format t "; Compiled ~A (~A seconds)~%" namestring elapsed)))
284    (values (truename output-file) warnings-p failure-p)))
Note: See TracBrowser for help on using the repository browser.