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

Last change on this file since 13046 was 13046, checked in by ehuelsmann, 11 years ago

Fix ANSI regressions caused by the implementation
of the new class writer.

Found by: Mark Evenson
Patch by: me

  • Property svn:eol-style set to native
  • Property svn:keywords set to Id
File size: 33.3 KB
Line 
1;;; compile-file.lisp
2;;;
3;;; Copyright (C) 2004-2006 Peter Graves
4;;; $Id: compile-file.lisp 13046 2010-11-25 13:15:18Z ehuelsmann $
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;;; As a special exception, the copyright holders of this library give you
21;;; permission to link this library with independent modules to produce an
22;;; executable, regardless of the license terms of these independent
23;;; modules, and to copy and distribute the resulting executable under
24;;; terms of your choice, provided that you also meet, for each linked
25;;; independent module, the terms and conditions of the license of that
26;;; module.  An independent module is a module which is not derived from
27;;; or based on this library.  If you modify this library, you may extend
28;;; this exception to your version of the library, but you are not
29;;; obligated to do so.  If you do not wish to do so, delete this
30;;; exception statement from your version.
31
32(in-package #:system)
33
34(require "JVM")
35;; (require "COMPILER-ERROR") already made accessible through JVM
36
37(defvar *fbound-names*)
38
39(defvar *class-number*)
40
41(defvar *output-file-pathname*)
42
43(defun base-classname (&optional (output-file-pathname *output-file-pathname*))
44  (sanitize-class-name (pathname-name output-file-pathname)))
45
46(defun fasl-loader-classname (&optional (output-file-pathname *output-file-pathname*))
47  (%format nil "~A_0" (base-classname output-file-pathname)))
48
49(declaim (ftype (function (t) t) compute-classfile-name))
50(defun compute-classfile-name (n &optional (output-file-pathname
51                                            *output-file-pathname*))
52  "Computes the name of the class file associated with number `n'."
53  (let ((name
54         (sanitize-class-name
55    (%format nil "~A_~D" (pathname-name output-file-pathname) n))))
56    (namestring (merge-pathnames (make-pathname :name name :type "cls")
57                                 output-file-pathname))))
58
59(defun sanitize-class-name (name)
60  (let ((name (copy-seq name)))
61    (dotimes (i (length name))
62      (declare (type fixnum i))
63      (when (or (char= (char name i) #\-)
64    (char= (char name i) #\.)
65    (char= (char name i) #\Space))
66        (setf (char name i) #\_)))
67    name))
68 
69
70(declaim (ftype (function () t) next-classfile-name))
71(defun next-classfile-name ()
72  (compute-classfile-name (incf *class-number*)))
73
74(defmacro report-error (&rest forms)
75  `(handler-case (progn ,@forms)
76     (compiler-unsupported-feature-error (condition)
77       (fresh-line)
78       (%format t "; UNSUPPORTED-FEATURE: ~A~%" condition)
79       (values nil condition))))
80
81;; Dummy function. Should never be called.
82(defun dummy (&rest ignored)
83  (declare (ignore ignored))
84  (assert nil))
85
86(declaim (ftype (function (t) t) verify-load))
87(defun verify-load (classfile)
88  #|(if (> *safety* 0)
89      (and classfile
90         (let ((*load-truename* *output-file-pathname*))
91           (report-error
92            (load-compiled-function classfile))))
93    t)|#
94  (declare (ignore classfile))
95  t)
96
97(declaim (ftype (function (t) t) process-defconstant))
98(defun process-defconstant (form)
99  ;; "If a DEFCONSTANT form appears as a top level form, the compiler
100  ;; must recognize that [the] name names a constant variable. An
101  ;; implementation may choose to evaluate the value-form at compile
102  ;; time, load time, or both. Therefore, users must ensure that the
103  ;; initial-value can be evaluated at compile time (regardless of
104  ;; whether or not references to name appear in the file) and that
105  ;; it always evaluates to the same value."
106  (eval form)
107  (output-form form))
108
109(declaim (ftype (function (t) t) note-toplevel-form))
110(defun note-toplevel-form (form)
111  (when *compile-print*
112    (fresh-line)
113    (princ "; ")
114    (let ((*print-length* 2)
115          (*print-level* 2)
116          (*print-pretty* nil))
117      (prin1 form))
118    (terpri)))
119
120(declaim (ftype (function (t stream t) t) process-toplevel-form))
121(defun process-toplevel-form (form stream compile-time-too)
122  (if (atom form)
123      (when compile-time-too
124        (eval form))
125    (progn
126      (let ((operator (%car form)))
127        (case operator
128          (MACROLET
129           (process-toplevel-macrolet form stream compile-time-too)
130           (return-from process-toplevel-form))
131          ((IN-PACKAGE DEFPACKAGE)
132           (note-toplevel-form form)
133           (setf form (precompiler:precompile-form form nil *compile-file-environment*))
134           (eval form)
135           ;; Force package prefix to be used when dumping form.
136           (let ((*package* +keyword-package+))
137             (output-form form))
138           (return-from process-toplevel-form))
139          ((DEFVAR DEFPARAMETER)
140           (note-toplevel-form form)
141           (if compile-time-too
142               (eval form)
143               ;; "If a DEFVAR or DEFPARAMETER form appears as a top level form,
144               ;; the compiler must recognize that the name has been proclaimed
145               ;; special. However, it must neither evaluate the initial-value
146               ;; form nor assign the dynamic variable named NAME at compile
147               ;; time."
148               (let ((name (second form)))
149                 (%defvar name))))
150          (DEFCONSTANT
151           (note-toplevel-form form)
152           (process-defconstant form)
153           (return-from process-toplevel-form))
154          (DEFUN
155           (note-toplevel-form form)
156           (let* ((name (second form))
157                  (block-name (fdefinition-block-name name))
158                  (lambda-list (third form))
159                  (body (nthcdr 3 form)))
160             (jvm::with-saved-compiler-policy
161               (multiple-value-bind (body decls doc)
162                   (parse-body body)
163                 (let* ((expr `(lambda ,lambda-list
164                                 ,@decls (block ,block-name ,@body)))
165      (saved-class-number *class-number*)
166                        (classfile (next-classfile-name))
167                        (internal-compiler-errors nil)
168                        (result (with-open-file
169            (f classfile
170               :direction :output
171               :element-type '(unsigned-byte 8)
172               :if-exists :supersede)
173                                  (handler-bind 
174                                      ((internal-compiler-error
175                                        #'(lambda (e)
176                                            (push e internal-compiler-errors)
177                                            (continue))))
178                                    (report-error
179                                     (jvm:compile-defun name expr *compile-file-environment*
180                                                        classfile f nil)))))
181                        (compiled-function (if (not internal-compiler-errors)
182                                               (verify-load classfile)
183                                               nil)))
184       (declare (ignore result))
185                   (cond
186                     ((and (not internal-compiler-errors)
187                           compiled-function)
188                      (setf form
189                            `(fset ',name
190           (sys::get-fasl-function *fasl-loader*
191                 ,saved-class-number)
192                                   ,*source-position*
193                                   ',lambda-list
194                                   ,doc))
195                      (when compile-time-too
196                        (fset name compiled-function)))
197                     (t
198                      ;; Add this warning when the stock ABCL compiles
199                      ;; again, as all warnings in COMPILE-SYSTEM
200                      ;; produce a non-zero exit status that stops
201                      ;; build.xml in its tracks.
202                      #+nil
203                      (compiler-warn "Unable to compile function ~A.  Using interpreted form instead.~%" name)
204                      (format *error-output*
205                              "; Unable to compile function ~A.  Using interpreted form instead.~%" name)
206                      (when internal-compiler-errors
207                        (dolist (e internal-compiler-errors)
208                          (format *error-output*
209                                  "; ~A~%" e)))
210                      (let ((precompiled-function
211                             (precompiler:precompile-form expr nil
212                                              *compile-file-environment*)))
213                        (setf form
214                              `(fset ',name
215                                     ,precompiled-function
216                                     ,*source-position*
217                                     ',lambda-list
218                                     ,doc)))
219                      (when compile-time-too
220                        (eval form)))))
221                 (when (and (symbolp name) (eq (get name '%inline) 'INLINE))
222                 ;; FIXME Need to support SETF functions too!
223                   (setf (inline-expansion name)
224                         (jvm::generate-inline-expansion block-name
225                                                         lambda-list body))
226                   (output-form `(setf (inline-expansion ',name)
227                                       ',(inline-expansion name))))))
228             (push name jvm::*functions-defined-in-current-file*)
229             (note-name-defined name)
230             ;; If NAME is not fbound, provide a dummy definition so that
231             ;; getSymbolFunctionOrDie() will succeed when we try to verify that
232             ;; functions defined later in the same file can be loaded correctly.
233             (unless (fboundp name)
234               (setf (fdefinition name) #'dummy)
235               (push name *fbound-names*))))
236          ((DEFGENERIC DEFMETHOD)
237           (note-toplevel-form form)
238           (note-name-defined (second form))
239           (let ((*compile-print* nil))
240             (process-toplevel-form (macroexpand-1 form *compile-file-environment*)
241                                    stream compile-time-too))
242             (return-from process-toplevel-form))
243          (DEFMACRO
244           (note-toplevel-form form)
245           (let ((name (second form)))
246             (eval form)
247             (let* ((expr (function-lambda-expression (macro-function name)))
248        (saved-class-number *class-number*)
249                    (classfile (next-classfile-name)))
250         (with-open-file
251       (f classfile
252          :direction :output
253          :element-type '(unsigned-byte 8)
254          :if-exists :supersede)
255     (ignore-errors
256       (jvm:compile-defun nil expr *compile-file-environment*
257                                      classfile f nil)))
258               (if (null (verify-load classfile))
259                   ;; FIXME error or warning
260                   (format *error-output* "; Unable to compile macro ~A~%" name)
261                 (progn
262                   (setf form
263                         (if (special-operator-p name)
264                             `(put ',name 'macroexpand-macro
265                                   (make-macro ',name
266                 (sys::get-fasl-function *fasl-loader* ,saved-class-number)))
267                             `(fset ',name
268                                    (make-macro ',name
269            (sys::get-fasl-function *fasl-loader* ,saved-class-number))
270                                    ,*source-position*
271                                    ',(third form)))))))))
272          (DEFTYPE
273           (note-toplevel-form form)
274           (eval form))
275          (EVAL-WHEN
276           (multiple-value-bind (ct lt e)
277               (parse-eval-when-situations (cadr form))
278             (let ((new-compile-time-too (or ct (and compile-time-too e)))
279                   (body (cddr form)))
280               (if lt
281                   (process-toplevel-progn body stream new-compile-time-too)
282                 (when new-compile-time-too
283                   (eval `(progn ,@body)))))
284           (return-from process-toplevel-form)))
285          (LOCALLY
286           ;; FIXME Need to handle special declarations too!
287           (jvm::with-saved-compiler-policy
288             (multiple-value-bind (forms decls)
289                 (parse-body (cdr form) nil)
290               (process-optimization-declarations decls)
291               (let* ((jvm::*visible-variables* jvm::*visible-variables*)
292                      (specials (jvm::process-declarations-for-vars (cdr form)
293                                                                    nil nil)))
294                 (dolist (special specials)
295                   (push special jvm::*visible-variables*))
296                 (process-toplevel-progn forms stream compile-time-too))
297               (return-from process-toplevel-form))))
298          (PROGN
299           (process-toplevel-progn (cdr form) stream compile-time-too)
300           (return-from process-toplevel-form))
301          (DECLARE
302           (compiler-style-warn "Misplaced declaration: ~S" form))
303          (t
304           (when (and (symbolp operator)
305                      (macro-function operator *compile-file-environment*))
306             (note-toplevel-form form)
307             ;; Note that we want MACROEXPAND-1 and not MACROEXPAND here, in
308             ;; case the form being expanded expands into something that needs
309             ;; special handling by PROCESS-TOPLEVEL-FORM (e.g. DEFMACRO).
310             (let ((*compile-print* nil))
311               (process-toplevel-form (macroexpand-1 form *compile-file-environment*)
312                                      stream compile-time-too))
313             (return-from process-toplevel-form))
314
315           (cond ((eq operator 'QUOTE)
316;;;                      (setf form (precompiler:precompile-form form nil
317;;;                                                  *compile-file-environment*))
318                  (when compile-time-too
319                    (eval form))
320                  (return-from process-toplevel-form))
321                 ((eq operator 'PUT)
322                  (setf form (precompiler:precompile-form form nil *compile-file-environment*)))
323                 ((eq operator 'COMPILER-DEFSTRUCT)
324                  (setf form (precompiler:precompile-form form nil *compile-file-environment*)))
325                 ((eq operator 'PROCLAIM)
326                  (setf form (precompiler:precompile-form form nil *compile-file-environment*)))
327                 ((and (memq operator '(EXPORT REQUIRE PROVIDE SHADOW))
328                       (or (keywordp (second form))
329                           (and (listp (second form))
330                                (eq (first (second form)) 'QUOTE))))
331                  (setf form (precompiler:precompile-form form nil *compile-file-environment*)))
332                 ((eq operator 'IMPORT)
333                  (setf form (precompiler:precompile-form form nil *compile-file-environment*))
334                  ;; Make sure package prefix is printed when symbols are imported.
335                  (let ((*package* +keyword-package+))
336                    (output-form form))
337                  (when compile-time-too
338                    (eval form))
339                  (return-from process-toplevel-form))
340                 ((and (eq operator '%SET-FDEFINITION)
341                       (eq (car (second form)) 'QUOTE)
342                       (consp (third form))
343                       (eq (%car (third form)) 'FUNCTION)
344                       (symbolp (cadr (third form))))
345                  (setf form (precompiler:precompile-form form nil *compile-file-environment*)))
346;;;                     ((memq operator '(LET LET*))
347;;;                      (let ((body (cddr form)))
348;;;                        (if (dolist (subform body nil)
349;;;                              (when (and (consp subform) (eq (%car subform) 'DEFUN))
350;;;                                (return t)))
351;;;                            (setf form (convert-toplevel-form form))
352;;;                            (setf form (precompiler:precompile-form form nil)))))
353                 ((eq operator 'mop::ensure-method)
354                  (setf form (convert-ensure-method form)))
355                 ((and (symbolp operator)
356                       (not (special-operator-p operator))
357                       (null (cdr form)))
358                  (setf form (precompiler:precompile-form form nil *compile-file-environment*)))
359                 (t
360;;;                      (setf form (precompiler:precompile-form form nil))
361                  (note-toplevel-form form)
362                  (setf form (convert-toplevel-form form nil)))))))))
363  (when (consp form)
364    (output-form form))
365  ;; Make sure the compiled-function loader knows where
366  ;; to load the compiled functions. Note that this trickery
367  ;; was already used in verify-load before I used it,
368  ;; however, binding *load-truename* isn't fully compliant, I think.
369  (when compile-time-too
370    (let ((*load-truename* *output-file-pathname*)
371    (*fasl-loader* (make-fasl-class-loader
372        *class-number*
373        (concatenate 'string "org.armedbear.lisp." (base-classname))
374        nil)))
375      (eval form))))
376
377(declaim (ftype (function (t) t) convert-ensure-method))
378(defun convert-ensure-method (form)
379  (c-e-m-1 form :function)
380  (c-e-m-1 form :fast-function)
381  (precompiler:precompile-form form nil *compile-file-environment*))
382
383(declaim (ftype (function (t t) t) c-e-m-1))
384(defun c-e-m-1 (form key)
385  (let* ((tail (cddr form))
386         (function-form (getf tail key)))
387    (when (and function-form (consp function-form)
388               (eq (%car function-form) 'FUNCTION))
389      (let ((lambda-expression (cadr function-form)))
390        (jvm::with-saved-compiler-policy
391          (let* ((saved-class-number *class-number*)
392     (classfile (next-classfile-name))
393                 (result
394      (with-open-file
395          (f classfile
396       :direction :output
397       :element-type '(unsigned-byte 8)
398       :if-exists :supersede)
399        (report-error
400         (jvm:compile-defun nil lambda-expression
401                                        *compile-file-environment*
402                                        classfile f nil))))
403                 (compiled-function (verify-load classfile)))
404      (declare (ignore result))
405            (cond (compiled-function
406                   (setf (getf tail key)
407       `(sys::get-fasl-function *fasl-loader* ,saved-class-number)))
408;;                         `(load-compiled-function ,(file-namestring classfile))))
409                  (t
410                   ;; FIXME This should be a warning or error of some sort...
411                   (format *error-output* "; Unable to compile method~%")))))))))
412
413(declaim (ftype (function (t) t) simple-toplevel-form-p))
414(defun simple-toplevel-form-p (form)
415  "Returns NIL if the form is too complex to become an
416interpreted toplevel form, non-NIL if it is 'simple enough'."
417  (and (consp form)
418             (every #'(lambda (arg)
419                        (or (and (atom arg)
420                                 (not (and (symbolp arg)
421                                           (symbol-macro-p arg))))
422                            (and (consp arg)
423                                 (eq 'QUOTE (car arg)))))
424              (cdr form))))
425
426(declaim (ftype (function (t t) t) convert-toplevel-form))
427(defun convert-toplevel-form (form declare-inline)
428  (when (or (simple-toplevel-form-p form)
429            (and (eq (car form) 'SETQ)
430                 ;; for SETQ, look at the evaluated part
431                 (simple-toplevel-form-p (third form))))
432    ;; single form with simple or constant arguments
433    ;; Without this exception, toplevel function calls
434    ;; will be compiled into lambdas which get compiled to
435    ;; compiled-functions. Those need to be loaded.
436    ;; Conclusion: Top level interpreting the function call
437    ;;  and its arguments may be (and should be) more efficient.
438    (return-from convert-toplevel-form
439      (precompiler:precompile-form form nil *compile-file-environment*)))
440  (let* ((expr `(lambda () ,form))
441   (saved-class-number *class-number*)
442         (classfile (next-classfile-name))
443         (result
444    (with-open-file
445        (f classfile
446     :direction :output
447     :element-type '(unsigned-byte 8)
448     :if-exists :supersede)
449      (report-error (jvm:compile-defun nil expr *compile-file-environment*
450                                             classfile f declare-inline))))
451         (compiled-function (verify-load classfile)))
452    (declare (ignore result))
453    (setf form
454          (if compiled-function
455              `(funcall (sys::get-fasl-function *fasl-loader* ,saved-class-number))
456              (precompiler:precompile-form form nil *compile-file-environment*)))))
457
458
459(defun process-toplevel-macrolet (form stream compile-time-too)
460  (let ((*compile-file-environment* (make-environment *compile-file-environment*)))
461    (dolist (definition (cadr form))
462      (environment-add-macro-definition *compile-file-environment*
463                                        (car definition)
464                                        (make-macro (car definition)
465                                                    (make-expander-for-macrolet definition))))
466    (dolist (body-form (cddr form))
467      (process-toplevel-form body-form stream compile-time-too))))
468
469(declaim (ftype (function (t stream t) t) process-toplevel-progn))
470(defun process-toplevel-progn (forms stream compile-time-too)
471  (dolist (form forms)
472    (process-toplevel-form form stream compile-time-too)))
473
474;;; Adapted from SBCL.
475;;; Parse an EVAL-WHEN situations list, returning three flags,
476;;; (VALUES COMPILE-TOPLEVEL LOAD-TOPLEVEL EXECUTE), indicating
477;;; the types of situations present in the list.
478(defun parse-eval-when-situations (situations)
479  (when (or (not (listp situations))
480      (set-difference situations
481          '(:compile-toplevel
482            compile
483            :load-toplevel
484            load
485            :execute
486            eval)))
487    (error "Bad EVAL-WHEN situation list: ~S." situations))
488  (values (intersection '(:compile-toplevel compile) situations)
489    (intersection '(:load-toplevel load) situations)
490    (intersection '(:execute eval) situations)))
491
492
493(defvar *binary-fasls* nil)
494(defvar *forms-for-output* nil)
495(defvar *fasl-stream* nil)
496
497(defun output-form (form)
498  (if *binary-fasls*
499      (push form *forms-for-output*)
500      (progn
501        (dump-form form *fasl-stream*)
502        (%stream-terpri *fasl-stream*))))
503
504(defun finalize-fasl-output ()
505  (when *binary-fasls*
506    (let ((*package* (find-package :keyword))
507          (*double-colon-package-separators* T))
508      (dump-form (convert-toplevel-form (list* 'PROGN
509                                               (nreverse *forms-for-output*))
510                                        t)
511                 *fasl-stream*))
512    (%stream-terpri *fasl-stream*)))
513
514(defun compile-file (input-file
515                     &key
516                     output-file
517                     ((:verbose *compile-verbose*) *compile-verbose*)
518                     ((:print *compile-print*) *compile-print*)
519                     external-format)
520  (declare (ignore external-format))    ; FIXME
521  (unless (or (and (probe-file input-file) (not (file-directory-p input-file)))
522              (pathname-type input-file))
523    (let ((pathname (merge-pathnames (make-pathname :type "lisp") input-file)))
524      (when (probe-file pathname)
525        (setf input-file pathname))))
526  (setf output-file (if output-file
527                        (merge-pathnames output-file *default-pathname-defaults*)
528                        (compile-file-pathname input-file)))
529  (let* ((*output-file-pathname* output-file)
530         (type (pathname-type output-file))
531         (temp-file (merge-pathnames (make-pathname :type (concatenate 'string type "-tmp"))
532                                     output-file))
533         (temp-file2 (merge-pathnames (make-pathname :type (concatenate 'string type "-tmp2"))
534                                     output-file))
535         (warnings-p nil)
536         (failure-p nil))
537    (with-open-file (in input-file :direction :input)
538      (let* ((*compile-file-pathname* (pathname in))
539             (*compile-file-truename* (truename in))
540             (*source* *compile-file-truename*)
541             (*class-number* 0)
542             (namestring (namestring *compile-file-truename*))
543             (start (get-internal-real-time))
544             elapsed
545             *fasl-uninterned-symbols*)
546        (when *compile-verbose*
547          (format t "; Compiling ~A ...~%" namestring))
548        (with-compilation-unit ()
549          (with-open-file (out temp-file
550                               :direction :output :if-exists :supersede
551                               :external-format *fasl-external-format*)
552            (let ((*readtable* *readtable*)
553                  (*read-default-float-format* *read-default-float-format*)
554                  (*read-base* *read-base*)
555                  (*package* *package*)
556                  (jvm::*functions-defined-in-current-file* '())
557                  (*fbound-names* '())
558                  (*fasl-stream* out)
559                  *forms-for-output*)
560              (jvm::with-saved-compiler-policy
561                (jvm::with-file-compilation
562                    (handler-bind ((style-warning 
563                                    #'(lambda (c)
564                                        (setf warnings-p t)
565                                        ;; let outer handlers do their thing
566                                        (signal c)
567                                        ;; prevent the next handler
568                                        ;; from running: we're a
569                                        ;; WARNING subclass
570                                        (continue)))
571                                   ((or warning 
572                                        compiler-error)
573                                    #'(lambda (c)
574                                        (declare (ignore c))
575                                        (setf warnings-p t
576                                              failure-p t))))
577                      (loop
578                         (let* ((*source-position* (file-position in))
579                                (jvm::*source-line-number* (stream-line-number in))
580                                (form (read in nil in))
581                                (*compiler-error-context* form))
582                           (when (eq form in)
583                             (return))
584                           (process-toplevel-form form out nil))))
585                    (finalize-fasl-output)
586                    (dolist (name *fbound-names*)
587                      (fmakunbound name)))))))
588        (with-open-file (in temp-file :direction :input)
589          (with-open-file (out temp-file2 :direction :output
590                               :if-does-not-exist :create
591                               :if-exists :supersede)
592            ;; write header
593            (write "; -*- Mode: Lisp -*-" :escape nil :stream out)
594            (%stream-terpri out)
595            (let ((*package* (find-package '#:cl)))
596              (write (list 'init-fasl :version *fasl-version*)
597                     :stream out)
598              (%stream-terpri out)
599              (write (list 'setq '*source* *compile-file-truename*)
600                     :stream out)
601              (%stream-terpri out)
602              ;; Note: Beyond this point, you can't use DUMP-FORM,
603              ;; because the list of uninterned symbols has been fixed now.
604              (when *fasl-uninterned-symbols*
605                (write (list 'setq '*fasl-uninterned-symbols*
606                             (coerce (mapcar #'car
607                                             (nreverse *fasl-uninterned-symbols*))
608                                     'vector))
609                       :stream out
610                       :length nil))
611              (%stream-terpri out)
612
613              (when (> *class-number* 0)
614                (generate-loader-function)
615                (write (list 'setq '*fasl-loader*
616                             `(sys::make-fasl-class-loader
617                               ,*class-number*
618                               ,(concatenate 'string "org.armedbear.lisp." (base-classname)))) :stream out))
619              (%stream-terpri out))
620
621
622            ;; copy remaining content
623            (loop for line = (read-line in nil :eof)
624               while (not (eq line :eof))
625               do (write-line line out))))
626        (delete-file temp-file)
627  (remove-zip-cache-entry output-file) ;; Necessary under windows
628        (rename-file temp-file2 output-file)
629
630        (when *compile-file-zip*
631          (let* ((type ;; Don't use ".zip", it'll result in an extension
632                  ;;  with a dot, which is rejected by NAMESTRING
633                  (%format nil "~A~A" (pathname-type output-file) "-zip"))
634                 (zipfile (namestring
635                           (merge-pathnames (make-pathname :type type)
636                                            output-file)))
637                 (pathnames nil)
638     (fasl-loader (namestring (merge-pathnames (make-pathname :name (fasl-loader-classname) :type "cls")
639                 output-file))))
640      (when (probe-file fasl-loader)
641        (push fasl-loader pathnames))
642            (dotimes (i *class-number*)
643              (let* ((pathname (compute-classfile-name (1+ i))))
644                (when (probe-file pathname)
645                  (push pathname pathnames))))
646            (setf pathnames (nreverse pathnames))
647            (let ((load-file (merge-pathnames (make-pathname :type "_")
648                                              output-file)))
649              (rename-file output-file load-file)
650              (push load-file pathnames))
651            (zip zipfile pathnames)
652            (dolist (pathname pathnames)
653              (let ((truename (probe-file pathname)))
654                (when truename
655                  (delete-file truename))))
656            (rename-file zipfile output-file)))
657
658        (setf elapsed (/ (- (get-internal-real-time) start) 1000.0))
659        (when *compile-verbose*
660          (format t "~&; Wrote ~A (~A seconds)~%"
661                  (namestring output-file) elapsed))))
662    (values (truename output-file) warnings-p failure-p)))
663
664(defmacro ncase (expr min max &rest clauses)
665  "A CASE where all test clauses are numbers ranging from a minimum to a maximum."
666  ;;Expr is subject to multiple evaluation, but since we only use ncase for
667  ;;fn-index below, let's ignore it.
668  (let* ((half (floor (/ (- max min) 2)))
669   (middle (+ min half)))
670    (if (> (- max min) 10)
671  `(if (< ,expr ,middle)
672       (ncase ,expr ,min ,middle ,@(subseq clauses 0 half))
673       (ncase ,expr ,middle ,max ,@(subseq clauses half)))
674  `(case ,expr ,@clauses))))
675
676(defconstant +fasl-classloader+
677  (jvm::make-jvm-class-name "org.armedbear.lisp.FaslClassLoader"))
678
679(defun generate-loader-function ()
680  (let* ((basename (base-classname))
681   (expr `(lambda (fasl-loader fn-index)
682                  (declare (type (integer 0 256000) fn-index))
683                  (identity fasl-loader) ;;to avoid unused arg
684                  (jvm::with-inline-code ()
685                    (jvm::emit 'jvm::aload 1)
686                    (jvm::emit-invokevirtual jvm::+lisp-object+ "javaInstance"
687                                             nil jvm::+java-object+)
688                    (jvm::emit-checkcast +fasl-classloader+)
689                    (jvm::emit 'jvm::iload 2))
690      (ncase fn-index 0 ,(1- *class-number*)
691        ,@(loop
692       :for i :from 1 :to *class-number*
693       :collect
694       (let* ((class (%format nil "org/armedbear/lisp/~A_~A"
695                                                basename i))
696                                (class-name (jvm::make-jvm-class-name class)))
697                           `(,(1- i)
698                              (jvm::with-inline-code ()
699                                (jvm::emit-new ,class-name)
700                                (jvm::emit 'jvm::dup)
701                                (jvm::emit-invokespecial-init ,class-name '())
702                                (jvm::emit-invokevirtual +fasl-classloader+
703                                                         "putFunction"
704                                                         (list :int jvm::+lisp-object+) jvm::+lisp-object+)
705        (jvm::emit 'jvm::pop))
706            t))))))
707   (classname (fasl-loader-classname))
708   (classfile (namestring (merge-pathnames (make-pathname :name classname :type "cls")
709             *output-file-pathname*))))
710    (jvm::with-saved-compiler-policy
711  (jvm::with-file-compilation
712      (with-open-file
713    (f classfile
714       :direction :output
715       :element-type '(unsigned-byte 8)
716       :if-exists :supersede)
717        (jvm:compile-defun nil expr *compile-file-environment*
718         classfile f nil))))))
719
720(defun compile-file-if-needed (input-file &rest allargs &key force-compile
721                               &allow-other-keys)
722  (setf input-file (truename input-file))
723  (cond (force-compile
724         (remf allargs :force-compile)
725         (apply 'compile-file input-file allargs))
726        (t
727         (let* ((source-write-time (file-write-date input-file))
728                (output-file       (or (getf allargs :output-file)
729                                       (compile-file-pathname input-file)))
730                (target-write-time (and (probe-file output-file)
731                                        (file-write-date output-file))))
732           (if (or (null target-write-time)
733                   (<= target-write-time source-write-time))
734               (apply 'compile-file input-file allargs)
735               output-file)))))
736
737(provide 'compile-file)
Note: See TracBrowser for help on using the repository browser.