Changeset 14094


Ignore:
Timestamp:
08/15/12 21:38:12 (8 years ago)
Author:
ehuelsmann
Message:

Factor out the actual compilation when the input stream has been opened
in order to allow compilation directly from stream (to be implemented).

File:
1 edited

Legend:

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

    r14067 r14094  
    697697(defvar *fasl-stream* nil)
    698698
    699 (defun compile-file (input-file
    700                      &key
    701                      output-file
    702                      ((:verbose *compile-verbose*) *compile-verbose*)
    703                      ((:print *compile-print*) *compile-print*)
    704                      (extract-toplevel-funcs-and-macros nil)
    705                      external-format)
    706   (declare (ignore external-format))    ; FIXME
    707   (unless (or (and (probe-file input-file) (not (file-directory-p input-file)))
    708               (pathname-type input-file))
    709     (let ((pathname (merge-pathnames (make-pathname :type "lisp") input-file)))
    710       (when (probe-file pathname)
    711         (setf input-file pathname))))
    712   (setf output-file (make-pathname
    713          :defaults (if output-file
    714            (merge-pathnames output-file
    715                 *default-pathname-defaults*)
    716            (compile-file-pathname input-file))
    717          :version nil))
    718   (let* ((*output-file-pathname* output-file)
    719          (type (pathname-type output-file))
    720          (temp-file (merge-pathnames (make-pathname :type (concatenate 'string type "-tmp"))
    721                                      output-file))
    722          (temp-file2 (merge-pathnames (make-pathname :type (concatenate 'string type "-tmp2"))
    723                                      output-file))
    724          (functions-file (merge-pathnames (make-pathname :type "funcs") output-file))
    725          (macros-file (merge-pathnames (make-pathname :type "macs") output-file))
    726          *toplevel-functions*
    727          *toplevel-macros*
    728          (warnings-p nil)
    729          (failure-p nil))
    730     (with-open-file (in input-file :direction :input)
    731       (let* ((*compile-file-pathname* (make-pathname :defaults (pathname in)
    732                  :version nil))
    733              (*compile-file-truename* (make-pathname :defaults (truename in)
    734                                                      :version nil))
    735              (*source* *compile-file-truename*)
    736              (*class-number* 0)
    737              (namestring (namestring *compile-file-truename*))
    738              (start (get-internal-real-time))
    739              *fasl-uninterned-symbols*)
    740         (when *compile-verbose*
    741           (format t "; Compiling ~A ...~%" namestring))
    742         (with-compilation-unit ()
    743           (with-open-file (out temp-file
    744                                :direction :output :if-exists :supersede
    745                                :external-format *fasl-external-format*)
    746             (let ((*readtable* *readtable*)
    747                   (*read-default-float-format* *read-default-float-format*)
    748                   (*read-base* *read-base*)
    749                   (*package* *package*)
    750                   (jvm::*functions-defined-in-current-file* '())
    751                   (*fbound-names* '())
    752                   (*fasl-stream* out)
    753                   *forms-for-output*)
    754               (jvm::with-saved-compiler-policy
    755                 (jvm::with-file-compilation
    756                     (handler-bind
    757                         ((style-warning
    758                           #'(lambda (c)
    759                               (setf warnings-p t)
    760                               ;; let outer handlers do their thing
    761                               (signal c)
    762                               ;; prevent the next handler
    763                               ;; from running: we're a
    764                               ;; WARNING subclass
    765                               (continue)))
    766                          ((or warning compiler-error)
    767                           #'(lambda (c)
    768                               (declare (ignore c))
    769                               (setf warnings-p t
    770                                     failure-p t))))
    771                       (loop
    772                          (let* ((*source-position* (file-position in))
    773                                 (jvm::*source-line-number* (stream-line-number in))
    774                                 (form (read in nil in))
    775                                 (*compiler-error-context* form))
    776                            (when (eq form in)
    777                              (return))
    778                            (process-toplevel-form form out nil))))
     699(defun compile-from-stream (in output-file temp-file temp-file2
     700                            extract-toplevel-funcs-and-macros
     701                            functions-file macros-file)
     702  (let* ((*compile-file-pathname* (make-pathname :defaults (pathname in)
     703                                                 :version nil))
     704         (*compile-file-truename* (make-pathname :defaults (truename in)
     705                                                 :version nil))
     706         (*source* *compile-file-truename*)
     707         (*class-number* 0)
     708         (namestring (namestring *compile-file-truename*))
     709         (start (get-internal-real-time))
     710         *fasl-uninterned-symbols*)
     711    (when *compile-verbose*
     712      (format t "; Compiling ~A ...~%" namestring))
     713    (with-compilation-unit ()
     714      (with-open-file (out temp-file
     715                           :direction :output :if-exists :supersede
     716                           :external-format *fasl-external-format*)
     717        (let ((*readtable* *readtable*)
     718              (*read-default-float-format* *read-default-float-format*)
     719              (*read-base* *read-base*)
     720              (*package* *package*)
     721              (jvm::*functions-defined-in-current-file* '())
     722              (*fbound-names* '())
     723              (*fasl-stream* out)
     724              *forms-for-output*)
     725          (jvm::with-saved-compiler-policy
     726            (jvm::with-file-compilation
     727              (handler-bind
     728                  ((style-warning
     729                    #'(lambda (c)
     730                        (setf warnings-p t)
     731                        ;; let outer handlers do their thing
     732                        (signal c)
     733                        ;; prevent the next handler
     734                        ;; from running: we're a
     735                        ;; WARNING subclass
     736                        (continue)))
     737                   ((or warning compiler-error)
     738                    #'(lambda (c)
     739                        (declare (ignore c))
     740                        (setf warnings-p t
     741                              failure-p t))))
     742                (loop
     743                   (let* ((*source-position* (file-position in))
     744                          (jvm::*source-line-number* (stream-line-number in))
     745                          (form (read in nil in))
     746                          (*compiler-error-context* form))
     747                     (when (eq form in)
     748                       (return))
     749                     (process-toplevel-form form out nil))))
    779750                    (finalize-fasl-output)
    780751                    (dolist (name *fbound-names*)
     
    860831          (format t "~&; Wrote ~A (~A seconds)~%"
    861832                  (namestring output-file)
    862                   (/ (- (get-internal-real-time) start) 1000.0)))))
    863     (values (truename output-file) warnings-p failure-p)))
     833                  (/ (- (get-internal-real-time) start) 1000.0)))) )
     834
     835(defun compile-file (input-file
     836                     &key
     837                     output-file
     838                     ((:verbose *compile-verbose*) *compile-verbose*)
     839                     ((:print *compile-print*) *compile-print*)
     840                     (extract-toplevel-funcs-and-macros nil)
     841                     external-format)
     842  (declare (ignore external-format))    ; FIXME
     843  (flet ((pathname-with-type (pathname type &optional suffix)
     844           (when suffix
     845             (setq type (concatenate 'string type suffix)))
     846           (merge-pathnames (make-pathname :type type)
     847                            pathname)))
     848    (unless (or (and (probe-file input-file)
     849                     (not (file-directory-p input-file)))
     850                (pathname-type input-file))
     851      (let ((pathname (pathname-with-type input-file "lisp")))
     852        (when (probe-file pathname)
     853          (setf input-file pathname))))
     854    (setf output-file
     855          (make-pathname :defaults
     856                         (if output-file
     857                             (merge-pathnames output-file
     858                                              *default-pathname-defaults*)
     859                             (compile-file-pathname input-file))
     860                         :version nil))
     861    (let* ((*output-file-pathname* output-file)
     862           (type (pathname-type output-file))
     863           (temp-file (pathname-with-type output-file type "-tmp"))
     864           (temp-file2 (pathname-with-type output-file type "-tmp2"))
     865           (functions-file (pathname-with-type output-file "funcs"))
     866           (macros-file (pathname-with-type output-file "macs"))
     867           *toplevel-functions*
     868           *toplevel-macros*
     869           (warnings-p nil)
     870           (failure-p nil))
     871      (with-open-file (in input-file :direction :input)
     872        (compile-from-stream in output-file temp-file temp-file2
     873                             extract-toplevel-funcs-and-macros
     874                             functions-file macros-file))
     875      (values (truename output-file) warnings-p failure-p))))
    864876
    865877(defun compile-file-if-needed (input-file &rest allargs &key force-compile
Note: See TracChangeset for help on using the changeset viewer.