[Openmcl-devel] ENSURE-DIRECTORIES-EXIST and DIRECTORY on Windows

Tue May 5 08:20:52 PDT 2009

By the way, in case anyone cares, SBCL sometimes
calls ensure-directories-exist implicitly, where CCL
does not.  The language spec has nothing to say
about it and I would have done it as CCL does.
If you're porting from SBCL to CCL, you might
have to add calls to ensure-directories-exist.

Gary Byers wrote:
> Yes, both of those functions were neglecting to handle
> PATHNAME-DEVICE.  D'oh!
>
> Thanks.
>
> On Sun, 3 May 2009, Martin wrote:
>
>   
>> 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
>> Openmcl-devel at clozure.com
>> http://clozure.com/mailman/listinfo/openmcl-devel
>>
>>
>>     
> _______________________________________________
> Openmcl-devel mailing list
> Openmcl-devel at clozure.com
> http://clozure.com/mailman/listinfo/openmcl-devel
>   
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <https://lists.clozure.com/pipermail/openmcl-devel/attachments/20090505/c7c51fbd/attachment.htm>