adaint.c, [...] (to_ptr32): New function.

2005-02-09  Doug Rupp  <rupp@adacore.com>
	    Thomas Quinot  <quinot@adacore.com>

	* adaint.c, adaint.h
	[VMS] (to_ptr32): New function.
	(MAYBE_TO_PTR32): New macro.
	(__gnat_portable_spawn,__gnat_portable_no_block_spawn): Adjust argv
	for pointer size.
	[VMS] (descriptor_s, ile_s): Use __char_ptr32 for adr field.
	[VMS] (#define fork()): Remove since unneccessary.
	(__gnat_set_close_on_exec): New routine to support
	GNAT.OS_Lib.Set_Close_On_Exec.

	* g-expect.adb (Set_Up_Communications): Mark the pipe descriptors for
	the parent side as close-on-exec so that they are not inherited by the
	child.

	* g-os_lib.ads, g-os_lib.adb (Set_Close_On_Exec): New subprogram to
	set or clear the FD_CLOEXEC flag on a file descriptor.

From-SVN: r94811

gcc/ada/adaint.c

@@ -6,7 +6,7 @@
  *                                                                          *
  *                          C Implementation File                           *
  *                                                                          *
- *          Copyright (C) 1992-2004, Free Software Foundation, Inc.         *
+ *          Copyright (C) 1992-2005, Free Software Foundation, Inc.         *
  *                                                                          *
  * GNAT is free software;  you can  redistribute it  and/or modify it under *
  * terms of the  GNU General Public License as published  by the Free Soft- *
@@ -277,6 +277,37 @@ int max_path_len = GNAT_MAX_PATH_LEN;
    system provides the routine readdir_r.  */
 #undef HAVE_READDIR_R
 
+#if defined(VMS) && defined (__LONG_POINTERS)
+
+/* Return a 32 bit pointer to an array of 32 bit pointers
+   given a 64 bit pointer to an array of 64 bit pointers */
+
+typedef __char_ptr32 *__char_ptr_char_ptr32 __attribute__ ((mode (SI)));
+
+static __char_ptr_char_ptr32
+to_ptr32 (char **ptr64)
+{
+  int argc;
+  __char_ptr_char_ptr32 short_argv;
+
+  for (argc=0; ptr64[argc]; argc++);
+
+  /* Reallocate argv with 32 bit pointers. */
+  short_argv = (__char_ptr_char_ptr32) decc$malloc
+    (sizeof (__char_ptr32) * (argc + 1));
+
+  for (argc=0; ptr64[argc]; argc++)
+    short_argv[argc] = (__char_ptr32) decc$strdup (ptr64[argc]);
+
+  short_argv[argc] = (__char_ptr32) 0;
+  return short_argv;
+
+}
+#define MAYBE_TO_PTR32(argv) to_ptr32 (argv)
+#else
+#define MAYBE_TO_PTR32(argv) argv
+#endif
+
 void
 __gnat_to_gm_time
   (OS_Time *p_time,
@@ -1213,13 +1244,13 @@ static char *to_host_path_spec (char *);
 struct descriptor_s
 {
   unsigned short len, mbz;
-  char *adr;
+  __char_ptr32 adr;
 };
 
 typedef struct _ile3
 {
   unsigned short len, code;
-  char *adr;
+  __char_ptr32 adr;
   unsigned short *retlen_adr;
 } ile_s;
 
@@ -1524,17 +1555,6 @@ __gnat_is_symbolic_link (char *name ATTRIBUTE_UNUSED)
 #endif
 }
 
-#ifdef VMS
-/* Defined in VMS header files. */
-#if defined (__ALPHA)
-#define fork() (decc$$alloc_vfork_blocks() >= 0 ? \
-		LIB$GET_CURRENT_INVO_CONTEXT (decc$$get_vfork_jmpbuf()) : -1)
-#elif defined (__IA64)
-#define fork() (decc$$alloc_vfork_blocks() >= 0 ? \
-		LIB$I64_GET_CURR_INVO_CONTEXT(decc$$get_vfork_jmpbuf()) : -1)
-#endif
-#endif
-
 #if defined (sun) && defined (__SVR4)
 /* Using fork on Solaris will duplicate all the threads. fork1, which
    duplicates only the active thread, must be used instead, or spawning
@@ -1585,7 +1605,7 @@ __gnat_portable_spawn (char *args[])
   if (pid == 0)
     {
       /* The child. */
-      if (execv (args[0], args) != 0)
+      if (execv (args[0], MAYBE_TO_PTR32 (args)) != 0)
 #if defined (VMS)
 	return -1; /* execv is in parent context on VMS.  */
 #else
@@ -1866,7 +1886,7 @@ __gnat_portable_no_block_spawn (char *args[])
   if (pid == 0)
     {
       /* The child.  */
-      if (execv (args[0], args) != 0)
+      if (execv (args[0], MAYBE_TO_PTR32 (args)) != 0)
 #if defined (VMS)
 	return -1; /* execv is in parent context on VMS. */
 #else
@@ -2593,3 +2613,24 @@ get_gcc_version (void)
 {
   return 3;
 }
+
+int
+__gnat_set_close_on_exec (int fd, int close_on_exec_p)
+{
+#if defined (F_GETFD) && defined (FD_CLOEXEC) && ! defined (__vxworks)
+  int flags = fcntl (fd, F_GETFD, 0);
+  if (flags < 0)
+    return flags;
+  if (close_on_exec_p)
+    flags |= FD_CLOEXEC;
+  else
+    flags &= ~FD_CLOEXEC;
+  return fcntl (fd, F_SETFD, flags | FD_CLOEXEC);
+#else
+  return -1;
+  /* For the Windows case, we should use SetHandleInformation to remove
+     the HANDLE_INHERIT property from fd. This is not implemented yet,
+     but for our purposes (support of GNAT.Expect) this does not matter,
+     as by default handles are *not* inherited. */
+#endif
+}

gcc/ada/adaint.h

@@ -6,7 +6,7 @@
  *                                                                          *
  *                              C Header File                               *
  *                                                                          *
- *          Copyright (C) 1992-2004 Free Software Foundation, Inc.          *
+ *          Copyright (C) 1992-2005 Free Software Foundation, Inc.          *
  *                                                                          *
  * GNAT is free software;  you can  redistribute it  and/or modify it under *
  * terms of the  GNU General Public License as published  by the Free Soft- *
@@ -149,6 +149,7 @@ extern void   __gnat_set_binary_mode		   (int);
 extern void   __gnat_set_text_mode		   (int);
 extern char  *__gnat_ttyname			   (int);
 extern int    __gnat_lseek			   (int, long, int);
+extern int    __gnat_set_close_on_exec		   (int, int);
 extern int    __gnat_dup			   (int);
 extern int    __gnat_dup2			   (int, int);
 

gcc/ada/g-expect.adb

@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---           Copyright (C) 2000-2003 Ada Core Technologies, Inc.            --
+--           Copyright (C) 2000-2005 Ada Core Technologies, Inc.            --
 --                                                                          --
 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
 -- terms of the  GNU General Public License as published  by the Free Soft- --
@@ -1123,6 +1123,8 @@ package body GNAT.Expect is
       Pipe2      : access Pipe_Type;
       Pipe3      : access Pipe_Type)
    is
+      Status : Boolean;
+
    begin
       --  Create the pipes
 
@@ -1134,18 +1136,36 @@ package body GNAT.Expect is
          return;
       end if;
 
+      --  Record the 'parent' end of the two pipes in Pid:
+      --    Child stdin  is connected to the 'write' end of Pipe1;
+      --    Child stdout is connected to the 'read'  end of Pipe2.
+      --  We do not want these descriptors to remain open in the child
+      --  process, so we mark them close-on-exec/non-inheritable.
+
       Pid.Input_Fd  := Pipe1.Output;
+      Set_Close_On_Exec (Pipe1.Output, True, Status);
       Pid.Output_Fd := Pipe2.Input;
+      Set_Close_On_Exec (Pipe2.Input, True, Status);
 
       if Err_To_Out then
+
+         --  Reuse the standard output pipe for standard error
+
          Pipe3.all := Pipe2.all;
       else
+
+         --  Create a separate pipe for standard error
+
          if Create_Pipe (Pipe3) /= 0 then
             return;
          end if;
       end if;
 
+      --  As above, we record the proper fd for the child's
+      --  standard error stream.
+
       Pid.Error_Fd := Pipe3.Input;
+      Set_Close_On_Exec (Pipe3.Input, True, Status);
    end Set_Up_Communications;
 
    ----------------------------------

gcc/ada/g-os_lib.adb

@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---           Copyright (C) 1995-2004 Ada Core Technologies, Inc.            --
+--           Copyright (C) 1995-2005 Ada Core Technologies, Inc.            --
 --                                                                          --
 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
 -- terms of the  GNU General Public License as published  by the Free Soft- --
@@ -1075,7 +1075,7 @@ package body GNAT.OS_Lib is
       S  : Integer;
 
    begin
-      --  Use the global lock because To_GM_Time is not thread safe.
+      --  Use the global lock because To_GM_Time is not thread safe
 
       Locked_Processing : begin
          SSL.Lock_Task.all;
@@ -1920,7 +1920,7 @@ package body GNAT.OS_Lib is
             if Status <= 0 then
                Last := Finish + 1;
 
-            --  Replace symbolic link with its value.
+            --  Replace symbolic link with its value
 
             else
                if Is_Absolute_Path (Link_Buffer (1 .. Status)) then
@@ -2056,6 +2056,23 @@ package body GNAT.OS_Lib is
       Rename_File (C_Old_Name'Address, C_New_Name'Address, Success);
    end Rename_File;
 
+   -----------------------
+   -- Set_Close_On_Exec --
+   -----------------------
+
+   procedure Set_Close_On_Exec
+     (FD            : File_Descriptor;
+      Close_On_Exec : Boolean;
+      Status        : out Boolean)
+   is
+      function C_Set_Close_On_Exec
+        (FD : File_Descriptor; Close_On_Exec : System.CRTL.int)
+         return System.CRTL.int;
+      pragma Import (C, C_Set_Close_On_Exec, "__gnat_set_close_on_exec");
+   begin
+      Status := C_Set_Close_On_Exec (FD, Boolean'Pos (Close_On_Exec)) = 0;
+   end Set_Close_On_Exec;
+
    --------------------
    -- Set_Executable --
    --------------------
@@ -2186,7 +2203,7 @@ package body GNAT.OS_Lib is
          Dup2 (Saved_Error, Standerr);
       end if;
 
-      --  And close the saved standard output and error file descriptors.
+      --  And close the saved standard output and error file descriptors
 
       Close (Saved_Output);
 
@@ -2234,7 +2251,7 @@ package body GNAT.OS_Lib is
    is
 
       procedure Spawn (Args : Argument_List);
-      --  Call Spawn.
+      --  Call Spawn with given argument list
 
       N_Args : Argument_List (Args'Range);
       --  Normalized arguments