OpenE2K/gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

exp_aggr.adb (Gen_Assign): If the expression is an aggregate for a component of an array of arrays in an...

Browse Source 
* exp_aggr.adb (Gen_Assign): If the expression is an aggregate for a
	component of an array of arrays in an assignment context, and the
	aggregate has component associations that require sliding on
	assignment, force reanalysis of the aggregate to generate a temporary
	before the assignment.
	(Must_Slide): Make global to the package, for use in Gen_Assign.

From-SVN: r94813
This commit is contained in:
Arnaud Charlet 2005-02-10 14:53:58 +01:00
parent 8afc118e11
commit 3cf3e5c6a2
1 changed files with 158 additions and 132 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

290
gcc/ada/exp_aggr.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2004 Free Software Foundation, Inc. --
-- Copyright (C) 1992-2005 Free Software Foundation, Inc. --
-- --
-- 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- --
@ -67,6 +67,20 @@ package body Exp_Aggr is
type Case_Table_Type is array (Nat range <>) of Case_Bounds;
-- Table type used by Check_Case_Choices procedure
function Must_Slide
(Obj_Type : Entity_Id;
Typ : Entity_Id) return Boolean;
-- A static array aggregate in an object declaration can in most cases be
-- expanded in place. The one exception is when the aggregate is given
-- with component associations that specify different bounds from those of
-- the type definition in the object declaration. In this pathological
-- case the aggregate must slide, and we must introduce an intermediate
-- temporary to hold it.
--
-- The same holds in an assignment to one-dimensional array of arrays,
-- when a component may be given with bounds that differ from those of the
-- component type.
procedure Sort_Case_Table (Case_Table : in out Case_Table_Type);
-- Sort the Case Table using the Lower Bound of each Choice as the key.
-- A simple insertion sort is used since the number of choices in a case
@ -110,16 +124,16 @@ 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 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 types. Flist is an
-- expression representing the finalization list on which to
-- attach the controlled components if any. Obj is present in the
-- object declaration and dynamic allocation cases, it contains
-- an entity that allows to know if the value being created needs to be
-- attached to the final list in case of pragma finalize_Storage_Only.
-- N is an N_Aggregate or a 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
-- types. Flist is an expression representing the finalization list on
-- which to attach the controlled components if any. Obj is present in the
-- object declaration and dynamic allocation cases, it contains an entity
-- that allows to know if the value being created needs to be attached to
-- the final list in case of pragma finalize_Storage_Only.
--
-- Is_Limited_Ancestor_Expansion indicates that the function has been
-- called recursively to expand the limited ancestor to avoid copying it.
@ -159,19 +173,19 @@ package body Exp_Aggr is
Max_Others_Replicate : Nat := 5;
Handle_Bit_Packed : Boolean := False);
-- If possible, convert named notation to positional notation. This
-- conversion is possible only in some static cases. If the conversion
-- is possible, then N is rewritten with the analyzed converted
-- aggregate. The parameter Max_Others_Replicate controls the maximum
-- number of values corresponding to an others choice that will be
-- converted to positional notation (the default of 5 is the normal
-- limit, and reflects the fact that normally the loop is better than
-- a lot of separate assignments). Note that this limit gets overridden
-- in any case if either of the restrictions No_Elaboration_Code or
-- No_Implicit_Loops is set. The parameter Handle_Bit_Packed is usually
-- set False (since we do not expect the back end to handle bit packed
-- arrays, so the normal case of conversion is pointless), but in the
-- special case of a call from Packed_Array_Aggregate_Handled, we set
-- this parameter to True, since these are cases we handle in there.
-- conversion is possible only in some static cases. If the conversion is
-- possible, then N is rewritten with the analyzed converted aggregate.
-- The parameter Max_Others_Replicate controls the maximum number of
-- values corresponding to an others choice that will be converted to
-- positional notation (the default of 5 is the normal limit, and reflects
-- the fact that normally the loop is better than a lot of separate
-- assignments). Note that this limit gets overridden in any case if
-- either of the restrictions No_Elaboration_Code or No_Implicit_Loops is
-- set. The parameter Handle_Bit_Packed is usually set False (since we do
-- not expect the back end to handle bit packed arrays, so the normal case
-- of conversion is pointless), but in the special case of a call from
-- Packed_Array_Aggregate_Handled, we set this parameter to True, since
-- these are cases we handle in there.
procedure Expand_Array_Aggregate (N : Node_Id);
-- This is the top-level routine to perform array aggregate expansion.
@ -220,18 +234,17 @@ package body Exp_Aggr is
Target : Node_Id;
Flist : Node_Id := Empty;
Obj : Entity_Id := Empty) return List_Id;
-- N is a nested (record or array) aggregate that has been marked
-- with 'Delay_Expansion'. Typ is the expected type of the
-- aggregate and Target is a (duplicable) expression that will
-- hold the result of the aggregate expansion. Flist is the
-- finalization list to be used to attach controlled
-- components. 'Obj' when non empty, carries the original object
-- being initialized in order to know if it needs to be attached
-- to the previous parameter which may not be the case when
-- Finalize_Storage_Only is set. Basically this procedure is used
-- to implement top-down expansions of nested aggregates. This is
-- necessary for avoiding temporaries at each level as well as for
-- propagating the right internal finalization list.
-- N is a nested (record or array) aggregate that has been marked with
-- 'Delay_Expansion'. Typ is the expected type of the aggregate and Target
-- is a (duplicable) expression that will hold the result of the aggregate
-- expansion. Flist is the finalization list to be used to attach
-- controlled components. 'Obj' when non empty, carries the original
-- object being initialized in order to know if it needs to be attached to
-- the previous parameter which may not be the case in the case where
-- Finalize_Storage_Only is set. Basically this procedure is used to
-- implement top-down expansions of nested aggregates. This is necessary
-- for avoiding temporaries at each level as well as for propagating the
-- right internal finalization list.
function Make_OK_Assignment_Statement
(Sloc : Source_Ptr;
@ -280,10 +293,10 @@ package body Exp_Aggr is
function Backend_Processing_Possible (N : Node_Id) return Boolean is
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;
-- Recursively checks that N is fully positional, returns true if so.
-- Recursively checks that N is fully positional, returns true if so
------------------
-- Static_Check --
@ -352,13 +365,12 @@ package body Exp_Aggr is
end if;
-- Checks 5 (if the component type is tagged, then we may need
-- to do tag adjustments; perhaps this should be refined to
-- check for any component associations that actually
-- need tag adjustment, along the lines of the test that's
-- done in Has_Delayed_Nested_Aggregate_Or_Tagged_Comps
-- for record aggregates with tagged components, but not
-- clear whether it's worthwhile ???; in the case of the
-- JVM, object tags are handled implicitly)
-- to do tag adjustments; perhaps this should be refined to check for
-- any component associations that actually need tag adjustment,
-- along the lines of the test that is carried out in
-- Has_Delayed_Nested_Aggregate_Or_Tagged_Comps for record aggregates
-- with tagged components, but not clear whether it's worthwhile ???;
-- in the case of the JVM, object tags are handled implicitly)
if Is_Tagged_Type (Component_Type (Typ)) and then not Java_VM then
return False;
@ -392,11 +404,11 @@ package body Exp_Aggr is
-- we are dealing with an expression we emit a sequence of
-- assignments instead of a loop.
-- (c) Generate the remaining loops to cover the others choice if any.
-- (c) Generate the remaining loops to cover the others choice if any
-- 2. If the aggregate contains positional elements we
-- (a) translate the positional elements in a series of assignments.
-- (a) translate the positional elements in a series of assignments
-- (b) Generate a final loop to cover the others choice if any.
-- Note that this final loop has to be a while loop since the case
@ -432,18 +444,18 @@ package body Exp_Aggr is
Index_Base_H : constant Node_Id := Type_High_Bound (Index_Base);
function Add (Val : Int; To : Node_Id) return Node_Id;
-- Returns an expression where Val is added to expression To,
-- unless To+Val is provably out of To's base type range.
-- To must be an already analyzed expression.
-- Returns an expression where Val is added to expression To, unless
-- To+Val is provably out of To's base type range. To must be an
-- already analyzed expression.
function Empty_Range (L, H : Node_Id) return Boolean;
-- Returns True if the range defined by L .. H is certainly empty.
-- Returns True if the range defined by L .. H is certainly empty
function Equal (L, H : Node_Id) return Boolean;
-- Returns True if L = H for sure.
-- Returns True if L = H for sure
function Index_Base_Name return Node_Id;
-- Returns a new reference to the index type name.
-- Returns a new reference to the index type name
function Gen_Assign (Ind : Node_Id; Expr : Node_Id) return List_Id;
-- Ind must be a side-effect free expression. If the input aggregate
@ -452,7 +464,7 @@ package body Exp_Aggr is
--
-- Into (Indices, Ind) := Expr;
--
-- Otherwise we call Build_Code recursively.
-- Otherwise we call Build_Code recursively
--
-- Ada 2005 (AI-287): In case of default initialized component, Expr
-- is empty and we generate a call to the corresponding IP subprogram.
@ -823,9 +835,30 @@ package body Exp_Aggr is
end if;
if Is_Delayed_Aggregate (Expr_Q) then
return
Add_Loop_Actions (
Late_Expansion (Expr_Q, Etype (Expr_Q), Indexed_Comp, F));
-- This is either a subaggregate of a multidimentional array,
-- or a component of an array type whose component type is
-- also an array. In the latter case, the expression may have
-- component associations that provide different bounds from
-- those of the component type, and sliding must occur. Instead
-- of decomposing the current aggregate assignment, force the
-- re-analysis of the assignment, so that a temporary will be
-- generated in the usual fashion, and sliding will take place.
if Nkind (Parent (N)) = N_Assignment_Statement
and then Is_Array_Type (Comp_Type)
and then Present (Component_Associations (Expr_Q))
and then Must_Slide (Comp_Type, Etype (Expr_Q))
then
Set_Expansion_Delayed (Expr_Q, False);
Set_Analyzed (Expr_Q, False);
else
return
Add_Loop_Actions (
Late_Expansion (
Expr_Q, Etype (Expr_Q), Indexed_Comp, F));
end if;
end if;
end if;
@ -1268,7 +1301,7 @@ package body Exp_Aggr is
Sort_Case_Table (Table);
end if;
-- STEP 1 (b): take care of the whole set of discrete choices.
-- STEP 1 (b): take care of the whole set of discrete choices
for J in 1 .. Nb_Choices loop
Low := Table (J).Choice_Lo;
@ -2470,7 +2503,7 @@ package body Exp_Aggr is
Next_Elmt (Disc2);
end loop;
-- If any discriminant constraint is non-static, emit a check.
-- If any discriminant constraint is non-static, emit a check
if Present (Cond) then
Insert_Action (N,
@ -2632,10 +2665,11 @@ package body Exp_Aggr is
(N : Node_Id;
Ix : Node_Id;
Ixb : Node_Id) return Boolean;
-- Convert the aggregate into a purely positional form if possible.
-- Convert the aggregate into a purely positional form if possible
function Is_Flat (N : Node_Id; Dims : Int) return Boolean;
-- Non trivial for multidimensional aggregate.
-- Return True iff the array N is flat (which is not rivial
-- in the case of multidimensionsl aggregates).
-------------
-- Flatten --
@ -2985,14 +3019,14 @@ package body Exp_Aggr is
-- Ctyp is the corresponding component type.
Aggr_Dimension : constant Pos := Number_Dimensions (Typ);
-- Number of aggregate index dimensions.
-- Number of aggregate index dimensions
Aggr_Low : array (1 .. Aggr_Dimension) of Node_Id;
Aggr_High : array (1 .. Aggr_Dimension) of Node_Id;
-- Low and High bounds of the constraint for each aggregate index.
-- Low and High bounds of the constraint for each aggregate index
Aggr_Index_Typ : array (1 .. Aggr_Dimension) of Entity_Id;
-- The type of each index.
-- The type of each index
Maybe_In_Place_OK : Boolean;
-- If the type is neither controlled nor packed and the aggregate
@ -3035,14 +3069,6 @@ package body Exp_Aggr is
-- be done in place, because none of the new values can depend on the
-- components of the target of the assignment.
function Must_Slide (N : Node_Id; Typ : Entity_Id) return Boolean;
-- A static aggregate in an object declaration can in most cases be
-- expanded in place. The one exception is when the aggregate is given
-- with component associations that specify different bounds from those
-- of the type definition in the object declaration. In this rather
-- pathological case the aggregate must slide, and we must introduce
-- an intermediate temporary to hold it.
procedure Others_Check (Sub_Aggr : Node_Id; Dim : Pos);
-- Checks that if an others choice is present in any sub-aggregate no
-- aggregate index is outside the bounds of the index constraint.
@ -3209,14 +3235,14 @@ package body Exp_Aggr is
procedure Check_Same_Aggr_Bounds (Sub_Aggr : Node_Id; Dim : Pos) is
Sub_Lo : constant Node_Id := Low_Bound (Aggregate_Bounds (Sub_Aggr));
Sub_Hi : constant Node_Id := High_Bound (Aggregate_Bounds (Sub_Aggr));
-- The bounds of this specific sub-aggregate.
-- The bounds of this specific sub-aggregate
Aggr_Lo : constant Node_Id := Aggr_Low (Dim);
Aggr_Hi : constant Node_Id := Aggr_High (Dim);
-- The bounds of the aggregate for this dimension
Ind_Typ : constant Entity_Id := Aggr_Index_Typ (Dim);
-- The index type for this dimension.
-- The index type for this dimension.xxx
Cond : Node_Id := Empty;
@ -3463,7 +3489,7 @@ package body Exp_Aggr is
Comp : Node_Id := Expr;
function Check_Component (Comp : Node_Id) return Boolean;
-- Do the recursive traversal, after copy.
-- Do the recursive traversal, after copy
---------------------
-- Check_Component --
@ -3518,7 +3544,8 @@ package body Exp_Aggr is
return False;
elsif Nkind (Expr) = N_Allocator then
-- For now, too complex to analyze.
-- For now, too complex to analyze
return False;
end if;
@ -3586,55 +3613,11 @@ package body Exp_Aggr is
end loop;
end if;
-- Now check the component values themselves.
-- Now check the component values themselves
return Safe_Aggregate (N);
end In_Place_Assign_OK;
----------------
-- Must_Slide --
----------------
function Must_Slide (N : Node_Id; Typ : Entity_Id) return Boolean
is
Obj_Type : constant Entity_Id :=
Etype (Defining_Identifier (Parent (N)));
L1, L2, H1, H2 : Node_Id;
begin
-- No sliding if the type of the object is not established yet, if
-- it is an unconstrained type whose actual subtype comes from the
-- aggregate, or if the two types are identical.
if not Is_Array_Type (Obj_Type) then
return False;
elsif not Is_Constrained (Obj_Type) then
return False;
elsif Typ = Obj_Type then
return False;
else
-- Sliding can only occur along the first dimension
Get_Index_Bounds (First_Index (Typ), L1, H1);
Get_Index_Bounds (First_Index (Obj_Type), L2, H2);
if not Is_Static_Expression (L1)
or else not Is_Static_Expression (L2)
or else not Is_Static_Expression (H1)
or else not Is_Static_Expression (H2)
then
return False;
else
return Expr_Value (L1) /= Expr_Value (L2)
or else Expr_Value (H1) /= Expr_Value (H2);
end if;
end if;
end Must_Slide;
------------------
-- Others_Check --
------------------
@ -3642,10 +3625,10 @@ package body Exp_Aggr is
procedure Others_Check (Sub_Aggr : Node_Id; Dim : Pos) is
Aggr_Lo : constant Node_Id := Aggr_Low (Dim);
Aggr_Hi : constant Node_Id := Aggr_High (Dim);
-- The bounds of the aggregate for this dimension.
-- The bounds of the aggregate for this dimension
Ind_Typ : constant Entity_Id := Aggr_Index_Typ (Dim);
-- The index type for this dimension.
-- The index type for this dimension
Need_To_Check : Boolean := False;
@ -3886,7 +3869,7 @@ package body Exp_Aggr is
pragma Assert (not Raises_Constraint_Error (N));
-- STEP 1a.
-- STEP 1a
-- Check that the index range defined by aggregate bounds is
-- compatible with corresponding index subtype.
@ -3934,14 +3917,14 @@ package body Exp_Aggr is
end loop;
end Index_Compatibility_Check;
-- STEP 1b.
-- STEP 1b
-- If an others choice is present check that no aggregate
-- index is outside the bounds of the index constraint.
Others_Check (N, 1);
-- STEP 1c.
-- STEP 1c
-- For multidimensional arrays make sure that all subaggregates
-- corresponding to the same dimension have the same bounds.
@ -3950,7 +3933,7 @@ package body Exp_Aggr is
Check_Same_Aggr_Bounds (N, 1);
end if;
-- STEP 2.
-- STEP 2
-- Here we test for is packed array aggregate that we can handle
-- at compile time. If so, return with transformation done. Note
@ -4017,7 +4000,7 @@ package body Exp_Aggr is
return;
end if;
-- STEP 3.
-- STEP 3
-- Delay expansion for nested aggregates it will be taken care of
-- when the parent aggregate is expanded
@ -4042,7 +4025,7 @@ package body Exp_Aggr is
return;
end if;
-- STEP 4.
-- STEP 4
-- Look if in place aggregate expansion is possible
@ -4086,7 +4069,8 @@ package body Exp_Aggr is
if not Has_Default_Init_Comps (N)
and then Comes_From_Source (Parent (N))
and then Nkind (Parent (N)) = N_Object_Declaration
and then not Must_Slide (N, Typ)
and then not
Must_Slide (Etype (Defining_Identifier (Parent (N))), Typ)
and then N = Expression (Parent (N))
and then not Is_Bit_Packed_Array (Typ)
and then not Has_Controlled_Component (Typ)
@ -4120,7 +4104,7 @@ package body Exp_Aggr is
Set_Expansion_Delayed (N);
return;
-- In the remaining cases the aggregate is the RHS of an assignment.
-- In the remaining cases the aggregate is the RHS of an assignment
elsif Maybe_In_Place_OK
and then Is_Entity_Name (Name (Parent (N)))
@ -4602,7 +4586,7 @@ package body Exp_Aggr is
if Is_Tagged_Type (Typ) then
-- The tagged case, _parent and _tag component must be created.
-- The tagged case, _parent and _tag component must be created
-- Reset null_present unconditionally. tagged records always have
-- at least one field (the tag or the parent)
@ -5164,6 +5148,48 @@ package body Exp_Aggr is
end if;
end Initialize_Discriminants;
----------------
-- Must_Slide --
----------------
function Must_Slide
(Obj_Type : Entity_Id;
Typ : Entity_Id) return Boolean
is
L1, L2, H1, H2 : Node_Id;
begin
-- No sliding if the type of the object is not established yet, if
-- it is an unconstrained type whose actual subtype comes from the
-- aggregate, or if the two types are identical.
if not Is_Array_Type (Obj_Type) then
return False;
elsif not Is_Constrained (Obj_Type) then
return False;
elsif Typ = Obj_Type then
return False;
else
-- Sliding can only occur along the first dimension
Get_Index_Bounds (First_Index (Typ), L1, H1);
Get_Index_Bounds (First_Index (Obj_Type), L2, H2);
if not Is_Static_Expression (L1)
or else not Is_Static_Expression (L2)
or else not Is_Static_Expression (H1)
or else not Is_Static_Expression (H2)
then
return False;
else
return Expr_Value (L1) /= Expr_Value (L2)
or else Expr_Value (H1) /= Expr_Value (H2);
end if;
end if;
end Must_Slide;
---------------------------
-- Safe_Slice_Assignment --
---------------------------