Commit 0f95b178 by Javier Miranda Committed by Arnaud Charlet

exp_aggr.ads, [...]:

2007-04-20  Javier Miranda  <miranda@adacore.com>
	    Ed Schonberg  <schonberg@adacore.com>
	    Bob Duff  <duff@adacore.com>
	    Hristian Kirtchev  <kirtchev@adacore.com>

	* exp_aggr.ads, exp_aggr.adb: 
	(Build_Record_Aggr_Code): Add missing initialization of secondary tags
	in extension aggregates.
	(Flatten): Other conditions being met, an aggregate is static if the
	low bound given by component associations is different from the low
	bound of the base index type.
	(Packed_Array_Aggregate_Handled): If the component type is itself a
	packed array or record, the front-end must expand into assignments.
	(Gen_Ctrl_Actions_For_Aggr): In call to Init_Controller, pass False to
	Init_Pr, instead of Ancestor_Is_Expression.
	(Gen_Ctrl_Actions_For_Aggr): When processing an aggregate of a
	coextension chain root, either generate a list controller or use the
	already existing one.
	(Static_Array_Aggregate): New procedure to construct a positional
	aggregate that can be handled by the backend, when all bounds and
	components are compile-time known constants.
	(Expand_Record_Aggregate): Force conversion of aggregates of tagged
	types covering interface types into assignments.
	(Replace_Type): move to Build_Record_Aggr_Code.
	(Expand_Record_Aggr_Code): if the target of the aggregate is an
	interface type, convert to the definite type of the aggregate itself,
	so that needed components are visible.
	(Convert_Aggr_In_Object_Decl): If the aggregate has controlled
	components and the context is an extended return statement do not
	create a transient block for it, to prevent premature finalization
	before the return is executed.
	(Gen_Assign): Do not generate a call to deep adjust routine if the
	component type is itself an array of controlled (sub)-components
	initialized with an inner aggregate.
	(Component_Check): New name for Static_Check. This name is now more
	appropriate, and documentation is added which was missing.
	(Component_Check): Add test for bit aligned component value
	(Component_Not_OK_For_Backend): Renames Has_Delayed_Nested_Aggregate_Or_
	Tagged_Comps, name is more appropriate given added function below.
	(Component_Not_OK_For_Backend): Check for bit aligned component ref.

From-SVN: r125392
parent 1c28fe3a
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- B o d y --
-- -- -- --
-- Copyright (C) 1992-2006, Free Software Foundation, Inc. -- -- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
-- -- -- --
-- GNAT is free software; you can redistribute it and/or modify it under -- -- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -36,9 +36,9 @@ with Exp_Ch7; use Exp_Ch7; ...@@ -36,9 +36,9 @@ with Exp_Ch7; use Exp_Ch7;
with Exp_Ch9; use Exp_Ch9; with Exp_Ch9; use Exp_Ch9;
with Exp_Tss; use Exp_Tss; with Exp_Tss; use Exp_Tss;
with Freeze; use Freeze; with Freeze; use Freeze;
with Hostparm; use Hostparm;
with Itypes; use Itypes; with Itypes; use Itypes;
with Lib; use Lib; with Lib; use Lib;
with Namet; use Namet;
with Nmake; use Nmake; with Nmake; use Nmake;
with Nlists; use Nlists; with Nlists; use Nlists;
with Opt; use Opt; with Opt; use Opt;
...@@ -54,6 +54,7 @@ with Sem_Util; use Sem_Util; ...@@ -54,6 +54,7 @@ with Sem_Util; use Sem_Util;
with Sinfo; use Sinfo; with Sinfo; use Sinfo;
with Snames; use Snames; with Snames; use Snames;
with Stand; use Stand; with Stand; use Stand;
with Targparm; use Targparm;
with Tbuild; use Tbuild; with Tbuild; use Tbuild;
with Uintp; use Uintp; with Uintp; use Uintp;
...@@ -121,7 +122,7 @@ package body Exp_Aggr is ...@@ -121,7 +122,7 @@ package body Exp_Aggr is
function Build_Record_Aggr_Code function Build_Record_Aggr_Code
(N : Node_Id; (N : Node_Id;
Typ : Entity_Id; Typ : Entity_Id;
Target : Node_Id; Lhs : Node_Id;
Flist : Node_Id := Empty; Flist : Node_Id := Empty;
Obj : Entity_Id := Empty; Obj : Entity_Id := Empty;
Is_Limited_Ancestor_Expansion : Boolean := False) return List_Id; Is_Limited_Ancestor_Expansion : Boolean := False) return List_Id;
...@@ -262,17 +263,11 @@ package body Exp_Aggr is ...@@ -262,17 +263,11 @@ package body Exp_Aggr is
function Make_OK_Assignment_Statement function Make_OK_Assignment_Statement
(Sloc : Source_Ptr; (Sloc : Source_Ptr;
Name : Node_Id; Name : Node_Id;
Expression : Node_Id; Expression : Node_Id) return Node_Id;
Self_Ref : Boolean := False) return Node_Id;
-- This is like Make_Assignment_Statement, except that Assignment_OK -- This is like Make_Assignment_Statement, except that Assignment_OK
-- is set in the left operand. All assignments built by this unit -- is set in the left operand. All assignments built by this unit
-- use this routine. This is needed to deal with assignments to -- use this routine. This is needed to deal with assignments to
-- initialized constants that are done in place. -- 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; function Packed_Array_Aggregate_Handled (N : Node_Id) return Boolean;
-- Given an array aggregate, this function handles the case of a packed -- Given an array aggregate, this function handles the case of a packed
...@@ -451,32 +446,46 @@ package body Exp_Aggr is ...@@ -451,32 +446,46 @@ package body Exp_Aggr is
-- 4. The array type of N does not follow the Fortran layout convention -- 4. The array type of N does not follow the Fortran layout convention
-- or if it does it must be 1 dimensional. -- or if it does it must be 1 dimensional.
-- 5. The array component type is tagged, which may necessitate -- 5. The array component type may not be tagged (which could necessitate
-- reassignment of proper tags. -- reassignment of proper tags).
-- 6. The array component type must not have unaligned bit components
-- 7. None of the components of the aggregate may be bit unaligned
-- components.
-- 6. The array component type might have unaligned bit components -- 8. There cannot be delayed components, since we do not know enough
-- at this stage to know if back end processing is possible.
-- 9. There cannot be any discriminated record components, since the
-- back end cannot handle this complex case.
function Backend_Processing_Possible (N : Node_Id) return Boolean is function Backend_Processing_Possible (N : Node_Id) return Boolean is
Typ : constant Entity_Id := Etype (N); Typ : constant Entity_Id := Etype (N);
-- Typ is the correct constrained array subtype of the aggregate -- Typ is the correct constrained array subtype of the aggregate
function Static_Check (N : Node_Id; Index : Node_Id) return Boolean; function Component_Check (N : Node_Id; Index : Node_Id) return Boolean;
-- Recursively checks that N is fully positional, returns true if so -- This routine checks components of aggregate N, enforcing checks
-- 1, 7, 8, and 9. In the multi-dimensional case, these checks are
-- performed on subaggregates. The Index value is the current index
-- being checked in the multi-dimensional case.
------------------ ---------------------
-- Static_Check -- -- Component_Check --
------------------ ---------------------
function Static_Check (N : Node_Id; Index : Node_Id) return Boolean is function Component_Check (N : Node_Id; Index : Node_Id) return Boolean is
Expr : Node_Id; Expr : Node_Id;
begin begin
-- Check for component associations -- Checks 1: (no component associations)
if Present (Component_Associations (N)) then if Present (Component_Associations (N)) then
return False; return False;
end if; end if;
-- Checks on components
-- Recurse to check subaggregates, which may appear in qualified -- Recurse to check subaggregates, which may appear in qualified
-- expressions. If delayed, the front-end will have to expand. -- expressions. If delayed, the front-end will have to expand.
-- If the component is a discriminated record, treat as non-static, -- If the component is a discriminated record, treat as non-static,
...@@ -484,10 +493,15 @@ package body Exp_Aggr is ...@@ -484,10 +493,15 @@ package body Exp_Aggr is
Expr := First (Expressions (N)); Expr := First (Expressions (N));
while Present (Expr) loop while Present (Expr) loop
-- Checks 8: (no delayed components)
if Is_Delayed_Aggregate (Expr) then if Is_Delayed_Aggregate (Expr) then
return False; return False;
end if; end if;
-- Checks 9: (no discriminated records)
if Present (Etype (Expr)) if Present (Etype (Expr))
and then Is_Record_Type (Etype (Expr)) and then Is_Record_Type (Etype (Expr))
and then Has_Discriminants (Etype (Expr)) and then Has_Discriminants (Etype (Expr))
...@@ -495,17 +509,27 @@ package body Exp_Aggr is ...@@ -495,17 +509,27 @@ package body Exp_Aggr is
return False; return False;
end if; end if;
-- Checks 7. Component must not be bit aligned component
if Possible_Bit_Aligned_Component (Expr) then
return False;
end if;
-- Recursion to following indexes for multiple dimension case
if Present (Next_Index (Index)) if Present (Next_Index (Index))
and then not Static_Check (Expr, Next_Index (Index)) and then not Component_Check (Expr, Next_Index (Index))
then then
return False; return False;
end if; end if;
-- All checks for that component finished, on to next
Next (Expr); Next (Expr);
end loop; end loop;
return True; return True;
end Static_Check; end Component_Check;
-- Start of processing for Backend_Processing_Possible -- Start of processing for Backend_Processing_Possible
...@@ -530,21 +554,20 @@ package body Exp_Aggr is ...@@ -530,21 +554,20 @@ package body Exp_Aggr is
return False; return False;
end if; end if;
-- Checks 1 (aggregate must be fully positional) -- Checks on components
if not Static_Check (N, First_Index (Typ)) then if not Component_Check (N, First_Index (Typ)) then
return False; return False;
end if; end if;
-- Checks 5 (if the component type is tagged, then we may need -- Checks 5 (if the component type is tagged, then we may need to do
-- to do tag adjustments; perhaps this should be refined to check for -- tag adjustments. Perhaps this should be refined to check for any
-- any component associations that actually need tag adjustment, -- component associations that actually need tag adjustment, similar
-- along the lines of the test that is carried out in -- to the test in Component_Not_OK_For_Backend for record aggregates
-- Has_Delayed_Nested_Aggregate_Or_Tagged_Comps for record aggregates
-- with tagged components, but not clear whether it's worthwhile ???; -- with tagged components, but not clear whether it's worthwhile ???;
-- in the case of the JVM, object tags are handled implicitly) -- in the case of the JVM, object tags are handled implicitly)
if Is_Tagged_Type (Component_Type (Typ)) and then not Java_VM then if Is_Tagged_Type (Component_Type (Typ)) and then VM_Target = No_VM then
return False; return False;
end if; end if;
...@@ -556,7 +579,6 @@ package body Exp_Aggr is ...@@ -556,7 +579,6 @@ package body Exp_Aggr is
-- Backend processing is possible -- Backend processing is possible
Set_Compile_Time_Known_Aggregate (N, True);
Set_Size_Known_At_Compile_Time (Etype (N), True); Set_Size_Known_At_Compile_Time (Etype (N), True);
return True; return True;
end Backend_Processing_Possible; end Backend_Processing_Possible;
...@@ -1094,7 +1116,7 @@ package body Exp_Aggr is ...@@ -1094,7 +1116,7 @@ package body Exp_Aggr is
if Present (Comp_Type) if Present (Comp_Type)
and then Is_Tagged_Type (Comp_Type) and then Is_Tagged_Type (Comp_Type)
and then not Java_VM and then VM_Target = No_VM
then then
A := A :=
Make_OK_Assignment_Statement (Loc, Make_OK_Assignment_Statement (Loc,
...@@ -1114,11 +1136,24 @@ package body Exp_Aggr is ...@@ -1114,11 +1136,24 @@ package body Exp_Aggr is
Append_To (L, A); Append_To (L, A);
end if; end if;
-- Adjust and Attach the component to the proper final list -- Adjust and attach the component to the proper final list, which
-- which can be the controller of the outer record object or -- can be the controller of the outer record object or the final
-- the final list associated with the scope -- list associated with the scope.
if Present (Comp_Type) and then Controlled_Type (Comp_Type) then -- If the component is itself an array of controlled types, whose
-- value is given by a sub-aggregate, then the attach calls have
-- been generated when individual subcomponent are assigned, and
-- and must not be done again to prevent malformed finalization
-- chains (see comments above, concerning the creation of a block
-- to hold inner finalization actions).
if Present (Comp_Type)
and then Controlled_Type (Comp_Type)
and then
(not Is_Array_Type (Comp_Type)
or else not Is_Controlled (Component_Type (Comp_Type))
or else Nkind (Expr) /= N_Aggregate)
then
Append_List_To (L, Append_List_To (L,
Make_Adjust_Call ( Make_Adjust_Call (
Ref => New_Copy_Tree (Indexed_Comp), Ref => New_Copy_Tree (Indexed_Comp),
...@@ -1253,7 +1288,17 @@ package body Exp_Aggr is ...@@ -1253,7 +1288,17 @@ package body Exp_Aggr is
Iteration_Scheme => L_Iteration_Scheme, Iteration_Scheme => L_Iteration_Scheme,
Statements => L_Body)); Statements => L_Body));
-- A small optimization: if the aggregate is initialized with a
-- box and the component type has no initialization procedure,
-- remove the useless empty loop.
if Nkind (First (S)) = N_Loop_Statement
and then Is_Empty_List (Statements (First (S)))
then
return New_List (Make_Null_Statement (Loc));
else
return S; return S;
end if;
end Gen_Loop; end Gen_Loop;
--------------- ---------------
...@@ -1605,7 +1650,7 @@ package body Exp_Aggr is ...@@ -1605,7 +1650,7 @@ package body Exp_Aggr is
function Build_Record_Aggr_Code function Build_Record_Aggr_Code
(N : Node_Id; (N : Node_Id;
Typ : Entity_Id; Typ : Entity_Id;
Target : Node_Id; Lhs : Node_Id;
Flist : Node_Id := Empty; Flist : Node_Id := Empty;
Obj : Entity_Id := Empty; Obj : Entity_Id := Empty;
Is_Limited_Ancestor_Expansion : Boolean := False) return List_Id Is_Limited_Ancestor_Expansion : Boolean := False) return List_Id
...@@ -1617,6 +1662,7 @@ package body Exp_Aggr is ...@@ -1617,6 +1662,7 @@ package body Exp_Aggr is
Comp : Node_Id; Comp : Node_Id;
Instr : Node_Id; Instr : Node_Id;
Ref : Node_Id; Ref : Node_Id;
Target : Entity_Id;
F : Node_Id; F : Node_Id;
Comp_Type : Entity_Id; Comp_Type : Entity_Id;
Selector : Entity_Id; Selector : Entity_Id;
...@@ -1639,7 +1685,8 @@ package body Exp_Aggr is ...@@ -1639,7 +1685,8 @@ package body Exp_Aggr is
Attach : Node_Id; Attach : Node_Id;
Ctrl_Stuff_Done : Boolean := False; Ctrl_Stuff_Done : Boolean := False;
-- Could use comments here ??? -- True if Gen_Ctrl_Actions_For_Aggr has already been called; calls
-- after the first do nothing.
function Ancestor_Discriminant_Value (Disc : Entity_Id) return Node_Id; function Ancestor_Discriminant_Value (Disc : Entity_Id) return Node_Id;
-- Returns the value that the given discriminant of an ancestor -- Returns the value that the given discriminant of an ancestor
...@@ -1659,8 +1706,8 @@ package body Exp_Aggr is ...@@ -1659,8 +1706,8 @@ package body Exp_Aggr is
-- assumed that both bounds are integer ranges. -- assumed that both bounds are integer ranges.
procedure Gen_Ctrl_Actions_For_Aggr; procedure Gen_Ctrl_Actions_For_Aggr;
-- Deal with the various controlled type data structure -- Deal with the various controlled type data structure initializations
-- initializations. -- (but only if it hasn't been done already).
function Get_Constraint_Association (T : Entity_Id) return Node_Id; function Get_Constraint_Association (T : Entity_Id) return Node_Id;
-- Returns the first discriminant association in the constraint -- Returns the first discriminant association in the constraint
...@@ -1672,10 +1719,10 @@ package body Exp_Aggr is ...@@ -1672,10 +1719,10 @@ package body Exp_Aggr is
F : Node_Id; F : Node_Id;
Attach : Node_Id; Attach : Node_Id;
Init_Pr : Boolean) return List_Id; Init_Pr : Boolean) return List_Id;
-- returns the list of statements necessary to initialize the internal -- Returns the list of statements necessary to initialize the internal
-- controller of the (possible) ancestor typ into target and attach -- controller of the (possible) ancestor typ into target and attach it
-- it to finalization list F. Init_Pr conditions the call to the -- to finalization list F. Init_Pr conditions the call to the init proc
-- init proc since it may already be done due to ancestor initialization -- since it may already be done due to ancestor initialization.
function Is_Int_Range_Bounds (Bounds : Node_Id) return Boolean; function Is_Int_Range_Bounds (Bounds : Node_Id) return Boolean;
-- Check whether Bounds is a range node and its lower and higher bounds -- Check whether Bounds is a range node and its lower and higher bounds
...@@ -1880,7 +1927,7 @@ package body Exp_Aggr is ...@@ -1880,7 +1927,7 @@ package body Exp_Aggr is
end Get_Constraint_Association; end Get_Constraint_Association;
--------------------- ---------------------
-- Init_controller -- -- Init_Controller --
--------------------- ---------------------
function Init_Controller function Init_Controller
...@@ -1972,24 +2019,32 @@ package body Exp_Aggr is ...@@ -1972,24 +2019,32 @@ package body Exp_Aggr is
------------------------------- -------------------------------
procedure Gen_Ctrl_Actions_For_Aggr is procedure Gen_Ctrl_Actions_For_Aggr is
Alloc : Node_Id := Empty;
begin begin
if not Ctrl_Stuff_Done then -- Do the work only the first time this is called
Ctrl_Stuff_Done := True;
else if Ctrl_Stuff_Done then
return; return;
end if; end if;
Ctrl_Stuff_Done := True;
if Present (Obj) if Present (Obj)
and then Finalize_Storage_Only (Typ) and then Finalize_Storage_Only (Typ)
and then (Is_Library_Level_Entity (Obj) and then
(Is_Library_Level_Entity (Obj)
or else Entity (Constant_Value (RTE (RE_Garbage_Collected))) = or else Entity (Constant_Value (RTE (RE_Garbage_Collected))) =
Standard_True) Standard_True)
-- why not Is_True (Expr_Value (RTE (RE_Garbaage_Collected) ???
then then
Attach := Make_Integer_Literal (Loc, 0); Attach := Make_Integer_Literal (Loc, 0);
elsif Nkind (Parent (N)) = N_Qualified_Expression elsif Nkind (Parent (N)) = N_Qualified_Expression
and then Nkind (Parent (Parent (N))) = N_Allocator and then Nkind (Parent (Parent (N))) = N_Allocator
then then
Alloc := Parent (Parent (N));
Attach := Make_Integer_Literal (Loc, 2); Attach := Make_Integer_Literal (Loc, 2);
else else
...@@ -2003,19 +2058,37 @@ package body Exp_Aggr is ...@@ -2003,19 +2058,37 @@ package body Exp_Aggr is
-- potentially transient current scope. -- potentially transient current scope.
if Controlled_Type (Typ) then if Controlled_Type (Typ) then
if Present (Flist) then
-- The current aggregate belongs to an allocator which acts as
-- the root of a coextension chain.
if Present (Alloc)
and then Is_Coextension_Root (Alloc)
then
if No (Associated_Final_Chain (Etype (Alloc))) then
Build_Final_List (Alloc, Etype (Alloc));
end if;
External_Final_List :=
Make_Selected_Component (Loc,
Prefix =>
New_Reference_To (
Associated_Final_Chain (Etype (Alloc)), Loc),
Selector_Name =>
Make_Identifier (Loc, Name_F));
elsif Present (Flist) then
External_Final_List := New_Copy_Tree (Flist); External_Final_List := New_Copy_Tree (Flist);
elsif Is_Entity_Name (Target) elsif Is_Entity_Name (Target)
and then Present (Scope (Entity (Target))) and then Present (Scope (Entity (Target)))
then then
External_Final_List External_Final_List :=
:= Find_Final_List (Scope (Entity (Target))); Find_Final_List (Scope (Entity (Target)));
else else
External_Final_List := Find_Final_List (Current_Scope); External_Final_List := Find_Final_List (Current_Scope);
end if; end if;
else else
External_Final_List := Empty; External_Final_List := Empty;
end if; end if;
...@@ -2037,6 +2110,20 @@ package body Exp_Aggr is ...@@ -2037,6 +2110,20 @@ package body Exp_Aggr is
if not Has_Controlled_Component (Typ) then if not Has_Controlled_Component (Typ) then
Ref := New_Copy_Tree (Target); Ref := New_Copy_Tree (Target);
Set_Assignment_OK (Ref); Set_Assignment_OK (Ref);
-- This is an aggregate of a coextension. Do not produce a
-- finalization call, but rather attach the reference of the
-- aggregate to its coextension chain.
if Present (Alloc)
and then Is_Coextension (Alloc)
then
if No (Coextensions (Alloc)) then
Set_Coextensions (Alloc, New_Elmt_List);
end if;
Append_Elmt (Ref, Coextensions (Alloc));
else
Append_To (L, Append_To (L,
Make_Attach_Call ( Make_Attach_Call (
Obj_Ref => Ref, Obj_Ref => Ref,
...@@ -2044,6 +2131,7 @@ package body Exp_Aggr is ...@@ -2044,6 +2131,7 @@ package body Exp_Aggr is
With_Attach => Attach)); With_Attach => Attach));
end if; end if;
end if; end if;
end if;
-- In the Has_Controlled component case, all the intermediate -- In the Has_Controlled component case, all the intermediate
-- controllers must be initialized -- controllers must be initialized
...@@ -2162,15 +2250,77 @@ package body Exp_Aggr is ...@@ -2162,15 +2250,77 @@ package body Exp_Aggr is
Typ => Init_Typ, Typ => Init_Typ,
F => F, F => F,
Attach => Attach, Attach => Attach,
Init_Pr => Ancestor_Is_Expression)); Init_Pr => False));
-- Note: Init_Pr is False because the ancestor part has
-- already been initialized either way (by default, if
-- given by a type name, otherwise from the expression).
end if; end if;
end; end;
end if; end if;
end Gen_Ctrl_Actions_For_Aggr; end Gen_Ctrl_Actions_For_Aggr;
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 (Lhs) then
Rewrite (Prefix (Expr),
New_Occurrence_Of (Entity (Lhs), Loc));
elsif Nkind (Lhs) = N_Selected_Component then
Rewrite (Expr,
Make_Attribute_Reference (Loc,
Attribute_Name => Name_Unrestricted_Access,
Prefix => New_Copy_Tree (Prefix (Lhs))));
Set_Analyzed (Parent (Expr), False);
else
Rewrite (Expr,
Make_Attribute_Reference (Loc,
Attribute_Name => Name_Unrestricted_Access,
Prefix => New_Copy_Tree (Lhs)));
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 Build_Record_Aggr_Code -- Start of processing for Build_Record_Aggr_Code
begin begin
if Has_Self_Reference (N) then
Replace_Self_Reference (N);
end if;
-- If the target of the aggregate is class-wide, we must convert it
-- to the actual type of the aggregate, so that the proper components
-- are visible. We know already that the types are compatible.
if Present (Etype (Lhs))
and then Is_Interface (Etype (Lhs))
then
Target := Unchecked_Convert_To (Typ, Lhs);
else
Target := Lhs;
end if;
-- Deal with the ancestor part of extension aggregates -- Deal with the ancestor part of extension aggregates
-- or with the discriminants of the root type -- or with the discriminants of the root type
...@@ -2280,7 +2430,7 @@ package body Exp_Aggr is ...@@ -2280,7 +2430,7 @@ package body Exp_Aggr is
Build_Record_Aggr_Code ( Build_Record_Aggr_Code (
N => Unqualify (A), N => Unqualify (A),
Typ => Etype (Unqualify (A)), Typ => Etype (Unqualify (A)),
Target => Target, Lhs => Target,
Flist => Flist, Flist => Flist,
Obj => Obj, Obj => Obj,
Is_Limited_Ancestor_Expansion => True)); Is_Limited_Ancestor_Expansion => True));
...@@ -2316,15 +2466,14 @@ package body Exp_Aggr is ...@@ -2316,15 +2466,14 @@ package body Exp_Aggr is
Assign := New_List ( Assign := New_List (
Make_OK_Assignment_Statement (Loc, Make_OK_Assignment_Statement (Loc,
Name => Ref, Name => Ref,
Expression => A, Expression => A));
Self_Ref => Has_Self_Reference (N)));
Set_No_Ctrl_Actions (First (Assign)); Set_No_Ctrl_Actions (First (Assign));
-- Assign the tag now to make sure that the dispatching call in -- Assign the tag now to make sure that the dispatching call in
-- the subsequent deep_adjust works properly (unless Java_VM, -- the subsequent deep_adjust works properly (unless VM_Target,
-- where tags are implicit). -- where tags are implicit).
if not Java_VM then if VM_Target = No_VM then
Instr := Instr :=
Make_OK_Assignment_Statement (Loc, Make_OK_Assignment_Statement (Loc,
Name => Name =>
...@@ -2343,6 +2492,20 @@ package body Exp_Aggr is ...@@ -2343,6 +2492,20 @@ package body Exp_Aggr is
Set_Assignment_OK (Name (Instr)); Set_Assignment_OK (Name (Instr));
Append_To (Assign, Instr); Append_To (Assign, Instr);
-- Ada 2005 (AI-251): If tagged type has progenitors we must
-- also initialize 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 => Assign);
end if;
end if; end if;
-- Call Adjust manually -- Call Adjust manually
...@@ -2690,19 +2853,18 @@ package body Exp_Aggr is ...@@ -2690,19 +2853,18 @@ package body Exp_Aggr is
Instr := Instr :=
Make_OK_Assignment_Statement (Loc, Make_OK_Assignment_Statement (Loc,
Name => Comp_Expr, Name => Comp_Expr,
Expression => Expression (Comp), Expression => Expression (Comp));
Self_Ref => Has_Self_Reference (N));
Set_No_Ctrl_Actions (Instr); Set_No_Ctrl_Actions (Instr);
Append_To (L, Instr); Append_To (L, Instr);
-- Adjust the tag if tagged (because of possible view -- Adjust the tag if tagged (because of possible view
-- conversions), unless compiling for the Java VM -- conversions), unless compiling for a VM where tags are
-- where tags are implicit. -- implicit.
-- tmp.comp._tag := comp_typ'tag; -- tmp.comp._tag := comp_typ'tag;
if Is_Tagged_Type (Comp_Type) and then not Java_VM then if Is_Tagged_Type (Comp_Type) and then VM_Target = No_VM then
Instr := Instr :=
Make_OK_Assignment_Statement (Loc, Make_OK_Assignment_Statement (Loc,
Name => Name =>
...@@ -2762,6 +2924,14 @@ package body Exp_Aggr is ...@@ -2762,6 +2924,14 @@ package body Exp_Aggr is
pragma Assert (Present (D_Val)); pragma Assert (Present (D_Val));
-- This check cannot performed for components that are
-- constrained by a current instance, because this is not a
-- value that can be compared with the actual constraint.
if Nkind (Node (D_Val)) /= N_Attribute_Reference
or else not Is_Entity_Name (Prefix (Node (D_Val)))
or else not Is_Type (Entity (Prefix (Node (D_Val))))
then
Append_To (L, Append_To (L,
Make_Raise_Constraint_Error (Loc, Make_Raise_Constraint_Error (Loc,
Condition => Condition =>
...@@ -2769,6 +2939,30 @@ package body Exp_Aggr is ...@@ -2769,6 +2939,30 @@ package body Exp_Aggr is
Left_Opnd => New_Copy_Tree (Node (D_Val)), Left_Opnd => New_Copy_Tree (Node (D_Val)),
Right_Opnd => Expression (Comp)), Right_Opnd => Expression (Comp)),
Reason => CE_Discriminant_Check_Failed)); Reason => CE_Discriminant_Check_Failed));
else
-- Find self-reference in previous discriminant
-- assignment, and replace with proper expression.
declare
Ass : Node_Id;
begin
Ass := First (L);
while Present (Ass) loop
if Nkind (Ass) = N_Assignment_Statement
and then Nkind (Name (Ass)) = N_Selected_Component
and then Chars (Selector_Name (Name (Ass))) =
Chars (Disc)
then
Set_Expression
(Ass, New_Copy_Tree (Expression (Comp)));
exit;
end if;
Next (Ass);
end loop;
end;
end if;
end; end;
end if; end if;
...@@ -2785,7 +2979,7 @@ package body Exp_Aggr is ...@@ -2785,7 +2979,7 @@ package body Exp_Aggr is
if Ancestor_Is_Expression then if Ancestor_Is_Expression then
null; null;
elsif Is_Tagged_Type (Typ) and then not Java_VM then elsif Is_Tagged_Type (Typ) and then VM_Target = No_VM then
Instr := Instr :=
Make_OK_Assignment_Statement (Loc, Make_OK_Assignment_Statement (Loc,
Name => Name =>
...@@ -2878,8 +3072,12 @@ package body Exp_Aggr is ...@@ -2878,8 +3072,12 @@ package body Exp_Aggr is
-- ??? Dubious actual for Obj: expect 'the original object -- ??? Dubious actual for Obj: expect 'the original object
-- being initialized' -- being initialized'
if Has_Task (Typ) then
Build_Task_Allocate_Block_With_Init_Stmts (L, Aggr, Init_Stmts); Build_Task_Allocate_Block_With_Init_Stmts (L, Aggr, Init_Stmts);
Insert_Actions_After (Decl, L); Insert_Actions_After (Decl, L);
else
Insert_Actions_After (Decl, Init_Stmts);
end if;
end; end;
else else
...@@ -3010,7 +3208,15 @@ package body Exp_Aggr is ...@@ -3010,7 +3208,15 @@ package body Exp_Aggr is
return; return;
end if; end if;
if Requires_Transient_Scope (Typ) then -- If the context is an extended return statement, it has its own
-- finalization machinery (i.e. works like a transient scope) and
-- we do not want to create an additional one, because objects on
-- the finalization list of the return must be moved to the caller's
-- finalization list to complete the return.
if Requires_Transient_Scope (Typ)
and then Ekind (Current_Scope) /= E_Return_Statement
then
Establish_Transient_Scope (Aggr, Sec_Stack => Establish_Transient_Scope (Aggr, Sec_Stack =>
Is_Controlled (Typ) or else Has_Controlled_Component (Typ)); Is_Controlled (Typ) or else Has_Controlled_Component (Typ));
end if; end if;
...@@ -3088,15 +3294,22 @@ package body Exp_Aggr is ...@@ -3088,15 +3294,22 @@ package body Exp_Aggr is
end if; end if;
-- Just set the Delay flag in the following cases where the -- Just set the Delay flag in the following cases where the
-- transformation will be done top down from above -- transformation will be done top down from above:
-- - internal aggregate (transformed when expanding the parent) -- - internal aggregate (transformed when expanding the parent)
-- - allocators (see Convert_Aggr_In_Allocator) -- - allocators (see Convert_Aggr_In_Allocator)
-- - object decl (see Convert_Aggr_In_Object_Decl) -- - object decl (see Convert_Aggr_In_Object_Decl)
-- - safe assignments (see Convert_Aggr_Assignments) -- - safe assignments (see Convert_Aggr_Assignments)
-- so far only the assignments in the init procs are taken -- so far only the assignments in the init procs are taken
-- into account -- into account
-- - (Ada 2005) A limited type in a return statement, which will
-- be rewritten as an extended return and may have its own
-- finalization machinery.
if Parent_Kind = N_Aggregate if Parent_Kind = N_Aggregate
or else Parent_Kind = N_Extension_Aggregate or else Parent_Kind = N_Extension_Aggregate
or else Parent_Kind = N_Component_Association or else Parent_Kind = N_Component_Association
...@@ -3104,6 +3317,10 @@ package body Exp_Aggr is ...@@ -3104,6 +3317,10 @@ package body Exp_Aggr is
or else (Parent_Kind = N_Object_Declaration and then not Unc_Decl) or else (Parent_Kind = N_Object_Declaration and then not Unc_Decl)
or else (Parent_Kind = N_Assignment_Statement or else (Parent_Kind = N_Assignment_Statement
and then Inside_Init_Proc) and then Inside_Init_Proc)
or else
(Is_Limited_Record (Typ)
and then Present (Parent (Parent (N)))
and then Nkind (Parent (Parent (N))) = N_Return_Statement)
then then
Set_Expansion_Delayed (N); Set_Expansion_Delayed (N);
return; return;
...@@ -3144,6 +3361,13 @@ package body Exp_Aggr is ...@@ -3144,6 +3361,13 @@ package body Exp_Aggr is
is is
Typ : constant Entity_Id := Etype (N); Typ : constant Entity_Id := Etype (N);
Static_Components : Boolean := True;
procedure Check_Static_Components;
-- Check whether all components of the aggregate are compile-time
-- known values, and can be passed as is to the back-end without
-- further expansion.
function Flatten function Flatten
(N : Node_Id; (N : Node_Id;
Ix : Node_Id; Ix : Node_Id;
...@@ -3156,6 +3380,56 @@ package body Exp_Aggr is ...@@ -3156,6 +3380,56 @@ package body Exp_Aggr is
-- Return True iff the array N is flat (which is not rivial -- Return True iff the array N is flat (which is not rivial
-- in the case of multidimensionsl aggregates). -- in the case of multidimensionsl aggregates).
-----------------------------
-- Check_Static_Components --
-----------------------------
procedure Check_Static_Components is
Expr : Node_Id;
begin
Static_Components := True;
if Nkind (N) = N_String_Literal then
null;
elsif Present (Expressions (N)) then
Expr := First (Expressions (N));
while Present (Expr) loop
if Nkind (Expr) /= N_Aggregate
or else not Compile_Time_Known_Aggregate (Expr)
or else Expansion_Delayed (Expr)
then
Static_Components := False;
exit;
end if;
Next (Expr);
end loop;
end if;
if Nkind (N) = N_Aggregate
and then Present (Component_Associations (N))
then
Expr := First (Component_Associations (N));
while Present (Expr) loop
if Nkind (Expression (Expr)) = N_Integer_Literal then
null;
elsif Nkind (Expression (Expr)) /= N_Aggregate
or else
not Compile_Time_Known_Aggregate (Expression (Expr))
or else Expansion_Delayed (Expression (Expr))
then
Static_Components := False;
exit;
end if;
Next (Expr);
end loop;
end if;
end Check_Static_Components;
------------- -------------
-- Flatten -- -- Flatten --
------------- -------------
...@@ -3177,18 +3451,17 @@ package body Exp_Aggr is ...@@ -3177,18 +3451,17 @@ package body Exp_Aggr is
return True; return True;
end if; end if;
-- Only handle bounds starting at the base type low bound if not Compile_Time_Known_Value (Lo)
-- for now since the compiler isn't able to handle different low or else not Compile_Time_Known_Value (Hi)
-- bounds yet. Case such as new String'(3..5 => ' ') will get then
-- the wrong bounds, though it seems that the aggregate should return False;
-- retain the bounds set on its Etype (see C64103E and CC1311B). end if;
Lov := Expr_Value (Lo); Lov := Expr_Value (Lo);
Hiv := Expr_Value (Hi); Hiv := Expr_Value (Hi);
if Hiv < Lov if Hiv < Lov
or else not Compile_Time_Known_Value (Blo) or else not Compile_Time_Known_Value (Blo)
or else (Lov /= Expr_Value (Blo))
then then
return False; return False;
end if; end if;
...@@ -3418,10 +3691,29 @@ package body Exp_Aggr is ...@@ -3418,10 +3691,29 @@ package body Exp_Aggr is
return; return;
end if; end if;
Check_Static_Components;
-- If the size is known, or all the components are static, try to
-- build a fully positional aggregate.
-- The size of the type may not be known for an aggregate with
-- discriminated array components, but if the components are static
-- it is still possible to verify statically that the length is
-- compatible with the upper bound of the type, and therefore it is
-- worth flattening such aggregates as well.
-- For now the back-end expands these aggregates into individual
-- assignments to the target anyway, but it is conceivable that
-- it will eventually be able to treat such aggregates statically???
if Aggr_Size_OK (Typ) if Aggr_Size_OK (Typ)
and then and then Flatten (N, First_Index (Typ), First_Index (Base_Type (Typ)))
Flatten (N, First_Index (Typ), First_Index (Base_Type (Typ)))
then then
if Static_Components then
Set_Compile_Time_Known_Aggregate (N);
Set_Expansion_Delayed (N, False);
end if;
Analyze_And_Resolve (N, Typ); Analyze_And_Resolve (N, Typ);
end if; end if;
end Convert_To_Positional; end Convert_To_Positional;
...@@ -4393,7 +4685,14 @@ package body Exp_Aggr is ...@@ -4393,7 +4685,14 @@ package body Exp_Aggr is
-- At this point we try to convert to positional form -- At this point we try to convert to positional form
if Ekind (Current_Scope) = E_Package
and then Static_Elaboration_Desired (Current_Scope)
then
Convert_To_Positional (N, Max_Others_Replicate => 100);
else
Convert_To_Positional (N); Convert_To_Positional (N);
end if;
-- if the result is no longer an aggregate (e.g. it may be a string -- if the result is no longer an aggregate (e.g. it may be a string
-- literal, or a temporary which has the needed value), then we are -- literal, or a temporary which has the needed value), then we are
...@@ -4411,6 +4710,14 @@ package body Exp_Aggr is ...@@ -4411,6 +4710,14 @@ package body Exp_Aggr is
return; return;
end if; end if;
-- If all aggregate components are compile-time known and
-- the aggregate has been flattened, nothing left to do.
if Compile_Time_Known_Aggregate (N) then
Set_Expansion_Delayed (N, False);
return;
end if;
-- Now see if back end processing is possible -- Now see if back end processing is possible
if Backend_Processing_Possible (N) then if Backend_Processing_Possible (N) then
...@@ -4467,9 +4774,16 @@ package body Exp_Aggr is ...@@ -4467,9 +4774,16 @@ package body Exp_Aggr is
or else (Parent_Kind = N_Assignment_Statement or else (Parent_Kind = N_Assignment_Statement
and then Inside_Init_Proc) and then Inside_Init_Proc)
then then
if Static_Array_Aggregate (N)
or else Compile_Time_Known_Aggregate (N)
then
Set_Expansion_Delayed (N, False);
return;
else
Set_Expansion_Delayed (N); Set_Expansion_Delayed (N);
return; return;
end if; end if;
end if;
-- STEP 4 -- STEP 4
...@@ -4682,7 +4996,6 @@ package body Exp_Aggr is ...@@ -4682,7 +4996,6 @@ package body Exp_Aggr is
else else
Expand_Array_Aggregate (N); Expand_Array_Aggregate (N);
end if; end if;
exception exception
when RE_Not_Available => when RE_Not_Available =>
return; return;
...@@ -4721,17 +5034,16 @@ package body Exp_Aggr is ...@@ -4721,17 +5034,16 @@ package body Exp_Aggr is
else else
Set_Etype (N, Typ); Set_Etype (N, Typ);
-- No tag is needed in the case of Java_VM if VM_Target = No_VM then
if Java_VM then
Expand_Record_Aggregate (N,
Parent_Expr => A);
else
Expand_Record_Aggregate (N, Expand_Record_Aggregate (N,
Orig_Tag => Orig_Tag =>
New_Occurrence_Of New_Occurrence_Of
(Node (First_Elmt (Access_Disp_Table (Typ))), Loc), (Node (First_Elmt (Access_Disp_Table (Typ))), Loc),
Parent_Expr => A); Parent_Expr => A);
else
-- No tag is needed in the case of a VM
Expand_Record_Aggregate (N,
Parent_Expr => A);
end if; end if;
end if; end if;
...@@ -4754,15 +5066,23 @@ package body Exp_Aggr is ...@@ -4754,15 +5066,23 @@ package body Exp_Aggr is
Typ : constant Entity_Id := Etype (N); Typ : constant Entity_Id := Etype (N);
Base_Typ : constant Entity_Id := Base_Type (Typ); Base_Typ : constant Entity_Id := Base_Type (Typ);
function Has_Delayed_Nested_Aggregate_Or_Tagged_Comps return Boolean; Static_Components : Boolean := True;
-- Checks the presence of a nested aggregate which needs Late_Expansion -- Flag to indicate whether all components are compile-time known,
-- or the presence of tagged components which may need tag adjustment. -- and the aggregate can be constructed statically and handled by
-- the back-end.
function Component_Not_OK_For_Backend return Boolean;
-- Check for presence of component which makes it impossible for the
-- backend to process the aggregate, thus requiring the use of a series
-- of assignment statements. Cases checked for are a nested aggregate
-- needing Late_Expansion, the presence of a tagged component which may
-- need tag adjustment, and a bit unaligned component reference.
-------------------------------------------------- ----------------------------------
-- Has_Delayed_Nested_Aggregate_Or_Tagged_Comps -- -- Component_Not_OK_For_Backend --
-------------------------------------------------- ----------------------------------
function Has_Delayed_Nested_Aggregate_Or_Tagged_Comps return Boolean is function Component_Not_OK_For_Backend return Boolean is
C : Node_Id; C : Node_Id;
Expr_Q : Node_Id; Expr_Q : Node_Id;
...@@ -4784,27 +5104,44 @@ package body Exp_Aggr is ...@@ -4784,27 +5104,44 @@ package body Exp_Aggr is
-- These are cases where the source expression may have -- These are cases where the source expression may have
-- a tag that could differ from the component tag (e.g., -- a tag that could differ from the component tag (e.g.,
-- can occur for type conversions and formal parameters). -- can occur for type conversions and formal parameters).
-- (Tag adjustment is not needed if Java_VM because object -- (Tag adjustment is not needed if VM_Target because object
-- tags are implicit in the JVM.) -- tags are implicit in the JVM.)
if Is_Tagged_Type (Etype (Expr_Q)) if Is_Tagged_Type (Etype (Expr_Q))
and then (Nkind (Expr_Q) = N_Type_Conversion and then (Nkind (Expr_Q) = N_Type_Conversion
or else (Is_Entity_Name (Expr_Q) or else (Is_Entity_Name (Expr_Q)
and then Ekind (Entity (Expr_Q)) in Formal_Kind)) and then
and then not Java_VM Ekind (Entity (Expr_Q)) in Formal_Kind))
and then VM_Target = No_VM
then then
Static_Components := False;
return True; return True;
end if;
if Is_Delayed_Aggregate (Expr_Q) then elsif Is_Delayed_Aggregate (Expr_Q) then
Static_Components := False;
return True; return True;
elsif Possible_Bit_Aligned_Component (Expr_Q) then
Static_Components := False;
return True;
end if;
if Is_Scalar_Type (Etype (Expr_Q)) then
if not Compile_Time_Known_Value (Expr_Q) then
Static_Components := False;
end if;
elsif Nkind (Expr_Q) /= N_Aggregate
or else not Compile_Time_Known_Aggregate (Expr_Q)
then
Static_Components := False;
end if; end if;
Next (C); Next (C);
end loop; end loop;
return False; return False;
end Has_Delayed_Nested_Aggregate_Or_Tagged_Comps; end Component_Not_OK_For_Backend;
-- Remaining Expand_Record_Aggregate variables -- Remaining Expand_Record_Aggregate variables
...@@ -4860,7 +5197,9 @@ package body Exp_Aggr is ...@@ -4860,7 +5197,9 @@ package body Exp_Aggr is
elsif Has_Default_Init_Comps (N) then elsif Has_Default_Init_Comps (N) then
Convert_To_Assignments (N, Typ); Convert_To_Assignments (N, Typ);
elsif Has_Delayed_Nested_Aggregate_Or_Tagged_Comps then -- Check components
elsif Component_Not_OK_For_Backend then
Convert_To_Assignments (N, Typ); Convert_To_Assignments (N, Typ);
-- If an ancestor is private, some components are not inherited and -- If an ancestor is private, some components are not inherited and
...@@ -4875,6 +5214,13 @@ package body Exp_Aggr is ...@@ -4875,6 +5214,13 @@ package body Exp_Aggr is
elsif Is_Tagged_Type (Typ) and then Has_Discriminants (Typ) then elsif Is_Tagged_Type (Typ) and then Has_Discriminants (Typ) then
Convert_To_Assignments (N, Typ); Convert_To_Assignments (N, Typ);
-- If the tagged types covers interface types we need to initialize all
-- the hidden components containing the pointers to secondary dispatch
-- tables.
elsif Is_Tagged_Type (Typ) and then Has_Abstract_Interfaces (Typ) then
Convert_To_Assignments (N, Typ);
-- If some components are mutable, the size of the aggregate component -- If some components are mutable, the size of the aggregate component
-- may be disctinct from the default size of the type component, so -- may be disctinct from the default size of the type component, so
-- we need to expand to insure that the back-end copies the proper -- we need to expand to insure that the back-end copies the proper
...@@ -4893,6 +5239,17 @@ package body Exp_Aggr is ...@@ -4893,6 +5239,17 @@ package body Exp_Aggr is
-- can be handled by gigi. -- can be handled by gigi.
else else
if Nkind (N) = N_Aggregate then
-- If the aggregate is static and can be handled by the
-- back-end, nothing left to do.
if Static_Components then
Set_Compile_Time_Known_Aggregate (N);
Set_Expansion_Delayed (N, False);
end if;
end if;
-- If no discriminants, nothing special to do -- If no discriminants, nothing special to do
if not Has_Discriminants (Typ) then if not Has_Discriminants (Typ) then
...@@ -5092,7 +5449,7 @@ package body Exp_Aggr is ...@@ -5092,7 +5449,7 @@ package body Exp_Aggr is
if Present (Orig_Tag) then if Present (Orig_Tag) then
Tag_Value := Orig_Tag; Tag_Value := Orig_Tag;
elsif Java_VM then elsif VM_Target /= No_VM then
Tag_Value := Empty; Tag_Value := Empty;
else else
Tag_Value := Tag_Value :=
...@@ -5154,9 +5511,9 @@ package body Exp_Aggr is ...@@ -5154,9 +5511,9 @@ package body Exp_Aggr is
end; end;
-- For a root type, the tag component is added (unless compiling -- For a root type, the tag component is added (unless compiling
-- for the Java VM, where tags are implicit). -- for the VMs, where tags are implicit).
elsif not Java_VM then elsif VM_Target = No_VM then
declare declare
Tag_Name : constant Node_Id := Tag_Name : constant Node_Id :=
New_Occurrence_Of New_Occurrence_Of
...@@ -5175,6 +5532,7 @@ package body Exp_Aggr is ...@@ -5175,6 +5532,7 @@ package body Exp_Aggr is
end if; end if;
end if; end if;
end if; end if;
end Expand_Record_Aggregate; end Expand_Record_Aggregate;
---------------------------- ----------------------------
...@@ -5284,50 +5642,11 @@ package body Exp_Aggr is ...@@ -5284,50 +5642,11 @@ package body Exp_Aggr is
function Make_OK_Assignment_Statement function Make_OK_Assignment_Statement
(Sloc : Source_Ptr; (Sloc : Source_Ptr;
Name : Node_Id; Name : Node_Id;
Expression : Node_Id; Expression : Node_Id) return Node_Id
Self_Ref : Boolean := False) return Node_Id
is 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 begin
Set_Assignment_OK (Name); Set_Assignment_OK (Name);
if Self_Ref then
Replace_Self_Reference (Expression);
end if;
return Make_Assignment_Statement (Sloc, Name, Expression); return Make_Assignment_Statement (Sloc, Name, Expression);
end Make_OK_Assignment_Statement; end Make_OK_Assignment_Statement;
...@@ -5393,6 +5712,12 @@ package body Exp_Aggr is ...@@ -5393,6 +5712,12 @@ package body Exp_Aggr is
return False; return False;
end if; end if;
if not Is_Scalar_Type (Component_Type (Typ))
and then Has_Non_Standard_Rep (Component_Type (Typ))
then
return False;
end if;
declare declare
Csiz : constant Nat := UI_To_Int (Component_Size (Typ)); Csiz : constant Nat := UI_To_Int (Component_Size (Typ));
...@@ -5774,4 +6099,109 @@ package body Exp_Aggr is ...@@ -5774,4 +6099,109 @@ package body Exp_Aggr is
end loop; end loop;
end Sort_Case_Table; end Sort_Case_Table;
----------------------------
-- Static_Array_Aggregate --
----------------------------
function Static_Array_Aggregate (N : Node_Id) return Boolean is
Bounds : constant Node_Id := Aggregate_Bounds (N);
Typ : constant Entity_Id := Etype (N);
Comp_Type : constant Entity_Id := Component_Type (Typ);
Agg : Node_Id;
Expr : Node_Id;
Lo : Node_Id;
Hi : Node_Id;
begin
if Is_Tagged_Type (Typ)
or else Is_Controlled (Typ)
or else Is_Packed (Typ)
then
return False;
end if;
if Present (Bounds)
and then Nkind (Bounds) = N_Range
and then Nkind (Low_Bound (Bounds)) = N_Integer_Literal
and then Nkind (High_Bound (Bounds)) = N_Integer_Literal
then
Lo := Low_Bound (Bounds);
Hi := High_Bound (Bounds);
if No (Component_Associations (N)) then
-- Verify that all components are static integers.
Expr := First (Expressions (N));
while Present (Expr) loop
if Nkind (Expr) /= N_Integer_Literal then
return False;
end if;
Next (Expr);
end loop;
return True;
else
-- We allow only a single named association, either a static
-- range or an others_clause, with a static expression.
Expr := First (Component_Associations (N));
if Present (Expressions (N)) then
return False;
elsif Present (Next (Expr)) then
return False;
elsif Present (Next (First (Choices (Expr)))) then
return False;
else
-- The aggregate is static if all components are literals,
-- or else all its components are static aggregates for the
-- component type.
if Is_Array_Type (Comp_Type)
or else Is_Record_Type (Comp_Type)
then
if Nkind (Expression (Expr)) /= N_Aggregate
or else
not Compile_Time_Known_Aggregate (Expression (Expr))
then
return False;
end if;
elsif Nkind (Expression (Expr)) /= N_Integer_Literal then
return False;
end if;
-- Create a positional aggregate with the right number of
-- copies of the expression.
Agg := Make_Aggregate (Sloc (N), New_List, No_List);
for I in UI_To_Int (Intval (Lo)) .. UI_To_Int (Intval (Hi))
loop
Append_To
(Expressions (Agg), New_Copy (Expression (Expr)));
Set_Etype (Last (Expressions (Agg)), Component_Type (Typ));
end loop;
Set_Aggregate_Bounds (Agg, Bounds);
Set_Etype (Agg, Typ);
Set_Analyzed (Agg);
Rewrite (N, Agg);
Set_Compile_Time_Known_Aggregate (N);
return True;
end if;
end if;
else
return False;
end if;
end Static_Array_Aggregate;
end Exp_Aggr; end Exp_Aggr;
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- S p e c -- -- S p e c --
-- -- -- --
-- Copyright (C) 1992-2006, Free Software Foundation, Inc. -- -- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
-- -- -- --
-- GNAT is free software; you can redistribute it and/or modify it under -- -- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -47,6 +47,16 @@ package Exp_Aggr is ...@@ -47,6 +47,16 @@ package Exp_Aggr is
-- assignment in the newly allocated object. -- assignment in the newly allocated object.
procedure Convert_Aggr_In_Assignment (N : Node_Id); procedure Convert_Aggr_In_Assignment (N : Node_Id);
-- ??? documentation needed -- If the right-hand side of an assignment is an aggregate, expand the
-- statement into a series of individual component assignments. This is
-- done if there are non-static values involved in either the bounds or
-- the components, and the aggregate cannot be handled as a whole by the
-- backend.
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
-- are compile-time known constants, rewrite N as a purely positional
-- aggregate, to be use to initialize variables and components of the type
-- without generating elaboration code.
end Exp_Aggr; end Exp_Aggr;
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment