exp_ch3.adb (Build_Variant_Record_Equality): Add pairs of formals for each discriminant of an unchecked union.

2013-07-05  Ed Schonberg  <schonberg@adacore.com>

	* exp_ch3.adb (Build_Variant_Record_Equality): Add pairs of
	formals for each discriminant of an unchecked union.
	(Make_Eq_Case): Suprogram accepts a list of discriminants. Nested
	variants are supported. New helper function Corresponding_Formal.
	* exp_ch4.adb (Build_Equality_Call): For unchecked unions,
	loop through discriminants to create list of inferred values,
	and modify call to equality routine accordingly.

From-SVN: r200709

3 files changed, 241 insertions, 105 deletions

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 1c3bbab..24b3fd2 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,13 @@
+2013-07-05  Ed Schonberg  <schonberg@adacore.com>
+
+	* exp_ch3.adb (Build_Variant_Record_Equality): Add pairs of
+	formals for each discriminant of an unchecked union.
+	(Make_Eq_Case): Suprogram accepts a list of discriminants. Nested
+	variants are supported. New helper function Corresponding_Formal.
+	* exp_ch4.adb (Build_Equality_Call): For unchecked unions,
+	loop through discriminants to create list of inferred values,
+	and modify call to equality routine accordingly.
+
 2013-07-05  Claire Dross  <dross@adacore.com>
 
 	* a-cfdlli.ads, a-cfhama.ads, a-cfhase.ads, a-cforma.ads,
diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb
index 1e50036..4491d30 100644
--- a/gcc/ada/exp_ch3.adb
+++ b/gcc/ada/exp_ch3.adb
@@ -237,16 +237,19 @@ package body Exp_Ch3 is
    --  user-defined equality. Factored out of Predefined_Primitive_Bodies.
 
    function Make_Eq_Case
-     (E     : Entity_Id;
-      CL    : Node_Id;
-      Discr : Entity_Id := Empty) return List_Id;
+     (E      : Entity_Id;
+      CL     : Node_Id;
+      Discrs : Elist_Id := New_Elmt_List) return List_Id;
    --  Building block for variant record equality. Defined to share the code
    --  between the tagged and non-tagged case. Given a Component_List node CL,
    --  it generates an 'if' followed by a 'case' statement that compares all
    --  components of local temporaries named X and Y (that are declared as
    --  formals at some upper level). E provides the Sloc to be used for the
-   --  generated code. Discr is used as the case statement switch in the case
-   --  of Unchecked_Union equality.
+   --  generated code.
+   --
+   --  IF E is an unchecked_union,  Discrs is the list of formals created for
+   --  the inferred discriminants of one operand. These formals are used in
+   --  the generated case statements for each variant of the unchecked union.
 
    function Make_Eq_If
      (E : Entity_Id;
@@ -4335,8 +4338,7 @@ package body Exp_Ch3 is
               Result_Definition => New_Reference_To (Standard_Boolean, Loc)),
           Declarations               => New_List,
           Handled_Statement_Sequence =>
-            Make_Handled_Sequence_Of_Statements (Loc,
-              Statements => Stmts)));
+            Make_Handled_Sequence_Of_Statements (Loc, Statements => Stmts)));
 
       Append_To (Pspecs,
         Make_Parameter_Specification (Loc,
@@ -4350,57 +4352,71 @@ package body Exp_Ch3 is
 
       --  Unchecked_Unions require additional machinery to support equality.
       --  Two extra parameters (A and B) are added to the equality function
-      --  parameter list in order to capture the inferred values of the
-      --  discriminants in later calls.
+      --  parameter list for each discriminant of the type, in order to
+      --  capture the inferred values of the discriminants in equality calls.
+      --  The names of the parameters match the names of the corresponding
+      --  discriminant, with an added suffix.
 
       if Is_Unchecked_Union (Typ) then
          declare
-            Discr_Type : constant Node_Id := Etype (First_Discriminant (Typ));
+            Discr      : Entity_Id;
+            Discr_Type : Entity_Id;
+            A, B       : Entity_Id;
+            New_Discrs : Elist_Id;
 
-            A : constant Node_Id :=
-                  Make_Defining_Identifier (Loc,
-                    Chars => Name_A);
+         begin
+            New_Discrs := New_Elmt_List;
 
-            B : constant Node_Id :=
-                  Make_Defining_Identifier (Loc,
-                    Chars => Name_B);
+            Discr := First_Discriminant (Typ);
+            while Present (Discr) loop
+               Discr_Type := Etype (Discr);
+               A := Make_Defining_Identifier (Loc,
+                      Chars => New_External_Name (Chars (Discr), 'A'));
 
-         begin
-            --  Add A and B to the parameter list
+               B := Make_Defining_Identifier (Loc,
+                      Chars => New_External_Name (Chars (Discr), 'B'));
 
-            Append_To (Pspecs,
-              Make_Parameter_Specification (Loc,
-                Defining_Identifier => A,
-                Parameter_Type => New_Reference_To (Discr_Type, Loc)));
+               --  Add new parameters to the parameter list
 
-            Append_To (Pspecs,
-              Make_Parameter_Specification (Loc,
-                Defining_Identifier => B,
-                Parameter_Type => New_Reference_To (Discr_Type, Loc)));
+               Append_To (Pspecs,
+                 Make_Parameter_Specification (Loc,
+                   Defining_Identifier => A,
+                   Parameter_Type      => New_Reference_To (Discr_Type, Loc)));
 
-            --  Generate the following header code to compare the inferred
-            --  discriminants:
+               Append_To (Pspecs,
+                 Make_Parameter_Specification (Loc,
+                   Defining_Identifier => B,
+                   Parameter_Type      => New_Reference_To (Discr_Type, Loc)));
 
-            --  if a /= b then
-            --     return False;
-            --  end if;
+               Append_Elmt (A, New_Discrs);
 
-            Append_To (Stmts,
-              Make_If_Statement (Loc,
-                Condition =>
-                  Make_Op_Ne (Loc,
-                    Left_Opnd => New_Reference_To (A, Loc),
-                    Right_Opnd => New_Reference_To (B, Loc)),
-                Then_Statements => New_List (
-                  Make_Simple_Return_Statement (Loc,
-                    Expression => New_Occurrence_Of (Standard_False, Loc)))));
+               --  Generate the following code to compare each of the inferred
+               --  discriminants:
+
+               --  if a /= b then
+               --     return False;
+               --  end if;
+
+               Append_To (Stmts,
+                 Make_If_Statement (Loc,
+                   Condition       =>
+                     Make_Op_Ne (Loc,
+                       Left_Opnd  => New_Reference_To (A, Loc),
+                       Right_Opnd => New_Reference_To (B, Loc)),
+                   Then_Statements => New_List (
+                     Make_Simple_Return_Statement (Loc,
+                       Expression =>
+                         New_Occurrence_Of (Standard_False, Loc)))));
+               Next_Discriminant (Discr);
+            end loop;
 
             --  Generate component-by-component comparison. Note that we must
-            --  propagate one of the inferred discriminant formals to act as
-            --  the case statement switch.
+            --  propagate the inferred discriminants formals to act as
+            --  the case statement switch. Their value is added when an
+            --  equality call on unchecked unions is expanded.
 
             Append_List_To (Stmts,
-              Make_Eq_Case (Typ, Comps, A));
+              Make_Eq_Case (Typ, Comps, New_Discrs));
          end;
 
       --  Normal case (not unchecked union)
@@ -8578,13 +8594,56 @@ package body Exp_Ch3 is
    function Make_Eq_Case
      (E     : Entity_Id;
       CL    : Node_Id;
-      Discr : Entity_Id := Empty) return List_Id
+      Discrs : Elist_Id := New_Elmt_List) return List_Id
    is
       Loc      : constant Source_Ptr := Sloc (E);
       Result   : constant List_Id    := New_List;
       Variant  : Node_Id;
       Alt_List : List_Id;
 
+      function Corresponding_Formal (C : Node_Id) return Entity_Id;
+      --  Given the discriminant that controls a given variant of an unchecked
+      --  union, find the formal of the equality function that carries the
+      --  inferred value of the discriminant.
+
+      function External_Name (E : Entity_Id) return Name_Id;
+      --  The value of a given discriminant is conveyed in the corresponding
+      --  formal parameter of the equality routine. The name of this formal
+      --  parameter carries a one-character suffix which is removed here.
+
+      --------------------------
+      -- Corresponding_Formal --
+      --------------------------
+
+      function Corresponding_Formal (C : Node_Id) return Entity_Id is
+         Discr : constant Entity_Id := Entity (Name (Variant_Part (C)));
+         Elm   : Elmt_Id;
+
+      begin
+         Elm := First_Elmt (Discrs);
+         while Present (Elm) loop
+            if Chars (Discr) = External_Name (Node (Elm)) then
+               return Node (Elm);
+            end if;
+            Next_Elmt (Elm);
+         end loop;
+
+         --  A formal of the proper name must be found
+
+         raise Program_Error;
+      end Corresponding_Formal;
+
+      -------------------
+      -- External_Name --
+      -------------------
+
+      function External_Name (E : Entity_Id) return Name_Id is
+      begin
+         Get_Name_String (Chars (E));
+         Name_Len := Name_Len - 1;
+         return Name_Find;
+      end External_Name;
+
    begin
       Append_To (Result, Make_Eq_If (E, Component_Items (CL)));
 
@@ -8604,18 +8663,21 @@ package body Exp_Ch3 is
          Append_To (Alt_List,
            Make_Case_Statement_Alternative (Loc,
              Discrete_Choices => New_Copy_List (Discrete_Choices (Variant)),
-             Statements => Make_Eq_Case (E, Component_List (Variant))));
+             Statements =>
+               Make_Eq_Case (E, Component_List (Variant), Discrs)));
 
          Next_Non_Pragma (Variant);
       end loop;
 
-      --  If we have an Unchecked_Union, use one of the parameters that
-      --  captures the discriminants.
+      --  If we have an Unchecked_Union, use one of the parameters of the
+      --  enclosing equality routine that captures the discriminant, to use
+      --  as the expression in the generated case statement.
 
       if Is_Unchecked_Union (E) then
          Append_To (Result,
            Make_Case_Statement (Loc,
-             Expression => New_Reference_To (Discr, Loc),
+             Expression =>
+               New_Reference_To (Corresponding_Formal (CL), Loc),
              Alternatives => Alt_List));
 
       else
diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb
index f4abc65..9b0fc02 100644
--- a/gcc/ada/exp_ch4.adb
+++ b/gcc/ada/exp_ch4.adb
@@ -6939,17 +6939,26 @@ package body Exp_Ch4 is
 
          if Is_Unchecked_Union (Op_Type) then
             declare
-               Lhs_Type      : constant Node_Id := Etype (L_Exp);
-               Rhs_Type      : constant Node_Id := Etype (R_Exp);
-               Lhs_Discr_Val : Node_Id;
-               Rhs_Discr_Val : Node_Id;
+               Lhs_Type : constant Node_Id := Etype (L_Exp);
+               Rhs_Type : constant Node_Id := Etype (R_Exp);
+
+               Lhs_Discr_Vals : Elist_Id;
+               --  List of inferred discriminant values for left operand.
+
+               Rhs_Discr_Vals : Elist_Id;
+               --  List of inferred discriminant values for right operand.
+
+               Discr : Entity_Id;
 
             begin
+               Lhs_Discr_Vals := New_Elmt_List;
+               Rhs_Discr_Vals := New_Elmt_List;
+
                --  Per-object constrained selected components require special
                --  attention. If the enclosing scope of the component is an
                --  Unchecked_Union, we cannot reference its discriminants
-               --  directly. This is why we use the two extra parameters of
-               --  the equality function of the enclosing Unchecked_Union.
+               --  directly. This is why we use the extra parameters of the
+               --  equality function of the enclosing Unchecked_Union.
 
                --  type UU_Type (Discr : Integer := 0) is
                --     . . .
@@ -6976,7 +6985,8 @@ package body Exp_Ch4 is
 
                --  A and B are the formal parameters of the equality function
                --  of Enclosing_UU_Type. The function always has two extra
-               --  formals to capture the inferred discriminant values.
+               --  formals to capture the inferred discriminant values for
+               --  each discriminant of the type.
 
                --  2. Non-Unchecked_Union enclosing record:
 
@@ -7001,86 +7011,140 @@ package body Exp_Ch4 is
                --  In this case we can directly reference the discriminants of
                --  the enclosing record.
 
-               --  Lhs of equality
+               --  Process left operand of equality
 
                if Nkind (Lhs) = N_Selected_Component
                  and then
                    Has_Per_Object_Constraint (Entity (Selector_Name (Lhs)))
                then
-                  --  Enclosing record is an Unchecked_Union, use formal A
+                  --  If enclosing record is an Unchecked_Union, use formals
+                  --  corresponding to each discriminant. The name of the
+                  --  formal is that of the discriminant, with added suffix,
+                  --  see Exp_Ch3.Build_Record_Equality for details.
 
                   if Is_Unchecked_Union
                        (Scope (Entity (Selector_Name (Lhs))))
                   then
-                     Lhs_Discr_Val := Make_Identifier (Loc, Name_A);
+                     Discr :=
+                       First_Discriminant
+                         (Scope (Entity (Selector_Name (Lhs))));
+                     while Present (Discr) loop
+                        Append_Elmt (
+                          Make_Identifier (Loc,
+                            Chars => New_External_Name (Chars (Discr), 'A')),
+                          To => Lhs_Discr_Vals);
+                        Next_Discriminant (Discr);
+                     end loop;
 
-                  --  Enclosing record is of a non-Unchecked_Union type, it is
-                  --  possible to reference the discriminant.
+                  --  If enclosing record is of a non-Unchecked_Union type, it
+                  --  is possible to reference its discriminants directly.
 
                   else
-                     Lhs_Discr_Val :=
-                       Make_Selected_Component (Loc,
-                         Prefix => Prefix (Lhs),
-                         Selector_Name =>
-                           New_Copy
-                             (Get_Discriminant_Value
-                                (First_Discriminant (Lhs_Type),
-                                 Lhs_Type,
-                                 Stored_Constraint (Lhs_Type))));
+                     Discr := First_Discriminant (Lhs_Type);
+                     while Present (Discr) loop
+                        Append_Elmt (
+                          Make_Selected_Component (Loc,
+                            Prefix => Prefix (Lhs),
+                            Selector_Name =>
+                              New_Copy
+                                (Get_Discriminant_Value (Discr,
+                                    Lhs_Type,
+                                    Stored_Constraint (Lhs_Type)))),
+                          To => Lhs_Discr_Vals);
+                        Next_Discriminant (Discr);
+                     end loop;
                   end if;
 
-               --  Comment needed here ???
+               --  Otherwise operand is on object with a constrained type.
+               --  Infer the discriminant values from the constraint.
 
                else
-                  --  Infer the discriminant value
-
-                  Lhs_Discr_Val :=
-                    New_Copy
-                      (Get_Discriminant_Value
-                         (First_Discriminant (Lhs_Type),
-                          Lhs_Type,
-                          Stored_Constraint (Lhs_Type)));
+
+                  Discr := First_Discriminant (Lhs_Type);
+                  while Present (Discr) loop
+                     Append_Elmt (
+                       New_Copy
+                         (Get_Discriminant_Value (Discr,
+                             Lhs_Type,
+                             Stored_Constraint (Lhs_Type))),
+                       To => Lhs_Discr_Vals);
+                     Next_Discriminant (Discr);
+                  end loop;
                end if;
 
-               --  Rhs of equality
+               --  Similar processing for right operand of equality
 
                if Nkind (Rhs) = N_Selected_Component
                  and then
                    Has_Per_Object_Constraint (Entity (Selector_Name (Rhs)))
                then
                   if Is_Unchecked_Union
-                       (Scope (Entity (Selector_Name (Rhs))))
+                    (Scope (Entity (Selector_Name (Rhs))))
                   then
-                     Rhs_Discr_Val := Make_Identifier (Loc, Name_B);
+                     Discr :=
+                       First_Discriminant
+                         (Scope (Entity (Selector_Name (Rhs))));
+                     while Present (Discr) loop
+                        Append_Elmt (
+                          Make_Identifier (Loc,
+                            Chars => New_External_Name (Chars (Discr), 'B')),
+                          To => Rhs_Discr_Vals);
+                        Next_Discriminant (Discr);
+                     end loop;
 
                   else
-                     Rhs_Discr_Val :=
-                       Make_Selected_Component (Loc,
-                         Prefix => Prefix (Rhs),
-                         Selector_Name =>
-                           New_Copy (Get_Discriminant_Value (
-                             First_Discriminant (Rhs_Type),
-                             Rhs_Type,
-                             Stored_Constraint (Rhs_Type))));
-
+                     Discr := First_Discriminant (Rhs_Type);
+                     while Present (Discr) loop
+                        Append_Elmt (
+                          Make_Selected_Component (Loc,
+                            Prefix        => Prefix (Rhs),
+                            Selector_Name =>
+                              New_Copy (Get_Discriminant_Value
+                                          (Discr,
+                                           Rhs_Type,
+                                           Stored_Constraint (Rhs_Type)))),
+                          To => Rhs_Discr_Vals);
+                        Next_Discriminant (Discr);
+                     end loop;
                   end if;
-               else
-                  Rhs_Discr_Val :=
-                    New_Copy (Get_Discriminant_Value (
-                      First_Discriminant (Rhs_Type),
-                      Rhs_Type,
-                      Stored_Constraint (Rhs_Type)));
 
+               else
+                  Discr := First_Discriminant (Rhs_Type);
+                  while Present (Discr) loop
+                     Append_Elmt (
+                       New_Copy (Get_Discriminant_Value
+                                   (Discr,
+                                    Rhs_Type,
+                                    Stored_Constraint (Rhs_Type))),
+                       To => Rhs_Discr_Vals);
+                     Next_Discriminant (Discr);
+                  end loop;
                end if;
 
-               Rewrite (N,
-                 Make_Function_Call (Loc,
-                   Name => New_Reference_To (Eq, Loc),
-                   Parameter_Associations => New_List (
-                     L_Exp,
-                     R_Exp,
-                     Lhs_Discr_Val,
-                     Rhs_Discr_Val)));
+               --  Now merge the list of discriminant values so that values
+               --  of corresponding discriminants are adjacent.
+
+               declare
+                  Params : List_Id;
+                  L_Elmt : Elmt_Id;
+                  R_Elmt : Elmt_Id;
+
+               begin
+                  Params := New_List (L_Exp, R_Exp);
+                  L_Elmt := First_Elmt (Lhs_Discr_Vals);
+                  R_Elmt := First_Elmt (Rhs_Discr_Vals);
+                  while Present (L_Elmt) loop
+                     Append_To (Params, Node (L_Elmt));
+                     Append_To (Params, Node (R_Elmt));
+                     Next_Elmt (L_Elmt);
+                     Next_Elmt (R_Elmt);
+                  end loop;
+
+                  Rewrite (N,
+                    Make_Function_Call (Loc,
+                      Name                   => New_Reference_To (Eq, Loc),
+                      Parameter_Associations => Params));
+               end;
             end;
 
          --  Normal case, not an unchecked union
@@ -7088,7 +7152,7 @@ package body Exp_Ch4 is
          else
             Rewrite (N,
               Make_Function_Call (Loc,
-                Name => New_Reference_To (Eq, Loc),
+                Name                   => New_Reference_To (Eq, Loc),
                 Parameter_Associations => New_List (L_Exp, R_Exp)));
          end if;