[multiple changes]

2016-04-20  Hristian Kirtchev  <kirtchev@adacore.com>

	* sem_attr.ads Add new table Universal_Type_Attribute.
	* sem_util.adb (Yields_Universal_Type): Use a table lookup when
	checking attributes.

2016-04-20  Ed Schonberg  <schonberg@adacore.com>

	* exp_aggr.adb (Init_Stored_Discriminants,
	Init_Visible_Discriminants): New procedures, subsidiary of
	Build_Record_Aggr_Code, to handle properly the construction
	of aggregates for a derived type that constrains some parent
	discriminants and renames others.

From-SVN: r235255

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 275823173e2eef7b9f8155dbfeab4d2f534765d7..16b6a580c2e0232580999e731b86c053909f7dd5 100644 (file)
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,17 @@
+2016-04-20  Hristian Kirtchev  <kirtchev@adacore.com>
+
+       * sem_attr.ads Add new table Universal_Type_Attribute.
+       * sem_util.adb (Yields_Universal_Type): Use a table lookup when
+       checking attributes.
+
+2016-04-20  Ed Schonberg  <schonberg@adacore.com>
+
+       * exp_aggr.adb (Init_Stored_Discriminants,
+       Init_Visible_Discriminants): New procedures, subsidiary of
+       Build_Record_Aggr_Code, to handle properly the construction
+       of aggregates for a derived type that constrains some parent
+       discriminants and renames others.
+
 2016-04-20  Hristian Kirtchev  <kirtchev@adacore.com>
 
        * sem_ch12.adb (Qualify_Universal_Operands): New routine.

diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb
index bd757cd1040700954679c5b5dc70a92c579f3e5c..c7a9a97e8e8aa488370e32ebec0472205c0b77b9 100644 (file)
--- a/gcc/ada/exp_aggr.adb
+++ b/gcc/ada/exp_aggr.adb
@@ -1879,6 +1879,11 @@ package body Exp_Aggr is
       --  Returns the first discriminant association in the constraint
       --  associated with T, if any, otherwise returns Empty.
 
+      function Get_Explicit_Discriminant_Value (D : Entity_Id) return Node_Id;
+      --  If the ancestor part is an unconstrained type and further ancestors
+      --  do not provide discriminants for it, check aggregate components for
+      --  values of the discriminants.
+
       procedure Init_Hidden_Discriminants (Typ : Entity_Id; List : List_Id);
       --  If Typ is derived, and constrains discriminants of the parent type,
       --  these discriminants are not components of the aggregate, and must be
@@ -1886,10 +1891,19 @@ package body Exp_Aggr is
       --  if Typ derives fron an already constrained subtype of a discriminated
       --  parent type.
 
-      function Get_Explicit_Discriminant_Value (D : Entity_Id) return Node_Id;
-      --  If the ancestor part is an unconstrained type and further ancestors
-      --  do not provide discriminants for it, check aggregate components for
-      --  values of the discriminants.
+      procedure Init_Stored_Discriminants;
+      --  If the type is derived and has inherited discriminants, generate
+      --  explicit assignments for each, using the store constraint of the
+      --  type. Note that both visible and stored discriminants must be
+      --  initialized in case the derived type has some renamed and some
+      --  constrained discriminants.
+
+      procedure Init_Visible_Discriminants;
+      --  If type has discriminants, retrieve their values from aggregate,
+      --  and generate explicit assignments for each. This does not include
+      --  discriminants inherited from ancestor, which are handled above.
+      --  The type of the aggregate is a subtype created ealier using the
+      --  given values of the discriminant components of the aggregate.
 
       function Is_Int_Range_Bounds (Bounds : Node_Id) return Boolean;
       --  Check whether Bounds is a range node and its lower and higher bounds
@@ -2279,6 +2293,70 @@ package body Exp_Aggr is
          end loop;
       end Init_Hidden_Discriminants;
 
+      --------------------------------
+      -- Init_Visible_Discriminants --
+      --------------------------------
+
+      procedure Init_Visible_Discriminants is
+         Discriminant       : Entity_Id;
+         Discriminant_Value : Node_Id;
+
+      begin
+         Discriminant := First_Discriminant (Typ);
+         while Present (Discriminant) loop
+            Comp_Expr :=
+              Make_Selected_Component (Loc,
+                Prefix        => New_Copy_Tree (Target),
+                Selector_Name => New_Occurrence_Of (Discriminant, Loc));
+
+            Discriminant_Value :=
+              Get_Discriminant_Value
+                (Discriminant, Typ, Discriminant_Constraint (N_Typ));
+
+            Instr :=
+              Make_OK_Assignment_Statement (Loc,
+                Name       => Comp_Expr,
+                Expression => New_Copy_Tree (Discriminant_Value));
+
+            Set_No_Ctrl_Actions (Instr);
+            Append_To (L, Instr);
+
+            Next_Discriminant (Discriminant);
+         end loop;
+      end Init_Visible_Discriminants;
+
+      -------------------------------
+      -- Init_Stored_Discriminants --
+      -------------------------------
+
+      procedure Init_Stored_Discriminants is
+         Discriminant       : Entity_Id;
+         Discriminant_Value : Node_Id;
+
+      begin
+         Discriminant := First_Stored_Discriminant (Typ);
+         while Present (Discriminant) loop
+            Comp_Expr :=
+              Make_Selected_Component (Loc,
+                Prefix        => New_Copy_Tree (Target),
+                Selector_Name => New_Occurrence_Of (Discriminant, Loc));
+
+            Discriminant_Value :=
+              Get_Discriminant_Value
+                (Discriminant, N_Typ, Discriminant_Constraint (N_Typ));
+
+            Instr :=
+              Make_OK_Assignment_Statement (Loc,
+                Name       => Comp_Expr,
+                Expression => New_Copy_Tree (Discriminant_Value));
+
+            Set_No_Ctrl_Actions (Instr);
+            Append_To (L, Instr);
+
+            Next_Stored_Discriminant (Discriminant);
+         end loop;
+      end Init_Stored_Discriminants;
+
       -------------------------
       -- Is_Int_Range_Bounds --
       -------------------------
@@ -2681,35 +2759,11 @@ package body Exp_Aggr is
 
             --  Generate discriminant init values for the visible discriminants
 
-            declare
-               Discriminant : Entity_Id;
-               Discriminant_Value : Node_Id;
-
-            begin
-               Discriminant := First_Stored_Discriminant (Typ);
-               while Present (Discriminant) loop
-                  Comp_Expr :=
-                    Make_Selected_Component (Loc,
-                      Prefix        => New_Copy_Tree (Target),
-                      Selector_Name => New_Occurrence_Of (Discriminant, Loc));
-
-                  Discriminant_Value :=
-                    Get_Discriminant_Value
-                      (Discriminant,
-                       N_Typ,
-                       Discriminant_Constraint (N_Typ));
-
-                  Instr :=
-                    Make_OK_Assignment_Statement (Loc,
-                      Name       => Comp_Expr,
-                      Expression => New_Copy_Tree (Discriminant_Value));
+            Init_Visible_Discriminants;
 
-                  Set_No_Ctrl_Actions (Instr);
-                  Append_To (L, Instr);
-
-                  Next_Stored_Discriminant (Discriminant);
-               end loop;
-            end;
+            if Is_Derived_Type (N_Typ) then
+               Init_Stored_Discriminants;
+            end if;
          end if;
       end if;
 

diff --git a/gcc/ada/sem_attr.ads b/gcc/ada/sem_attr.ads
index a8fa47139ec6f660d59cae67a267d942b8d7d20e..b3c30183883c82a852192303a7a7d10247a034b6 100644 (file)
--- a/gcc/ada/sem_attr.ads
+++ b/gcc/ada/sem_attr.ads
@@ -605,6 +605,44 @@ package Sem_Attr is
 
       others => False);
 
+   --  The following table lists all attributes that yield a result of a
+   --  universal type.
+
+   Universal_Type_Attribute : constant array (Attribute_Id) of Boolean :=
+     (Attribute_Aft                          => True,
+      Attribute_Alignment                    => True,
+      Attribute_Component_Size               => True,
+      Attribute_Count                        => True,
+      Attribute_Delta                        => True,
+      Attribute_Digits                       => True,
+      Attribute_Exponent                     => True,
+      Attribute_First_Bit                    => True,
+      Attribute_Fore                         => True,
+      Attribute_Last_Bit                     => True,
+      Attribute_Length                       => True,
+      Attribute_Machine_Emax                 => True,
+      Attribute_Machine_Emin                 => True,
+      Attribute_Machine_Mantissa             => True,
+      Attribute_Machine_Radix                => True,
+      Attribute_Max_Alignment_For_Allocation => True,
+      Attribute_Max_Size_In_Storage_Elements => True,
+      Attribute_Model_Emin                   => True,
+      Attribute_Model_Epsilon                => True,
+      Attribute_Model_Mantissa               => True,
+      Attribute_Model_Small                  => True,
+      Attribute_Modulus                      => True,
+      Attribute_Pos                          => True,
+      Attribute_Position                     => True,
+      Attribute_Safe_First                   => True,
+      Attribute_Safe_Last                    => True,
+      Attribute_Scale                        => True,
+      Attribute_Size                         => True,
+      Attribute_Small                        => True,
+      Attribute_Wide_Wide_Width              => True,
+      Attribute_Wide_Width                   => True,
+      Attribute_Width                        => True,
+      others                                 => False);
+
    -----------------
    -- Subprograms --
    -----------------

diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb
index 4989409d67e670f24cce34e534be730e62b7271d..5f2722d06dfe323600d2fd2792402d3d2f1d5080 100644 (file)
--- a/gcc/ada/sem_util.adb
+++ b/gcc/ada/sem_util.adb
@@ -20962,8 +20962,6 @@ package body Sem_Util is
    ---------------------------
 
    function Yields_Universal_Type (N : Node_Id) return Boolean is
-      Nam : Name_Id;
-
    begin
       --  Integer and real literals are of a universal type
 
@@ -20973,41 +20971,8 @@ package body Sem_Util is
       --  The values of certain attributes are of a universal type
 
       elsif Nkind (N) = N_Attribute_Reference then
-         Nam := Attribute_Name (N);
-
          return
-           Nam = Name_Aft
-             or else Nam = Name_Alignment
-             or else Nam = Name_Component_Size
-             or else Nam = Name_Count
-             or else Nam = Name_Delta
-             or else Nam = Name_Digits
-             or else Nam = Name_Exponent
-             or else Nam = Name_First_Bit
-             or else Nam = Name_Fore
-             or else Nam = Name_Last_Bit
-             or else Nam = Name_Length
-             or else Nam = Name_Machine_Emax
-             or else Nam = Name_Machine_Emin
-             or else Nam = Name_Machine_Mantissa
-             or else Nam = Name_Machine_Radix
-             or else Nam = Name_Max_Alignment_For_Allocation
-             or else Nam = Name_Max_Size_In_Storage_Elements
-             or else Nam = Name_Model_Emin
-             or else Nam = Name_Model_Epsilon
-             or else Nam = Name_Model_Mantissa
-             or else Nam = Name_Model_Small
-             or else Nam = Name_Modulus
-             or else Nam = Name_Pos
-             or else Nam = Name_Position
-             or else Nam = Name_Safe_First
-             or else Nam = Name_Safe_Last
-             or else Nam = Name_Scale
-             or else Nam = Name_Size
-             or else Nam = Name_Small
-             or else Nam = Name_Wide_Wide_Width
-             or else Nam = Name_Wide_Width
-             or else Nam = Name_Width;
+           Universal_Type_Attribute (Get_Attribute_Id (Attribute_Name (N)));
 
       --  ??? There are possibly other cases to consider