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

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

PROCESS-TOPLEVEL-FORM: better handling of declarations in LOCALLY case.

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