diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb index 5337391dde2..ad2dcbe1326 100644 --- a/gcc/ada/exp_aggr.adb +++ b/gcc/ada/exp_aggr.adb @@ -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 -- ---------------------------