Changeset 13498 for trunk/abcl/src/org


Ignore:
Timestamp:
08/14/11 20:53:26 (10 years ago)
Author:
ehuelsmann
Message:

Start breaking up the beast function that COMPILE-FILE used to be.

File:
1 edited

Legend:

Unmodified
Added
Removed
  • trunk/abcl/src/org/armedbear/lisp/compile-file.lisp

    r13497 r13498  
    571571      (eval form))))
    572572
     573(defun populate-zip-fasl (output-file)
     574  (let* ((type ;; Don't use ".zip", it'll result in an extension
     575          ;;  with a dot, which is rejected by NAMESTRING
     576          (%format nil "~A~A" (pathname-type output-file) "-zip"))
     577         (zipfile (namestring
     578                   (merge-pathnames (make-pathname :type type)
     579                                    output-file)))
     580         (pathnames nil)
     581         (fasl-loader (namestring (merge-pathnames
     582                                   (make-pathname :name (fasl-loader-classname)
     583                                                  :type "cls")
     584                                   output-file))))
     585    (when (probe-file fasl-loader)
     586      (push fasl-loader pathnames))
     587    (dotimes (i *class-number*)
     588      (push (probe-file (compute-classfile-name (1+ i))) pathnames))
     589    (setf pathnames (nreverse (remove nil pathnames)))
     590    (let ((load-file (merge-pathnames (make-pathname :type "_")
     591                                      output-file)))
     592      (rename-file output-file load-file)
     593      (push load-file pathnames))
     594    (zip zipfile pathnames)
     595    (dolist (pathname pathnames)
     596      (ignore-errors (delete-file pathname)))
     597    (rename-file zipfile output-file)))
     598
     599(defun write-fasl-prologue (stream)
     600  (let ((out stream))
     601    ;; write header
     602    (write "; -*- Mode: Lisp -*-" :escape nil :stream out)
     603    (%stream-terpri out)
     604    (write (list 'init-fasl :version *fasl-version*) :stream out)
     605    (%stream-terpri out)
     606    (write (list 'setq '*source* *compile-file-truename*) :stream out)
     607    (%stream-terpri out)
     608
     609    ;; Note: Beyond this point, you can't use DUMP-FORM,
     610    ;; because the list of uninterned symbols has been fixed now.
     611    (when *fasl-uninterned-symbols*
     612      (write (list 'setq '*fasl-uninterned-symbols*
     613                   (coerce (mapcar #'car (nreverse *fasl-uninterned-symbols*))
     614                           'vector))
     615             :stream out :length nil))
     616    (%stream-terpri out)
     617
     618    (when (> *class-number* 0)
     619      (write (list 'setq '*fasl-loader*
     620                   `(sys::make-fasl-class-loader
     621                     nil
     622                     ,(concatenate 'string "org.armedbear.lisp." (base-classname))
     623                     nil))
     624             :stream out))
     625    (%stream-terpri out)))
     626
    573627
    574628
     
    612666             (namestring (namestring *compile-file-truename*))
    613667             (start (get-internal-real-time))
    614              elapsed
    615668             *fasl-uninterned-symbols*)
    616669        (when *compile-verbose*
     
    630683              (jvm::with-saved-compiler-policy
    631684                (jvm::with-file-compilation
    632                     (handler-bind ((style-warning
    633                                     #'(lambda (c)
    634                                         (setf warnings-p t)
    635                                         ;; let outer handlers do their thing
    636                                         (signal c)
    637                                         ;; prevent the next handler
    638                                         ;; from running: we're a
    639                                         ;; WARNING subclass
    640                                         (continue)))
    641                                    ((or warning
    642                                        compiler-error)
    643                                     #'(lambda (c)
    644                                         (declare (ignore c))
    645                                         (setf warnings-p t
    646                                               failure-p t))))
     685                    (handler-bind
     686                        ((style-warning
     687                          #'(lambda (c)
     688                              (setf warnings-p t)
     689                              ;; let outer handlers do their thing
     690                              (signal c)
     691                              ;; prevent the next handler
     692                              ;; from running: we're a
     693                              ;; WARNING subclass
     694                              (continue)))
     695                         ((or warning compiler-error)
     696                          #'(lambda (c)
     697                              (declare (ignore c))
     698                              (setf warnings-p t
     699                                    failure-p t))))
    647700                      (loop
    648701                         (let* ((*source-position* (file-position in))
     
    660713                               :if-does-not-exist :create
    661714                               :if-exists :supersede)
    662             ;; write header
    663             (write "; -*- Mode: Lisp -*-" :escape nil :stream out)
    664             (%stream-terpri out)
    665715            (let ((*package* (find-package '#:cl))
    666716                  (*print-fasl* t)
     
    696746              ;;        (*readtable* (copy-readtable nil))
    697747
    698               (write (list 'init-fasl :version *fasl-version*)
    699                      :stream out)
    700               (%stream-terpri out)
    701               (write (list 'setq '*source* *compile-file-truename*)
    702                      :stream out)
    703               (%stream-terpri out)
    704               ;; Note: Beyond this point, you can't use DUMP-FORM,
    705               ;; because the list of uninterned symbols has been fixed now.
    706               (when *fasl-uninterned-symbols*
    707                 (write (list 'setq '*fasl-uninterned-symbols*
    708                              (coerce (mapcar #'car
    709                                              (nreverse *fasl-uninterned-symbols*))
    710                                      'vector))
    711                        :stream out
    712                        :length nil))
    713               (%stream-terpri out)
    714 
    715               (when (> *class-number* 0)
    716                 (write (list 'setq '*fasl-loader*
    717                              `(sys::make-fasl-class-loader
    718                                nil
    719                                ,(concatenate 'string "org.armedbear.lisp." (base-classname))
    720                                nil)) :stream out))
    721               (%stream-terpri out))
    722 
    723 
    724             ;; copy remaining content
    725             (loop for line = (read-line in nil :eof)
    726                while (not (eq line :eof))
    727                do (write-line line out))))
     748              (write-fasl-prologue out)
     749              ;; copy remaining content
     750              (loop for line = (read-line in nil :eof)
     751                 while (not (eq line :eof))
     752                 do (write-line line out)))))
    728753        (delete-file temp-file)
    729754        (remove-zip-cache-entry output-file) ;; Necessary under windows
     
    731756
    732757        (when *compile-file-zip*
    733           (let* ((type ;; Don't use ".zip", it'll result in an extension
    734                   ;;  with a dot, which is rejected by NAMESTRING
    735                   (%format nil "~A~A" (pathname-type output-file) "-zip"))
    736                  (zipfile (namestring
    737                            (merge-pathnames (make-pathname :type type)
    738                                             output-file)))
    739                  (pathnames nil)
    740      (fasl-loader (namestring (merge-pathnames (make-pathname :name (fasl-loader-classname) :type "cls")
    741                  output-file))))
    742       (when (probe-file fasl-loader)
    743         (push fasl-loader pathnames))
    744             (dotimes (i *class-number*)
    745               (let* ((pathname (compute-classfile-name (1+ i))))
    746                 (when (probe-file pathname)
    747                   (push pathname pathnames))))
    748             (setf pathnames (nreverse pathnames))
    749             (let ((load-file (merge-pathnames (make-pathname :type "_")
    750                                               output-file)))
    751               (rename-file output-file load-file)
    752               (push load-file pathnames))
    753             (zip zipfile pathnames)
    754             (dolist (pathname pathnames)
    755               (let ((truename (probe-file pathname)))
    756                 (when truename
    757                   (delete-file truename))))
    758             (rename-file zipfile output-file)))
    759 
    760         (setf elapsed (/ (- (get-internal-real-time) start) 1000.0))
     758          (populate-zip-fasl output-file))
     759
    761760        (when *compile-verbose*
    762761          (format t "~&; Wrote ~A (~A seconds)~%"
    763                   (namestring output-file) elapsed))))
     762                  (namestring output-file)
     763                  (/ (- (get-internal-real-time) start) 1000.0)))))
    764764    (values (truename output-file) warnings-p failure-p)))
    765765
Note: See TracChangeset for help on using the changeset viewer.