X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fwin32-pathname.lisp;h=72bb09d2ad27e32d43257d77d1c4efa4cf5f1ba7;hb=a129450e9b56cee8e307fc5c320105fe00ba45b7;hp=169f384f4e268c8af33c147e94a51bce2d556747;hpb=9de65d498a9da0c70a60ea2bf9b5af39aaffe55d;p=sbcl.git

diff --git a/src/code/win32-pathname.lisp b/src/code/win32-pathname.lisp
index 169f384..72bb09d 100644
--- a/src/code/win32-pathname.lisp
+++ b/src/code/win32-pathname.lisp
@@ -291,17 +291,26 @@
          (ecase (pop directory)
            (:absolute
             (let ((next (pop directory)))
+              ;; Don't use USER-HOMEDIR-NAMESTRING, since
+              ;; it can be specified as C:/User/user
+              ;; and (native-namestring (user-homedir-pathname))
+              ;; will be not equal to it, because it's parsed first.
               (cond ((eq :home next)
-                     (write-string (user-homedir-namestring) s))
+                     (write-string (native-namestring (user-homedir-pathname))
+                                   s))
                     ((and (consp next) (eq :home (car next)))
-                     (let ((where (user-homedir-namestring (second next))))
+                     (let ((where (user-homedir-pathname (second next))))
                        (if where
-                           (write-string where s)
+                           (write-string (native-namestring where) s)
                            (error "User homedir unknown for: ~S"
                                   (second next)))))
+                    ;; namestring of user-homedir-pathname already has
+                    ;; // at the end
                     (next
-                     (push next directory)))
-              (write-char #\\ s)))
+                     (write-char #\\ s)
+                     (push next directory))
+                    (t
+                     (write-char #\\ s)))))
            (:relative)))
        (loop for (piece . subdirs) on directory
              do (typecase piece
@@ -324,7 +333,7 @@
                  (error "ungood type component in NATIVE-NAMESTRING: ~S" type))
                (write-char #\. s)
                (write-string type-string s)))
-           (when type-present-p ;
+           (when type-present-p
              (error
               "type component without a name component in NATIVE-NAMESTRING: ~S"
               type)))