Support open-process and friends on MS-Windows

Support open-process and friends on MS-Windows

[Eli Zaretskii]

This is a re-spin of the patches last posted here:

  https://lists.gnu.org/archive/html/guile-devel/2014-08/msg00015.html

At Andy's suggestion, I've removed most of the Windows-specific code
to the new Windows-specific file w32-proc.c, leaving just the minimum
changes in posix.c itself.  The patch below is against the stable-2.0
branch in the Guile Git repository.

I hope we will be able to get this into the repository this time.

TIA

commit 44f8eebf9850431790b23b031f5b6e90fb3de777
Author: Eli Zaretskii <eliz@gnu.org>
Date:   Fri Jun 24 12:45:02 2016 +0300

    Provide support for open-process and related functions on MS-Windows
    
    * libguile/w32-proc.c: New file, with MinGW support code for
    scm_open_process, scm_getpriority, scm_setpriority,
    scm_getaffinity, and scm_setaffinity.  Also, provides macros that
    on Posix hosts are in sys/wait.h, like WIFEXITED and WTERMSIG, and
    simple definitions for getuid, getgid, setuid, setgid, and
    waitpid.
    
    * libguile/posix.c [__MINGW32__]: Include w32-proc.c.
    (scm_kill) [__MINGW32__]: Support killing subprocesses on MS-Windows.
    (scm_status_exit_val, scm_getuid, scm_getegid): Don't exclude from
    compilation with MinGW.
    (scm_execl, scm_execle): Cast arguments of execv/execve to avoid
    compiler warnings.
    (scm_open_process): Condition parts specific to 'fork'-based
    implementation with "#ifdef HAVE_FORK".
    [__MINGW32__]: MinGW alternative to 'fork'-based implementation;
    most of the supporting code is in w32-proc.c.
    (scm_getpriority, scm_setpriority, scm_getaffinity)
    (scm_setaffinity, scm_init_popen): Don't exclude from MinGW
    compilation.
    (scm_init_posix): Register scm_init_popen extension even if
    HAVE_FORK is not defined.

diff --git a/libguile/posix.c b/libguile/posix.c
index 2654716..35b920f 100644
--- a/libguile/posix.c
+++ b/libguile/posix.c
@@ -84,6 +84,10 @@
 #if HAVE_SYS_WAIT_H
 # include <sys/wait.h>
 #endif
+#ifdef __MINGW32__
+# include "w32-proc.c"
+#endif	/* __MINGW32__ */
+
 #ifndef WEXITSTATUS
 # define WEXITSTATUS(stat_val) ((unsigned)(stat_val) >> 8)
 #endif
@@ -659,7 +663,7 @@ SCM_DEFINE (scm_kill, "kill", 2, 0, 0,
 #else
   /* Mingw has raise(), but not kill().  (Other raw DOS environments might
      be similar.)  Use raise() when the requested pid is our own process,
-     otherwise bomb.  */
+     otherwise TerminateProcess.  */
   if (scm_to_int (pid) == getpid ())
     {
       if (raise (scm_to_int (sig)) != 0)
@@ -673,6 +677,25 @@ SCM_DEFINE (scm_kill, "kill", 2, 0, 0,
           goto err;
         }
     }
+#ifdef __MINGW32__
+  else
+    {
+      HANDLE ph = OpenProcess (PROCESS_TERMINATE, 0, scm_to_int (pid));
+      int s = scm_to_int (sig);
+
+      if (!ph)
+	{
+	  errno = EPERM;
+	  goto err;
+	}
+      if (!TerminateProcess (ph, w32_signal_to_status (s)))
+	{
+	  errno = EINVAL;
+	  goto err;
+	}
+      CloseHandle (ph);
+    }
+#endif	/* __MINGW32__ */
 #endif
   return SCM_UNSPECIFIED;
 }
@@ -735,7 +758,6 @@ SCM_DEFINE (scm_waitpid, "waitpid", 1, 1, 0,
 #undef FUNC_NAME
 #endif /* HAVE_WAITPID */
 
-#ifndef __MINGW32__
 SCM_DEFINE (scm_status_exit_val, "status:exit-val", 1, 0, 0, 
             (SCM status),
 	    "Return the exit status value, as would be set if a process\n"
@@ -786,7 +808,6 @@ SCM_DEFINE (scm_status_stop_sig, "status:stop-sig", 1, 0, 0,
     return SCM_BOOL_F;
 }
 #undef FUNC_NAME
-#endif /* __MINGW32__ */
 
 #ifdef HAVE_GETPPID
 SCM_DEFINE (scm_getppid, "getppid", 0, 0, 0,
@@ -801,7 +822,6 @@ SCM_DEFINE (scm_getppid, "getppid", 0, 0, 0,
 #endif /* HAVE_GETPPID */
 
 
-#ifndef __MINGW32__
 SCM_DEFINE (scm_getuid, "getuid", 0, 0, 0,
             (),
 	    "Return an integer representing the current real user ID.")
@@ -905,10 +925,8 @@ SCM_DEFINE (scm_seteuid, "seteuid", 1, 0, 0,
   return SCM_UNSPECIFIED;
 }
 #undef FUNC_NAME
-#endif /* __MINGW32__ */
 
 
-#ifdef HAVE_SETEGID
 SCM_DEFINE (scm_setegid, "setegid", 1, 0, 0,
             (SCM id),
 	    "Sets the effective group ID to the integer @var{id}, provided the process\n"
@@ -931,7 +949,6 @@ SCM_DEFINE (scm_setegid, "setegid", 1, 0, 0,
     
 }
 #undef FUNC_NAME
-#endif
 
 
 #ifdef HAVE_GETPGRP
@@ -1141,7 +1158,7 @@ SCM_DEFINE (scm_execl, "execl", 1, 0, 1,
 
   exec_argv = scm_i_allocate_string_pointers (args);
 
-  execv (exec_file, exec_argv);
+  execv (exec_file, (char const * const *)exec_argv);
   SCM_SYSERROR;
 
   /* not reached.  */
@@ -1170,7 +1187,7 @@ SCM_DEFINE (scm_execlp, "execlp", 1, 0, 1,
 
   exec_argv = scm_i_allocate_string_pointers (args);
 
-  execvp (exec_file, exec_argv);
+  execvp (exec_file, (char const * const *)exec_argv);
   SCM_SYSERROR;
 
   /* not reached.  */
@@ -1204,7 +1221,8 @@ SCM_DEFINE (scm_execle, "execle", 2, 0, 1,
   exec_argv = scm_i_allocate_string_pointers (args);
   exec_env = scm_i_allocate_string_pointers (env);
 
-  execve (exec_file, exec_argv, exec_env);
+  execve (exec_file, (char const * const *)exec_argv,
+	  (char const * const *)exec_env);
   SCM_SYSERROR;
 
   /* not reached.  */
@@ -1246,6 +1264,7 @@ SCM_DEFINE (scm_fork, "primitive-fork", 0, 0, 0,
   return scm_from_int (pid);
 }
 #undef FUNC_NAME
+#endif /* HAVE_FORK */
 
 /* Since Guile uses threads, we have to be very careful to avoid calling
    functions that are not async-signal-safe in the child.  That's why
@@ -1262,7 +1281,9 @@ scm_open_process (SCM mode, SCM prog, SCM args)
   int pid;
   char *exec_file;
   char **exec_argv;
+#ifdef HAVE_FORK
   int max_fd = 1024;
+#endif
 
   exec_file = scm_to_locale_string (prog);
   exec_argv = scm_i_allocate_string_pointers (scm_cons (prog, args));
@@ -1319,12 +1340,28 @@ scm_open_process (SCM mode, SCM prog, SCM args)
   }
 #endif
 
+#ifdef HAVE_FORK
   pid = fork ();
+#elif defined(__MINGW32__)
+  if (!reading)
+    c2p[1] = out;
+  if (!writing)
+    p2c[0] = in;
+  pid = start_child (exec_file, exec_argv, reading, c2p, writing, p2c, err);
+#else
+  close (c2p[0]);
+  close (c2p[1]);
+  close (p2c[0]);
+  close (p2c[1]);
+  free (exec_file);
+  errno = ENOSYS;
+  SCM_SYSERROR;
+#endif	/* HAVE_FORK */
 
   if (pid == -1)
     {
       int errno_save = errno;
-      free (exec_file);
+
       if (reading)
         {
           close (c2p[0]);
@@ -1336,6 +1373,8 @@ scm_open_process (SCM mode, SCM prog, SCM args)
           close (p2c[1]);
         }
       errno = errno_save;
+
+      free (exec_file);
       SCM_SYSERROR;
     }
 
@@ -1360,6 +1399,7 @@ scm_open_process (SCM mode, SCM prog, SCM args)
         (scm_list_3 (read_port, write_port, scm_from_int (pid)));
     }
 
+#ifdef HAVE_FORK
   /* The child.  */
   if (reading)
     close (c2p[0]);
@@ -1408,16 +1448,16 @@ scm_open_process (SCM mode, SCM prog, SCM args)
   if (err > 0)
     {
       char *msg = strerror (errno);
-      fprintf (fdopen (err, "a"), "In execlp of %s: %s\n",
+      fprintf (fdopen (err, "a"), "In execvp of %s: %s\n",
                exec_file, msg);
     }
 
   _exit (EXIT_FAILURE);
+#endif	/* HAVE_FORK */
   /* Not reached.  */
   return SCM_BOOL_F;
 }
 #undef FUNC_NAME
-#endif /* HAVE_FORK */
 
 #ifdef __MINGW32__
 # include "win32-uname.h"
@@ -1909,7 +1949,7 @@ SCM_DEFINE (scm_getlogin, "getlogin", 0, 0, 0,
 }
 #undef FUNC_NAME
 
-#if HAVE_GETPRIORITY
+#if HAVE_GETPRIORITY || defined __MINGW32__
 SCM_DEFINE (scm_getpriority, "getpriority", 2, 0, 0, 
             (SCM which, SCM who),
 	    "Return the scheduling priority of the process, process group\n"
@@ -1938,9 +1978,9 @@ SCM_DEFINE (scm_getpriority, "getpriority", 2, 0, 0,
   return scm_from_int (ret);
 }
 #undef FUNC_NAME
-#endif /* HAVE_GETPRIORITY */
+#endif /* HAVE_GETPRIORITY || __MINGW32__ */
 
-#if HAVE_SETPRIORITY
+#if HAVE_SETPRIORITY || defined __MINGW32__
 SCM_DEFINE (scm_setpriority, "setpriority", 3, 0, 0, 
             (SCM which, SCM who, SCM prio),
 	    "Set the scheduling priority of the process, process group\n"
@@ -1969,9 +2009,9 @@ SCM_DEFINE (scm_setpriority, "setpriority", 3, 0, 0,
   return SCM_UNSPECIFIED;
 }
 #undef FUNC_NAME
-#endif /* HAVE_SETPRIORITY */
+#endif /* HAVE_SETPRIORITY || __MINGW32__ */
 
-#ifdef HAVE_SCHED_GETAFFINITY
+#if defined HAVE_SCHED_GETAFFINITY || defined __MINGW32__
 
 static SCM
 cpu_set_to_bitvector (const cpu_set_t *cs)
@@ -2000,7 +2040,7 @@ SCM_DEFINE (scm_getaffinity, "getaffinity", 1, 0, 0,
 	    "Guile can use without stepping on other processes' toes.\n\n"
 	    "Currently this procedure is only defined on GNU variants\n"
 	    "(@pxref{CPU Affinity, @code{sched_getaffinity},, libc, The\n"
-	    "GNU C Library Reference Manual}).\n")
+	    "GNU C Library Reference Manual}) and on MS-Windows.\n")
 #define FUNC_NAME s_scm_getaffinity
 {
   int err;
@@ -2015,9 +2055,9 @@ SCM_DEFINE (scm_getaffinity, "getaffinity", 1, 0, 0,
 }
 #undef FUNC_NAME
 
-#endif /* HAVE_SCHED_GETAFFINITY */
+#endif /* HAVE_SCHED_GETAFFINITY || __MINGW32__ */
 
-#ifdef HAVE_SCHED_SETAFFINITY
+#if defined HAVE_SCHED_SETAFFINITY || defined __MINGW32__
 
 SCM_DEFINE (scm_setaffinity, "setaffinity", 2, 0, 0,
 	    (SCM pid, SCM mask),
@@ -2026,7 +2066,7 @@ SCM_DEFINE (scm_setaffinity, "setaffinity", 2, 0, 0,
 	    "is unspecified.\n\n"
 	    "Currently this procedure is only defined on GNU variants\n"
 	    "(@pxref{CPU Affinity, @code{sched_setaffinity},, libc, The\n"
-	    "GNU C Library Reference Manual}).\n")
+	    "GNU C Library Reference Manual}) and on MS-Windows.\n")
 #define FUNC_NAME s_scm_setaffinity
 {
   cpu_set_t cs;
@@ -2056,7 +2096,7 @@ SCM_DEFINE (scm_setaffinity, "setaffinity", 2, 0, 0,
 }
 #undef FUNC_NAME
 
-#endif /* HAVE_SCHED_SETAFFINITY */
+#endif /* HAVE_SCHED_SETAFFINITY || __MINGW32__ */
 
 \f
 #if HAVE_GETPASS
@@ -2235,13 +2275,11 @@ SCM_DEFINE (scm_gethostname, "gethostname", 0, 0, 0,
 #endif /* HAVE_GETHOSTNAME */
 
 \f
-#ifdef HAVE_FORK
 static void
 scm_init_popen (void)
 {
   scm_c_define_gsubr ("open-process", 2, 0, 1, scm_open_process);
 }
-#endif
 
 void
 scm_init_posix ()
@@ -2340,11 +2378,11 @@ scm_init_posix ()
 
 #ifdef HAVE_FORK
   scm_add_feature ("fork");
+#endif	/* HAVE_FORK */
   scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION,
                             "scm_init_popen",
 			    (scm_t_extension_init_func) scm_init_popen,
 			    NULL);
-#endif	/* HAVE_FORK */
 }
 
 /*
diff --git a/libguile/w32-proc.c b/libguile/w32-proc.c
new file mode 100644
index 0000000..fc5aa62
--- /dev/null
+++ b/libguile/w32-proc.c
@@ -0,0 +1,886 @@
+/* Copyright (C) 2016 Free Software Foundation, Inc.
+ *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
+ *
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
+ */
+
+#include <c-strcase.h>
+
+# define WEXITSTATUS(stat_val) ((stat_val) & 255)
+/* MS-Windows programs that crash due to a fatal exception exit with
+   an exit code whose 2 MSB bits are set.  */
+# define WIFEXITED(stat_val)   (((stat_val) & 0xC0000000) == 0)
+# define WIFSIGNALED(stat_val) (((stat_val) & 0xC0000000) == 0xC0000000)
+# define WTERMSIG(stat_val)    w32_status_to_termsig (stat_val)
+/* The funny conditional avoids a compiler warning in status:stop_sig.  */
+# define WIFSTOPPED(stat_val)  ((stat_val) == (stat_val) ? 0 : 0)
+# define WSTOPSIG(stat_var)    (0)
+# include <process.h>
+# define HAVE_WAITPID 1
+  static int w32_status_to_termsig (DWORD);
+  static int w32_signal_to_status (int);
+# define getuid()              (500) /* Local Administrator */
+# define getgid()              (513) /* None */
+# define setuid(u)             (0)
+# define setgid(g)             (0)
+# define WIN32_LEAN_AND_MEAN
+# include <windows.h>
+# define WNOHANG               1
+  int waitpid (intptr_t, int *, int);
+
+  typedef DWORD_PTR cpu_set_t;
+
+#define CPU_ZERO(s)     memset(s,0,sizeof(*s))
+#define CPU_ISSET(b,s)  ((*s) & (1U << (b))) != 0
+#define CPU_SET(b,s)    (*s) |= (1U << (b))
+#define CPU_SETSIZE     (8*sizeof(DWORD_PTR))
+
+/* Run a child process with redirected standard handles, without
+   redirecting standard handles of the parent.  This is required in
+   multithreaded programs, where redirecting a standard handle affects
+   all threads.  */
+
+#include <stdlib.h>
+#include <string.h>
+
+/* Prepare a possibly redirected file handle to be passed to a child
+   process.  The handle is for the file/device open on file descriptor
+   FD; if FD is invalid, use the null device instead.
+
+   USE_STD non-zero means we have been passed the descriptor used by
+   the parent.
+
+   ACCESS is the Windows access mode for opening the null device.
+
+   Returns the Win32 handle to be passed to CreateProcess.  */
+static HANDLE
+prepare_child_handle (int fd, int use_std, DWORD access)
+{
+  HANDLE htem, hret;
+  DWORD err = 0;
+
+  /* Start with the descriptor, if specified by the caller and valid,
+     otherwise open the null device.  */
+  if (fd < 0)
+    htem = INVALID_HANDLE_VALUE;
+  else
+    htem = (HANDLE)_get_osfhandle (fd);
+
+  /* Duplicate the handle and make it inheritable.  */
+  if (DuplicateHandle (GetCurrentProcess (),
+		       htem,
+		       GetCurrentProcess (),
+		       &hret,
+		       0,
+		       TRUE,
+		       DUPLICATE_SAME_ACCESS) == FALSE)
+    {
+      /* If the original standard handle was invalid (happens, e.g.,
+	 in GUI programs), open the null device instead.  */
+      if ((err = GetLastError ()) == ERROR_INVALID_HANDLE
+	  && use_std)
+	{
+	  htem = CreateFile ("NUL", access,
+			     FILE_SHARE_READ | FILE_SHARE_WRITE, NULL,
+			     OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, NULL);
+	  if (htem != INVALID_HANDLE_VALUE
+	      && DuplicateHandle (GetCurrentProcess (),
+				  htem,
+				  GetCurrentProcess (),
+				  &hret,
+				  0,
+				  TRUE,
+				  DUPLICATE_SAME_ACCESS) == FALSE)
+	    {
+	      err = GetLastError ();
+	      CloseHandle (htem);
+	      hret = INVALID_HANDLE_VALUE;
+	    }
+	}
+    }
+
+  if (hret == INVALID_HANDLE_VALUE)
+    {
+      switch (err)
+	{
+	  case ERROR_NO_MORE_FILES:
+	    errno = EMFILE;
+	    break;
+	  case ERROR_INVALID_HANDLE:
+	  default:
+	    errno = EBADF;
+	    break;
+	}
+    }
+
+  return hret;
+}
+
+/* A comparison function for sorting the environment.  */
+static int
+compenv (const void *a1, const void *a2)
+{
+  return stricmp (*((char**)a1), *((char**)a2));
+}
+
+/* Convert the program's 'environ' array to a block of environment
+   variables suitable to be passed to CreateProcess.  This is needed
+   to ensure the child process inherits the up-to-date environment of
+   the parent, including any variables inserted by the parent.  */
+static void
+prepare_envblk (char **envp, char **envblk)
+{
+  char **tmp;
+  int size_needed;
+  int envcnt;
+  char *ptr;
+
+  for (envcnt = 0; envp[envcnt]; envcnt++)
+    ;
+
+  tmp = scm_calloc ((envcnt + 1) * sizeof (*tmp));
+
+  for (envcnt = size_needed = 0; envp[envcnt]; envcnt++)
+    {
+      tmp[envcnt] = envp[envcnt];
+      size_needed += strlen (envp[envcnt]) + 1;
+    }
+  size_needed++;
+
+  /* Windows likes its environment variables sorted.  */
+  qsort ((void *) tmp, (size_t) envcnt, sizeof (char *), compenv);
+
+  /* CreateProcess needs the environment block as a linear array,
+     where each variable is terminated by a null character, and the
+     last one is terminated by 2 null characters.  */
+  ptr = *envblk = scm_calloc (size_needed);
+
+  for (envcnt = 0; tmp[envcnt]; envcnt++)
+    {
+      strcpy (ptr, tmp[envcnt]);
+      ptr += strlen (tmp[envcnt]) + 1;
+    }
+
+  free (tmp);
+}
+
+/* Find an executable PROGRAM on PATH, return result in malloc'ed
+   storage.  If PROGRAM is /bin/sh, and no sh.exe was found on PATH,
+   fall back on the Windows shell and set BIN_SH_REPLACED to non-zero.  */
+static char *
+lookup_cmd (const char *program, int *bin_sh_replaced)
+{
+  static const char *extensions[] = {
+    ".exe", ".cmd", ".bat", "", ".com", NULL
+  };
+  int bin_sh_requested = 0;
+  char *path, *dir, *sep;
+  char abs_name[MAX_PATH];
+  DWORD abs_namelen = 0;
+
+  /* If they ask for the Unix system shell, try to find it on PATH.  */
+  if (c_strcasecmp (program, "/bin/sh") == 0)
+    {
+      bin_sh_requested = 1;
+      program = "sh.exe";
+    }
+
+  /* If PROGRAM includes leading directories, the caller already did
+     our job.  */
+  if (strchr (program, '/') != NULL
+      || strchr (program, '\\') != NULL)
+    return scm_strdup (program);
+
+  /* Note: It is OK for getenv below to return NULL -- in that case,
+     SearchPath will search in the directories whose list is specified
+     by the system Registry.  */
+  path = getenv ("PATH");
+  if (!path)	/* shouldn't happen, really */
+    path = ".";
+  dir = sep = path = strdup (path);
+  for ( ; sep && *sep; dir = sep + 1)
+    {
+      int i;
+
+      sep = strpbrk (dir, ";");
+      if (sep == dir)	/* two or more ;'s in a row */
+	continue;
+      if (sep)
+	*sep = '\0';
+      for (i = 0; extensions[i]; i++)
+	{
+	  abs_namelen = SearchPath (dir, program, extensions[i],
+				    MAX_PATH, abs_name, NULL);
+	  if (0 < abs_namelen && abs_namelen <= MAX_PATH)	/* found! */
+	    break;
+	}
+      if (extensions[i])	/* found! */
+	break;
+      if (sep)
+	*sep = ';';
+    }
+
+  free (path);
+
+  /* If they asked for /bin/sh and we didn't find it, fall back on the
+     default Windows shell.  */
+  if (abs_namelen <= 0 && bin_sh_requested)
+    {
+      const char *shell = getenv ("ComSpec");
+
+      if (!shell)
+	shell = "C:\\Windows\\system32\\cmd.exe";
+
+      *bin_sh_replaced = 1;
+      strcpy (abs_name, shell);
+      abs_namelen = strlen (abs_name);
+    }
+
+  /* If not found, return the original PROGRAM name.  */
+  if (abs_namelen <= 0 || abs_namelen > MAX_PATH)
+    return scm_strdup (program);
+
+  return scm_strndup (abs_name, abs_namelen);
+}
+
+/* Concatenate command-line arguments in argv[] into a single
+   command-line string, while quoting arguments as needed.  The result
+   is malloc'ed.  */
+static char *
+prepare_cmdline (const char *cmd, const char * const *argv, int bin_sh_replaced)
+{
+  /* These characters should include anything that is special to _any_
+     program, including both Windows and Unixy shells, and the
+     widlcard expansion in startup code of a typical Windows app.  */
+  const char need_quotes[] = " \t#;\"\'*?[]&|<>(){}$`^";
+  size_t cmdlen = 1;	/* for terminating null */
+  char *cmdline = scm_malloc (cmdlen);
+  char *dst = cmdline;
+  int cmd_exe_quoting = 0;
+  int i;
+  const char *p;
+
+  /* Are we constructing a command line for cmd.exe?  */
+  if (bin_sh_replaced)
+    cmd_exe_quoting = 1;
+  else
+    {
+      for (p = cmd + strlen (cmd);
+	   p > cmd && p[-1] != '/' && p[-1] != '\\' && p[-1] != ':';
+	   p--)
+	;
+      if (c_strcasecmp (p, "cmd.exe") == 0
+	  || c_strcasecmp (p, "cmd") == 0)
+	cmd_exe_quoting = 1;
+    }
+
+  /* Initialize the command line to empty.  */
+  *dst = '\0';
+
+  /* Append arguments, if any, from argv[]. */
+  for (i = 0; argv[i]; i++)
+    {
+      const char *src = argv[i];
+      size_t len;
+      int quote_this = 0, n_backslashes = 0;
+      int j;
+
+      /* Append the blank separator.  We don't do that for argv[0]
+	 because that is the command name (will end up in child's
+	 argv[0]), and is only recognized as such if there're no
+	 blanks before it.  */
+      if (i > 0)
+	*dst++ = ' ';
+      len = dst - cmdline;
+
+      /* How much space is required for this argument?  */
+      cmdlen += strlen (argv[i]) + 1; /* 1 for a blank separator */
+      /* cmd.exe needs a different style of quoting: all the arguments
+	 beyond the /c switch are enclosed in an extra pair of quotes,
+	 and not otherwise quoted/escaped. */
+      if (cmd_exe_quoting)
+	{
+	  if (i == 2)
+	    cmdlen += 2;
+	}
+      else if (strpbrk (argv[i], need_quotes))
+	{
+	  quote_this = 1;
+	  cmdlen += 2;
+	  for ( ; *src; src++)
+	    {
+	      /* An embedded quote needs to be escaped by a backslash.
+		 Any backslashes immediately preceding that quote need
+		 each one to be escaped by another backslash.  */
+	      if (*src == '\"')
+		cmdlen += n_backslashes + 1;
+	      if (*src == '\\')
+		n_backslashes++;
+	      else
+		n_backslashes = 0;
+	    }
+	  /* If the closing quote we will add is preceded by
+	     backslashes, those backslashes need to be escaped.  */
+	  cmdlen += n_backslashes;
+	}
+
+      /* Enlarge the command-line string as needed.  */
+      cmdline = scm_realloc (cmdline, cmdlen);
+      dst = cmdline + len;
+
+      if (i == 0
+	  && c_strcasecmp (argv[0], "/bin/sh") == 0
+	  && bin_sh_replaced)
+	{
+	  strcpy (dst, "cmd.exe");
+	  dst += sizeof ("cmd.exe") - 1;
+	  continue;
+	}
+      if (i == 1 && bin_sh_replaced && strcmp (argv[1], "-c") == 0)
+	{
+	  *dst++ = '/';
+	  *dst++ = 'c';
+	  *dst = '\0';
+	  continue;
+	}
+
+      /* Add this argument, possibly quoted, to the command line.  */
+      if (quote_this || (i == 2 && cmd_exe_quoting))
+	*dst++ = '\"';
+      for (src = argv[i]; *src; src++)
+	{
+	  if (quote_this)
+	    {
+	      if (*src == '\"')
+		for (j = n_backslashes + 1; j > 0; j--)
+		  *dst++ = '\\';
+	      if (*src == '\\')
+		n_backslashes++;
+	      else
+		n_backslashes = 0;
+	    }
+	  *dst++ = *src;
+	}
+      if (quote_this)
+	{
+	  for (j = n_backslashes; j > 0; j--)
+	    *dst++ = '\\';
+	  *dst++ = '\"';
+	}
+      *dst = '\0';
+    }
+
+  if (cmd_exe_quoting && i > 2)
+    {
+      /* One extra slot was already reserved when we enlarged cmdlen
+	 by 2 in the "if (cmd_exe_quoting)" clause above.  So we can
+	 safely append a closing quote.  */
+      *dst++ = '\"';
+      *dst = '\0';
+    }
+
+  return cmdline;
+}
+
+/* Start a child process running the program in EXEC_FILE with its
+   standard input and output optionally redirected to a pipe.  ARGV is
+   the array of command-line arguments to pass to the child.  P2C and
+   C2P are 2 pipes for communicating with the child, and ERRFD is the
+   standard error file descriptor to be inherited by the child.
+   READING and WRITING, if non-zero, mean that the corresponding pipe
+   will be used.
+
+   Return the PID of the child process, or -1 if couldn't start a
+   process.  */
+static intptr_t
+start_child (const char *exec_file, char **argv,
+	     int reading, int c2p[2], int writing, int p2c[2], int errfd)
+{
+  HANDLE hin = INVALID_HANDLE_VALUE, hout = INVALID_HANDLE_VALUE;
+  HANDLE herr = INVALID_HANDLE_VALUE;
+  STARTUPINFO si;
+  char *env_block = NULL;
+  char *cmdline = NULL;
+  PROCESS_INFORMATION pi;
+  char *progfile, *p;
+  int errno_save;
+  intptr_t pid;
+  int bin_sh_replaced = 0;
+
+  /* Prepare standard handles to be passed to the child process.  */
+  hin = prepare_child_handle (p2c[0], !writing, GENERIC_READ);
+  if (hin == INVALID_HANDLE_VALUE)
+    return -1;
+  hout = prepare_child_handle (c2p[1], !reading, GENERIC_WRITE);
+  if (hout == INVALID_HANDLE_VALUE)
+    return -1;
+  herr = prepare_child_handle (errfd, 1, GENERIC_WRITE);
+  if (herr == INVALID_HANDLE_VALUE)
+    return -1;
+
+  /* Make sure the parent side of both pipes is not inherited.  This
+     is required because gnulib's 'pipe' creates pipes whose both ends
+     are inheritable, which is traditional on Posix (where pipe
+     descriptors are implicitly duplicated by 'fork'), but wrong on
+     Windows (where pipe handles need to be explicitly
+     duplicated).  */
+  if (writing)
+    SetHandleInformation ((HANDLE)_get_osfhandle (p2c[1]),
+			  HANDLE_FLAG_INHERIT, 0);
+  if (reading)
+    {
+      SetHandleInformation ((HANDLE)_get_osfhandle (c2p[0]),
+			    HANDLE_FLAG_INHERIT, 0);
+      /* Gnulib's 'pipe' opens the pipe in binary mode, but we don't
+	 want to read text-mode input of subprocesses in binary more,
+	 because then we will get the ^M (a.k.a. "CR") characters we
+	 don't expect.  */
+      _setmode (c2p[0], _O_TEXT);
+    }
+
+  /* Set up the startup info for the child, using the parent's as the
+     starting point, and specify in it the redirected handles.  */
+  GetStartupInfo (&si);
+  si.dwFlags = STARTF_USESTDHANDLES;
+  si.lpReserved = 0;
+  si.cbReserved2 = 0;
+  si.lpReserved2 = 0;
+  si.hStdInput = hin;
+  si.hStdOutput = hout;
+  si.hStdError = herr;
+
+  /* Create the environment block for the child.  This is needed
+     because the environment we have in 'environ' is not in the format
+     expected by CreateProcess.  */
+  prepare_envblk (environ, &env_block);
+
+  /* CreateProcess doesn't search PATH, so we must do that for it.  */
+  progfile = lookup_cmd (exec_file, &bin_sh_replaced);
+
+  /* CreateProcess doesn't like forward slashes in the application
+     file name.  */
+  for (p = progfile; *p; p++)
+    if (*p == '/')
+      *p = '\\';
+
+  /* Construct the command line.  */
+  cmdline = prepare_cmdline (exec_file, (const char * const *)argv,
+			     bin_sh_replaced);
+
+  /* All set and ready to fly.  Launch the child process.  */
+  if (!CreateProcess (progfile, cmdline, NULL, NULL, TRUE, 0, env_block, NULL,
+		      &si, &pi))
+    {
+      pid = -1;
+
+      /* Since we use Win32 APIs directly, we need to translate their
+	 errors to errno values by hand.  */
+      switch (GetLastError ())
+	{
+	  case ERROR_FILE_NOT_FOUND:
+	  case ERROR_PATH_NOT_FOUND:
+	  case ERROR_INVALID_DRIVE:
+	  case ERROR_BAD_PATHNAME:
+	    errno = ENOENT;
+	    break;
+	  case ERROR_ACCESS_DENIED:
+	    errno = EACCES;
+	    break;
+	  case ERROR_BAD_ENVIRONMENT:
+	    errno = E2BIG;
+	    break;
+	  case ERROR_BROKEN_PIPE:
+	    errno = EPIPE;
+	    break;
+	  case ERROR_INVALID_HANDLE:
+	    errno = EBADF;
+	    break;
+	  case ERROR_MAX_THRDS_REACHED:
+	    errno = EAGAIN;
+	    break;
+	  case ERROR_BAD_EXE_FORMAT:
+	  case ERROR_BAD_FORMAT:
+	  default:
+	    errno = ENOEXEC;
+	    break;
+	}
+    }
+  else
+    pid = (intptr_t)pi.hProcess;
+
+  errno_save = errno;
+
+  /* Free resources.  */
+  free (progfile);
+  free (cmdline);
+  free (env_block);
+  CloseHandle (hin);
+  CloseHandle (hout);
+  CloseHandle (herr);
+  CloseHandle (pi.hThread);
+
+  /* Posix requires to call the shell if execvp fails to invoke EXEC_FILE.  */
+  if (errno_save == ENOEXEC || errno_save == ENOENT)
+    {
+      const char *shell = getenv ("ComSpec");
+
+      if (!shell)
+	shell = "cmd.exe";
+
+      if (c_strcasecmp (exec_file, shell) != 0)
+	{
+	  argv[0] = (char *)exec_file;
+	  return start_child (shell, argv, reading, c2p, writing, p2c, errfd);
+	}
+    }
+
+  errno = errno_save;
+  return pid;
+}
+
+\f
+/* Emulation of waitpid which only supports WNOHANG, since _cwait doesn't.  */
+int
+waitpid (intptr_t pid, int *status, int options)
+{
+  if ((options & WNOHANG) != 0)
+    {
+      DWORD st;
+
+      if (!GetExitCodeProcess ((HANDLE)pid, &st))
+	{
+	  errno = ECHILD;
+	  return -1;
+	}
+      if (st == STILL_ACTIVE)
+	return 0;
+      if (status)
+	*status = st;
+      return (int)pid;
+    }
+
+  return (int)_cwait (status, pid, WAIT_CHILD);
+}
+
+\f
+/* Translate abnormal exit status of Windows programs into the signal
+   that terminated the program.  This is required to support scm_kill
+   and WTERMSIG.  */
+
+struct signal_and_status {
+  int sig;
+  DWORD status;
+};
+
+static const struct signal_and_status sigtbl[] = {
+  {SIGSEGV, 0xC0000005},	/* access to invalid address */
+  {SIGSEGV, 0xC0000008},	/* invalid handle */
+  {SIGILL,  0xC000001D},	/* illegal instruction */
+  {SIGILL,  0xC0000025},	/* non-continuable instruction */
+  {SIGSEGV, 0xC000008C},	/* array bounds exceeded */
+  {SIGFPE,  0xC000008D},	/* float denormal */
+  {SIGFPE,  0xC000008E},	/* float divide by zero */
+  {SIGFPE,  0xC000008F},	/* float inexact */
+  {SIGFPE,  0xC0000090},	/* float invalid operation */
+  {SIGFPE,  0xC0000091},	/* float overflow */
+  {SIGFPE,  0xC0000092},	/* float stack check */
+  {SIGFPE,  0xC0000093},	/* float underflow */
+  {SIGFPE,  0xC0000094},	/* integer divide by zero */
+  {SIGFPE,  0xC0000095},	/* integer overflow */
+  {SIGILL,  0xC0000096},	/* privileged instruction */
+  {SIGSEGV, 0xC00000FD},	/* stack overflow */
+  {SIGTERM, 0xC000013A},	/* Ctrl-C exit */
+  {SIGINT,  0xC000013A}
+};
+
+static int
+w32_signal_to_status (int sig)
+{
+  int i;
+
+  for (i = 0; i < sizeof (sigtbl) / sizeof (sigtbl[0]); i++)
+    if (sig == sigtbl[i].sig)
+      return sigtbl[i].status;
+
+  return (int)0xC000013A;
+}
+
+static int
+w32_status_to_termsig (DWORD status)
+{
+  int i;
+
+  for (i = 0; i < sizeof (sigtbl) / sizeof (sigtbl[0]); i++)
+    if (status == sigtbl[i].status)
+      return sigtbl[i].sig;
+
+  return SIGTERM;
+}
+
+/* Emulation of getpriority and setpriority.  */
+
+#define PRIO_PROCESS 1
+#define PRIO_PGRP    2
+#define PRIO_USER    3
+#define NZERO        8
+
+static int
+getpriority (int which, int who)
+{
+  HANDLE hp;
+  int nice_value = -1;
+  int error = 0;
+
+  /* We don't support process groups and users.  */
+  if (which != PRIO_PROCESS)
+    {
+      errno = ENOSYS;
+      return -1;
+    }
+
+  if (who == 0)
+    hp = GetCurrentProcess ();
+  else
+    hp = OpenProcess (PROCESS_QUERY_INFORMATION, FALSE, who);
+
+  if (hp)
+    {
+      DWORD pri_class = GetPriorityClass (hp);
+
+      if (pri_class > 0)
+	{
+	  switch (pri_class)
+	    {
+	    case IDLE_PRIORITY_CLASS:
+	      nice_value = 4;
+	      break;
+	    case BELOW_NORMAL_PRIORITY_CLASS:
+	      nice_value = 6;
+	      break;
+	    case NORMAL_PRIORITY_CLASS:
+	      nice_value = 8;
+	      break;
+	    case ABOVE_NORMAL_PRIORITY_CLASS:
+	      nice_value = 10;
+	      break;
+	    case HIGH_PRIORITY_CLASS:
+	      nice_value = 13;
+	      break;
+	    case REALTIME_PRIORITY_CLASS:
+	      nice_value = 24;
+	      break;
+	    }
+	  /* If WHO is us, we can provide a more fine-grained value by
+	     looking at the current thread's priority value.  (For
+	     other processes, it is not clear which thread to use.)  */
+	  if (who == 0 || who == GetCurrentProcessId ())
+	    {
+	      HANDLE ht = GetCurrentThread ();
+	      int tprio = GetThreadPriority (ht);
+
+	      switch (tprio)
+		{
+		case THREAD_PRIORITY_IDLE:
+		  if (pri_class == REALTIME_PRIORITY_CLASS)
+		    nice_value = 16;
+		  else
+		    nice_value = 1;
+		  break;
+		case THREAD_PRIORITY_TIME_CRITICAL:
+		  if (pri_class == REALTIME_PRIORITY_CLASS)
+		    nice_value = 31;
+		  else
+		    nice_value = 15;
+		case THREAD_PRIORITY_ERROR_RETURN:
+		  nice_value = -1;
+		  error = 1;
+		  break;
+		default:
+		  nice_value += tprio;
+		  break;
+		}
+	    }
+	  /* Map to "nice values" similar to what one would see on
+	     Posix platforms.  */
+	  if (!error)
+	    nice_value = - (nice_value - NZERO);
+	}
+      else
+	error = 1;
+    }
+  else
+    error = 1;
+
+  if (error)
+    {
+      DWORD err = GetLastError ();
+
+      switch (err)
+	{
+	case ERROR_INVALID_PARAMETER:
+	case ERROR_INVALID_THREAD_ID:
+	  errno = ESRCH;
+	  break;
+	default:
+	  errno = EPERM;
+	  break;
+	}
+    }
+
+  return nice_value;
+}
+
+static int
+setpriority (int which, int who, int nice_val)
+{
+  HANDLE hp;
+  DWORD err;
+
+  if (which != PRIO_PROCESS)
+    {
+      errno = ENOSYS;
+      return -1;
+    }
+
+  if (who == 0)
+    hp = GetCurrentProcess ();
+  else
+    hp = OpenProcess (PROCESS_SET_INFORMATION, FALSE, who);
+
+  if (hp)
+    {
+      DWORD pri_class;
+
+      /* Map "nice values" back to process priority classes.  */
+      nice_val = -nice_val + NZERO;
+      if (nice_val < 6)
+	pri_class = IDLE_PRIORITY_CLASS;
+      else if (nice_val < 8)
+	pri_class = BELOW_NORMAL_PRIORITY_CLASS;
+      else if (nice_val < 10)
+	pri_class = NORMAL_PRIORITY_CLASS;
+      else if (nice_val < 13)
+	pri_class = ABOVE_NORMAL_PRIORITY_CLASS;
+      else if (nice_val < 16)
+	pri_class = HIGH_PRIORITY_CLASS;
+      else
+	pri_class = REALTIME_PRIORITY_CLASS;
+
+      if (SetPriorityClass (hp, pri_class))
+	return 0;
+    }
+
+  err = GetLastError ();
+
+  switch (err)
+    {
+    case ERROR_INVALID_PARAMETER:
+      errno = ESRCH;
+      break;
+    default:
+      errno = EPERM;
+      break;
+    }
+
+  return -1;
+}
+
+/* Emulation of sched_getaffinity and sched_setaffinity.  */
+static int
+sched_getaffinity (int pid, size_t mask_size, cpu_set_t *mask)
+{
+  HANDLE hp;
+  DWORD err;
+
+  if (mask == NULL)
+    {
+      errno = EFAULT;
+      return -1;
+    }
+
+  if (pid == 0)
+    hp = GetCurrentProcess ();
+  else
+    hp = OpenProcess (PROCESS_QUERY_INFORMATION, FALSE, pid);
+
+  if (hp)
+    {
+      DWORD_PTR ignored;
+      BOOL result = GetProcessAffinityMask (hp, (DWORD_PTR *)mask, &ignored);
+
+      if (pid != 0)
+	CloseHandle (hp);
+      if (result)
+	return 0;
+    }
+
+  err = GetLastError ();
+
+  switch (err)
+    {
+    case ERROR_INVALID_PARAMETER:
+      errno = ESRCH;
+      break;
+    case ERROR_ACCESS_DENIED:
+    default:
+      errno = EPERM;
+      break;
+    }
+
+  return -1;
+}
+
+static int
+sched_setaffinity (int pid, size_t mask_size, cpu_set_t *mask)
+{
+  HANDLE hp;
+  DWORD err;
+
+  if (mask == NULL)
+    {
+      errno = EFAULT;
+      return -1;
+    }
+
+  if (pid == 0)
+    hp = GetCurrentProcess ();
+  else
+    hp = OpenProcess (PROCESS_SET_INFORMATION, FALSE, pid);
+
+  if (hp)
+    {
+      BOOL result = SetProcessAffinityMask (hp, *(DWORD_PTR *)mask);
+
+      if (pid != 0)
+	CloseHandle (hp);
+      if (result)
+	return 0;
+    }
+
+  err = GetLastError ();
+
+  switch (err)
+    {
+    case ERROR_INVALID_PARAMETER:
+      errno = ESRCH;
+      break;
+    case ERROR_ACCESS_DENIED:
+    default:
+      errno = EPERM;
+      break;
+    }
+
+  return -1;
+}

Re: Support open-process and friends on MS-Windows

[Andy Wingo]

On Fri 24 Jun 2016 11:51, Eli Zaretskii <eliz@gnu.org> writes:

> This is a re-spin of the patches last posted here:
>
>   https://lists.gnu.org/archive/html/guile-devel/2014-08/msg00015.html
>
> At Andy's suggestion, I've removed most of the Windows-specific code
> to the new Windows-specific file w32-proc.c, leaving just the minimum
> changes in posix.c itself.  The patch below is against the stable-2.0
> branch in the Guile Git repository.
>
> I hope we will be able to get this into the repository this time.

Thanks!

I think it looks pretty good.  I wouldn't mind committing as-is.  I
would like to hear what Ludovic or Mark thinks before doing do; WDYT?

Andy

Re: Support open-process and friends on MS-Windows

[Eli Zaretskii]

> From: Andy Wingo <wingo@pobox.com>
> Cc: ludo@gnu.org,  guile-devel@gnu.org
> Date: Fri, 24 Jun 2016 12:45:36 +0200
> 
> Thanks!
> 
> I think it looks pretty good.  I wouldn't mind committing as-is.  I
> would like to hear what Ludovic or Mark thinks before doing do; WDYT?

It's obviously your call how to proceed with this.

Thanks.

Re: Support open-process and friends on MS-Windows

[Ludovic Courtès]

Eli Zaretskii <eliz@gnu.org> skribis:

> commit 44f8eebf9850431790b23b031f5b6e90fb3de777
> Author: Eli Zaretskii <eliz@gnu.org>
> Date:   Fri Jun 24 12:45:02 2016 +0300
>
>     Provide support for open-process and related functions on MS-Windows
>     
>     * libguile/w32-proc.c: New file, with MinGW support code for
>     scm_open_process, scm_getpriority, scm_setpriority,
>     scm_getaffinity, and scm_setaffinity.  Also, provides macros that
>     on Posix hosts are in sys/wait.h, like WIFEXITED and WTERMSIG, and
>     simple definitions for getuid, getgid, setuid, setgid, and
>     waitpid.

This is a good idea (I cannot comment on the content of w32-proc.c since
I’m not familiar with the Windows API, but I obviously trust you).

> diff --git a/libguile/posix.c b/libguile/posix.c
> index 2654716..35b920f 100644
> --- a/libguile/posix.c
> +++ b/libguile/posix.c
> @@ -84,6 +84,10 @@
>  #if HAVE_SYS_WAIT_H
>  # include <sys/wait.h>
>  #endif
> +#ifdef __MINGW32__
> +# include "w32-proc.c"
> +#endif	/* __MINGW32__ */

I’d have a slight preference for using AC_LIBSOURCE or a Makefile.am
snippet to compile w32-proc.c separately (which means w32-proc.h should
be added to provide declarations).

However this shouldn’t be a blocker (if the current approach is kept,
use <w32-proc.c> rather than "w32-proc.c").

> @@ -659,7 +663,7 @@ SCM_DEFINE (scm_kill, "kill", 2, 0, 0,
>  #else
>    /* Mingw has raise(), but not kill().  (Other raw DOS environments might
>       be similar.)  Use raise() when the requested pid is our own process,
> -     otherwise bomb.  */
> +     otherwise TerminateProcess.  */
>    if (scm_to_int (pid) == getpid ())
>      {
>        if (raise (scm_to_int (sig)) != 0)
> @@ -673,6 +677,25 @@ SCM_DEFINE (scm_kill, "kill", 2, 0, 0,
>            goto err;
>          }
>      }
> +#ifdef __MINGW32__
> +  else
> +    {
> +      HANDLE ph = OpenProcess (PROCESS_TERMINATE, 0, scm_to_int (pid));
> +      int s = scm_to_int (sig);
> +
> +      if (!ph)
> +	{
> +	  errno = EPERM;
> +	  goto err;
> +	}
> +      if (!TerminateProcess (ph, w32_signal_to_status (s)))
> +	{
> +	  errno = EINVAL;
> +	  goto err;
> +	}
> +      CloseHandle (ph);
> +    }
> +#endif	/* __MINGW32__ */
>  #endif
>    return SCM_UNSPECIFIED;

For consistency maybe this should go in a ‘kill’ function in w32-proc.c?

The rest looks good to me.

Thanks a lot for taking the time to update the patch, and for forgiving
our failure to handle it earlier.

Ludo’.

Re: Support open-process and friends on MS-Windows

[Eli Zaretskii]

> From: ludo@gnu.org (Ludovic Courtès)
> Cc: Andy Wingo <wingo@pobox.com>,  guile-devel@gnu.org
> Date: Fri, 24 Jun 2016 13:49:17 +0200
> 
> > diff --git a/libguile/posix.c b/libguile/posix.c
> > index 2654716..35b920f 100644
> > --- a/libguile/posix.c
> > +++ b/libguile/posix.c
> > @@ -84,6 +84,10 @@
> >  #if HAVE_SYS_WAIT_H
> >  # include <sys/wait.h>
> >  #endif
> > +#ifdef __MINGW32__
> > +# include "w32-proc.c"
> > +#endif	/* __MINGW32__ */
> 
> I’d have a slight preference for using AC_LIBSOURCE or a Makefile.am
> snippet to compile w32-proc.c separately (which means w32-proc.h should
> be added to provide declarations).

I'm not much of an expert on autotools, so I preferred to do this the
way I can understand and convince myself the code is correct.  I don't
mind to doing that your way, of course, but I'd prefer that someone
else does the refactoring, if possible.

> However this shouldn’t be a blocker (if the current approach is kept,
> use <w32-proc.c> rather than "w32-proc.c").

Great!

> > +#ifdef __MINGW32__
> > +  else
> > +    {
> > +      HANDLE ph = OpenProcess (PROCESS_TERMINATE, 0, scm_to_int (pid));
> > +      int s = scm_to_int (sig);
> > +
> > +      if (!ph)
> > +	{
> > +	  errno = EPERM;
> > +	  goto err;
> > +	}
> > +      if (!TerminateProcess (ph, w32_signal_to_status (s)))
> > +	{
> > +	  errno = EINVAL;
> > +	  goto err;
> > +	}
> > +      CloseHandle (ph);
> > +    }
> > +#endif	/* __MINGW32__ */
> >  #endif
> >    return SCM_UNSPECIFIED;
> 
> For consistency maybe this should go in a ‘kill’ function in w32-proc.c?

I can do that.  It's just that I thought such a short code fragment
doesn't need that, but I don't mind.

> Thanks a lot for taking the time to update the patch, and for forgiving
> our failure to handle it earlier.

Thanks for giving me another chance to submit this.

Re: Support open-process and friends on MS-Windows

[Eli Zaretskii]

Here's the modified patch with the couple of changes requested in
response to the previous version:

Author: Eli Zaretskii <eliz@gnu.org>
Date:   Fri Jun 25 12:10:34 2016 +0300

    Provide support for open-process and related functions on MS-Windows

    * libguile/w32-proc.c: New file, with MinGW support code for
    scm_open_process, scm_kill, scm_getpriority, scm_setpriority,
    scm_getaffinity, and scm_setaffinity.  Also, provides macros that
    on Posix hosts are in sys/wait.h, like WIFEXITED and WTERMSIG, and
    simple definitions for getuid, getgid, setuid, setgid, and
    waitpid.

    * libguile/posix.c [__MINGW32__]: Include w32-proc.c.
    (scm_kill) [__MINGW32__]: Support killing subprocesses on MS-Windows.
    (scm_status_exit_val, scm_getuid, scm_getegid): Don't exclude from
    compilation with MinGW.
    (scm_execl, scm_execle): Cast arguments of execv/execve to avoid
    compiler warnings.
    (scm_open_process): Condition parts specific to 'fork'-based
    implementation with "#ifdef HAVE_FORK".
    [__MINGW32__]: MinGW alternative to 'fork'-based implementation;
    most of the supporting code is in w32-proc.c.
    (scm_getpriority, scm_setpriority, scm_getaffinity)
    (scm_setaffinity, scm_init_popen): Don't exclude from MinGW
    compilation.
    (scm_init_posix): Register scm_init_popen extension even if
    HAVE_FORK is not defined.

diff --git a/libguile/posix.c b/libguile/posix.c
index 2654716..741867c 100644
--- a/libguile/posix.c
+++ b/libguile/posix.c
@@ -84,6 +84,10 @@
 #if HAVE_SYS_WAIT_H
 # include <sys/wait.h>
 #endif
+#ifdef __MINGW32__
+# include <w32-proc.c>
+#endif	/* __MINGW32__ */
+
 #ifndef WEXITSTATUS
 # define WEXITSTATUS(stat_val) ((unsigned)(stat_val) >> 8)
 #endif
@@ -659,7 +663,7 @@ SCM_DEFINE (scm_kill, "kill", 2, 0, 0,
 #else
   /* Mingw has raise(), but not kill().  (Other raw DOS environments might
      be similar.)  Use raise() when the requested pid is our own process,
-     otherwise bomb.  */
+     otherwise TerminateProcess.  */
   if (scm_to_int (pid) == getpid ())
     {
       if (raise (scm_to_int (sig)) != 0)
@@ -673,6 +677,10 @@ SCM_DEFINE (scm_kill, "kill", 2, 0, 0,
           goto err;
         }
     }
+#ifdef __MINGW32__
+  if (w32_kill_proc (scm_to_int (pid), scm_to_int (sig)) != 0)
+    SCM_SYSERROR;
+#endif	/* __MINGW32__ */
 #endif
   return SCM_UNSPECIFIED;
 }
@@ -735,7 +743,6 @@ SCM_DEFINE (scm_waitpid, "waitpid", 1, 1, 0,
 #undef FUNC_NAME
 #endif /* HAVE_WAITPID */
 
-#ifndef __MINGW32__
 SCM_DEFINE (scm_status_exit_val, "status:exit-val", 1, 0, 0, 
             (SCM status),
 	    "Return the exit status value, as would be set if a process\n"
@@ -786,7 +793,6 @@ SCM_DEFINE (scm_status_stop_sig, "status:stop-sig", 1, 0, 0,
     return SCM_BOOL_F;
 }
 #undef FUNC_NAME
-#endif /* __MINGW32__ */
 
 #ifdef HAVE_GETPPID
 SCM_DEFINE (scm_getppid, "getppid", 0, 0, 0,
@@ -801,7 +807,6 @@ SCM_DEFINE (scm_getppid, "getppid", 0, 0, 0,
 #endif /* HAVE_GETPPID */
 
 
-#ifndef __MINGW32__
 SCM_DEFINE (scm_getuid, "getuid", 0, 0, 0,
             (),
 	    "Return an integer representing the current real user ID.")
@@ -905,10 +910,8 @@ SCM_DEFINE (scm_seteuid, "seteuid", 1, 0, 0,
   return SCM_UNSPECIFIED;
 }
 #undef FUNC_NAME
-#endif /* __MINGW32__ */
 
 
-#ifdef HAVE_SETEGID
 SCM_DEFINE (scm_setegid, "setegid", 1, 0, 0,
             (SCM id),
 	    "Sets the effective group ID to the integer @var{id}, provided the process\n"
@@ -931,7 +934,6 @@ SCM_DEFINE (scm_setegid, "setegid", 1, 0, 0,
     
 }
 #undef FUNC_NAME
-#endif
 
 
 #ifdef HAVE_GETPGRP
@@ -1141,7 +1143,7 @@ SCM_DEFINE (scm_execl, "execl", 1, 0, 1,
 
   exec_argv = scm_i_allocate_string_pointers (args);
 
-  execv (exec_file, exec_argv);
+  execv (exec_file, (char const * const *)exec_argv);
   SCM_SYSERROR;
 
   /* not reached.  */
@@ -1170,7 +1172,7 @@ SCM_DEFINE (scm_execlp, "execlp", 1, 0, 1,
 
   exec_argv = scm_i_allocate_string_pointers (args);
 
-  execvp (exec_file, exec_argv);
+  execvp (exec_file, (char const * const *)exec_argv);
   SCM_SYSERROR;
 
   /* not reached.  */
@@ -1204,7 +1206,8 @@ SCM_DEFINE (scm_execle, "execle", 2, 0, 1,
   exec_argv = scm_i_allocate_string_pointers (args);
   exec_env = scm_i_allocate_string_pointers (env);
 
-  execve (exec_file, exec_argv, exec_env);
+  execve (exec_file, (char const * const *)exec_argv,
+	  (char const * const *)exec_env);
   SCM_SYSERROR;
 
   /* not reached.  */
@@ -1246,6 +1249,7 @@ SCM_DEFINE (scm_fork, "primitive-fork", 0, 0, 0,
   return scm_from_int (pid);
 }
 #undef FUNC_NAME
+#endif /* HAVE_FORK */
 
 /* Since Guile uses threads, we have to be very careful to avoid calling
    functions that are not async-signal-safe in the child.  That's why
@@ -1262,7 +1266,9 @@ scm_open_process (SCM mode, SCM prog, SCM args)
   int pid;
   char *exec_file;
   char **exec_argv;
+#ifdef HAVE_FORK
   int max_fd = 1024;
+#endif
 
   exec_file = scm_to_locale_string (prog);
   exec_argv = scm_i_allocate_string_pointers (scm_cons (prog, args));
@@ -1319,12 +1325,28 @@ scm_open_process (SCM mode, SCM prog, SCM args)
   }
 #endif
 
+#ifdef HAVE_FORK
   pid = fork ();
+#elif defined(__MINGW32__)
+  if (!reading)
+    c2p[1] = out;
+  if (!writing)
+    p2c[0] = in;
+  pid = start_child (exec_file, exec_argv, reading, c2p, writing, p2c, err);
+#else
+  close (c2p[0]);
+  close (c2p[1]);
+  close (p2c[0]);
+  close (p2c[1]);
+  free (exec_file);
+  errno = ENOSYS;
+  SCM_SYSERROR;
+#endif	/* HAVE_FORK */
 
   if (pid == -1)
     {
       int errno_save = errno;
-      free (exec_file);
+
       if (reading)
         {
           close (c2p[0]);
@@ -1336,6 +1358,8 @@ scm_open_process (SCM mode, SCM prog, SCM args)
           close (p2c[1]);
         }
       errno = errno_save;
+
+      free (exec_file);
       SCM_SYSERROR;
     }
 
@@ -1360,6 +1384,7 @@ scm_open_process (SCM mode, SCM prog, SCM args)
         (scm_list_3 (read_port, write_port, scm_from_int (pid)));
     }
 
+#ifdef HAVE_FORK
   /* The child.  */
   if (reading)
     close (c2p[0]);
@@ -1408,16 +1433,16 @@ scm_open_process (SCM mode, SCM prog, SCM args)
   if (err > 0)
     {
       char *msg = strerror (errno);
-      fprintf (fdopen (err, "a"), "In execlp of %s: %s\n",
+      fprintf (fdopen (err, "a"), "In execvp of %s: %s\n",
                exec_file, msg);
     }
 
   _exit (EXIT_FAILURE);
+#endif	/* HAVE_FORK */
   /* Not reached.  */
   return SCM_BOOL_F;
 }
 #undef FUNC_NAME
-#endif /* HAVE_FORK */
 
 #ifdef __MINGW32__
 # include "win32-uname.h"
@@ -1909,7 +1934,7 @@ SCM_DEFINE (scm_getlogin, "getlogin", 0, 0, 0,
 }
 #undef FUNC_NAME
 
-#if HAVE_GETPRIORITY
+#if HAVE_GETPRIORITY || defined __MINGW32__
 SCM_DEFINE (scm_getpriority, "getpriority", 2, 0, 0, 
             (SCM which, SCM who),
 	    "Return the scheduling priority of the process, process group\n"
@@ -1938,9 +1963,9 @@ SCM_DEFINE (scm_getpriority, "getpriority", 2, 0, 0,
   return scm_from_int (ret);
 }
 #undef FUNC_NAME
-#endif /* HAVE_GETPRIORITY */
+#endif /* HAVE_GETPRIORITY || __MINGW32__ */
 
-#if HAVE_SETPRIORITY
+#if HAVE_SETPRIORITY || defined __MINGW32__
 SCM_DEFINE (scm_setpriority, "setpriority", 3, 0, 0, 
             (SCM which, SCM who, SCM prio),
 	    "Set the scheduling priority of the process, process group\n"
@@ -1969,9 +1994,9 @@ SCM_DEFINE (scm_setpriority, "setpriority", 3, 0, 0,
   return SCM_UNSPECIFIED;
 }
 #undef FUNC_NAME
-#endif /* HAVE_SETPRIORITY */
+#endif /* HAVE_SETPRIORITY || __MINGW32__ */
 
-#ifdef HAVE_SCHED_GETAFFINITY
+#if defined HAVE_SCHED_GETAFFINITY || defined __MINGW32__
 
 static SCM
 cpu_set_to_bitvector (const cpu_set_t *cs)
@@ -2000,7 +2025,7 @@ SCM_DEFINE (scm_getaffinity, "getaffinity", 1, 0, 0,
 	    "Guile can use without stepping on other processes' toes.\n\n"
 	    "Currently this procedure is only defined on GNU variants\n"
 	    "(@pxref{CPU Affinity, @code{sched_getaffinity},, libc, The\n"
-	    "GNU C Library Reference Manual}).\n")
+	    "GNU C Library Reference Manual}) and on MS-Windows.\n")
 #define FUNC_NAME s_scm_getaffinity
 {
   int err;
@@ -2015,9 +2040,9 @@ SCM_DEFINE (scm_getaffinity, "getaffinity", 1, 0, 0,
 }
 #undef FUNC_NAME
 
-#endif /* HAVE_SCHED_GETAFFINITY */
+#endif /* HAVE_SCHED_GETAFFINITY || __MINGW32__ */
 
-#ifdef HAVE_SCHED_SETAFFINITY
+#if defined HAVE_SCHED_SETAFFINITY || defined __MINGW32__
 
 SCM_DEFINE (scm_setaffinity, "setaffinity", 2, 0, 0,
 	    (SCM pid, SCM mask),
@@ -2026,7 +2051,7 @@ SCM_DEFINE (scm_setaffinity, "setaffinity", 2, 0, 0,
 	    "is unspecified.\n\n"
 	    "Currently this procedure is only defined on GNU variants\n"
 	    "(@pxref{CPU Affinity, @code{sched_setaffinity},, libc, The\n"
-	    "GNU C Library Reference Manual}).\n")
+	    "GNU C Library Reference Manual}) and on MS-Windows.\n")
 #define FUNC_NAME s_scm_setaffinity
 {
   cpu_set_t cs;
@@ -2056,7 +2081,7 @@ SCM_DEFINE (scm_setaffinity, "setaffinity", 2, 0, 0,
 }
 #undef FUNC_NAME
 
-#endif /* HAVE_SCHED_SETAFFINITY */
+#endif /* HAVE_SCHED_SETAFFINITY || __MINGW32__ */
 
 \f
 #if HAVE_GETPASS
@@ -2235,13 +2260,11 @@ SCM_DEFINE (scm_gethostname, "gethostname", 0, 0, 0,
 #endif /* HAVE_GETHOSTNAME */
 
 \f
-#ifdef HAVE_FORK
 static void
 scm_init_popen (void)
 {
   scm_c_define_gsubr ("open-process", 2, 0, 1, scm_open_process);
 }
-#endif
 
 void
 scm_init_posix ()
@@ -2340,11 +2363,11 @@ scm_init_posix ()
 
 #ifdef HAVE_FORK
   scm_add_feature ("fork");
+#endif	/* HAVE_FORK */
   scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION,
                             "scm_init_popen",
 			    (scm_t_extension_init_func) scm_init_popen,
 			    NULL);
-#endif	/* HAVE_FORK */
 }
 
 /*
diff --git a/libguile/w32-proc.c b/libguile/w32-proc.c
new file mode 100644
index 0000000..016448c
--- /dev/null
+++ b/libguile/w32-proc.c
@@ -0,0 +1,907 @@
+/* Copyright (C) 2016 Free Software Foundation, Inc.
+ *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
+ *
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
+ */
+
+#include <c-strcase.h>
+
+# define WEXITSTATUS(stat_val) ((stat_val) & 255)
+/* MS-Windows programs that crash due to a fatal exception exit with
+   an exit code whose 2 MSB bits are set.  */
+# define WIFEXITED(stat_val)   (((stat_val) & 0xC0000000) == 0)
+# define WIFSIGNALED(stat_val) (((stat_val) & 0xC0000000) == 0xC0000000)
+# define WTERMSIG(stat_val)    w32_status_to_termsig (stat_val)
+/* The funny conditional avoids a compiler warning in status:stop_sig.  */
+# define WIFSTOPPED(stat_val)  ((stat_val) == (stat_val) ? 0 : 0)
+# define WSTOPSIG(stat_var)    (0)
+# include <process.h>
+# define HAVE_WAITPID 1
+  static int w32_status_to_termsig (DWORD);
+  static int w32_signal_to_status (int);
+# define getuid()              (500) /* Local Administrator */
+# define getgid()              (513) /* None */
+# define setuid(u)             (0)
+# define setgid(g)             (0)
+# define WIN32_LEAN_AND_MEAN
+# include <windows.h>
+# define WNOHANG               1
+  int waitpid (intptr_t, int *, int);
+
+  typedef DWORD_PTR cpu_set_t;
+
+#define CPU_ZERO(s)     memset(s,0,sizeof(*s))
+#define CPU_ISSET(b,s)  ((*s) & (1U << (b))) != 0
+#define CPU_SET(b,s)    (*s) |= (1U << (b))
+#define CPU_SETSIZE     (8*sizeof(DWORD_PTR))
+
+/* Run a child process with redirected standard handles, without
+   redirecting standard handles of the parent.  This is required in
+   multithreaded programs, where redirecting a standard handle affects
+   all threads.  */
+
+#include <stdlib.h>
+#include <string.h>
+
+/* Prepare a possibly redirected file handle to be passed to a child
+   process.  The handle is for the file/device open on file descriptor
+   FD; if FD is invalid, use the null device instead.
+
+   USE_STD non-zero means we have been passed the descriptor used by
+   the parent.
+
+   ACCESS is the Windows access mode for opening the null device.
+
+   Returns the Win32 handle to be passed to CreateProcess.  */
+static HANDLE
+prepare_child_handle (int fd, int use_std, DWORD access)
+{
+  HANDLE htem, hret;
+  DWORD err = 0;
+
+  /* Start with the descriptor, if specified by the caller and valid,
+     otherwise open the null device.  */
+  if (fd < 0)
+    htem = INVALID_HANDLE_VALUE;
+  else
+    htem = (HANDLE)_get_osfhandle (fd);
+
+  /* Duplicate the handle and make it inheritable.  */
+  if (DuplicateHandle (GetCurrentProcess (),
+		       htem,
+		       GetCurrentProcess (),
+		       &hret,
+		       0,
+		       TRUE,
+		       DUPLICATE_SAME_ACCESS) == FALSE)
+    {
+      /* If the original standard handle was invalid (happens, e.g.,
+	 in GUI programs), open the null device instead.  */
+      if ((err = GetLastError ()) == ERROR_INVALID_HANDLE
+	  && use_std)
+	{
+	  htem = CreateFile ("NUL", access,
+			     FILE_SHARE_READ | FILE_SHARE_WRITE, NULL,
+			     OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, NULL);
+	  if (htem != INVALID_HANDLE_VALUE
+	      && DuplicateHandle (GetCurrentProcess (),
+				  htem,
+				  GetCurrentProcess (),
+				  &hret,
+				  0,
+				  TRUE,
+				  DUPLICATE_SAME_ACCESS) == FALSE)
+	    {
+	      err = GetLastError ();
+	      CloseHandle (htem);
+	      hret = INVALID_HANDLE_VALUE;
+	    }
+	}
+    }
+
+  if (hret == INVALID_HANDLE_VALUE)
+    {
+      switch (err)
+	{
+	  case ERROR_NO_MORE_FILES:
+	    errno = EMFILE;
+	    break;
+	  case ERROR_INVALID_HANDLE:
+	  default:
+	    errno = EBADF;
+	    break;
+	}
+    }
+
+  return hret;
+}
+
+/* A comparison function for sorting the environment.  */
+static int
+compenv (const void *a1, const void *a2)
+{
+  return stricmp (*((char**)a1), *((char**)a2));
+}
+
+/* Convert the program's 'environ' array to a block of environment
+   variables suitable to be passed to CreateProcess.  This is needed
+   to ensure the child process inherits the up-to-date environment of
+   the parent, including any variables inserted by the parent.  */
+static void
+prepare_envblk (char **envp, char **envblk)
+{
+  char **tmp;
+  int size_needed;
+  int envcnt;
+  char *ptr;
+
+  for (envcnt = 0; envp[envcnt]; envcnt++)
+    ;
+
+  tmp = scm_calloc ((envcnt + 1) * sizeof (*tmp));
+
+  for (envcnt = size_needed = 0; envp[envcnt]; envcnt++)
+    {
+      tmp[envcnt] = envp[envcnt];
+      size_needed += strlen (envp[envcnt]) + 1;
+    }
+  size_needed++;
+
+  /* Windows likes its environment variables sorted.  */
+  qsort ((void *) tmp, (size_t) envcnt, sizeof (char *), compenv);
+
+  /* CreateProcess needs the environment block as a linear array,
+     where each variable is terminated by a null character, and the
+     last one is terminated by 2 null characters.  */
+  ptr = *envblk = scm_calloc (size_needed);
+
+  for (envcnt = 0; tmp[envcnt]; envcnt++)
+    {
+      strcpy (ptr, tmp[envcnt]);
+      ptr += strlen (tmp[envcnt]) + 1;
+    }
+
+  free (tmp);
+}
+
+/* Find an executable PROGRAM on PATH, return result in malloc'ed
+   storage.  If PROGRAM is /bin/sh, and no sh.exe was found on PATH,
+   fall back on the Windows shell and set BIN_SH_REPLACED to non-zero.  */
+static char *
+lookup_cmd (const char *program, int *bin_sh_replaced)
+{
+  static const char *extensions[] = {
+    ".exe", ".cmd", ".bat", "", ".com", NULL
+  };
+  int bin_sh_requested = 0;
+  char *path, *dir, *sep;
+  char abs_name[MAX_PATH];
+  DWORD abs_namelen = 0;
+
+  /* If they ask for the Unix system shell, try to find it on PATH.  */
+  if (c_strcasecmp (program, "/bin/sh") == 0)
+    {
+      bin_sh_requested = 1;
+      program = "sh.exe";
+    }
+
+  /* If PROGRAM includes leading directories, the caller already did
+     our job.  */
+  if (strchr (program, '/') != NULL
+      || strchr (program, '\\') != NULL)
+    return scm_strdup (program);
+
+  /* Note: It is OK for getenv below to return NULL -- in that case,
+     SearchPath will search in the directories whose list is specified
+     by the system Registry.  */
+  path = getenv ("PATH");
+  if (!path)	/* shouldn't happen, really */
+    path = ".";
+  dir = sep = path = strdup (path);
+  for ( ; sep && *sep; dir = sep + 1)
+    {
+      int i;
+
+      sep = strpbrk (dir, ";");
+      if (sep == dir)	/* two or more ;'s in a row */
+	continue;
+      if (sep)
+	*sep = '\0';
+      for (i = 0; extensions[i]; i++)
+	{
+	  abs_namelen = SearchPath (dir, program, extensions[i],
+				    MAX_PATH, abs_name, NULL);
+	  if (0 < abs_namelen && abs_namelen <= MAX_PATH)	/* found! */
+	    break;
+	}
+      if (extensions[i])	/* found! */
+	break;
+      if (sep)
+	*sep = ';';
+    }
+
+  free (path);
+
+  /* If they asked for /bin/sh and we didn't find it, fall back on the
+     default Windows shell.  */
+  if (abs_namelen <= 0 && bin_sh_requested)
+    {
+      const char *shell = getenv ("ComSpec");
+
+      if (!shell)
+	shell = "C:\\Windows\\system32\\cmd.exe";
+
+      *bin_sh_replaced = 1;
+      strcpy (abs_name, shell);
+      abs_namelen = strlen (abs_name);
+    }
+
+  /* If not found, return the original PROGRAM name.  */
+  if (abs_namelen <= 0 || abs_namelen > MAX_PATH)
+    return scm_strdup (program);
+
+  return scm_strndup (abs_name, abs_namelen);
+}
+
+/* Concatenate command-line arguments in argv[] into a single
+   command-line string, while quoting arguments as needed.  The result
+   is malloc'ed.  */
+static char *
+prepare_cmdline (const char *cmd, const char * const *argv, int bin_sh_replaced)
+{
+  /* These characters should include anything that is special to _any_
+     program, including both Windows and Unixy shells, and the
+     widlcard expansion in startup code of a typical Windows app.  */
+  const char need_quotes[] = " \t#;\"\'*?[]&|<>(){}$`^";
+  size_t cmdlen = 1;	/* for terminating null */
+  char *cmdline = scm_malloc (cmdlen);
+  char *dst = cmdline;
+  int cmd_exe_quoting = 0;
+  int i;
+  const char *p;
+
+  /* Are we constructing a command line for cmd.exe?  */
+  if (bin_sh_replaced)
+    cmd_exe_quoting = 1;
+  else
+    {
+      for (p = cmd + strlen (cmd);
+	   p > cmd && p[-1] != '/' && p[-1] != '\\' && p[-1] != ':';
+	   p--)
+	;
+      if (c_strcasecmp (p, "cmd.exe") == 0
+	  || c_strcasecmp (p, "cmd") == 0)
+	cmd_exe_quoting = 1;
+    }
+
+  /* Initialize the command line to empty.  */
+  *dst = '\0';
+
+  /* Append arguments, if any, from argv[]. */
+  for (i = 0; argv[i]; i++)
+    {
+      const char *src = argv[i];
+      size_t len;
+      int quote_this = 0, n_backslashes = 0;
+      int j;
+
+      /* Append the blank separator.  We don't do that for argv[0]
+	 because that is the command name (will end up in child's
+	 argv[0]), and is only recognized as such if there're no
+	 blanks before it.  */
+      if (i > 0)
+	*dst++ = ' ';
+      len = dst - cmdline;
+
+      /* How much space is required for this argument?  */
+      cmdlen += strlen (argv[i]) + 1; /* 1 for a blank separator */
+      /* cmd.exe needs a different style of quoting: all the arguments
+	 beyond the /c switch are enclosed in an extra pair of quotes,
+	 and not otherwise quoted/escaped. */
+      if (cmd_exe_quoting)
+	{
+	  if (i == 2)
+	    cmdlen += 2;
+	}
+      else if (strpbrk (argv[i], need_quotes))
+	{
+	  quote_this = 1;
+	  cmdlen += 2;
+	  for ( ; *src; src++)
+	    {
+	      /* An embedded quote needs to be escaped by a backslash.
+		 Any backslashes immediately preceding that quote need
+		 each one to be escaped by another backslash.  */
+	      if (*src == '\"')
+		cmdlen += n_backslashes + 1;
+	      if (*src == '\\')
+		n_backslashes++;
+	      else
+		n_backslashes = 0;
+	    }
+	  /* If the closing quote we will add is preceded by
+	     backslashes, those backslashes need to be escaped.  */
+	  cmdlen += n_backslashes;
+	}
+
+      /* Enlarge the command-line string as needed.  */
+      cmdline = scm_realloc (cmdline, cmdlen);
+      dst = cmdline + len;
+
+      if (i == 0
+	  && c_strcasecmp (argv[0], "/bin/sh") == 0
+	  && bin_sh_replaced)
+	{
+	  strcpy (dst, "cmd.exe");
+	  dst += sizeof ("cmd.exe") - 1;
+	  continue;
+	}
+      if (i == 1 && bin_sh_replaced && strcmp (argv[1], "-c") == 0)
+	{
+	  *dst++ = '/';
+	  *dst++ = 'c';
+	  *dst = '\0';
+	  continue;
+	}
+
+      /* Add this argument, possibly quoted, to the command line.  */
+      if (quote_this || (i == 2 && cmd_exe_quoting))
+	*dst++ = '\"';
+      for (src = argv[i]; *src; src++)
+	{
+	  if (quote_this)
+	    {
+	      if (*src == '\"')
+		for (j = n_backslashes + 1; j > 0; j--)
+		  *dst++ = '\\';
+	      if (*src == '\\')
+		n_backslashes++;
+	      else
+		n_backslashes = 0;
+	    }
+	  *dst++ = *src;
+	}
+      if (quote_this)
+	{
+	  for (j = n_backslashes; j > 0; j--)
+	    *dst++ = '\\';
+	  *dst++ = '\"';
+	}
+      *dst = '\0';
+    }
+
+  if (cmd_exe_quoting && i > 2)
+    {
+      /* One extra slot was already reserved when we enlarged cmdlen
+	 by 2 in the "if (cmd_exe_quoting)" clause above.  So we can
+	 safely append a closing quote.  */
+      *dst++ = '\"';
+      *dst = '\0';
+    }
+
+  return cmdline;
+}
+
+/* Start a child process running the program in EXEC_FILE with its
+   standard input and output optionally redirected to a pipe.  ARGV is
+   the array of command-line arguments to pass to the child.  P2C and
+   C2P are 2 pipes for communicating with the child, and ERRFD is the
+   standard error file descriptor to be inherited by the child.
+   READING and WRITING, if non-zero, mean that the corresponding pipe
+   will be used.
+
+   Return the PID of the child process, or -1 if couldn't start a
+   process.  */
+static intptr_t
+start_child (const char *exec_file, char **argv,
+	     int reading, int c2p[2], int writing, int p2c[2], int errfd)
+{
+  HANDLE hin = INVALID_HANDLE_VALUE, hout = INVALID_HANDLE_VALUE;
+  HANDLE herr = INVALID_HANDLE_VALUE;
+  STARTUPINFO si;
+  char *env_block = NULL;
+  char *cmdline = NULL;
+  PROCESS_INFORMATION pi;
+  char *progfile, *p;
+  int errno_save;
+  intptr_t pid;
+  int bin_sh_replaced = 0;
+
+  /* Prepare standard handles to be passed to the child process.  */
+  hin = prepare_child_handle (p2c[0], !writing, GENERIC_READ);
+  if (hin == INVALID_HANDLE_VALUE)
+    return -1;
+  hout = prepare_child_handle (c2p[1], !reading, GENERIC_WRITE);
+  if (hout == INVALID_HANDLE_VALUE)
+    return -1;
+  herr = prepare_child_handle (errfd, 1, GENERIC_WRITE);
+  if (herr == INVALID_HANDLE_VALUE)
+    return -1;
+
+  /* Make sure the parent side of both pipes is not inherited.  This
+     is required because gnulib's 'pipe' creates pipes whose both ends
+     are inheritable, which is traditional on Posix (where pipe
+     descriptors are implicitly duplicated by 'fork'), but wrong on
+     Windows (where pipe handles need to be explicitly
+     duplicated).  */
+  if (writing)
+    SetHandleInformation ((HANDLE)_get_osfhandle (p2c[1]),
+			  HANDLE_FLAG_INHERIT, 0);
+  if (reading)
+    {
+      SetHandleInformation ((HANDLE)_get_osfhandle (c2p[0]),
+			    HANDLE_FLAG_INHERIT, 0);
+      /* Gnulib's 'pipe' opens the pipe in binary mode, but we don't
+	 want to read text-mode input of subprocesses in binary more,
+	 because then we will get the ^M (a.k.a. "CR") characters we
+	 don't expect.  */
+      _setmode (c2p[0], _O_TEXT);
+    }
+
+  /* Set up the startup info for the child, using the parent's as the
+     starting point, and specify in it the redirected handles.  */
+  GetStartupInfo (&si);
+  si.dwFlags = STARTF_USESTDHANDLES;
+  si.lpReserved = 0;
+  si.cbReserved2 = 0;
+  si.lpReserved2 = 0;
+  si.hStdInput = hin;
+  si.hStdOutput = hout;
+  si.hStdError = herr;
+
+  /* Create the environment block for the child.  This is needed
+     because the environment we have in 'environ' is not in the format
+     expected by CreateProcess.  */
+  prepare_envblk (environ, &env_block);
+
+  /* CreateProcess doesn't search PATH, so we must do that for it.  */
+  progfile = lookup_cmd (exec_file, &bin_sh_replaced);
+
+  /* CreateProcess doesn't like forward slashes in the application
+     file name.  */
+  for (p = progfile; *p; p++)
+    if (*p == '/')
+      *p = '\\';
+
+  /* Construct the command line.  */
+  cmdline = prepare_cmdline (exec_file, (const char * const *)argv,
+			     bin_sh_replaced);
+
+  /* All set and ready to fly.  Launch the child process.  */
+  if (!CreateProcess (progfile, cmdline, NULL, NULL, TRUE, 0, env_block, NULL,
+		      &si, &pi))
+    {
+      pid = -1;
+
+      /* Since we use Win32 APIs directly, we need to translate their
+	 errors to errno values by hand.  */
+      switch (GetLastError ())
+	{
+	  case ERROR_FILE_NOT_FOUND:
+	  case ERROR_PATH_NOT_FOUND:
+	  case ERROR_INVALID_DRIVE:
+	  case ERROR_BAD_PATHNAME:
+	    errno = ENOENT;
+	    break;
+	  case ERROR_ACCESS_DENIED:
+	    errno = EACCES;
+	    break;
+	  case ERROR_BAD_ENVIRONMENT:
+	    errno = E2BIG;
+	    break;
+	  case ERROR_BROKEN_PIPE:
+	    errno = EPIPE;
+	    break;
+	  case ERROR_INVALID_HANDLE:
+	    errno = EBADF;
+	    break;
+	  case ERROR_MAX_THRDS_REACHED:
+	    errno = EAGAIN;
+	    break;
+	  case ERROR_BAD_EXE_FORMAT:
+	  case ERROR_BAD_FORMAT:
+	  default:
+	    errno = ENOEXEC;
+	    break;
+	}
+    }
+  else
+    pid = (intptr_t)pi.hProcess;
+
+  errno_save = errno;
+
+  /* Free resources.  */
+  free (progfile);
+  free (cmdline);
+  free (env_block);
+  CloseHandle (hin);
+  CloseHandle (hout);
+  CloseHandle (herr);
+  CloseHandle (pi.hThread);
+
+  /* Posix requires to call the shell if execvp fails to invoke EXEC_FILE.  */
+  if (errno_save == ENOEXEC || errno_save == ENOENT)
+    {
+      const char *shell = getenv ("ComSpec");
+
+      if (!shell)
+	shell = "cmd.exe";
+
+      if (c_strcasecmp (exec_file, shell) != 0)
+	{
+	  argv[0] = (char *)exec_file;
+	  return start_child (shell, argv, reading, c2p, writing, p2c, errfd);
+	}
+    }
+
+  errno = errno_save;
+  return pid;
+}
+
+\f
+/* Emulation of waitpid which only supports WNOHANG, since _cwait doesn't.  */
+int
+waitpid (intptr_t pid, int *status, int options)
+{
+  if ((options & WNOHANG) != 0)
+    {
+      DWORD st;
+
+      if (!GetExitCodeProcess ((HANDLE)pid, &st))
+	{
+	  errno = ECHILD;
+	  return -1;
+	}
+      if (st == STILL_ACTIVE)
+	return 0;
+      if (status)
+	*status = st;
+      return (int)pid;
+    }
+
+  return (int)_cwait (status, pid, WAIT_CHILD);
+}
+
+\f
+/* Translate abnormal exit status of Windows programs into the signal
+   that terminated the program.  This is required to support scm_kill
+   and WTERMSIG.  */
+
+struct signal_and_status {
+  int sig;
+  DWORD status;
+};
+
+static const struct signal_and_status sigtbl[] = {
+  {SIGSEGV, 0xC0000005},	/* access to invalid address */
+  {SIGSEGV, 0xC0000008},	/* invalid handle */
+  {SIGILL,  0xC000001D},	/* illegal instruction */
+  {SIGILL,  0xC0000025},	/* non-continuable instruction */
+  {SIGSEGV, 0xC000008C},	/* array bounds exceeded */
+  {SIGFPE,  0xC000008D},	/* float denormal */
+  {SIGFPE,  0xC000008E},	/* float divide by zero */
+  {SIGFPE,  0xC000008F},	/* float inexact */
+  {SIGFPE,  0xC0000090},	/* float invalid operation */
+  {SIGFPE,  0xC0000091},	/* float overflow */
+  {SIGFPE,  0xC0000092},	/* float stack check */
+  {SIGFPE,  0xC0000093},	/* float underflow */
+  {SIGFPE,  0xC0000094},	/* integer divide by zero */
+  {SIGFPE,  0xC0000095},	/* integer overflow */
+  {SIGILL,  0xC0000096},	/* privileged instruction */
+  {SIGSEGV, 0xC00000FD},	/* stack overflow */
+  {SIGTERM, 0xC000013A},	/* Ctrl-C exit */
+  {SIGINT,  0xC000013A}
+};
+
+static int
+w32_signal_to_status (int sig)
+{
+  int i;
+
+  for (i = 0; i < sizeof (sigtbl) / sizeof (sigtbl[0]); i++)
+    if (sig == sigtbl[i].sig)
+      return sigtbl[i].status;
+
+  return (int)0xC000013A;
+}
+
+static int
+w32_status_to_termsig (DWORD status)
+{
+  int i;
+
+  for (i = 0; i < sizeof (sigtbl) / sizeof (sigtbl[0]); i++)
+    if (status == sigtbl[i].status)
+      return sigtbl[i].sig;
+
+  return SIGTERM;
+}
+
+/* Support for scm_kill.  */
+static int
+w32_kill_proc (int pid, int sig)
+{
+  HANDLE ph = OpenProcess (PROCESS_TERMINATE, 0, pid);
+
+  if (!ph)
+    {
+      errno = EPERM;
+      return -1;
+    }
+  if (!TerminateProcess (ph, w32_signal_to_status (sig)))
+    {
+      errno = EINVAL;
+      return -1;
+    }
+  CloseHandle (ph);
+
+  return 0;
+}
+
+/* Emulation of getpriority and setpriority.  */
+
+#define PRIO_PROCESS 1
+#define PRIO_PGRP    2
+#define PRIO_USER    3
+#define NZERO        8
+
+static int
+getpriority (int which, int who)
+{
+  HANDLE hp;
+  int nice_value = -1;
+  int error = 0;
+
+  /* We don't support process groups and users.  */
+  if (which != PRIO_PROCESS)
+    {
+      errno = ENOSYS;
+      return -1;
+    }
+
+  if (who == 0)
+    hp = GetCurrentProcess ();
+  else
+    hp = OpenProcess (PROCESS_QUERY_INFORMATION, FALSE, who);
+
+  if (hp)
+    {
+      DWORD pri_class = GetPriorityClass (hp);
+
+      if (pri_class > 0)
+	{
+	  switch (pri_class)
+	    {
+	    case IDLE_PRIORITY_CLASS:
+	      nice_value = 4;
+	      break;
+	    case BELOW_NORMAL_PRIORITY_CLASS:
+	      nice_value = 6;
+	      break;
+	    case NORMAL_PRIORITY_CLASS:
+	      nice_value = 8;
+	      break;
+	    case ABOVE_NORMAL_PRIORITY_CLASS:
+	      nice_value = 10;
+	      break;
+	    case HIGH_PRIORITY_CLASS:
+	      nice_value = 13;
+	      break;
+	    case REALTIME_PRIORITY_CLASS:
+	      nice_value = 24;
+	      break;
+	    }
+	  /* If WHO is us, we can provide a more fine-grained value by
+	     looking at the current thread's priority value.  (For
+	     other processes, it is not clear which thread to use.)  */
+	  if (who == 0 || who == GetCurrentProcessId ())
+	    {
+	      HANDLE ht = GetCurrentThread ();
+	      int tprio = GetThreadPriority (ht);
+
+	      switch (tprio)
+		{
+		case THREAD_PRIORITY_IDLE:
+		  if (pri_class == REALTIME_PRIORITY_CLASS)
+		    nice_value = 16;
+		  else
+		    nice_value = 1;
+		  break;
+		case THREAD_PRIORITY_TIME_CRITICAL:
+		  if (pri_class == REALTIME_PRIORITY_CLASS)
+		    nice_value = 31;
+		  else
+		    nice_value = 15;
+		case THREAD_PRIORITY_ERROR_RETURN:
+		  nice_value = -1;
+		  error = 1;
+		  break;
+		default:
+		  nice_value += tprio;
+		  break;
+		}
+	    }
+	  /* Map to "nice values" similar to what one would see on
+	     Posix platforms.  */
+	  if (!error)
+	    nice_value = - (nice_value - NZERO);
+	}
+      else
+	error = 1;
+    }
+  else
+    error = 1;
+
+  if (error)
+    {
+      DWORD err = GetLastError ();
+
+      switch (err)
+	{
+	case ERROR_INVALID_PARAMETER:
+	case ERROR_INVALID_THREAD_ID:
+	  errno = ESRCH;
+	  break;
+	default:
+	  errno = EPERM;
+	  break;
+	}
+    }
+
+  return nice_value;
+}
+
+static int
+setpriority (int which, int who, int nice_val)
+{
+  HANDLE hp;
+  DWORD err;
+
+  if (which != PRIO_PROCESS)
+    {
+      errno = ENOSYS;
+      return -1;
+    }
+
+  if (who == 0)
+    hp = GetCurrentProcess ();
+  else
+    hp = OpenProcess (PROCESS_SET_INFORMATION, FALSE, who);
+
+  if (hp)
+    {
+      DWORD pri_class;
+
+      /* Map "nice values" back to process priority classes.  */
+      nice_val = -nice_val + NZERO;
+      if (nice_val < 6)
+	pri_class = IDLE_PRIORITY_CLASS;
+      else if (nice_val < 8)
+	pri_class = BELOW_NORMAL_PRIORITY_CLASS;
+      else if (nice_val < 10)
+	pri_class = NORMAL_PRIORITY_CLASS;
+      else if (nice_val < 13)
+	pri_class = ABOVE_NORMAL_PRIORITY_CLASS;
+      else if (nice_val < 16)
+	pri_class = HIGH_PRIORITY_CLASS;
+      else
+	pri_class = REALTIME_PRIORITY_CLASS;
+
+      if (SetPriorityClass (hp, pri_class))
+	return 0;
+    }
+
+  err = GetLastError ();
+
+  switch (err)
+    {
+    case ERROR_INVALID_PARAMETER:
+      errno = ESRCH;
+      break;
+    default:
+      errno = EPERM;
+      break;
+    }
+
+  return -1;
+}
+
+/* Emulation of sched_getaffinity and sched_setaffinity.  */
+static int
+sched_getaffinity (int pid, size_t mask_size, cpu_set_t *mask)
+{
+  HANDLE hp;
+  DWORD err;
+
+  if (mask == NULL)
+    {
+      errno = EFAULT;
+      return -1;
+    }
+
+  if (pid == 0)
+    hp = GetCurrentProcess ();
+  else
+    hp = OpenProcess (PROCESS_QUERY_INFORMATION, FALSE, pid);
+
+  if (hp)
+    {
+      DWORD_PTR ignored;
+      BOOL result = GetProcessAffinityMask (hp, (DWORD_PTR *)mask, &ignored);
+
+      if (pid != 0)
+	CloseHandle (hp);
+      if (result)
+	return 0;
+    }
+
+  err = GetLastError ();
+
+  switch (err)
+    {
+    case ERROR_INVALID_PARAMETER:
+      errno = ESRCH;
+      break;
+    case ERROR_ACCESS_DENIED:
+    default:
+      errno = EPERM;
+      break;
+    }
+
+  return -1;
+}
+
+static int
+sched_setaffinity (int pid, size_t mask_size, cpu_set_t *mask)
+{
+  HANDLE hp;
+  DWORD err;
+
+  if (mask == NULL)
+    {
+      errno = EFAULT;
+      return -1;
+    }
+
+  if (pid == 0)
+    hp = GetCurrentProcess ();
+  else
+    hp = OpenProcess (PROCESS_SET_INFORMATION, FALSE, pid);
+
+  if (hp)
+    {
+      BOOL result = SetProcessAffinityMask (hp, *(DWORD_PTR *)mask);
+
+      if (pid != 0)
+	CloseHandle (hp);
+      if (result)
+	return 0;
+    }
+
+  err = GetLastError ();
+
+  switch (err)
+    {
+    case ERROR_INVALID_PARAMETER:
+      errno = ESRCH;
+      break;
+    case ERROR_ACCESS_DENIED:
+    default:
+      errno = EPERM;
+      break;
+    }
+
+  return -1;
+}

Re: Support open-process and friends on MS-Windows

[Andy Wingo]

On Sat 25 Jun 2016 11:11, Eli Zaretskii <eliz@gnu.org> writes:

> Here's the modified patch with the couple of changes requested in
> response to the previous version:

Great!  I have two nits.  One, if it is possible for you, please attach
the patch in the format that "git format-patch" makes.  That makes it
easy to apply, otherwise I have to futz around with --author and I could
accidentally fat-finger it and get it wrong.

Secondly, please make w32-proc override the definitions of
HAVE_GETPRIORITY, HAVE_SETPRIORITY, HAVE_SCHED_GETAFFINITY, and
HAVE_SCHED_SETAFFINITY.  That way you won't need this kind of change
either:

> -#if HAVE_GETPRIORITY
> +#if HAVE_GETPRIORITY || defined __MINGW32__

If you've already discussed this with Ludovic and decided to go this way
explicitly, please disregard this second nit.

I will also wait a day or two for any comments from Ludovic before
applying.

Thanks again, great stuff!

Andy

Re: Support open-process and friends on MS-Windows

[Eli Zaretskii]

> From: Andy Wingo <wingo@pobox.com>
> Cc: ludo@gnu.org,  guile-devel@gnu.org
> Date: Sat, 25 Jun 2016 11:51:53 +0200
> 
> On Sat 25 Jun 2016 11:11, Eli Zaretskii <eliz@gnu.org> writes:
> 
> > Here's the modified patch with the couple of changes requested in
> > response to the previous version:
> 
> Great!  I have two nits.  One, if it is possible for you, please attach
> the patch in the format that "git format-patch" makes.  That makes it
> easy to apply, otherwise I have to futz around with --author and I could
> accidentally fat-finger it and get it wrong.
> 
> Secondly, please make w32-proc override the definitions of
> HAVE_GETPRIORITY, HAVE_SETPRIORITY, HAVE_SCHED_GETAFFINITY, and
> HAVE_SCHED_SETAFFINITY.  That way you won't need this kind of change
> either:
> 
> > -#if HAVE_GETPRIORITY
> > +#if HAVE_GETPRIORITY || defined __MINGW32__
> 
> If you've already discussed this with Ludovic and decided to go this way
> explicitly, please disregard this second nit.
> 
> I will also wait a day or two for any comments from Ludovic before
> applying.

Thanks, I will wait for Ludovic to tell he's okay with overriding the
HAVE_* macros, and will send a format-patch formatted changes after
that.

Re: Support open-process and friends on MS-Windows

[Ludovic Courtès]

Eli Zaretskii <eliz@gnu.org> skribis:

>> From: Andy Wingo <wingo@pobox.com>
>> Cc: ludo@gnu.org,  guile-devel@gnu.org
>> Date: Sat, 25 Jun 2016 11:51:53 +0200
>> 
>> On Sat 25 Jun 2016 11:11, Eli Zaretskii <eliz@gnu.org> writes:
>> 
>> > Here's the modified patch with the couple of changes requested in
>> > response to the previous version:
>> 
>> Great!  I have two nits.  One, if it is possible for you, please attach
>> the patch in the format that "git format-patch" makes.  That makes it
>> easy to apply, otherwise I have to futz around with --author and I could
>> accidentally fat-finger it and get it wrong.
>> 
>> Secondly, please make w32-proc override the definitions of
>> HAVE_GETPRIORITY, HAVE_SETPRIORITY, HAVE_SCHED_GETAFFINITY, and
>> HAVE_SCHED_SETAFFINITY.  That way you won't need this kind of change
>> either:
>> 
>> > -#if HAVE_GETPRIORITY
>> > +#if HAVE_GETPRIORITY || defined __MINGW32__
>> 
>> If you've already discussed this with Ludovic and decided to go this way
>> explicitly, please disregard this second nit.
>> 
>> I will also wait a day or two for any comments from Ludovic before
>> applying.
>
> Thanks, I will wait for Ludovic to tell he's okay with overriding the
> HAVE_* macros,

Yes, I agree with Andy, I think it’ll be nicer.

> and will send a format-patch formatted changes after that.

Cool, thank you!

Ludo’.

Re: Support open-process and friends on MS-Windows

[Eli Zaretskii]

[-- Attachment #1: Type: text/plain, Size: 1274 bytes --]

> From: ludo@gnu.org (Ludovic Courtès)
> Cc: Andy Wingo <wingo@pobox.com>,  guile-devel@gnu.org
> Date: Sat, 25 Jun 2016 15:02:42 +0200
> 
> >> Great!  I have two nits.  One, if it is possible for you, please attach
> >> the patch in the format that "git format-patch" makes.  That makes it
> >> easy to apply, otherwise I have to futz around with --author and I could
> >> accidentally fat-finger it and get it wrong.
> >> 
> >> Secondly, please make w32-proc override the definitions of
> >> HAVE_GETPRIORITY, HAVE_SETPRIORITY, HAVE_SCHED_GETAFFINITY, and
> >> HAVE_SCHED_SETAFFINITY.  That way you won't need this kind of change
> >> either:
> >> 
> >> > -#if HAVE_GETPRIORITY
> >> > +#if HAVE_GETPRIORITY || defined __MINGW32__
> >> 
> >> If you've already discussed this with Ludovic and decided to go this way
> >> explicitly, please disregard this second nit.
> >> 
> >> I will also wait a day or two for any comments from Ludovic before
> >> applying.
> >
> > Thanks, I will wait for Ludovic to tell he's okay with overriding the
> > HAVE_* macros,
> 
> Yes, I agree with Andy, I think it’ll be nicer.
> 
> > and will send a format-patch formatted changes after that.
> 
> Cool, thank you!

Thanks, updated patch attached below.


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: 0001-Provide-support-for-open-process-and-related-functio.patch --]
[-- Type: text/x-patch, Size: 34230 bytes --]

From a02b0c9a95ce286669b2f7b76beba9709e8d9601 Mon Sep 17 00:00:00 2001
From: Eli Zaretskii <eliz@gnu.org>
Date: Sat, 25 Jun 2016 16:14:21 +0300
Subject: [PATCH] Provide support for open-process and related functions on
 MS-Windows

* libguile/w32-proc.c: New file, with MinGW support code for
scm_open_process, scm_kill, scm_getpriority, scm_setpriority,
scm_getaffinity, and scm_setaffinity.  Also, provides macros that
on Posix hosts are in sys/wait.h, like WIFEXITED and WTERMSIG, and
simple definitions for getuid, getgid, setuid, setgid, and
waitpid.

* libguile/posix.c [__MINGW32__]: Include w32-proc.c.
(scm_kill) [__MINGW32__]: Support killing subprocesses on MS-Windows.
(scm_status_exit_val, scm_getuid, scm_getegid): Don't exclude from
compilation with MinGW.
(scm_execl, scm_execle): Cast arguments of execv/execve to avoid
compiler warnings.
(scm_open_process): Condition parts specific to 'fork'-based
implementation with "#ifdef HAVE_FORK".
[__MINGW32__]: MinGW alternative to 'fork'-based implementation;
most of the supporting code is in w32-proc.c.
(scm_getpriority, scm_setpriority, scm_getaffinity)
(scm_setaffinity, scm_init_popen): Don't exclude from MinGW
compilation.
(scm_init_posix): Register scm_init_popen extension even if
HAVE_FORK is not defined.
---
 libguile/posix.c    |  75 +++--
 libguile/w32-proc.c | 919 ++++++++++++++++++++++++++++++++++++++++++++++++++++
 2 files changed, 968 insertions(+), 26 deletions(-)
 create mode 100644 libguile/w32-proc.c

diff --git a/libguile/posix.c b/libguile/posix.c
index 2654716..741867c 100644
--- a/libguile/posix.c
+++ b/libguile/posix.c
@@ -84,6 +84,10 @@
 #if HAVE_SYS_WAIT_H
 # include <sys/wait.h>
 #endif
+#ifdef __MINGW32__
+# include <w32-proc.c>
+#endif	/* __MINGW32__ */
+
 #ifndef WEXITSTATUS
 # define WEXITSTATUS(stat_val) ((unsigned)(stat_val) >> 8)
 #endif
@@ -659,7 +663,7 @@ SCM_DEFINE (scm_kill, "kill", 2, 0, 0,
 #else
   /* Mingw has raise(), but not kill().  (Other raw DOS environments might
      be similar.)  Use raise() when the requested pid is our own process,
-     otherwise bomb.  */
+     otherwise TerminateProcess.  */
   if (scm_to_int (pid) == getpid ())
     {
       if (raise (scm_to_int (sig)) != 0)
@@ -673,6 +677,10 @@ SCM_DEFINE (scm_kill, "kill", 2, 0, 0,
           goto err;
         }
     }
+#ifdef __MINGW32__
+  if (w32_kill_proc (scm_to_int (pid), scm_to_int (sig)) != 0)
+    SCM_SYSERROR;
+#endif	/* __MINGW32__ */
 #endif
   return SCM_UNSPECIFIED;
 }
@@ -735,7 +743,6 @@ SCM_DEFINE (scm_waitpid, "waitpid", 1, 1, 0,
 #undef FUNC_NAME
 #endif /* HAVE_WAITPID */
 
-#ifndef __MINGW32__
 SCM_DEFINE (scm_status_exit_val, "status:exit-val", 1, 0, 0, 
             (SCM status),
 	    "Return the exit status value, as would be set if a process\n"
@@ -786,7 +793,6 @@ SCM_DEFINE (scm_status_stop_sig, "status:stop-sig", 1, 0, 0,
     return SCM_BOOL_F;
 }
 #undef FUNC_NAME
-#endif /* __MINGW32__ */
 
 #ifdef HAVE_GETPPID
 SCM_DEFINE (scm_getppid, "getppid", 0, 0, 0,
@@ -801,7 +807,6 @@ SCM_DEFINE (scm_getppid, "getppid", 0, 0, 0,
 #endif /* HAVE_GETPPID */
 
 
-#ifndef __MINGW32__
 SCM_DEFINE (scm_getuid, "getuid", 0, 0, 0,
             (),
 	    "Return an integer representing the current real user ID.")
@@ -905,10 +910,8 @@ SCM_DEFINE (scm_seteuid, "seteuid", 1, 0, 0,
   return SCM_UNSPECIFIED;
 }
 #undef FUNC_NAME
-#endif /* __MINGW32__ */
 
 
-#ifdef HAVE_SETEGID
 SCM_DEFINE (scm_setegid, "setegid", 1, 0, 0,
             (SCM id),
 	    "Sets the effective group ID to the integer @var{id}, provided the process\n"
@@ -931,7 +934,6 @@ SCM_DEFINE (scm_setegid, "setegid", 1, 0, 0,
     
 }
 #undef FUNC_NAME
-#endif
 
 
 #ifdef HAVE_GETPGRP
@@ -1141,7 +1143,7 @@ SCM_DEFINE (scm_execl, "execl", 1, 0, 1,
 
   exec_argv = scm_i_allocate_string_pointers (args);
 
-  execv (exec_file, exec_argv);
+  execv (exec_file, (char const * const *)exec_argv);
   SCM_SYSERROR;
 
   /* not reached.  */
@@ -1170,7 +1172,7 @@ SCM_DEFINE (scm_execlp, "execlp", 1, 0, 1,
 
   exec_argv = scm_i_allocate_string_pointers (args);
 
-  execvp (exec_file, exec_argv);
+  execvp (exec_file, (char const * const *)exec_argv);
   SCM_SYSERROR;
 
   /* not reached.  */
@@ -1204,7 +1206,8 @@ SCM_DEFINE (scm_execle, "execle", 2, 0, 1,
   exec_argv = scm_i_allocate_string_pointers (args);
   exec_env = scm_i_allocate_string_pointers (env);
 
-  execve (exec_file, exec_argv, exec_env);
+  execve (exec_file, (char const * const *)exec_argv,
+	  (char const * const *)exec_env);
   SCM_SYSERROR;
 
   /* not reached.  */
@@ -1246,6 +1249,7 @@ SCM_DEFINE (scm_fork, "primitive-fork", 0, 0, 0,
   return scm_from_int (pid);
 }
 #undef FUNC_NAME
+#endif /* HAVE_FORK */
 
 /* Since Guile uses threads, we have to be very careful to avoid calling
    functions that are not async-signal-safe in the child.  That's why
@@ -1262,7 +1266,9 @@ scm_open_process (SCM mode, SCM prog, SCM args)
   int pid;
   char *exec_file;
   char **exec_argv;
+#ifdef HAVE_FORK
   int max_fd = 1024;
+#endif
 
   exec_file = scm_to_locale_string (prog);
   exec_argv = scm_i_allocate_string_pointers (scm_cons (prog, args));
@@ -1319,12 +1325,28 @@ scm_open_process (SCM mode, SCM prog, SCM args)
   }
 #endif
 
+#ifdef HAVE_FORK
   pid = fork ();
+#elif defined(__MINGW32__)
+  if (!reading)
+    c2p[1] = out;
+  if (!writing)
+    p2c[0] = in;
+  pid = start_child (exec_file, exec_argv, reading, c2p, writing, p2c, err);
+#else
+  close (c2p[0]);
+  close (c2p[1]);
+  close (p2c[0]);
+  close (p2c[1]);
+  free (exec_file);
+  errno = ENOSYS;
+  SCM_SYSERROR;
+#endif	/* HAVE_FORK */
 
   if (pid == -1)
     {
       int errno_save = errno;
-      free (exec_file);
+
       if (reading)
         {
           close (c2p[0]);
@@ -1336,6 +1358,8 @@ scm_open_process (SCM mode, SCM prog, SCM args)
           close (p2c[1]);
         }
       errno = errno_save;
+
+      free (exec_file);
       SCM_SYSERROR;
     }
 
@@ -1360,6 +1384,7 @@ scm_open_process (SCM mode, SCM prog, SCM args)
         (scm_list_3 (read_port, write_port, scm_from_int (pid)));
     }
 
+#ifdef HAVE_FORK
   /* The child.  */
   if (reading)
     close (c2p[0]);
@@ -1408,16 +1433,16 @@ scm_open_process (SCM mode, SCM prog, SCM args)
   if (err > 0)
     {
       char *msg = strerror (errno);
-      fprintf (fdopen (err, "a"), "In execlp of %s: %s\n",
+      fprintf (fdopen (err, "a"), "In execvp of %s: %s\n",
                exec_file, msg);
     }
 
   _exit (EXIT_FAILURE);
+#endif	/* HAVE_FORK */
   /* Not reached.  */
   return SCM_BOOL_F;
 }
 #undef FUNC_NAME
-#endif /* HAVE_FORK */
 
 #ifdef __MINGW32__
 # include "win32-uname.h"
@@ -1909,7 +1934,7 @@ SCM_DEFINE (scm_getlogin, "getlogin", 0, 0, 0,
 }
 #undef FUNC_NAME
 
-#if HAVE_GETPRIORITY
+#if HAVE_GETPRIORITY || defined __MINGW32__
 SCM_DEFINE (scm_getpriority, "getpriority", 2, 0, 0, 
             (SCM which, SCM who),
 	    "Return the scheduling priority of the process, process group\n"
@@ -1938,9 +1963,9 @@ SCM_DEFINE (scm_getpriority, "getpriority", 2, 0, 0,
   return scm_from_int (ret);
 }
 #undef FUNC_NAME
-#endif /* HAVE_GETPRIORITY */
+#endif /* HAVE_GETPRIORITY || __MINGW32__ */
 
-#if HAVE_SETPRIORITY
+#if HAVE_SETPRIORITY || defined __MINGW32__
 SCM_DEFINE (scm_setpriority, "setpriority", 3, 0, 0, 
             (SCM which, SCM who, SCM prio),
 	    "Set the scheduling priority of the process, process group\n"
@@ -1969,9 +1994,9 @@ SCM_DEFINE (scm_setpriority, "setpriority", 3, 0, 0,
   return SCM_UNSPECIFIED;
 }
 #undef FUNC_NAME
-#endif /* HAVE_SETPRIORITY */
+#endif /* HAVE_SETPRIORITY || __MINGW32__ */
 
-#ifdef HAVE_SCHED_GETAFFINITY
+#if defined HAVE_SCHED_GETAFFINITY || defined __MINGW32__
 
 static SCM
 cpu_set_to_bitvector (const cpu_set_t *cs)
@@ -2000,7 +2025,7 @@ SCM_DEFINE (scm_getaffinity, "getaffinity", 1, 0, 0,
 	    "Guile can use without stepping on other processes' toes.\n\n"
 	    "Currently this procedure is only defined on GNU variants\n"
 	    "(@pxref{CPU Affinity, @code{sched_getaffinity},, libc, The\n"
-	    "GNU C Library Reference Manual}).\n")
+	    "GNU C Library Reference Manual}) and on MS-Windows.\n")
 #define FUNC_NAME s_scm_getaffinity
 {
   int err;
@@ -2015,9 +2040,9 @@ SCM_DEFINE (scm_getaffinity, "getaffinity", 1, 0, 0,
 }
 #undef FUNC_NAME
 
-#endif /* HAVE_SCHED_GETAFFINITY */
+#endif /* HAVE_SCHED_GETAFFINITY || __MINGW32__ */
 
-#ifdef HAVE_SCHED_SETAFFINITY
+#if defined HAVE_SCHED_SETAFFINITY || defined __MINGW32__
 
 SCM_DEFINE (scm_setaffinity, "setaffinity", 2, 0, 0,
 	    (SCM pid, SCM mask),
@@ -2026,7 +2051,7 @@ SCM_DEFINE (scm_setaffinity, "setaffinity", 2, 0, 0,
 	    "is unspecified.\n\n"
 	    "Currently this procedure is only defined on GNU variants\n"
 	    "(@pxref{CPU Affinity, @code{sched_setaffinity},, libc, The\n"
-	    "GNU C Library Reference Manual}).\n")
+	    "GNU C Library Reference Manual}) and on MS-Windows.\n")
 #define FUNC_NAME s_scm_setaffinity
 {
   cpu_set_t cs;
@@ -2056,7 +2081,7 @@ SCM_DEFINE (scm_setaffinity, "setaffinity", 2, 0, 0,
 }
 #undef FUNC_NAME
 
-#endif /* HAVE_SCHED_SETAFFINITY */
+#endif /* HAVE_SCHED_SETAFFINITY || __MINGW32__ */
 
 \f
 #if HAVE_GETPASS
@@ -2235,13 +2260,11 @@ SCM_DEFINE (scm_gethostname, "gethostname", 0, 0, 0,
 #endif /* HAVE_GETHOSTNAME */
 
 \f
-#ifdef HAVE_FORK
 static void
 scm_init_popen (void)
 {
   scm_c_define_gsubr ("open-process", 2, 0, 1, scm_open_process);
 }
-#endif
 
 void
 scm_init_posix ()
@@ -2340,11 +2363,11 @@ scm_init_posix ()
 
 #ifdef HAVE_FORK
   scm_add_feature ("fork");
+#endif	/* HAVE_FORK */
   scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION,
                             "scm_init_popen",
 			    (scm_t_extension_init_func) scm_init_popen,
 			    NULL);
-#endif	/* HAVE_FORK */
 }
 
 /*
diff --git a/libguile/w32-proc.c b/libguile/w32-proc.c
new file mode 100644
index 0000000..2026f15
--- /dev/null
+++ b/libguile/w32-proc.c
@@ -0,0 +1,919 @@
+/* Copyright (C) 2016 Free Software Foundation, Inc.
+ *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
+ *
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
+ */
+
+#include <c-strcase.h>
+
+# define WEXITSTATUS(stat_val) ((stat_val) & 255)
+/* MS-Windows programs that crash due to a fatal exception exit with
+   an exit code whose 2 MSB bits are set.  */
+# define WIFEXITED(stat_val)   (((stat_val) & 0xC0000000) == 0)
+# define WIFSIGNALED(stat_val) (((stat_val) & 0xC0000000) == 0xC0000000)
+# define WTERMSIG(stat_val)    w32_status_to_termsig (stat_val)
+/* The funny conditional avoids a compiler warning in status:stop_sig.  */
+# define WIFSTOPPED(stat_val)  ((stat_val) == (stat_val) ? 0 : 0)
+# define WSTOPSIG(stat_var)    (0)
+# include <process.h>
+# define HAVE_WAITPID 1
+  static int w32_status_to_termsig (DWORD);
+  static int w32_signal_to_status (int);
+# define getuid()              (500) /* Local Administrator */
+# define getgid()              (513) /* None */
+# define setuid(u)             (0)
+# define setgid(g)             (0)
+# define WIN32_LEAN_AND_MEAN
+# include <windows.h>
+# define WNOHANG               1
+  int waitpid (intptr_t, int *, int);
+
+  typedef DWORD_PTR cpu_set_t;
+
+#define CPU_ZERO(s)     memset(s,0,sizeof(*s))
+#define CPU_ISSET(b,s)  ((*s) & (1U << (b))) != 0
+#define CPU_SET(b,s)    (*s) |= (1U << (b))
+#define CPU_SETSIZE     (8*sizeof(DWORD_PTR))
+
+/* Run a child process with redirected standard handles, without
+   redirecting standard handles of the parent.  This is required in
+   multithreaded programs, where redirecting a standard handle affects
+   all threads.  */
+
+#include <stdlib.h>
+#include <string.h>
+
+/* Prepare a possibly redirected file handle to be passed to a child
+   process.  The handle is for the file/device open on file descriptor
+   FD; if FD is invalid, use the null device instead.
+
+   USE_STD non-zero means we have been passed the descriptor used by
+   the parent.
+
+   ACCESS is the Windows access mode for opening the null device.
+
+   Returns the Win32 handle to be passed to CreateProcess.  */
+static HANDLE
+prepare_child_handle (int fd, int use_std, DWORD access)
+{
+  HANDLE htem, hret;
+  DWORD err = 0;
+
+  /* Start with the descriptor, if specified by the caller and valid,
+     otherwise open the null device.  */
+  if (fd < 0)
+    htem = INVALID_HANDLE_VALUE;
+  else
+    htem = (HANDLE)_get_osfhandle (fd);
+
+  /* Duplicate the handle and make it inheritable.  */
+  if (DuplicateHandle (GetCurrentProcess (),
+		       htem,
+		       GetCurrentProcess (),
+		       &hret,
+		       0,
+		       TRUE,
+		       DUPLICATE_SAME_ACCESS) == FALSE)
+    {
+      /* If the original standard handle was invalid (happens, e.g.,
+	 in GUI programs), open the null device instead.  */
+      if ((err = GetLastError ()) == ERROR_INVALID_HANDLE
+	  && use_std)
+	{
+	  htem = CreateFile ("NUL", access,
+			     FILE_SHARE_READ | FILE_SHARE_WRITE, NULL,
+			     OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, NULL);
+	  if (htem != INVALID_HANDLE_VALUE
+	      && DuplicateHandle (GetCurrentProcess (),
+				  htem,
+				  GetCurrentProcess (),
+				  &hret,
+				  0,
+				  TRUE,
+				  DUPLICATE_SAME_ACCESS) == FALSE)
+	    {
+	      err = GetLastError ();
+	      CloseHandle (htem);
+	      hret = INVALID_HANDLE_VALUE;
+	    }
+	}
+    }
+
+  if (hret == INVALID_HANDLE_VALUE)
+    {
+      switch (err)
+	{
+	  case ERROR_NO_MORE_FILES:
+	    errno = EMFILE;
+	    break;
+	  case ERROR_INVALID_HANDLE:
+	  default:
+	    errno = EBADF;
+	    break;
+	}
+    }
+
+  return hret;
+}
+
+/* A comparison function for sorting the environment.  */
+static int
+compenv (const void *a1, const void *a2)
+{
+  return stricmp (*((char**)a1), *((char**)a2));
+}
+
+/* Convert the program's 'environ' array to a block of environment
+   variables suitable to be passed to CreateProcess.  This is needed
+   to ensure the child process inherits the up-to-date environment of
+   the parent, including any variables inserted by the parent.  */
+static void
+prepare_envblk (char **envp, char **envblk)
+{
+  char **tmp;
+  int size_needed;
+  int envcnt;
+  char *ptr;
+
+  for (envcnt = 0; envp[envcnt]; envcnt++)
+    ;
+
+  tmp = scm_calloc ((envcnt + 1) * sizeof (*tmp));
+
+  for (envcnt = size_needed = 0; envp[envcnt]; envcnt++)
+    {
+      tmp[envcnt] = envp[envcnt];
+      size_needed += strlen (envp[envcnt]) + 1;
+    }
+  size_needed++;
+
+  /* Windows likes its environment variables sorted.  */
+  qsort ((void *) tmp, (size_t) envcnt, sizeof (char *), compenv);
+
+  /* CreateProcess needs the environment block as a linear array,
+     where each variable is terminated by a null character, and the
+     last one is terminated by 2 null characters.  */
+  ptr = *envblk = scm_calloc (size_needed);
+
+  for (envcnt = 0; tmp[envcnt]; envcnt++)
+    {
+      strcpy (ptr, tmp[envcnt]);
+      ptr += strlen (tmp[envcnt]) + 1;
+    }
+
+  free (tmp);
+}
+
+/* Find an executable PROGRAM on PATH, return result in malloc'ed
+   storage.  If PROGRAM is /bin/sh, and no sh.exe was found on PATH,
+   fall back on the Windows shell and set BIN_SH_REPLACED to non-zero.  */
+static char *
+lookup_cmd (const char *program, int *bin_sh_replaced)
+{
+  static const char *extensions[] = {
+    ".exe", ".cmd", ".bat", "", ".com", NULL
+  };
+  int bin_sh_requested = 0;
+  char *path, *dir, *sep;
+  char abs_name[MAX_PATH];
+  DWORD abs_namelen = 0;
+
+  /* If they ask for the Unix system shell, try to find it on PATH.  */
+  if (c_strcasecmp (program, "/bin/sh") == 0)
+    {
+      bin_sh_requested = 1;
+      program = "sh.exe";
+    }
+
+  /* If PROGRAM includes leading directories, the caller already did
+     our job.  */
+  if (strchr (program, '/') != NULL
+      || strchr (program, '\\') != NULL)
+    return scm_strdup (program);
+
+  /* Note: It is OK for getenv below to return NULL -- in that case,
+     SearchPath will search in the directories whose list is specified
+     by the system Registry.  */
+  path = getenv ("PATH");
+  if (!path)	/* shouldn't happen, really */
+    path = ".";
+  dir = sep = path = strdup (path);
+  for ( ; sep && *sep; dir = sep + 1)
+    {
+      int i;
+
+      sep = strpbrk (dir, ";");
+      if (sep == dir)	/* two or more ;'s in a row */
+	continue;
+      if (sep)
+	*sep = '\0';
+      for (i = 0; extensions[i]; i++)
+	{
+	  abs_namelen = SearchPath (dir, program, extensions[i],
+				    MAX_PATH, abs_name, NULL);
+	  if (0 < abs_namelen && abs_namelen <= MAX_PATH)	/* found! */
+	    break;
+	}
+      if (extensions[i])	/* found! */
+	break;
+      if (sep)
+	*sep = ';';
+    }
+
+  free (path);
+
+  /* If they asked for /bin/sh and we didn't find it, fall back on the
+     default Windows shell.  */
+  if (abs_namelen <= 0 && bin_sh_requested)
+    {
+      const char *shell = getenv ("ComSpec");
+
+      if (!shell)
+	shell = "C:\\Windows\\system32\\cmd.exe";
+
+      *bin_sh_replaced = 1;
+      strcpy (abs_name, shell);
+      abs_namelen = strlen (abs_name);
+    }
+
+  /* If not found, return the original PROGRAM name.  */
+  if (abs_namelen <= 0 || abs_namelen > MAX_PATH)
+    return scm_strdup (program);
+
+  return scm_strndup (abs_name, abs_namelen);
+}
+
+/* Concatenate command-line arguments in argv[] into a single
+   command-line string, while quoting arguments as needed.  The result
+   is malloc'ed.  */
+static char *
+prepare_cmdline (const char *cmd, const char * const *argv, int bin_sh_replaced)
+{
+  /* These characters should include anything that is special to _any_
+     program, including both Windows and Unixy shells, and the
+     widlcard expansion in startup code of a typical Windows app.  */
+  const char need_quotes[] = " \t#;\"\'*?[]&|<>(){}$`^";
+  size_t cmdlen = 1;	/* for terminating null */
+  char *cmdline = scm_malloc (cmdlen);
+  char *dst = cmdline;
+  int cmd_exe_quoting = 0;
+  int i;
+  const char *p;
+
+  /* Are we constructing a command line for cmd.exe?  */
+  if (bin_sh_replaced)
+    cmd_exe_quoting = 1;
+  else
+    {
+      for (p = cmd + strlen (cmd);
+	   p > cmd && p[-1] != '/' && p[-1] != '\\' && p[-1] != ':';
+	   p--)
+	;
+      if (c_strcasecmp (p, "cmd.exe") == 0
+	  || c_strcasecmp (p, "cmd") == 0)
+	cmd_exe_quoting = 1;
+    }
+
+  /* Initialize the command line to empty.  */
+  *dst = '\0';
+
+  /* Append arguments, if any, from argv[]. */
+  for (i = 0; argv[i]; i++)
+    {
+      const char *src = argv[i];
+      size_t len;
+      int quote_this = 0, n_backslashes = 0;
+      int j;
+
+      /* Append the blank separator.  We don't do that for argv[0]
+	 because that is the command name (will end up in child's
+	 argv[0]), and is only recognized as such if there're no
+	 blanks before it.  */
+      if (i > 0)
+	*dst++ = ' ';
+      len = dst - cmdline;
+
+      /* How much space is required for this argument?  */
+      cmdlen += strlen (argv[i]) + 1; /* 1 for a blank separator */
+      /* cmd.exe needs a different style of quoting: all the arguments
+	 beyond the /c switch are enclosed in an extra pair of quotes,
+	 and not otherwise quoted/escaped. */
+      if (cmd_exe_quoting)
+	{
+	  if (i == 2)
+	    cmdlen += 2;
+	}
+      else if (strpbrk (argv[i], need_quotes))
+	{
+	  quote_this = 1;
+	  cmdlen += 2;
+	  for ( ; *src; src++)
+	    {
+	      /* An embedded quote needs to be escaped by a backslash.
+		 Any backslashes immediately preceding that quote need
+		 each one to be escaped by another backslash.  */
+	      if (*src == '\"')
+		cmdlen += n_backslashes + 1;
+	      if (*src == '\\')
+		n_backslashes++;
+	      else
+		n_backslashes = 0;
+	    }
+	  /* If the closing quote we will add is preceded by
+	     backslashes, those backslashes need to be escaped.  */
+	  cmdlen += n_backslashes;
+	}
+
+      /* Enlarge the command-line string as needed.  */
+      cmdline = scm_realloc (cmdline, cmdlen);
+      dst = cmdline + len;
+
+      if (i == 0
+	  && c_strcasecmp (argv[0], "/bin/sh") == 0
+	  && bin_sh_replaced)
+	{
+	  strcpy (dst, "cmd.exe");
+	  dst += sizeof ("cmd.exe") - 1;
+	  continue;
+	}
+      if (i == 1 && bin_sh_replaced && strcmp (argv[1], "-c") == 0)
+	{
+	  *dst++ = '/';
+	  *dst++ = 'c';
+	  *dst = '\0';
+	  continue;
+	}
+
+      /* Add this argument, possibly quoted, to the command line.  */
+      if (quote_this || (i == 2 && cmd_exe_quoting))
+	*dst++ = '\"';
+      for (src = argv[i]; *src; src++)
+	{
+	  if (quote_this)
+	    {
+	      if (*src == '\"')
+		for (j = n_backslashes + 1; j > 0; j--)
+		  *dst++ = '\\';
+	      if (*src == '\\')
+		n_backslashes++;
+	      else
+		n_backslashes = 0;
+	    }
+	  *dst++ = *src;
+	}
+      if (quote_this)
+	{
+	  for (j = n_backslashes; j > 0; j--)
+	    *dst++ = '\\';
+	  *dst++ = '\"';
+	}
+      *dst = '\0';
+    }
+
+  if (cmd_exe_quoting && i > 2)
+    {
+      /* One extra slot was already reserved when we enlarged cmdlen
+	 by 2 in the "if (cmd_exe_quoting)" clause above.  So we can
+	 safely append a closing quote.  */
+      *dst++ = '\"';
+      *dst = '\0';
+    }
+
+  return cmdline;
+}
+
+/* Start a child process running the program in EXEC_FILE with its
+   standard input and output optionally redirected to a pipe.  ARGV is
+   the array of command-line arguments to pass to the child.  P2C and
+   C2P are 2 pipes for communicating with the child, and ERRFD is the
+   standard error file descriptor to be inherited by the child.
+   READING and WRITING, if non-zero, mean that the corresponding pipe
+   will be used.
+
+   Return the PID of the child process, or -1 if couldn't start a
+   process.  */
+static intptr_t
+start_child (const char *exec_file, char **argv,
+	     int reading, int c2p[2], int writing, int p2c[2], int errfd)
+{
+  HANDLE hin = INVALID_HANDLE_VALUE, hout = INVALID_HANDLE_VALUE;
+  HANDLE herr = INVALID_HANDLE_VALUE;
+  STARTUPINFO si;
+  char *env_block = NULL;
+  char *cmdline = NULL;
+  PROCESS_INFORMATION pi;
+  char *progfile, *p;
+  int errno_save;
+  intptr_t pid;
+  int bin_sh_replaced = 0;
+
+  /* Prepare standard handles to be passed to the child process.  */
+  hin = prepare_child_handle (p2c[0], !writing, GENERIC_READ);
+  if (hin == INVALID_HANDLE_VALUE)
+    return -1;
+  hout = prepare_child_handle (c2p[1], !reading, GENERIC_WRITE);
+  if (hout == INVALID_HANDLE_VALUE)
+    return -1;
+  herr = prepare_child_handle (errfd, 1, GENERIC_WRITE);
+  if (herr == INVALID_HANDLE_VALUE)
+    return -1;
+
+  /* Make sure the parent side of both pipes is not inherited.  This
+     is required because gnulib's 'pipe' creates pipes whose both ends
+     are inheritable, which is traditional on Posix (where pipe
+     descriptors are implicitly duplicated by 'fork'), but wrong on
+     Windows (where pipe handles need to be explicitly
+     duplicated).  */
+  if (writing)
+    SetHandleInformation ((HANDLE)_get_osfhandle (p2c[1]),
+			  HANDLE_FLAG_INHERIT, 0);
+  if (reading)
+    {
+      SetHandleInformation ((HANDLE)_get_osfhandle (c2p[0]),
+			    HANDLE_FLAG_INHERIT, 0);
+      /* Gnulib's 'pipe' opens the pipe in binary mode, but we don't
+	 want to read text-mode input of subprocesses in binary more,
+	 because then we will get the ^M (a.k.a. "CR") characters we
+	 don't expect.  */
+      _setmode (c2p[0], _O_TEXT);
+    }
+
+  /* Set up the startup info for the child, using the parent's as the
+     starting point, and specify in it the redirected handles.  */
+  GetStartupInfo (&si);
+  si.dwFlags = STARTF_USESTDHANDLES;
+  si.lpReserved = 0;
+  si.cbReserved2 = 0;
+  si.lpReserved2 = 0;
+  si.hStdInput = hin;
+  si.hStdOutput = hout;
+  si.hStdError = herr;
+
+  /* Create the environment block for the child.  This is needed
+     because the environment we have in 'environ' is not in the format
+     expected by CreateProcess.  */
+  prepare_envblk (environ, &env_block);
+
+  /* CreateProcess doesn't search PATH, so we must do that for it.  */
+  progfile = lookup_cmd (exec_file, &bin_sh_replaced);
+
+  /* CreateProcess doesn't like forward slashes in the application
+     file name.  */
+  for (p = progfile; *p; p++)
+    if (*p == '/')
+      *p = '\\';
+
+  /* Construct the command line.  */
+  cmdline = prepare_cmdline (exec_file, (const char * const *)argv,
+			     bin_sh_replaced);
+
+  /* All set and ready to fly.  Launch the child process.  */
+  if (!CreateProcess (progfile, cmdline, NULL, NULL, TRUE, 0, env_block, NULL,
+		      &si, &pi))
+    {
+      pid = -1;
+
+      /* Since we use Win32 APIs directly, we need to translate their
+	 errors to errno values by hand.  */
+      switch (GetLastError ())
+	{
+	  case ERROR_FILE_NOT_FOUND:
+	  case ERROR_PATH_NOT_FOUND:
+	  case ERROR_INVALID_DRIVE:
+	  case ERROR_BAD_PATHNAME:
+	    errno = ENOENT;
+	    break;
+	  case ERROR_ACCESS_DENIED:
+	    errno = EACCES;
+	    break;
+	  case ERROR_BAD_ENVIRONMENT:
+	    errno = E2BIG;
+	    break;
+	  case ERROR_BROKEN_PIPE:
+	    errno = EPIPE;
+	    break;
+	  case ERROR_INVALID_HANDLE:
+	    errno = EBADF;
+	    break;
+	  case ERROR_MAX_THRDS_REACHED:
+	    errno = EAGAIN;
+	    break;
+	  case ERROR_BAD_EXE_FORMAT:
+	  case ERROR_BAD_FORMAT:
+	  default:
+	    errno = ENOEXEC;
+	    break;
+	}
+    }
+  else
+    pid = (intptr_t)pi.hProcess;
+
+  errno_save = errno;
+
+  /* Free resources.  */
+  free (progfile);
+  free (cmdline);
+  free (env_block);
+  CloseHandle (hin);
+  CloseHandle (hout);
+  CloseHandle (herr);
+  CloseHandle (pi.hThread);
+
+  /* Posix requires to call the shell if execvp fails to invoke EXEC_FILE.  */
+  if (errno_save == ENOEXEC || errno_save == ENOENT)
+    {
+      const char *shell = getenv ("ComSpec");
+
+      if (!shell)
+	shell = "cmd.exe";
+
+      if (c_strcasecmp (exec_file, shell) != 0)
+	{
+	  argv[0] = (char *)exec_file;
+	  return start_child (shell, argv, reading, c2p, writing, p2c, errfd);
+	}
+    }
+
+  errno = errno_save;
+  return pid;
+}
+
+\f
+/* Emulation of waitpid which only supports WNOHANG, since _cwait doesn't.  */
+int
+waitpid (intptr_t pid, int *status, int options)
+{
+  if ((options & WNOHANG) != 0)
+    {
+      DWORD st;
+
+      if (!GetExitCodeProcess ((HANDLE)pid, &st))
+	{
+	  errno = ECHILD;
+	  return -1;
+	}
+      if (st == STILL_ACTIVE)
+	return 0;
+      if (status)
+	*status = st;
+      return (int)pid;
+    }
+
+  return (int)_cwait (status, pid, WAIT_CHILD);
+}
+
+\f
+/* Translate abnormal exit status of Windows programs into the signal
+   that terminated the program.  This is required to support scm_kill
+   and WTERMSIG.  */
+
+struct signal_and_status {
+  int sig;
+  DWORD status;
+};
+
+static const struct signal_and_status sigtbl[] = {
+  {SIGSEGV, 0xC0000005},	/* access to invalid address */
+  {SIGSEGV, 0xC0000008},	/* invalid handle */
+  {SIGILL,  0xC000001D},	/* illegal instruction */
+  {SIGILL,  0xC0000025},	/* non-continuable instruction */
+  {SIGSEGV, 0xC000008C},	/* array bounds exceeded */
+  {SIGFPE,  0xC000008D},	/* float denormal */
+  {SIGFPE,  0xC000008E},	/* float divide by zero */
+  {SIGFPE,  0xC000008F},	/* float inexact */
+  {SIGFPE,  0xC0000090},	/* float invalid operation */
+  {SIGFPE,  0xC0000091},	/* float overflow */
+  {SIGFPE,  0xC0000092},	/* float stack check */
+  {SIGFPE,  0xC0000093},	/* float underflow */
+  {SIGFPE,  0xC0000094},	/* integer divide by zero */
+  {SIGFPE,  0xC0000095},	/* integer overflow */
+  {SIGILL,  0xC0000096},	/* privileged instruction */
+  {SIGSEGV, 0xC00000FD},	/* stack overflow */
+  {SIGTERM, 0xC000013A},	/* Ctrl-C exit */
+  {SIGINT,  0xC000013A}
+};
+
+static int
+w32_signal_to_status (int sig)
+{
+  int i;
+
+  for (i = 0; i < sizeof (sigtbl) / sizeof (sigtbl[0]); i++)
+    if (sig == sigtbl[i].sig)
+      return sigtbl[i].status;
+
+  return (int)0xC000013A;
+}
+
+static int
+w32_status_to_termsig (DWORD status)
+{
+  int i;
+
+  for (i = 0; i < sizeof (sigtbl) / sizeof (sigtbl[0]); i++)
+    if (status == sigtbl[i].status)
+      return sigtbl[i].sig;
+
+  return SIGTERM;
+}
+
+/* Support for scm_kill.  */
+static int
+w32_kill_proc (int pid, int sig)
+{
+  HANDLE ph = OpenProcess (PROCESS_TERMINATE, 0, pid);
+
+  if (!ph)
+    {
+      errno = EPERM;
+      return -1;
+    }
+  if (!TerminateProcess (ph, w32_signal_to_status (sig)))
+    {
+      errno = EINVAL;
+      return -1;
+    }
+  CloseHandle (ph);
+
+  return 0;
+}
+
+/* Emulation of getpriority and setpriority.  */
+
+#define PRIO_PROCESS 1
+#define PRIO_PGRP    2
+#define PRIO_USER    3
+#define NZERO        8
+
+static int
+getpriority (int which, int who)
+{
+  HANDLE hp;
+  int nice_value = -1;
+  int error = 0;
+
+  /* We don't support process groups and users.  */
+  if (which != PRIO_PROCESS)
+    {
+      errno = ENOSYS;
+      return -1;
+    }
+
+  if (who == 0)
+    hp = GetCurrentProcess ();
+  else
+    hp = OpenProcess (PROCESS_QUERY_INFORMATION, FALSE, who);
+
+  if (hp)
+    {
+      DWORD pri_class = GetPriorityClass (hp);
+
+      if (pri_class > 0)
+	{
+	  switch (pri_class)
+	    {
+	    case IDLE_PRIORITY_CLASS:
+	      nice_value = 4;
+	      break;
+	    case BELOW_NORMAL_PRIORITY_CLASS:
+	      nice_value = 6;
+	      break;
+	    case NORMAL_PRIORITY_CLASS:
+	      nice_value = 8;
+	      break;
+	    case ABOVE_NORMAL_PRIORITY_CLASS:
+	      nice_value = 10;
+	      break;
+	    case HIGH_PRIORITY_CLASS:
+	      nice_value = 13;
+	      break;
+	    case REALTIME_PRIORITY_CLASS:
+	      nice_value = 24;
+	      break;
+	    }
+	  /* If WHO is us, we can provide a more fine-grained value by
+	     looking at the current thread's priority value.  (For
+	     other processes, it is not clear which thread to use.)  */
+	  if (who == 0 || who == GetCurrentProcessId ())
+	    {
+	      HANDLE ht = GetCurrentThread ();
+	      int tprio = GetThreadPriority (ht);
+
+	      switch (tprio)
+		{
+		case THREAD_PRIORITY_IDLE:
+		  if (pri_class == REALTIME_PRIORITY_CLASS)
+		    nice_value = 16;
+		  else
+		    nice_value = 1;
+		  break;
+		case THREAD_PRIORITY_TIME_CRITICAL:
+		  if (pri_class == REALTIME_PRIORITY_CLASS)
+		    nice_value = 31;
+		  else
+		    nice_value = 15;
+		case THREAD_PRIORITY_ERROR_RETURN:
+		  nice_value = -1;
+		  error = 1;
+		  break;
+		default:
+		  nice_value += tprio;
+		  break;
+		}
+	    }
+	  /* Map to "nice values" similar to what one would see on
+	     Posix platforms.  */
+	  if (!error)
+	    nice_value = - (nice_value - NZERO);
+	}
+      else
+	error = 1;
+    }
+  else
+    error = 1;
+
+  if (error)
+    {
+      DWORD err = GetLastError ();
+
+      switch (err)
+	{
+	case ERROR_INVALID_PARAMETER:
+	case ERROR_INVALID_THREAD_ID:
+	  errno = ESRCH;
+	  break;
+	default:
+	  errno = EPERM;
+	  break;
+	}
+    }
+
+  return nice_value;
+}
+
+#undef HAVE_GETPRIORITY
+#define HAVE_GETPRIORITY 1
+
+static int
+setpriority (int which, int who, int nice_val)
+{
+  HANDLE hp;
+  DWORD err;
+
+  if (which != PRIO_PROCESS)
+    {
+      errno = ENOSYS;
+      return -1;
+    }
+
+  if (who == 0)
+    hp = GetCurrentProcess ();
+  else
+    hp = OpenProcess (PROCESS_SET_INFORMATION, FALSE, who);
+
+  if (hp)
+    {
+      DWORD pri_class;
+
+      /* Map "nice values" back to process priority classes.  */
+      nice_val = -nice_val + NZERO;
+      if (nice_val < 6)
+	pri_class = IDLE_PRIORITY_CLASS;
+      else if (nice_val < 8)
+	pri_class = BELOW_NORMAL_PRIORITY_CLASS;
+      else if (nice_val < 10)
+	pri_class = NORMAL_PRIORITY_CLASS;
+      else if (nice_val < 13)
+	pri_class = ABOVE_NORMAL_PRIORITY_CLASS;
+      else if (nice_val < 16)
+	pri_class = HIGH_PRIORITY_CLASS;
+      else
+	pri_class = REALTIME_PRIORITY_CLASS;
+
+      if (SetPriorityClass (hp, pri_class))
+	return 0;
+    }
+
+  err = GetLastError ();
+
+  switch (err)
+    {
+    case ERROR_INVALID_PARAMETER:
+      errno = ESRCH;
+      break;
+    default:
+      errno = EPERM;
+      break;
+    }
+
+  return -1;
+}
+
+#undef HAVE_SETPRIORITY
+#define HAVE_SETPRIORITY 1
+
+/* Emulation of sched_getaffinity and sched_setaffinity.  */
+static int
+sched_getaffinity (int pid, size_t mask_size, cpu_set_t *mask)
+{
+  HANDLE hp;
+  DWORD err;
+
+  if (mask == NULL)
+    {
+      errno = EFAULT;
+      return -1;
+    }
+
+  if (pid == 0)
+    hp = GetCurrentProcess ();
+  else
+    hp = OpenProcess (PROCESS_QUERY_INFORMATION, FALSE, pid);
+
+  if (hp)
+    {
+      DWORD_PTR ignored;
+      BOOL result = GetProcessAffinityMask (hp, (DWORD_PTR *)mask, &ignored);
+
+      if (pid != 0)
+	CloseHandle (hp);
+      if (result)
+	return 0;
+    }
+
+  err = GetLastError ();
+
+  switch (err)
+    {
+    case ERROR_INVALID_PARAMETER:
+      errno = ESRCH;
+      break;
+    case ERROR_ACCESS_DENIED:
+    default:
+      errno = EPERM;
+      break;
+    }
+
+  return -1;
+}
+
+#undef HAVE_SCHED_GETAFFINITY
+#define HAVE_SCHED_GETAFFINITY 1
+
+static int
+sched_setaffinity (int pid, size_t mask_size, cpu_set_t *mask)
+{
+  HANDLE hp;
+  DWORD err;
+
+  if (mask == NULL)
+    {
+      errno = EFAULT;
+      return -1;
+    }
+
+  if (pid == 0)
+    hp = GetCurrentProcess ();
+  else
+    hp = OpenProcess (PROCESS_SET_INFORMATION, FALSE, pid);
+
+  if (hp)
+    {
+      BOOL result = SetProcessAffinityMask (hp, *(DWORD_PTR *)mask);
+
+      if (pid != 0)
+	CloseHandle (hp);
+      if (result)
+	return 0;
+    }
+
+  err = GetLastError ();
+
+  switch (err)
+    {
+    case ERROR_INVALID_PARAMETER:
+      errno = ESRCH;
+      break;
+    case ERROR_ACCESS_DENIED:
+    default:
+      errno = EPERM;
+      break;
+    }
+
+  return -1;
+}
+
+#undef HAVE_SCHED_SETAFFINITY
+#define HAVE_SCHED_SETAFFINITY 1
-- 
2.9.0.windows.1

Re: Support open-process and friends on MS-Windows

[Eli Zaretskii]

[-- Attachment #1: Type: text/plain, Size: 1324 bytes --]

[Please disregard the previous patch and use this one instead.]

> From: ludo@gnu.org (Ludovic Courtès)
> Cc: Andy Wingo <wingo@pobox.com>,  guile-devel@gnu.org
> Date: Sat, 25 Jun 2016 15:02:42 +0200
> 
> >> Great!  I have two nits.  One, if it is possible for you, please attach
> >> the patch in the format that "git format-patch" makes.  That makes it
> >> easy to apply, otherwise I have to futz around with --author and I could
> >> accidentally fat-finger it and get it wrong.
> >> 
> >> Secondly, please make w32-proc override the definitions of
> >> HAVE_GETPRIORITY, HAVE_SETPRIORITY, HAVE_SCHED_GETAFFINITY, and
> >> HAVE_SCHED_SETAFFINITY.  That way you won't need this kind of change
> >> either:
> >> 
> >> > -#if HAVE_GETPRIORITY
> >> > +#if HAVE_GETPRIORITY || defined __MINGW32__
> >> 
> >> If you've already discussed this with Ludovic and decided to go this way
> >> explicitly, please disregard this second nit.
> >> 
> >> I will also wait a day or two for any comments from Ludovic before
> >> applying.
> >
> > Thanks, I will wait for Ludovic to tell he's okay with overriding the
> > HAVE_* macros,
> 
> Yes, I agree with Andy, I think it’ll be nicer.
> 
> > and will send a format-patch formatted changes after that.
> 
> Cool, thank you!

Updated patch below.


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: 0001-Provide-support-for-open-process-and-related-functio.patch --]
[-- Type: text/x-patch, Size: 32547 bytes --]

From 21d718f0b1c9bba62204eab7342406c46e5cbdc2 Mon Sep 17 00:00:00 2001
From: Eli Zaretskii <eliz@gnu.org>
Date: Sat, 25 Jun 2016 16:29:22 +0300
Subject: [PATCH] Provide support for open-process and related functions on
 MS-Windows

* libguile/w32-proc.c: New file, with MinGW support code for
scm_open_process, scm_kill, scm_getpriority, scm_setpriority,
scm_getaffinity, and scm_setaffinity.  Also, provides macros that
on Posix hosts are in sys/wait.h, like WIFEXITED and WTERMSIG, and
simple definitions for getuid, getgid, setuid, setgid, and
waitpid.

* libguile/posix.c [__MINGW32__]: Include w32-proc.c.
(scm_kill) [__MINGW32__]: Support killing subprocesses on MS-Windows.
(scm_status_exit_val, scm_getuid, scm_getegid): Don't exclude from
compilation with MinGW.
(scm_execl, scm_execle): Cast arguments of execv/execve to avoid
compiler warnings.
(scm_open_process): Condition parts specific to 'fork'-based
implementation with "#ifdef HAVE_FORK".
[__MINGW32__]: MinGW alternative to 'fork'-based implementation;
most of the supporting code is in w32-proc.c.
(scm_getpriority, scm_setpriority, scm_getaffinity)
(scm_setaffinity, scm_init_popen): Don't exclude from MinGW
compilation.
(scm_init_posix): Register scm_init_popen extension even if
HAVE_FORK is not defined.
---
 libguile/posix.c    |  59 +++-
 libguile/w32-proc.c | 919 ++++++++++++++++++++++++++++++++++++++++++++++++++++
 2 files changed, 960 insertions(+), 18 deletions(-)
 create mode 100644 libguile/w32-proc.c

diff --git a/libguile/posix.c b/libguile/posix.c
index 2654716..8541f7d 100644
--- a/libguile/posix.c
+++ b/libguile/posix.c
@@ -84,6 +84,10 @@
 #if HAVE_SYS_WAIT_H
 # include <sys/wait.h>
 #endif
+#ifdef __MINGW32__
+# include <w32-proc.c>
+#endif	/* __MINGW32__ */
+
 #ifndef WEXITSTATUS
 # define WEXITSTATUS(stat_val) ((unsigned)(stat_val) >> 8)
 #endif
@@ -659,7 +663,7 @@ SCM_DEFINE (scm_kill, "kill", 2, 0, 0,
 #else
   /* Mingw has raise(), but not kill().  (Other raw DOS environments might
      be similar.)  Use raise() when the requested pid is our own process,
-     otherwise bomb.  */
+     otherwise TerminateProcess.  */
   if (scm_to_int (pid) == getpid ())
     {
       if (raise (scm_to_int (sig)) != 0)
@@ -673,6 +677,10 @@ SCM_DEFINE (scm_kill, "kill", 2, 0, 0,
           goto err;
         }
     }
+#ifdef __MINGW32__
+  if (w32_kill_proc (scm_to_int (pid), scm_to_int (sig)) != 0)
+    SCM_SYSERROR;
+#endif	/* __MINGW32__ */
 #endif
   return SCM_UNSPECIFIED;
 }
@@ -735,7 +743,6 @@ SCM_DEFINE (scm_waitpid, "waitpid", 1, 1, 0,
 #undef FUNC_NAME
 #endif /* HAVE_WAITPID */
 
-#ifndef __MINGW32__
 SCM_DEFINE (scm_status_exit_val, "status:exit-val", 1, 0, 0, 
             (SCM status),
 	    "Return the exit status value, as would be set if a process\n"
@@ -786,7 +793,6 @@ SCM_DEFINE (scm_status_stop_sig, "status:stop-sig", 1, 0, 0,
     return SCM_BOOL_F;
 }
 #undef FUNC_NAME
-#endif /* __MINGW32__ */
 
 #ifdef HAVE_GETPPID
 SCM_DEFINE (scm_getppid, "getppid", 0, 0, 0,
@@ -801,7 +807,6 @@ SCM_DEFINE (scm_getppid, "getppid", 0, 0, 0,
 #endif /* HAVE_GETPPID */
 
 
-#ifndef __MINGW32__
 SCM_DEFINE (scm_getuid, "getuid", 0, 0, 0,
             (),
 	    "Return an integer representing the current real user ID.")
@@ -905,10 +910,8 @@ SCM_DEFINE (scm_seteuid, "seteuid", 1, 0, 0,
   return SCM_UNSPECIFIED;
 }
 #undef FUNC_NAME
-#endif /* __MINGW32__ */
 
 
-#ifdef HAVE_SETEGID
 SCM_DEFINE (scm_setegid, "setegid", 1, 0, 0,
             (SCM id),
 	    "Sets the effective group ID to the integer @var{id}, provided the process\n"
@@ -931,7 +934,6 @@ SCM_DEFINE (scm_setegid, "setegid", 1, 0, 0,
     
 }
 #undef FUNC_NAME
-#endif
 
 
 #ifdef HAVE_GETPGRP
@@ -1141,7 +1143,7 @@ SCM_DEFINE (scm_execl, "execl", 1, 0, 1,
 
   exec_argv = scm_i_allocate_string_pointers (args);
 
-  execv (exec_file, exec_argv);
+  execv (exec_file, (char const * const *)exec_argv);
   SCM_SYSERROR;
 
   /* not reached.  */
@@ -1170,7 +1172,7 @@ SCM_DEFINE (scm_execlp, "execlp", 1, 0, 1,
 
   exec_argv = scm_i_allocate_string_pointers (args);
 
-  execvp (exec_file, exec_argv);
+  execvp (exec_file, (char const * const *)exec_argv);
   SCM_SYSERROR;
 
   /* not reached.  */
@@ -1204,7 +1206,8 @@ SCM_DEFINE (scm_execle, "execle", 2, 0, 1,
   exec_argv = scm_i_allocate_string_pointers (args);
   exec_env = scm_i_allocate_string_pointers (env);
 
-  execve (exec_file, exec_argv, exec_env);
+  execve (exec_file, (char const * const *)exec_argv,
+	  (char const * const *)exec_env);
   SCM_SYSERROR;
 
   /* not reached.  */
@@ -1246,6 +1249,7 @@ SCM_DEFINE (scm_fork, "primitive-fork", 0, 0, 0,
   return scm_from_int (pid);
 }
 #undef FUNC_NAME
+#endif /* HAVE_FORK */
 
 /* Since Guile uses threads, we have to be very careful to avoid calling
    functions that are not async-signal-safe in the child.  That's why
@@ -1262,7 +1266,9 @@ scm_open_process (SCM mode, SCM prog, SCM args)
   int pid;
   char *exec_file;
   char **exec_argv;
+#ifdef HAVE_FORK
   int max_fd = 1024;
+#endif
 
   exec_file = scm_to_locale_string (prog);
   exec_argv = scm_i_allocate_string_pointers (scm_cons (prog, args));
@@ -1319,12 +1325,28 @@ scm_open_process (SCM mode, SCM prog, SCM args)
   }
 #endif
 
+#ifdef HAVE_FORK
   pid = fork ();
+#elif defined(__MINGW32__)
+  if (!reading)
+    c2p[1] = out;
+  if (!writing)
+    p2c[0] = in;
+  pid = start_child (exec_file, exec_argv, reading, c2p, writing, p2c, err);
+#else
+  close (c2p[0]);
+  close (c2p[1]);
+  close (p2c[0]);
+  close (p2c[1]);
+  free (exec_file);
+  errno = ENOSYS;
+  SCM_SYSERROR;
+#endif	/* HAVE_FORK */
 
   if (pid == -1)
     {
       int errno_save = errno;
-      free (exec_file);
+
       if (reading)
         {
           close (c2p[0]);
@@ -1336,6 +1358,8 @@ scm_open_process (SCM mode, SCM prog, SCM args)
           close (p2c[1]);
         }
       errno = errno_save;
+
+      free (exec_file);
       SCM_SYSERROR;
     }
 
@@ -1360,6 +1384,7 @@ scm_open_process (SCM mode, SCM prog, SCM args)
         (scm_list_3 (read_port, write_port, scm_from_int (pid)));
     }
 
+#ifdef HAVE_FORK
   /* The child.  */
   if (reading)
     close (c2p[0]);
@@ -1408,16 +1433,16 @@ scm_open_process (SCM mode, SCM prog, SCM args)
   if (err > 0)
     {
       char *msg = strerror (errno);
-      fprintf (fdopen (err, "a"), "In execlp of %s: %s\n",
+      fprintf (fdopen (err, "a"), "In execvp of %s: %s\n",
                exec_file, msg);
     }
 
   _exit (EXIT_FAILURE);
+#endif	/* HAVE_FORK */
   /* Not reached.  */
   return SCM_BOOL_F;
 }
 #undef FUNC_NAME
-#endif /* HAVE_FORK */
 
 #ifdef __MINGW32__
 # include "win32-uname.h"
@@ -2000,7 +2025,7 @@ SCM_DEFINE (scm_getaffinity, "getaffinity", 1, 0, 0,
 	    "Guile can use without stepping on other processes' toes.\n\n"
 	    "Currently this procedure is only defined on GNU variants\n"
 	    "(@pxref{CPU Affinity, @code{sched_getaffinity},, libc, The\n"
-	    "GNU C Library Reference Manual}).\n")
+	    "GNU C Library Reference Manual}) and on MS-Windows.\n")
 #define FUNC_NAME s_scm_getaffinity
 {
   int err;
@@ -2026,7 +2051,7 @@ SCM_DEFINE (scm_setaffinity, "setaffinity", 2, 0, 0,
 	    "is unspecified.\n\n"
 	    "Currently this procedure is only defined on GNU variants\n"
 	    "(@pxref{CPU Affinity, @code{sched_setaffinity},, libc, The\n"
-	    "GNU C Library Reference Manual}).\n")
+	    "GNU C Library Reference Manual}) and on MS-Windows.\n")
 #define FUNC_NAME s_scm_setaffinity
 {
   cpu_set_t cs;
@@ -2235,13 +2260,11 @@ SCM_DEFINE (scm_gethostname, "gethostname", 0, 0, 0,
 #endif /* HAVE_GETHOSTNAME */
 
 \f
-#ifdef HAVE_FORK
 static void
 scm_init_popen (void)
 {
   scm_c_define_gsubr ("open-process", 2, 0, 1, scm_open_process);
 }
-#endif
 
 void
 scm_init_posix ()
@@ -2340,11 +2363,11 @@ scm_init_posix ()
 
 #ifdef HAVE_FORK
   scm_add_feature ("fork");
+#endif	/* HAVE_FORK */
   scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION,
                             "scm_init_popen",
 			    (scm_t_extension_init_func) scm_init_popen,
 			    NULL);
-#endif	/* HAVE_FORK */
 }
 
 /*
diff --git a/libguile/w32-proc.c b/libguile/w32-proc.c
new file mode 100644
index 0000000..2026f15
--- /dev/null
+++ b/libguile/w32-proc.c
@@ -0,0 +1,919 @@
+/* Copyright (C) 2016 Free Software Foundation, Inc.
+ *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
+ *
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
+ */
+
+#include <c-strcase.h>
+
+# define WEXITSTATUS(stat_val) ((stat_val) & 255)
+/* MS-Windows programs that crash due to a fatal exception exit with
+   an exit code whose 2 MSB bits are set.  */
+# define WIFEXITED(stat_val)   (((stat_val) & 0xC0000000) == 0)
+# define WIFSIGNALED(stat_val) (((stat_val) & 0xC0000000) == 0xC0000000)
+# define WTERMSIG(stat_val)    w32_status_to_termsig (stat_val)
+/* The funny conditional avoids a compiler warning in status:stop_sig.  */
+# define WIFSTOPPED(stat_val)  ((stat_val) == (stat_val) ? 0 : 0)
+# define WSTOPSIG(stat_var)    (0)
+# include <process.h>
+# define HAVE_WAITPID 1
+  static int w32_status_to_termsig (DWORD);
+  static int w32_signal_to_status (int);
+# define getuid()              (500) /* Local Administrator */
+# define getgid()              (513) /* None */
+# define setuid(u)             (0)
+# define setgid(g)             (0)
+# define WIN32_LEAN_AND_MEAN
+# include <windows.h>
+# define WNOHANG               1
+  int waitpid (intptr_t, int *, int);
+
+  typedef DWORD_PTR cpu_set_t;
+
+#define CPU_ZERO(s)     memset(s,0,sizeof(*s))
+#define CPU_ISSET(b,s)  ((*s) & (1U << (b))) != 0
+#define CPU_SET(b,s)    (*s) |= (1U << (b))
+#define CPU_SETSIZE     (8*sizeof(DWORD_PTR))
+
+/* Run a child process with redirected standard handles, without
+   redirecting standard handles of the parent.  This is required in
+   multithreaded programs, where redirecting a standard handle affects
+   all threads.  */
+
+#include <stdlib.h>
+#include <string.h>
+
+/* Prepare a possibly redirected file handle to be passed to a child
+   process.  The handle is for the file/device open on file descriptor
+   FD; if FD is invalid, use the null device instead.
+
+   USE_STD non-zero means we have been passed the descriptor used by
+   the parent.
+
+   ACCESS is the Windows access mode for opening the null device.
+
+   Returns the Win32 handle to be passed to CreateProcess.  */
+static HANDLE
+prepare_child_handle (int fd, int use_std, DWORD access)
+{
+  HANDLE htem, hret;
+  DWORD err = 0;
+
+  /* Start with the descriptor, if specified by the caller and valid,
+     otherwise open the null device.  */
+  if (fd < 0)
+    htem = INVALID_HANDLE_VALUE;
+  else
+    htem = (HANDLE)_get_osfhandle (fd);
+
+  /* Duplicate the handle and make it inheritable.  */
+  if (DuplicateHandle (GetCurrentProcess (),
+		       htem,
+		       GetCurrentProcess (),
+		       &hret,
+		       0,
+		       TRUE,
+		       DUPLICATE_SAME_ACCESS) == FALSE)
+    {
+      /* If the original standard handle was invalid (happens, e.g.,
+	 in GUI programs), open the null device instead.  */
+      if ((err = GetLastError ()) == ERROR_INVALID_HANDLE
+	  && use_std)
+	{
+	  htem = CreateFile ("NUL", access,
+			     FILE_SHARE_READ | FILE_SHARE_WRITE, NULL,
+			     OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, NULL);
+	  if (htem != INVALID_HANDLE_VALUE
+	      && DuplicateHandle (GetCurrentProcess (),
+				  htem,
+				  GetCurrentProcess (),
+				  &hret,
+				  0,
+				  TRUE,
+				  DUPLICATE_SAME_ACCESS) == FALSE)
+	    {
+	      err = GetLastError ();
+	      CloseHandle (htem);
+	      hret = INVALID_HANDLE_VALUE;
+	    }
+	}
+    }
+
+  if (hret == INVALID_HANDLE_VALUE)
+    {
+      switch (err)
+	{
+	  case ERROR_NO_MORE_FILES:
+	    errno = EMFILE;
+	    break;
+	  case ERROR_INVALID_HANDLE:
+	  default:
+	    errno = EBADF;
+	    break;
+	}
+    }
+
+  return hret;
+}
+
+/* A comparison function for sorting the environment.  */
+static int
+compenv (const void *a1, const void *a2)
+{
+  return stricmp (*((char**)a1), *((char**)a2));
+}
+
+/* Convert the program's 'environ' array to a block of environment
+   variables suitable to be passed to CreateProcess.  This is needed
+   to ensure the child process inherits the up-to-date environment of
+   the parent, including any variables inserted by the parent.  */
+static void
+prepare_envblk (char **envp, char **envblk)
+{
+  char **tmp;
+  int size_needed;
+  int envcnt;
+  char *ptr;
+
+  for (envcnt = 0; envp[envcnt]; envcnt++)
+    ;
+
+  tmp = scm_calloc ((envcnt + 1) * sizeof (*tmp));
+
+  for (envcnt = size_needed = 0; envp[envcnt]; envcnt++)
+    {
+      tmp[envcnt] = envp[envcnt];
+      size_needed += strlen (envp[envcnt]) + 1;
+    }
+  size_needed++;
+
+  /* Windows likes its environment variables sorted.  */
+  qsort ((void *) tmp, (size_t) envcnt, sizeof (char *), compenv);
+
+  /* CreateProcess needs the environment block as a linear array,
+     where each variable is terminated by a null character, and the
+     last one is terminated by 2 null characters.  */
+  ptr = *envblk = scm_calloc (size_needed);
+
+  for (envcnt = 0; tmp[envcnt]; envcnt++)
+    {
+      strcpy (ptr, tmp[envcnt]);
+      ptr += strlen (tmp[envcnt]) + 1;
+    }
+
+  free (tmp);
+}
+
+/* Find an executable PROGRAM on PATH, return result in malloc'ed
+   storage.  If PROGRAM is /bin/sh, and no sh.exe was found on PATH,
+   fall back on the Windows shell and set BIN_SH_REPLACED to non-zero.  */
+static char *
+lookup_cmd (const char *program, int *bin_sh_replaced)
+{
+  static const char *extensions[] = {
+    ".exe", ".cmd", ".bat", "", ".com", NULL
+  };
+  int bin_sh_requested = 0;
+  char *path, *dir, *sep;
+  char abs_name[MAX_PATH];
+  DWORD abs_namelen = 0;
+
+  /* If they ask for the Unix system shell, try to find it on PATH.  */
+  if (c_strcasecmp (program, "/bin/sh") == 0)
+    {
+      bin_sh_requested = 1;
+      program = "sh.exe";
+    }
+
+  /* If PROGRAM includes leading directories, the caller already did
+     our job.  */
+  if (strchr (program, '/') != NULL
+      || strchr (program, '\\') != NULL)
+    return scm_strdup (program);
+
+  /* Note: It is OK for getenv below to return NULL -- in that case,
+     SearchPath will search in the directories whose list is specified
+     by the system Registry.  */
+  path = getenv ("PATH");
+  if (!path)	/* shouldn't happen, really */
+    path = ".";
+  dir = sep = path = strdup (path);
+  for ( ; sep && *sep; dir = sep + 1)
+    {
+      int i;
+
+      sep = strpbrk (dir, ";");
+      if (sep == dir)	/* two or more ;'s in a row */
+	continue;
+      if (sep)
+	*sep = '\0';
+      for (i = 0; extensions[i]; i++)
+	{
+	  abs_namelen = SearchPath (dir, program, extensions[i],
+				    MAX_PATH, abs_name, NULL);
+	  if (0 < abs_namelen && abs_namelen <= MAX_PATH)	/* found! */
+	    break;
+	}
+      if (extensions[i])	/* found! */
+	break;
+      if (sep)
+	*sep = ';';
+    }
+
+  free (path);
+
+  /* If they asked for /bin/sh and we didn't find it, fall back on the
+     default Windows shell.  */
+  if (abs_namelen <= 0 && bin_sh_requested)
+    {
+      const char *shell = getenv ("ComSpec");
+
+      if (!shell)
+	shell = "C:\\Windows\\system32\\cmd.exe";
+
+      *bin_sh_replaced = 1;
+      strcpy (abs_name, shell);
+      abs_namelen = strlen (abs_name);
+    }
+
+  /* If not found, return the original PROGRAM name.  */
+  if (abs_namelen <= 0 || abs_namelen > MAX_PATH)
+    return scm_strdup (program);
+
+  return scm_strndup (abs_name, abs_namelen);
+}
+
+/* Concatenate command-line arguments in argv[] into a single
+   command-line string, while quoting arguments as needed.  The result
+   is malloc'ed.  */
+static char *
+prepare_cmdline (const char *cmd, const char * const *argv, int bin_sh_replaced)
+{
+  /* These characters should include anything that is special to _any_
+     program, including both Windows and Unixy shells, and the
+     widlcard expansion in startup code of a typical Windows app.  */
+  const char need_quotes[] = " \t#;\"\'*?[]&|<>(){}$`^";
+  size_t cmdlen = 1;	/* for terminating null */
+  char *cmdline = scm_malloc (cmdlen);
+  char *dst = cmdline;
+  int cmd_exe_quoting = 0;
+  int i;
+  const char *p;
+
+  /* Are we constructing a command line for cmd.exe?  */
+  if (bin_sh_replaced)
+    cmd_exe_quoting = 1;
+  else
+    {
+      for (p = cmd + strlen (cmd);
+	   p > cmd && p[-1] != '/' && p[-1] != '\\' && p[-1] != ':';
+	   p--)
+	;
+      if (c_strcasecmp (p, "cmd.exe") == 0
+	  || c_strcasecmp (p, "cmd") == 0)
+	cmd_exe_quoting = 1;
+    }
+
+  /* Initialize the command line to empty.  */
+  *dst = '\0';
+
+  /* Append arguments, if any, from argv[]. */
+  for (i = 0; argv[i]; i++)
+    {
+      const char *src = argv[i];
+      size_t len;
+      int quote_this = 0, n_backslashes = 0;
+      int j;
+
+      /* Append the blank separator.  We don't do that for argv[0]
+	 because that is the command name (will end up in child's
+	 argv[0]), and is only recognized as such if there're no
+	 blanks before it.  */
+      if (i > 0)
+	*dst++ = ' ';
+      len = dst - cmdline;
+
+      /* How much space is required for this argument?  */
+      cmdlen += strlen (argv[i]) + 1; /* 1 for a blank separator */
+      /* cmd.exe needs a different style of quoting: all the arguments
+	 beyond the /c switch are enclosed in an extra pair of quotes,
+	 and not otherwise quoted/escaped. */
+      if (cmd_exe_quoting)
+	{
+	  if (i == 2)
+	    cmdlen += 2;
+	}
+      else if (strpbrk (argv[i], need_quotes))
+	{
+	  quote_this = 1;
+	  cmdlen += 2;
+	  for ( ; *src; src++)
+	    {
+	      /* An embedded quote needs to be escaped by a backslash.
+		 Any backslashes immediately preceding that quote need
+		 each one to be escaped by another backslash.  */
+	      if (*src == '\"')
+		cmdlen += n_backslashes + 1;
+	      if (*src == '\\')
+		n_backslashes++;
+	      else
+		n_backslashes = 0;
+	    }
+	  /* If the closing quote we will add is preceded by
+	     backslashes, those backslashes need to be escaped.  */
+	  cmdlen += n_backslashes;
+	}
+
+      /* Enlarge the command-line string as needed.  */
+      cmdline = scm_realloc (cmdline, cmdlen);
+      dst = cmdline + len;
+
+      if (i == 0
+	  && c_strcasecmp (argv[0], "/bin/sh") == 0
+	  && bin_sh_replaced)
+	{
+	  strcpy (dst, "cmd.exe");
+	  dst += sizeof ("cmd.exe") - 1;
+	  continue;
+	}
+      if (i == 1 && bin_sh_replaced && strcmp (argv[1], "-c") == 0)
+	{
+	  *dst++ = '/';
+	  *dst++ = 'c';
+	  *dst = '\0';
+	  continue;
+	}
+
+      /* Add this argument, possibly quoted, to the command line.  */
+      if (quote_this || (i == 2 && cmd_exe_quoting))
+	*dst++ = '\"';
+      for (src = argv[i]; *src; src++)
+	{
+	  if (quote_this)
+	    {
+	      if (*src == '\"')
+		for (j = n_backslashes + 1; j > 0; j--)
+		  *dst++ = '\\';
+	      if (*src == '\\')
+		n_backslashes++;
+	      else
+		n_backslashes = 0;
+	    }
+	  *dst++ = *src;
+	}
+      if (quote_this)
+	{
+	  for (j = n_backslashes; j > 0; j--)
+	    *dst++ = '\\';
+	  *dst++ = '\"';
+	}
+      *dst = '\0';
+    }
+
+  if (cmd_exe_quoting && i > 2)
+    {
+      /* One extra slot was already reserved when we enlarged cmdlen
+	 by 2 in the "if (cmd_exe_quoting)" clause above.  So we can
+	 safely append a closing quote.  */
+      *dst++ = '\"';
+      *dst = '\0';
+    }
+
+  return cmdline;
+}
+
+/* Start a child process running the program in EXEC_FILE with its
+   standard input and output optionally redirected to a pipe.  ARGV is
+   the array of command-line arguments to pass to the child.  P2C and
+   C2P are 2 pipes for communicating with the child, and ERRFD is the
+   standard error file descriptor to be inherited by the child.
+   READING and WRITING, if non-zero, mean that the corresponding pipe
+   will be used.
+
+   Return the PID of the child process, or -1 if couldn't start a
+   process.  */
+static intptr_t
+start_child (const char *exec_file, char **argv,
+	     int reading, int c2p[2], int writing, int p2c[2], int errfd)
+{
+  HANDLE hin = INVALID_HANDLE_VALUE, hout = INVALID_HANDLE_VALUE;
+  HANDLE herr = INVALID_HANDLE_VALUE;
+  STARTUPINFO si;
+  char *env_block = NULL;
+  char *cmdline = NULL;
+  PROCESS_INFORMATION pi;
+  char *progfile, *p;
+  int errno_save;
+  intptr_t pid;
+  int bin_sh_replaced = 0;
+
+  /* Prepare standard handles to be passed to the child process.  */
+  hin = prepare_child_handle (p2c[0], !writing, GENERIC_READ);
+  if (hin == INVALID_HANDLE_VALUE)
+    return -1;
+  hout = prepare_child_handle (c2p[1], !reading, GENERIC_WRITE);
+  if (hout == INVALID_HANDLE_VALUE)
+    return -1;
+  herr = prepare_child_handle (errfd, 1, GENERIC_WRITE);
+  if (herr == INVALID_HANDLE_VALUE)
+    return -1;
+
+  /* Make sure the parent side of both pipes is not inherited.  This
+     is required because gnulib's 'pipe' creates pipes whose both ends
+     are inheritable, which is traditional on Posix (where pipe
+     descriptors are implicitly duplicated by 'fork'), but wrong on
+     Windows (where pipe handles need to be explicitly
+     duplicated).  */
+  if (writing)
+    SetHandleInformation ((HANDLE)_get_osfhandle (p2c[1]),
+			  HANDLE_FLAG_INHERIT, 0);
+  if (reading)
+    {
+      SetHandleInformation ((HANDLE)_get_osfhandle (c2p[0]),
+			    HANDLE_FLAG_INHERIT, 0);
+      /* Gnulib's 'pipe' opens the pipe in binary mode, but we don't
+	 want to read text-mode input of subprocesses in binary more,
+	 because then we will get the ^M (a.k.a. "CR") characters we
+	 don't expect.  */
+      _setmode (c2p[0], _O_TEXT);
+    }
+
+  /* Set up the startup info for the child, using the parent's as the
+     starting point, and specify in it the redirected handles.  */
+  GetStartupInfo (&si);
+  si.dwFlags = STARTF_USESTDHANDLES;
+  si.lpReserved = 0;
+  si.cbReserved2 = 0;
+  si.lpReserved2 = 0;
+  si.hStdInput = hin;
+  si.hStdOutput = hout;
+  si.hStdError = herr;
+
+  /* Create the environment block for the child.  This is needed
+     because the environment we have in 'environ' is not in the format
+     expected by CreateProcess.  */
+  prepare_envblk (environ, &env_block);
+
+  /* CreateProcess doesn't search PATH, so we must do that for it.  */
+  progfile = lookup_cmd (exec_file, &bin_sh_replaced);
+
+  /* CreateProcess doesn't like forward slashes in the application
+     file name.  */
+  for (p = progfile; *p; p++)
+    if (*p == '/')
+      *p = '\\';
+
+  /* Construct the command line.  */
+  cmdline = prepare_cmdline (exec_file, (const char * const *)argv,
+			     bin_sh_replaced);
+
+  /* All set and ready to fly.  Launch the child process.  */
+  if (!CreateProcess (progfile, cmdline, NULL, NULL, TRUE, 0, env_block, NULL,
+		      &si, &pi))
+    {
+      pid = -1;
+
+      /* Since we use Win32 APIs directly, we need to translate their
+	 errors to errno values by hand.  */
+      switch (GetLastError ())
+	{
+	  case ERROR_FILE_NOT_FOUND:
+	  case ERROR_PATH_NOT_FOUND:
+	  case ERROR_INVALID_DRIVE:
+	  case ERROR_BAD_PATHNAME:
+	    errno = ENOENT;
+	    break;
+	  case ERROR_ACCESS_DENIED:
+	    errno = EACCES;
+	    break;
+	  case ERROR_BAD_ENVIRONMENT:
+	    errno = E2BIG;
+	    break;
+	  case ERROR_BROKEN_PIPE:
+	    errno = EPIPE;
+	    break;
+	  case ERROR_INVALID_HANDLE:
+	    errno = EBADF;
+	    break;
+	  case ERROR_MAX_THRDS_REACHED:
+	    errno = EAGAIN;
+	    break;
+	  case ERROR_BAD_EXE_FORMAT:
+	  case ERROR_BAD_FORMAT:
+	  default:
+	    errno = ENOEXEC;
+	    break;
+	}
+    }
+  else
+    pid = (intptr_t)pi.hProcess;
+
+  errno_save = errno;
+
+  /* Free resources.  */
+  free (progfile);
+  free (cmdline);
+  free (env_block);
+  CloseHandle (hin);
+  CloseHandle (hout);
+  CloseHandle (herr);
+  CloseHandle (pi.hThread);
+
+  /* Posix requires to call the shell if execvp fails to invoke EXEC_FILE.  */
+  if (errno_save == ENOEXEC || errno_save == ENOENT)
+    {
+      const char *shell = getenv ("ComSpec");
+
+      if (!shell)
+	shell = "cmd.exe";
+
+      if (c_strcasecmp (exec_file, shell) != 0)
+	{
+	  argv[0] = (char *)exec_file;
+	  return start_child (shell, argv, reading, c2p, writing, p2c, errfd);
+	}
+    }
+
+  errno = errno_save;
+  return pid;
+}
+
+\f
+/* Emulation of waitpid which only supports WNOHANG, since _cwait doesn't.  */
+int
+waitpid (intptr_t pid, int *status, int options)
+{
+  if ((options & WNOHANG) != 0)
+    {
+      DWORD st;
+
+      if (!GetExitCodeProcess ((HANDLE)pid, &st))
+	{
+	  errno = ECHILD;
+	  return -1;
+	}
+      if (st == STILL_ACTIVE)
+	return 0;
+      if (status)
+	*status = st;
+      return (int)pid;
+    }
+
+  return (int)_cwait (status, pid, WAIT_CHILD);
+}
+
+\f
+/* Translate abnormal exit status of Windows programs into the signal
+   that terminated the program.  This is required to support scm_kill
+   and WTERMSIG.  */
+
+struct signal_and_status {
+  int sig;
+  DWORD status;
+};
+
+static const struct signal_and_status sigtbl[] = {
+  {SIGSEGV, 0xC0000005},	/* access to invalid address */
+  {SIGSEGV, 0xC0000008},	/* invalid handle */
+  {SIGILL,  0xC000001D},	/* illegal instruction */
+  {SIGILL,  0xC0000025},	/* non-continuable instruction */
+  {SIGSEGV, 0xC000008C},	/* array bounds exceeded */
+  {SIGFPE,  0xC000008D},	/* float denormal */
+  {SIGFPE,  0xC000008E},	/* float divide by zero */
+  {SIGFPE,  0xC000008F},	/* float inexact */
+  {SIGFPE,  0xC0000090},	/* float invalid operation */
+  {SIGFPE,  0xC0000091},	/* float overflow */
+  {SIGFPE,  0xC0000092},	/* float stack check */
+  {SIGFPE,  0xC0000093},	/* float underflow */
+  {SIGFPE,  0xC0000094},	/* integer divide by zero */
+  {SIGFPE,  0xC0000095},	/* integer overflow */
+  {SIGILL,  0xC0000096},	/* privileged instruction */
+  {SIGSEGV, 0xC00000FD},	/* stack overflow */
+  {SIGTERM, 0xC000013A},	/* Ctrl-C exit */
+  {SIGINT,  0xC000013A}
+};
+
+static int
+w32_signal_to_status (int sig)
+{
+  int i;
+
+  for (i = 0; i < sizeof (sigtbl) / sizeof (sigtbl[0]); i++)
+    if (sig == sigtbl[i].sig)
+      return sigtbl[i].status;
+
+  return (int)0xC000013A;
+}
+
+static int
+w32_status_to_termsig (DWORD status)
+{
+  int i;
+
+  for (i = 0; i < sizeof (sigtbl) / sizeof (sigtbl[0]); i++)
+    if (status == sigtbl[i].status)
+      return sigtbl[i].sig;
+
+  return SIGTERM;
+}
+
+/* Support for scm_kill.  */
+static int
+w32_kill_proc (int pid, int sig)
+{
+  HANDLE ph = OpenProcess (PROCESS_TERMINATE, 0, pid);
+
+  if (!ph)
+    {
+      errno = EPERM;
+      return -1;
+    }
+  if (!TerminateProcess (ph, w32_signal_to_status (sig)))
+    {
+      errno = EINVAL;
+      return -1;
+    }
+  CloseHandle (ph);
+
+  return 0;
+}
+
+/* Emulation of getpriority and setpriority.  */
+
+#define PRIO_PROCESS 1
+#define PRIO_PGRP    2
+#define PRIO_USER    3
+#define NZERO        8
+
+static int
+getpriority (int which, int who)
+{
+  HANDLE hp;
+  int nice_value = -1;
+  int error = 0;
+
+  /* We don't support process groups and users.  */
+  if (which != PRIO_PROCESS)
+    {
+      errno = ENOSYS;
+      return -1;
+    }
+
+  if (who == 0)
+    hp = GetCurrentProcess ();
+  else
+    hp = OpenProcess (PROCESS_QUERY_INFORMATION, FALSE, who);
+
+  if (hp)
+    {
+      DWORD pri_class = GetPriorityClass (hp);
+
+      if (pri_class > 0)
+	{
+	  switch (pri_class)
+	    {
+	    case IDLE_PRIORITY_CLASS:
+	      nice_value = 4;
+	      break;
+	    case BELOW_NORMAL_PRIORITY_CLASS:
+	      nice_value = 6;
+	      break;
+	    case NORMAL_PRIORITY_CLASS:
+	      nice_value = 8;
+	      break;
+	    case ABOVE_NORMAL_PRIORITY_CLASS:
+	      nice_value = 10;
+	      break;
+	    case HIGH_PRIORITY_CLASS:
+	      nice_value = 13;
+	      break;
+	    case REALTIME_PRIORITY_CLASS:
+	      nice_value = 24;
+	      break;
+	    }
+	  /* If WHO is us, we can provide a more fine-grained value by
+	     looking at the current thread's priority value.  (For
+	     other processes, it is not clear which thread to use.)  */
+	  if (who == 0 || who == GetCurrentProcessId ())
+	    {
+	      HANDLE ht = GetCurrentThread ();
+	      int tprio = GetThreadPriority (ht);
+
+	      switch (tprio)
+		{
+		case THREAD_PRIORITY_IDLE:
+		  if (pri_class == REALTIME_PRIORITY_CLASS)
+		    nice_value = 16;
+		  else
+		    nice_value = 1;
+		  break;
+		case THREAD_PRIORITY_TIME_CRITICAL:
+		  if (pri_class == REALTIME_PRIORITY_CLASS)
+		    nice_value = 31;
+		  else
+		    nice_value = 15;
+		case THREAD_PRIORITY_ERROR_RETURN:
+		  nice_value = -1;
+		  error = 1;
+		  break;
+		default:
+		  nice_value += tprio;
+		  break;
+		}
+	    }
+	  /* Map to "nice values" similar to what one would see on
+	     Posix platforms.  */
+	  if (!error)
+	    nice_value = - (nice_value - NZERO);
+	}
+      else
+	error = 1;
+    }
+  else
+    error = 1;
+
+  if (error)
+    {
+      DWORD err = GetLastError ();
+
+      switch (err)
+	{
+	case ERROR_INVALID_PARAMETER:
+	case ERROR_INVALID_THREAD_ID:
+	  errno = ESRCH;
+	  break;
+	default:
+	  errno = EPERM;
+	  break;
+	}
+    }
+
+  return nice_value;
+}
+
+#undef HAVE_GETPRIORITY
+#define HAVE_GETPRIORITY 1
+
+static int
+setpriority (int which, int who, int nice_val)
+{
+  HANDLE hp;
+  DWORD err;
+
+  if (which != PRIO_PROCESS)
+    {
+      errno = ENOSYS;
+      return -1;
+    }
+
+  if (who == 0)
+    hp = GetCurrentProcess ();
+  else
+    hp = OpenProcess (PROCESS_SET_INFORMATION, FALSE, who);
+
+  if (hp)
+    {
+      DWORD pri_class;
+
+      /* Map "nice values" back to process priority classes.  */
+      nice_val = -nice_val + NZERO;
+      if (nice_val < 6)
+	pri_class = IDLE_PRIORITY_CLASS;
+      else if (nice_val < 8)
+	pri_class = BELOW_NORMAL_PRIORITY_CLASS;
+      else if (nice_val < 10)
+	pri_class = NORMAL_PRIORITY_CLASS;
+      else if (nice_val < 13)
+	pri_class = ABOVE_NORMAL_PRIORITY_CLASS;
+      else if (nice_val < 16)
+	pri_class = HIGH_PRIORITY_CLASS;
+      else
+	pri_class = REALTIME_PRIORITY_CLASS;
+
+      if (SetPriorityClass (hp, pri_class))
+	return 0;
+    }
+
+  err = GetLastError ();
+
+  switch (err)
+    {
+    case ERROR_INVALID_PARAMETER:
+      errno = ESRCH;
+      break;
+    default:
+      errno = EPERM;
+      break;
+    }
+
+  return -1;
+}
+
+#undef HAVE_SETPRIORITY
+#define HAVE_SETPRIORITY 1
+
+/* Emulation of sched_getaffinity and sched_setaffinity.  */
+static int
+sched_getaffinity (int pid, size_t mask_size, cpu_set_t *mask)
+{
+  HANDLE hp;
+  DWORD err;
+
+  if (mask == NULL)
+    {
+      errno = EFAULT;
+      return -1;
+    }
+
+  if (pid == 0)
+    hp = GetCurrentProcess ();
+  else
+    hp = OpenProcess (PROCESS_QUERY_INFORMATION, FALSE, pid);
+
+  if (hp)
+    {
+      DWORD_PTR ignored;
+      BOOL result = GetProcessAffinityMask (hp, (DWORD_PTR *)mask, &ignored);
+
+      if (pid != 0)
+	CloseHandle (hp);
+      if (result)
+	return 0;
+    }
+
+  err = GetLastError ();
+
+  switch (err)
+    {
+    case ERROR_INVALID_PARAMETER:
+      errno = ESRCH;
+      break;
+    case ERROR_ACCESS_DENIED:
+    default:
+      errno = EPERM;
+      break;
+    }
+
+  return -1;
+}
+
+#undef HAVE_SCHED_GETAFFINITY
+#define HAVE_SCHED_GETAFFINITY 1
+
+static int
+sched_setaffinity (int pid, size_t mask_size, cpu_set_t *mask)
+{
+  HANDLE hp;
+  DWORD err;
+
+  if (mask == NULL)
+    {
+      errno = EFAULT;
+      return -1;
+    }
+
+  if (pid == 0)
+    hp = GetCurrentProcess ();
+  else
+    hp = OpenProcess (PROCESS_SET_INFORMATION, FALSE, pid);
+
+  if (hp)
+    {
+      BOOL result = SetProcessAffinityMask (hp, *(DWORD_PTR *)mask);
+
+      if (pid != 0)
+	CloseHandle (hp);
+      if (result)
+	return 0;
+    }
+
+  err = GetLastError ();
+
+  switch (err)
+    {
+    case ERROR_INVALID_PARAMETER:
+      errno = ESRCH;
+      break;
+    case ERROR_ACCESS_DENIED:
+    default:
+      errno = EPERM;
+      break;
+    }
+
+  return -1;
+}
+
+#undef HAVE_SCHED_SETAFFINITY
+#define HAVE_SCHED_SETAFFINITY 1
-- 
2.9.0.windows.1

Re: Support open-process and friends on MS-Windows

[Andy Wingo]

On Sat 25 Jun 2016 15:31, Eli Zaretskii <eliz@gnu.org> writes:

> [Please disregard the previous patch and use this one instead.]

Thanks for the updates.  I have a couple of additional nits, having
applied and built the patch.

> @@ -659,7 +663,7 @@ SCM_DEFINE (scm_kill, "kill", 2, 0, 0,
>  #else
>    /* Mingw has raise(), but not kill().  (Other raw DOS environments might
>       be similar.)  Use raise() when the requested pid is our own process,
> -     otherwise bomb.  */
> +     otherwise TerminateProcess.  */
>    if (scm_to_int (pid) == getpid ())
>      {
>        if (raise (scm_to_int (sig)) != 0)
> @@ -673,6 +677,10 @@ SCM_DEFINE (scm_kill, "kill", 2, 0, 0,
>            goto err;
>          }
>      }
> +#ifdef __MINGW32__
> +  if (w32_kill_proc (scm_to_int (pid), scm_to_int (sig)) != 0)
> +    SCM_SYSERROR;
> +#endif	/* __MINGW32__ */
>  #endif
>    return SCM_UNSPECIFIED;
>  }

Here we effectively have two mingw blocks.  Can the previous one be
removed?  If not, let's fold it into `w32_kill_proc', and in any case
let's rename `w32_kill_proc' to `kill', and then define HAVE_KILL.

> @@ -1141,7 +1143,7 @@ SCM_DEFINE (scm_execl, "execl", 1, 0, 1,
>  
>    exec_argv = scm_i_allocate_string_pointers (args);
>  
> -  execv (exec_file, exec_argv);
> +  execv (exec_file, (char const * const *)exec_argv);
>    SCM_SYSERROR;
>  
>    /* not reached.  */

make[3]: Entering directory '/home/wingo/src/guile-2.0/libguile'
  CC       libguile_2.0_la-posix.lo
posix.c: In function 'scm_execl':
posix.c:1146:21: warning: passing argument 2 of 'execv' from incompatible pointer type [-Wincompatible-pointer-types]
   execv (exec_file, (char const * const *)exec_argv);
                     ^
In file included from ../lib/unistd.h:40:0,
                 from posix.c:50:
/home/wingo/.guix-profile/include/unistd.h:566:12: note: expected 'char * const*' but argument is of type 'const char * const*'
 extern int execv (const char *__path, char *const __argv[])
            ^~~~~

What should be done here?

Similarly in the following cases.

> @@ -1408,16 +1433,16 @@ scm_open_process (SCM mode, SCM prog, SCM args)
>    if (err > 0)
>      {
>        char *msg = strerror (errno);
> -      fprintf (fdopen (err, "a"), "In execlp of %s: %s\n",
> +      fprintf (fdopen (err, "a"), "In execvp of %s: %s\n",
>                 exec_file, msg);
>      }
>  
>    _exit (EXIT_FAILURE);
> +#endif	/* HAVE_FORK */
>    /* Not reached.  */
>    return SCM_BOOL_F;
>  }
>  #undef FUNC_NAME
> -#endif /* HAVE_FORK */

This change updates to provide `open-process' effectively on all systems
instead of only if `fork' is available, but then it causes a runtime
error if the system doesn't have `fork' and isn't `mingw32'.  I guess
that's OK in practice.  Would you mind updating the documentation in
doc/ref/posix.texi to indicate this?  Thanks.

Cheers, and thanks for dealing with the late feedback.

Andy

Re: Support open-process and friends on MS-Windows

[Eli Zaretskii]

> From: Andy Wingo <wingo@pobox.com>
> Cc: ludo@gnu.org (Ludovic Courtès),  guile-devel@gnu.org
> Date: Sat, 25 Jun 2016 16:43:34 +0200
> 
> > @@ -659,7 +663,7 @@ SCM_DEFINE (scm_kill, "kill", 2, 0, 0,
> >  #else
> >    /* Mingw has raise(), but not kill().  (Other raw DOS environments might
> >       be similar.)  Use raise() when the requested pid is our own process,
> > -     otherwise bomb.  */
> > +     otherwise TerminateProcess.  */
> >    if (scm_to_int (pid) == getpid ())
> >      {
> >        if (raise (scm_to_int (sig)) != 0)
> > @@ -673,6 +677,10 @@ SCM_DEFINE (scm_kill, "kill", 2, 0, 0,
> >            goto err;
> >          }
> >      }
> > +#ifdef __MINGW32__
> > +  if (w32_kill_proc (scm_to_int (pid), scm_to_int (sig)) != 0)
> > +    SCM_SYSERROR;
> > +#endif	/* __MINGW32__ */
> >  #endif
> >    return SCM_UNSPECIFIED;
> >  }
> 
> Here we effectively have two mingw blocks.  Can the previous one be
> removed?

The previous block is not MinGW-specific.  It allows any system that
has 'raise' (which is Standard C, so should be available everywhere)
to at least kill the current process.  This code was there before my
changes, and I saw no reasons to remove it.

> If not, let's fold it into `w32_kill_proc', and in any case
> let's rename `w32_kill_proc' to `kill', and then define HAVE_KILL.

I didn't want to call the function 'kill', as some other linked-in
library might have it, and then you'd have a clash.  'kill' is too
simple a name to overload.

> > @@ -1141,7 +1143,7 @@ SCM_DEFINE (scm_execl, "execl", 1, 0, 1,
> >  
> >    exec_argv = scm_i_allocate_string_pointers (args);
> >  
> > -  execv (exec_file, exec_argv);
> > +  execv (exec_file, (char const * const *)exec_argv);
> >    SCM_SYSERROR;
> >  
> >    /* not reached.  */
> 
> make[3]: Entering directory '/home/wingo/src/guile-2.0/libguile'
>   CC       libguile_2.0_la-posix.lo
> posix.c: In function 'scm_execl':
> posix.c:1146:21: warning: passing argument 2 of 'execv' from incompatible pointer type [-Wincompatible-pointer-types]
>    execv (exec_file, (char const * const *)exec_argv);
>                      ^
> In file included from ../lib/unistd.h:40:0,
>                  from posix.c:50:
> /home/wingo/.guix-profile/include/unistd.h:566:12: note: expected 'char * const*' but argument is of type 'const char * const*'
>  extern int execv (const char *__path, char *const __argv[])
>             ^~~~~
> 
> What should be done here?

Make the cast MinGW-only?

> > @@ -1408,16 +1433,16 @@ scm_open_process (SCM mode, SCM prog, SCM args)
> >    if (err > 0)
> >      {
> >        char *msg = strerror (errno);
> > -      fprintf (fdopen (err, "a"), "In execlp of %s: %s\n",
> > +      fprintf (fdopen (err, "a"), "In execvp of %s: %s\n",
> >                 exec_file, msg);
> >      }
> >  
> >    _exit (EXIT_FAILURE);
> > +#endif	/* HAVE_FORK */
> >    /* Not reached.  */
> >    return SCM_BOOL_F;
> >  }
> >  #undef FUNC_NAME
> > -#endif /* HAVE_FORK */
> 
> This change updates to provide `open-process' effectively on all systems
> instead of only if `fork' is available, but then it causes a runtime
> error if the system doesn't have `fork' and isn't `mingw32'.

Sorry, I don't follow: the change in fprintf fixes a simple type (the
function whose call failed is 'execvp', not 'execlp'.  Or are you
talking about something else?

> I guess that's OK in practice.  Would you mind updating the
> documentation in doc/ref/posix.texi to indicate this?  Thanks.

Once I understand the issue, sure.

Thanks.

Re: Support open-process and friends on MS-Windows

[Mark H Weaver]

Eli Zaretskii <eliz@gnu.org> writes:
> +# define getuid()              (500) /* Local Administrator */
> +# define getgid()              (513) /* None */
> +# define setuid(u)             (0)
> +# define setgid(g)             (0)

As I've said before, I'm not comfortable with these definitions.  These
are not operations that can be safely ignored.  If we cannot do a job
that's requested of us, we should raise an exception.  We should not
make numbers up out of thin air and pass them off as fact, nor should we
claim to have successfully done a job that we are unable to do.

More to the point, we should not assume that the caller's requests are
unimportant.  Feigning success on ignored requests and fabricating
misinformation might be okay in some cases, but in other cases it is
likely to lead to security holes and other bugs.  For example, a common
pattern is to use 'setuid' to drop privileges before running some
untrusted code.  We must not silently ignore such requests.

      Mark

Re: Support open-process and friends on MS-Windows

[Eli Zaretskii]

> From: Mark H Weaver <mhw@netris.org>
> Cc: ludo@gnu.org (Ludovic Courtès),  wingo@pobox.com,
>   guile-devel@gnu.org
> Date: Sat, 02 Jul 2016 19:02:08 -0400
> 
> Eli Zaretskii <eliz@gnu.org> writes:
> > +# define getuid()              (500) /* Local Administrator */
> > +# define getgid()              (513) /* None */
> > +# define setuid(u)             (0)
> > +# define setgid(g)             (0)
> 
> As I've said before, I'm not comfortable with these definitions.  These
> are not operations that can be safely ignored.  If we cannot do a job
> that's requested of us, we should raise an exception.  We should not
> make numbers up out of thin air and pass them off as fact, nor should we
> claim to have successfully done a job that we are unable to do.
> 
> More to the point, we should not assume that the caller's requests are
> unimportant.  Feigning success on ignored requests and fabricating
> misinformation might be okay in some cases, but in other cases it is
> likely to lead to security holes and other bugs.  For example, a common
> pattern is to use 'setuid' to drop privileges before running some
> untrusted code.  We must not silently ignore such requests.

As I've said before, these operations either have no meaning on
MS-Windows, or cannot be easily mapped to the equivalent Windows
notions.  All other applications ported from Posix platforms that I
know of do something like the above, and I have yet to hear a single
complaint.  Raising exceptions in these cases will simply get in the
way of writing portable Guile programs, because the application
programmer will have to work around the exception in Guile code, or
declare that the program does not support MS-Windows.

Please accept my opinions that are based on many years of experience
in porting Unix and GNU applications to MS-DOS and MS-Windows.

Thanks.

Re: Support open-process and friends on MS-Windows

[Eli Zaretskii]

> Date: Sun, 03 Jul 2016 06:47:37 +0300
> From: Eli Zaretskii <eliz@gnu.org>
> Cc: wingo@pobox.com, ludo@gnu.org, guile-devel@gnu.org
> 
> As I've said before, these operations either have no meaning on
> MS-Windows, or cannot be easily mapped to the equivalent Windows
> notions.  All other applications ported from Posix platforms that I
> know of do something like the above, and I have yet to hear a single
> complaint.  Raising exceptions in these cases will simply get in the
> way of writing portable Guile programs, because the application
> programmer will have to work around the exception in Guile code, or
> declare that the program does not support MS-Windows.

For those who want to see the detailed arguments I brought up in a
past discussion, please read

  https://lists.gnu.org/archive/html/guile-devel/2014-02/msg00072.html

It's a long message covering a lot of turf, but the stuff relevant to
these particular issues starts around the middle of the message, with
this citation:

> >> On the other hand, if a program _does_ try to do one of those things, it
> >> might be important that the job be done right.

Re: Support open-process and friends on MS-Windows

[Mark H Weaver]

Eli Zaretskii <eliz@gnu.org> writes:

>> From: Mark H Weaver <mhw@netris.org>
>> Cc: ludo@gnu.org (Ludovic Courtès),  wingo@pobox.com,
>>   guile-devel@gnu.org
>> Date: Sat, 02 Jul 2016 19:02:08 -0400
>> 
>> Eli Zaretskii <eliz@gnu.org> writes:
>> > +# define getuid()              (500) /* Local Administrator */
>> > +# define getgid()              (513) /* None */
>> > +# define setuid(u)             (0)
>> > +# define setgid(g)             (0)
>> 
>> As I've said before, I'm not comfortable with these definitions.  These
>> are not operations that can be safely ignored.  If we cannot do a job
>> that's requested of us, we should raise an exception.  We should not
>> make numbers up out of thin air and pass them off as fact, nor should we
>> claim to have successfully done a job that we are unable to do.
>> 
>> More to the point, we should not assume that the caller's requests are
>> unimportant.  Feigning success on ignored requests and fabricating
>> misinformation might be okay in some cases, but in other cases it is
>> likely to lead to security holes and other bugs.  For example, a common
>> pattern is to use 'setuid' to drop privileges before running some
>> untrusted code.  We must not silently ignore such requests.
>
> [...]  All other applications ported from Posix platforms that I
> know of do something like the above, and I have yet to hear a single
> complaint.

Most applications do not expose get*id/set*id to other programs as part
of their public API.  When they are kept private, such hacks are far
more defensible, because it is possible to examine every call site and
thereby determine whether any harm might be caused by silently ignoring
requests and returning bogus results.

In the case of Guile, you are asking us to expose these dishonest and
potentially dangerous definitions in our public API, and therefore to an
unbounded set of programs and use cases, not to mention public scrutiny.

Before I would consider doing this, I would need to be convinced of
three propositions:

(1) that get*id/set*id are used so frequently in Guile programs that it
    would be unreasonably onerous to examine and modify each call site
    to handle the MS-Windows case.

(2) that security flaws would be extremely unlikely to arise from your
    definitions.

(3) that for the overwhelming majority of call sites, your definitions
    lead to correct behavior on MS-Windows.

I'm skeptical of all three.

> Raising exceptions in these cases will simply get in the
> way of writing portable Guile programs, because the application
> programmer will have to work around the exception in Guile code,

That's exactly what *should* be done, because only at the application
level is it possible to reliably determine how to properly handle the
absence of these operations.

      Mark

Re: Support open-process and friends on MS-Windows

[Ludovic Courtès]

Mark H Weaver <mhw@netris.org> skribis:

> Eli Zaretskii <eliz@gnu.org> writes:
>
>>> From: Mark H Weaver <mhw@netris.org>
>>> Cc: ludo@gnu.org (Ludovic Courtès),  wingo@pobox.com,
>>>   guile-devel@gnu.org
>>> Date: Sat, 02 Jul 2016 19:02:08 -0400
>>> 
>>> Eli Zaretskii <eliz@gnu.org> writes:
>>> > +# define getuid()              (500) /* Local Administrator */
>>> > +# define getgid()              (513) /* None */
>>> > +# define setuid(u)             (0)
>>> > +# define setgid(g)             (0)

What about leaving ‘setuid’ and ‘setgid’ undefined, as was the case
until now?

‘getuid’ and ‘getgid’ could either be undefined or return a “random”
value; the latter only makes sense if in practice it helps run useful
code without any observable difference, though I’m unsure whether such
code exists.

Anyway, I think we shouldn’t lose our hair over this problem; I’m
grateful Eli did all this work porting Guile to MinGW, and that is what
matters most.

Thanks,
Ludo’.

Re: Support open-process and friends on MS-Windows

[Eli Zaretskii]

> From: ludo@gnu.org (Ludovic Courtès)
> Cc: Eli Zaretskii <eliz@gnu.org>,  wingo@pobox.com,  guile-devel@gnu.org
> Date: Tue, 05 Jul 2016 10:04:23 +0200
> 
> Mark H Weaver <mhw@netris.org> skribis:
> 
> > Eli Zaretskii <eliz@gnu.org> writes:
> >
> >>> From: Mark H Weaver <mhw@netris.org>
> >>> Cc: ludo@gnu.org (Ludovic Courtès),  wingo@pobox.com,
> >>>   guile-devel@gnu.org
> >>> Date: Sat, 02 Jul 2016 19:02:08 -0400
> >>> 
> >>> Eli Zaretskii <eliz@gnu.org> writes:
> >>> > +# define getuid()              (500) /* Local Administrator */
> >>> > +# define getgid()              (513) /* None */
> >>> > +# define setuid(u)             (0)
> >>> > +# define setgid(g)             (0)
> 
> What about leaving ‘setuid’ and ‘setgid’ undefined, as was the case
> until now?

I fail to see how this would be better.  It would mean any program
that calls these will not work on MS-Windows.  Why should we expect
developers of those Guile programs to be aware of the issue and solve
it on the Guile Scheme level?  And what solution will they possibly be
able to come up with, except not to call these APIs on Windows?

> ‘getuid’ and ‘getgid’ could either be undefined or return a “random”
> value; the latter only makes sense if in practice it helps run useful
> code without any observable difference, though I’m unsure whether such
> code exists.

Random values are better than nothing, but they are worse than
consistent values, because some program might record the value from
one call and then compare it further down the program flow with the
results of another call.  Consistent values will win in this case.

> Anyway, I think we shouldn’t lose our hair over this problem; I’m
> grateful Eli did all this work porting Guile to MinGW, and that is what
> matters most.

Thank you.  I certainly hope so.

Re: Support open-process and friends on MS-Windows

[Ludovic Courtès]

Eli Zaretskii <eliz@gnu.org> skribis:

>> From: ludo@gnu.org (Ludovic Courtès)
>> Cc: Eli Zaretskii <eliz@gnu.org>,  wingo@pobox.com,  guile-devel@gnu.org
>> Date: Tue, 05 Jul 2016 10:04:23 +0200
>> 
>> Mark H Weaver <mhw@netris.org> skribis:
>> 
>> > Eli Zaretskii <eliz@gnu.org> writes:
>> >
>> >>> From: Mark H Weaver <mhw@netris.org>
>> >>> Cc: ludo@gnu.org (Ludovic Courtès),  wingo@pobox.com,
>> >>>   guile-devel@gnu.org
>> >>> Date: Sat, 02 Jul 2016 19:02:08 -0400
>> >>> 
>> >>> Eli Zaretskii <eliz@gnu.org> writes:
>> >>> > +# define getuid()              (500) /* Local Administrator */
>> >>> > +# define getgid()              (513) /* None */
>> >>> > +# define setuid(u)             (0)
>> >>> > +# define setgid(g)             (0)
>> 
>> What about leaving ‘setuid’ and ‘setgid’ undefined, as was the case
>> until now?
>
> I fail to see how this would be better.  It would mean any program
> that calls these will not work on MS-Windows.  Why should we expect
> developers of those Guile programs to be aware of the issue and solve
> it on the Guile Scheme level?  And what solution will they possibly be
> able to come up with, except not to call these APIs on Windows?

Our strategy so far has been to (1) either solve the portability issue
via Gnulib, or (2) do not provide the feature that is unavailable (the
#ifdef HAVE_ in posix.c et al.)

It means that application writers have to be aware of the portability
problems, even if it’s all Scheme.  That sounds reasonable to me.

WDYT?

Thanks,
Ludo’.

Re: Support open-process and friends on MS-Windows

[Eli Zaretskii]

> From: ludo@gnu.org (Ludovic Courtès)
> Cc: mhw@netris.org,  wingo@pobox.com,  guile-devel@gnu.org
> Date: Mon, 11 Jul 2016 10:09:47 +0200
> 
> >> >>> Eli Zaretskii <eliz@gnu.org> writes:
> >> >>> > +# define getuid()              (500) /* Local Administrator */
> >> >>> > +# define getgid()              (513) /* None */
> >> >>> > +# define setuid(u)             (0)
> >> >>> > +# define setgid(g)             (0)
> >> 
> >> What about leaving ‘setuid’ and ‘setgid’ undefined, as was the case
> >> until now?
> >
> > I fail to see how this would be better.  It would mean any program
> > that calls these will not work on MS-Windows.  Why should we expect
> > developers of those Guile programs to be aware of the issue and solve
> > it on the Guile Scheme level?  And what solution will they possibly be
> > able to come up with, except not to call these APIs on Windows?
> 
> Our strategy so far has been to (1) either solve the portability issue
> via Gnulib, or (2) do not provide the feature that is unavailable (the
> #ifdef HAVE_ in posix.c et al.)
> 
> It means that application writers have to be aware of the portability
> problems, even if it’s all Scheme.  That sounds reasonable to me.
> 
> WDYT?

I don't think it's wise, and I explained why.  Gnulib in this case is
unlikely to provide any implementation, except one that always fails,
because these operations have no equivalent on MS-Windows.

But if agreeing to remove these two lines will cause the rest of the
patch to be finally admitted, I'm fine with that compromise.

TIA

Re: Support open-process and friends on MS-Windows

[Eli Zaretskii]

> From: Mark H Weaver <mhw@netris.org>
> Cc: wingo@pobox.com,  ludo@gnu.org,  guile-devel@gnu.org
> Date: Tue, 05 Jul 2016 03:44:15 -0400
> 
> Most applications do not expose get*id/set*id to other programs as part
> of their public API.

Emacs exposes getuid, getgid, geteuid, and getegid, has been doing
that for a very long time.  See the functions user-id, user-real-id,
group-id, and group-real-id.

> When they are kept private, such hacks are far more defensible,
> because it is possible to examine every call site and thereby
> determine whether any harm might be caused by silently ignoring
> requests and returning bogus results.
> 
> In the case of Guile, you are asking us to expose these dishonest and
> potentially dangerous definitions in our public API, and therefore to an
> unbounded set of programs and use cases, not to mention public scrutiny.

I don't see a significant difference between these two classes of use
cases.  IME, when someone needs the results of getuid etc. in Lisp,
Scheme, or some other high-level language, they use them in the same
way as one would do that in C as part of some primitive.  After all,
what other reasons could you imagine for using these values, except to
write code in Scheme to do something similar to some primitive, but
with a quirk?  All the rest of the applications of these values I
could think of (e.g., scanning /etc/passwd etc.) are not relevant to
Windows anyway, since these facilities don't exist there in the form
and format they do on Posix platforms.

If you can think of some other kinds of application that might need
these values, please describe them.

> Before I would consider doing this, I would need to be convinced of
> three propositions:
> 
> (1) that get*id/set*id are used so frequently in Guile programs that it
>     would be unreasonably onerous to examine and modify each call site
>     to handle the MS-Windows case.

getuid is used in boot-9.scm, so if it's unavailable, we cannot build
Guile without making changes in the Scheme code.  I don't know if that
convinces you, and I have no practical way of counting their uses in
Guile programs outside Guile itself.

But even if the frequency is not high enough, what would be the
practical alternative?  Guile is an extension language, so we cannot
possibly go out and fix all those uses, as they are not confined to a
small number of known packages.

> (2) that security flaws would be extremely unlikely to arise from your
>     definitions.

setuid and setgid are defined to no-ops, so their security flaws are
by definition nil.  What kind of security flaws could arise from
getuid and getgid, as I proposed to define them?  Windows will not
allow access to protected files regardless of the user/group ID we
use, so I think these, too, have no security related issues that I can
think of.

> (3) that for the overwhelming majority of call sites, your definitions
>     lead to correct behavior on MS-Windows.

I can tell that they survived the Guile test suite.

More generally, the get*id values are just numbers that have no
implication on code correctness.  _Any_ scalar values returned by
these functions on Windows will not be correct, because the
corresponding Windows values are variable-length arrays (called
Security Identifiers, or "SIDs").  Moreover, even if we do return the
full SID to Guile, there's no way of using them in any Guile API
because those APIs are modeled on Posix, which expects a single scalar
value.

So I think doing something like I suggested is really the only
practical solution -- return some plausible number whose only real use
could be to display it.

> I'm skeptical of all three.

I know.  And that's what makes this experience so frustrating for me:
you remain skeptical whatever I say, even though this dispute has been
going on for a couple of years.

> > Raising exceptions in these cases will simply get in the
> > way of writing portable Guile programs, because the application
> > programmer will have to work around the exception in Guile code,
> 
> That's exactly what *should* be done, because only at the application
> level is it possible to reliably determine how to properly handle the
> absence of these operations.

IME, the considerations on the application level will invariably be
exactly the same as what I suggest: either don't call the API or
ignore the result.

Here's a relevant example: a Windows port of GNU 'cp'.  I'm trying to
recursively copy a directory:

  D:\usr\eli\data>cp -pvr foo bar
  `foo' -> `bar'
  `foo/#bug.m#' -> `bar/#bug.m#'
  `foo/bug.el' -> `bar/bug.el'
  `foo/bug.m' -> `bar/bug.m'
  cp: failed to preserve ownership for `bar': Permission denied
  ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^

The error happens because the person who ported the program didn't
make 'chown' and its supporting code a no-op on Windows for
directories.  The result: infinite annoyance for users, and for no
good reason at all, because Windows copies the NTFS security
permissions by default.  In this case, the error is not fatal, but
that's just sheer luck.

Suppose someone would like to write 'cp' in Guile Scheme -- what do
you envision they will want to do with 'chown' on MS-Windows, if they
want the result to be better than the above?

The absolute majority of Guile programs are written by people with
only Posix background, they don't know enough about Windows and don't
care about it.  We cannot expect them to figure out all these subtle
issues and solve them in Scheme -- that's simply not going to happen.
What will happen is that Guile programs that use these APIs will
simply be broken on Windows, and for no good reason at all, as I
attempted to explain several times in so many words.  Do we really
want that?  I hope not.