exp_aggr.adb (Build_Array_Aggr_Code): Rename variable "Others_Mbox_Present" to…

exp_aggr.adb (Build_Array_Aggr_Code): Rename variable "Others_Mbox_Present" to "Others_Box_Present" because the mbox...

2006-02-13  Ed Schonberg  <schonberg@adacore.com>

	* exp_aggr.adb (Build_Array_Aggr_Code): Rename variable
	"Others_Mbox_Present" to "Others_Box_Present" because the mbox concept
	does not exist in the Ada RM.
	(Compatible_Int_Bounds): Determine whether two integer range bounds
	are of equal length and have the same start and end values.
	(Is_Int_Range_Bounds): Determine whether a node is an integer range.
	(Build_Record_Aggr_Code): Perform proper sliding of a nested array
	aggregate when it is part of an object declaration.
	(Build_Record_Aggr_Code)  If the aggregate ttype is a derived type that
	constrains discriminants of its parent, add explicitly the discriminant
	constraints of the ancestor by retrieving them from the
	stored_constraint of the parent.

From-SVN: r111057

gcc/ada/exp_aggr.adb

@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 1992-2005, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2006, 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- --
@@ -850,7 +850,7 @@ package body Exp_Aggr is
             --  Ada 2005 (AI-287): Do nothing else in case of default
             --  initialized component.
 
-            if not Present (Expr) then
+            if No (Expr) then
                return Lis;
 
             elsif Nkind (Parent (Expr)) = N_Component_Association
@@ -918,7 +918,7 @@ package body Exp_Aggr is
          --  Ada 2005 (AI-287): In case of default initialized component, Expr
          --  is not present (and therefore we also initialize Expr_Q to empty).
 
-         if not Present (Expr) then
+         if No (Expr) then
             Expr_Q := Empty;
          elsif Nkind (Expr) = N_Qualified_Expression then
             Expr_Q := Expression (Expr);
@@ -1018,8 +1018,7 @@ package body Exp_Aggr is
          --  Ada 2005 (AI-287): In case of default initialized component, call
          --  the initialization subprogram associated with the component type.
 
-         if not Present (Expr) then
-
+         if No (Expr) then
             if Present (Base_Init_Proc (Etype (Ctype)))
               or else Has_Task (Base_Type (Ctype))
             then
@@ -1143,7 +1142,7 @@ package body Exp_Aggr is
             --  Ada 2005 (AI-287): Nothing else need to be done in case of
             --  default initialized component.
 
-            if not Present (Expr) then
+            if No (Expr) then
                null;
 
             else
@@ -1376,8 +1375,8 @@ package body Exp_Aggr is
       Expr   : Node_Id;
       Typ    : Entity_Id;
 
-      Others_Expr         : Node_Id := Empty;
-      Others_Mbox_Present : Boolean := False;
+      Others_Expr        : Node_Id := Empty;
+      Others_Box_Present : Boolean := False;
 
       Aggr_L : constant Node_Id := Low_Bound (Aggregate_Bounds (N));
       Aggr_H : constant Node_Id := High_Bound (Aggregate_Bounds (N));
@@ -1439,7 +1438,7 @@ package body Exp_Aggr is
                   Set_Loop_Actions (Assoc, New_List);
 
                   if Box_Present (Assoc) then
-                     Others_Mbox_Present := True;
+                     Others_Box_Present := True;
                   else
                      Others_Expr := Expression (Assoc);
                   end if;
@@ -1489,7 +1488,7 @@ package body Exp_Aggr is
          --  We don't need to generate loops over empty gaps, but if there is
          --  a single empty range we must analyze the expression for semantics
 
-         if Present (Others_Expr) or else Others_Mbox_Present then
+         if Present (Others_Expr) or else Others_Box_Present then
             declare
                First : Boolean := True;
 
@@ -1621,10 +1620,6 @@ package body Exp_Aggr is
       Attach   : Node_Id;
       Ctrl_Stuff_Done : Boolean := False;
 
-      function Get_Constraint_Association (T : Entity_Id) return Node_Id;
-      --  Returns the first discriminant association in the constraint
-      --  associated with T, if any, otherwise returns Empty.
-
       function Ancestor_Discriminant_Value (Disc : Entity_Id) return Node_Id;
       --  Returns the value that the given discriminant of an ancestor
       --  type should receive (in the absence of a conflict with the
@@ -1636,6 +1631,20 @@ package body Exp_Aggr is
       --  values provided by either an association of the aggregate or
       --  by the constraint imposed by a parent type (RM95-4.3.2(8)).
 
+      function Compatible_Int_Bounds
+        (Agg_Bounds : Node_Id;
+         Typ_Bounds : Node_Id) return Boolean;
+      --  Return true if Agg_Bounds are equal or within Typ_Bounds. It is
+      --  assumed that both bounds are integer ranges.
+
+      procedure Gen_Ctrl_Actions_For_Aggr;
+      --  Deal with the various controlled type data structure
+      --  initializations.
+
+      function Get_Constraint_Association (T : Entity_Id) return Node_Id;
+      --  Returns the first discriminant association in the constraint
+      --  associated with T, if any, otherwise returns Empty.
+
       function Init_Controller
         (Target  : Node_Id;
          Typ     : Entity_Id;
@@ -1647,9 +1656,9 @@ package body Exp_Aggr is
       --  it to finalization list F. Init_Pr conditions the call to the
       --  init proc since it may already be done due to ancestor initialization
 
-      procedure Gen_Ctrl_Actions_For_Aggr;
-      --  Deal with the various controlled type data structure
-      --  initializations
+      function Is_Int_Range_Bounds (Bounds : Node_Id) return Boolean;
+      --  Check whether Bounds is a range node and its lower and higher bounds
+      --  are integers literals.
 
       ---------------------------------
       -- Ancestor_Discriminant_Value --
@@ -1811,6 +1820,22 @@ package body Exp_Aggr is
          end loop;
       end Check_Ancestor_Discriminants;
 
+      ---------------------------
+      -- Compatible_Int_Bounds --
+      ---------------------------
+
+      function Compatible_Int_Bounds
+        (Agg_Bounds : Node_Id;
+         Typ_Bounds : Node_Id) return Boolean
+      is
+         Agg_Lo : constant Uint := Intval (Low_Bound  (Agg_Bounds));
+         Agg_Hi : constant Uint := Intval (High_Bound (Agg_Bounds));
+         Typ_Lo : constant Uint := Intval (Low_Bound  (Typ_Bounds));
+         Typ_Hi : constant Uint := Intval (High_Bound (Typ_Bounds));
+      begin
+         return Typ_Lo <= Agg_Lo and then Agg_Hi <= Typ_Hi;
+      end Compatible_Int_Bounds;
+
       --------------------------------
       -- Get_Constraint_Association --
       --------------------------------
@@ -1909,6 +1934,17 @@ package body Exp_Aggr is
          return L;
       end Init_Controller;
 
+      -------------------------
+      -- Is_Int_Range_Bounds --
+      -------------------------
+
+      function Is_Int_Range_Bounds (Bounds : Node_Id) return Boolean is
+      begin
+         return Nkind (Bounds) = N_Range
+           and then Nkind (Low_Bound  (Bounds)) = N_Integer_Literal
+           and then Nkind (High_Bound (Bounds)) = N_Integer_Literal;
+      end Is_Int_Range_Bounds;
+
       -------------------------------
       -- Gen_Ctrl_Actions_For_Aggr --
       -------------------------------
@@ -2307,12 +2343,62 @@ package body Exp_Aggr is
          if Has_Discriminants (Typ)
            and then not Is_Unchecked_Union (Base_Type (Typ))
          then
-            --  ??? The discriminants of the object not inherited in the type
-            --  of the object should be initialized here
+            --  If the type is derived, and constrains discriminants of the
+            --  parent type, these discriminants are not components of the
+            --  aggregate, and must be initialized explicitly. They are not
+            --  visible components of the object, but can become visible with
+            --  a view conversion to the ancestor.
 
-            null;
+            declare
+               Btype      : Entity_Id;
+               Parent_Type : Entity_Id;
+               Disc        : Entity_Id;
+               Discr_Val   : Elmt_Id;
+
+            begin
+               Btype := Base_Type (Typ);
+
+               while Is_Derived_Type (Btype)
+                  and then Present (Stored_Constraint (Btype))
+               loop
+                  Parent_Type := Etype (Btype);
+
+                  Disc := First_Discriminant (Parent_Type);
+                  Discr_Val :=
+                    First_Elmt (Stored_Constraint (Base_Type (Typ)));
+                  while Present (Discr_Val) loop
 
-            --  Generate discriminant init values
+                     --  Only those discriminants of the parent that are not
+                     --  renamed by discriminants of the derived type need to
+                     --  be added explicitly.
+
+                     if not Is_Entity_Name (Node (Discr_Val))
+                       or else
+                         Ekind (Entity (Node (Discr_Val))) /= E_Discriminant
+                     then
+                        Comp_Expr :=
+                          Make_Selected_Component (Loc,
+                            Prefix        => New_Copy_Tree (Target),
+                            Selector_Name => New_Occurrence_Of (Disc, Loc));
+
+                        Instr :=
+                          Make_OK_Assignment_Statement (Loc,
+                            Name       => Comp_Expr,
+                            Expression => New_Copy_Tree (Node (Discr_Val)));
+
+                        Set_No_Ctrl_Actions (Instr);
+                        Append_To (L, Instr);
+                     end if;
+
+                     Next_Discriminant (Disc);
+                     Next_Elmt (Discr_Val);
+                  end loop;
+
+                  Btype := Base_Type (Parent_Type);
+               end loop;
+            end;
+
+            --  Generate discriminant init values for the visible discriminants
 
             declare
                Discriminant : Entity_Id;
@@ -2461,9 +2547,111 @@ package body Exp_Aggr is
             --  inner aggregate top-down.
 
             if Is_Delayed_Aggregate (Expr_Q) then
-               Append_List_To (L,
-                 Late_Expansion (Expr_Q, Comp_Type, Comp_Expr,
-                   Internal_Final_List));
+
+               --  We have the following case of aggregate nesting inside
+               --  an object declaration:
+
+               --    type Arr_Typ is array (Integer range <>) of ...;
+               --
+               --    type Rec_Typ (...) is record
+               --       Obj_Arr_Typ : Arr_Typ (A .. B);
+               --    end record;
+               --
+               --    Obj_Rec_Typ : Rec_Typ := (...,
+               --      Obj_Arr_Typ => (X => (...), Y => (...)));
+
+               --  The length of the ranges of the aggregate and Obj_Add_Typ
+               --  are equal (B - A = Y - X), but they do not coincide (X /=
+               --  A and B /= Y). This case requires array sliding which is
+               --  performed in the following manner:
+
+               --    subtype Arr_Sub is Arr_Typ (X .. Y);
+               --    Temp : Arr_Sub;
+               --    Temp (X) := (...);
+               --    ...
+               --    Temp (Y) := (...);
+               --    Obj_Rec_Typ.Obj_Arr_Typ := Temp;
+
+               if Present (Obj)
+                 and then Ekind (Comp_Type) = E_Array_Subtype
+                 and then Is_Int_Range_Bounds (Aggregate_Bounds (Expr_Q))
+                 and then Is_Int_Range_Bounds (First_Index (Comp_Type))
+                 and then not
+                   Compatible_Int_Bounds (
+                     Agg_Bounds => Aggregate_Bounds (Expr_Q),
+                     Typ_Bounds => First_Index (Comp_Type))
+               then
+                  declare
+                     --  Create the array subtype with bounds equal to those
+                     --  of the corresponding aggregate.
+
+                     SubE : constant Entity_Id :=
+                              Make_Defining_Identifier (Loc,
+                                New_Internal_Name ('T'));
+
+                     SubD : constant Node_Id :=
+                              Make_Subtype_Declaration (Loc,
+                                Defining_Identifier =>
+                                  SubE,
+                                Subtype_Indication  =>
+                                  Make_Subtype_Indication (Loc,
+                                    Subtype_Mark => New_Reference_To (
+                                      Etype (Comp_Type), Loc),
+                                    Constraint =>
+                                      Make_Index_Or_Discriminant_Constraint (
+                                        Loc, Constraints => New_List (
+                                          New_Copy_Tree (Aggregate_Bounds (
+                                            Expr_Q))))));
+
+                     --  Create a temporary array of the above subtype which
+                     --  will be used to capture the aggregate assignments.
+
+                     TmpE : constant Entity_Id :=
+                              Make_Defining_Identifier (Loc,
+                                New_Internal_Name ('A'));
+
+                     TmpD : constant Node_Id :=
+                              Make_Object_Declaration (Loc,
+                                Defining_Identifier =>
+                                  TmpE,
+                                Object_Definition   =>
+                                  New_Reference_To (SubE, Loc));
+
+                  begin
+                     Set_No_Initialization (TmpD);
+                     Append_To (L, SubD);
+                     Append_To (L, TmpD);
+
+                     --  Expand the aggregate into assignments to the temporary
+                     --  array.
+
+                     Append_List_To (L,
+                       Late_Expansion (Expr_Q, Comp_Type,
+                         New_Reference_To (TmpE, Loc), Internal_Final_List));
+
+                     --  Slide
+
+                     Append_To (L,
+                       Make_Assignment_Statement (Loc,
+                         Name       => New_Copy_Tree (Comp_Expr),
+                         Expression => New_Reference_To (TmpE, Loc)));
+
+                     --  Do not pass the original aggregate to Gigi as is
+                     --  since it will potentially clobber the front or the
+                     --  end of the array. Setting the expression to empty
+                     --  is safe since all aggregates will be expanded into
+                     --  assignments.
+
+                     Set_Expression (Parent (Obj), Empty);
+                  end;
+
+               --  Normal case (sliding not required)
+
+               else
+                  Append_List_To (L,
+                    Late_Expansion (Expr_Q, Comp_Type, Comp_Expr,
+                      Internal_Final_List));
+               end if;
 
             else
                Instr :=