Changeset 9817


Ignore:
Timestamp:
Jun 21, 2008, 9:55:07 PM (11 years ago)
Author:
gb
Message:

Some support for pathname devices (e.g., drive letters) for Windows.

File:
1 edited

Legend:

Unmodified
Added
Removed
  • branches/win64/level-1/l1-files.lisp

    r8945 r9817  
    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
     
    128137
    129138(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) #\:))
    130144  (let ((esc *pathname-escape-character*))
    131145    (if (position esc name)
     
    272286
    273287
    274 ; I thought I wanted to call this from elsewhere but perhaps not
     288;;; I thought I wanted to call this from elsewhere but perhaps not
    275289(defun absolute-directory-list (dirlist)
    276   ; just make relative absolute and remove ups where possible
     290  ;; just make relative absolute and remove ups where possible
    277291  (when (eq (car dirlist) :relative)
    278292    (let ((default (mac-default-directory)) default-dir)
     
    317331(defun namestring (path)
    318332  "Construct the full (name)string form of the pathname."
    319   (%str-cat (host-namestring path)
     333  (%str-cat (device-namestring path)
     334            (host-namestring path)
    320335            (directory-namestring path)
    321336            (file-namestring path)))
     337
     338(defun device-namestring (path)
     339  (let* ((device (pathname-device path)))
     340    (if (and device (not (eq device :unspecific)))
     341      (%str-cat device ":")
     342      "")))
    322343
    323344(defun host-namestring (path)
     
    459480      (%str-cat host dir nam))))
    460481
    461 (defun cons-pathname (dir name type &optional host version)
     482(defun cons-pathname (dir name type &optional host version device)
    462483  (if (neq host :unspecific)
    463484    (%cons-logical-pathname dir name type host version)
    464     (%cons-pathname dir name type version)))
     485    (%cons-pathname dir name type version device)))
    465486
    466487(defun pathname (path)
     
    484505  (require-type reference-host '(or null string))
    485506  (multiple-value-bind (sstr start end) (get-sstring string start end)
     507    #-windows-target
    486508    (if (and (> end start)
    487509             (eql (schar sstr start) #\~))
     
    489511            start 0
    490512            end (length sstr)))
    491     (let (directory name type host version (start-pos start) (end-pos end) has-slashes)
     513    (let (directory name type host version device (start-pos start) (end-pos end) has-slashes)
    492514      (multiple-value-setq (host start-pos has-slashes) (pathname-host-sstr sstr start-pos end-pos))
    493515      (cond ((and host (neq host :unspecific))
     
    503525               (error "Illegal logical namestring ~S" (%substr sstr start end)))
    504526             (setq host reference-host)))
     527      #+windows-target
     528      (when (and (eq host :unspecific)
     529                 (eql start-pos 0)
     530                 (eql (position #\: sstr) 1))
     531        (let* ((ch (schar sstr 0)))
     532          (when (and (alpha-char-p ch)
     533                     (standard-char-p ch))
     534            (setq device (make-string 1 :initial-element ch)
     535                  start-pos 2))))
    505536      (multiple-value-setq (directory start-pos) (pathname-directory-sstr sstr start-pos end-pos host))
    506537      (unless (eq host :unspecific)
     
    511542        (setq name (%std-name-component (%substr sstr start-pos end-pos))))
    512543      (if (eq host :unspecific)
    513         (%cons-pathname directory name type version)
     544        (%cons-pathname directory name type version device)
    514545        (%cons-logical-pathname directory name type host version)))))
    515546
     
    532563
    533564
     565(defun %std-device-component (device host)
     566  (when (and (or (null host) (eq host :unspecific))
     567             (and device (not (eq device :unspecific))))
     568    #+windows-target
     569    (unless (and (typep device 'string)
     570                 (eql (length device) 1)
     571                 (alpha-char-p (char device 0))
     572                 (standard-char-p (char device 0)))
     573      (error "Invalid pathname device ~s" device))
     574    device))
     575   
    534576(defun make-pathname (&key (host nil host-p)
    535                            device
     577                           (device nil device-p)
    536578                           (directory nil directory-p)
    537579                           (name nil name-p)
     
    542584  "Makes a new pathname from the component arguments. Note that host is
    543585a host-structure or string."
    544   (declare (ignore device))
    545586  (when case (setq case (require-type case pathname-case-type)))
    546587  (if (null host-p)
     
    554595  (if (and defaults (not directory-p))
    555596    (setq directory (pathname-directory defaults)))
     597  (if (and defaults (not device-p))
     598    (setq device (pathname-device defaults)))
     599  (setq device (%std-device-component device host))
    556600  (setq name
    557601        (if name-p
     
    569613  (setq path
    570614        (if (eq host :unspecific)
    571           (%cons-pathname directory name type version)
     615          (%cons-pathname directory name type version device)
    572616          (%cons-logical-pathname
    573617           (or directory
     
    647691         (path-name (pathname-name path))
    648692         (path-type (pathname-type path))
     693         (path-device (pathname-device path))
    649694         (default-dir (and defaults (pathname-directory defaults)))
    650695         (default-host (and defaults (pathname-host defaults)))
     696         (default-device (and defaults (pathname-device defaults)))
    651697         ; take host from defaults iff path-dir is logical or absent - huh?
    652698         (host (cond ((or (null path-host)  ; added 7/96
     
    674720                             (or (and defaults (pathname-version defaults))
    675721                                 default-version))
    676                             (t default-version)))))
     722                            (t default-version))))
     723         (device (or path-device default-device)))
    677724    (if (and (pathnamep path)
    678725             (eq dir (%pathname-directory path))
     
    680727             (eq typ (%pathname-type path))
    681728             (eq host path-host)
     729             (eq device path-device)
    682730             (eq version (pathname-version path)))
    683731      path
    684       (cons-pathname dir nam typ host version))))
     732      (cons-pathname dir nam typ host version device))))
    685733
    686734(defun directory-pathname-p (path)
     
    729777  "Return PATHNAME's device."
    730778  (declare (ignore case))
    731   (cond ((typep (pathname thing) 'logical-pathname) :unspecific)))
     779  (let* ((p (pathname thing)))
     780    (etypecase p
     781      (logical-pathname :unspecific)
     782      (pathname (%physical-pathname-device p)))))
    732783
    733784
Note: See TracChangeset for help on using the changeset viewer.