@@ -53,6 +53,7 @@ with Sem_Aggr; use Sem_Aggr;
with Sem_Aux; use Sem_Aux;
with Sem_Ch3; use Sem_Ch3;
with Sem_Eval; use Sem_Eval;
+with Sem_Mech; use Sem_Mech;
with Sem_Res; use Sem_Res;
with Sem_Util; use Sem_Util;
with Sinfo; use Sinfo;
@@ -86,6 +87,11 @@ package body Exp_Aggr is
procedure Expand_Delta_Array_Aggregate (N : Node_Id; Deltas : List_Id);
procedure Expand_Delta_Record_Aggregate (N : Node_Id; Deltas : List_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
+ -- that all dereferences are explicit in the tree rooted at N.
+
function Has_Default_Init_Comps (N : Node_Id) return Boolean;
-- N is an aggregate (record or array). Checks the presence of default
-- initialization (<>) in any component (Ada 2005: AI-287).
@@ -217,7 +223,9 @@ package body Exp_Aggr is
-- defaults. An aggregate for a type with mutable components must be
-- expanded into individual assignments.
- function In_Place_Assign_OK (N : Node_Id) return Boolean;
+ function In_Place_Assign_OK
+ (N : Node_Id;
+ Target_Object : Entity_Id := Empty) return Boolean;
-- Predicate to determine whether an aggregate assignment can be done in
-- place, because none of the new values can depend on the components of
-- the target of the assignment.
@@ -4122,23 +4130,40 @@ package body Exp_Aggr is
-- In_Place_Assign_OK --
------------------------
- function In_Place_Assign_OK (N : Node_Id) return Boolean is
+ function In_Place_Assign_OK
+ (N : Node_Id;
+ Target_Object : Entity_Id := Empty) return Boolean
+ is
Is_Array : constant Boolean := Is_Array_Type (Etype (N));
- Aggr_In : Node_Id;
- Aggr_Lo : Node_Id;
- Aggr_Hi : Node_Id;
- Obj_In : Node_Id;
- Obj_Lo : Node_Id;
- Obj_Hi : Node_Id;
+ Aggr_In : Node_Id;
+ Aggr_Lo : Node_Id;
+ Aggr_Hi : Node_Id;
+ Obj_In : Node_Id;
+ Obj_Lo : Node_Id;
+ Obj_Hi : Node_Id;
+ Parent_Kind : Node_Kind;
+ Parent_Node : Node_Id;
function Safe_Aggregate (Aggr : Node_Id) return Boolean;
-- Check recursively that each component of a (sub)aggregate does not
-- depend on the variable being assigned to.
function Safe_Component (Expr : Node_Id) return Boolean;
- -- Verify that an expression cannot depend on the variable being
- -- assigned to. Room for improvement here (but less than before).
+ -- Verify that an expression cannot depend on the target being assigned
+ -- to. Return true for compile-time known values, stand-alone objects,
+ -- parameters passed by copy, calls to functions that return by copy,
+ -- selected components thereof only if the aggregate's type is an array,
+ -- indexed components and slices thereof only if the aggregate's type is
+ -- a record, and simple expressions involving only these as operands.
+ -- This is OK whatever the target because, for a component to overlap
+ -- with the target, it must be either a direct reference to a component
+ -- of the target, in which case there must be a matching selection or
+ -- indexation or slicing, or an indirect reference to such a component,
+ -- which is excluded by the above condition. Additionally, if the target
+ -- is statically known, return true for arbitrarily nested selections,
+ -- indexations or slicings, provided that their ultimate prefix is not
+ -- the target itself.
--------------------
-- Safe_Aggregate --
@@ -4200,43 +4225,137 @@ package body Exp_Aggr is
function Safe_Component (Expr : Node_Id) return Boolean is
Comp : Node_Id := Expr;
- function Check_Component (Comp : Node_Id) return Boolean;
- -- Do the recursive traversal, after copy
+ function Check_Component (C : Node_Id; T_OK : Boolean) return Boolean;
+ -- Do the recursive traversal, after copy. If T_OK is True, return
+ -- True for a stand-alone object only if the target is statically
+ -- known and distinct from the object. At the top level, we start
+ -- with T_OK set to False and set it to True at a deeper level only
+ -- if we cannot disambiguate the component here without statically
+ -- knowing the target. Note that this is not optimal, we should do
+ -- something along the lines of Denotes_Same_Prefix for that.
---------------------
-- Check_Component --
---------------------
- function Check_Component (Comp : Node_Id) return Boolean is
+ function Check_Component (C : Node_Id; T_OK : Boolean) return Boolean
+ is
+
+ function SDO (E : Entity_Id) return Uint;
+ -- Return the Scope Depth Of the enclosing dynamic scope of E
+
+ ---------
+ -- SDO --
+ ---------
+
+ function SDO (E : Entity_Id) return Uint is
+ begin
+ return Scope_Depth (Enclosing_Dynamic_Scope (E));
+ end SDO;
+
+ -- Start of processing for Check_Component
+
begin
- if Is_Overloaded (Comp) then
+ if Is_Overloaded (C) then
return False;
+
+ elsif Compile_Time_Known_Value (C) then
+ return True;
end if;
- return Compile_Time_Known_Value (Comp)
+ case Nkind (C) is
+ when N_Attribute_Reference =>
+ return Check_Component (Prefix (C), T_OK);
+
+ when N_Function_Call =>
+ if Nkind (Name (C)) = N_Explicit_Dereference then
+ return not Returns_By_Ref (Etype (Name (C)));
+ else
+ return not Returns_By_Ref (Entity (Name (C)));
+ end if;
+
+ when N_Indexed_Component | N_Slice =>
+ -- In a target record, these operations cannot determine
+ -- alone a component so we can recurse whatever the target.
+ return Check_Component (Prefix (C), T_OK or else Is_Array);
+
+ when N_Selected_Component =>
+ -- In a target array, this operation cannot determine alone
+ -- a component so we can recurse whatever the target.
+ return
+ Check_Component (Prefix (C), T_OK or else not Is_Array);
+
+ when N_Type_Conversion | N_Unchecked_Type_Conversion =>
+ return Check_Component (Expression (C), T_OK);
- or else (Is_Entity_Name (Comp)
- and then Present (Entity (Comp))
- and then Ekind (Entity (Comp)) not in Type_Kind
- and then No (Renamed_Object (Entity (Comp))))
+ when N_Binary_Op =>
+ return Check_Component (Left_Opnd (C), T_OK)
+ and then Check_Component (Right_Opnd (C), T_OK);
- or else (Nkind (Comp) = N_Attribute_Reference
- and then Check_Component (Prefix (Comp)))
+ when N_Unary_Op =>
+ return Check_Component (Right_Opnd (C), T_OK);
- or else (Nkind (Comp) in N_Binary_Op
- and then Check_Component (Left_Opnd (Comp))
- and then Check_Component (Right_Opnd (Comp)))
+ when others =>
+ if Is_Entity_Name (C) and then Is_Object (Entity (C)) then
+ -- Case of a formal parameter component. It's either
+ -- trivial if passed by copy or very annoying if not,
+ -- because in the latter case it's almost equivalent
+ -- to a dereference, so the path-based disambiguation
+ -- logic is totally off and we always need the target.
- or else (Nkind (Comp) in N_Unary_Op
- and then Check_Component (Right_Opnd (Comp)))
+ if Is_Formal (Entity (C)) then
+
+ -- If it is passed by copy, then this is safe
+
+ if Mechanism (Entity (C)) = By_Copy then
+ return True;
+
+ -- Otherwise, this is safe if the target is present
+ -- and is at least as deeply nested as the component.
+
+ else
+ return Present (Target_Object)
+ and then not Is_Formal (Target_Object)
+ and then SDO (Target_Object) >= SDO (Entity (C));
+ end if;
+
+ -- For a renamed object, recurse
+
+ elsif Present (Renamed_Object (Entity (C))) then
+ return
+ Check_Component (Renamed_Object (Entity (C)), T_OK);
+
+ -- If this is safe whatever the target, we are done
+
+ elsif not T_OK then
+ return True;
+
+ -- If there is no target or the component is the target,
+ -- this is not safe.
+
+ elsif No (Target_Object)
+ or else Entity (C) = Target_Object
+ then
+ return False;
+
+ -- Case of a formal parameter target. This is safe if it
+ -- is at most as deeply nested as the component.
+
+ elsif Is_Formal (Target_Object) then
+ return SDO (Target_Object) <= SDO (Entity (C));
+
+ -- For distinct stand-alone objects, this is safe
+
+ else
+ return True;
+ end if;
- or else (Nkind (Comp) = N_Selected_Component
- and then Is_Array
- and then Check_Component (Prefix (Comp)))
+ -- For anything else than an object, this is not safe
- or else (Nkind_In (Comp, N_Type_Conversion,
- N_Unchecked_Type_Conversion)
- and then Check_Component (Expression (Comp)));
+ else
+ return False;
+ end if;
+ end case;
end Check_Component;
-- Start of processing for Safe_Component
@@ -4275,7 +4394,7 @@ package body Exp_Aggr is
if Nkind (Comp) = N_Aggregate then
return Safe_Aggregate (Comp);
else
- return Check_Component (Comp);
+ return Check_Component (Comp, False);
end if;
end Safe_Component;
@@ -4286,33 +4405,38 @@ package body Exp_Aggr is
if Needs_Finalization (Etype (N)) then
return False;
+ end if;
- elsif Is_Array and then Present (Component_Associations (N)) then
+ Parent_Node := Parent (N);
+ Parent_Kind := Nkind (Parent_Node);
- -- On assignment, sliding can take place, so we cannot do the
- -- assignment in place unless the bounds of the aggregate are
- -- statically equal to those of the target.
+ if Parent_Kind = N_Qualified_Expression then
+ Parent_Node := Parent (Parent_Node);
+ Parent_Kind := Nkind (Parent_Node);
+ end if;
- -- If the aggregate is given by an others choice, the bounds are
- -- derived from the left-hand side, and the assignment is safe if
- -- the expression is.
+ -- On assignment, sliding can take place, so we cannot do the
+ -- assignment in place unless the bounds of the aggregate are
+ -- statically equal to those of the target.
- if Is_Others_Aggregate (N) then
- return
- Safe_Component
- (Expression (First (Component_Associations (N))));
- end if;
+ -- If the aggregate is given by an others choice, the bounds are
+ -- derived from the left-hand side, and the assignment is safe if
+ -- the expression is.
+ if Is_Array
+ and then Present (Component_Associations (N))
+ and then not Is_Others_Aggregate (N)
+ then
Aggr_In := First_Index (Etype (N));
- if Nkind (Parent (N)) = N_Assignment_Statement then
- Obj_In := First_Index (Etype (Name (Parent (N))));
+ if Parent_Kind = N_Assignment_Statement then
+ Obj_In := First_Index (Etype (Name (Parent_Node)));
else
-- Context is an allocator. Check bounds of aggregate against
-- given type in qualified expression.
- pragma Assert (Nkind (Parent (Parent (N))) = N_Allocator);
+ pragma Assert (Parent_Kind = N_Allocator);
Obj_In := First_Index (Etype (Entity (Subtype_Mark (Parent (N)))));
end if;
@@ -4320,9 +4444,12 @@ package body Exp_Aggr is
Get_Index_Bounds (Aggr_In, Aggr_Lo, Aggr_Hi);
Get_Index_Bounds (Obj_In, Obj_Lo, Obj_Hi);
- if not Compile_Time_Known_Value (Aggr_Lo)
- or else not Compile_Time_Known_Value (Obj_Lo)
+ -- We require static bounds for the target and a static matching
+ -- of low bound for the aggregate.
+
+ if not Compile_Time_Known_Value (Obj_Lo)
or else not Compile_Time_Known_Value (Obj_Hi)
+ or else not Compile_Time_Known_Value (Aggr_Lo)
or else Expr_Value (Aggr_Lo) /= Expr_Value (Obj_Lo)
then
return False;
@@ -4336,8 +4463,8 @@ package body Exp_Aggr is
-- diminishing returns) for safely building arrays in place
-- here.
- elsif Nkind (Parent (N)) = N_Assignment_Statement
- or else Is_Constrained (Etype (Parent (N)))
+ elsif Parent_Kind = N_Assignment_Statement
+ or else Is_Constrained (Etype (Parent_Node))
then
if not Compile_Time_Known_Value (Aggr_Hi)
or else Expr_Value (Aggr_Hi) /= Expr_Value (Obj_Hi)
@@ -4351,9 +4478,14 @@ package body Exp_Aggr is
end loop;
end if;
- -- Now check the component values themselves
+ -- Now check the component values themselves, except for an allocator
+ -- for which the target is newly allocated memory.
- return Safe_Aggregate (N);
+ if Parent_Kind = N_Allocator then
+ return True;
+ else
+ return Safe_Aggregate (N);
+ end if;
end In_Place_Assign_OK;
----------------------------
@@ -4468,14 +4600,13 @@ package body Exp_Aggr is
Build_Record_Aggr_Code (N, Typ, Target_Expr));
Rewrite (Parent_Node, Make_Null_Statement (Loc));
- -- Do not declare a temporary to initialize an aggregate assigned to an
- -- identifier when in-place assignment is possible, preserving the
+ -- Do not declare a temporary to initialize an aggregate assigned to
+ -- a target when in-place assignment is possible, i.e. preserving the
-- by-copy semantic of aggregates. This avoids large stack usage and
-- generates more efficient code.
elsif Parent_Kind = N_Assignment_Statement
- and then Nkind (Name (Parent_Node)) = N_Identifier
- and then In_Place_Assign_OK (N)
+ and then In_Place_Assign_OK (N, Get_Base_Object (Name (Parent_Node)))
then
declare
Lhs : constant Node_Id := Name (Parent_Node);
@@ -6284,14 +6415,15 @@ package body Exp_Aggr is
then
Maybe_In_Place_OK := False;
- else
+ elsif Parent_Kind = N_Assignment_Statement then
Maybe_In_Place_OK :=
- (Nkind (Parent (N)) = N_Assignment_Statement
- and then In_Place_Assign_OK (N))
+ In_Place_Assign_OK (N, Get_Base_Object (Name (Parent_Node)));
+
+ elsif Parent_Kind = N_Allocator then
+ Maybe_In_Place_OK := In_Place_Assign_OK (N);
- or else
- (Nkind (Parent (Parent (N))) = N_Allocator
- and then In_Place_Assign_OK (N));
+ else
+ Maybe_In_Place_OK := False;
end if;
-- If this is an array of tasks, it will be expanded into build-in-place
@@ -6345,10 +6477,7 @@ package body Exp_Aggr is
Set_Etype (Tmp, Typ);
end if;
- elsif Maybe_In_Place_OK
- and then Nkind (Parent (N)) = N_Qualified_Expression
- and then Nkind (Parent (Parent (N))) = N_Allocator
- then
+ elsif Maybe_In_Place_OK and then Parent_Kind = N_Allocator then
Set_Expansion_Delayed (N);
return;
@@ -6356,7 +6485,7 @@ package body Exp_Aggr is
-- enclosing construct is expanded.
elsif Maybe_In_Place_OK
- and then Nkind (Parent (N)) = N_Simple_Return_Statement
+ and then Parent_Kind = N_Simple_Return_Statement
then
Set_Expansion_Delayed (N);
return;
@@ -6364,9 +6493,9 @@ package body Exp_Aggr is
-- In the remaining cases the aggregate is the RHS of an assignment
elsif Maybe_In_Place_OK
- and then Safe_Left_Hand_Side (Name (Parent (N)))
+ and then Safe_Left_Hand_Side (Name (Parent_Node))
then
- Tmp := Name (Parent (N));
+ Tmp := Name (Parent_Node);
if Etype (Tmp) /= Etype (N) then
Apply_Length_Check (N, Etype (Tmp));
@@ -6384,10 +6513,10 @@ package body Exp_Aggr is
-- by converting it into a loop over the discrete range of the slice.
elsif Maybe_In_Place_OK
- and then Nkind (Name (Parent (N))) = N_Slice
+ and then Nkind (Name (Parent_Node)) = N_Slice
and then Is_Others_Aggregate (N)
then
- Tmp := Name (Parent (N));
+ Tmp := Name (Parent_Node);
-- Set type of aggregate to be type of lhs in assignment, in order
-- to suppress redundant length checks.
@@ -6415,7 +6544,7 @@ package body Exp_Aggr is
-- around the aggregate for this purpose.
if Ekind (Current_Scope) = E_Loop
- and then Nkind (Parent (Parent (N))) = N_Allocator
+ and then Parent_Kind = N_Allocator
then
Establish_Transient_Scope (N, Manage_Sec_Stack => False);
end if;
@@ -6525,13 +6654,13 @@ package body Exp_Aggr is
-- If the aggregate has been assigned in place, remove the original
-- assignment.
- if Nkind (Parent (N)) = N_Assignment_Statement
- and then Maybe_In_Place_OK
- then
- Rewrite (Parent (N), Make_Null_Statement (Loc));
+ if Parent_Kind = N_Assignment_Statement and then Maybe_In_Place_OK then
+ Rewrite (Parent_Node, Make_Null_Statement (Loc));
+
+ -- Or else, if a temporary was created, replace the aggregate with it
- elsif Nkind (Parent (N)) /= N_Object_Declaration
- or else Tmp /= Defining_Identifier (Parent (N))
+ elsif Parent_Kind /= N_Object_Declaration
+ or else Tmp /= Defining_Identifier (Parent_Node)
then
Rewrite (N, New_Occurrence_Of (Tmp, Loc));
Analyze_And_Resolve (N, Typ);
@@ -7611,6 +7740,28 @@ package body Exp_Aggr is
end if;
end Expand_Record_Aggregate;
+ ---------------------
+ -- Get_Base_Object --
+ ---------------------
+
+ function Get_Base_Object (N : Node_Id) return Entity_Id is
+ R : Node_Id;
+
+ begin
+ R := Get_Referenced_Object (N);
+
+ while Nkind_In (R, N_Indexed_Component, N_Selected_Component, N_Slice)
+ loop
+ R := Get_Referenced_Object (Prefix (R));
+ end loop;
+
+ if Is_Entity_Name (R) and then Is_Object (Entity (R)) then
+ return Entity (R);
+ else
+ return Empty;
+ end if;
+ end Get_Base_Object;
+
----------------------------
-- Has_Default_Init_Comps --
----------------------------