X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fwin32-pathname.lisp;h=4a3d10bb4cf52e07f6154bda84730323881c1120;hb=3eb0a28fe6a7912d6ff2b97221325c0e3bfc5703;hp=0b5872a34188476eeb4556323b178f4c35a754e7;hpb=84e9f00b07d3d5ce4a5a5d30bcdf94c0bd7f2f0f;p=sbcl.git

diff --git a/src/code/win32-pathname.lisp b/src/code/win32-pathname.lisp
index 0b5872a..4a3d10b 100644
--- 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)