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

	* 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

1 files changed, 158 insertions, 132 deletions

diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb
index 5337391..ad2dcbe 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 --
    ---------------------------