diff options
| -rw-r--r-- | gcc/ada/g-os_lib.adb | 124 | ||||
| -rw-r--r-- | gcc/ada/g-os_lib.ads | 36 |
2 files changed, 148 insertions, 12 deletions
diff --git a/gcc/ada/g-os_lib.adb b/gcc/ada/g-os_lib.adb index 65213cd5247..a9460bdff4e 100644 --- a/gcc/ada/g-os_lib.adb +++ b/gcc/ada/g-os_lib.adb @@ -35,20 +35,32 @@ with System.Case_Util; with System.CRTL; with System.Soft_Links; with Unchecked_Conversion; +with Unchecked_Deallocation; with System; use System; package body GNAT.OS_Lib is + -- Imported procedures Dup and Dup2 are used in procedures Spawn and + -- Non_Blocking_Spawn. + + function Dup (Fd : File_Descriptor) return File_Descriptor; + pragma Import (C, Dup, "__gnat_dup"); + + procedure Dup2 (Old_Fd, New_Fd : File_Descriptor); + pragma Import (C, Dup2, "__gnat_dup2"); + OpenVMS : Boolean; -- Note: OpenVMS should be a constant, but it cannot be, because it -- prevents bootstrapping on some platforms. - On_Windows : constant Boolean := Directory_Separator = '\'; - pragma Import (Ada, OpenVMS, "system__openvms"); -- Needed to avoid doing useless checks when non on a VMS platform (see -- Normalize_Pathname). + On_Windows : constant Boolean := Directory_Separator = '\'; + -- An indication that we are on Windows. Used in Normalize_Pathname, to + -- deal with drive letters in the beginning of absolute paths. + package SSL renames System.Soft_Links; -- The following are used by Create_Temp_File @@ -354,19 +366,28 @@ package body GNAT.OS_Lib is procedure Copy (From, To : File_Descriptor) is Buf_Size : constant := 200_000; - Buffer : array (1 .. Buf_Size) of Character; - R : Integer; - W : Integer; + type Buf is array (1 .. Buf_Size) of Character; + type Buf_Ptr is access Buf; + + Buffer : Buf_Ptr; + R : Integer; + W : Integer; Status_From : Boolean; Status_To : Boolean; -- Statuses for the calls to Close + procedure Free is new Unchecked_Deallocation (Buf, Buf_Ptr); + begin if From = Invalid_FD or else To = Invalid_FD then raise Copy_Error; end if; + -- Allocate the buffer on the heap + + Buffer := new Buf; + loop R := Read (From, Buffer (1)'Address, Buf_Size); @@ -386,6 +407,8 @@ package body GNAT.OS_Lib is Close (From, Status_From); Close (To, Status_To); + Free (Buffer); + raise Copy_Error; end if; end loop; @@ -393,6 +416,8 @@ package body GNAT.OS_Lib is Close (From, Status_From); Close (To, Status_To); + Free (Buffer); + if not (Status_From and Status_To) then raise Copy_Error; end if; @@ -1334,6 +1359,89 @@ package body GNAT.OS_Lib is return Pid; end Non_Blocking_Spawn; + function Non_Blocking_Spawn + (Program_Name : String; + Args : Argument_List; + Output_File_Descriptor : File_Descriptor; + Err_To_Out : Boolean := True) + return Process_Id + is + Saved_Output : File_Descriptor; + Saved_Error : File_Descriptor := Invalid_FD; + -- We need to initialize Saved_Error to Invalid_FD to avoid + -- a compiler warning that this variable may be used before + -- it is initialized (which can not happen, but the compiler + -- is not smart enough to figure this out). + Pid : Process_Id; + begin + if Output_File_Descriptor = Invalid_FD then + return Invalid_Pid; + end if; + + -- Set standard output and, if specified, error to the temporary file + Saved_Output := Dup (Standout); + Dup2 (Output_File_Descriptor, Standout); + + if Err_To_Out then + Saved_Error := Dup (Standerr); + Dup2 (Output_File_Descriptor, Standerr); + end if; + + -- Spawn the program + + Pid := Non_Blocking_Spawn (Program_Name, Args); + + -- Restore the standard output and error + + Dup2 (Saved_Output, Standout); + + if Err_To_Out then + Dup2 (Saved_Error, Standerr); + end if; + + -- And close the saved standard output and error file descriptors + + Close (Saved_Output); + + if Err_To_Out then + Close (Saved_Error); + end if; + + return Pid; + end Non_Blocking_Spawn; + + function Non_Blocking_Spawn + (Program_Name : String; + Args : Argument_List; + Output_File : String; + Err_To_Out : Boolean := True) + return Process_Id + is + Output_File_Descriptor : constant File_Descriptor := + Create_Output_Text_File (Output_File); + Result : Process_Id; + + begin + -- Do not attempt to spawn if the output file could not be created + + if Output_File_Descriptor = Invalid_FD then + return Invalid_Pid; + + else + Result := Non_Blocking_Spawn + (Program_Name, Args, Output_File_Descriptor, Err_To_Out); + + -- Close the file just created for the output, as the file descriptor + -- cannot be used anywhere, being a local value. It is safe to do + -- that, as the file descriptor has been duplicated to form + -- standard output and error of the spawned process. + + Close (Output_File_Descriptor); + + return Result; + end if; + end Non_Blocking_Spawn; + ------------------------- -- Normalize_Arguments -- ------------------------- @@ -2167,12 +2275,6 @@ package body GNAT.OS_Lib is Return_Code : out Integer; Err_To_Out : Boolean := True) is - function Dup (Fd : File_Descriptor) return File_Descriptor; - pragma Import (C, Dup, "__gnat_dup"); - - procedure Dup2 (Old_Fd, New_Fd : File_Descriptor); - pragma Import (C, Dup2, "__gnat_dup2"); - Saved_Output : File_Descriptor; Saved_Error : File_Descriptor := Invalid_FD; -- We need to initialize Saved_Error to Invalid_FD to avoid diff --git a/gcc/ada/g-os_lib.ads b/gcc/ada/g-os_lib.ads index fa094b088c7..5c67c7ad7a7 100644 --- a/gcc/ada/g-os_lib.ads +++ b/gcc/ada/g-os_lib.ads @@ -114,7 +114,6 @@ package GNAT.OS_Lib is subtype Second_Type is Integer range 0 .. 59; -- Declarations similar to those in Calendar, breaking down the time - function GM_Year (Date : OS_Time) return Year_Type; function GM_Month (Date : OS_Time) return Month_Type; function GM_Day (Date : OS_Time) return Day_Type; @@ -715,6 +714,41 @@ package GNAT.OS_Lib is -- This function will always return Invalid_Id under VxWorks, since there -- is no notion of executables under this OS. + function Non_Blocking_Spawn + (Program_Name : String; + Args : Argument_List; + Output_File_Descriptor : File_Descriptor; + Err_To_Out : Boolean := True) + return Process_Id; + -- Similar to the procedure above, but redirects the output to the file + -- designated by Output_File_Descriptor. If Err_To_Out is True, then the + -- Standard Error output is also redirected. Invalid_Id is returned + -- if the program could not be spawned successfully. + -- + -- "Non_Blocking_Spawn" should not be used in tasking applications. + -- + -- This function will always return Invalid_Id under VxWorks, since there + -- is no notion of executables under this OS. + + function Non_Blocking_Spawn + (Program_Name : String; + Args : Argument_List; + Output_File : String; + Err_To_Out : Boolean := True) + return Process_Id; + -- Similar to the procedure above, but saves the output of the command to + -- a file with the name Output_File. + -- + -- Success is set to True if the command is executed and its output + -- successfully written to the file. Invalid_Id is returned if the output + -- file could not be created or if the program could not be spawned + -- successfully. + -- + -- "Non_Blocking_Spawn" should not be used in tasking applications. + -- + -- This function will always return Invalid_Id under VxWorks, since there + -- is no notion of executables under this OS. + procedure Wait_Process (Pid : out Process_Id; Success : out Boolean); -- Wait for the completion of any of the processes created by previous -- calls to Non_Blocking_Spawn. The caller will be suspended until one of |