wild-pathname-p and ensure-directories-exist - gcl.git - GNU Common Lisp

diff --git a/gcl/lsp/gcl_iolib.lsp b/gcl/lsp/gcl_iolib.lsp
index 258e0ec5f..8177beb53 100755
--- a/gcl/lsp/gcl_iolib.lsp
+++ b/gcl/lsp/gcl_iolib.lsp

@@ -374,29 +374,6 @@

(format t "~&Starts dribbling to ~A (~d/~d/~d, ~d:~d:~d)."

namestring year month day hour min sec))))))

-;;; ensure-directories-exist

-

-(defun ensure-directories-exist (pathspec &key verbose)

- (declare (optimize (safety 2)))

- (let* ((path (pathname pathspec))

- (dir (make-pathname :host (pathname-host path)

- :device (pathname-device path)

- :directory (pathname-directory path)))

- (created nil)

- trans walk newdir)

- (when (pathname-directory dir)

- (unless (directory dir)

- (setq trans (pathname-directory (translate-logical-pathname dir)))

- (setq walk (list (car trans)))

- (dolist (step (cdr trans))

- (nconc walk (list step))

- (setq newdir (make-pathname :directory walk))

- (unless (directory newdir)

- (si:mkdir newdir)

- (when verbose (format t "~&Directory ~A created.~%" newdir))))

- (setq created t)))

- (values pathspec created)))

-

;;; new logical pathname translation

;

;;; examples :

@@ -742,3 +719,28 @@

(defun load (f &rest args)

(values (apply 'load1 f args)))

+(defun ensure-directories-exist (ps &key verbose &aux created)

+ (when (wild-pathname-p ps)

+ (error 'file-error :pathname ps :format-control "Pathname is wild"))

+ (labels ((d (x y &aux (z (ldiff x y)) (p (make-pathname :directory z)))

+ (when (when z (stringp (car (last z))))

+ (unless (eq :directory (car (stat p)))

+ (mkdir (namestring p))

+ (setq created t)

+ (when verbose (format *standard-output* "Creating directory ~s~%" p))))

+ (when y (d x (cdr y)))))

+ (let ((pd (pathname-directory ps)))

+ (d pd (cdr pd)))

+ (values ps created)))

+

+#.(let ((g '(:host :device :directory :name :type :version)))

+ `(defun wild-pathname-p (pd &optional f &aux (p (pathname pd)))

+ (declare (optimize (safety 1)))

+ (check-type f (or null (member ,@g)))

+ (labels ((w-f (x)

+ (case x

+ ,@(mapcar (lambda (x &aux (f (intern (concatenate 'string "PATHNAME-" (string-upcase x)))))

+ `(,x ,(if (eq x :directory) `(when (member :wild (,f p)) t) `(eq :wild (,f p))))) g))))

+ (if f

+ (w-f f)

+ (reduce (lambda (z x) (or z (w-f x))) ',g :initial-value nil)))))

diff --git a/gcl/o/boot.c b/gcl/o/boot.c
index 667da59c6..a2779f5b1 100644
--- a/gcl/o/boot.c
+++ b/gcl/o/boot.c

@@ -610,6 +610,10 @@ DEFKTFUN("SUBLIS",fLsublis,LISP,({\

}

sublis(y);}))

+DEFUN("WILD-PATHNAME-P",object,fLwild_pathname_p,LISP,1,2,NONE,OO,OO,OO,OO,(object x,...),"") {

+ return Cnil;

+}

+

#ifndef NO_BOOT_H

#include "boot.h"

#endif

diff --git a/gcl/o/file.d b/gcl/o/file.d
index b111e80ba..d6f1fa291 100755
--- a/gcl/o/file.d
+++ b/gcl/o/file.d

@@ -2465,7 +2465,7 @@ DEFUN("OPEN-INT",object,fSopen_int,SI,8,8,NONE,OO,OO,OO,OO,

if ((type_of(filename) != t_string) ||

(filename->st.st_self[0] != '|')) {

check_type_or_pathname_string_symbol_stream(&filename);

- if (wild_pathname_p(filename,Cnil) == Ct) {

+ if (ifuncall2(sLwild_pathname_p,filename,Cnil) == Ct) {

WILD_PATH(filename);

RETURN1(Cnil);

}

@@ -2605,7 +2605,7 @@ DEFVAR("*DISABLE-RECOMPILE*",sSAdisable_recompile,SI,Ct,"");

defaults = coerce_to_pathname(defaults);

pathname = merge_pathnames(pathname, defaults, sKnewest);

pntype = pathname->pn.pn_type;

- if (wild_pathname_p(pathname,Cnil) == Ct) {

+ if (ifuncall2(sLwild_pathname_p,pathname,Cnil) == Ct) {

WILD_PATH(pathname);

@(return Cnil)

}

diff --git a/gcl/o/pathname.d b/gcl/o/pathname.d
index e7c8ffe13..358f1bc18 100755
--- a/gcl/o/pathname.d
+++ b/gcl/o/pathname.d

@@ -1730,61 +1730,6 @@ object o;

return 0;

}

-object wild_pathname_p(x,totest)

-object x,totest;

-{

- int is_wild = 0;

- vs_mark;

-

- check_type_or_pathname_string_symbol_stream(&x);

- x = coerce_to_pathname(x);

- vs_push(x);

-

- if (totest != Cnil) {

- if (totest == sKdirectory) {

- if (wild_component_p(x->pn.pn_directory)) is_wild++;

- } else

- if (totest == sKname) {

- if (wild_component_p(x->pn.pn_name)) is_wild++;

- } else

- if (totest == sKtype) {

- if (wild_component_p(x->pn.pn_type)) is_wild++;

- } else

- if (totest == sKdevice) {

- if (wild_component_p(x->pn.pn_device)) is_wild++;

- } else

- if (totest == sKhost) {

- if (wild_component_p(x->pn.pn_host)) is_wild++;

- } else

- if (totest == sKversion) {

- if (wild_component_p(x->pn.pn_version)) is_wild++;

- } else

- return(file_error("Invalid key for wild-pathname-p ~S.",totest));

- } else {

- if (wild_component_p(x->pn.pn_directory)) is_wild++;

- else

- if (wild_component_p(x->pn.pn_name)) is_wild++;

- else

- if (wild_component_p(x->pn.pn_type)) is_wild++;

- else

- if (wild_component_p(x->pn.pn_device)) is_wild++;

- else

- if (wild_component_p(x->pn.pn_host)) is_wild++;

- else

- if (wild_component_p(x->pn.pn_version)) is_wild++;

- }

- vs_reset;

- return is_wild ? Ct : Cnil;

-}

-

-@(defun wild_pathname_p (pathname &o

- (totest `Cnil`)

- &aux x)

-@

- x = wild_pathname_p(pathname,totest);

- @(return x)

-@)

-

/*

* pathstring_match_add

* add a match to the list of matches

@@ -2533,7 +2478,6 @@ gcl_init_pathname_function()

make_function("DIRECTORY-NAMESTRING", Ldirectory_namestring);

make_function("HOST-NAMESTRING", Lhost_namestring);

make_function("ENOUGH-NAMESTRING", Lenough_namestring);

- make_function("WILD-PATHNAME-P", Lwild_pathname_p);

make_function("PATHNAME-MATCH-P", Lpathname_match_p);

make_function("TRANSLATE-PATHNAME", Ltranslate_pathname);

make_function("TRANSLATE-LOGICAL-PATHNAME", Ltranslate_logical_pathname);

diff --git a/gcl/o/toplevel.c b/gcl/o/toplevel.c
index 94dcd714b..3546a3378 100755
--- a/gcl/o/toplevel.c
+++ b/gcl/o/toplevel.c

@@ -248,6 +248,7 @@ FFN(Fthe)(object args)

}

}

+DEF_ORDINARY("WILD-PATHNAME-P",sLwild_pathname_p,LISP,"");

DEF_ORDINARY("LDB",sLldb,LISP,"");

DEF_ORDINARY("LDB-TEST",sLldb_test,LISP,"");

DEF_ORDINARY("DPB",sLdpb,LISP,"");

diff --git a/gcl/o/unixfsys.c b/gcl/o/unixfsys.c
index 4a286e264..50b08d156 100755
--- a/gcl/o/unixfsys.c
+++ b/gcl/o/unixfsys.c

@@ -238,7 +238,7 @@ truename(object pathname)

vs_mark;

vs_push(pathname);

- if (wild_pathname_p(pathname,Cnil) == Ct)

+ if (ifuncall2(sLwild_pathname_p,pathname,Cnil) == Ct)

return(WILD_PATH(pathname));

coerce_to_local_filename(pathname, filename);

@@ -450,7 +450,7 @@ LFD(Ltruename)(void)

check_type_or_pathname_string_symbol_stream(&vs_base[0]);

vs_base[0]=coerce_to_pathname(vs_base[0]);

- if (wild_pathname_p(vs_base[0],Cnil) == Ct) {

+ if (ifuncall2(sLwild_pathname_p,vs_base[0],Cnil) == Ct) {

WILD_PATH(vs_base[0]);

vs_base[0] = Cnil;

return;

@@ -479,7 +479,7 @@ LFD(Lrename_file)(void)

check_type_or_pathname_string_symbol_stream(&vs_base[0]);

check_type_or_Pathname_string_symbol(&vs_base[1]);

- if (wild_pathname_p(vs_base[0],Cnil) == Ct) {

+ if (ifuncall2(sLwild_pathname_p,vs_base[0],Cnil) == Ct) {

WILD_PATH(vs_base[0]);

vs_base[0] = Cnil;

return;

@@ -490,7 +490,7 @@ LFD(Lrename_file)(void)

vs_base[1] = coerce_to_pathname(vs_base[1]);

vs_base[1] = merge_pathnames(vs_base[1], vs_base[0], Cnil);

- if (wild_pathname_p(vs_base[1],Cnil) == Ct) {

+ if (ifuncall2(sLwild_pathname_p,vs_base[1],Cnil) == Ct) {

WILD_PATH(vs_base[1]);

vs_base[0] = Cnil;

return;

@@ -573,7 +573,7 @@ DEFUN("DELETE-FILE",object,fLdelete_file,LISP,1,1,NONE,OO,OO,OO,OO,(object path)

check_type_or_pathname_string_symbol_stream(&path);

- if (wild_pathname_p(path,Cnil) == Ct)

+ if (ifuncall2(sLwild_pathname_p,path,Cnil) == Ct)

RETURN1(WILD_PATH(path));

coerce_to_local_filename(path, filename);

@@ -596,7 +596,7 @@ LFD(Lprobe_file)(void)

check_type_or_pathname_string_symbol_stream(&vs_base[0]);

- if (wild_pathname_p(vs_base[0],Cnil) == Ct) {

+ if (ifuncall2(sLwild_pathname_p,vs_base[0],Cnil) == Ct) {

WILD_PATH(vs_base[0]);

vs_base[0] = Cnil;

return;

@@ -616,7 +616,7 @@ LFD(Lfile_write_date)(void)

check_arg(1);

check_type_or_pathname_string_symbol_stream(&vs_base[0]);

- if (wild_pathname_p(vs_base[0],Cnil) == Ct) {

+ if (ifuncall2(sLwild_pathname_p,vs_base[0],Cnil) == Ct) {

WILD_PATH(vs_base[0]);

vs_base[0] = Cnil;

return;

@@ -642,7 +642,7 @@ LFD(Lfile_author)(void)

check_arg(1);

check_type_or_pathname_string_symbol_stream(&vs_base[0]);

- if (wild_pathname_p(vs_base[0],Cnil) == Ct) {

+ if (ifuncall2(sLwild_pathname_p,vs_base[0],Cnil) == Ct) {

WILD_PATH(vs_base[0]);

vs_base[0] = Cnil;

return;

@@ -859,7 +859,7 @@ FFN(siLchdir)(void)

check_arg(1);

check_type_or_pathname_string_symbol_stream(&vs_base[0]);

- if (wild_pathname_p(vs_base[0],Cnil) == Ct) {

+ if (ifuncall2(sLwild_pathname_p,vs_base[0],Cnil) == Ct) {

WILD_PATH(vs_base[0]);

vs_base[0] = Cnil;

return;

@@ -879,7 +879,7 @@ FFN(siLmkdir)(void)

check_arg(1);

check_type_or_pathname_string_symbol_stream(&vs_base[0]);

- if (wild_pathname_p(vs_base[0],Cnil) == Ct) {

+ if (ifuncall2(sLwild_pathname_p,vs_base[0],Cnil) == Ct) {

WILD_PATH(vs_base[0]);

vs_base[0] = Cnil;

return;

@@ -903,7 +903,7 @@ FFN(siLrmdir)(void)

check_arg(1);

check_type_or_pathname_string_symbol_stream(&vs_base[0]);

- if (wild_pathname_p(vs_base[0],Cnil) == Ct) {

+ if (ifuncall2(sLwild_pathname_p,vs_base[0],Cnil) == Ct) {

WILD_PATH(vs_base[0]);

vs_base[0] = Cnil;

return;