Allow file ports in ‘chdir’ when supported.

* configure.ac: Check for ‘fchdir’.
* libguile/filesys.c
(scm_chdir): Support file ports.
(scm_init_filesys): Report support of file ports.
* doc/ref/posix.texi (Processes): Update accordingly.
* doc/ref/guile.texi: Add copyright line for new documentation in this
patch and later patches.
* test-suite/tests/filesys.test ("chdir"): Test it.

Signed-off-by: Ludovic Courtès <ludo@gnu.org>

configure.ac

@@ -516,7 +516,8 @@ AC_CHECK_HEADERS([crt_externs.h])
 #   pipe2 - non-POSIX, found in glibc (GNU/Linux and GNU/Hurd)
 #
 AC_CHECK_FUNCS([DINFINITY DQNAN cexp chsize clog clog10 ctermid         \
-  fesetround ftime ftruncate fchown fchmod getcwd geteuid getsid        \
+  fesetround ftime ftruncate fchown fchmod fchdir			\
+  getcwd geteuid getsid							\
   gettimeofday getuid getgid gmtime_r ioctl lstat mkdir mkdtemp mknod   \
   nice readlink rmdir setegid seteuid                            \
   setuid setgid setpgid setsid sigaction siginterrupt stat64  \

doc/ref/guile.texi

@@ -14,7 +14,8 @@
 This manual documents Guile version @value{VERSION}.
 
 Copyright (C) 1996-1997, 2000-2005, 2009-2021 Free Software Foundation,
-Inc.
+Inc. @*
+Copyright (C) 2021 Maxime Devos
 
 Permission is granted to copy, distribute and/or modify this document
 under the terms of the GNU Free Documentation License, Version 1.3 or

doc/ref/posix.texi

@@ -2,6 +2,7 @@
 @c This is part of the GNU Guile Reference Manual.
 @c Copyright (C)  1996, 1997, 2000, 2001, 2002, 2003, 2004, 2006, 2007,
 @c   2008, 2009, 2010, 2011, 2012, 2013, 2014, 2017, 2021 Free Software Foundation, Inc.
+@c Copyright (C)  2021 Maxime Devos <maximedevos@telenet.be>
 @c See the file guile.texi for copying conditions.
 
 @node POSIX
@@ -1623,7 +1624,9 @@ The return value is unspecified.
 @deffn {Scheme Procedure} chdir str
 @deffnx {C Function} scm_chdir (str)
 @cindex current directory
-Change the current working directory to @var{str}.
+Change the current working directory to @var{str}.  @var{str} can be a
+string containing a file name, or a port if supported by the system.
+@code{(provided? 'chdir-port)} reports whether ports are supported.
 The return value is unspecified.
 @end deffn
 

libguile/filesys.c

@@ -1,5 +1,6 @@
 /* Copyright 1996-2002,2004,2006,2009-2019,2021
      Free Software Foundation, Inc.
+   Copyright 2021 Maxime Devos <maximedevos@telenet.be>
 
    This file is part of Guile.
 
@@ -608,12 +609,28 @@ SCM_DEFINE (scm_link, "link", 2, 0, 0,
 SCM_DEFINE (scm_chdir, "chdir", 1, 0, 0, 
             (SCM str),
 	    "Change the current working directory to @var{str}.\n"
+            "@var{str} can be a string containing a file name,\n"
+            "or a port if supported by the system.\n"
+            "@code{(provided? 'chdir-port)} reports whether ports "
+            "are supported."
 	    "The return value is unspecified.")
 #define FUNC_NAME s_scm_chdir
 {
   int ans;
 
+#ifdef HAVE_FCHDIR
+  if (SCM_OPFPORTP (str))
+    {
+      int fdes;
+      fdes = SCM_FPORT_FDES (str);
+      SCM_SYSCALL (ans = fchdir (fdes));
+      scm_remember_upto_here_1 (str);
+    }
+  else
+#endif
+    {
       STRING_SYSCALL (str, c_str, ans = chdir (c_str));
+    }
   if (ans != 0)
     SCM_SYSERROR;
   return SCM_UNSPECIFIED;
@@ -2053,5 +2070,9 @@ scm_init_filesys ()
 
   scm_dot_string = scm_from_utf8_string (".");
 
+#ifdef HAVE_FCHDIR
+  scm_add_feature("chdir-port");
+#endif
+
 #include "filesys.x"
 }

test-suite/tests/filesys.test

@@ -1,6 +1,7 @@
 ;;;; filesys.test --- test file system functions -*- scheme -*-
 ;;;; 
 ;;;; Copyright (C) 2004, 2006, 2013, 2019, 2021 Free Software Foundation, Inc.
+;;;; Copyright (C) 2021 Maxime Devos <maximedevos@telenet.be>
 ;;;; 
 ;;;; This library is free software; you can redistribute it and/or
 ;;;; modify it under the terms of the GNU Lesser General Public
@@ -265,3 +266,43 @@
                  (result   (eqv? 'directory (stat:type _stat))))
             (false-if-exception (rmdir name))
             result)))))
+
+(with-test-prefix "chdir"
+  (pass-if-equal "current directory" (getcwd)
+    (begin (chdir ".") (getcwd)))
+  (define file (search-path %load-path "ice-9/boot-9.scm"))
+
+
+  (pass-if-equal "test directory" (dirname file)
+    (let ((olddir (getcwd))
+          (dir #f))
+      (chdir (dirname file))
+      (set! dir (getcwd))
+      (chdir olddir)
+      dir))
+
+  (pass-if-equal "test directory, via port" (dirname file)
+    (unless (provided? 'chdir-port)
+      (throw 'unresolved))
+    (let ((olddir (getcwd))
+          (port (open (dirname file) O_RDONLY))
+          (dir #f))
+      (chdir port)
+      (set! dir (getcwd))
+      (chdir olddir)
+      dir))
+
+  (pass-if-exception "closed port"  exception:wrong-type-arg
+    (unless (provided? 'chdir-port)
+      (throw 'unresolved))
+    (let ((port (open (dirname file) O_RDONLY))
+          (olddir (getcwd)))
+      (close-port port)
+      (chdir port)
+      (chdir olddir))) ; should not be reached
+
+  (pass-if-exception "not a port or file name" exception:wrong-type-arg
+    (chdir '(stuff)))
+
+  (pass-if-exception "non-file port" exception:wrong-type-arg
+    (chdir (open-input-string ""))))