[Ada] Bug in composition of equality for variant records

This patch fixes an omission in the construction of equality routines
for variant records, to take into account user-defined equality
functions for components of the record. Previously the constructed
equality routine for variant records used the predefined equality for
all components, When composavility of equality was introduced for
untagged records, expansion of record equality was modified properly,
but not for the case of variant records, which use a different and more
complex process to build the equality function.

2019-07-04  Ed Schonberg  <schonberg@adacore.com>

gcc/ada/

	* exp_ch4.ads, exp_ch4.adb (Build_Eq_Call): New visible
	subprogram, extracted from Expand_Composite_Equality, to handle
	properly the composition of equality for variant record types.
	* exp_ch3.adb (MAke_Eq_If): Use Build_Eq_Call for each
	component, to handle properly the case of a component with a
	user-defined equality. Revert to predefined equality if the
	user-defined operation is abstract, to maintain compatibility
	with older versions,

gcc/testsuite/

	* gnat.dg/equal6.adb, gnat.dg/equal6_types.adb,
	gnat.dg/equal6_types.ads: New testcase.

From-SVN: r273062

gcc/ada/ChangeLog

+2019-07-04  Ed Schonberg  <schonberg@adacore.com>
+
+	* exp_ch4.ads, exp_ch4.adb (Build_Eq_Call): New visible
+	subprogram, extracted from Expand_Composite_Equality, to handle
+	properly the composition of equality for variant record types.
+	* exp_ch3.adb (MAke_Eq_If): Use Build_Eq_Call for each
+	component, to handle properly the case of a component with a
+	user-defined equality. Revert to predefined equality if the
+	user-defined operation is abstract, to maintain compatibility
+	with older versions,
+
 2019-07-04  Justin Squirek  <squirek@adacore.com>
 
 	* exp_ch3.adb (Build_Initialization_Call): Fixup

gcc/ada/exp_ch3.adb

@@ -9477,6 +9477,11 @@ package body Exp_Ch3 is
 
    --  or a null statement if the list L is empty
 
+   --  Equality may be user-defined for a given component type, in which case
+   --  a function call is constructed instead of an operator node. This is an
+   --  Ada 2012 change in the composability of equality for untagged composite
+   --  types.
+
    function Make_Eq_If
      (E : Entity_Id;
       L : List_Id) return Node_Id
@@ -9485,6 +9490,8 @@ package body Exp_Ch3 is
       C          : Node_Id;
       Field_Name : Name_Id;
       Cond       : Node_Id;
+      Next_Test  : Node_Id;
+      Typ        : Entity_Id;
 
    begin
       if No (L) then
@@ -9495,6 +9502,7 @@ package body Exp_Ch3 is
 
          C := First_Non_Pragma (L);
          while Present (C) loop
+            Typ        := Etype (Defining_Identifier (C));
             Field_Name := Chars (Defining_Identifier (C));
 
             --  The tags must not be compared: they are not part of the value.
@@ -9507,22 +9515,55 @@ package body Exp_Ch3 is
             --  discriminants could be picked up in the private type case.
 
             if Field_Name = Name_uParent
-              and then Is_Interface (Etype (Defining_Identifier (C)))
+              and then Is_Interface (Typ)
             then
                null;
 
             elsif Field_Name /= Name_uTag then
-               Evolve_Or_Else (Cond,
-                 Make_Op_Ne (Loc,
-                   Left_Opnd =>
-                     Make_Selected_Component (Loc,
-                       Prefix        => Make_Identifier (Loc, Name_X),
-                       Selector_Name => Make_Identifier (Loc, Field_Name)),
+               declare
+                  Lhs : constant Node_Id :=
+                    Make_Selected_Component (Loc,
+                      Prefix        => Make_Identifier (Loc, Name_X),
+                      Selector_Name => Make_Identifier (Loc, Field_Name));
 
-                   Right_Opnd =>
-                     Make_Selected_Component (Loc,
-                       Prefix        => Make_Identifier (Loc, Name_Y),
-                       Selector_Name => Make_Identifier (Loc, Field_Name))));
+                  Rhs : constant Node_Id :=
+                    Make_Selected_Component (Loc,
+                      Prefix        => Make_Identifier (Loc, Name_Y),
+                      Selector_Name => Make_Identifier (Loc, Field_Name));
+                  Eq_Call : Node_Id;
+
+               begin
+                  --  Build equality code with a user-defined operator, if
+                  --  available, and with the predefined "=" otherwise.
+                  --  For compatibility with older Ada versions, and preserve
+                  --  the workings of some ASIS tools, we also use the
+                  --  predefined operation if the component-type equality
+                  --  is abstract, rather than raising Program_Error.
+
+                  if Ada_Version < Ada_2012 then
+                     Next_Test := Make_Op_Ne (Loc, Lhs, Rhs);
+
+                  else
+                     Eq_Call := Build_Eq_Call (Typ, Loc, Lhs, Rhs);
+
+                     if No (Eq_Call) then
+                        Next_Test := Make_Op_Ne (Loc, Lhs, Rhs);
+
+                     --  If a component has a defined abstract equality,
+                     --  its application raises Program_Error on that
+                     --  component and therefore on the current variant.
+
+                     elsif Nkind (Eq_Call) = N_Raise_Program_Error then
+                        Set_Etype (Eq_Call, Standard_Boolean);
+                        Next_Test := Make_Op_Not (Loc, Eq_Call);
+
+                     else
+                        Next_Test := Make_Op_Not (Loc, Eq_Call);
+                     end if;
+                  end if;
+               end;
+
+               Evolve_Or_Else (Cond, Next_Test);
             end if;
 
             Next_Non_Pragma (C);

gcc/ada/exp_ch4.adb

@@ -2338,52 +2338,6 @@ package body Exp_Ch4 is
       Full_Type : Entity_Id;
       Eq_Op     : Entity_Id;
 
-      function Find_Primitive_Eq return Node_Id;
-      --  AI05-0123: Locate primitive equality for type if it exists, and
-      --  build the corresponding call. If operation is abstract, replace
-      --  call with an explicit raise. Return Empty if there is no primitive.
-
-      -----------------------
-      -- Find_Primitive_Eq --
-      -----------------------
-
-      function Find_Primitive_Eq return Node_Id is
-         Prim_E : Elmt_Id;
-         Prim   : Node_Id;
-
-      begin
-         Prim_E := First_Elmt (Collect_Primitive_Operations (Typ));
-         while Present (Prim_E) loop
-            Prim := Node (Prim_E);
-
-            --  Locate primitive equality with the right signature
-
-            if Chars (Prim) = Name_Op_Eq
-              and then Etype (First_Formal (Prim)) =
-                       Etype (Next_Formal (First_Formal (Prim)))
-              and then Etype (Prim) = Standard_Boolean
-            then
-               if Is_Abstract_Subprogram (Prim) then
-                  return
-                    Make_Raise_Program_Error (Loc,
-                      Reason => PE_Explicit_Raise);
-
-               else
-                  return
-                    Make_Function_Call (Loc,
-                      Name                   => New_Occurrence_Of (Prim, Loc),
-                      Parameter_Associations => New_List (Lhs, Rhs));
-               end if;
-            end if;
-
-            Next_Elmt (Prim_E);
-         end loop;
-
-         --  If not found, predefined operation will be used
-
-         return Empty;
-      end Find_Primitive_Eq;
-
    --  Start of processing for Expand_Composite_Equality
 
    begin
@@ -2654,7 +2608,7 @@ package body Exp_Ch4 is
             --  a primitive equality declared for it.
 
             declare
-               Op : constant Node_Id := Find_Primitive_Eq;
+               Op : constant Node_Id := Build_Eq_Call (Typ, Loc, Lhs, Rhs);
 
             begin
                --  Use user-defined primitive if it exists, otherwise use
@@ -12599,7 +12553,53 @@ package body Exp_Ch4 is
       Adjust_Result_Type (N, Typ);
    end Expand_Short_Circuit_Operator;
 
-   -------------------------------------
+   -----------------------
+   -- Build_Eq_Call --
+   -----------------------
+
+   function Build_Eq_Call
+     (Typ : Entity_Id;
+      Loc : Source_Ptr;
+      Lhs : Node_Id;
+      Rhs : Node_Id) return Node_Id
+   is
+      Prim_E : Elmt_Id;
+      Prim   : Node_Id;
+
+   begin
+      Prim_E := First_Elmt (Collect_Primitive_Operations (Typ));
+      while Present (Prim_E) loop
+         Prim := Node (Prim_E);
+
+         --  Locate primitive equality with the right signature
+
+         if Chars (Prim) = Name_Op_Eq
+           and then Etype (First_Formal (Prim)) =
+                    Etype (Next_Formal (First_Formal (Prim)))
+           and then Etype (Prim) = Standard_Boolean
+         then
+            if Is_Abstract_Subprogram (Prim) then
+               return
+                 Make_Raise_Program_Error (Loc,
+                   Reason => PE_Explicit_Raise);
+
+            else
+               return
+                 Make_Function_Call (Loc,
+                   Name                   => New_Occurrence_Of (Prim, Loc),
+                   Parameter_Associations => New_List (Lhs, Rhs));
+            end if;
+         end if;
+
+         Next_Elmt (Prim_E);
+      end loop;
+
+      --  If not found, predefined operation will be used
+
+      return Empty;
+   end Build_Eq_Call;
+
+   ------------------------------------
    -- Fixup_Universal_Fixed_Operation --
    -------------------------------------
 

gcc/ada/exp_ch4.ads

@@ -29,6 +29,20 @@ with Types; use Types;
 
 package Exp_Ch4 is
 
+   function Build_Eq_Call
+     (Typ : Entity_Id;
+      Loc : Source_Ptr;
+      Lhs : Node_Id;
+      Rhs : Node_Id) return Node_Id;
+   --  AI05-0123: Locate primitive equality for type if it exists, and build
+   --  the corresponding call. If operation is abstract, replace call with
+   --  an explicit raise. Return Empty if there is no primitive.
+   --  Used in the construction of record-equality routines for records here
+   --  and for variant records in exp_ch3.adb. These two paths are distinct
+   --  for historical but also technical reasons: for variant records the
+   --  constructed function includes a case statement with nested returns,
+   --  while for records without variants only a simple expression is needed.
+
    procedure Expand_N_Allocator                   (N : Node_Id);
    procedure Expand_N_And_Then                    (N : Node_Id);
    procedure Expand_N_Case_Expression             (N : Node_Id);

gcc/testsuite/ChangeLog

+2019-07-04  Ed Schonberg  <schonberg@adacore.com>
+
+	* gnat.dg/equal6.adb, gnat.dg/equal6_types.adb,
+	gnat.dg/equal6_types.ads: New testcase.
+
 2019-07-04  Justin Squirek  <squirek@adacore.com>
 
 	* gnat.dg/allocator.adb: New testcase.

gcc/testsuite/gnat.dg/equal6.adb

+--  { dg-do run }
+with Text_IO;
+with Equal6_Types; use Equal6_Types;
+
+procedure Equal6 is
+   Packets_In  : To_Evc_Optional_Packet_List_T;
+   Packets_Out : To_Evc_Optional_Packet_List_T;
+begin
+   Packets_In.list (1) :=
+     (Data_Used_Outside_Ertms_System =>
+        (Mail_Box    =>
+           (Receiver => 31,
+            Data     => (Length => 12, Message => (0, others => 0)))));
+
+   Packets_Out.list (1) :=
+     (Data_Used_Outside_Ertms_System =>
+        (Mail_Box    =>
+           (Receiver => 31,
+            Data     => (Length => 12, Message => (0, others => 1)))));
+
+   if not (Packets_In = Packets_Out) then
+      raise Program_Error;
+   end if;
+
+   if not (Equal1_Called and then Equal2_Called) then
+      raise Program_Error;
+   end if;
+
+end Equal6;

gcc/testsuite/gnat.dg/equal6_types.adb

+package body Equal6_Types is
+
+   function "=" (L, R : in Mail_Box_Data_T) return Boolean is
+      use type Bits_T;
+   begin
+      Equal1_Called := True;
+      return L.Message (1) = R.Message (1);
+   end "=";
+
+   function "=" (L, R : in To_Evc_Optional_Packet_List_T) return Boolean is
+   begin
+      Equal2_Called := True;
+      return L.List (1) = R.List (1);
+   end "=";
+end Equal6_Types;

gcc/testsuite/gnat.dg/equal6_types.ads

+package Equal6_Types is
+   type Bit_T is range 0 .. 1;
+
+   type Bits_T is array (Positive range <>) of Bit_T;
+
+   type Nid_Xuser_T is range 0 .. 511;
+
+   Dispatch_P44_To_Ntc_C : constant Nid_Xuser_T := 102;
+
+   type Mail_Box_Data_T is record
+      Length  : Natural;
+      Message : Bits_T (1 .. 200);
+   end record;
+   function "=" (L, R : in Mail_Box_Data_T) return Boolean;
+   Equal1_Called : Boolean := False;
+
+   type Mail_Box_T (Receiver : Nid_Xuser_T := Nid_Xuser_T'First) is record
+      Data : Mail_Box_Data_T;
+      case Receiver is
+         when Dispatch_P44_To_Ntc_C =>
+            Stm_Id : Positive;
+         when others =>
+            null;
+      end case;
+   end record;
+
+   type Data_Used_Outside_Ertms_System_T is record
+      Mail_Box    : Mail_Box_T;
+   end record;
+
+   type To_Evc_Optional_Packet_T
+   is record
+            Data_Used_Outside_Ertms_System : Data_Used_Outside_Ertms_System_T;
+   end record;
+
+   type To_Evc_Optional_Packet_List_Length_T is range 0 .. 50;
+   type To_Evc_Optional_Packet_Map_T is
+     array
+       (To_Evc_Optional_Packet_List_Length_T range <>)
+            of To_Evc_Optional_Packet_T;
+
+   type To_Evc_Optional_Packet_List_T is record
+      List : To_Evc_Optional_Packet_Map_T
+        (1 .. To_Evc_Optional_Packet_List_Length_T'Last);
+   end record;
+   function "=" (L, R : in To_Evc_Optional_Packet_List_T) return Boolean;
+   Equal2_Called : Boolean := False;
+
+end Equal6_Types;