<!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>