===================================================================
@@ -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);
===================================================================
@@ -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;
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 <kirtchev@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.