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

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

PROCESS-TOPLEVEL-FORM: use the correct block name for SETF functions.

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