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------------------------------------------------------------------------------ 31 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. 35 36-- This version is for Alpha/VMS 37 38separate (GNAT.Expect) 39procedure 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) 45is 46 function Alloc_Vfork_Blocks return Integer; 47 pragma Import (C, Alloc_Vfork_Blocks, "decc$$alloc_vfork_blocks"); 48 49 function Get_Vfork_Jmpbuf return System.Address; 50 pragma Import (C, Get_Vfork_Jmpbuf, "decc$$get_vfork_jmpbuf"); 51 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"); 56 57 Pipe1, Pipe2, Pipe3 : aliased Pipe_Type; 58 59 Arg : String_Access; 60 Arg_List : aliased array (1 .. Args'Length + 2) of System.Address; 61 62 Command_With_Path : String_Access; 63 64begin 65 -- Create the rest of the pipes 66 67 Set_Up_Communications 68 (Descriptor, Err_To_Out, Pipe1'Access, Pipe2'Access, Pipe3'Access); 69 70 Command_With_Path := Locate_Exec_On_Path (Command); 71 72 if Command_With_Path = null then 73 raise Invalid_Process; 74 end if; 75 76 -- Fork a new process (it is not possible to do this in a subprogram) 77 78 Descriptor.Pid := 79 (if Alloc_Vfork_Blocks >= 0 80 then Get_Current_Invo_Context (Get_Vfork_Jmpbuf) else -1); 81 82 -- Are we now in the child 83 84 if Descriptor.Pid = Null_Pid then 85 86 -- Prepare an array of arguments to pass to C 87 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; 92 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; 99 100 Arg_List (Arg_List'Last) := System.Null_Address; 101 102 -- This does not return on Unix systems 103 104 Set_Up_Child_Communications 105 (Descriptor, Pipe1, Pipe2, Pipe3, Command_With_Path.all, 106 Arg_List'Address); 107 end if; 108 109 Free (Command_With_Path); 110 111 -- Did we have an error when spawning the child ? 112 113 if Descriptor.Pid < Null_Pid then 114 raise Invalid_Process; 115 else 116 -- We are now in the parent process 117 118 Set_Up_Parent_Communications (Descriptor, Pipe1, Pipe2, Pipe3); 119 end if; 120 121 -- Create the buffer 122 123 Descriptor.Buffer_Size := Buffer_Size; 124 125 if Buffer_Size /= 0 then 126 Descriptor.Buffer := new String (1 .. Positive (Buffer_Size)); 127 end if; 128end Non_Blocking_Spawn; 129