exp_aggr.adb (Build_Record_Aggr_Code): For extension aggregates...
2006-10-31 Bob Duff <duff@adacore.com> Ed Schonberg <schonberg@adacore.com> * exp_aggr.adb (Build_Record_Aggr_Code): For extension aggregates, if the parent part is a build-in-place function call, generate assignments. (Expand_Record_Aggregate): Call Convert_To_Assignments if any components are build-in-place function calls. (Replace_Self_Reference): New subsidiary of Make_OK_Assignment_Statement, to replace an access attribute that is a self-reference into an access to the appropriate component of the target object. Generalizes previous mechanism to handle self-references nested at any level. (Is_Self_Referential_Init): Remove, not needed. (Is_Self_Referential_Init): New predicate to simplify handling of self referential components in record aggregates. (Has_Default_Init_Comps, Make_OK_Assignment_Statement): Add guard to check for presence of entity before checking for self-reference. (Has_Default_Init_Comps): Return True if a component association is a self-reference to the enclosing type, which can only come from a default initialization. (Make_OK_Assignment_Statement): If the expression is of the form Typ'Acc, where Acc is an access attribute, the expression comes from a default initialized self-referential component. (Build_Record_Aggr_Code): If the type of the aggregate is a tagged type that has been derived from several abstract interfaces we must also initialize the tags of the secondary dispatch tables. From-SVN: r118253
This commit is contained in:
parent
e84a19613d
commit
c5ee5ad288
|
@ -41,6 +41,7 @@ with Itypes; use Itypes;
|
|||
with Lib; use Lib;
|
||||
with Nmake; use Nmake;
|
||||
with Nlists; use Nlists;
|
||||
with Opt; use Opt;
|
||||
with Restrict; use Restrict;
|
||||
with Rident; use Rident;
|
||||
with Rtsfind; use Rtsfind;
|
||||
|
@ -113,7 +114,7 @@ package body Exp_Aggr is
|
|||
-- aggregate
|
||||
|
||||
procedure Convert_To_Assignments (N : Node_Id; Typ : Entity_Id);
|
||||
-- N is an N_Aggregate of a N_Extension_Aggregate. Typ is the type of
|
||||
-- N is an N_Aggregate or an N_Extension_Aggregate. Typ is the type of
|
||||
-- the aggregate. Transform the given aggregate into a sequence of
|
||||
-- assignments component per component.
|
||||
|
||||
|
@ -124,7 +125,7 @@ package body Exp_Aggr is
|
|||
Flist : Node_Id := Empty;
|
||||
Obj : Entity_Id := Empty;
|
||||
Is_Limited_Ancestor_Expansion : Boolean := False) return List_Id;
|
||||
-- N is an N_Aggregate or a 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
|
||||
-- component by component assignments will take place. Returns the list of
|
||||
-- assignments plus all other adjustments needed for tagged and controlled
|
||||
|
@ -256,11 +257,17 @@ package body Exp_Aggr is
|
|||
function Make_OK_Assignment_Statement
|
||||
(Sloc : Source_Ptr;
|
||||
Name : Node_Id;
|
||||
Expression : Node_Id) return Node_Id;
|
||||
Expression : Node_Id;
|
||||
Self_Ref : Boolean := False) return Node_Id;
|
||||
-- This is like Make_Assignment_Statement, except that Assignment_OK
|
||||
-- is set in the left operand. All assignments built by this unit
|
||||
-- use this routine. This is needed to deal with assignments to
|
||||
-- initialized constants that are done in place.
|
||||
-- If Self_Ref is true, the aggregate contains an access reference to the
|
||||
-- enclosing type, obtained from a default initialization. The reference
|
||||
-- as to be expanded into a reference to the enclosing object, which is
|
||||
-- obtained from the Name in the assignment. The value of Self_Ref is
|
||||
-- inherited from the aggregate itself.
|
||||
|
||||
function Packed_Array_Aggregate_Handled (N : Node_Id) return Boolean;
|
||||
-- Given an array aggregate, this function handles the case of a packed
|
||||
|
@ -2239,16 +2246,21 @@ package body Exp_Aggr is
|
|||
Check_Ancestor_Discriminants (Entity (A));
|
||||
end if;
|
||||
|
||||
-- Ada 2005 (AI-287): If the ancestor part is a limited type,
|
||||
-- a recursive call expands the ancestor.
|
||||
-- Ada 2005 (AI-287): If the ancestor part is an aggregate of
|
||||
-- limited type, a recursive call expands the ancestor. Note that
|
||||
-- in the limited case, the ancestor part must be either a
|
||||
-- function call (possibly qualified) or aggregate (definitely
|
||||
-- qualified).
|
||||
|
||||
elsif Is_Limited_Type (Etype (A)) then
|
||||
elsif Is_Limited_Type (Etype (A))
|
||||
and then Nkind (Unqualify (A)) /= N_Function_Call -- aggregate?
|
||||
then
|
||||
Ancestor_Is_Expression := True;
|
||||
|
||||
Append_List_To (L,
|
||||
Build_Record_Aggr_Code (
|
||||
N => Expression (A),
|
||||
Typ => Etype (Expression (A)),
|
||||
N => Unqualify (A),
|
||||
Typ => Etype (Unqualify (A)),
|
||||
Target => Target,
|
||||
Flist => Flist,
|
||||
Obj => Obj,
|
||||
|
@ -2256,6 +2268,10 @@ package body Exp_Aggr is
|
|||
|
||||
-- If the ancestor part is an expression "E", we generate
|
||||
-- T(tmp) := E;
|
||||
-- In Ada 2005, this includes the case of a (possibly qualified)
|
||||
-- limited function call. The assignment will turn into a
|
||||
-- build-in-place function call (see
|
||||
-- Make_Build_In_Place_Call_In_Assignment).
|
||||
|
||||
else
|
||||
Ancestor_Is_Expression := True;
|
||||
|
@ -2264,10 +2280,8 @@ package body Exp_Aggr is
|
|||
-- If the ancestor part is an aggregate, force its full
|
||||
-- expansion, which was delayed.
|
||||
|
||||
if Nkind (A) = N_Qualified_Expression
|
||||
and then (Nkind (Expression (A)) = N_Aggregate
|
||||
or else
|
||||
Nkind (Expression (A)) = N_Extension_Aggregate)
|
||||
if Nkind (Unqualify (A)) = N_Aggregate
|
||||
or else Nkind (Unqualify (A)) = N_Extension_Aggregate
|
||||
then
|
||||
Set_Analyzed (A, False);
|
||||
Set_Analyzed (Expression (A), False);
|
||||
|
@ -2283,7 +2297,8 @@ package body Exp_Aggr is
|
|||
Assign := New_List (
|
||||
Make_OK_Assignment_Statement (Loc,
|
||||
Name => Ref,
|
||||
Expression => A));
|
||||
Expression => A,
|
||||
Self_Ref => Has_Self_Reference (N)));
|
||||
Set_No_Ctrl_Actions (First (Assign));
|
||||
|
||||
-- Assign the tag now to make sure that the dispatching call in
|
||||
|
@ -2657,7 +2672,8 @@ package body Exp_Aggr is
|
|||
Instr :=
|
||||
Make_OK_Assignment_Statement (Loc,
|
||||
Name => Comp_Expr,
|
||||
Expression => Expression (Comp));
|
||||
Expression => Expression (Comp),
|
||||
Self_Ref => Has_Self_Reference (N));
|
||||
|
||||
Set_No_Ctrl_Actions (Instr);
|
||||
Append_To (L, Instr);
|
||||
|
@ -2769,6 +2785,20 @@ package body Exp_Aggr is
|
|||
Loc)));
|
||||
|
||||
Append_To (L, Instr);
|
||||
|
||||
-- Ada 2005 (AI-251): If the tagged type has been derived from
|
||||
-- abstract interfaces we must also initialize the tags of the
|
||||
-- secondary dispatch tables.
|
||||
|
||||
if Present (Abstract_Interfaces (Base_Type (Typ)))
|
||||
and then not
|
||||
Is_Empty_Elmt_List (Abstract_Interfaces (Base_Type (Typ)))
|
||||
then
|
||||
Init_Secondary_Tags
|
||||
(Typ => Base_Type (Typ),
|
||||
Target => Target,
|
||||
Stmts_List => L);
|
||||
end if;
|
||||
end if;
|
||||
|
||||
-- If the controllers have not been initialized yet (by lack of non-
|
||||
|
@ -4765,10 +4795,19 @@ package body Exp_Aggr is
|
|||
return;
|
||||
end if;
|
||||
|
||||
-- Ada 2005 (AI-318-2): We need to convert to assignments if components
|
||||
-- are build-in-place function calls. This test could be more specific,
|
||||
-- but doing it for all inherently limited aggregates seems harmless.
|
||||
-- The assignments will turn into build-in-place function calls (see
|
||||
-- Make_Build_In_Place_Call_In_Assignment).
|
||||
|
||||
if Ada_Version >= Ada_05 and then Is_Inherently_Limited_Type (Typ) then
|
||||
Convert_To_Assignments (N, Typ);
|
||||
|
||||
-- Gigi doesn't handle properly temporaries of variable size
|
||||
-- so we generate it in the front-end
|
||||
|
||||
if not Size_Known_At_Compile_Time (Typ) then
|
||||
elsif not Size_Known_At_Compile_Time (Typ) then
|
||||
Convert_To_Assignments (N, Typ);
|
||||
|
||||
-- Temporaries for controlled aggregates need to be attached to a
|
||||
|
@ -5131,6 +5170,10 @@ package body Exp_Aggr is
|
|||
return False;
|
||||
end if;
|
||||
|
||||
if Has_Self_Reference (N) then
|
||||
return True;
|
||||
end if;
|
||||
|
||||
-- Check if any direct component has default initialized components
|
||||
|
||||
C := First (Comps);
|
||||
|
@ -5218,10 +5261,50 @@ package body Exp_Aggr is
|
|||
function Make_OK_Assignment_Statement
|
||||
(Sloc : Source_Ptr;
|
||||
Name : Node_Id;
|
||||
Expression : Node_Id) return Node_Id
|
||||
Expression : Node_Id;
|
||||
Self_Ref : Boolean := False) return Node_Id
|
||||
is
|
||||
function Replace_Type (Expr : Node_Id) return Traverse_Result;
|
||||
-- If the aggregate contains a self-reference, traverse each
|
||||
-- expression to replace a possible self-reference with a reference
|
||||
-- to the proper component of the target of the assignment.
|
||||
|
||||
------------------
|
||||
-- Replace_Type --
|
||||
------------------
|
||||
|
||||
function Replace_Type (Expr : Node_Id) return Traverse_Result is
|
||||
begin
|
||||
if Nkind (Expr) = N_Attribute_Reference
|
||||
and then Is_Entity_Name (Prefix (Expr))
|
||||
and then Is_Type (Entity (Prefix (Expr)))
|
||||
then
|
||||
if Is_Entity_Name (Prefix (Name)) then
|
||||
Rewrite (Prefix (Expr),
|
||||
New_Occurrence_Of (Entity (Prefix (Name)), Sloc));
|
||||
else
|
||||
Rewrite (Expr,
|
||||
Make_Attribute_Reference (Sloc,
|
||||
Attribute_Name => Name_Unrestricted_Access,
|
||||
Prefix => New_Copy_Tree (Prefix (Name))));
|
||||
Set_Analyzed (Parent (Expr), False);
|
||||
end if;
|
||||
end if;
|
||||
return OK;
|
||||
end Replace_Type;
|
||||
|
||||
procedure Replace_Self_Reference is
|
||||
new Traverse_Proc (Replace_Type);
|
||||
|
||||
-- Start of processing for Make_OK_Assignment_Statement
|
||||
|
||||
begin
|
||||
Set_Assignment_OK (Name);
|
||||
|
||||
if Self_Ref then
|
||||
Replace_Self_Reference (Expression);
|
||||
end if;
|
||||
|
||||
return Make_Assignment_Statement (Sloc, Name, Expression);
|
||||
end Make_OK_Assignment_Statement;
|
||||
|
||||
|
|
Loading…
Reference in New Issue