From ded462b0dea5615ac36e1256caffa5f2c7f5f1b8 Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Tue, 25 Apr 2017 11:25:40 +0200 Subject: [PATCH] [multiple changes] 2017-04-25 Gary Dismukes * exp_ch7.adb, einfo.ads, sem_prag.adb: Minor reformatting and typo correction. 2017-04-25 Yannick Moy * sem_res.adb (Resolve_Comparison_Op): Do not attempt evaluation of relational operations inside assertions. 2017-04-25 Justin Squirek * exp_util.adb (Add_Interface_Invariants): Restored, code moved back from Build_Invariant_Procedure_Body. (Add_Parent_Invariants): Restored, code moved back from Build_Invariant_Procedure_Body. (Build_Invariant_Procedure_Body): Remove refactored calls and integrated code from Add_Parent_Invariants and Add_Interface_Invariants. 2017-04-25 Johannes Kanig * errout.adb (Output_Messages): Adjust computation of total errors * erroutc.adb (Error_Msg): In statistics counts, deal correctly with informational messages that are not warnings. * errutil.adb (Finalize): adjust computation of total errors. 2017-04-25 Arnaud Charlet * terminals.c (__gnat_terminate_pid): New. * g-exptty.ads (Terminate_Process): New. Update comments. From-SVN: r247157 --- gcc/ada/ChangeLog | 33 +++++ gcc/ada/einfo.ads | 16 +-- gcc/ada/errout.adb | 2 +- gcc/ada/erroutc.adb | 13 +- gcc/ada/errutil.adb | 2 +- gcc/ada/exp_ch7.adb | 4 +- gcc/ada/exp_util.adb | 287 ++++++++++++++++++++++++++----------------- gcc/ada/g-exptty.adb | 13 +- gcc/ada/g-exptty.ads | 10 +- gcc/ada/sem_prag.adb | 2 +- gcc/ada/sem_res.adb | 11 +- gcc/ada/terminals.c | 58 +++++++++ 12 files changed, 314 insertions(+), 137 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 50e45b69d33..192e893f92a 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,36 @@ +2017-04-25 Gary Dismukes + + * exp_ch7.adb, einfo.ads, sem_prag.adb: Minor reformatting and typo + correction. + +2017-04-25 Yannick Moy + + * sem_res.adb (Resolve_Comparison_Op): Do not + attempt evaluation of relational operations inside assertions. + +2017-04-25 Justin Squirek + + * exp_util.adb (Add_Interface_Invariants): + Restored, code moved back from Build_Invariant_Procedure_Body. + (Add_Parent_Invariants): Restored, code moved back from + Build_Invariant_Procedure_Body. + (Build_Invariant_Procedure_Body): + Remove refactored calls and integrated code from + Add_Parent_Invariants and Add_Interface_Invariants. + +2017-04-25 Johannes Kanig + + * errout.adb (Output_Messages): Adjust computation of total + errors + * erroutc.adb (Error_Msg): In statistics counts, deal + correctly with informational messages that are not warnings. + * errutil.adb (Finalize): adjust computation of total errors. + +2017-04-25 Arnaud Charlet + + * terminals.c (__gnat_terminate_pid): New. + * g-exptty.ads (Terminate_Process): New. Update comments. + 2017-04-25 Arnaud Charlet * a-cfinve.ads, a-cofove.ads (Empty_Vector): add Global contract. diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index 9a0530d8da7..59990185489 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -3711,8 +3711,8 @@ package Einfo is -- Original_Access_Type (Node28) -- Defined in E_Access_Subprogram_Type entities. Set only if the access --- type was generated by the expander as part of processing an access --- to protected subprogram type. Points to the access to protected +-- type was generated by the expander as part of processing an access- +-- to-protected-subprogram type. Points to the access-to-protected- -- subprogram type. -- Original_Array_Type (Node21) @@ -4842,24 +4842,24 @@ package Einfo is -- keyword present. E_Access_Subprogram_Type, - -- An access to subprogram type, created by an access to subprogram + -- An access-to-subprogram type, created by an access-to-subprogram -- declaration. E_Access_Protected_Subprogram_Type, -- An access to a protected subprogram, created by the corresponding -- declaration. Values of such a type denote both a protected object -- and a protected operation within, and have different compile-time - -- and run-time properties than other access to subprograms. + -- and run-time properties than other access-to-subprogram values. E_Anonymous_Access_Protected_Subprogram_Type, - -- An anonymous access to protected subprogram type, created by an - -- access to subprogram declaration. + -- An anonymous access-to-protected-subprogram type, created by an + -- access-to-subprogram declaration. E_Anonymous_Access_Subprogram_Type, - -- An anonymous access to subprogram type, created by an access to + -- An anonymous access-to-subprogram type, created by an access-to- -- subprogram declaration, or generated for a current instance of -- a type name appearing within a component definition that has an - -- anonymous access to subprogram type. + -- anonymous access-to-subprogram type. E_Anonymous_Access_Type, -- An anonymous access type created by an access parameter or access diff --git a/gcc/ada/errout.adb b/gcc/ada/errout.adb index 40eaf91b942..ea806397dc9 100644 --- a/gcc/ada/errout.adb +++ b/gcc/ada/errout.adb @@ -2105,7 +2105,7 @@ package body Errout is if Warning_Mode = Treat_As_Error then Total_Errors_Detected := - Total_Errors_Detected + Warnings_Detected - Info_Messages; + Total_Errors_Detected + Warnings_Detected; Warnings_Detected := Info_Messages; end if; end Output_Messages; diff --git a/gcc/ada/erroutc.adb b/gcc/ada/erroutc.adb index ada93157af0..f637083cb06 100644 --- a/gcc/ada/erroutc.adb +++ b/gcc/ada/erroutc.adb @@ -139,13 +139,16 @@ package body Erroutc is -- Adjust error message count - if Errors.Table (D).Warn or else Errors.Table (D).Style then - Warnings_Detected := Warnings_Detected - 1; + if Errors.Table (D).Info then + Info_Messages := Info_Messages - 1; - if Errors.Table (D).Info then - Info_Messages := Info_Messages - 1; + if Errors.Table (D).Warn then + Warnings_Detected := Warnings_Detected - 1; end if; + elsif Errors.Table (D).Warn or else Errors.Table (D).Style then + Warnings_Detected := Warnings_Detected - 1; + -- Note: we do not need to decrement Warnings_Treated_As_Errors -- because this only gets incremented if we actually output the -- message, which we won't do if we are deleting it here! @@ -240,7 +243,7 @@ package body Erroutc is function Compilation_Errors return Boolean is begin return Total_Errors_Detected /= 0 - or else (Warnings_Detected - Info_Messages /= 0 + or else (Warnings_Detected /= 0 and then Warning_Mode = Treat_As_Error) or else Warnings_Treated_As_Errors /= 0; end Compilation_Errors; diff --git a/gcc/ada/errutil.adb b/gcc/ada/errutil.adb index 3a8f0fbf5d8..e10624fc3d7 100644 --- a/gcc/ada/errutil.adb +++ b/gcc/ada/errutil.adb @@ -588,7 +588,7 @@ package body Errutil is if Warning_Mode = Treat_As_Error then Total_Errors_Detected := - Total_Errors_Detected + Warnings_Detected - Info_Messages; + Total_Errors_Detected + Warnings_Detected; Warnings_Detected := Info_Messages; end if; diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb index 852ae444033..a3082e28b19 100644 --- a/gcc/ada/exp_ch7.adb +++ b/gcc/ada/exp_ch7.adb @@ -486,14 +486,14 @@ package body Exp_Ch7 is then return False; - -- Do not consider an access type which return on the secondary stack + -- Do not consider an access type that returns on the secondary stack elsif Present (Associated_Storage_Pool (Ptr_Typ)) and then Is_RTE (Associated_Storage_Pool (Ptr_Typ), RE_SS_Pool) then return False; - -- Do not consider an access type which may never allocate an object + -- Do not consider an access type that can never allocate an object elsif No_Pool_Assigned (Ptr_Typ) then return False; diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index 034df56907f..9f5224c49e1 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -1999,6 +1999,25 @@ package body Exp_Util is -- Obj_Id denotes the entity of the _object formal parameter of the -- invariant procedure. All created checks are added to list Checks. + procedure Add_Inherited_Invariant + (Full_Typ : Entity_Id; + Priv_Typ : Entity_Id; + Obj_Id : Entity_Id; + Checks : in out List_Id); + -- Generate an invariant check for each inherited class-wide invariant + -- coming from all parent types of type T. Obj_Id denotes the entity of + -- the _object formal parameter of the invariant procedure. All created + -- checks are added to list Checks. + + procedure Add_Interface_Invariants + (T : Entity_Id; + Obj_Id : Entity_Id; + Checks : in out List_Id); + -- Generate an invariant check for each inherited class-wide invariant + -- coming from all interfaces implemented by type T. Obj_Id denotes the + -- entity of the _object formal parameter of the invariant procedure. + -- All created checks are added to list Checks. + procedure Add_Invariant_Check (Prag : Node_Id; Expr : Node_Id; @@ -2009,15 +2028,6 @@ package body Exp_Util is -- is added to list Checks. Flag Inherited should be set when the pragma -- is inherited from a parent or interface type. - procedure Add_Inherited_Invariant - (T : Entity_Id; - Obj_Id : Entity_Id; - Checks : in out List_Id); - -- Generate an invariant check for each inherited class-wide invariant - -- coming from all parent types of type T. Obj_Id denotes the entity of - -- the _object formal parameter of the invariant procedure. All created - -- checks are added to list Checks. - procedure Add_Own_Invariant (T : Entity_Id; Obj_Id : Entity_Id; @@ -2028,6 +2038,15 @@ package body Exp_Util is -- invariant procedure. All created checks are added to list Checks. -- Priv_Item denotes the first rep item of the private type. + procedure Add_Parent_Invariants + (T : Entity_Id; + Obj_Id : Entity_Id; + Checks : in out List_Id); + -- Generate an invariant check for each inherited class-wide invariant + -- coming from all parent types of type T. Obj_Id denotes the entity of + -- the _object formal parameter of the invariant procedure. All created + -- checks are added to list Checks. + procedure Add_Record_Component_Invariants (T : Entity_Id; Obj_Id : Entity_Id; @@ -2197,9 +2216,10 @@ package body Exp_Util is ----------------------------- procedure Add_Inherited_Invariant - (T : Entity_Id; - Obj_Id : Entity_Id; - Checks : in out List_Id) + (Full_Typ : Entity_Id; + Priv_Typ : Entity_Id; + Obj_Id : Entity_Id; + Checks : in out List_Id) is Arg1 : Node_Id; Arg2 : Node_Id; @@ -2211,11 +2231,16 @@ package body Exp_Util is -- instance of a type with the _object formal parameter begin - if not Present (T) then + if not Present (Priv_Typ) and then not Present (Full_Typ) then return; end if; - Prag := First_Rep_Item (T); + if Present (Priv_Typ) then + Prag := First_Rep_Item (Priv_Typ); + else + Prag := First_Rep_Item (Full_Typ); + end if; + while Present (Prag) loop if Nkind (Prag) = N_Pragma and then Pragma_Name (Prag) = Name_Invariant @@ -2229,30 +2254,30 @@ package body Exp_Util is -- Extract the arguments of the invariant pragma Arg1 := First (Pragma_Argument_Associations (Prag)); - Arg2 := Next (Arg1); - + Arg2 := Get_Pragma_Arg (Next (Arg1)); Arg1 := Get_Pragma_Arg (Arg1); - Arg2 := Get_Pragma_Arg (Arg2); + + -- The pragma applies to the partial view + + if Present (Priv_Typ) and then Entity (Arg1) = Priv_Typ then + Rep_Typ := Priv_Typ; + + -- The pragma applies to the full view + + elsif Present (Full_Typ) and then Entity (Arg1) = Full_Typ then + Rep_Typ := Full_Typ; -- Otherwise the pragma applies to a parent type in which case -- it will be processed at a later stage by -- Add_Parent_Invariants or Add_Interface_Invariants. - if Entity (Arg1) = T then - Rep_Typ := Entity (Arg1); - - elsif Present (Full_View (T)) - and then Entity (Arg1) = Full_View (T) - then - Rep_Typ := Full_View (T); - else return; end if; - -- Nothing to do when the caller requests the processing of - -- all inherited class-wide invariants, but the pragma does - -- not fall in this category. + -- Nothing to do when the caller requests the processing of all + -- inherited class-wide invariants, but the pragma does not + -- fall in this category. if not Class_Present (Prag) then return; @@ -2275,6 +2300,42 @@ package body Exp_Util is end loop; end Add_Inherited_Invariant; + ------------------------------ + -- Add_Interface_Invariants -- + ------------------------------ + + procedure Add_Interface_Invariants + (T : Entity_Id; + Obj_Id : Entity_Id; + Checks : in out List_Id) + is + Iface_Elmt : Elmt_Id; + Ifaces : Elist_Id; + + begin + -- Generate an invariant check for each inherited class-wide + -- invariant coming from all interfaces implemented by type T. Obj_Id + -- denotes the entity of the _object formal parameter of the + -- invariant procedure. All created checks are added to list Checks. + + if Is_Tagged_Type (T) then + Collect_Interfaces (T, Ifaces); + + -- Process the class-wide invariants of all implemented interfaces + + Iface_Elmt := First_Elmt (Ifaces); + while Present (Iface_Elmt) loop + Add_Inherited_Invariant + (Full_Typ => Node (Iface_Elmt), + Priv_Typ => Empty, + Obj_Id => Obj_Id, + Checks => Checks); + + Next_Elmt (Iface_Elmt); + end loop; + end if; + end Add_Interface_Invariants; + ------------------------- -- Add_Invariant_Check -- ------------------------- @@ -2355,6 +2416,80 @@ package body Exp_Util is Produced_Check := True; end Add_Invariant_Check; + --------------------------- + -- Add_Parent_Invariants -- + --------------------------- + + procedure Add_Parent_Invariants + (T : Entity_Id; + Obj_Id : Entity_Id; + Checks : in out List_Id) + is + Dummy_1 : Entity_Id; + Dummy_2 : Entity_Id; + + Curr_Typ : Entity_Id; + -- The entity of the current type being examined + + Full_Typ : Entity_Id; + -- The full view of Par_Typ + + Par_Typ : Entity_Id; + -- The entity of the parent type + + Priv_Typ : Entity_Id; + -- The partial view of Par_Typ + + begin + -- Do not process array types because they cannot have true parent + -- types. This also prevents the generation of a duplicate invariant + -- check when the input type is an array base type because its Etype + -- denotes the first subtype, both of which share the same component + -- type. + + if Is_Array_Type (T) then + return; + end if; + + -- Climb the parent type chain + + Curr_Typ := T; + loop + -- Do not consider subtypes as they inherit the invariants + -- from their base types. + + Par_Typ := Base_Type (Etype (Curr_Typ)); + + -- Stop the climb once the root of the parent chain is + -- reached. + + exit when Curr_Typ = Par_Typ; + + -- Process the class-wide invariants of the parent type + + Get_Views (Par_Typ, Priv_Typ, Full_Typ, Dummy_1, Dummy_2); + + -- Process the elements of an array type + + if Is_Array_Type (Full_Typ) then + Add_Array_Component_Invariants (Full_Typ, Obj_Id, Checks); + + -- Process the components of a record type + + elsif Ekind (Full_Typ) = E_Record_Type then + Add_Record_Component_Invariants (Full_Typ, Obj_Id, Checks); + end if; + + Add_Inherited_Invariant + (Full_Typ => Full_Typ, + Priv_Typ => Priv_Typ, + Obj_Id => Obj_Id, + Checks => Checks); + + Curr_Typ := Par_Typ; + end loop; + end Add_Parent_Invariants; + ----------------------- -- Add_Own_Invariant -- ----------------------- @@ -2399,17 +2534,15 @@ package body Exp_Util is -- Extract the arguments of the invariant pragma Arg1 := First (Pragma_Argument_Associations (Prag)); - Arg2 := Next (Arg1); - + Arg2 := Get_Pragma_Arg (Next (Arg1)); Arg1 := Get_Pragma_Arg (Arg1); - Arg2 := Get_Pragma_Arg (Arg2); - Asp := Corresponding_Aspect (Prag); Ploc := Sloc (Prag); - -- Otherwise the pragma applies to a parent type in which case - -- it will be processed at a later stage by - -- Add_Parent_Invariants or Add_Interface_Invariants. + -- Verify the pragma belongs to T, otherwise the pragma applies + -- to a parent type in which case it will be processed at a + -- later stage by Add_Parent_Invariants or + -- Add_Interface_Invariants. if Entity (Arg1) /= T then return; @@ -2724,10 +2857,7 @@ package body Exp_Util is -- Local variables - Dummy_1 : Entity_Id; - Dummy_2 : Entity_Id; - Iface_Elmt : Elmt_Id; - Ifaces : Elist_Id; + Dummy : Entity_Id; Mode : Ghost_Mode_Type; Priv_Item : Node_Id; Proc_Body : Node_Id; @@ -2799,7 +2929,7 @@ package body Exp_Util is -- Obtain both views of the type - Get_Views (Work_Typ, Priv_Typ, Full_Typ, Dummy_1, CRec_Typ); + Get_Views (Work_Typ, Priv_Typ, Full_Typ, Dummy, CRec_Typ); -- The caller requests a body for the partial invariant procedure @@ -2991,81 +3121,12 @@ package body Exp_Util is -- Process the inherited class-wide invariants of all parent types. -- This also handles any invariants on record components. - declare - Curr_Typ : Entity_Id; - -- The entity of the current type being examined - - Par_Full : Entity_Id; - -- The full view of Par_Typ - - Par_Priv : Entity_Id; - -- The partial view of Par_Typ - - Par_Typ : Entity_Id; - -- The entity of the parent type - - begin - if not Is_Array_Type (Full_Typ) then - - -- Climb the parent type chain - - Curr_Typ := Full_Typ; - loop - -- Do not consider subtypes as they inherit the invariants - -- from their base types. - - Par_Typ := Base_Type (Etype (Curr_Typ)); - - -- Stop the climb once the root of the parent chain is - -- reached. + Add_Parent_Invariants (Full_Typ, Obj_Id, Stmts); - exit when Curr_Typ = Par_Typ; + -- Process the inherited class-wide invariants of all implemented + -- interface types. - -- Process the class-wide invariants of the parent type - - Get_Views (Par_Typ, Par_Priv, Par_Full, Dummy_1, Dummy_2); - - -- Process the elements of an array type - - if Is_Array_Type (Par_Full) then - Add_Array_Component_Invariants (Par_Full, Obj_Id, Stmts); - - -- Process the components of a record type - - elsif Ekind (Par_Full) = E_Record_Type then - Add_Record_Component_Invariants (Par_Full, Obj_Id, Stmts); - end if; - - Add_Inherited_Invariant - (T => Par_Priv, - Obj_Id => Obj_Id, - Checks => Stmts); - - Curr_Typ := Par_Typ; - end loop; - end if; - end; - - -- Generate an invariant check for each inherited class-wide - -- invariant coming from all interfaces implemented by type T. Obj_Id - -- denotes the entity of the _object formal parameter of the - -- invariant procedure. All created checks are added to list Checks. - - if Is_Tagged_Type (Full_Typ) then - Collect_Interfaces (Full_Typ, Ifaces); - - -- Process the class-wide invariants of all implemented interfaces - - Iface_Elmt := First_Elmt (Ifaces); - while Present (Iface_Elmt) loop - Add_Inherited_Invariant - (T => Node (Iface_Elmt), - Obj_Id => Obj_Id, - Checks => Stmts); - - Next_Elmt (Iface_Elmt); - end loop; - end if; + Add_Interface_Invariants (Full_Typ, Obj_Id, Stmts); end if; End_Scope; diff --git a/gcc/ada/g-exptty.adb b/gcc/ada/g-exptty.adb index 8b7fd6ee268..00615f9e883 100644 --- a/gcc/ada/g-exptty.adb +++ b/gcc/ada/g-exptty.adb @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2000-2014, AdaCore -- +-- Copyright (C) 2000-2016, AdaCore -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -147,6 +147,17 @@ package body GNAT.Expect.TTY is Internal (Pid); end Interrupt; + ----------------------- + -- Terminate_Process -- + ----------------------- + + procedure Terminate_Process (Pid : Integer) is + procedure Internal (Pid : Integer); + pragma Import (C, Internal, "__gnat_terminate_pid"); + begin + Internal (Pid); + end Terminate_Process; + ----------------------- -- Pseudo_Descriptor -- ----------------------- diff --git a/gcc/ada/g-exptty.ads b/gcc/ada/g-exptty.ads index e218e0b5d54..10e0f81147e 100644 --- a/gcc/ada/g-exptty.ads +++ b/gcc/ada/g-exptty.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2000-2011, AdaCore -- +-- Copyright (C) 2000-2016, AdaCore -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -64,7 +64,13 @@ package GNAT.Expect.TTY is -- GNAT.TTY.Close_TTY. procedure Interrupt (Pid : Integer); - -- Interrupt a process given its pid + -- Interrupt a process given its pid. + -- This is equivalent to sending a ctrl-c event, or kill -SIGINT. + + procedure Terminate_Process (Pid : Integer); + -- Terminate abruptly a process given its pid. + -- This is equivalent to kill -SIGKILL under unix, or TerminateProcess + -- under Windows. overriding procedure Send (Descriptor : in out TTY_Process_Descriptor; diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index 0029c6a80a8..c00e86b1402 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -17922,7 +17922,7 @@ package body Sem_Prag is if Is_Library_Level_Entity (Typ) then null; - -- Qietly ignore an access-to-object type originally declared + -- Quietly ignore an access-to-object type originally declared -- at the library level within a generic, but instantiated at -- a non-library level. As a result the access-to-object type -- "loses" its No_Heap_Finalization property. diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index 337b1228ab1..5a0797ecb54 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -6898,11 +6898,16 @@ package body Sem_Res is N, Etype (L)); end if; + Analyze_Dimension (N); + -- Evaluate the relation (note we do this after the above check since - -- this Eval call may change N to True/False. + -- this Eval call may change N to True/False. Skip this evaluation + -- inside assertions, in order to keep assertions as written by users + -- for tools that rely on these, e.g. GNATprove for loop invariants. - Analyze_Dimension (N); - Eval_Relational_Op (N); + if In_Assertion_Expr = 0 then + Eval_Relational_Op (N); + end if; end Resolve_Comparison_Op; ----------------------------------------- diff --git a/gcc/ada/terminals.c b/gcc/ada/terminals.c index 35cd7430bb8..9133a3bd88c 100644 --- a/gcc/ada/terminals.c +++ b/gcc/ada/terminals.c @@ -89,6 +89,12 @@ __gnat_terminate_process (void *desc ATTRIBUTE_UNUSED) return -1; } +int +__gnat_terminate_pid (int pid ATTRIBUTE_UNUSED) +{ + return -1; +} + int __gnat_tty_fd (void* t ATTRIBUTE_UNUSED) { @@ -962,6 +968,47 @@ __gnat_terminate_process (struct TTY_Process* p) return 0; } +typedef struct { + DWORD dwProcessId; + HANDLE hwnd; +} pid_struct; + +static BOOL CALLBACK +find_process_handle (HWND hwnd, pid_struct * ps) +{ + DWORD thread_id; + DWORD process_id; + + thread_id = GetWindowThreadProcessId (hwnd, &process_id); + if (process_id == ps->dwProcessId) + { + ps->hwnd = hwnd; + return FALSE; + } + /* keep looking */ + return TRUE; +} + +int +__gnat_terminate_pid (int pid) +{ + pid_struct ps; + + ps.dwProcessId = pid; + ps.hwnd = 0; + EnumWindows ((WNDENUMPROC) find_process_handle, (LPARAM) &ps); + + if (ps.hwnd) + { + if (!TerminateProcess (ps.hwnd, 1)) + return -1; + else + return 0; + } + + return -1; +} + /* wait for process pid to terminate and return the process status. This implementation is different from the adaint.c one for Windows as it uses the Win32 API instead of the C one. */ @@ -1500,6 +1547,17 @@ int __gnat_terminate_process (pty_desc *desc) return kill (desc->child_pid, SIGKILL); } +/* __gnat_terminate_pid - kill a process + * + * PARAMETERS + * pid unix process id + */ +int +__gnat_terminate_pid (int pid) +{ + return kill (pid, SIGKILL); +} + /* __gnat_tty_waitpid - wait for the child process to die * * PARAMETERS -- 2.30.2