~ chicken-core (chicken-5) 221f751c4132f8054a9dd6ef57d48275f635d77d

commit 221f751c4132f8054a9dd6ef57d48275f635d77d
Author:     Peter Bex <peter@more-magic.net>
AuthorDate: Sat Jun 20 14:08:26 2015 +0200
Commit:     Evan Hanson <evhan@foldling.org>
CommitDate: Thu Jun 25 12:35:36 2015 +1200

    Fix create-directory parent dir creation on Windows.
    
    When passing #t as the second argument to make create-directory behave
    like "mkdir -p", on Windows there was a small mistake in the logic so it
    would never actually create the topmost parent directory, only those at
    level 2 and below.  This was exposed by the find-files test which uses
    this feature of create-directory.
    
    Instead of having differing implementations, we move the UNIX
    implementation into posix-common; it recursively decomposes pathnames
    using standard procedures that already deal with the difference in path
    separator.  Both use C_mkdir(), which is defined in a platform-specific
    way (but using a common API) at the top of each corresponding platform's
    posix file.
    
    Signed-off-by: Evan Hanson <evhan@foldling.org>

diff --git a/NEWS b/NEWS
index 68ba0c2e..8862b61c 100644
--- a/NEWS
+++ b/NEWS
@@ -38,6 +38,8 @@
     to Seth Alves).
   - file-mkstemp now works correctly on Windows, it now returns valid
     file descriptors (#819, thanks to Michele La Monaca).
+  - create-directory on Windows now creates all intermediate
+    directories when passed #t as second parameter.
 
 - Runtime system:
   - Removed several deprecated, undocumented parts of the C interface:
diff --git a/posix-common.scm b/posix-common.scm
index 9cf38ae0..cd52156a 100644
--- a/posix-common.scm
+++ b/posix-common.scm
@@ -444,6 +444,24 @@ EOF
         (rmdir name))
       (rmdir name))))
 
+(define-inline (*create-directory loc name)
+  (unless (fx= 0 (##core#inline "C_mkdir" (##sys#make-c-string name loc)))
+    (posix-error #:file-error loc "cannot create directory" name)) )
+
+(define create-directory
+  (lambda (name #!optional parents?)
+    (##sys#check-string name 'create-directory)
+    (unless (or (fx= 0 (##sys#size name))
+                (file-exists? name))
+      (if parents?
+        (let loop ((dir (let-values (((dir file ext) (decompose-pathname name)))
+                          (if file (make-pathname dir file ext) dir))))
+          (when (and dir (not (directory? dir)))
+            (loop (pathname-directory dir))
+            (*create-directory 'create-directory dir)) )
+        (*create-directory 'create-directory name) ) )
+    name))
+
 (define directory
   (lambda (#!optional (spec (current-directory)) show-dotfiles?)
     (##sys#check-string spec 'directory)
@@ -472,7 +490,6 @@ EOF
 		      (loop)
 		      (cons file (loop)) ) ) ) ) ) ) ) )
 
-
 ;;; Filename globbing:
 
 (define glob
diff --git a/posixunix.scm b/posixunix.scm
index 662553f1..aa9f0c9e 100644
--- a/posixunix.scm
+++ b/posixunix.scm
@@ -611,24 +611,6 @@ EOF
 
 ;;; Directory stuff:
 
-(define-inline (*create-directory loc name)
-  (unless (fx= 0 (##core#inline "C_mkdir" (##sys#make-c-string name loc)))
-    (posix-error #:file-error loc "cannot create directory" name)) )
-
-(define create-directory
-  (lambda (name #!optional parents?)
-    (##sys#check-string name 'create-directory)
-    (unless (or (fx= 0 (##sys#size name))
-                (file-exists? name))
-      (if parents?
-        (let loop ((dir (let-values (((dir file ext) (decompose-pathname name)))
-                          (if file (make-pathname dir file ext) dir))))
-          (when (and dir (not (directory? dir)))
-            (loop (pathname-directory dir))
-            (*create-directory 'create-directory dir)) )
-        (*create-directory 'create-directory name) ) )
-    name))
-
 (define change-directory
   (lambda (name)
     (##sys#check-string name 'change-directory)
diff --git a/posixwin.scm b/posixwin.scm
index 646553b0..ae689a72 100644
--- a/posixwin.scm
+++ b/posixwin.scm
@@ -810,34 +810,6 @@ EOF
 
 ;;; Directory stuff:
 
-(define-inline (create-directory-helper name)
-  (unless (fx= 0 (##core#inline "C_mkdir" (##sys#make-c-string name 'create-directory)))
-    (##sys#update-errno)
-    (##sys#signal-hook #:file-error 'create-directory
-		       "cannot create directory" name)))
-
-(define-inline (create-directory-helper-silent name)
-  (unless (##sys#file-exists? name #f #t #f)
-    (create-directory-helper name)))
-
-(define-inline (create-directory-helper-parents name)
-  (let* ((l   (string-split name "/\\"))
-	 (c   (car l)))
-    (for-each
-     (lambda (x)
-       (set! c (string-append c "/" x))
-       (create-directory-helper-silent c))
-     (cdr l))))
-
-(define create-directory
-  (lambda (name #!optional parents?)
-    (##sys#check-string name 'create-directory)
-    (let ((name name))
-      (if parents?
-          (create-directory-helper-parents name)
-          (create-directory-helper name))
-      name)))
-
 (define change-directory
   (lambda (name)
     (##sys#check-string name 'change-directory)