@@ -283,7 +283,7 @@ package body Exp_Aggr is
-- are writing into.
procedure Convert_Array_Aggr_In_Allocator
- (Decl : Node_Id;
+ (N : Node_Id;
Aggr : Node_Id;
Target : Node_Id);
-- If the aggregate appears within an allocator and can be expanded in
@@ -3542,13 +3542,12 @@ package body Exp_Aggr is
-------------------------------
procedure Convert_Aggr_In_Allocator
- (Alloc : Node_Id;
- Decl : Node_Id;
- Aggr : Node_Id)
+ (N : Node_Id;
+ Aggr : Node_Id;
+ Temp : Entity_Id)
is
Loc : constant Source_Ptr := Sloc (Aggr);
Typ : constant Entity_Id := Etype (Aggr);
- Temp : constant Entity_Id := Defining_Identifier (Decl);
Occ : constant Node_Id :=
Unchecked_Convert_To (Typ,
@@ -3556,26 +3555,29 @@ package body Exp_Aggr is
begin
if Is_Array_Type (Typ) then
- Convert_Array_Aggr_In_Allocator (Decl, Aggr, Occ);
+ Convert_Array_Aggr_In_Allocator (N, Aggr, Occ);
elsif Has_Default_Init_Comps (Aggr) then
declare
- L : constant List_Id := New_List;
- Init_Stmts : List_Id;
+ Init_Stmts : constant List_Id := Late_Expansion (Aggr, Typ, Occ);
begin
- Init_Stmts := Late_Expansion (Aggr, Typ, Occ);
-
if Has_Task (Typ) then
- Build_Task_Allocate_Block (L, Aggr, Init_Stmts);
- Insert_Actions (Alloc, L);
+ declare
+ Actions : constant List_Id := New_List;
+
+ begin
+ Build_Task_Allocate_Block (Actions, Aggr, Init_Stmts);
+ Insert_Actions (N, Actions);
+ end;
+
else
- Insert_Actions (Alloc, Init_Stmts);
+ Insert_Actions (N, Init_Stmts);
end if;
end;
else
- Insert_Actions (Alloc, Late_Expansion (Aggr, Typ, Occ));
+ Insert_Actions (N, Late_Expansion (Aggr, Typ, Occ));
end if;
end Convert_Aggr_In_Allocator;
@@ -3774,7 +3776,7 @@ package body Exp_Aggr is
-------------------------------------
procedure Convert_Array_Aggr_In_Allocator
- (Decl : Node_Id;
+ (N : Node_Id;
Aggr : Node_Id;
Target : Node_Id)
is
@@ -3829,7 +3831,7 @@ package body Exp_Aggr is
Scalar_Comp => Is_Scalar_Type (Ctyp));
end if;
- Insert_Actions_After (Decl, Aggr_Code);
+ Insert_Actions (N, Aggr_Code);
end Convert_Array_Aggr_In_Allocator;
------------------------
@@ -31,24 +31,14 @@ package Exp_Aggr is
procedure Expand_N_Delta_Aggregate (N : Node_Id);
procedure Expand_N_Extension_Aggregate (N : Node_Id);
- function Is_Delayed_Aggregate (N : Node_Id) return Boolean;
- -- Returns True if N is an aggregate of some kind whose Expansion_Delayed
- -- flag is set (see sinfo for meaning of flag).
-
- procedure Convert_Aggr_In_Object_Decl (N : Node_Id);
- -- N is a N_Object_Declaration with an expression which must be an
- -- N_Aggregate or N_Extension_Aggregate with Expansion_Delayed.
- -- This procedure performs in-place aggregate assignment.
-
procedure Convert_Aggr_In_Allocator
- (Alloc : Node_Id;
- Decl : Node_Id;
- Aggr : Node_Id);
- -- Alloc is the allocator whose expression is the aggregate Aggr.
- -- Decl is an N_Object_Declaration created during allocator expansion.
- -- This procedure performs in-place aggregate assignment into the
- -- temporary declared in Decl, and the allocator becomes an access to
- -- that temporary.
+ (N : Node_Id;
+ Aggr : Node_Id;
+ Temp : Entity_Id);
+ -- N is an N_Allocator whose (ultimate) expression is the aggregate Aggr.
+ -- This procedure performs an in-place aggregate assignment into an object
+ -- allocated with the subtype of Aggr and designated by Temp, so that N
+ -- can be rewritten as a mere occurrence of Temp.
procedure Convert_Aggr_In_Assignment (N : Node_Id);
-- If the right-hand side of an assignment is an aggregate, expand the
@@ -57,6 +47,15 @@ package Exp_Aggr is
-- the components, and the aggregate cannot be handled as a whole by the
-- backend.
+ procedure Convert_Aggr_In_Object_Decl (N : Node_Id);
+ -- N is an N_Object_Declaration with an expression which must be an
+ -- N_Aggregate or N_Extension_Aggregate with Expansion_Delayed.
+ -- This procedure performs in-place aggregate assignment.
+
+ function Is_Delayed_Aggregate (N : Node_Id) return Boolean;
+ -- Returns True if N is an aggregate of some kind whose Expansion_Delayed
+ -- flag is set (see sinfo for meaning of flag).
+
function Static_Array_Aggregate (N : Node_Id) return Boolean;
-- N is an array aggregate that may have a component association with
-- an others clause and a range. If bounds are static and the expressions
@@ -380,7 +380,7 @@ package body Exp_Ch13 is
-- ensures that the hidden list header will be deallocated along with
-- the actual object.
- Build_Allocate_Deallocate_Proc (N, Is_Allocate => False);
+ Build_Allocate_Deallocate_Proc (N);
end Expand_N_Free_Statement;
----------------------------
@@ -562,6 +562,45 @@ package body Exp_Ch4 is
DesigT : constant Entity_Id := Designated_Type (PtrT);
Special_Return : constant Boolean := For_Special_Return_Object (N);
+ procedure Build_Aggregate_In_Place (Temp : Entity_Id; Typ : Entity_Id);
+ -- If Exp is an aggregate to build in place, build the declaration of
+ -- Temp with Typ and with expression an uninitialized allocator for
+ -- Etype (Exp), then perform an in-place aggregate assignment of Exp
+ -- into the allocated memory.
+
+ ------------------------------
+ -- Build_Aggregate_In_Place --
+ ------------------------------
+
+ procedure Build_Aggregate_In_Place (Temp : Entity_Id; Typ : Entity_Id) is
+ Temp_Decl : constant Node_Id :=
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Temp,
+ Object_Definition => New_Occurrence_Of (Typ, Loc),
+ Expression =>
+ Make_Allocator (Loc,
+ Expression => New_Occurrence_Of (Etype (Exp), Loc)));
+
+ begin
+ -- Prevent default initialization of the allocator
+
+ Set_No_Initialization (Expression (Temp_Decl));
+
+ -- Copy the Comes_From_Source flag onto the allocator since logically
+ -- this allocator is a replacement of the original allocator. This is
+ -- for proper handling of restriction No_Implicit_Heap_Allocations.
+
+ Preserve_Comes_From_Source (Expression (Temp_Decl), N);
+
+ -- Insert declaration, assignment and build the allocation procedure
+
+ Insert_Action (N, Temp_Decl);
+ Convert_Aggr_In_Allocator (N, Exp, Temp);
+ Build_Allocate_Deallocate_Proc (Temp_Decl);
+ end Build_Aggregate_In_Place;
+
+ -- Local variables
+
Adj_Call : Node_Id;
Aggr_In_Place : Boolean;
Node : Node_Id;
@@ -753,28 +792,7 @@ package body Exp_Ch4 is
if not Is_Interface (DesigT) then
if Aggr_In_Place then
- Temp_Decl :=
- Make_Object_Declaration (Loc,
- Defining_Identifier => Temp,
- Object_Definition => New_Occurrence_Of (PtrT, Loc),
- Expression =>
- Make_Allocator (Loc,
- Expression =>
- New_Occurrence_Of (Etype (Exp), Loc)));
-
- -- Copy the Comes_From_Source flag for the allocator we just
- -- built, since logically this allocator is a replacement of
- -- the original allocator node. This is for proper handling of
- -- restriction No_Implicit_Heap_Allocations.
-
- Preserve_Comes_From_Source
- (Expression (Temp_Decl), N);
-
- Set_No_Initialization (Expression (Temp_Decl));
- Insert_Action (N, Temp_Decl);
-
- Build_Allocate_Deallocate_Proc (Temp_Decl, True);
- Convert_Aggr_In_Allocator (N, Temp_Decl, Exp);
+ Build_Aggregate_In_Place (Temp, PtrT);
else
Node := Relocate_Node (N);
@@ -788,7 +806,7 @@ package body Exp_Ch4 is
Expression => Node);
Insert_Action (N, Temp_Decl);
- Build_Allocate_Deallocate_Proc (Temp_Decl, True);
+ Build_Allocate_Deallocate_Proc (Temp_Decl);
end if;
-- Ada 2005 (AI-251): Handle allocators whose designated type is an
@@ -827,27 +845,7 @@ package body Exp_Ch4 is
-- Declare the object using the previous type declaration
if Aggr_In_Place then
- Temp_Decl :=
- Make_Object_Declaration (Loc,
- Defining_Identifier => Temp,
- Object_Definition => New_Occurrence_Of (Def_Id, Loc),
- Expression =>
- Make_Allocator (Loc,
- New_Occurrence_Of (Etype (Exp), Loc)));
-
- -- Copy the Comes_From_Source flag for the allocator we just
- -- built, since logically this allocator is a replacement of
- -- the original allocator node. This is for proper handling
- -- of restriction No_Implicit_Heap_Allocations.
-
- Set_Comes_From_Source
- (Expression (Temp_Decl), Comes_From_Source (N));
-
- Set_No_Initialization (Expression (Temp_Decl));
- Insert_Action (N, Temp_Decl);
-
- Build_Allocate_Deallocate_Proc (Temp_Decl, True);
- Convert_Aggr_In_Allocator (N, Temp_Decl, Exp);
+ Build_Aggregate_In_Place (Temp, Def_Id);
else
Node := Relocate_Node (N);
@@ -861,7 +859,7 @@ package body Exp_Ch4 is
Expression => Node);
Insert_Action (N, Temp_Decl);
- Build_Allocate_Deallocate_Proc (Temp_Decl, True);
+ Build_Allocate_Deallocate_Proc (Temp_Decl);
end if;
-- Generate an additional object containing the address of the
@@ -992,28 +990,7 @@ package body Exp_Ch4 is
or else (Modify_Tree_For_C and then Nkind (Exp) = N_Aggregate)
then
Temp := Make_Temporary (Loc, 'P', N);
- Temp_Decl :=
- Make_Object_Declaration (Loc,
- Defining_Identifier => Temp,
- Object_Definition => New_Occurrence_Of (PtrT, Loc),
- Expression =>
- Make_Allocator (Loc,
- Expression => New_Occurrence_Of (Etype (Exp), Loc)));
-
- -- Copy the Comes_From_Source flag for the allocator we just built,
- -- since logically this allocator is a replacement of the original
- -- allocator node. This is for proper handling of restriction
- -- No_Implicit_Heap_Allocations.
-
- Set_Comes_From_Source
- (Expression (Temp_Decl), Comes_From_Source (N));
-
- Set_No_Initialization (Expression (Temp_Decl));
- Insert_Action (N, Temp_Decl);
-
- Build_Allocate_Deallocate_Proc (Temp_Decl, True);
- Convert_Aggr_In_Allocator (N, Temp_Decl, Exp);
-
+ Build_Aggregate_In_Place (Temp, PtrT);
Rewrite (N, New_Occurrence_Of (Temp, Loc));
Analyze_And_Resolve (N, PtrT);
@@ -1041,7 +1018,7 @@ package body Exp_Ch4 is
end if;
else
- Build_Allocate_Deallocate_Proc (N, True);
+ Build_Allocate_Deallocate_Proc (N);
-- For an access-to-unconstrained-packed-array type, build an
-- expression with a constrained subtype in order for the code
@@ -2589,7 +2566,7 @@ package body Exp_Ch4 is
end if;
end To_Ityp;
- -- Local Declarations
+ -- Local variables
Opnd_Typ : Entity_Id;
Slice_Rng : Node_Id;
@@ -4626,7 +4603,7 @@ package body Exp_Ch4 is
-- the context requires it.
elsif No_Initialization (N) then
- Build_Allocate_Deallocate_Proc (N, True);
+ Build_Allocate_Deallocate_Proc (N);
-- If the allocator is for a type which requires initialization, and
-- there is no initial value (i.e. operand is a subtype indication
@@ -4685,7 +4662,7 @@ package body Exp_Ch4 is
Expression => Relocate_Node (N));
Insert_Action (N, Temp_Decl, Suppress => All_Checks);
- Build_Allocate_Deallocate_Proc (Temp_Decl, True);
+ Build_Allocate_Deallocate_Proc (Temp_Decl);
-- Generate:
-- Temp.all := ...
@@ -4822,7 +4799,7 @@ package body Exp_Ch4 is
Expression => Relocate_Node (N));
Insert_Action (N, Temp_Decl, Suppress => All_Checks);
- Build_Allocate_Deallocate_Proc (Temp_Decl, True);
+ Build_Allocate_Deallocate_Proc (Temp_Decl);
-- If the designated type is a task type or contains tasks,
-- create a specific block to activate the created tasks.
@@ -4875,7 +4852,7 @@ package body Exp_Ch4 is
-- No initialization required
else
- Build_Allocate_Deallocate_Proc (N, True);
+ Build_Allocate_Deallocate_Proc (N);
end if;
end if;
end if;
@@ -721,10 +721,9 @@ package body Exp_Util is
-- Build_Allocate_Deallocate_Proc --
------------------------------------
- procedure Build_Allocate_Deallocate_Proc
- (N : Node_Id;
- Is_Allocate : Boolean)
- is
+ procedure Build_Allocate_Deallocate_Proc (N : Node_Id) is
+ Is_Allocate : constant Boolean := Nkind (N) /= N_Free_Statement;
+
function Find_Object (E : Node_Id) return Node_Id;
-- Given an arbitrary expression of an allocator, try to find an object
-- reference in it, otherwise return the original expression.
@@ -827,14 +826,9 @@ package body Exp_Util is
-- Start of processing for Build_Allocate_Deallocate_Proc
begin
- -- Obtain the attributes of the allocation / deallocation
-
- if Nkind (N) = N_Free_Statement then
- Expr := Expression (N);
- Ptr_Typ := Base_Type (Etype (Expr));
- Proc_To_Call := Procedure_To_Call (N);
+ -- Obtain the attributes of the allocation
- else
+ if Is_Allocate then
if Nkind (N) = N_Object_Declaration then
Expr := Expression (N);
else
@@ -862,7 +856,7 @@ package body Exp_Util is
and then Nkind (Parent (Entity (Expr))) = N_Object_Declaration
and then Nkind (Expression (Parent (Entity (Expr)))) = N_Allocator
then
- Build_Allocate_Deallocate_Proc (Parent (Entity (Expr)), True);
+ Build_Allocate_Deallocate_Proc (Parent (Entity (Expr)));
return;
end if;
@@ -870,6 +864,13 @@ package body Exp_Util is
Ptr_Typ := Base_Type (Etype (Expr));
Proc_To_Call := Procedure_To_Call (Expr);
+
+ -- Obtain the attributes of the deallocation
+
+ else
+ Expr := Expression (N);
+ Ptr_Typ := Base_Type (Etype (Expr));
+ Proc_To_Call := Procedure_To_Call (N);
end if;
Pool_Id := Associated_Storage_Pool (Ptr_Typ);
@@ -968,7 +969,6 @@ package body Exp_Util is
Size_Id : constant Entity_Id := Make_Temporary (Loc, 'S');
Actuals : List_Id;
- Alloc_Nod : Node_Id := Empty;
Alloc_Expr : Node_Id := Empty;
Fin_Addr_Id : Entity_Id;
Fin_Coll_Act : Node_Id;
@@ -981,29 +981,11 @@ package body Exp_Util is
-- node for later processing and calculation of alignment.
if Is_Allocate then
-
- if Nkind (Expr) = N_Allocator then
- Alloc_Nod := Expr;
-
- -- When Expr is an object declaration we have to examine its
- -- expression.
-
- elsif Nkind (Expr) = N_Object_Declaration
- and then Nkind (Expression (Expr)) = N_Allocator
- then
- Alloc_Nod := Expression (Expr);
-
- -- Otherwise, we raise an error because we should have found one
-
- else
- raise Program_Error;
- end if;
-
-- Extract the qualified expression if there is one from the
-- allocator.
- if Nkind (Expression (Alloc_Nod)) = N_Qualified_Expression then
- Alloc_Expr := Expression (Alloc_Nod);
+ if Nkind (Expression (Expr)) = N_Qualified_Expression then
+ Alloc_Expr := Expression (Expr);
end if;
end if;
@@ -234,9 +234,7 @@ package Exp_Util is
-- Return the static value of a statically known attribute reference
-- Pref'Constrained.
- procedure Build_Allocate_Deallocate_Proc
- (N : Node_Id;
- Is_Allocate : Boolean);
+ procedure Build_Allocate_Deallocate_Proc (N : Node_Id);
-- Create a custom Allocate/Deallocate to be associated with an allocation
-- or deallocation:
--
@@ -246,8 +244,7 @@ package Exp_Util is
--
-- N must be an allocator or the declaration of a temporary variable which
-- represents the expression of the original allocator node, otherwise N
- -- must be a free statement. If flag Is_Allocate is set, the generated
- -- routine is allocate, deallocate otherwise.
+ -- must be a free statement.
function Build_Abort_Undefer_Block
(Loc : Source_Ptr;
From: Eric Botcazou <ebotcazou@adacore.com> This eliminates a few oddities present in the expander for allocators and aggregates present in allocators: - Convert_Array_Aggr_In_Allocator takes both a Decl and Alloc parameters, and inserts new code before Alloc for records and after Decl for arrays through Convert_Array_Aggr_In_Allocator. Now, for the 3 (duplicated) calls to the procedure, that's the same place. It also creates a new list that it does not use in most cases. - Expand_Allocator_Expression uses the same code sequence in 3 places when the expression is an aggregate to build in place. - Build_Allocate_Deallocate_Proc takes an Is_Allocate parameter that is entirely determined by the N parameter: if N is an allocator, it must be true; if N is a free statement, it must be false. Barring that, the procedure either raises an assertion or Program_Error. It also contains useless pattern matching code in the second part. No functional changes. gcc/ada/ * exp_aggr.ads (Convert_Aggr_In_Allocator): Rename Alloc into N, replace Decl with Temp and adjust description. (Convert_Aggr_In_Object_Decl): Alphabetize. (Is_Delayed_Aggregate): Likewise. * exp_aggr.adb (Convert_Aggr_In_Allocator): Rename Alloc into N and replace Decl with Temp. Allocate a list only when neeeded. (Convert_Array_Aggr_In_Allocator): Replace N with Decl and insert new code before it. * exp_ch4.adb (Build_Aggregate_In_Place): New procedure nested in Expand_Allocator_Expression. (Expand_Allocator_Expression): Call it to build aggregates in place. Remove second parameter in calls to Build_Allocate_Deallocate_Proc. (Expand_N_Allocator): Likewise. * exp_ch13.adb (Expand_N_Free_Statement): Likewise. * exp_util.ads (Build_Allocate_Deallocate_Proc): Remove Is_Allocate parameter. * exp_util.adb (Build_Allocate_Deallocate_Proc): Remove Is_Allocate parameter and replace it with local variable of same name. Delete useless pattern matching. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/exp_aggr.adb | 34 ++++++------ gcc/ada/exp_aggr.ads | 33 ++++++------ gcc/ada/exp_ch13.adb | 2 +- gcc/ada/exp_ch4.adb | 123 ++++++++++++++++++------------------------- gcc/ada/exp_util.adb | 48 ++++++----------- gcc/ada/exp_util.ads | 7 +-- 6 files changed, 102 insertions(+), 145 deletions(-)