Ignore:
Timestamp:
10/11/12 11:33:19 (8 years ago)
Author:
Mark Evenson
Message:

Refactor PATHNAME implementation details to tighten existing semantics.

None of this should change the behavior of CL:PATHNAME, but it
prepares for that in subsequent patches to address problems in merging
when the defaults points to a JAR-PATHNAME.

Fix COMPILE-FILE to work with source located in jar archive.

Moved Utilities.getFile() to instance method of Pathname which makes
more logical sense. Moved Utilities.getPathnameDirectory() to static
instance classes. These functions no longer merge their argument with
*DEFAULT-PATHNAME-DEFAULTS*, as this should be done explictly at a
higher level in the Lisp calling into Java abstraction.

RENAME-FILE no longer on namestrings, but instead use the result of
TRUENAME invocation, as namestrings will not always roundtrip
exactly back to PATHNAMES.

POPULATE-ZIP-FASL no longer forms its argumentes by merging paths,
instead using MAKE-PATHNAME with controlled defaults.

SYSTEM:NEXT-CLASSFILE-NAME and SYSTEM:COMPUTE-CLASSFILE-NAME changed
to NEXT-CLASSFILE and COMPUTE-CLASSFILE returning PATHNAME objects
rather than namestrings.

Compiler now dumps pathname in alternate form that preserves DEVICE
:UNSPECIFIC.

File:
1 edited

Legend:

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

    r14163 r14176  
     1
    12;;; compile-file.lisp
    23;;;
     
    5455  (%format nil "~A_0" (base-classname output-file-pathname)))
    5556
    56 (declaim (ftype (function (t) t) compute-classfile-name))
    57 (defun compute-classfile-name (n &optional (output-file-pathname
     57(declaim (ftype (function (t) t) compute-classfile))
     58(defun compute-classfile (n &optional (output-file-pathname
    5859                                            *output-file-pathname*))
    59   "Computes the name of the class file associated with number `n'."
     60  "Computes the pathname of the class file associated with number `n'."
    6061  (let ((name
    6162         (sanitize-class-name
    6263    (%format nil "~A_~D" (pathname-name output-file-pathname) n))))
    63     (namestring (merge-pathnames (make-pathname :name name :type *compile-file-class-extension*)
    64                                  output-file-pathname))))
     64    (merge-pathnames (make-pathname :name name :type *compile-file-class-extension*)
     65                                 output-file-pathname)))
    6566
    6667(defun sanitize-class-name (name)
     
    7576 
    7677
    77 (declaim (ftype (function () t) next-classfile-name))
    78 (defun next-classfile-name ()
    79   (compute-classfile-name (incf *class-number*)))
     78(declaim (ftype (function () t) next-classfile))
     79(defun next-classfile ()
     80  (compute-classfile (incf *class-number*)))
    8081
    8182(defmacro report-error (&rest forms)
     
    186187         (expr `(lambda () ,form))
    187188         (saved-class-number *class-number*)
    188          (classfile (next-classfile-name))
     189         (classfile (next-classfile))
    189190         (result
    190191          (with-open-file
     
    308309                 (jvm::with-saved-compiler-policy
    309310                     (let* ((saved-class-number *class-number*)
    310                             (classfile (next-classfile-name))
     311                            (classfile (next-classfile))
    311312                            (result
    312313                             (with-open-file
     
    451452    (let* ((expr (function-lambda-expression (macro-function name)))
    452453           (saved-class-number *class-number*)
    453            (classfile (next-classfile-name)))
     454           (classfile (next-classfile)))
    454455      (with-open-file
    455456          (f classfile
     
    491492                          ,@decls (block ,block-name ,@body)))
    492493                 (saved-class-number *class-number*)
    493                  (classfile (next-classfile-name))
     494                 (classfile (next-classfile))
    494495                 (internal-compiler-errors nil)
    495496                 (result (with-open-file
     
    637638
    638639(defun populate-zip-fasl (output-file)
    639   (let* ((type ;; Don't use ".zip", it'll result in an extension
    640           ;;  with a dot, which is rejected by NAMESTRING
     640  (let* ((type ;; Don't use ".zip", it'll result in an extension with
     641               ;; a dot, which is rejected by NAMESTRING
    641642          (%format nil "~A~A" (pathname-type output-file) "-zip"))
    642          (zipfile (namestring
    643                    (merge-pathnames (make-pathname :type type)
    644                                     output-file)))
     643         (output-file (if (logical-pathname-p output-file)
     644                          (translate-logical-pathname output-file)
     645                          output-file))
     646         (zipfile
     647          (if (find :windows *features*)
     648              (make-pathname :defaults output-file :type type)
     649              (make-pathname :defaults output-file :type type
     650                             :device :unspecific)))
    645651         (pathnames nil)
    646          (fasl-loader (namestring (merge-pathnames
    647                                    (make-pathname :name (fasl-loader-classname)
    648                                                   :type *compile-file-class-extension*)
    649                                    output-file))))
     652         (fasl-loader (make-pathname :defaults output-file
     653                                     :name (fasl-loader-classname)
     654                                     :type *compile-file-class-extension*)))
    650655    (when (probe-file fasl-loader)
    651656      (push fasl-loader pathnames))
    652657    (dotimes (i *class-number*)
    653       (let ((truename (probe-file (compute-classfile-name (1+ i)))))
     658      (let ((truename (probe-file (compute-classfile (1+ i)))))
    654659        (when truename
    655660          (push truename pathnames)
     
    669674              (push resource pathnames))))))
    670675    (setf pathnames (nreverse (remove nil pathnames)))
    671     (let ((load-file (merge-pathnames (make-pathname :type "_")
    672                                       output-file)))
     676    (let ((load-file (make-pathname :defaults output-file
     677                                    :type "_")))
    673678      (rename-file output-file load-file)
    674679      (push load-file pathnames))
     
    711716(defvar *fasl-stream* nil)
    712717
     718(defvar *debug-compile-from-stream* nil)
    713719(defun compile-from-stream (in output-file temp-file temp-file2
    714720                            extract-toplevel-funcs-and-macros
     
    723729         (start (get-internal-real-time))
    724730         *fasl-uninterned-symbols*)
     731    (setf *debug-compile-from-stream*
     732          (list :in in
     733                :compile-file-pathname *compile-file-pathname*))
    725734    (when *compile-verbose*
    726735      (format t "; Compiling ~A ...~%" namestring))
     
    849858                 do (write-line line out)))))
    850859        (delete-file temp-file)
    851         (remove-zip-cache-entry output-file) ;; Necessary under windows
     860        (when (find :windows *features*)
     861          (remove-zip-cache-entry output-file))
    852862        (rename-file temp-file2 output-file)
    853863
     
    871881           (when suffix
    872882             (setq type (concatenate 'string type suffix)))
    873            (merge-pathnames (make-pathname :type type)
    874                             pathname)))
     883           (make-pathname :type type :defaults pathname)))
    875884    (unless (or (and (probe-file input-file)
    876885                     (not (file-directory-p input-file)))
Note: See TracChangeset for help on using the changeset viewer.