git
/
gcc
mirror of git://gcc.gnu.org/git/gcc.git
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

ada: Implement built-in-place expansion of container aggregates 

It is implemented for container aggregates that are used to initialize an
object, as specified by RM 7.6(17.2/3-17.3/3) for immutably limited types
and types that need finalization, but for all types like other aggregates.

gcc/ada/ChangeLog:

	* exp_aggr.adb (Expand_Delta_Array_Aggregate): Move declaration.
	(Expand_Delta_Record_Aggregate): Likewise.
	(Expand_Container_Aggregate): Likewise.  Move implementation to
	Build_Container_Aggr_Code.  Implement built-in-place expansion
	for object declarations and allocators.
	(Build_Container_Aggr_Code): New function containing most of the
	code of the original Expand_Container_Aggregate.  Do not build a
	temporary for the size calculation.  Minor formatting tweaks.
	(Expand_N_Aggregate): Add comment.
	* exp_ch4.adb (Expand_Allocator_Expression): Detect the case of
	a container aggregate as qualified expression.  Do not apply the
	predicate check on entry in this case and rewrite the allocator.
	* exp_ch7.adb (Build_Finalizer.Process_Object_Declaration): Deal
	with Last_Aggregate_Assignment first to compute the attachment
	point (as already done in Attach_Object_To_Master_Node).
This commit is contained in:
Eric Botcazou 2024-10-18 12:06:23 +02:00 committed by Marc Poulhiès
parent a5a0d605d8
commit b30440436f
3 changed files with 285 additions and 148 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

387
gcc/ada/exp_aggr.adb
View File

@ -94,10 +94,6 @@ package body Exp_Aggr is
type Case_Table_Type is array (Nat range <>) of Case_Bounds;
-- Table type used by Check_Case_Choices procedure
procedure Expand_Delta_Array_Aggregate (N : Node_Id; Deltas : List_Id);
procedure Expand_Delta_Record_Aggregate (N : Node_Id; Deltas : List_Id);
procedure Expand_Container_Aggregate (N : Node_Id);
function Get_Base_Object (N : Node_Id) return Entity_Id;
-- Return the base object, i.e. the outermost prefix object, that N refers
-- to statically, or Empty if it cannot be determined. The assumption is
@ -181,7 +177,7 @@ package body Exp_Aggr is
Typ : Entity_Id;
Lhs : Node_Id) return List_Id;
-- N is an N_Aggregate or an N_Extension_Aggregate. Typ is the type of the
-- aggregate. Target is an expression containing the location on which the
-- aggregate. Lhs is an expression containing the location on which the
-- component by component assignments will take place. Returns the list of
-- assignments plus all other adjustments needed for tagged and controlled
-- types.
@ -191,6 +187,9 @@ package body Exp_Aggr is
-- component by component. N is an N_Aggregate or N_Extension_Aggregate.
-- Typ is the type of the record aggregate.
procedure Expand_Delta_Record_Aggregate (N : Node_Id; Deltas : List_Id);
-- This is the top level procedure for delta record aggregate expansion
procedure Expand_Record_Aggregate
(N : Node_Id;
Orig_Tag : Node_Id := Empty;
@ -232,6 +231,23 @@ package body Exp_Aggr is
-- functions of the parent type, and when applying a stream attribute to
-- an object of the derived type.
---------------------------------------------------------
-- Local Subprograms for Container Aggregate Expansion --
---------------------------------------------------------
procedure Expand_Container_Aggregate (N : Node_Id);
-- This is the top-level routine for container aggregate expansion
function Build_Container_Aggr_Code
(N : Node_Id;
Typ : Entity_Id;
Lhs : Node_Id;
Init : out Node_Id) return List_Id;
-- N is an N_Aggregate for a container type Typ. Lhs is an expression
-- containing the location of the anonymous object, which may be built
-- in place. Returns the function call used to initialize the anonymous
-- object in Init and the list of statements needed to build N.
-----------------------------------------------------
-- Local Subprograms for Array Aggregate Expansion --
-----------------------------------------------------
@ -299,9 +315,12 @@ package body Exp_Aggr is
-- these are cases we handle in there.
procedure Expand_Array_Aggregate (N : Node_Id);
-- This is the top-level routine to perform array aggregate expansion.
-- This is the top-level routine for array aggregate expansion.
-- N is the N_Aggregate node to be expanded.
procedure Expand_Delta_Array_Aggregate (N : Node_Id; Deltas : List_Id);
-- This is the top-level routine for delta array aggregate expansion
function Is_Two_Dim_Packed_Array (Typ : Entity_Id) return Boolean;
-- For 2D packed array aggregates with constant bounds and constant scalar
-- components, it is preferable to pack the inner aggregates because the
@ -6499,6 +6518,7 @@ package body Exp_Aggr is
procedure Expand_N_Aggregate (N : Node_Id) is
T : constant Entity_Id := Etype (N);
begin
-- Record aggregate case
@ -6508,6 +6528,8 @@ package body Exp_Aggr is
then
Expand_Record_Aggregate (N);
-- Container aggregate case
elsif Has_Aspect (T, Aspect_Aggregate) then
Expand_Container_Aggregate (N);
@ -6612,41 +6634,34 @@ package body Exp_Aggr is
return;
end Expand_N_Aggregate;
--------------------------------
-- Expand_Container_Aggregate --
--------------------------------
-------------------------------
-- Build_Container_Aggr_Code --
-------------------------------
procedure Expand_Container_Aggregate (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
Typ : constant Entity_Id := Etype (N);
Asp : constant Node_Id := Find_Value_Of_Aspect (Typ, Aspect_Aggregate);
function Build_Container_Aggr_Code
(N : Node_Id;
Typ : Entity_Id;
Lhs : Node_Id;
Init : out Node_Id) return List_Id
is
Loc : constant Source_Ptr := Sloc (N);
Aggr_Code : constant List_Id := New_List;
Asp : constant Node_Id :=
Find_Value_Of_Aspect (Typ, Aspect_Aggregate);
Empty_Subp : Node_Id := Empty;
Add_Named_Subp : Node_Id := Empty;
Add_Unnamed_Subp : Node_Id := Empty;
New_Indexed_Subp : Node_Id := Empty;
Assign_Indexed_Subp : Node_Id := Empty;
-- Identifiers for the subprograms referenced in the aggregate
Aggr_Code : constant List_Id := New_List;
Temp : constant Entity_Id := Make_Temporary (Loc, 'C', N);
Comp : Node_Id;
Init_Stat : Node_Id;
-- The following are used when the size of the aggregate is not
-- static and requires a dynamic evaluation.
Siz_Decl : Node_Id;
Siz_Exp : Node_Id;
Choice_Lo : Node_Id := Empty;
Choice_Hi : Node_Id := Empty;
-- These variables are used to determine the smallest and largest
-- choice values. Choice_Lo and Choice_Hi are passed to the New_Indexed
-- function, for allocating an indexed aggregate object.
Choice_Lo : Node_Id := Empty;
Choice_Hi : Node_Id := Empty;
Is_Indexed_Aggregate : Boolean := False;
function Aggregate_Size return Node_Id;
-- Compute number of entries in aggregate, including choices
-- that cover a range or subtype, as well as iterated constructs.
@ -6658,7 +6673,7 @@ package body Exp_Aggr is
-- happens this function returns an empty node. In that case we will
-- later just allocate a default size for the aggregate.
function Build_Siz_Exp (Comp : Node_Id) return Node_Id;
function Build_Size_Expr (Comp : Node_Id) return Node_Id;
-- When the aggregate contains a single Iterated_Component_Association
-- or Element_Association with non-static bounds, build an expression
-- to be used as the allocated size of the container. This may be an
@ -6673,7 +6688,7 @@ package body Exp_Aggr is
-- given either by a loop parameter specification or an iterator
-- specification.
function Expand_Range_Component
function Expand_Range_Component
(Rng : Node_Id;
Expr : Node_Id;
Insert_Op : Entity_Id) return Node_Id;
@ -6693,8 +6708,6 @@ package body Exp_Aggr is
Comp_Siz_Exp : Node_Id;
Siz_Exp : Node_Id;
-- Start of processing for Aggregate_Size
begin
-- Aggregate is either all positional or all named
@ -6705,7 +6718,7 @@ package body Exp_Aggr is
Comp := First (Component_Associations (N));
while Present (Comp) loop
Comp_Siz_Exp := Build_Siz_Exp (Comp);
Comp_Siz_Exp := Build_Size_Expr (Comp);
if No (Comp_Siz_Exp) then
@ -6714,6 +6727,7 @@ package body Exp_Aggr is
-- should use the default value instead.
return Empty;
else
if Is_Static_Expression (Siz_Exp)
and then Is_Static_Expression (Comp_Siz_Exp)
@ -6724,6 +6738,7 @@ package body Exp_Aggr is
To_Int (Siz_Exp) + To_Int (Comp_Siz_Exp));
Set_Is_Static_Expression (Siz_Exp);
else
Siz_Exp := Make_Op_Add (Sloc (Comp),
Left_Opnd => Siz_Exp,
@ -6738,11 +6753,11 @@ package body Exp_Aggr is
return Siz_Exp;
end Aggregate_Size;
-------------------
-- Build_Siz_Exp --
-------------------
---------------------
-- Build_Size_Expr --
---------------------
function Build_Siz_Exp (Comp : Node_Id) return Node_Id is
function Build_Size_Expr (Comp : Node_Id) return Node_Id is
Lo, Hi : Node_Id;
It : Node_Id;
Siz_Exp : Node_Id := Empty;
@ -6754,9 +6769,11 @@ package body Exp_Aggr is
-- Update the Choice_Lo and Choice_Hi variables with the smallest
-- and largest possible node values.
procedure Update_Choices (Lo : Node_Id; Hi : Node_Id) is
-- Local variables
--------------------
-- Update_Choices --
--------------------
procedure Update_Choices (Lo : Node_Id; Hi : Node_Id) is
Range_Int_Lo : constant Int := To_Int (Lo);
Range_Int_Hi : constant Int := To_Int (Hi);
@ -6776,7 +6793,7 @@ package body Exp_Aggr is
end if;
end Update_Choices;
-- Start of processing for Build_Siz_Exp
-- Start of processing for Build_Size_Expr
begin
if Nkind (Comp) = N_Range then
@ -6797,6 +6814,7 @@ package body Exp_Aggr is
Set_Is_Static_Expression (Siz_Exp);
return Siz_Exp;
else
-- Capture the nonstatic bounds, for later use in passing on
-- the call to New_Indexed.
@ -6833,7 +6851,7 @@ package body Exp_Aggr is
Siz_Exp : Node_Id := Empty;
begin
while Present (Idx_N) loop
Temp_Siz_Exp := Build_Siz_Exp (Idx_N);
Temp_Siz_Exp := Build_Size_Expr (Idx_N);
pragma Assert (Present (Temp_Siz_Exp));
@ -6866,8 +6884,9 @@ package body Exp_Aggr is
end if;
return Empty;
else
return Build_Siz_Exp (First (Discrete_Choices (Comp)));
return Build_Size_Expr (First (Discrete_Choices (Comp)));
end if;
elsif Nkind (Comp) = N_Component_Association then
@ -6878,7 +6897,7 @@ package body Exp_Aggr is
if Nkind (Choice) = N_Range then
Temp_Siz_Exp := Build_Siz_Exp (Choice);
Temp_Siz_Exp := Build_Size_Expr (Choice);
-- Choice is subtype_mark; add range based on its bounds
@ -6893,7 +6912,7 @@ package body Exp_Aggr is
New_Copy_Tree (Lo),
New_Copy_Tree (Hi)));
Temp_Siz_Exp := Build_Siz_Exp (Choice);
Temp_Siz_Exp := Build_Size_Expr (Choice);
-- Choice is a single discrete value
@ -6935,6 +6954,7 @@ package body Exp_Aggr is
end loop;
return Siz_Exp;
elsif Nkind (Comp) = N_Iterated_Element_Association then
return Empty;
@ -6945,14 +6965,14 @@ package body Exp_Aggr is
else
return Empty;
end if;
end Build_Siz_Exp;
end Build_Size_Expr;
-------------------------------
-- Expand_Iterated_Component --
-------------------------------
procedure Expand_Iterated_Component (Comp : Node_Id) is
Expr : constant Node_Id := Expression (Comp);
Expr : constant Node_Id := Expression (Comp);
Key_Expr : Node_Id := Empty;
Loop_Id : Entity_Id;
@ -6998,8 +7018,8 @@ package body Exp_Aggr is
(Loop_Parameter_Specification
(L_Iteration_Scheme), Loop_Id);
end if;
else
else
-- Iterated_Component_Association.
if Present (Iterator_Specification (Comp)) then
@ -7047,20 +7067,21 @@ package body Exp_Aggr is
(Make_Procedure_Call_Statement (Loc,
Name => New_Occurrence_Of (Entity (Add_Unnamed_Subp), Loc),
Parameter_Associations =>
New_List (New_Occurrence_Of (Temp, Loc),
New_List (New_Copy_Tree (Lhs),
New_Copy_Tree (Expr))));
else
-- Named or indexed aggregate, for which a key is present,
-- possibly with a specified key_expression.
if Present (Key_Expr) then
Params := New_List (New_Occurrence_Of (Temp, Loc),
New_Copy_Tree (Key_Expr),
New_Copy_Tree (Expr));
Params := New_List (New_Copy_Tree (Lhs),
New_Copy_Tree (Key_Expr),
New_Copy_Tree (Expr));
else
Params := New_List (New_Occurrence_Of (Temp, Loc),
New_Occurrence_Of (Loop_Id, Loc),
New_Copy_Tree (Expr));
Params := New_List (New_Copy_Tree (Lhs),
New_Occurrence_Of (Loop_Id, Loc),
New_Copy_Tree (Expr));
end if;
Stats := New_List
@ -7074,8 +7095,8 @@ package body Exp_Aggr is
Identifier => Empty,
Iteration_Scheme => L_Iteration_Scheme,
Statements => Stats);
Append (Loop_Stat, Aggr_Code);
Append (Loop_Stat, Aggr_Code);
end Expand_Iterated_Component;
----------------------------
@ -7087,8 +7108,7 @@ package body Exp_Aggr is
Expr : Node_Id;
Insert_Op : Entity_Id) return Node_Id
is
Loop_Id : constant Entity_Id :=
Make_Temporary (Loc, 'T');
Loop_Id : constant Entity_Id := Make_Temporary (Loc, 'T');
L_Iteration_Scheme : Node_Id;
Stats : List_Id;
@ -7106,11 +7126,11 @@ package body Exp_Aggr is
Name =>
New_Occurrence_Of (Insert_Op, Loc),
Parameter_Associations =>
New_List (New_Occurrence_Of (Temp, Loc),
New_List (New_Copy_Tree (Lhs),
New_Occurrence_Of (Loop_Id, Loc),
New_Copy_Tree (Expr))));
return Make_Implicit_Loop_Statement
return Make_Implicit_Loop_Statement
(Node => N,
Identifier => Empty,
Iteration_Scheme => L_Iteration_Scheme,
@ -7121,43 +7141,52 @@ package body Exp_Aggr is
-- To_Int --
------------
-- The bounds of the discrete range are integers or enumeration literals
function To_Int (Expr : N_Subexpr_Id) return Int is
begin
-- The bounds of the discrete range are integers or enumeration
-- literals
return UI_To_Int ((if Nkind (Expr) = N_Integer_Literal
then Intval (Expr)
else Enumeration_Pos (Expr)));
else Enumeration_Pos (Expr)));
end To_Int;
-- Start of processing for Expand_Container_Aggregate
-- Local variables
Is_Indexed_Aggregate : Boolean;
-- True if the aggregate is indexed as per RM 4.3.5(25/5)
-- Start of processing for Build_Container_Aggr_Code
begin
Parse_Aspect_Aggregate (Asp,
Empty_Subp, Add_Named_Subp, Add_Unnamed_Subp,
New_Indexed_Subp, Assign_Indexed_Subp);
-- Determine whether this is an indexed aggregate (see RM 4.3.5(25/5))
-- Determine whether this is an indexed aggregate
Is_Indexed_Aggregate :=
Sem_Aggr.Is_Indexed_Aggregate
(N, Add_Unnamed_Subp, New_Indexed_Subp);
-- The constructor for bounded containers is a function with
-- a parameter that sets the size of the container. If the
-- size cannot be determined statically we use a default value
-- or a dynamic expression.
Siz_Exp := Aggregate_Size;
-- Build the function call that initializes the anonymous object
declare
Count_Type : Entity_Id := Standard_Natural;
Default : Node_Id := Empty;
Empty_First_Formal : constant Entity_Id :=
First_Formal (Entity (Empty_Subp));
Param_List : List_Id;
First_Formal (Entity (Empty_Subp));
Count_Type : Entity_Id;
Default : Node_Id;
Param_List : List_Id;
Siz_Exp : Node_Id;
begin
-- The constructor for bounded containers is a function with
-- a parameter that sets the size of the container. If the
-- size cannot be determined statically we use a default value
-- or a dynamic expression.
Siz_Exp := Aggregate_Size;
-- If aggregate size is not static, we use the default value of the
-- Empty operation's formal parameter for the allocation. We assume
-- that this (implementation-dependent) value is static, even though
@ -7166,6 +7195,10 @@ package body Exp_Aggr is
if Present (Empty_First_Formal) then
Default := Default_Value (Empty_First_Formal);
Count_Type := Etype (Empty_First_Formal);
else
Default := Empty;
Count_Type := Standard_Natural;
end if;
-- Create an object initialized by the aggregate's determined size
@ -7174,32 +7207,21 @@ package body Exp_Aggr is
-- and the default otherwise.
if Present (Siz_Exp) then
Siz_Exp := Make_Type_Conversion (Loc,
Subtype_Mark =>
New_Occurrence_Of (Count_Type, Loc),
Expression => Siz_Exp);
Siz_Exp :=
Make_Type_Conversion (Loc,
Subtype_Mark => New_Occurrence_Of (Count_Type, Loc),
Expression => Siz_Exp);
elsif Present (Default) then
Siz_Exp := Make_Integer_Literal (Loc,
UI_To_Int (Intval (Default)));
Siz_Exp := New_Copy_Tree (Default);
-- If the length isn't known and there's not a default, then use
-- zero for the initial container length.
else
Siz_Exp := Make_Type_Conversion (Loc,
Subtype_Mark =>
New_Occurrence_Of (Count_Type, Loc),
Expression => Make_Integer_Literal (Loc, 0));
Siz_Exp := Make_Integer_Literal (Loc, 0);
end if;
Siz_Decl := Make_Object_Declaration (Loc,
Defining_Identifier => Make_Temporary (Loc, 'S', N),
Object_Definition =>
New_Occurrence_Of (Count_Type, Loc),
Expression => Siz_Exp);
Append (Siz_Decl, Aggr_Code);
-- In the case of an indexed aggregate, the aggregate is allocated
-- with the New_Indexed operation, passing the bounds.
@ -7223,10 +7245,7 @@ package body Exp_Aggr is
Left_Opnd => Make_Type_Conversion (Loc,
Subtype_Mark =>
New_Occurrence_Of (Index_Type, Loc),
Expression =>
New_Occurrence_Of
(Defining_Identifier (Siz_Decl),
Loc)),
Expression => Siz_Exp),
Right_Opnd => Make_Integer_Literal (Loc, 1)));
else
@ -7234,40 +7253,28 @@ package body Exp_Aggr is
Choice_Hi := New_Copy_Tree (Choice_Hi);
end if;
Init_Stat :=
Make_Object_Declaration (Loc,
Defining_Identifier => Temp,
Object_Definition => New_Occurrence_Of (Typ, Loc),
Expression => Make_Function_Call (Loc,
Name =>
New_Occurrence_Of (Entity (New_Indexed_Subp), Loc),
Parameter_Associations =>
New_List (Choice_Lo, Choice_Hi)));
Init :=
Make_Function_Call (Loc,
Name => New_Occurrence_Of (Entity (New_Indexed_Subp), Loc),
Parameter_Associations => New_List (Choice_Lo, Choice_Hi));
end;
-- Otherwise we generate a call to the Empty function, passing the
-- determined number of elements as saved in Siz_Decl if the function
-- has a formal parameter, and otherwise making a parameterless call.
-- determined number of elements Siz_Exp if the function has a formal
-- parameter, and otherwise making a parameterless call.
else
if Present (Empty_First_Formal) then
Param_List :=
New_List
(New_Occurrence_Of (Defining_Identifier (Siz_Decl), Loc));
Param_List := New_List (Siz_Exp);
else
Param_List := No_List;
end if;
Init_Stat :=
Make_Object_Declaration (Loc,
Defining_Identifier => Temp,
Object_Definition => New_Occurrence_Of (Typ, Loc),
Expression => Make_Function_Call (Loc,
Name => New_Occurrence_Of (Entity (Empty_Subp), Loc),
Parameter_Associations => Param_List));
Init :=
Make_Function_Call (Loc,
Name => New_Occurrence_Of (Entity (Empty_Subp), Loc),
Parameter_Associations => Param_List);
end if;
Append (Init_Stat, Aggr_Code);
end;
-- Report warning on infinite recursion if an empty container aggregate
@ -7361,12 +7368,12 @@ package body Exp_Aggr is
end if;
Param_List :=
New_List (New_Occurrence_Of (Temp, Loc),
New_List (New_Copy_Tree (Lhs),
New_Occurrence_Of (Key_Index, Loc),
New_Copy_Tree (Comp));
else
Param_List :=
New_List (New_Occurrence_Of (Temp, Loc),
New_List (New_Copy_Tree (Lhs),
New_Copy_Tree (Comp));
end if;
@ -7382,15 +7389,20 @@ package body Exp_Aggr is
-- such as sets may include iterated component associations.
elsif not Is_Indexed_Aggregate then
Comp := First (Component_Associations (N));
while Present (Comp) loop
if Nkind (Comp) = N_Iterated_Component_Association
or else Nkind (Comp) = N_Iterated_Element_Association
then
Expand_Iterated_Component (Comp);
end if;
Next (Comp);
end loop;
declare
Comp : Node_Id;
begin
Comp := First (Component_Associations (N));
while Present (Comp) loop
if Nkind (Comp) = N_Iterated_Component_Association
or else Nkind (Comp) = N_Iterated_Element_Association
then
Expand_Iterated_Component (Comp);
end if;
Next (Comp);
end loop;
end;
end if;
---------------------
@ -7400,8 +7412,11 @@ package body Exp_Aggr is
elsif Present (Add_Named_Subp) then
declare
Insert : constant Entity_Id := Entity (Add_Named_Subp);
Stat : Node_Id;
Key : Node_Id;
Comp : Node_Id;
Key : Node_Id;
Stat : Node_Id;
begin
Comp := First (Component_Associations (N));
@ -7429,7 +7444,7 @@ package body Exp_Aggr is
Stat := Make_Procedure_Call_Statement (Loc,
Name => New_Occurrence_Of (Insert, Loc),
Parameter_Associations =>
New_List (New_Occurrence_Of (Temp, Loc),
New_List (New_Copy_Tree (Lhs),
New_Copy_Tree (Key),
New_Copy_Tree (Expression (Comp))));
end if;
@ -7498,7 +7513,7 @@ package body Exp_Aggr is
Stat := Make_Procedure_Call_Statement (Loc,
Name => New_Occurrence_Of (Insert, Loc),
Parameter_Associations =>
New_List (New_Occurrence_Of (Temp, Loc),
New_List (New_Copy_Tree (Lhs),
New_Copy_Tree (Key),
New_Copy_Tree (Expression (Comp))));
end if;
@ -7527,9 +7542,107 @@ package body Exp_Aggr is
end;
end if;
Insert_Actions (N, Aggr_Code);
Rewrite (N, New_Occurrence_Of (Temp, Loc));
Analyze_And_Resolve (N, Typ);
return Aggr_Code;
end Build_Container_Aggr_Code;
--------------------------------
-- Expand_Container_Aggregate --
--------------------------------
procedure Expand_Container_Aggregate (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
Typ : constant Entity_Id := Etype (N);
Aggr_Code : List_Id;
Init : Node_Id;
Lhs : Node_Id;
Obj_Id : Entity_Id;
Par : Node_Id;
begin
Par := Parent (N);
while Nkind (Par) = N_Qualified_Expression loop
Par := Parent (Par);
end loop;
-- If the aggregate is the initialization expression of an object
-- declaration, we always build the aggregate in place, although
-- this is required only for immutably limited types and types
-- that need finalization, see RM 7.6(17.2/3-17.3/3).
if Nkind (Par) = N_Object_Declaration then
Obj_Id := Defining_Identifier (Par);
Lhs := New_Occurrence_Of (Obj_Id, Loc);
Set_Assignment_OK (Lhs);
Aggr_Code := Build_Container_Aggr_Code (N, Typ, Lhs, Init);
-- Save the last assignment statement associated with the aggregate
-- when building a controlled object. This reference is utilized by
-- the finalization machinery when marking an object as successfully
-- initialized.
if Needs_Finalization (Typ) then
Mutate_Ekind (Obj_Id, E_Variable);
Set_Last_Aggregate_Assignment (Obj_Id, Last (Aggr_Code));
end if;
-- If a transient scope has been created around the declaration, we
-- need to attach the code to it so that the finalization actions of
-- the declaration will be inserted after it. Otherwise, we directly
-- insert it after the declaration and it will be analyzed only once
-- the declaration is processed.
if Scope_Is_Transient and then Par = Node_To_Be_Wrapped then
Insert_Actions_After (Par, Aggr_Code);
else
Insert_List_After (Par, Aggr_Code);
end if;
Rewrite (N, Init);
Analyze_And_Resolve (N, Typ);
-- Likewise if the aggregate is the qualified expression of an allocator
-- but, in this case, we wait until after Expand_Allocator_Expression
-- rewrites the allocator as the initialization expression of an object
-- declaration to have the left hand side.
elsif Nkind (Par) = N_Allocator then
if Nkind (Parent (Par)) = N_Object_Declaration
and then not Comes_From_Source (Defining_Identifier (Parent (Par)))
then
Obj_Id := Defining_Identifier (Parent (Par));
Lhs :=
Make_Explicit_Dereference (Loc,
Prefix => New_Occurrence_Of (Obj_Id, Loc));
Set_Assignment_OK (Lhs);
Aggr_Code := Build_Container_Aggr_Code (N, Typ, Lhs, Init);
Insert_Actions_After (Parent (Par), Aggr_Code);
Rewrite (N, Init);
Analyze_And_Resolve (N, Typ);
end if;
-- Otherwise we create a temporary for the anonymous object and replace
-- the aggregate with the temporary.
else
Obj_Id := Make_Temporary (Loc, 'A', N);
Lhs := New_Occurrence_Of (Obj_Id, Loc);
Set_Assignment_OK (Lhs);
Aggr_Code := Build_Container_Aggr_Code (N, Typ, Lhs, Init);
Prepend_To (Aggr_Code,
Make_Object_Declaration (Loc,
Defining_Identifier => Obj_Id,
Object_Definition => New_Occurrence_Of (Typ, Loc),
Expression => Init));
Insert_Actions (N, Aggr_Code);
Rewrite (N, Lhs);
Analyze_And_Resolve (N, Typ);
end if;
end Expand_Container_Aggregate;
------------------------------

32
gcc/ada/exp_ch4.adb
View File

@ -657,6 +657,7 @@ package body Exp_Ch4 is
Adj_Call : Node_Id;
Aggr_In_Place : Boolean;
Container_Aggr : Boolean;
Delayed_Cond_Expr : Boolean;
Node : Node_Id;
Temp : Entity_Id;
@ -668,6 +669,8 @@ package body Exp_Ch4 is
TagR : Node_Id := Empty;
-- Target reference for tag assignment
-- Start of processing for Expand_Allocator_Expression
begin
-- Handle call to C++ constructor
@ -689,14 +692,19 @@ package body Exp_Ch4 is
Aggr_In_Place := Is_Delayed_Aggregate (Exp);
Delayed_Cond_Expr := Is_Delayed_Conditional_Expression (Exp);
Container_Aggr := Nkind (Exp) = N_Aggregate
and then Has_Aspect (T, Aspect_Aggregate);
-- If the expression is an aggregate to be built in place, then we need
-- to delay applying predicate checks, because this would result in the
-- creation of a temporary, which is illegal for limited types and just
-- inefficient in the other cases. Likewise for a conditional expression
-- whose expansion has been delayed.
-- whose expansion has been delayed and for container aggregates.
if not Aggr_In_Place and then not Delayed_Cond_Expr then
if not Aggr_In_Place
and then not Delayed_Cond_Expr
and then not Container_Aggr
then
Apply_Predicate_Check (Exp, T);
end if;
@ -759,9 +767,26 @@ package body Exp_Ch4 is
return;
end if;
-- An allocator with a container aggregate as qualified expression must
-- be rewritten into the form expected by Expand_Container_Aggregate.
if Container_Aggr then
Temp := Make_Temporary (Loc, 'P', N);
Temp_Decl :=
Make_Object_Declaration (Loc,
Defining_Identifier => Temp,
Object_Definition => New_Occurrence_Of (PtrT, Loc),
Expression => Relocate_Node (N));
Set_Analyzed (Exp, False);
Insert_Action (N, Temp_Decl);
Rewrite (N, New_Occurrence_Of (Temp, Loc));
Analyze_And_Resolve (N, PtrT);
Apply_Predicate_Check (N, T, Deref => True);
-- Case of tagged type or type requiring finalization
if Is_Tagged_Type (T) or else Needs_Finalization (T) then
elsif Is_Tagged_Type (T) or else Needs_Finalization (T) then
-- Ada 2005 (AI-318-02): If the initialization expression is a call
-- to a build-in-place function, then access to the allocated object
@ -1072,7 +1097,6 @@ package body Exp_Ch4 is
Build_Allocate_Deallocate_Proc (Declaration_Node (Temp), Mark => N);
Rewrite (N, New_Occurrence_Of (Temp, Loc));
Analyze_And_Resolve (N, PtrT);
Apply_Predicate_Check (N, T, Deref => True);
elsif Is_Access_Type (T) and then Can_Never_Be_Null (T) then

14
gcc/ada/exp_ch7.adb
View File

@ -2781,18 +2781,18 @@ package body Exp_Ch7 is
if Ekind (Obj_Id) in E_Constant | E_Variable then
-- The object is initialized by a build-in-place function call.
-- The Master_Node insertion point is after the function call.
if Present (BIP_Initialization_Call (Obj_Id)) then
Master_Node_Ins := BIP_Initialization_Call (Obj_Id);
-- The object is initialized by an aggregate. The Master_Node
-- insertion point is after the last aggregate assignment.
elsif Present (Last_Aggregate_Assignment (Obj_Id)) then
if Present (Last_Aggregate_Assignment (Obj_Id)) then
Master_Node_Ins := Last_Aggregate_Assignment (Obj_Id);
-- The object is initialized by a build-in-place function call.
-- The Master_Node insertion point is after the function call.
elsif Present (BIP_Initialization_Call (Obj_Id)) then
Master_Node_Ins := BIP_Initialization_Call (Obj_Id);
-- In other cases the Master_Node is inserted after the last call
-- to either [Deep_]Initialize or the type-specific init proc.