X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ffilesys.lisp;h=b14adc882f96c0801fbd25dfabb1da1a7aface51;hb=f0da2f63aa0b4e6d4dbf884854a4bf2dfdd01fc0;hp=d01a738ce5028a70e558a19952136f8ca2188939;hpb=79be3b7a53f2082be86f2cfcd9ed725a01d07ecc;p=sbcl.git

diff --git a/src/code/filesys.lisp b/src/code/filesys.lisp
index d01a738..b14adc8 100644
--- a/src/code/filesys.lisp
+++ b/src/code/filesys.lisp
@@ -1118,6 +1118,12 @@ Experimental: interface subject to change."
                                            (car one) (car two)) x))
                         (intersect-directory-helper (cdr one) (cdr two)))))))))
 
+
+(defun directory-pathname-p (pathname)
+  (and (pathnamep pathname)
+       (null (pathname-name pathname))
+       (null (pathname-type pathname))))
+
 (defun ensure-directories-exist (pathspec &key verbose (mode #o777))
   #!+sb-doc
   "Test whether the directories containing the specified file
@@ -1130,37 +1136,48 @@ Experimental: interface subject to change."
       (error 'simple-file-error
              :format-control "bad place for a wild pathname"
              :pathname pathspec))
-    (let ((dir (pathname-directory pathname)))
+    (let* ((dir (pathname-directory pathname))
+           ;; *d-p-d* can have name and type components which would prevent
+           ;; PROBE-FILE below from working
+           (*default-pathname-defaults*
+             (make-pathname :directory dir :device (pathname-device pathname))))
       (loop for i from 1 upto (length dir)
-            do (let ((newpath (make-pathname
-                               :host (pathname-host pathname)
-                               :device (pathname-device pathname)
-                               :directory (subseq dir 0 i))))
-                 (unless (probe-file newpath)
-                   (let ((namestring (coerce (native-namestring newpath)
-                                             'string)))
-                     (when verbose
-                       (format *standard-output*
-                               "~&creating directory: ~A~%"
-                               namestring))
-                     (sb!unix:unix-mkdir namestring mode)
-                     (unless (probe-file newpath)
-                       (restart-case (error
-                                      'simple-file-error
-                                      :pathname pathspec
-                                      :format-control
-                                      "can't create directory ~A"
-                                      :format-arguments (list namestring))
-                         (retry ()
-                           :report "Retry directory creation."
-                           (ensure-directories-exist
-                            pathspec
-                            :verbose verbose :mode mode))
-                         (continue ()
-                           :report
-                           "Continue as if directory creation was successful."
-                           nil)))
-                     (setf created-p t)))))
+            do
+            (let* ((newpath (make-pathname
+                             :host (pathname-host pathname)
+                             :device (pathname-device pathname)
+                             :directory (subseq dir 0 i)))
+                   (probed (probe-file newpath)))
+              (unless (directory-pathname-p probed)
+                (let ((namestring (coerce (native-namestring newpath)
+                                          'string)))
+                  (when verbose
+                    (format *standard-output*
+                            "~&creating directory: ~A~%"
+                            namestring))
+                  (sb!unix:unix-mkdir namestring mode)
+                  (unless (directory-pathname-p (probe-file newpath))
+                    (restart-case
+                        (error
+                         'simple-file-error
+                         :pathname pathspec
+                         :format-control
+                         (if (and probed
+                                  (not (directory-pathname-p probed)))
+                             "Can't create directory ~A,~
+                                 ~%a file with the same name already exists."
+                             "Can't create directory ~A")
+                         :format-arguments (list namestring))
+                      (retry ()
+                        :report "Retry directory creation."
+                        (ensure-directories-exist
+                         pathspec
+                         :verbose verbose :mode mode))
+                      (continue ()
+                        :report
+                        "Continue as if directory creation was successful."
+                        nil)))
+                  (setf created-p t)))))
       (values pathspec created-p))))
 
 (/show0 "filesys.lisp 1000")