Implement -mmemcpy-strategy= and -mmemset-strategy= options
[official-gcc.git] / gcc / ada / g-enblsp-vms-alpha.adb
blobf932a075b88f9d6d8f66816af2aba91309c004e7
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT COMPILER COMPONENTS --
4 -- --
5 -- G N A T . E X P E C T . N O N _ B L O C K I N G _ S P A W N --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 2005-2010, AdaCore --
10 -- --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. --
17 -- --
18 -- As a special exception under Section 7 of GPL version 3, you are granted --
19 -- additional permissions described in the GCC Runtime Library Exception, --
20 -- version 3.1, as published by the Free Software Foundation. --
21 -- --
22 -- You should have received a copy of the GNU General Public License and --
23 -- a copy of the GCC Runtime Library Exception along with this program; --
24 -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
25 -- <http://www.gnu.org/licenses/>. --
26 -- --
27 -- GNAT was originally developed by the GNAT team at New York University. --
28 -- Extensive contributions were provided by Ada Core Technologies Inc. --
29 -- --
30 ------------------------------------------------------------------------------
32 -- This package provides a target dependent non-blocking spawn function
33 -- for use by the VMS GNAT.Expect package (g-expect-vms.adb). This package
34 -- should not be directly with'ed by an application program.
36 -- This version is for Alpha/VMS
38 separate (GNAT.Expect)
39 procedure Non_Blocking_Spawn
40 (Descriptor : out Process_Descriptor'Class;
41 Command : String;
42 Args : GNAT.OS_Lib.Argument_List;
43 Buffer_Size : Natural := 4096;
44 Err_To_Out : Boolean := False)
46 function Alloc_Vfork_Blocks return Integer;
47 pragma Import (C, Alloc_Vfork_Blocks, "decc$$alloc_vfork_blocks");
49 function Get_Vfork_Jmpbuf return System.Address;
50 pragma Import (C, Get_Vfork_Jmpbuf, "decc$$get_vfork_jmpbuf");
52 function Get_Current_Invo_Context
53 (Addr : System.Address) return Process_Id;
54 pragma Import (C, Get_Current_Invo_Context,
55 "LIB$GET_CURRENT_INVO_CONTEXT");
57 Pipe1, Pipe2, Pipe3 : aliased Pipe_Type;
59 Arg : String_Access;
60 Arg_List : aliased array (1 .. Args'Length + 2) of System.Address;
62 Command_With_Path : String_Access;
64 begin
65 -- Create the rest of the pipes
67 Set_Up_Communications
68 (Descriptor, Err_To_Out, Pipe1'Access, Pipe2'Access, Pipe3'Access);
70 Command_With_Path := Locate_Exec_On_Path (Command);
72 if Command_With_Path = null then
73 raise Invalid_Process;
74 end if;
76 -- Fork a new process (it is not possible to do this in a subprogram)
78 Descriptor.Pid :=
79 (if Alloc_Vfork_Blocks >= 0
80 then Get_Current_Invo_Context (Get_Vfork_Jmpbuf) else -1);
82 -- Are we now in the child
84 if Descriptor.Pid = Null_Pid then
86 -- Prepare an array of arguments to pass to C
88 Arg := new String (1 .. Command_With_Path'Length + 1);
89 Arg (1 .. Command_With_Path'Length) := Command_With_Path.all;
90 Arg (Arg'Last) := ASCII.NUL;
91 Arg_List (1) := Arg.all'Address;
93 for J in Args'Range loop
94 Arg := new String (1 .. Args (J)'Length + 1);
95 Arg (1 .. Args (J)'Length) := Args (J).all;
96 Arg (Arg'Last) := ASCII.NUL;
97 Arg_List (J + 2 - Args'First) := Arg.all'Address;
98 end loop;
100 Arg_List (Arg_List'Last) := System.Null_Address;
102 -- This does not return on Unix systems
104 Set_Up_Child_Communications
105 (Descriptor, Pipe1, Pipe2, Pipe3, Command_With_Path.all,
106 Arg_List'Address);
107 end if;
109 Free (Command_With_Path);
111 -- Did we have an error when spawning the child ?
113 if Descriptor.Pid < Null_Pid then
114 raise Invalid_Process;
115 else
116 -- We are now in the parent process
118 Set_Up_Parent_Communications (Descriptor, Pipe1, Pipe2, Pipe3);
119 end if;
121 -- Create the buffer
123 Descriptor.Buffer_Size := Buffer_Size;
125 if Buffer_Size /= 0 then
126 Descriptor.Buffer := new String (1 .. Positive (Buffer_Size));
127 end if;
128 end Non_Blocking_Spawn;