~ chicken-core (chicken-5) 9235b64dab35843478e76a349875110648e2243d

commit 9235b64dab35843478e76a349875110648e2243d
Author:     felix <felix@call-with-current-continuation.org>
AuthorDate: Wed Aug 31 11:45:18 2011 +0200
Commit:     felix <felix@call-with-current-continuation.org>
CommitDate: Wed Aug 31 11:45:18 2011 +0200

    added change-directory* (contributed by Alan Post)

diff --git a/manual/Unit posix b/manual/Unit posix
index cdbfddbb..0f6d0a2d 100644
--- a/manual/Unit posix	
+++ b/manual/Unit posix	
@@ -84,6 +84,14 @@ Permission bits used with, for example, {{file-open}}.
 
 Changes the current working directory to {{NAME}}.
 
+==== change-directory*
+
+<procedure>(change-directory* FD)</procedure>
+
+Changes the current working directory to the one represented by the
+file-descriptor {{FD}}, which should be an exact integer.
+
+
 ==== current-directory
 
 <procedure>(current-directory [DIR])</procedure>
@@ -1249,6 +1257,7 @@ not be obtained. On Windows, this procedure always returns {{0}},
 === How Scheme procedures relate to UNIX C functions
 
 ; {{change-directory}} : {{chdir}}
+; {{change-directory*}} : {{fchdir}}
 ; {{change-file-mode}} : {{chmod}}
 ; {{change-file-owner}} : {{chown}}
 ; {{create-directory}} : {{mkdir}}
@@ -1368,6 +1377,7 @@ Microsoft tools or with MinGW):
  set-signal-mask!  signal-mask  signal-masked?  signal-mask!  signal-unmask!
  user-information  group-information  get-groups  set-groups!  initialize-groups
  errno/wouldblock
+ change-directory*
  change-file-owner
  current-user-id  current-group-id  current-effective-user-id  current-effective-groupd-id
  set-user-id!  set-group-id!
diff --git a/posixunix.scm b/posixunix.scm
index 3e578d92..e76122c9 100644
--- a/posixunix.scm
+++ b/posixunix.scm
@@ -142,6 +142,7 @@ 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)))
 #define C_rmdir(str)        C_fix(rmdir(C_c_string(str)))
 
@@ -768,6 +769,12 @@ EOF
 	(posix-error #:file-error 'change-directory "cannot change current directory" name) )
       name)))
 
+(define (change-directory* fd)
+  (##sys#check-exact fd 'change-directory*) 
+  (unless (fx= 0 (##core#inline "C_fchdir" fd)) 
+    (posix-error #:file-error 'change-directory* "cannot change current directory" fd) ) 
+  fd)) 
+
 
 ;;; Pipes:
 
diff --git a/posixwin.scm b/posixwin.scm
index 45ca60af..1cd6b340 100644
--- a/posixwin.scm
+++ b/posixwin.scm
@@ -34,6 +34,7 @@
 ; set-signal-mask!  signal-mask	 signal-masked?	 signal-mask!  signal-unmask!
 ; user-information group-information  get-groups  set-groups!  initialize-groups
 ; errno/wouldblock
+; change-directory*
 ; change-file-owner
 ; current-user-id  current-group-id  current-effective-user-id	current-effective-group-id
 ; current-effective-user-name
@@ -1731,6 +1732,7 @@ EOF
      (define (?name . _)
        (error '?name (##core#immutable '"this function is not available on this platform")) ) ] ) )
 
+(define-unimplemented change-directory*)
 (define-unimplemented change-file-owner)
 (define-unimplemented create-fifo)
 (define-unimplemented create-session)
diff --git a/types.db b/types.db
index 91b46ea2..769b8d5b 100644
--- a/types.db
+++ b/types.db
@@ -1465,6 +1465,7 @@
 (call-with-input-pipe (#(procedure #:enforce) call-with-input-pipe (string (procedure (port) . *) #!optional symbol) . *))
 (call-with-output-pipe (#(procedure #:enforce) call-with-output-pipe (string (procedure (port) . *) #!optional symbol) . *))
 (change-directory (#(procedure #:clean #:enforce) change-directory (string) string))
+(change-directory* (#(procedure #:clean #:enforce) change-directory* (fixnum) fixnum))
 (change-file-mode (#(procedure #:clean #:enforce) change-file-mode (string fixnum) undefined))
 (change-file-owner (#(procedure #:clean #:enforce) change-file-owner (string fixnum fixnum) undefined))
 (close-input-pipe (#(procedure #:clean #:enforce) close-input-pipe (port) fixnum))