0.9.11.31: misc win32 improvements

[sbcl.git] / src / code / win32-pathname.lisp

diff --git a/src/code/win32-pathname.lisp b/src/code/win32-pathname.lisp
index 0b5872a..4a3d10b 100644 (file)
--- a/src/code/win32-pathname.lisp
+++ b/src/code/win32-pathname.lisp
@@ -266,18 +266,25 @@
        (when device
          (write-string device s)
          (write-char #\: s))
-       (ecase (car directory)
-         (:absolute (write-char #\\ s))
-         (:relative))
-       (dolist (piece (cdr directory))
-         (typecase piece
-           ((member :up) (write-string ".." s))
-           (string (write-string piece s))
-           (t (error "ungood piece in NATIVE-NAMESTRING: ~S" piece)))
-         (write-char #\\ s))
+       (tagbody
+          (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 directory
+            (write-char #\\ s)
+            (go :subdir))
+        :done)
        (when name
          (unless (stringp name)
            (error "non-STRING name in NATIVE-NAMESTRING: ~S" name))
+         (write-char #\\ s)
          (write-string name s)
          (when type
            (unless (stringp type)