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

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

Work in progress (tested).

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