Changeset 10634 for trunk/source/level-1

Sep 8, 2008, 5:54:19 AM (12 years ago)

More Windows pathname changes.

1 edited


  • trunk/source/level-1/l1-pathnames.lisp

    r10426 r10634  
    2727  (let* ((p (%null-ptr)))
    2828    (declare (dynamic-extent p))
    29     (%get-cstring (%get-kernel-global-ptr 'image-name p))))
     29    #-windows-target
     30    (%get-cstring (%get-kernel-global-ptr 'image-name p))
     31    #+windows-target
     32    (strip-drive-for-now
     33     (nbackslash-to-forward-slash
     34      (%get-cstring (%get-kernel-global-ptr 'image-name p))))))
    3136(defloadvar *heap-image-name* (heap-image-name))
    315320   unspecified elements into a completed to-pathname based on the to-wildname."
    316321  (when (not (pathnamep source)) (setq source (pathname source)))
    317   (flet ((foo-error (source from)
    318            (error "Source ~S and from-wildname ~S do not match" source from)))
    319     (let (r-host r-device r-directory r-name r-type r-version s-host f-host t-host)
     322  (flet ((translate-pathname-component-mismatch (component-name source from)
     323           (error "~S components of source ~S and from-wildname ~S do not match" component-name source from)))
     324    (let (r-host  r-directory r-name r-type r-version s-host f-host t-host t-device)
    320325      (setq s-host (pathname-host source))
    321326      (setq f-host (pathname-host from-wildname))
    322327      (setq t-host (pathname-host to-wildname))
    323       (if (not (%host-component-match-p s-host f-host)) (foo-error source from-wildname))
     328      (setq t-device (pathname-device to-wildname))
     329      (if (not (%host-component-match-p s-host f-host)) (translate-pathname-component-mismatch 'pathname-host source from-wildname))
    324330      (setq r-host (translate-component s-host f-host t-host reversible))
    325331      (let ((s-dir (%std-directory-component (pathname-directory source) s-host))
    327333            (t-dir (%std-directory-component (pathname-directory to-wildname) t-host)))
    328334        (let ((match (%pathname-match-directory s-dir f-dir)))
    329           (if (not match)(foo-error source from-wildname))
     335          (if (not match)(translate-pathname-component-mismatch 'pathname-directory source from-wildname))
    330336          (setq r-directory  (translate-directory s-dir f-dir t-dir reversible t-host))))
    331337      (let ((s-name (pathname-name source))
    332338            (f-name (pathname-name from-wildname))
    333339            (t-name (pathname-name to-wildname)))
    334         (if (not (%component-match-p s-name f-name))(foo-error source from-wildname))       
     340        (if (not (%component-match-p s-name f-name))(translate-pathname-component-mismatch 'pathname-name source from-wildname))       
    335341        (setq r-name (translate-component s-name f-name t-name reversible)))
    336342      (let ((s-type (pathname-type source))
    337343            (f-type (pathname-type from-wildname))
    338344            (t-type (pathname-type to-wildname)))
    339         (if (not (%component-match-p s-type f-type))(foo-error source from-wildname))
     345        (if (not (%component-match-p s-type f-type))(translate-pathname-component-mismatch 'pathname-component source from-wildname))
    340346        (setq r-type (translate-component s-type f-type t-type reversible)))
    341347      (let ((s-version (pathname-version source))
    342348            (f-version (pathname-version from-wildname))
    343349            (t-version (pathname-version to-wildname)))
    344         (if (not (%component-match-p s-version f-version))(foo-error source from-wildname))
     350        (if (not (%component-match-p s-version f-version)) (translate-pathname-component-mismatch 'pathname-version source from-wildname))
    345351        (setq r-version (translate-component s-version f-version t-version reversible))
    346352        ;(if (eq r-version :unspecific)(setq r-version nil))
    347353        )
    348       (make-pathname :device r-device :host r-host :directory r-directory
     354      (make-pathname :device t-device :host r-host :directory r-directory
    349355                     :name r-name :type r-type :version r-version :defaults nil)
    350356      )))
    663669          ((null host) (%cons-pathname (pathname-directory pathname)
    664670                                       (pathname-name pathname)
    665                                        (pathname-type pathname)))
     671                                       (pathname-type pathname)
     672                                       (pathname-version pathname)
     673                                       (pathname-device pathname)))
    666674          (t
    667675           (let ((rule (assoc pathname (logical-pathname-translations host)
Note: See TracChangeset for help on using the changeset viewer.