X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fwin32-pathname.lisp;h=a3770feab832b04168a32928fab1aeeac0e72c6b;hb=a160917364f85b38dc0826a5e3dcef87e3c4c62c;hp=ac29f7b7587706a451f598d43c102657693cd989;hpb=6584a2c88efaa6931083721adae2f9f10e0fefd5;p=sbcl.git

diff --git a/src/code/win32-pathname.lisp b/src/code/win32-pathname.lisp
index ac29f7b..a3770fe 100644
--- a/src/code/win32-pathname.lisp
+++ b/src/code/win32-pathname.lisp
@@ -97,7 +97,7 @@
                 type
                 version)))))
 
-(defun parse-native-win32-namestring (namestring start end)
+(defun parse-native-win32-namestring (namestring start end as-directory)
   (declare (type simple-string namestring)
            (type index start end))
   (setf namestring (coerce namestring 'simple-string))
@@ -110,22 +110,27 @@
                                collect (if (and (string= piece "..") rest)
                                            :up
                                            piece)))
+             (directory (if (and as-directory
+                                 (string/= "" (car (last components))))
+                            components
+                            (butlast components)))
              (name-and-type
-              (let* ((end (first (last components)))
-                     (dot (position #\. end :from-end t)))
-                ;; FIXME: can we get this dot-interpretation knowledge
-                ;; from existing code?  EXTRACT-NAME-TYPE-AND-VERSION
-                ;; does slightly more work than that.
-                (cond
-                  ((string= end "")
-                   (list nil nil))
-                  ((and dot (> dot 0))
-                   (list (subseq end 0 dot) (subseq end (1+ dot))))
-                  (t
-                   (list end nil))))))
+              (unless as-directory
+                (let* ((end (first (last components)))
+                       (dot (position #\. end :from-end t)))
+                  ;; FIXME: can we get this dot-interpretation knowledge
+                  ;; from existing code?  EXTRACT-NAME-TYPE-AND-VERSION
+                  ;; does slightly more work than that.
+                  (cond
+                    ((string= end "")
+                     (list nil nil))
+                    ((and dot (> dot 0))
+                     (list (subseq end 0 dot) (subseq end (1+ dot))))
+                    (t
+                     (list end nil)))))))
         (values nil
                 device
-                (cons (if absolute :absolute :relative) (butlast components))
+                (cons (if absolute :absolute :relative) directory)
                 (first name-and-type)
                 (second name-and-type)
                 nil)))))
@@ -255,42 +260,55 @@
                (unparse-win32-directory pathname)
                (unparse-win32-file pathname)))
 
-(defun unparse-native-win32-namestring (pathname)
-  (declare (type pathname pathname))
-  (let ((device (pathname-device pathname))
-        (directory (pathname-directory pathname))
-        (name (pathname-name pathname))
-        (type (pathname-type pathname)))
+(defun unparse-native-win32-namestring (pathname as-file)
+  (declare (type pathname pathname)
+           ;; Windows doesn't like directory names with trailing slashes.
+           (ignore as-file))
+  (let* ((device (pathname-device pathname))
+         (directory (pathname-directory pathname))
+         (name (pathname-name pathname))
+         (name-present-p (typep name '(not (member nil :unspecific))))
+         (name-string (if name-present-p name ""))
+         (type (pathname-type pathname))
+         (type-present-p (typep type '(not (member nil :unspecific))))
+         (type-string (if type-present-p type "")))
     (coerce
      (with-output-to-string (s)
        (when device
          (write-string device s)
          (write-char #\: s))
        (tagbody
-          (ecase (pop directory)
-            (:absolute (write-char #\\ s))
-            (:relative))
+          (when directory
+            (ecase (pop directory)
+              (:absolute (write-char #\\ s))
+              (:relative)))
           (unless directory (go :done))
         :subdir
           (let ((piece (pop directory)))
             (typecase piece
               ((member :up) (write-string ".." s))
               (string (write-string piece s))
-              (t (error "ungood piece in NATIVE-NAMESTRING: ~S" piece)))
-            (when (or directory name type)
+              (t (error "ungood directory segment in NATIVE-NAMESTRING: ~S"
+                        piece)))
+            (when (or directory name)
               (write-char #\\ s)))
           (when directory
             (go :subdir))
         :done)
-       (when name
-         (unless (stringp name)
-           (error "non-STRING name in NATIVE-NAMESTRING: ~S" name))
-         (write-string name s)
-         (when type
-           (unless (stringp type)
-             (error "non-STRING type in NATIVE-NAMESTRING: ~S" name))
-           (write-char #\. s)
-           (write-string type s))))
+       (if name-present-p
+           (progn
+             (unless (stringp name-string) ;some kind of wild field
+               (error "ungood name component in NATIVE-NAMESTRING: ~S" name))
+             (write-string name-string s)
+             (when type-present-p
+               (unless (stringp type-string) ;some kind of wild field
+                 (error "ungood type component in NATIVE-NAMESTRING: ~S" type))
+               (write-char #\. s)
+               (write-string type-string s)))
+           (when type-present-p ;
+             (error
+              "type component without a name component in NATIVE-NAMESTRING: ~S"
+              type))))
      'simple-string)))
 
 ;;; FIXME.
@@ -307,7 +325,7 @@
               (cond ((null pathname-directory) '(:relative))
                     ((eq (car pathname-directory) :relative)
                      pathname-directory)
-                    ((and (> prefix-len 1)
+                    ((and (> prefix-len 0)
                           (>= (length pathname-directory) prefix-len)
                           (compare-component (subseq pathname-directory
                                                      0 prefix-len)