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

341
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; type Case_Table_Type is array (Nat range <>) of Case_Bounds;
-- Table type used by Check_Case_Choices procedure -- 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; function Get_Base_Object (N : Node_Id) return Entity_Id;
-- Return the base object, i.e. the outermost prefix object, that N refers -- 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 -- to statically, or Empty if it cannot be determined. The assumption is
@ -181,7 +177,7 @@ package body Exp_Aggr is
Typ : Entity_Id; Typ : Entity_Id;
Lhs : Node_Id) return List_Id; Lhs : Node_Id) return List_Id;
-- N is an N_Aggregate or an N_Extension_Aggregate. Typ is the type of the -- 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 -- component by component assignments will take place. Returns the list of
-- assignments plus all other adjustments needed for tagged and controlled -- assignments plus all other adjustments needed for tagged and controlled
-- types. -- types.
@ -191,6 +187,9 @@ package body Exp_Aggr is
-- component by component. N is an N_Aggregate or N_Extension_Aggregate. -- component by component. N is an N_Aggregate or N_Extension_Aggregate.
-- Typ is the type of the record 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 procedure Expand_Record_Aggregate
(N : Node_Id; (N : Node_Id;
Orig_Tag : Node_Id := Empty; 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 -- functions of the parent type, and when applying a stream attribute to
-- an object of the derived type. -- 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 -- -- Local Subprograms for Array Aggregate Expansion --
----------------------------------------------------- -----------------------------------------------------
@ -299,9 +315,12 @@ package body Exp_Aggr is
-- these are cases we handle in there. -- these are cases we handle in there.
procedure Expand_Array_Aggregate (N : Node_Id); 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. -- 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; function Is_Two_Dim_Packed_Array (Typ : Entity_Id) return Boolean;
-- For 2D packed array aggregates with constant bounds and constant scalar -- For 2D packed array aggregates with constant bounds and constant scalar
-- components, it is preferable to pack the inner aggregates because the -- 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 procedure Expand_N_Aggregate (N : Node_Id) is
T : constant Entity_Id := Etype (N); T : constant Entity_Id := Etype (N);
begin begin
-- Record aggregate case -- Record aggregate case
@ -6508,6 +6528,8 @@ package body Exp_Aggr is
then then
Expand_Record_Aggregate (N); Expand_Record_Aggregate (N);
-- Container aggregate case
elsif Has_Aspect (T, Aspect_Aggregate) then elsif Has_Aspect (T, Aspect_Aggregate) then
Expand_Container_Aggregate (N); Expand_Container_Aggregate (N);
@ -6612,40 +6634,33 @@ package body Exp_Aggr is
return; return;
end Expand_N_Aggregate; end Expand_N_Aggregate;
-------------------------------- -------------------------------
-- Expand_Container_Aggregate -- -- Build_Container_Aggr_Code --
-------------------------------- -------------------------------
procedure Expand_Container_Aggregate (N : Node_Id) is 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); Loc : constant Source_Ptr := Sloc (N);
Typ : constant Entity_Id := Etype (N); Aggr_Code : constant List_Id := New_List;
Asp : constant Node_Id := Find_Value_Of_Aspect (Typ, Aspect_Aggregate); Asp : constant Node_Id :=
Find_Value_Of_Aspect (Typ, Aspect_Aggregate);
Empty_Subp : Node_Id := Empty; Empty_Subp : Node_Id := Empty;
Add_Named_Subp : Node_Id := Empty; Add_Named_Subp : Node_Id := Empty;
Add_Unnamed_Subp : Node_Id := Empty; Add_Unnamed_Subp : Node_Id := Empty;
New_Indexed_Subp : Node_Id := Empty; New_Indexed_Subp : Node_Id := Empty;
Assign_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;
-- 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_Lo : Node_Id := Empty;
Choice_Hi : Node_Id := Empty; Choice_Hi : Node_Id := Empty;
-- These variables are used to determine the smallest and largest
Is_Indexed_Aggregate : Boolean := False; -- choice values. Choice_Lo and Choice_Hi are passed to the New_Indexed
-- function, for allocating an indexed aggregate object.
function Aggregate_Size return Node_Id; function Aggregate_Size return Node_Id;
-- Compute number of entries in aggregate, including choices -- Compute number of entries in aggregate, including choices
@ -6658,7 +6673,7 @@ package body Exp_Aggr is
-- happens this function returns an empty node. In that case we will -- happens this function returns an empty node. In that case we will
-- later just allocate a default size for the aggregate. -- 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 -- When the aggregate contains a single Iterated_Component_Association
-- or Element_Association with non-static bounds, build an expression -- or Element_Association with non-static bounds, build an expression
-- to be used as the allocated size of the container. This may be an -- to be used as the allocated size of the container. This may be an
@ -6693,8 +6708,6 @@ package body Exp_Aggr is
Comp_Siz_Exp : Node_Id; Comp_Siz_Exp : Node_Id;
Siz_Exp : Node_Id; Siz_Exp : Node_Id;
-- Start of processing for Aggregate_Size
begin begin
-- Aggregate is either all positional or all named -- Aggregate is either all positional or all named
@ -6705,7 +6718,7 @@ package body Exp_Aggr is
Comp := First (Component_Associations (N)); Comp := First (Component_Associations (N));
while Present (Comp) loop while Present (Comp) loop
Comp_Siz_Exp := Build_Siz_Exp (Comp); Comp_Siz_Exp := Build_Size_Expr (Comp);
if No (Comp_Siz_Exp) then if No (Comp_Siz_Exp) then
@ -6714,6 +6727,7 @@ package body Exp_Aggr is
-- should use the default value instead. -- should use the default value instead.
return Empty; return Empty;
else else
if Is_Static_Expression (Siz_Exp) if Is_Static_Expression (Siz_Exp)
and then Is_Static_Expression (Comp_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)); To_Int (Siz_Exp) + To_Int (Comp_Siz_Exp));
Set_Is_Static_Expression (Siz_Exp); Set_Is_Static_Expression (Siz_Exp);
else else
Siz_Exp := Make_Op_Add (Sloc (Comp), Siz_Exp := Make_Op_Add (Sloc (Comp),
Left_Opnd => Siz_Exp, Left_Opnd => Siz_Exp,
@ -6738,11 +6753,11 @@ package body Exp_Aggr is
return Siz_Exp; return Siz_Exp;
end Aggregate_Size; 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; Lo, Hi : Node_Id;
It : Node_Id; It : Node_Id;
Siz_Exp : Node_Id := Empty; 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 -- Update the Choice_Lo and Choice_Hi variables with the smallest
-- and largest possible node values. -- 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_Lo : constant Int := To_Int (Lo);
Range_Int_Hi : constant Int := To_Int (Hi); Range_Int_Hi : constant Int := To_Int (Hi);
@ -6776,7 +6793,7 @@ package body Exp_Aggr is
end if; end if;
end Update_Choices; end Update_Choices;
-- Start of processing for Build_Siz_Exp -- Start of processing for Build_Size_Expr
begin begin
if Nkind (Comp) = N_Range then if Nkind (Comp) = N_Range then
@ -6797,6 +6814,7 @@ package body Exp_Aggr is
Set_Is_Static_Expression (Siz_Exp); Set_Is_Static_Expression (Siz_Exp);
return Siz_Exp; return Siz_Exp;
else else
-- Capture the nonstatic bounds, for later use in passing on -- Capture the nonstatic bounds, for later use in passing on
-- the call to New_Indexed. -- the call to New_Indexed.
@ -6833,7 +6851,7 @@ package body Exp_Aggr is
Siz_Exp : Node_Id := Empty; Siz_Exp : Node_Id := Empty;
begin begin
while Present (Idx_N) loop 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)); pragma Assert (Present (Temp_Siz_Exp));
@ -6866,8 +6884,9 @@ package body Exp_Aggr is
end if; end if;
return Empty; return Empty;
else else
return Build_Siz_Exp (First (Discrete_Choices (Comp))); return Build_Size_Expr (First (Discrete_Choices (Comp)));
end if; end if;
elsif Nkind (Comp) = N_Component_Association then elsif Nkind (Comp) = N_Component_Association then
@ -6878,7 +6897,7 @@ package body Exp_Aggr is
if Nkind (Choice) = N_Range then 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 -- 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 (Lo),
New_Copy_Tree (Hi))); New_Copy_Tree (Hi)));
Temp_Siz_Exp := Build_Siz_Exp (Choice); Temp_Siz_Exp := Build_Size_Expr (Choice);
-- Choice is a single discrete value -- Choice is a single discrete value
@ -6935,6 +6954,7 @@ package body Exp_Aggr is
end loop; end loop;
return Siz_Exp; return Siz_Exp;
elsif Nkind (Comp) = N_Iterated_Element_Association then elsif Nkind (Comp) = N_Iterated_Element_Association then
return Empty; return Empty;
@ -6945,7 +6965,7 @@ package body Exp_Aggr is
else else
return Empty; return Empty;
end if; end if;
end Build_Siz_Exp; end Build_Size_Expr;
------------------------------- -------------------------------
-- Expand_Iterated_Component -- -- Expand_Iterated_Component --
@ -6998,8 +7018,8 @@ package body Exp_Aggr is
(Loop_Parameter_Specification (Loop_Parameter_Specification
(L_Iteration_Scheme), Loop_Id); (L_Iteration_Scheme), Loop_Id);
end if; end if;
else
else
-- Iterated_Component_Association. -- Iterated_Component_Association.
if Present (Iterator_Specification (Comp)) then if Present (Iterator_Specification (Comp)) then
@ -7047,18 +7067,19 @@ package body Exp_Aggr is
(Make_Procedure_Call_Statement (Loc, (Make_Procedure_Call_Statement (Loc,
Name => New_Occurrence_Of (Entity (Add_Unnamed_Subp), Loc), Name => New_Occurrence_Of (Entity (Add_Unnamed_Subp), Loc),
Parameter_Associations => Parameter_Associations =>
New_List (New_Occurrence_Of (Temp, Loc), New_List (New_Copy_Tree (Lhs),
New_Copy_Tree (Expr)))); New_Copy_Tree (Expr))));
else else
-- Named or indexed aggregate, for which a key is present, -- Named or indexed aggregate, for which a key is present,
-- possibly with a specified key_expression. -- possibly with a specified key_expression.
if Present (Key_Expr) then if Present (Key_Expr) then
Params := New_List (New_Occurrence_Of (Temp, Loc), Params := New_List (New_Copy_Tree (Lhs),
New_Copy_Tree (Key_Expr), New_Copy_Tree (Key_Expr),
New_Copy_Tree (Expr)); New_Copy_Tree (Expr));
else else
Params := New_List (New_Occurrence_Of (Temp, Loc), Params := New_List (New_Copy_Tree (Lhs),
New_Occurrence_Of (Loop_Id, Loc), New_Occurrence_Of (Loop_Id, Loc),
New_Copy_Tree (Expr)); New_Copy_Tree (Expr));
end if; end if;
@ -7074,8 +7095,8 @@ package body Exp_Aggr is
Identifier => Empty, Identifier => Empty,
Iteration_Scheme => L_Iteration_Scheme, Iteration_Scheme => L_Iteration_Scheme,
Statements => Stats); Statements => Stats);
Append (Loop_Stat, Aggr_Code);
Append (Loop_Stat, Aggr_Code);
end Expand_Iterated_Component; end Expand_Iterated_Component;
---------------------------- ----------------------------
@ -7087,8 +7108,7 @@ package body Exp_Aggr is
Expr : Node_Id; Expr : Node_Id;
Insert_Op : Entity_Id) return Node_Id Insert_Op : Entity_Id) return Node_Id
is is
Loop_Id : constant Entity_Id := Loop_Id : constant Entity_Id := Make_Temporary (Loc, 'T');
Make_Temporary (Loc, 'T');
L_Iteration_Scheme : Node_Id; L_Iteration_Scheme : Node_Id;
Stats : List_Id; Stats : List_Id;
@ -7106,7 +7126,7 @@ package body Exp_Aggr is
Name => Name =>
New_Occurrence_Of (Insert_Op, Loc), New_Occurrence_Of (Insert_Op, Loc),
Parameter_Associations => Parameter_Associations =>
New_List (New_Occurrence_Of (Temp, Loc), New_List (New_Copy_Tree (Lhs),
New_Occurrence_Of (Loop_Id, Loc), New_Occurrence_Of (Loop_Id, Loc),
New_Copy_Tree (Expr)))); New_Copy_Tree (Expr))));
@ -7121,28 +7141,45 @@ package body Exp_Aggr is
-- To_Int -- -- To_Int --
------------ ------------
-- The bounds of the discrete range are integers or enumeration literals
function To_Int (Expr : N_Subexpr_Id) return Int is function To_Int (Expr : N_Subexpr_Id) return Int is
begin begin
-- The bounds of the discrete range are integers or enumeration
-- literals
return UI_To_Int ((if Nkind (Expr) = N_Integer_Literal return UI_To_Int ((if Nkind (Expr) = N_Integer_Literal
then Intval (Expr) then Intval (Expr)
else Enumeration_Pos (Expr))); else Enumeration_Pos (Expr)));
end To_Int; 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 begin
Parse_Aspect_Aggregate (Asp, Parse_Aspect_Aggregate (Asp,
Empty_Subp, Add_Named_Subp, Add_Unnamed_Subp, Empty_Subp, Add_Named_Subp, Add_Unnamed_Subp,
New_Indexed_Subp, Assign_Indexed_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 := Is_Indexed_Aggregate :=
Sem_Aggr.Is_Indexed_Aggregate Sem_Aggr.Is_Indexed_Aggregate
(N, Add_Unnamed_Subp, New_Indexed_Subp); (N, Add_Unnamed_Subp, New_Indexed_Subp);
-- Build the function call that initializes the anonymous object
declare
Empty_First_Formal : constant Entity_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 -- The constructor for bounded containers is a function with
-- a parameter that sets the size of the container. If the -- a parameter that sets the size of the container. If the
-- size cannot be determined statically we use a default value -- size cannot be determined statically we use a default value
@ -7150,14 +7187,6 @@ package body Exp_Aggr is
Siz_Exp := Aggregate_Size; Siz_Exp := Aggregate_Size;
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;
begin
-- If aggregate size is not static, we use the default value of the -- If aggregate size is not static, we use the default value of the
-- Empty operation's formal parameter for the allocation. We assume -- Empty operation's formal parameter for the allocation. We assume
-- that this (implementation-dependent) value is static, even though -- that this (implementation-dependent) value is static, even though
@ -7166,6 +7195,10 @@ package body Exp_Aggr is
if Present (Empty_First_Formal) then if Present (Empty_First_Formal) then
Default := Default_Value (Empty_First_Formal); Default := Default_Value (Empty_First_Formal);
Count_Type := Etype (Empty_First_Formal); Count_Type := Etype (Empty_First_Formal);
else
Default := Empty;
Count_Type := Standard_Natural;
end if; end if;
-- Create an object initialized by the aggregate's determined size -- Create an object initialized by the aggregate's determined size
@ -7174,32 +7207,21 @@ package body Exp_Aggr is
-- and the default otherwise. -- and the default otherwise.
if Present (Siz_Exp) then if Present (Siz_Exp) then
Siz_Exp := Make_Type_Conversion (Loc, Siz_Exp :=
Subtype_Mark => Make_Type_Conversion (Loc,
New_Occurrence_Of (Count_Type, Loc), Subtype_Mark => New_Occurrence_Of (Count_Type, Loc),
Expression => Siz_Exp); Expression => Siz_Exp);
elsif Present (Default) then elsif Present (Default) then
Siz_Exp := Make_Integer_Literal (Loc, Siz_Exp := New_Copy_Tree (Default);
UI_To_Int (Intval (Default)));
-- If the length isn't known and there's not a default, then use -- If the length isn't known and there's not a default, then use
-- zero for the initial container length. -- zero for the initial container length.
else else
Siz_Exp := Make_Type_Conversion (Loc, Siz_Exp := Make_Integer_Literal (Loc, 0);
Subtype_Mark =>
New_Occurrence_Of (Count_Type, Loc),
Expression => Make_Integer_Literal (Loc, 0));
end if; 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 -- In the case of an indexed aggregate, the aggregate is allocated
-- with the New_Indexed operation, passing the bounds. -- with the New_Indexed operation, passing the bounds.
@ -7223,10 +7245,7 @@ package body Exp_Aggr is
Left_Opnd => Make_Type_Conversion (Loc, Left_Opnd => Make_Type_Conversion (Loc,
Subtype_Mark => Subtype_Mark =>
New_Occurrence_Of (Index_Type, Loc), New_Occurrence_Of (Index_Type, Loc),
Expression => Expression => Siz_Exp),
New_Occurrence_Of
(Defining_Identifier (Siz_Decl),
Loc)),
Right_Opnd => Make_Integer_Literal (Loc, 1))); Right_Opnd => Make_Integer_Literal (Loc, 1)));
else else
@ -7234,40 +7253,28 @@ package body Exp_Aggr is
Choice_Hi := New_Copy_Tree (Choice_Hi); Choice_Hi := New_Copy_Tree (Choice_Hi);
end if; end if;
Init_Stat := Init :=
Make_Object_Declaration (Loc, Make_Function_Call (Loc,
Defining_Identifier => Temp, Name => New_Occurrence_Of (Entity (New_Indexed_Subp), Loc),
Object_Definition => New_Occurrence_Of (Typ, Loc), Parameter_Associations => New_List (Choice_Lo, Choice_Hi));
Expression => Make_Function_Call (Loc,
Name =>
New_Occurrence_Of (Entity (New_Indexed_Subp), Loc),
Parameter_Associations =>
New_List (Choice_Lo, Choice_Hi)));
end; end;
-- Otherwise we generate a call to the Empty function, passing the -- Otherwise we generate a call to the Empty function, passing the
-- determined number of elements as saved in Siz_Decl if the function -- determined number of elements Siz_Exp if the function has a formal
-- has a formal parameter, and otherwise making a parameterless call. -- parameter, and otherwise making a parameterless call.
else else
if Present (Empty_First_Formal) then if Present (Empty_First_Formal) then
Param_List := Param_List := New_List (Siz_Exp);
New_List
(New_Occurrence_Of (Defining_Identifier (Siz_Decl), Loc));
else else
Param_List := No_List; Param_List := No_List;
end if; end if;
Init_Stat := Init :=
Make_Object_Declaration (Loc, Make_Function_Call (Loc,
Defining_Identifier => Temp,
Object_Definition => New_Occurrence_Of (Typ, Loc),
Expression => Make_Function_Call (Loc,
Name => New_Occurrence_Of (Entity (Empty_Subp), Loc), Name => New_Occurrence_Of (Entity (Empty_Subp), Loc),
Parameter_Associations => Param_List)); Parameter_Associations => Param_List);
end if; end if;
Append (Init_Stat, Aggr_Code);
end; end;
-- Report warning on infinite recursion if an empty container aggregate -- Report warning on infinite recursion if an empty container aggregate
@ -7361,12 +7368,12 @@ package body Exp_Aggr is
end if; end if;
Param_List := Param_List :=
New_List (New_Occurrence_Of (Temp, Loc), New_List (New_Copy_Tree (Lhs),
New_Occurrence_Of (Key_Index, Loc), New_Occurrence_Of (Key_Index, Loc),
New_Copy_Tree (Comp)); New_Copy_Tree (Comp));
else else
Param_List := Param_List :=
New_List (New_Occurrence_Of (Temp, Loc), New_List (New_Copy_Tree (Lhs),
New_Copy_Tree (Comp)); New_Copy_Tree (Comp));
end if; end if;
@ -7382,6 +7389,10 @@ package body Exp_Aggr is
-- such as sets may include iterated component associations. -- such as sets may include iterated component associations.
elsif not Is_Indexed_Aggregate then elsif not Is_Indexed_Aggregate then
declare
Comp : Node_Id;
begin
Comp := First (Component_Associations (N)); Comp := First (Component_Associations (N));
while Present (Comp) loop while Present (Comp) loop
if Nkind (Comp) = N_Iterated_Component_Association if Nkind (Comp) = N_Iterated_Component_Association
@ -7391,6 +7402,7 @@ package body Exp_Aggr is
end if; end if;
Next (Comp); Next (Comp);
end loop; end loop;
end;
end if; end if;
--------------------- ---------------------
@ -7400,8 +7412,11 @@ package body Exp_Aggr is
elsif Present (Add_Named_Subp) then elsif Present (Add_Named_Subp) then
declare declare
Insert : constant Entity_Id := Entity (Add_Named_Subp); Insert : constant Entity_Id := Entity (Add_Named_Subp);
Stat : Node_Id;
Comp : Node_Id;
Key : Node_Id; Key : Node_Id;
Stat : Node_Id;
begin begin
Comp := First (Component_Associations (N)); Comp := First (Component_Associations (N));
@ -7429,7 +7444,7 @@ package body Exp_Aggr is
Stat := Make_Procedure_Call_Statement (Loc, Stat := Make_Procedure_Call_Statement (Loc,
Name => New_Occurrence_Of (Insert, Loc), Name => New_Occurrence_Of (Insert, Loc),
Parameter_Associations => Parameter_Associations =>
New_List (New_Occurrence_Of (Temp, Loc), New_List (New_Copy_Tree (Lhs),
New_Copy_Tree (Key), New_Copy_Tree (Key),
New_Copy_Tree (Expression (Comp)))); New_Copy_Tree (Expression (Comp))));
end if; end if;
@ -7498,7 +7513,7 @@ package body Exp_Aggr is
Stat := Make_Procedure_Call_Statement (Loc, Stat := Make_Procedure_Call_Statement (Loc,
Name => New_Occurrence_Of (Insert, Loc), Name => New_Occurrence_Of (Insert, Loc),
Parameter_Associations => Parameter_Associations =>
New_List (New_Occurrence_Of (Temp, Loc), New_List (New_Copy_Tree (Lhs),
New_Copy_Tree (Key), New_Copy_Tree (Key),
New_Copy_Tree (Expression (Comp)))); New_Copy_Tree (Expression (Comp))));
end if; end if;
@ -7527,9 +7542,107 @@ package body Exp_Aggr is
end; end;
end if; end if;
Insert_Actions (N, Aggr_Code); return Aggr_Code;
Rewrite (N, New_Occurrence_Of (Temp, Loc)); 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); 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; 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; Adj_Call : Node_Id;
Aggr_In_Place : Boolean; Aggr_In_Place : Boolean;
Container_Aggr : Boolean;
Delayed_Cond_Expr : Boolean; Delayed_Cond_Expr : Boolean;
Node : Node_Id; Node : Node_Id;
Temp : Entity_Id; Temp : Entity_Id;
@ -668,6 +669,8 @@ package body Exp_Ch4 is
TagR : Node_Id := Empty; TagR : Node_Id := Empty;
-- Target reference for tag assignment -- Target reference for tag assignment
-- Start of processing for Expand_Allocator_Expression
begin begin
-- Handle call to C++ constructor -- Handle call to C++ constructor
@ -689,14 +692,19 @@ package body Exp_Ch4 is
Aggr_In_Place := Is_Delayed_Aggregate (Exp); Aggr_In_Place := Is_Delayed_Aggregate (Exp);
Delayed_Cond_Expr := Is_Delayed_Conditional_Expression (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 -- 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 -- to delay applying predicate checks, because this would result in the
-- creation of a temporary, which is illegal for limited types and just -- creation of a temporary, which is illegal for limited types and just
-- inefficient in the other cases. Likewise for a conditional expression -- 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); Apply_Predicate_Check (Exp, T);
end if; end if;
@ -759,9 +767,26 @@ package body Exp_Ch4 is
return; return;
end if; 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 -- 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 -- Ada 2005 (AI-318-02): If the initialization expression is a call
-- to a build-in-place function, then access to the allocated object -- 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); Build_Allocate_Deallocate_Proc (Declaration_Node (Temp), Mark => N);
Rewrite (N, New_Occurrence_Of (Temp, Loc)); Rewrite (N, New_Occurrence_Of (Temp, Loc));
Analyze_And_Resolve (N, PtrT); Analyze_And_Resolve (N, PtrT);
Apply_Predicate_Check (N, T, Deref => True); Apply_Predicate_Check (N, T, Deref => True);
elsif Is_Access_Type (T) and then Can_Never_Be_Null (T) then 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 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 -- The object is initialized by an aggregate. The Master_Node
-- insertion point is after the last aggregate assignment. -- 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); 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 -- In other cases the Master_Node is inserted after the last call
-- to either [Deep_]Initialize or the type-specific init proc. -- to either [Deep_]Initialize or the type-specific init proc.