This patch modifies the finalization machinery to recognize a controlled deferred constant initialized by means of a build-in-place function call as requiring finalization actions.
------------ -- Source -- ------------ -- types.ads private with Ada.Finalization; package Types is type T (<>) is limited private; function Create return T; private type T is new Ada.Finalization.Limited_Controlled with record Id : Natural := 0; end record; overriding procedure Initialize (X : in out T); overriding procedure Finalize (X : in out T); end Types; -- types.adb with Ada.Text_IO; use Ada.Text_IO; package body Types is Id_Gen : Natural := 0; procedure Finalize (X : in out T) is begin Put_Line (" fin" & X.Id'Img); X.Id := 0; end; procedure Initialize (X : in out T) is begin Id_Gen := Id_Gen + 1; X.Id := Id_Gen; Put_Line (" ini" & X.Id'Img); end Initialize; function Create return T is begin return Result : T do Put_Line ("Create"); end return; end Create; end Types; -- main.adb with Types; use Types; procedure Main is Obj : T renames Create; begin null; end Main; ---------------------------- -- Compilation and output -- ---------------------------- $ gnatmake -q main.adb $ ./main ini 1 Create fin 1 Tested on x86_64-pc-linux-gnu, committed on trunk 2016-06-16 Hristian Kirtchev <kirtc...@adacore.com> * exp_ch7.adb (Find_Last_Init): Remove obsolete code. The logic is now performed by Process_Object_Declaration. (Process_Declarations): Recognize a controlled deferred constant which is in fact initialized by means of a build-in-place function call as needing finalization actions. (Process_Object_Declaration): Insert the counter after the build-in-place initialization call for a controlled object. This was previously done in Find_Last_Init. * exp_util.adb (Requires_Cleanup_Actions): Recognize a controlled deferred constant which is in fact initialized by means of a build-in-place function call as needing finalization actions.
Index: exp_ch7.adb =================================================================== --- exp_ch7.adb (revision 237429) +++ exp_ch7.adb (working copy) @@ -2100,16 +2100,21 @@ null; -- The object is of the form: - -- Obj : Typ [:= Expr]; + -- Obj : [constant] Typ [:= Expr]; - -- Do not process the incomplete view of a deferred constant. - -- Do not consider tag-to-class-wide conversions. + -- Do not process tag-to-class-wide conversions because they do + -- not yield an object. Do not process the incomplete view of a + -- deferred constant. Note that an object initialized by means + -- of a build-in-place function call may appear as a deferred + -- constant after expansion activities. These kinds of objects + -- must be finalized. elsif not Is_Imported (Obj_Id) and then Needs_Finalization (Obj_Typ) - and then not (Ekind (Obj_Id) = E_Constant - and then not Has_Completion (Obj_Id)) and then not Is_Tag_To_Class_Wide_Conversion (Obj_Id) + and then not (Ekind (Obj_Id) = E_Constant + and then not Has_Completion (Obj_Id) + and then No (BIP_Initialization_Call (Obj_Id))) then Processing_Actions; @@ -2757,48 +2762,9 @@ Stmt := Next_Suitable_Statement (Decl); - -- A limited controlled object initialized by a function call uses - -- the build-in-place machinery to obtain its value. + -- Nothing to do for an object with suppressed initialization - -- Obj : Lim_Controlled_Type := Func_Call; - - -- is expanded into - - -- Obj : Lim_Controlled_Type; - -- type Ptr_Typ is access Lim_Controlled_Type; - -- Temp : constant Ptr_Typ := - -- Func_Call - -- (BIPalloc => 1, - -- BIPaccess => Obj'Unrestricted_Access)'reference; - - -- In this scenario the declaration of the temporary acts as the - -- last initialization statement. - - if Is_Limited_Type (Obj_Typ) - and then Has_Init_Expression (Decl) - and then No (Expression (Decl)) - then - while Present (Stmt) loop - if Nkind (Stmt) = N_Object_Declaration - and then Present (Expression (Stmt)) - and then Is_Object_Access_BIP_Func_Call - (Expr => Expression (Stmt), - Obj_Id => Obj_Id) - then - Last_Init := Stmt; - exit; - end if; - - Next (Stmt); - end loop; - - -- Nothing to do for an object with supporessed initialization. - -- Note that this check is not performed at the beginning of the - -- routine because a declaration marked with No_Initialization - -- may still be initialized by a build-in-place call (the case - -- above). - - elsif No_Initialization (Decl) then + if No_Initialization (Decl) then return; -- In all other cases the initialization calls follow the related @@ -2937,18 +2903,33 @@ Expression => Make_Integer_Literal (Loc, Counter_Val)); -- Insert the counter after all initialization has been done. The - -- place of insertion depends on the context. If an object is being - -- initialized via an aggregate, then the counter must be inserted - -- after the last aggregate assignment. + -- place of insertion depends on the context. - if Ekind_In (Obj_Id, E_Constant, E_Variable) - and then Present (Last_Aggregate_Assignment (Obj_Id)) - then - Count_Ins := Last_Aggregate_Assignment (Obj_Id); - Body_Ins := Empty; + if Ekind_In (Obj_Id, E_Constant, E_Variable) then + -- The object is initialized by a build-in-place function call. + -- The counter insertion point is after the function call. + + if Present (BIP_Initialization_Call (Obj_Id)) then + Count_Ins := BIP_Initialization_Call (Obj_Id); + Body_Ins := Empty; + + -- The object is initialized by an aggregate. Insert the counter + -- after the last aggregate assignment. + + elsif Present (Last_Aggregate_Assignment (Obj_Id)) then + Count_Ins := Last_Aggregate_Assignment (Obj_Id); + Body_Ins := Empty; + + -- In all other cases the counter is inserted after the last call + -- to either [Deep_]Initialize or the type-specific init proc. + + else + Find_Last_Init (Count_Ins, Body_Ins); + end if; + -- In all other cases the counter is inserted after the last call to - -- either [Deep_]Initialize or the type specific init proc. + -- either [Deep_]Initialize or the type-specific init proc. else Find_Last_Init (Count_Ins, Body_Ins); Index: exp_util.adb =================================================================== --- exp_util.adb (revision 237510) +++ exp_util.adb (working copy) @@ -2948,10 +2948,9 @@ N_Discriminant_Association, N_Parameter_Association, N_Pragma_Argument_Association) - and then not Nkind_In - (Parent (Par), N_Function_Call, - N_Procedure_Call_Statement, - N_Entry_Call_Statement) + and then not Nkind_In (Parent (Par), N_Function_Call, + N_Procedure_Call_Statement, + N_Entry_Call_Statement) then return Par; @@ -8279,16 +8278,21 @@ return False; -- The object is of the form: - -- Obj : Typ [:= Expr]; + -- Obj : [constant] Typ [:= Expr]; -- - -- Do not process the incomplete view of a deferred constant. Do - -- not consider tag-to-class-wide conversions. + -- Do not process tag-to-class-wide conversions because they do + -- not yield an object. Do not process the incomplete view of a + -- deferred constant. Note that an object initialized by means + -- of a build-in-place function call may appear as a deferred + -- constant after expansion activities. These kinds of objects + -- must be finalized. elsif not Is_Imported (Obj_Id) and then Needs_Finalization (Obj_Typ) + and then not Is_Tag_To_Class_Wide_Conversion (Obj_Id) and then not (Ekind (Obj_Id) = E_Constant - and then not Has_Completion (Obj_Id)) - and then not Is_Tag_To_Class_Wide_Conversion (Obj_Id) + and then not Has_Completion (Obj_Id) + and then No (BIP_Initialization_Call (Obj_Id))) then return True;