source: trunk/abcl/src/org/armedbear/lisp/compile-file.lisp

Last change on this file was 14915, checked in by mevenson, 11 months ago

style: non-functional refactoring to non-dangling close parenthesis form

  • Property svn:eol-style set to native
  • Property svn:keywords set to Id
File size: 45.2 KB
Line 
1
2;;; compile-file.lisp
3;;;
4;;; Copyright (C) 2004-2006 Peter Graves
5;;; $Id: compile-file.lisp 14915 2016-11-24 10:31:24Z mevenson $
6;;;
7;;; This program is free software; you can redistribute it and/or
8;;; modify it under the terms of the GNU General Public License
9;;; as published by the Free Software Foundation; either version 2
10;;; of the License, or (at your option) any later version.
11;;;
12;;; This program is distributed in the hope that it will be useful,
13;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
14;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
15;;; GNU General Public License for more details.
16;;;
17;;; You should have received a copy of the GNU General Public License
18;;; along with this program; if not, write to the Free Software
19;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
20;;;
21;;; As a special exception, the copyright holders of this library give you
22;;; permission to link this library with independent modules to produce an
23;;; executable, regardless of the license terms of these independent
24;;; modules, and to copy and distribute the resulting executable under
25;;; terms of your choice, provided that you also meet, for each linked
26;;; independent module, the terms and conditions of the license of that
27;;; module.  An independent module is a module which is not derived from
28;;; or based on this library.  If you modify this library, you may extend
29;;; this exception to your version of the library, but you are not
30;;; obligated to do so.  If you do not wish to do so, delete this
31;;; exception statement from your version.
32
33(in-package #:system)
34
35(require "COMPILER-PASS2")
36
37
38(export 'compile-file-if-needed)
39
40(defvar *fbound-names*)
41
42(defvar *class-number*)
43
44(defvar *output-file-pathname*)
45
46(defvar *toplevel-functions*)
47(defvar *toplevel-macros*)
48(defvar *toplevel-exports*)
49(defvar *toplevel-setf-expanders*)
50(defvar *toplevel-setf-functions*)
51
52
53(defun base-classname (&optional (output-file-pathname *output-file-pathname*))
54  (sanitize-class-name (pathname-name output-file-pathname)))
55
56(defun fasl-loader-classname (&optional (output-file-pathname *output-file-pathname*))
57  (%format nil "~A_0" (base-classname output-file-pathname)))
58
59(declaim (ftype (function (t) t) compute-classfile))
60(defun compute-classfile (n &optional (output-file-pathname
61                                            *output-file-pathname*))
62  "Computes the pathname of the class file associated with number `n'."
63  (let ((name
64         (sanitize-class-name
65    (%format nil "~A_~D" (pathname-name output-file-pathname) n))))
66    (merge-pathnames (make-pathname :name name :type *compile-file-class-extension*)
67                                 output-file-pathname)))
68
69(defun sanitize-class-name (name)
70  (let ((name (copy-seq name)))
71    (dotimes (i (length name))
72      (declare (type fixnum i))
73      (when (or (char= (char name i) #\-)
74    (char= (char name i) #\.)
75    (char= (char name i) #\Space))
76        (setf (char name i) #\_)))
77    name))
78 
79
80(declaim (ftype (function () t) next-classfile))
81(defun next-classfile ()
82  (compute-classfile (incf *class-number*)))
83
84(defmacro report-error (&rest forms)
85  `(handler-case (progn ,@forms)
86     (compiler-unsupported-feature-error (condition)
87       (fresh-line)
88       (%format t "; UNSUPPORTED-FEATURE: ~A~%" condition)
89       (values nil condition))))
90
91;; Dummy function. Should never be called.
92(defun dummy (&rest ignored)
93  (declare (ignore ignored))
94  (assert nil))
95
96;;; ??? rename to something shorter?
97(defparameter *compiler-diagnostic* nil
98  "The stream to emit compiler diagnostic messages to, or nil to muffle output.")
99(export '*compiler-diagnostic*)
100(defmacro diag (fmt &rest args)
101  `(format *compiler-diagnostic* "~&SYSTEM::*COMPILER-DIAGNOSTIC* ~A~&" (format nil ,fmt ,@args)))
102
103(declaim (ftype (function (t) t) verify-load))
104(defun verify-load (classfile &key (force nil))
105  "Return whether the file at the path denoted by CLASSFILE is a loadable JVM artifact."
106  (declare (ignore force))
107  (unless classfile
108    (diag "Nil classfile argument passed to verify-load.")
109    (return-from verify-load nil))
110  (with-open-file (cf classfile :direction :input)
111    (when 
112        (= 0 (file-length cf))
113;;; TODO hook into a real ABCL compiler condition hierarchy
114      (diag "Internal compiler error detected: Fasl contains ~
115zero-length jvm classfile corresponding to ~A." classfile)
116      (return-from verify-load nil)))
117  ;; ### FIXME
118  ;; The section below can't work, because we have
119  ;; circular references between classes of outer- and innerscoped
120  ;; functions. We need the class loader to resolve these circular
121  ;; references for us. Our FASL class loader does exactly that,
122  ;; so we need a class loader here which knows how to find
123  ;; all the .cls files related to the current scope being loaded.
124  #+nil
125  (when (or force (> *safety* *speed*))
126    (diag "Testing compiled bytecode by loading classfile into JVM.")
127    (let ((*load-truename* *output-file-pathname*))
128      ;; load-compiled-function used to be wrapped via report-error
129      (return-from verify-load (load-compiled-function classfile))))
130  t)
131
132(declaim (ftype (function (t) t) note-toplevel-form))
133(defun note-toplevel-form (form)
134  (when *compile-print*
135    (fresh-line)
136    (princ "; ")
137    (let ((*print-length* 2)
138          (*print-level* 2)
139          (*print-pretty* nil))
140      (prin1 form))
141    (terpri)))
142
143(defun output-form (form)
144  (if *binary-fasls*
145      (push form *forms-for-output*)
146      (progn
147        (dump-form form *fasl-stream*)
148        (%stream-terpri *fasl-stream*))))
149
150(defun finalize-fasl-output ()
151  (when *binary-fasls*
152    (let ((*package* (find-package :keyword))
153          (*double-colon-package-separators* T))
154      (dump-form (convert-toplevel-form (list* 'PROGN
155                                               (nreverse *forms-for-output*))
156                                        t)
157                 *fasl-stream*))
158    (%stream-terpri *fasl-stream*)))
159
160
161(declaim (ftype (function (t) t) simple-toplevel-form-p))
162(defun simple-toplevel-form-p (form)
163  "Returns NIL if the form is too complex to become an
164interpreted toplevel form, non-NIL if it is 'simple enough'."
165  (and (consp form)
166       (every #'(lambda (arg)
167                  (or (and (atom arg)
168                           (not (and (symbolp arg)
169                                     (symbol-macro-p arg))))
170                      (and (consp arg)
171                           (eq 'QUOTE (car arg)))))
172              (cdr form))))
173
174(declaim (ftype (function (t t) t) convert-toplevel-form))
175(defun convert-toplevel-form (form declare-inline)
176  (when (or (simple-toplevel-form-p form)
177            (and (eq (car form) 'SETQ)
178                 ;; for SETQ, look at the evaluated part
179                 (simple-toplevel-form-p (third form))))
180    ;; single form with simple or constant arguments
181    ;; Without this exception, toplevel function calls
182    ;; will be compiled into lambdas which get compiled to
183    ;; compiled-functions. Those need to be loaded.
184    ;; Conclusion: Top level interpreting the function call
185    ;;  and its arguments may be (and should be) more efficient.
186    (return-from convert-toplevel-form
187      (precompiler:precompile-form form nil *compile-file-environment*)))
188  (let* ((toplevel-form (third form))
189         (expr `(lambda () ,form))
190         (saved-class-number *class-number*)
191         (classfile (next-classfile))
192         (result
193          (with-open-file
194              (f classfile
195                 :direction :output
196                 :element-type '(unsigned-byte 8)
197                 :if-exists :supersede)
198            (report-error (jvm:compile-defun nil
199                                             expr *compile-file-environment*
200                                             classfile f
201                                             declare-inline))))
202         (compiled-function (verify-load classfile)))
203    (declare (ignore toplevel-form result))
204    (progn
205      #+nil
206      (when (> *debug* 0)
207;; TODO        (annotate form toplevel-form classfile compiled-function fasl-class-number)
208        ;;; ??? define an API by perhaps exporting these symbols?
209        (setf (getf form 'form-source) 
210              toplevel-form
211             
212              (getf form 'classfile) 
213              classfile
214                   
215              (getf form 'compiled-function) 
216              compiled-function
217                 
218              (getf form 'class-number) 
219              saved-class-number))
220      (setf form
221            (if compiled-function
222                `(funcall (sys::get-fasl-function *fasl-loader*
223                                                  ,saved-class-number))
224                (precompiler:precompile-form form nil
225                                             *compile-file-environment*))))))
226
227
228(declaim (ftype (function (t stream t) t) process-progn))
229(defun process-progn (forms stream compile-time-too)
230  (dolist (form forms)
231    (process-toplevel-form form stream compile-time-too))
232  nil)
233
234
235(declaim (ftype (function (t t t) t) process-toplevel-form))
236(defun precompile-toplevel-form (form stream compile-time-too)
237  (declare (ignore stream))
238  (let ((form (precompiler:precompile-form form nil
239                                           *compile-file-environment*)))
240    (when compile-time-too
241      (eval form))
242    form))
243
244
245
246(defun process-toplevel-macrolet (form stream compile-time-too)
247  (let ((*compile-file-environment*
248         (make-environment *compile-file-environment*)))
249    (dolist (definition (cadr form))
250      (environment-add-macro-definition *compile-file-environment*
251                                        (car definition)
252                                        (make-macro (car definition)
253                                                    (make-macro-expander definition))))
254    (dolist (body-form (cddr form))
255      (process-toplevel-form body-form stream compile-time-too)))
256  nil)
257
258(declaim (ftype (function (t t t) t) process-toplevel-defconstant))
259(defun process-toplevel-defconstant (form stream compile-time-too)
260  (declare (ignore stream compile-time-too))
261  ;; "If a DEFCONSTANT form appears as a top level form, the compiler
262  ;; must recognize that [the] name names a constant variable. An
263  ;; implementation may choose to evaluate the value-form at compile
264  ;; time, load time, or both. Therefore, users must ensure that the
265  ;; initial-value can be evaluated at compile time (regardless of
266  ;; whether or not references to name appear in the file) and that
267  ;; it always evaluates to the same value."
268  (note-toplevel-form form)
269  (eval form)
270  `(progn
271     (put ',(second form) 'sys::source (cons '(,(second form) ,(namestring *source*) ,*source-position*) (get ',(second form)  'sys::source nil)))
272     ,form))
273
274(declaim (ftype (function (t t t) t) process-toplevel-quote))
275(defun process-toplevel-quote (form stream compile-time-too)
276  (declare (ignore stream))
277  (when compile-time-too
278    (eval form))
279  nil)
280
281
282(declaim (ftype (function (t t t) t) process-toplevel-import))
283(defun process-toplevel-import (form stream compile-time-too)
284  (declare (ignore stream))
285  (let ((form (precompiler:precompile-form form nil
286                                           *compile-file-environment*)))
287    (let ((*package* +keyword-package+))
288      (output-form form))
289    (when compile-time-too
290      (eval form)))
291  nil)
292
293(declaim (ftype (function (t t t) t) process-toplevel-export))
294(defun process-toplevel-export (form stream compile-time-too)
295  (when (and (listp (second form))
296             (eq (car (second form)) 'QUOTE)) ;; constant export list
297    (let ((sym-or-syms (second (second form))))
298      (setf *toplevel-exports*
299            (append  *toplevel-exports* (if (listp sym-or-syms)
300                                            sym-or-syms
301                                            (list sym-or-syms))))))
302  (precompile-toplevel-form form stream compile-time-too))
303
304
305(declaim (ftype (function (t t t) t) process-record-source-information))
306
307(defun process-record-source-information (form stream compile-time-too)
308  (declare (ignore stream compile-time-too))
309  (let* ((name (second form))
310   (type (third form)))
311    (when (quoted-form-p name) (setq name (second name)))
312    (when (quoted-form-p type) (setq type (second type)))
313    (let ((sym (if (consp name) (second name) name)))
314      `(put ',sym 'sys::source (cons '(,type ,(namestring *source*) ,*source-position*)
315           (get ',sym  'sys::source nil))))))
316
317   
318(declaim (ftype (function (t t t) t) process-toplevel-mop.ensure-method))
319(defun process-toplevel-mop.ensure-method (form stream compile-time-too)
320  (declare (ignore stream))
321  (flet ((convert-ensure-method (form key)
322           (let* ((tail (cddr form))
323                  (function-form (getf tail key)))
324             (when (and function-form (consp function-form)
325               (eq (%car function-form) 'FUNCTION))
326               (let ((lambda-expression (cadr function-form)))
327                 (jvm::with-saved-compiler-policy
328                     (let* ((saved-class-number *class-number*)
329                            (classfile (next-classfile))
330                            (result
331                             (with-open-file
332                                 (f classfile
333                                    :direction :output
334                                    :element-type '(unsigned-byte 8)
335                                    :if-exists :supersede)
336                               (report-error
337                                (jvm:compile-defun nil lambda-expression
338                                                   *compile-file-environment*
339                                                   classfile f nil))))
340                            (compiled-function (verify-load classfile)))
341                       (declare (ignore result))
342                       (cond
343                         (compiled-function
344                          (setf (getf tail key)
345                                `(sys::get-fasl-function *fasl-loader*
346                                                         ,saved-class-number)))
347                         (t
348                          ;; FIXME This should be a warning or error of some sort...
349                          (format *error-output* "; Unable to compile method~%"))))))))))
350
351
352    (when compile-time-too
353      (let* ((copy-form (copy-tree form))
354             ;; ### Ideally, the precompiler would leave the forms alone
355             ;;  and copy them where required, instead of forcing us to
356             ;;  do a deep copy in advance
357             (precompiled-form (precompiler:precompile-form copy-form nil
358                                                            *compile-file-environment*)))
359        (eval precompiled-form)))
360    (convert-ensure-method form :function)
361    (convert-ensure-method form :fast-function))
362  (precompiler:precompile-form form nil *compile-file-environment*))
363
364(declaim (ftype (function (t t t) t) process-toplevel-defvar/defparameter))
365(defun process-toplevel-defvar/defparameter (form stream compile-time-too)
366  (declare (ignore stream))
367  (note-toplevel-form form)
368  (if compile-time-too
369      (eval form)
370      ;; "If a DEFVAR or DEFPARAMETER form appears as a top level form,
371      ;; the compiler must recognize that the name has been proclaimed
372      ;; special. However, it must neither evaluate the initial-value
373      ;; form nor assign the dynamic variable named NAME at compile
374      ;; time."
375      (let ((name (second form)))
376        (%defvar name)))
377  (let ((name (second form)))
378    `(progn 
379       (put ',name 'sys::source (cons (list :variable ,(namestring *source*) ,*source-position*) (get ',name  'sys::source nil)))
380      ,form)))
381
382(declaim (ftype (function (t t t) t) process-toplevel-defpackage/in-package))
383(defun process-toplevel-defpackage/in-package (form stream compile-time-too)
384  (declare (ignore stream compile-time-too))
385  (note-toplevel-form form)
386  (let ((defpackage-name (and (eq (car form) 'defpackage) (intern (string (second form)) :keyword))) )
387    (setf form
388    (precompiler:precompile-form form nil *compile-file-environment*))
389    (eval form)
390    ;; Force package prefix to be used when dumping form.
391    (let ((*package* +keyword-package+))
392      (output-form form))
393    ;; a bit ugly here. Since we precompile, and added record-source-information we need to know where it is.
394    ;; The defpackage is at top, so we know where the name is (though it is a string by now)
395    ;; (if it is a defpackage)
396    (if defpackage-name
397  `(put ,defpackage-name 'sys::source
398        (cons '(:package ,(namestring *source*) ,*source-position*)
399        (get ,defpackage-name 'sys::source nil)))
400  nil)))
401
402(declaim (ftype (function (t t t) t) process-toplevel-declare))
403(defun process-toplevel-declare (form stream compile-time-too)
404  (declare (ignore stream compile-time-too))
405  (compiler-style-warn "Misplaced declaration: ~S" form)
406  nil)
407
408(declaim (ftype (function (t t t) t) process-toplevel-progn))
409(defun process-toplevel-progn (form stream compile-time-too)
410  (process-progn (cdr form) stream compile-time-too)
411  nil)
412
413(declaim (ftype (function (t t t) t) process-toplevel-deftype))
414(defun process-toplevel-deftype (form stream compile-time-too)
415  (declare (ignore stream compile-time-too))
416  (note-toplevel-form form)
417  (eval form)
418  `(progn
419     (put ',(second form) 'sys::source (cons '(,(second form) ,(namestring *source*) ,*source-position*) (get ',(second form)  'sys::source nil)))
420     ,form))
421
422(declaim (ftype (function (t t t) t) process-toplevel-eval-when))
423(defun process-toplevel-eval-when (form stream compile-time-too)
424  (flet ((parse-eval-when-situations (situations)
425           "Parse an EVAL-WHEN situations list, returning three flags,
426            (VALUES COMPILE-TOPLEVEL LOAD-TOPLEVEL EXECUTE), indicating
427            the types of situations present in the list."
428            ; Adapted from SBCL.
429           (when (or (not (listp situations))
430                     (set-difference situations
431                                     '(:compile-toplevel
432                                       compile
433                                       :load-toplevel
434                                       load
435                                       :execute
436                                       eval)))
437             (error "Bad EVAL-WHEN situation list: ~S." situations))
438           (values (intersection '(:compile-toplevel compile) situations)
439                   (intersection '(:load-toplevel load) situations)
440                   (intersection '(:execute eval) situations))))
441    (multiple-value-bind (ct lt e)
442        (parse-eval-when-situations (cadr form))
443      (let ((new-compile-time-too (or ct (and compile-time-too e)))
444            (body (cddr form)))
445        (if lt
446            (process-progn body stream new-compile-time-too)
447            (when new-compile-time-too
448              (eval `(progn ,@body)))))))
449  nil)
450
451
452(declaim (ftype (function (t t t) t) process-toplevel-defmethod/defgeneric))
453(defun process-toplevel-defmethod/defgeneric (form stream compile-time-too)
454  (note-toplevel-form form)
455  (note-name-defined (second form))
456  (push (second form) *toplevel-functions*)
457  (when (and (consp (second form))
458             (eq 'setf (first (second form))))
459    (push (second (second form))
460          *toplevel-setf-functions*))
461  (let ((*compile-print* nil))
462    (process-toplevel-form (macroexpand-1 form *compile-file-environment*)
463           stream compile-time-too))
464  (let* ((sym (if (consp (second form)) (second (second form)) (second form))))
465    (when (eq (car form) 'defgeneric)
466      `(progn
467   (put ',sym 'sys::source
468        (cons  '((:generic-function ,(second form)) ,(namestring *source*) ,*source-position*) (get ',sym  'sys::source nil)))
469   ,@(loop for method-form in (cdddr form)
470     when (eq (car method-form) :method)
471       collect
472       (multiple-value-bind (function-name qualifiers lambda-list specializers documentation declarations body) 
473           (mop::parse-defmethod `(,(second form) ,@(rest method-form)))
474                     ;;; FIXME: style points for refactoring double backquote to "normal" form
475         `(put ',sym 'sys::source
476         (cons `((:method ,',sym ,',qualifiers ,',specializers) ,,(namestring *source*) ,,*source-position*)
477         (get ',sym  'sys::source nil)))))))))
478
479
480(declaim (ftype (function (t t t) t) process-toplevel-locally))
481(defun process-toplevel-locally (form stream compile-time-too)
482  (jvm::with-saved-compiler-policy
483      (multiple-value-bind (forms decls)
484          (parse-body (cdr form) nil)
485        (process-optimization-declarations decls)
486        (let* ((jvm::*visible-variables* jvm::*visible-variables*)
487               (specials (jvm::process-declarations-for-vars (cdr form)
488                                                             nil nil)))
489          (dolist (special specials)
490            (push special jvm::*visible-variables*))
491          (process-progn forms stream compile-time-too))))
492  nil)
493
494(declaim (ftype (function (t t t) t) process-toplevel-defmacro))
495(defun process-toplevel-defmacro (form stream compile-time-too)
496  (declare (ignore stream compile-time-too))
497  (note-toplevel-form form)
498  (let ((name (second form)))
499    (eval form)
500    (push name *toplevel-macros*)
501    (let* ((expr (function-lambda-expression (macro-function name)))
502           (saved-class-number *class-number*)
503           (classfile (next-classfile)))
504      (with-open-file
505          (f classfile
506             :direction :output
507             :element-type '(unsigned-byte 8)
508             :if-exists :supersede)
509        (ignore-errors
510          (jvm:compile-defun nil expr *compile-file-environment*
511                             classfile f nil)))
512      (when (null (verify-load classfile))
513        ;; FIXME error or warning
514        (format *error-output* "; Unable to compile macro ~A~%" name)
515        (return-from process-toplevel-defmacro form))
516
517      (if (special-operator-p name)
518          `(put ',name 'macroexpand-macro
519                (make-macro ',name
520                            (sys::get-fasl-function *fasl-loader*
521                                                    ,saved-class-number)))
522    `(progn
523       (put ',name 'sys::source
524      (cons '(:macro  ,(namestring *source*) ,*source-position*) (get ',name  'sys::source nil)))
525       (fset ',name
526       (make-macro ',name
527             (sys::get-fasl-function *fasl-loader*
528                   ,saved-class-number))
529       ,*source-position*
530       ',(third form)
531       ,(%documentation name 'cl:function)))))))
532
533(declaim (ftype (function (t t t) t) process-toplevel-defun))
534(defun process-toplevel-defun (form stream compile-time-too)
535  (declare (ignore stream))
536  (note-toplevel-form form)
537  (let* ((name (second form))
538         (block-name (fdefinition-block-name name))
539         (lambda-list (third form))
540         (body (nthcdr 3 form)))
541    (jvm::with-saved-compiler-policy
542        (multiple-value-bind (body decls doc)
543            (parse-body body)
544          (let* ((expr `(lambda ,lambda-list
545                          ,@decls (block ,block-name ,@body)))
546                 (saved-class-number *class-number*)
547                 (classfile (next-classfile))
548                 (internal-compiler-errors nil)
549                 (result (with-open-file
550                             (f classfile
551                                :direction :output
552                                :element-type '(unsigned-byte 8)
553                                :if-exists :supersede)
554                           (handler-bind
555                               ((internal-compiler-error
556                                 #'(lambda (e)
557                                     (push e internal-compiler-errors)
558                                     (continue))))
559                             (report-error
560                              (jvm:compile-defun name expr *compile-file-environment*
561                                                 classfile f nil)))))
562                 (compiled-function (if (not internal-compiler-errors)
563                                        (verify-load classfile)
564                                        nil)))
565            (declare (ignore result))
566            (cond
567              ((and (not internal-compiler-errors)
568                    compiled-function)
569               (when compile-time-too
570                 (eval form))
571         (let ((sym (if (consp name) (second name) name)))
572     (setf form
573           `(progn
574       (put ',sym 'sys::source (cons '((:function ,name)  ,(namestring *source*) ,*source-position*) (get ',sym  'sys::source nil)))           
575       (fset ',name
576                            (sys::get-fasl-function *fasl-loader*
577                                                    ,saved-class-number)
578                            ,*source-position*
579                            ',lambda-list
580                            ,doc)))))
581              (t
582               (compiler-warn "Unable to compile function ~A.  Using interpreted form instead.~%" name)
583               (when internal-compiler-errors
584                 (dolist (e internal-compiler-errors)
585                   (format *error-output*
586                           "; ~A~%" e)))
587               (let ((precompiled-function
588                      (precompiler:precompile-form expr nil
589                                                   *compile-file-environment*)))
590                 (setf form
591                       `(fset ',name
592                              ,precompiled-function
593                              ,*source-position*
594                              ',lambda-list
595                              ,doc)))
596               (when compile-time-too
597                 (eval form)))))
598          (when (and (symbolp name) (eq (get name '%inline) 'INLINE))
599            ;; FIXME Need to support SETF functions too!
600            (setf (inline-expansion name)
601                  (jvm::generate-inline-expansion block-name
602                                                  lambda-list
603                                                  (append decls body)))
604            (output-form `(setf (inline-expansion ',name)
605                                ',(inline-expansion name))))))
606    (push name jvm::*functions-defined-in-current-file*)
607    (note-name-defined name)
608    (push name *toplevel-functions*)
609    (when (and (consp name)
610               (eq 'setf (first name)))
611      (push (second name) *toplevel-setf-functions*))
612    ;; If NAME is not fbound, provide a dummy definition so that
613    ;; getSymbolFunctionOrDie() will succeed when we try to verify that
614    ;; functions defined later in the same file can be loaded correctly.
615    (unless (fboundp name)
616      (setf (fdefinition name) #'dummy)
617      (push name *fbound-names*)))
618  form)
619
620
621;; toplevel handlers
622;;   each toplevel handler takes a form and stream as input
623
624(defun install-toplevel-handler (symbol handler)
625  (setf (get symbol 'toplevel-handler) handler))
626
627(dolist (pair '((COMPILER-DEFSTRUCT precompile-toplevel-form)
628                (DECLARE process-toplevel-declare)
629                (DEFCONSTANT process-toplevel-defconstant)
630                (DEFGENERIC process-toplevel-defmethod/defgeneric)
631                (DEFMACRO process-toplevel-defmacro)
632                (DEFMETHOD process-toplevel-defmethod/defgeneric)
633                (DEFPACKAGE process-toplevel-defpackage/in-package)
634                (DEFPARAMETER process-toplevel-defvar/defparameter)
635                (DEFTYPE process-toplevel-deftype)
636                (DEFUN process-toplevel-defun)
637                (DEFVAR process-toplevel-defvar/defparameter)
638                (EVAL-WHEN process-toplevel-eval-when)
639                (EXPORT process-toplevel-export)
640                (IMPORT process-toplevel-import)
641                (IN-PACKAGE process-toplevel-defpackage/in-package)
642                (LOCALLY process-toplevel-locally)
643                (MACROLET process-toplevel-macrolet)
644                (PROCLAIM precompile-toplevel-form)
645                (PROGN process-toplevel-progn)
646                (PROVIDE precompile-toplevel-form)
647                (PUT precompile-toplevel-form)
648                (QUOTE process-toplevel-quote)
649                (REQUIRE precompile-toplevel-form)
650                (SHADOW precompile-toplevel-form)
651                (%SET-FDEFINITION precompile-toplevel-form)
652                (MOP::ENSURE-METHOD process-toplevel-mop.ensure-method)
653    (record-source-information-for-type process-record-source-information)))
654  (install-toplevel-handler (car pair) (cadr pair)))
655
656(declaim (ftype (function (t stream t) t) process-toplevel-form))
657(defun process-toplevel-form (form stream compile-time-too)
658  (unless (atom form)
659    (let* ((operator (%car form))
660           (handler (get operator 'toplevel-handler)))
661      (when handler
662        (let ((out-form (funcall handler form stream compile-time-too)))
663          (when out-form
664            (output-form out-form)))
665        (return-from process-toplevel-form))
666      (when (and (symbolp operator)
667                 (macro-function operator *compile-file-environment*))
668        (when (eq operator 'define-setf-expander) ;; ??? what if the symbol is package qualified?
669          (push (second form) *toplevel-setf-expanders*))
670        (when (and (eq operator 'defsetf) ;; ??? what if the symbol is package qualified?
671                   (consp (third form))) ;; long form of DEFSETF
672          (push (second form) *toplevel-setf-expanders*))
673        (note-toplevel-form form)
674        ;; Note that we want MACROEXPAND-1 and not MACROEXPAND here, in
675        ;; case the form being expanded expands into something that needs
676        ;; special handling by PROCESS-TOPLEVEL-FORM (e.g. DEFMACRO).
677        (let ((*compile-print* nil))
678          (process-toplevel-form (macroexpand-1 form *compile-file-environment*)
679                                 stream compile-time-too))
680        (return-from process-toplevel-form))
681      (cond
682        ((and (symbolp operator)
683              (not (special-operator-p operator))
684              (null (cdr form)))
685         (setf form (precompiler:precompile-form form nil
686                                                 *compile-file-environment*)))
687        (t
688         (note-toplevel-form form)
689         (setf form (convert-toplevel-form form nil)))))
690    (when (consp form)
691      (output-form form)))
692  ;; Make sure the compiled-function loader knows where
693  ;; to load the compiled functions. Note that this trickery
694  ;; was already used in verify-load before I used it,
695  ;; however, binding *load-truename* isn't fully compliant, I think.
696  (when compile-time-too
697    (let ((*load-truename* *output-file-pathname*)
698          (*fasl-loader* (make-fasl-class-loader
699                          (concatenate 'string
700                                       "org.armedbear.lisp." (base-classname)))))
701      (eval form))))
702
703(defun populate-zip-fasl (output-file)
704  (let* ((type ;; Don't use ".zip", it'll result in an extension with
705               ;; a dot, which is rejected by NAMESTRING
706          (%format nil "~A~A" (pathname-type output-file) "-zip"))
707         (output-file (if (logical-pathname-p output-file)
708                          (translate-logical-pathname output-file)
709                          output-file))
710         (zipfile 
711          (if (find :windows *features*)
712              (make-pathname :defaults output-file :type type)
713              (make-pathname :defaults output-file :type type
714                             :device :unspecific)))
715         (pathnames nil)
716         (fasl-loader (make-pathname :defaults output-file
717                                     :name (fasl-loader-classname)
718                                     :type *compile-file-class-extension*)))
719    (when (probe-file fasl-loader)
720      (push fasl-loader pathnames))
721    (dotimes (i *class-number*)
722      (let ((truename (probe-file (compute-classfile (1+ i)))))
723        (when truename
724          (push truename pathnames)
725          ;;; XXX it would be better to just use the recorded number
726          ;;; of class constants, but probing for the first at least
727          ;;; makes this subjectively bearable.
728          (when (probe-file
729                 (make-pathname :name (format nil "~A_0"
730                                              (pathname-name truename))
731                                :type "clc"
732                                :defaults truename))
733            (dolist (resource (directory
734                               (make-pathname :name (format nil "~A_*"
735                                                            (pathname-name truename))
736                                              :type "clc"
737                                              :defaults truename)))
738              (push resource pathnames))))))
739    (setf pathnames (nreverse (remove nil pathnames)))
740    (let ((load-file (make-pathname :defaults output-file
741                                    :name "__loader__"
742                                    :type "_")))
743      (rename-file output-file load-file)
744      (push load-file pathnames))
745    (zip zipfile pathnames)
746    (dolist (pathname pathnames)
747      (ignore-errors (delete-file pathname)))
748    (rename-file zipfile output-file)))
749
750(defun write-fasl-prologue (stream)
751  (let ((out stream))
752    ;; write header
753    (write "; -*- Mode: Lisp -*-" :escape nil :stream out)
754    (%stream-terpri out)
755    (write (list 'init-fasl :version *fasl-version*) :stream out)
756    (%stream-terpri out)
757    (write (list 'setq '*source* *compile-file-truename*) :stream out)
758    (%stream-terpri out)
759
760    ;; Note: Beyond this point, you can't use DUMP-FORM,
761    ;; because the list of uninterned symbols has been fixed now.
762    (when *fasl-uninterned-symbols*
763      (write (list 'setq '*fasl-uninterned-symbols*
764                   (coerce (mapcar #'car (nreverse *fasl-uninterned-symbols*))
765                           'vector))
766             :stream out :length nil))
767    (%stream-terpri out)
768
769    (when (> *class-number* 0)
770      (write (list 'setq '*fasl-loader*
771                   `(sys::make-fasl-class-loader
772                     ,(concatenate 'string "org.armedbear.lisp."
773                                   (base-classname))))
774             :stream out))
775    (%stream-terpri out)))
776
777
778
779(defvar *binary-fasls* nil)
780(defvar *forms-for-output* nil)
781(defvar *fasl-stream* nil)
782
783(defun compile-from-stream (in output-file temp-file temp-file2
784                            extract-toplevel-funcs-and-macros
785                            functions-file macros-file exports-file 
786                            setf-functions-file setf-expanders-file)
787  (let* ((*compile-file-pathname* (make-pathname :defaults (pathname in)
788                                                 :version nil))
789         (*compile-file-truename* (make-pathname :defaults (truename in)
790                                                 :version nil))
791         (*source* *compile-file-truename*)
792         (*class-number* 0)
793         (namestring (namestring *compile-file-truename*))
794         (start (get-internal-real-time))
795         *fasl-uninterned-symbols*
796         (warnings-p nil)
797         (failure-p nil))
798    (when *compile-verbose*
799      (format t "; Compiling ~A ...~%" namestring))
800    (with-compilation-unit ()
801      (with-open-file (out temp-file
802                           :direction :output :if-exists :supersede
803                           :external-format *fasl-external-format*)
804        (let ((*readtable* *readtable*)
805              (*read-default-float-format* *read-default-float-format*)
806              (*read-base* *read-base*)
807              (*package* *package*)
808              (jvm::*functions-defined-in-current-file* '())
809              (*fbound-names* '())
810              (*fasl-stream* out)
811              *forms-for-output*)
812          (jvm::with-saved-compiler-policy
813            (jvm::with-file-compilation
814              (handler-bind
815                  ((style-warning 
816                    #'(lambda (c)
817                        (setf warnings-p t)
818                        ;; let outer handlers do their thing
819                        (signal c)
820                        ;; prevent the next handler
821                        ;; from running: we're a
822                        ;; WARNING subclass
823                        (continue)))
824                   ((or warning compiler-error)
825                    #'(lambda (c)
826                        (declare (ignore c))
827                        (setf warnings-p t
828                              failure-p t))))
829                (loop
830                   (let* ((*source-position* (file-position in))
831                          (jvm::*source-line-number* (stream-line-number in))
832                          (form (read in nil in))
833                          (*compiler-error-context* form))
834                     (when (eq form in)
835                       (return))
836                     (process-toplevel-form form out nil))))
837                    (finalize-fasl-output)
838                    (dolist (name *fbound-names*)
839                      (fmakunbound name)))))))
840        (when extract-toplevel-funcs-and-macros
841          (setf *toplevel-functions*
842                (remove-if-not (lambda (func-name)
843                                 (if (symbolp func-name)
844                                     (symbol-package func-name)
845                                     T))
846                               (remove-duplicates
847                            *toplevel-functions*)))
848          (when *toplevel-functions*
849            (with-open-file (f-out functions-file
850                                   :direction :output
851                                   :if-does-not-exist :create
852                                   :if-exists :supersede)
853
854              (let ((*package* (find-package :keyword)))
855                (write *toplevel-functions* :stream f-out))))
856          (setf *toplevel-macros*
857                (remove-if-not (lambda (mac-name)
858                                 (if (symbolp mac-name)
859                                     (symbol-package mac-name)
860                                     T))
861                               (remove-duplicates *toplevel-macros*)))
862          (when *toplevel-macros*
863            (with-open-file (m-out macros-file
864                                   :direction :output
865                                   :if-does-not-exist :create
866                                   :if-exists :supersede)
867              (let ((*package* (find-package :keyword)))
868                (write *toplevel-macros* :stream m-out))))
869          (setf *toplevel-exports*
870                (remove-if-not (lambda (sym)
871                                 (if (symbolp sym)
872                                     (symbol-package sym)
873                                     T))
874                               (remove-duplicates *toplevel-exports*)))
875          (when *toplevel-exports*
876            (with-open-file (e-out exports-file
877                                   :direction :output
878                                   :if-does-not-exist :create
879                                   :if-exists :supersede)
880              (let ((*package* (find-package :keyword)))
881                (write *toplevel-exports* :stream e-out))))
882          (setf *toplevel-setf-functions*
883                (remove-if-not (lambda (sym)
884                                 (if (symbolp sym)
885                                     (symbol-package sym)
886                                     T))
887                               (remove-duplicates *toplevel-setf-functions*)))
888          (when *toplevel-setf-functions*
889            (with-open-file (e-out setf-functions-file
890                                   :direction :output
891                                   :if-does-not-exist :create
892                                   :if-exists :supersede)
893              (let ((*package* (find-package :keyword)))
894                (write *toplevel-setf-functions* :stream e-out))))
895          (setf *toplevel-setf-expanders*
896                (remove-if-not (lambda (sym)
897                                 (if (symbolp sym)
898                                     (symbol-package sym)
899                                     T))
900                               (remove-duplicates *toplevel-setf-expanders*)))
901          (when *toplevel-setf-expanders*
902            (with-open-file (e-out setf-expanders-file
903                                   :direction :output
904                                   :if-does-not-exist :create
905                                   :if-exists :supersede)
906              (let ((*package* (find-package :keyword)))
907                (write *toplevel-setf-expanders* :stream e-out)))))
908        (with-open-file (in temp-file :direction :input :external-format *fasl-external-format*)
909          (with-open-file (out temp-file2 :direction :output
910                               :if-does-not-exist :create
911                               :if-exists :supersede
912                               :external-format *fasl-external-format*)
913            (let ((*package* (find-package '#:cl))
914                  (*print-fasl* t)
915                  (*print-array* t)
916                  (*print-base* 10)
917                  (*print-case* :upcase)
918                  (*print-circle* nil)
919                  (*print-escape* t)
920                  (*print-gensym* t)
921                  (*print-length* nil)
922                  (*print-level* nil)
923                  (*print-lines* nil)
924                  (*print-pretty* nil)
925                  (*print-radix* nil)
926                  (*print-readably* t)
927                  (*print-right-margin* nil)
928                  (*print-structure* t)
929
930                  ;; make sure to write all floats with their exponent marker:
931                  ;; the dump-time default may not be the same at load-time
932
933                  (*read-default-float-format* nil))
934
935              ;; these values are also bound by WITH-STANDARD-IO-SYNTAX,
936              ;; but not used by our reader/printer, so don't bind them,
937              ;; for efficiency reasons.
938              ;;        (*read-eval* t)
939              ;;        (*read-suppress* nil)
940              ;;        (*print-miser-width* nil)
941              ;;        (*print-pprint-dispatch* (copy-pprint-dispatch nil))
942              ;;        (*read-base* 10)
943              ;;        (*read-default-float-format* 'single-float)
944              ;;        (*readtable* (copy-readtable nil))
945
946              (write-fasl-prologue out)
947              ;; copy remaining content
948              (loop for line = (read-line in nil :eof)
949                 while (not (eq line :eof))
950        do (write-line line out)))))
951        (delete-file temp-file)
952        (when (find :windows *features*)
953          (remove-zip-cache-entry output-file))
954        (rename-file temp-file2 output-file)
955
956        (when *compile-file-zip*
957          (populate-zip-fasl output-file))
958
959        (when *compile-verbose*
960          (format t "~&; Wrote ~A (~A seconds)~%"
961                  (namestring output-file)
962                  (/ (- (get-internal-real-time) start) 1000.0)))
963        (values (truename output-file) warnings-p failure-p)))
964
965(defun compile-file (input-file
966                     &key
967                     output-file
968                     ((:verbose *compile-verbose*) *compile-verbose*)
969                     ((:print *compile-print*) *compile-print*)
970                     (extract-toplevel-funcs-and-macros nil)
971                     (external-format :utf-8))
972  (flet ((pathname-with-type (pathname type &optional suffix)
973           (when suffix
974             (setq type (concatenate 'string type suffix)))
975           (make-pathname :type type :defaults pathname)))
976    (unless (or (and (probe-file input-file)
977                     (not (file-directory-p input-file)))
978                (pathname-type input-file))
979      (let ((pathname (pathname-with-type input-file "lisp")))
980        (when (probe-file pathname)
981          (setf input-file pathname))))
982    (setf output-file
983          (make-pathname :defaults
984                         (if output-file
985                             (merge-pathnames output-file
986                                              *default-pathname-defaults*)
987                             (compile-file-pathname input-file))
988                         :version nil))
989    (let* ((*output-file-pathname* output-file)
990           (type (pathname-type output-file))
991           (temp-file (pathname-with-type output-file type "-tmp"))
992           (temp-file2 (pathname-with-type output-file type "-tmp2"))
993           (functions-file (pathname-with-type output-file "funcs"))
994           (macros-file (pathname-with-type output-file "macs"))
995           (exports-file (pathname-with-type output-file "exps"))
996           (setf-functions-file (pathname-with-type output-file "setf-functions"))
997           (setf-expanders-file (pathname-with-type output-file "setf-expanders"))
998           *toplevel-functions*
999           *toplevel-macros*
1000           *toplevel-exports*
1001           *toplevel-setf-functions*
1002           *toplevel-setf-expanders*)
1003      (with-open-file (in input-file :direction :input :external-format external-format)
1004        (multiple-value-bind (output-file-truename warnings-p failure-p)
1005            (compile-from-stream in output-file temp-file temp-file2
1006                                 extract-toplevel-funcs-and-macros
1007                                 functions-file macros-file exports-file 
1008                                 setf-functions-file setf-expanders-file)
1009          (values (truename output-file) warnings-p failure-p))))))
1010
1011(defun compile-file-if-needed (input-file &rest allargs &key force-compile
1012                               &allow-other-keys)
1013  (setf input-file (truename input-file))
1014  (cond (force-compile
1015         (remf allargs :force-compile)
1016         (apply 'compile-file input-file allargs))
1017        (t
1018         (let* ((source-write-time (file-write-date input-file))
1019                (output-file       (or (getf allargs :output-file)
1020                                       (compile-file-pathname input-file)))
1021                (target-write-time (and (probe-file output-file)
1022                                        (file-write-date output-file))))
1023           (if (or (null target-write-time)
1024                   (<= target-write-time source-write-time))
1025               (apply #'compile-file input-file allargs)
1026               output-file)))))
1027
1028(provide 'compile-file)
Note: See TracBrowser for help on using the repository browser.