From a3d1ca0127cf4ca6bb8d0da5a525d17dfc58cbc9 Mon Sep 17 00:00:00 2001 From: Hristian Kirtchev Date: Thu, 11 Jul 2019 08:01:39 +0000 Subject: [PATCH] [Ada] Missing finalization of private protected type This patch updates the analysis of protected types to properly mark the type as having controlled components when it contains at least one such component. This in turn marks a potential partial view as requiring finalization actions. ------------ -- Source -- ------------ -- types.ads with Ada.Finalization; use Ada.Finalization; package Types is type Ctrl_Typ is new Controlled with null record; procedure Finalize (Obj : in out Ctrl_Typ); type Prot_Typ is limited private; private protected type Prot_Typ is private Comp : Ctrl_Typ; end Prot_Typ; end Types; -- types.adb with Ada.Text_IO; use Ada.Text_IO; package body Types is procedure Finalize (Obj : in out Ctrl_Typ) is begin Put_Line ("finalize"); end Finalize; protected body Prot_Typ is end Prot_Typ; end Types; -- main.adb with Types; use Types; procedure Main is Obj : Prot_Typ; begin null; end Main; 2019-07-11 Hristian Kirtchev gcc/ada/ * exp_util.ads, exp_util.adb (Needs_Finalization): Move to Sem_Util. * sem_ch9.adb (Analyze_Protected_Definition): Code cleanup. Mark the protected type as having controlled components when it contains at least one such component. * sem_util.ads, sem_util.adb (Needs_Finalization): New function. From-SVN: r273383 --- gcc/ada/ChangeLog | 10 +++++ gcc/ada/exp_util.adb | 92 +------------------------------------------- gcc/ada/exp_util.ads | 4 -- gcc/ada/sem_ch9.adb | 48 ++++++++++++----------- gcc/ada/sem_util.adb | 88 ++++++++++++++++++++++++++++++++++++++++++ gcc/ada/sem_util.ads | 4 ++ 6 files changed, 129 insertions(+), 117 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 48c72d6c92e..93a6fdc5db5 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,13 @@ +2019-07-11 Hristian Kirtchev + + * exp_util.ads, exp_util.adb (Needs_Finalization): Move to + Sem_Util. + * sem_ch9.adb (Analyze_Protected_Definition): Code cleanup. Mark + the protected type as having controlled components when it + contains at least one such component. + * sem_util.ads, sem_util.adb (Needs_Finalization): New + function. + 2019-07-11 Eric Botcazou * alloc.ads (Rep_JSON_Table_Initial): New constant. diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index e4fbd8b19f8..b677a72587d 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -10554,94 +10554,6 @@ package body Exp_Util is end if; end Needs_Constant_Address; - ------------------------ - -- Needs_Finalization -- - ------------------------ - - function Needs_Finalization (Typ : Entity_Id) return Boolean is - function Has_Some_Controlled_Component - (Input_Typ : Entity_Id) return Boolean; - -- Determine whether type Input_Typ has at least one controlled - -- component. - - ----------------------------------- - -- Has_Some_Controlled_Component -- - ----------------------------------- - - function Has_Some_Controlled_Component - (Input_Typ : Entity_Id) return Boolean - is - Comp : Entity_Id; - - begin - -- When a type is already frozen and has at least one controlled - -- component, or is manually decorated, it is sufficient to inspect - -- flag Has_Controlled_Component. - - if Has_Controlled_Component (Input_Typ) then - return True; - - -- Otherwise inspect the internals of the type - - elsif not Is_Frozen (Input_Typ) then - if Is_Array_Type (Input_Typ) then - return Needs_Finalization (Component_Type (Input_Typ)); - - elsif Is_Record_Type (Input_Typ) then - Comp := First_Component (Input_Typ); - while Present (Comp) loop - if Needs_Finalization (Etype (Comp)) then - return True; - end if; - - Next_Component (Comp); - end loop; - end if; - end if; - - return False; - end Has_Some_Controlled_Component; - - -- Start of processing for Needs_Finalization - - begin - -- Certain run-time configurations and targets do not provide support - -- for controlled types. - - if Restriction_Active (No_Finalization) then - return False; - - -- C++ types are not considered controlled. It is assumed that the non- - -- Ada side will handle their clean up. - - elsif Convention (Typ) = Convention_CPP then - return False; - - -- Class-wide types are treated as controlled because derivations from - -- the root type may introduce controlled components. - - elsif Is_Class_Wide_Type (Typ) then - return True; - - -- Concurrent types are controlled as long as their corresponding record - -- is controlled. - - elsif Is_Concurrent_Type (Typ) - and then Present (Corresponding_Record_Type (Typ)) - and then Needs_Finalization (Corresponding_Record_Type (Typ)) - then - return True; - - -- Otherwise the type is controlled when it is either derived from type - -- [Limited_]Controlled and not subject to aspect Disable_Controlled, or - -- contains at least one controlled component. - - else - return - Is_Controlled (Typ) or else Has_Some_Controlled_Component (Typ); - end if; - end Needs_Finalization; - ---------------------------- -- New_Class_Wide_Subtype -- ---------------------------- @@ -12170,9 +12082,7 @@ package body Exp_Util is Typ : Entity_Id; begin - if No (L) - or else Is_Empty_List (L) - then + if No (L) or else Is_Empty_List (L) then return False; end if; diff --git a/gcc/ada/exp_util.ads b/gcc/ada/exp_util.ads index 7cb9d2de73a..c0848c7c65d 100644 --- a/gcc/ada/exp_util.ads +++ b/gcc/ada/exp_util.ads @@ -944,10 +944,6 @@ package Exp_Util is -- consist of constants, when the object has a nontrivial initialization -- or is controlled. - function Needs_Finalization (Typ : Entity_Id) return Boolean; - -- Determine whether type Typ is controlled and this requires finalization - -- actions. - function Non_Limited_Designated_Type (T : Entity_Id) return Entity_Id; -- An anonymous access type may designate a limited view. Check whether -- non-limited view is available during expansion, to examine components diff --git a/gcc/ada/sem_ch9.adb b/gcc/ada/sem_ch9.adb index 19fff577994..0696f928e38 100644 --- a/gcc/ada/sem_ch9.adb +++ b/gcc/ada/sem_ch9.adb @@ -1897,9 +1897,6 @@ package body Sem_Ch9 is ---------------------------------- procedure Analyze_Protected_Definition (N : Node_Id) is - E : Entity_Id; - L : Entity_Id; - procedure Undelay_Itypes (T : Entity_Id); -- Itypes created for the private components of a protected type -- do not receive freeze nodes, because there is no scope in which @@ -1932,9 +1929,7 @@ package body Sem_Ch9 is end if; while Present (Comp) loop - if Is_Type (Comp) - and then Is_Itype (Comp) - then + if Is_Type (Comp) and then Is_Itype (Comp) then Set_Has_Delayed_Freeze (Comp, False); Set_Is_Frozen (Comp); @@ -1942,9 +1937,7 @@ package body Sem_Ch9 is Layout_Type (Comp); end if; - if Is_Record_Type (Comp) - or else Is_Protected_Type (Comp) - then + if Is_Record_Type (Comp) or else Is_Protected_Type (Comp) then Undelay_Itypes (Comp); end if; end if; @@ -1953,6 +1946,12 @@ package body Sem_Ch9 is end loop; end Undelay_Itypes; + -- Local variables + + Prot_Typ : constant Entity_Id := Current_Scope; + Item_Id : Entity_Id; + Last_Id : Entity_Id; + -- Start of processing for Analyze_Protected_Definition begin @@ -1963,32 +1962,37 @@ package body Sem_Ch9 is if Present (Private_Declarations (N)) and then not Is_Empty_List (Private_Declarations (N)) then - L := Last_Entity (Current_Scope); + Last_Id := Last_Entity (Prot_Typ); Analyze_Declarations (Private_Declarations (N)); - if Present (L) then - Set_First_Private_Entity (Current_Scope, Next_Entity (L)); + if Present (Last_Id) then + Set_First_Private_Entity (Prot_Typ, Next_Entity (Last_Id)); else - Set_First_Private_Entity (Current_Scope, - First_Entity (Current_Scope)); + Set_First_Private_Entity (Prot_Typ, First_Entity (Prot_Typ)); end if; end if; - E := First_Entity (Current_Scope); - while Present (E) loop - if Ekind_In (E, E_Function, E_Procedure) then - Set_Convention (E, Convention_Protected); + Item_Id := First_Entity (Prot_Typ); + while Present (Item_Id) loop + if Ekind_In (Item_Id, E_Function, E_Procedure) then + Set_Convention (Item_Id, Convention_Protected); else - Propagate_Concurrent_Flags (Current_Scope, Etype (E)); + Propagate_Concurrent_Flags (Prot_Typ, Etype (Item_Id)); + + if Chars (Item_Id) /= Name_uParent + and then Needs_Finalization (Etype (Item_Id)) + then + Set_Has_Controlled_Component (Prot_Typ); + end if; end if; - Next_Entity (E); + Next_Entity (Item_Id); end loop; - Undelay_Itypes (Current_Scope); + Undelay_Itypes (Prot_Typ); Check_Max_Entries (N, Max_Protected_Entries); - Process_End_Label (N, 'e', Current_Scope); + Process_End_Label (N, 'e', Prot_Typ); end Analyze_Protected_Definition; ---------------------------------------- diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index b6a31e6a9c8..147c281c797 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -19418,6 +19418,94 @@ package body Sem_Util is return Empty; end Nearest_Enclosing_Instance; + ------------------------ + -- Needs_Finalization -- + ------------------------ + + function Needs_Finalization (Typ : Entity_Id) return Boolean is + function Has_Some_Controlled_Component + (Input_Typ : Entity_Id) return Boolean; + -- Determine whether type Input_Typ has at least one controlled + -- component. + + ----------------------------------- + -- Has_Some_Controlled_Component -- + ----------------------------------- + + function Has_Some_Controlled_Component + (Input_Typ : Entity_Id) return Boolean + is + Comp : Entity_Id; + + begin + -- When a type is already frozen and has at least one controlled + -- component, or is manually decorated, it is sufficient to inspect + -- flag Has_Controlled_Component. + + if Has_Controlled_Component (Input_Typ) then + return True; + + -- Otherwise inspect the internals of the type + + elsif not Is_Frozen (Input_Typ) then + if Is_Array_Type (Input_Typ) then + return Needs_Finalization (Component_Type (Input_Typ)); + + elsif Is_Record_Type (Input_Typ) then + Comp := First_Component (Input_Typ); + while Present (Comp) loop + if Needs_Finalization (Etype (Comp)) then + return True; + end if; + + Next_Component (Comp); + end loop; + end if; + end if; + + return False; + end Has_Some_Controlled_Component; + + -- Start of processing for Needs_Finalization + + begin + -- Certain run-time configurations and targets do not provide support + -- for controlled types. + + if Restriction_Active (No_Finalization) then + return False; + + -- C++ types are not considered controlled. It is assumed that the non- + -- Ada side will handle their clean up. + + elsif Convention (Typ) = Convention_CPP then + return False; + + -- Class-wide types are treated as controlled because derivations from + -- the root type may introduce controlled components. + + elsif Is_Class_Wide_Type (Typ) then + return True; + + -- Concurrent types are controlled as long as their corresponding record + -- is controlled. + + elsif Is_Concurrent_Type (Typ) + and then Present (Corresponding_Record_Type (Typ)) + and then Needs_Finalization (Corresponding_Record_Type (Typ)) + then + return True; + + -- Otherwise the type is controlled when it is either derived from type + -- [Limited_]Controlled and not subject to aspect Disable_Controlled, or + -- contains at least one controlled component. + + else + return + Is_Controlled (Typ) or else Has_Some_Controlled_Component (Typ); + end if; + end Needs_Finalization; + ---------------------- -- Needs_One_Actual -- ---------------------- diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index 808d6935257..35ef1114b2d 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -2220,6 +2220,10 @@ package Sem_Util is -- Return the entity of the nearest enclosing instance which encapsulates -- entity E. If no such instance exits, return Empty. + function Needs_Finalization (Typ : Entity_Id) return Boolean; + -- Determine whether type Typ is controlled and this requires finalization + -- actions. + function Needs_One_Actual (E : Entity_Id) return Boolean; -- Returns True if a function has defaults for all but its first formal, -- which is a controlling formal. Used in Ada 2005 mode to solve the -- 2.30.2