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 IA64/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 Setjmp1 (Addr : System.Address) return Process_Id; 53 pragma Import (C, Setjmp1, "decc$setjmp1"); 54 55 Pipe1, Pipe2, Pipe3 : aliased Pipe_Type; 56 57 Arg : String_Access; 58 Arg_List : aliased array (1 .. Args'Length + 2) of System.Address; 59 60 Command_With_Path : String_Access; 61 62begin 63 -- Create the rest of the pipes 64 65 Set_Up_Communications 66 (Descriptor, Err_To_Out, Pipe1'Access, Pipe2'Access, Pipe3'Access); 67 68 Command_With_Path := Locate_Exec_On_Path (Command); 69 70 if Command_With_Path = null then 71 raise Invalid_Process; 72 end if; 73 74 -- Fork a new process (it is not possible to do this in a subprogram) 75 76 Descriptor.Pid := 77 (if Alloc_Vfork_Blocks >= 0 then Setjmp1 (Get_Vfork_Jmpbuf) else -1); 78 79 -- Are we now in the child 80 81 if Descriptor.Pid = Null_Pid then 82 83 -- Prepare an array of arguments to pass to C 84 85 Arg := new String (1 .. Command_With_Path'Length + 1); 86 Arg (1 .. Command_With_Path'Length) := Command_With_Path.all; 87 Arg (Arg'Last) := ASCII.NUL; 88 Arg_List (1) := Arg.all'Address; 89 90 for J in Args'Range loop 91 Arg := new String (1 .. Args (J)'Length + 1); 92 Arg (1 .. Args (J)'Length) := Args (J).all; 93 Arg (Arg'Last) := ASCII.NUL; 94 Arg_List (J + 2 - Args'First) := Arg.all'Address; 95 end loop; 96 97 Arg_List (Arg_List'Last) := System.Null_Address; 98 99 -- This does not return on Unix systems 100 101 Set_Up_Child_Communications 102 (Descriptor, Pipe1, Pipe2, Pipe3, Command_With_Path.all, 103 Arg_List'Address); 104 end if; 105 106 Free (Command_With_Path); 107 108 -- Did we have an error when spawning the child ? 109 110 if Descriptor.Pid < Null_Pid then 111 raise Invalid_Process; 112 else 113 -- We are now in the parent process 114 115 Set_Up_Parent_Communications (Descriptor, Pipe1, Pipe2, Pipe3); 116 end if; 117 118 -- Create the buffer 119 120 Descriptor.Buffer_Size := Buffer_Size; 121 122 if Buffer_Size /= 0 then 123 Descriptor.Buffer := new String (1 .. Positive (Buffer_Size)); 124 end if; 125end Non_Blocking_Spawn; 126