Ignore:
Timestamp:
Sep 8, 2008, 5:48:34 AM (11 years ago)
Author:
gb
Message:

Windows-related pathname changes.

File:
1 edited

Legend:

Unmodified
Added
Removed
  • trunk/source/level-1/l1-files.lisp

    r9048 r10631  
    103103;; Reverse of above, take native namestring and make a Lisp pathname.
    104104(defun native-to-pathname (name)
    105   (pathname (%path-std-quotes name nil "*;:")))
     105  (pathname (%path-std-quotes name nil
     106                              #+windows-target "*;"
     107                              #-windows-target "*;:")))
    106108
    107109(defun native-to-directory-pathname (name)
     110  #+windows-target
     111  (let* ((len (length name)))
     112    (when (and (> len 1) (not (or (eql (schar name (1- len)) #\/)
     113                                  (eql (schar name (1- len)) #\\))))
     114      (setq name (%str-cat name "/")))
     115    (string-to-pathname (strip-drive-for-now name)))
     116  #-windows-target
    108117  (make-directory-pathname  :device nil :directory (%path-std-quotes name nil "*;:")))
    109118
     
    119128
    120129                   
     130(defun %shrink-vector (vector to-size)
     131  (cond ((eq (length vector) to-size)
     132         vector)
     133        ((array-has-fill-pointer-p vector)
     134         (setf (fill-pointer vector) to-size)
     135         vector)
     136        (t (subseq vector 0 to-size))))
    121137
    122138(defun namestring-unquote (name)
     139  #+(and windows-target bogus)
     140  (when (and (> (length name) 1)
     141             (eql (schar name 1) #\|))
     142    (setq name (subseq name 0))
     143    (setf (schar name 1) #\:))
    123144  (let ((esc *pathname-escape-character*))
    124145    (if (position esc name)
     
    269290
    270291
    271 ; I thought I wanted to call this from elsewhere but perhaps not
     292;;; I thought I wanted to call this from elsewhere but perhaps not
    272293(defun absolute-directory-list (dirlist)
    273294  ; just make relative absolute and remove ups where possible
     
    314335(defun namestring (path)
    315336  "Construct the full (name)string form of the pathname."
    316   (%str-cat (host-namestring path)
     337  (%str-cat (device-namestring path)
     338            (host-namestring path)
    317339            (directory-namestring path)
    318340            (file-namestring path)))
     341
     342(defun device-namestring (path)
     343  (let* ((device (pathname-device path)))
     344    (if (and device (not (eq device :unspecific)))
     345      (%str-cat device ":")
     346      "")))
    319347
    320348(defun host-namestring (path)
     
    456484      (%str-cat host dir nam))))
    457485
    458 (defun cons-pathname (dir name type &optional host version)
     486(defun cons-pathname (dir name type &optional host version device)
    459487  (if (neq host :unspecific)
    460488    (%cons-logical-pathname dir name type host version)
    461     (%cons-pathname dir name type version)))
     489    (%cons-pathname dir name type version device)))
    462490
    463491(defun pathname (path)
     
    481509  (require-type reference-host '(or null string))
    482510  (multiple-value-bind (sstr start end) (get-sstring string start end)
     511    #-windows-target
    483512    (if (and (> end start)
    484513             (eql (schar sstr start) #\~))
     
    486515            start 0
    487516            end (length sstr)))
    488     (let (directory name type host version (start-pos start) (end-pos end) has-slashes)
     517    (let (directory name type host version device (start-pos start) (end-pos end) has-slashes)
    489518      (multiple-value-setq (host start-pos has-slashes) (pathname-host-sstr sstr start-pos end-pos))
    490519      (cond ((and host (neq host :unspecific))
     
    500529               (error "Illegal logical namestring ~S" (%substr sstr start end)))
    501530             (setq host reference-host)))
     531      #+windows-target
     532      (when (and (eq host :unspecific)
     533                 (eql start-pos 0)
     534                 (eql (position #\: sstr) 1))
     535        (let* ((ch (schar sstr 0)))
     536          (when (and (alpha-char-p ch)
     537                     (standard-char-p ch))
     538            (setq device (make-string 1 :initial-element ch)
     539                  start-pos 2))))
    502540      (multiple-value-setq (directory start-pos) (pathname-directory-sstr sstr start-pos end-pos host))
    503541      (unless (eq host :unspecific)
     
    508546        (setq name (%std-name-component (%substr sstr start-pos end-pos))))
    509547      (if (eq host :unspecific)
    510         (%cons-pathname directory name type version)
     548        (%cons-pathname directory name type :newest device)
    511549        (%cons-logical-pathname directory name type host version)))))
    512550
     
    529567
    530568
     569(defun %std-device-component (device host)
     570  (when (and (or (null host) (eq host :unspecific))
     571             (and device (not (eq device :unspecific))))
     572    #+windows-target
     573    (unless (and (typep device 'string)
     574                 (eql (length device) 1)
     575                 (alpha-char-p (char device 0))
     576                 (standard-char-p (char device 0)))
     577      (error "Invalid pathname device ~s" device))
     578    device))
     579   
    531580(defun make-pathname (&key (host nil host-p)
    532                            device
     581                           (device nil device-p)
    533582                           (directory nil directory-p)
    534583                           (name nil name-p)
     
    539588  "Makes a new pathname from the component arguments. Note that host is
    540589a host-structure or string."
    541   (declare (ignore device))
    542590  (when case (setq case (require-type case pathname-case-type)))
    543591  (if (null host-p)
     
    551599  (if (and defaults (not directory-p))
    552600    (setq directory (pathname-directory defaults)))
     601  (if (and defaults (not device-p))
     602    (setq device (pathname-device defaults)))
     603  (setq device (%std-device-component device host))
    553604  (setq name
    554605        (if name-p
     
    566617  (setq path
    567618        (if (eq host :unspecific)
    568           (%cons-pathname directory name type version)
     619          (%cons-pathname directory name type version device)
    569620          (%cons-logical-pathname
    570621           (or directory
     
    644695         (path-name (pathname-name path))
    645696         (path-type (pathname-type path))
     697         (path-device (pathname-device path))
    646698         (default-dir (and defaults (pathname-directory defaults)))
    647699         (default-host (and defaults (pathname-host defaults)))
     700         (default-device (and defaults (pathname-device defaults)))
    648701         ; take host from defaults iff path-dir is logical or absent - huh?
    649702         (host (cond ((or (null path-host)  ; added 7/96
     
    671724                             (or (and defaults (pathname-version defaults))
    672725                                 default-version))
    673                             (t default-version)))))
     726                            (t default-version))))
     727         (device (or path-device default-device)))
    674728    (if (and (pathnamep path)
    675729             (eq dir (%pathname-directory path))
     
    677731             (eq typ (%pathname-type path))
    678732             (eq host path-host)
     733             (eq device path-device)
    679734             (eq version (pathname-version path)))
    680735      path
    681       (cons-pathname dir nam typ host version))))
     736      (cons-pathname dir nam typ host version device))))
    682737
    683738(defun directory-pathname-p (path)
     
    726781  "Return PATHNAME's device."
    727782  (declare (ignore case))
    728   (cond ((typep (pathname thing) 'logical-pathname) :unspecific)))
     783  (let* ((p (pathname thing)))
     784    (etypecase p
     785      (logical-pathname :unspecific)
     786      (pathname (%physical-pathname-device p)))))
    729787
    730788
     
    751809                     (multiple-value-bind (host pos2) (pathname-host-sstr sstr start end)
    752810                       (unless (eq host :unspecific) (setq logical-p t))
     811                       #+windows-target
     812                       (unless logical-p
     813                         (if (and (> end 1)
     814                                  (eql (schar sstr 1) #\:))
     815                           (setq pos2 2)))
    753816                      (pathname-directory-sstr sstr pos2 end host))))
    754817                  (t (report-bad-arg path pathname-arg-type)))))
Note: See TracChangeset for help on using the changeset viewer.