[Ada] GNAT.OS_Lib clean ups/improvements
Arnaud Charlet
charlet@adacore.com
Fri Nov 19 10:47:00 GMT 2004
Tested on x86-linux + manual checks on ppc-darwin and x86-windows
Committed on mainline.
Various clean ups related to GNAT.OS_Lib:
First, an issue appeared under Windows 2000 where launching
gnatmake in low priority (start /low gnatmake) launched gcc
subprocesses at normal priorities instead of inheriting gnatmake's
priority.
Then, we're adding in package GNAT.OS_Lib two new Spawn functions.
These procedures redirect the output from the spawned
program into either a file descriptor, or a file.
Finally, fix the fact that GNAT.OS_Lib.Is_Symbolic_Link did not work under
Darwin.
2004-11-18 Arnaud Charlet <charlet@adacore.com>
* adaint.h, adaint.c
(__gnat_portable_spawn): Fix cast of spawnvp third parameter
to avoid warnings.
Add also a cast to kill another warning.
(win32_no_block_spawn): Initialize CreateProcess's dwCreationFlags
parameter with the priority class of the parent process instead of
always using the NORMAL_PRIORITY_CLASS.
(__gnat_dup): New function.
(__gnat_dup2): New function.
(__gnat_is_symbolic_link): Enable the effective body of this
function when __APPLE__ is defined.
* g-os_lib.ads, g-os_lib.adb (Spawn): Two new procedures.
Update comments.
-------------- next part --------------
Index: adaint.h
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/adaint.h,v
retrieving revision 1.19
diff -u -p -r1.19 adaint.h
--- adaint.h 5 May 2004 10:09:54 -0000 1.19
+++ adaint.h 19 Nov 2004 10:34:32 -0000
@@ -147,6 +147,8 @@ extern void __gnat_set_binary_mode
extern void __gnat_set_text_mode (int);
extern char *__gnat_ttyname (int);
extern int __gnat_lseek (int, long, int);
+extern int __gnat_dup (int);
+extern int __gnat_dup2 (int, int);
#ifdef __MINGW32__
extern void __gnat_plist_init (void);
Index: adaint.c
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/adaint.c,v
retrieving revision 1.39
diff -u -p -r1.39 adaint.c
--- adaint.c 27 Oct 2004 12:28:43 -0000 1.39
+++ adaint.c 19 Nov 2004 10:34:32 -0000
@@ -1512,7 +1512,7 @@ __gnat_is_symbolic_link (char *name ATTR
#if defined (__vxworks)
return 0;
-#elif defined (_AIX) || defined (__unix__)
+#elif defined (_AIX) || defined (__APPLE__) || defined (__unix__)
int ret;
struct stat statbuf;
@@ -1557,11 +1557,11 @@ __gnat_portable_spawn (char *args[])
strcat (args[0], args_0);
strcat (args[0], "\"");
- status = spawnvp (P_WAIT, args_0, (const char* const*)args);
+ status = spawnvp (P_WAIT, args_0, (char* const*)args);
/* restore previous value */
free (args[0]);
- args[0] = args_0;
+ args[0] = (char *)args_0;
if (status < 0)
return -1;
@@ -1606,6 +1606,34 @@ __gnat_portable_spawn (char *args[])
return 0;
}
+/* Create a copy of the given file descriptor.
+ Return -1 if an error occurred. */
+
+int
+__gnat_dup (int oldfd)
+{
+#if defined (__vxworks)
+ /* Not supported on VxWorks. */
+ return -1;
+#else
+ return dup (oldfd);
+#endif
+}
+
+/* Make newfd be the copy of oldfd, closing newfd first if necessary.
+ Return -1 if an error occured. */
+
+int
+__gnat_dup2 (int oldfd, int newfd)
+{
+#if defined (__vxworks)
+ /* Not supported on VxWorks. */
+ return -1;
+#else
+ return dup2 (oldfd, newfd);
+#endif
+}
+
/* WIN32 code to implement a wait call that wait for any child process. */
#ifdef _WIN32
@@ -1743,8 +1771,9 @@ win32_no_block_spawn (char *command, cha
k++;
}
- result = CreateProcess (NULL, (char *) full_command, &SA, NULL, TRUE,
- NORMAL_PRIORITY_CLASS, NULL, NULL, &SI, &PI);
+ result = CreateProcess
+ (NULL, (char *) full_command, &SA, NULL, TRUE,
+ GetPriorityClass (GetCurrentProcess()), NULL, NULL, &SI, &PI);
free (full_command);
Index: g-os_lib.ads
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/g-os_lib.ads,v
retrieving revision 1.15
diff -u -p -r1.15 g-os_lib.ads
--- g-os_lib.ads 27 Oct 2004 13:03:37 -0000 1.15
+++ g-os_lib.ads 19 Nov 2004 10:34:32 -0000
@@ -420,12 +420,12 @@ pragma Elaborate_Body (OS_Lib);
-- returns an empty string.
--
-- For case-sensitive file systems, the value of Case_Sensitive parameter
- -- is ignored. In systems that have a non case-sensitive file system like
- -- Windows and OpenVMS, if this parameter is set OFF, then the result
- -- is returned folded to lower case, this allows to checks if two files
- -- are the same by applying this function to their names and by comparing
- -- the results of these calls. If Case_Sensitive is ON, this function does
- -- not change the casing of file and directory names.
+ -- is ignored. For file systems that are not case-sensitive, such as
+ -- Windows and OpenVMS, if this parameter is set to False, then the file
+ -- and directory names are folded to lower case. This allows checking
+ -- whether two files are the same by applying this function to their names
+ -- and comparing the results. If Case_Sensitive is set to True, this
+ -- function does not change the casing of file and directory names.
function Is_Absolute_Path (Name : String) return Boolean;
-- Returns True if Name is an absolute path name, i.e. it designates
@@ -652,7 +652,38 @@ pragma Elaborate_Body (OS_Lib);
-- operating systems which have no notion of separately spawnable programs.
--
-- "Spawn" should not be used in tasking applications.
+
+ procedure Spawn
+ (Program_Name : String;
+ Args : Argument_List;
+ Output_File_Descriptor : File_Descriptor;
+ Return_Code : out Integer;
+ Err_To_Out : Boolean := True);
+ -- 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.
+ --
+ -- Return_Code is set to the status code returned by the operating
+ -- system as described above.
+ --
+ -- "Spawn" should not be used in tasking applications.
+
+ procedure Spawn
+ (Program_Name : String;
+ Args : Argument_List;
+ Output_File : String;
+ Success : out Boolean;
+ Return_Code : out Integer;
+ Err_To_Out : Boolean := True);
+ -- 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. If Success is True, then
+ -- Return_Code will be set to the status code returned by the
+ -- operating system. Otherwise, Return_Code is undefined.
--
+ -- "Spawn" should not be used in tasking applications.
type Process_Id is private;
-- A private type used to identify a process activated by the following
Index: g-os_lib.adb
===================================================================
RCS file: /cvs/gcc/gcc/gcc/ada/g-os_lib.adb,v
retrieving revision 1.16
diff -u -p -r1.16 g-os_lib.adb
--- g-os_lib.adb 27 Oct 2004 13:03:37 -0000 1.16
+++ g-os_lib.adb 19 Nov 2004 10:34:32 -0000
@@ -2143,6 +2143,80 @@ package body GNAT.OS_Lib is
Success := (Spawn (Program_Name, Args) = 0);
end Spawn;
+ procedure Spawn
+ (Program_Name : String;
+ Args : Argument_List;
+ Output_File_Descriptor : File_Descriptor;
+ 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;
+
+ begin
+ -- Set standard output and 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
+
+ Return_Code := 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;
+ end Spawn;
+
+ procedure Spawn
+ (Program_Name : String;
+ Args : Argument_List;
+ Output_File : String;
+ Success : out Boolean;
+ Return_Code : out Integer;
+ Err_To_Out : Boolean := True)
+ is
+ FD : File_Descriptor;
+
+ begin
+ Success := True;
+ Return_Code := 0;
+
+ FD := Create_Output_Text_File (Output_File);
+
+ if FD = Invalid_FD then
+ Success := False;
+ return;
+ end if;
+
+ Spawn (Program_Name, Args, FD, Return_Code, Err_To_Out);
+
+ Close (FD, Success);
+ end Spawn;
+
--------------------
-- Spawn_Internal --
--------------------
More information about the Gcc-patches
mailing list