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

Last change on this file since 8416 was 8416, checked in by piso, 17 years ago

Work in progress (tested).

File size: 12.5 KB
Line 
1;;; compile-file.lisp
2;;;
3;;; Copyright (C) 2004-2005 Peter Graves
4;;; $Id: compile-file.lisp,v 1.52 2005-01-31 05:54:14 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::*toplevel-defuns*)
130                ;; If NAME is not fbound, provide a dummy definition so that
131                ;; getSymbolFunctionOrDie() will succeed when we try to verify that
132                ;; functions defined later in the same file can be loaded correctly.
133                (unless (fboundp name)
134                  (setf (symbol-function name) #'dummy)
135                  (push name *fbound-names*)))))
136           (DEFMACRO
137            (let ((name (second form)))
138              (%format t "; Processing macro ~A~%" name)
139              (eval form)
140              (let* ((expr (function-lambda-expression (macro-function name)))
141                     (classfile-name (next-classfile-name))
142                     (classfile
143                      (ignore-errors
144                       (jvm:compile-defun nil expr nil classfile-name))))
145                (if (verify-load classfile)
146                    (progn
147                      (%format t ";  Macro ~A => ~A.cls~%" name
148                               (pathname-name (pathname classfile-name)))
149                      (setf form
150                            (if (special-operator-p name)
151                                `(%put ',name 'macroexpand-macro
152                                       (make-macro ',name
153                                                   (load-compiled-function
154                                                    ,(file-namestring classfile))))
155                                `(fset ',name
156                                       (make-macro ',name
157                                                   (load-compiled-function
158                                                    ,(file-namestring classfile)))
159                                       ,*source-position*
160                                       ',(third form)))))
161                    (%format t ";  Unable to compile macro ~A~%" name)))))
162           (DEFTYPE
163            (eval form))
164           (EVAL-WHEN
165            (multiple-value-bind (ct lt e) (parse-eval-when-situations (cadr form))
166              (let ((new-compile-time-too (or ct
167                                              (and compile-time-too e)))
168                    (body (cddr form)))
169                (cond (lt
170                       (process-toplevel-progn body stream new-compile-time-too))
171                      (new-compile-time-too
172                       (eval `(progn ,@body)))))
173              (return-from process-toplevel-form)))
174           (LOCALLY
175            ;; FIXME Need to handle special declarations too!
176            (let ((jvm:*speed* jvm:*speed*)
177                  (jvm:*safety* jvm:*safety*)
178                  (jvm:*debug* jvm:*debug*))
179              (jvm::process-optimization-declarations (cdr form))
180              (process-toplevel-progn (cdr form) stream compile-time-too)
181              (return-from process-toplevel-form)))
182           (PROGN
183            (process-toplevel-progn (cdr form) stream compile-time-too)
184            (return-from process-toplevel-form))
185           (t
186            (when (and (symbolp (car form))
187                       (macro-function (car form)))
188              (process-toplevel-form (macroexpand-1 form) stream compile-time-too)
189              (return-from process-toplevel-form))
190            (when compile-time-too
191              (eval form))))))
192  (when (and (consp form) (neq (car form) 'QUOTE))
193    (let ((*print-fasl* t)
194          (*print-level* nil)
195          (*print-length* nil)
196          (*print-circle* nil))
197      (if (eq (car form) 'IMPORT)
198          ;; Make sure package prefix is printed when symbols are imported.
199          (let ((*package* (find-package "COMMON-LISP")))
200            (write form :stream stream))
201          (write form :stream stream)))
202    (terpri stream)))
203
204(defun process-toplevel-progn (forms stream compile-time-too)
205  (dolist (form forms)
206    (process-toplevel-form form stream compile-time-too)))
207
208;;; Adapted from SBCL.
209;;; Parse an EVAL-WHEN situations list, returning three flags,
210;;; (VALUES COMPILE-TOPLEVEL LOAD-TOPLEVEL EXECUTE), indicating
211;;; the types of situations present in the list.
212(defun parse-eval-when-situations (situations)
213  (when (or (not (listp situations))
214      (set-difference situations
215          '(:compile-toplevel
216            compile
217            :load-toplevel
218            load
219            :execute
220            eval)))
221    (error "Bad EVAL-WHEN situation list: ~S." situations))
222  (values (intersection '(:compile-toplevel compile) situations)
223    (intersection '(:load-toplevel load) situations)
224    (intersection '(:execute eval) situations)))
225
226(defun compile-file (input-file &key output-file verbose print external-format)
227  (unless (or (and (probe-file input-file) (not (file-directory-p input-file)))
228              (pathname-type input-file))
229    (let ((pathname (merge-pathnames (make-pathname :type "lisp") input-file)))
230      (when (probe-file pathname)
231        (setf input-file pathname))))
232  (unless output-file
233    (setf output-file (compile-file-pathname input-file)))
234  (let* ((*output-file-pathname* output-file)
235         (type (pathname-type output-file))
236         (temp-file (merge-pathnames (make-pathname :type (concatenate 'string type "-tmp"))
237                                     output-file))
238         (warnings-p t)
239         (failure-p t))
240    (with-open-file (in input-file :direction :input)
241      (let* ((*compile-file-pathname* (pathname in))
242             (*compile-file-truename* (truename in))
243             (*class-number* 0)
244             (namestring (namestring *compile-file-truename*))
245             (start (get-internal-real-time))
246             elapsed)
247        (%format t "; Compiling ~A ...~%" namestring)
248        (jvm::with-compilation-unit
249         (with-open-file (out temp-file :direction :output :if-exists :supersede)
250           (let ((*readtable* *readtable*)
251                 (*package* *package*)
252                 (jvm:*speed* jvm:*speed*)
253                 (jvm:*safety* jvm:*safety*)
254                 (jvm:*debug* jvm:*debug*)
255                 (jvm::*toplevel-defuns* ())
256                 (*fbound-names* ()))
257             (write "; -*- Mode: Lisp -*-" :escape nil :stream out)
258             (terpri out)
259             (let ((*package* (find-package '#:cl)))
260               (write (list 'init-fasl :version *fasl-version*) :stream out)
261               (terpri out)
262               (write (list 'setq '*fasl-source* *compile-file-truename*) :stream out)
263               (terpri out))
264             (loop
265               (let* ((*source-position* (file-position in))
266                      (form (read in nil in)))
267                 (when (eq form in)
268                   (return))
269                 (process-toplevel-form form out nil)))
270             (dolist (name *fbound-names*)
271               (fmakunbound name))))
272         (cond
273          ((zerop (+ jvm::*errors* jvm::*warnings* jvm::*style-warnings*))
274           (setf warnings-p nil failure-p nil))
275          ((zerop (+ jvm::*errors* jvm::*warnings*))
276           (setf failure-p nil))))
277        (setf elapsed (/ (- (get-internal-real-time) start) 1000.0))
278        (rename-file temp-file output-file)
279        (%format t "; Compiled ~A (~A seconds)~%" namestring elapsed)))
280    (values (truename output-file) warnings-p failure-p)))
Note: See TracBrowser for help on using the repository browser.