Another simple one. `create-directory` is pretty small and relies only
on "C_mkdir" (which is already in file.scm) as far as C functions go, so
it's easy to move.
Cheers,
Evan
>From 2f8fdf3f157ef82a892618e65ebd629214b28a8f Mon Sep 17 00:00:00 2001
From: Evan Hanson <ev...@foldling.org>
Date: Tue, 25 Jul 2017 18:58:39 +1200
Subject: [PATCH] Move `create-directory' into (chicken file)
---
file.scm | 18 ++++++++++++++++++
posix-common.scm | 18 ------------------
posix.scm | 2 +-
posixunix.scm | 1 -
posixwin.scm | 1 -
types.db | 2 +-
6 files changed, 20 insertions(+), 22 deletions(-)
diff --git a/file.scm b/file.scm
index 87579d45..f9f42949 100644
--- a/file.scm
+++ b/file.scm
@@ -113,6 +113,24 @@ EOF
;;; Directory management:
+(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 recursive)
+ (##sys#check-string name 'create-directory)
+ (unless (or (fx= 0 (##sys#size name))
+ (file-exists? name))
+ (if recursive
+ (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 delete-directory
(lambda (name #!optional recursive)
(define (rmdir dir)
diff --git a/posix-common.scm b/posix-common.scm
index ca8136a8..da68a48c 100644
--- a/posix-common.scm
+++ b/posix-common.scm
@@ -507,24 +507,6 @@ EOF
#:file-error
'current-directory "cannot retrieve current directory") ) ) ) )
-(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)
diff --git a/posix.scm b/posix.scm
index 44cf77b0..ec89380d 100644
--- a/posix.scm
+++ b/posix.scm
@@ -42,7 +42,7 @@
(module chicken.posix
(block-device? call-with-input-pipe call-with-output-pipe
change-directory change-directory* character-device? close-input-pipe
- close-output-pipe create-directory create-fifo create-pipe
+ close-output-pipe create-fifo create-pipe
create-session create-symbolic-link current-directory
current-effective-group-id current-effective-user-id
current-effective-user-name current-group-id current-process-id
diff --git a/posixunix.scm b/posixunix.scm
index 9203c03a..9376c2bc 100644
--- a/posixunix.scm
+++ b/posixunix.scm
@@ -112,7 +112,6 @@ static C_TLS struct timeval C_timeval;
static C_TLS char C_hostbuf[ 256 ];
static C_TLS struct stat C_statbuf;
-#define C_mkdir(str) C_fix(mkdir(C_c_string(str), S_IRWXU | S_IRWXG | S_IRWXO))
#define C_fchdir(fd) C_fix(fchdir(C_unfix(fd)))
#define C_chdir(str) C_fix(chdir(C_c_string(str)))
diff --git a/posixwin.scm b/posixwin.scm
index 2e0819ac..b20ef2e4 100644
--- a/posixwin.scm
+++ b/posixwin.scm
@@ -115,7 +115,6 @@ static C_TLS TCHAR C_username[255 + 1] = "";
/* Directory Operations */
-#define C_mkdir(str) C_fix(mkdir(C_c_string(str)))
#define C_chdir(str) C_fix(chdir(C_c_string(str)))
/* DIRENT stuff */
diff --git a/types.db b/types.db
index 2b2fb1cc..5412a33d 100644
--- a/types.db
+++ b/types.db
@@ -1586,6 +1586,7 @@
;; file
+(chicken.file#create-directory (#(procedure #:clean #:enforce) chicken.file#create-directory (string #!optional *) string))
(chicken.file#create-temporary-directory (#(procedure #:clean #:enforce) chicken.file#create-temporary-directory () string))
(chicken.file#create-temporary-file (#(procedure #:clean #:enforce) chicken.file#create-temporary-file (#!optional string) string))
(chicken.file#delete-directory (#(procedure #:clean #:enforce) chicken.file#delete-directory (string #!optional *) string))
@@ -1922,7 +1923,6 @@
(chicken.posix#change-directory* (#(procedure #:clean #:enforce) chicken.posix#change-directory* (fixnum) fixnum))
(chicken.posix#close-input-pipe (#(procedure #:clean #:enforce) chicken.posix#close-input-pipe (input-port) fixnum))
(chicken.posix#close-output-pipe (#(procedure #:clean #:enforce) chicken.posix#close-output-pipe (output-port) fixnum))
-(chicken.posix#create-directory (#(procedure #:clean #:enforce) chicken.posix#create-directory (string #!optional *) string))
(chicken.posix#create-fifo (#(procedure #:clean #:enforce) chicken.posix#create-fifo (string #!optional fixnum) undefined))
(chicken.posix#create-pipe (procedure chicken.posix#create-pipe (#!optional fixnum) fixnum fixnum))
(chicken.posix#create-session (#(procedure #:clean) chicken.posix#create-session () fixnum))
--
2.11.0
_______________________________________________
Chicken-hackers mailing list
Chicken-hackers@nongnu.org
https://lists.nongnu.org/mailman/listinfo/chicken-hackers
