<!DOCTYPE html PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN">
<html>
<head>
  
</head>
<body text="#000000" bgcolor="#ffffff">
By the way, in case anyone cares, SBCL sometimes<br>
calls ensure-directories-exist implicitly, where CCL<br>
does not.  The language spec has nothing to say<br>
about it and I would have done it as CCL does.<br>
If you're porting from SBCL to CCL, you might<br>
have to add calls to ensure-directories-exist.<br>
<br>
<br>
Gary Byers wrote:
<blockquote type="cite" cite="mid:20090503040146.S97662@abq.clozure.com">
  <pre wrap="">Yes, both of those functions were neglecting to handle
PATHNAME-DEVICE.  D'oh!

Thanks.

On Sun, 3 May 2009, Martin wrote:

  </pre>
  <blockquote type="cite">
    <pre wrap="">Hi!

First, I want to appreciate the work you have put into the Windows port
of Clozure CL. Thanks.

At the end of this mail is a patch which attempts to make CCL's
DIRECTORY and ENSURE-DIRECTORIES-EXIST functions nicer on Windows.

(I am using 1.3-r11949 on Windows XP SP2.)

Most of the changes typically involve the addition of the :DEVICE
component for to make the functions `drive aware'---if you will.

For 1 and 2, the `context' is:

? (PATHNAME-DEVICE (CURRENT-DIRECTORY)) => C



1.

? (ENSURE-DIRECTORIES-EXIST "D:/dir1/dir2/") => creates "C:/dir1/dir2/"
instead.



2.

? (DIRECTORY "D:/dir1/dir2/*.*") => NIL (despite having files in
D:/dir1/dir2/).



3. I have a file tree with the following structure:

D:.
|   init.bat
|
+---.dir2
|   |   .file3
|   |   file1.txt
|   |   file2
|   |
|   +---.dir1-2
|   |       .file5
|   |       file3.txt
|   |       file4
|   |
|   \---dir1-1
|           .file3
|           file1.txt
|           file2
|
\---dir1
    |   .file3
    |   file1.txt
    |   file2
    |
    +---.dir1-2
    |       .file5
    |       file3.txt
    |       file4
    |
    \---dir1-1
            .file3
            file1.txt
            file2


? (DIRECTORY #P"D:/sources/lang/lisp/ccl/tests/**/.dir2/" :directories t))
=>
'(#P"/sources/lang/lisp/ccl/tests/.dir2/"
#P"/sources/lang/lisp/ccl/tests/.dir2/.dir2/"
#P"/sources/lang/lisp/ccl/tests/.dir2/.dir1-2/.dir2/"
#P"/sources/lang/lisp/ccl/tests/.dir2/dir1-1/.dir2/"
#P"/sources/lang/lisp/ccl/tests/dir1/.dir2/"
#P"/sources/lang/lisp/ccl/tests/dir1/.dir1-2/.dir2/"
#P"/sources/lang/lisp/ccl/tests/dir1/dir1-1/.dir2/")

If I understand the Spec well, I expected:
#P"D:/sources/lang/lisp/ccl/tests/.dir2/"

Regards,
Martin.


Patch: (In the expected format, I hope.)

;;; --------------------------------------------------
;;;  BOF



--- pathnames.orig.lisp
+++ pathnames.new.lisp
@@ -231,4 +231,6 @@
   argument."
-  (let* ((pathname (make-directory-pathname :directory
(pathname-directory (translate-logical-pathname (merge-pathnames
pathspec)))))
-        (created-p nil))
+  (let ((pathname (let ((pathspec (translate-logical-pathname
(merge-pathnames pathspec))))
+                   (make-directory-pathname :device (pathname-device pathspec)
+                                            :directory (pathname-directory pathspec))))
+       (created-p nil))
     (when (wild-pathname-p pathname)
@@ -301,4 +303,9 @@

-(defmacro with-open-dir ((dirent dir) &body body)
-  `(let ((,dirent (%open-dir ,dir)))
+(defun %path-cat (device dir subdir)
+  (if device
+      (%str-cat device ":" dir subdir)
+    (%str-cat dir subdir)))
+
+(defmacro with-open-dir ((dirent device dir) &body body)
+  `(let ((,dirent (%open-dir (namestring (make-pathname :device ,device
:directory ,dir)))))
      (when ,dirent
@@ -361,4 +368,7 @@
 (defun %one-wild (dir wild rest path so-far keys)
-  (let ((result ()) (all (getf keys :all)) name subdir)
-    (with-open-dir (dirent dir)
+  (let ((result ())
+       (device (pathname-device path))
+       (all (getf keys :all))
+       name)
+    (with-open-dir (dirent device dir)
       (while (setq name (%read-dir dirent))
@@ -368,4 +378,5 @@
                   (%path-pstr*= wild name)
-                  (eq (%unix-file-kind (setq subdir (%str-cat dir name)) t) :directory))
-         (let ((so-far (cons (%path-std-quotes name nil "/;:*") so-far)))
+                  (eq (%unix-file-kind (%path-cat device dir name) t) :directory))
+         (let ((subdir (%path-cat nil dir name))
+               (so-far (cons (%path-std-quotes name nil "/;:*") so-far)))
            (declare (dynamic-extent so-far))
@@ -376,3 +387,4 @@
 (defun %files-in-directory (dir path so-far keys)
-  (let ((name (pathname-name path))
+  (let ((device (pathname-device path))
+       (name (pathname-name path))
         (type (pathname-type path))
@@ -388,9 +400,12 @@
     (if (not (or name type))
-      (when directories
-       (setq ans (if directory-pathnames
-                   (%cons-pathname (reverse so-far) nil nil)
-                   (%cons-pathname (reverse (cdr so-far)) (car so-far) nil)))
-       (when (and ans (or (null test) (funcall test ans)))
-         (setq result (list ans))))
-      (with-open-dir (dirent dir)
+      (let (full-path)
+       (when (and directories
+                  (eq (%unix-file-kind (namestring (setq full-path (%cons-pathname
(reverse so-far) nil nil nil device)))
+                                       t)
+                      :directory))
+         (setq ans (if directory-pathnames full-path
+                     (%cons-pathname (reverse (cdr so-far)) (car so-far) nil nil
device)))
+         (when (and ans (or (null test) (funcall test ans)))
+           (setq result (list ans)))))
+      (with-open-dir (dirent (pathname-device path) dir)
        (while (setq sub (%read-dir dirent))
@@ -404,3 +419,3 @@
            (setq ans
-                 (if (eq (%unix-file-kind (%str-cat dir sub) t) :directory)
+                 (if (eq (%unix-file-kind (%path-cat device dir sub) t) :directory)
                    (when directories
@@ -408,7 +423,7 @@
                        (if directory-pathnames
-                         (%cons-pathname (reverse (cons std-sub so-far)) nil nil)
-                         (%cons-pathname (or dir-list (setq dir-list (reverse so-far)))
std-sub nil))))
+                         (%cons-pathname (reverse (cons std-sub so-far)) nil nil nil device)
+                         (%cons-pathname (or dir-list (setq dir-list (reverse so-far)))
std-sub nil nil device))))
                    (when files
                      (multiple-value-bind (name type) (%std-name-and-type sub)
-                       (%cons-pathname (or dir-list (setq dir-list (reverse so-far))) name
type)))))
+                       (%cons-pathname (or dir-list (setq dir-list (reverse so-far))) name
type nil device)))))
            (when (and ans (or (null test) (funcall test ans)))
@@ -421,2 +436,3 @@
         (result nil)
+       (device (pathname-device path))
         (name (pathname-name path))
@@ -427,3 +443,3 @@
        (follow-links (getf keys :follow-links))
-       sub subfile dir-list ans)
+       sub dir-list ans)
     ;; First process the case that the ** stands for 0 components
@@ -446,4 +462,4 @@
                 (setq sub (if directory-pathnames
-                            (%cons-pathname (setq dir-list (reverse so-far)) nil nil)
-                            (%cons-pathname (reverse (cdr so-far)) (car so-far) nil)))
+                            (%cons-pathname (setq dir-list (reverse so-far)) nil nil nil
device)
+                            (%cons-pathname (reverse (cdr so-far)) (car so-far) nil nil
device)))
                 (when (or (null test) (funcall test sub))
@@ -451,3 +467,3 @@
     ; now descend doing %all-dirs on dirs and collecting files & dirs
if do-x is t
-    (with-open-dir (dirent dir)
+    (with-open-dir (dirent device dir)
       (while (setq sub (%read-dir dirent))
@@ -456,4 +472,5 @@
                   (not (string= sub "..")))
-         (if (eq (%unix-file-kind (setq subfile (%str-cat dir sub)) t)
:directory)
-           (let* ((std-sub (%path-std-quotes sub nil "/;:*"))
+         (if (eq (%unix-file-kind (%path-cat device dir sub) t) :directory)
+           (let* ((subfile (%path-cat nil dir sub))
+                  (std-sub (%path-std-quotes sub nil "/;:*"))
                   (so-far (cons std-sub so-far))
@@ -463,5 +480,5 @@
                (setq ans (if directory-pathnames
-                           (%cons-pathname (reverse so-far) nil nil)
+                           (%cons-pathname (reverse so-far) nil nil nil device)
                            (%cons-pathname (or dir-list (setq dir-list (reverse (cdr
so-far))))
-                                           std-sub nil)))
+                                           std-sub nil nil device)))
                (when (or (null test) (funcall test ans))
@@ -471,3 +488,3 @@
              (multiple-value-bind (name type) (%std-name-and-type sub)
-               (setq ans (%cons-pathname (or dir-list (setq dir-list (reverse
so-far))) name type))
+               (setq ans (%cons-pathname (or dir-list (setq dir-list (reverse
so-far))) name type nil device))
                (when (or (null test) (funcall test ans))



;;; EOF
;;; --------------------------------------------------



_______________________________________________
Openmcl-devel mailing list
<a href="mailto:Openmcl-devel@clozure.com" class="moz-txt-link-abbreviated">Openmcl-devel@clozure.com</a>
<a href="http://clozure.com/mailman/listinfo/openmcl-devel" class="moz-txt-link-freetext">http://clozure.com/mailman/listinfo/openmcl-devel</a>


    </pre>
  </blockquote>
  <pre wrap=""><!---->_______________________________________________
Openmcl-devel mailing list
<a href="mailto:Openmcl-devel@clozure.com" class="moz-txt-link-abbreviated">Openmcl-devel@clozure.com</a>
<a href="http://clozure.com/mailman/listinfo/openmcl-devel" class="moz-txt-link-freetext">http://clozure.com/mailman/listinfo/openmcl-devel</a>
  </pre>
</blockquote>
</body>
</html>