[Ada] Wrong equality on untagged private type

When a private type declaration T1 is completed with a derivation of an
untagged private type that overrides the predefined equality primitive, and the
full view of T2 is a derivation of another private type T2 whose full view is a
tagged type, the compiler may generate code that references the wrong equality
primitive when processing comparisons of objects of type T1.

2018-05-29  Javier Miranda  <miranda@adacore.com>

gcc/ada/

	* exp_ch4.adb (Expand_N_Op_Eq, Expand_Composite_Equality): Use the new
	subprogram Inherits_From_Tagged_Full_View to identify more reliably
	untagged private types completed with a derivation of an untagged
	private whose full view is a tagged type.
	* sem_util.ads, sem_util.adb (Inherits_From_Tagged_Full_View): New
	subprogram.
	(Collect_Primitive_Operations): Handle untagged private types completed
	with a derivation of an untagged private type whose full view is a
	tagged type. In such case, collecting the list of primitives we may
	find two equality primitives: one associated with the untagged private
	and another associated with the ultimate tagged type (and we must
	remove from the returned list this latter one).

gcc/testsuite/

	* gnat.dg/equal2.adb: New testcase.

From-SVN: r260886

6 files changed, 160 insertions, 29 deletions

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index ec13550..1ad345e 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,18 @@
+2018-05-29  Javier Miranda  <miranda@adacore.com>
+
+	* exp_ch4.adb (Expand_N_Op_Eq, Expand_Composite_Equality): Use the new
+	subprogram Inherits_From_Tagged_Full_View to identify more reliably
+	untagged private types completed with a derivation of an untagged
+	private whose full view is a tagged type.
+	* sem_util.ads, sem_util.adb (Inherits_From_Tagged_Full_View): New
+	subprogram.
+	(Collect_Primitive_Operations): Handle untagged private types completed
+	with a derivation of an untagged private type whose full view is a
+	tagged type. In such case, collecting the list of primitives we may
+	find two equality primitives: one associated with the untagged private
+	and another associated with the ultimate tagged type (and we must
+	remove from the returned list this latter one).
+
 2018-05-29  Ed Schonberg  <schonberg@adacore.com>
 
 	* exp_unst.adb (Visit_Node): Handle statement sequences that include an
diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb
index 4cde820..bc50422 100644
--- a/gcc/ada/exp_ch4.adb
+++ b/gcc/ada/exp_ch4.adb
@@ -2488,17 +2488,13 @@ package body Exp_Ch4 is
             Full_Type := Root_Type (Full_Type);
          end if;
 
-         --  If this is derived from an untagged private type completed with a
-         --  tagged type, it does not have a full view, so we use the primitive
-         --  operations of the private type. This check should no longer be
-         --  necessary when these types receive their full views ???
-
-         if Is_Private_Type (Typ)
-           and then not Is_Tagged_Type (Typ)
-           and then not Is_Controlled (Typ)
-           and then Is_Derived_Type (Typ)
-           and then No (Full_View (Typ))
-         then
+         --  If this is an untagged private type completed with a derivation of
+         --  an untagged private type whose full view is a tagged type, we use
+         --  the primitive operations of the private parent type (since it does
+         --  not have a full view, and also because its equality primitive may
+         --  have been overridden in its untagged full view).
+
+         if Inherits_From_Tagged_Full_View (Typ) then
             Prim := First_Elmt (Collect_Primitive_Operations (Typ));
          else
             Prim := First_Elmt (Primitive_Operations (Full_Type));
@@ -7857,16 +7853,14 @@ package body Exp_Ch4 is
                return;
             end if;
 
-            --  If this is derived from an untagged private type completed with
-            --  a tagged type, it does not have a full view, so we use the
-            --  primitive operations of the private type. This check should no
-            --  longer be necessary when these types get their full views???
+            --  If this is an untagged private type completed with a derivation
+            --  of an untagged private type whose full view is a tagged type,
+            --  we use the primitive operations of the private type (since it
+            --  does not have a full view, and also because its equality
+            --  primitive may have been overridden in its untagged full view).
+
+            if Inherits_From_Tagged_Full_View (A_Typ) then
 
-            if Is_Private_Type (A_Typ)
-              and then not Is_Tagged_Type (A_Typ)
-              and then Is_Derived_Type (A_Typ)
-              and then No (Full_View (A_Typ))
-            then
                --  Search for equality operation, checking that the operands
                --  have the same type. Note that we must find a matching entry,
                --  or something is very wrong.
diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb
index 4cef1ba..ed66422 100644
--- a/gcc/ada/sem_util.adb
+++ b/gcc/ada/sem_util.adb
@@ -5084,15 +5084,7 @@ package body Sem_Util is
    ----------------------------------
 
    function Collect_Primitive_Operations (T : Entity_Id) return Elist_Id is
-      B_Type         : constant Entity_Id := Base_Type (T);
-      B_Decl         : constant Node_Id   := Original_Node (Parent (B_Type));
-      B_Scope        : Entity_Id          := Scope (B_Type);
-      Op_List        : Elist_Id;
-      Formal         : Entity_Id;
-      Is_Prim        : Boolean;
-      Is_Type_In_Pkg : Boolean;
-      Formal_Derived : Boolean := False;
-      Id             : Entity_Id;
+      B_Type : constant Entity_Id := Base_Type (T);
 
       function Match (E : Entity_Id) return Boolean;
       --  True if E's base type is B_Type, or E is of an anonymous access type
@@ -5120,6 +5112,18 @@ package body Sem_Util is
                and then Full_View (Etyp) = B_Type);
       end Match;
 
+      --  Local variables
+
+      B_Decl         : constant Node_Id := Original_Node (Parent (B_Type));
+      B_Scope        : Entity_Id        := Scope (B_Type);
+      Op_List        : Elist_Id;
+      Eq_Prims_List  : Elist_Id := No_Elist;
+      Formal         : Entity_Id;
+      Is_Prim        : Boolean;
+      Is_Type_In_Pkg : Boolean;
+      Formal_Derived : Boolean := False;
+      Id             : Entity_Id;
+
    --  Start of processing for Collect_Primitive_Operations
 
    begin
@@ -5268,6 +5272,22 @@ package body Sem_Util is
 
                   else
                      Append_Elmt (Id, Op_List);
+
+                     --  Save collected equality primitives for later filtering
+                     --  (if we are processing a private type for which we can
+                     --  collect several candidates).
+
+                     if Inherits_From_Tagged_Full_View (T)
+                       and then Chars (Id) = Name_Op_Eq
+                       and then Etype (First_Formal (Id)) =
+                                Etype (Next_Formal (First_Formal (Id)))
+                     then
+                        if No (Eq_Prims_List) then
+                           Eq_Prims_List := New_Elmt_List;
+                        end if;
+
+                        Append_Elmt (Id, Eq_Prims_List);
+                     end if;
                   end if;
                end if;
             end if;
@@ -5285,6 +5305,43 @@ package body Sem_Util is
                Id := First_Entity (System_Aux_Id);
             end if;
          end loop;
+
+         --  Filter collected equality primitives
+
+         if Inherits_From_Tagged_Full_View (T)
+           and then Present (Eq_Prims_List)
+         then
+            declare
+               First  : constant Elmt_Id := First_Elmt (Eq_Prims_List);
+               Second : Elmt_Id;
+
+            begin
+               pragma Assert (No (Next_Elmt (First))
+                 or else No (Next_Elmt (Next_Elmt (First))));
+
+               --  No action needed if we have collected a single equality
+               --  primitive
+
+               if Present (Next_Elmt (First)) then
+                  Second := Next_Elmt (First);
+
+                  if Is_Dispatching_Operation
+                       (Ultimate_Alias (Node (First)))
+                  then
+                     Remove (Op_List, Node (First));
+
+                  elsif Is_Dispatching_Operation
+                          (Ultimate_Alias (Node (Second)))
+                  then
+                     Remove (Op_List, Node (Second));
+
+                  else
+                     pragma Assert (False);
+                     raise Program_Error;
+                  end if;
+               end if;
+            end;
+         end if;
       end if;
 
       return Op_List;
@@ -12615,6 +12672,20 @@ package body Sem_Util is
       end if;
    end Inherit_Rep_Item_Chain;
 
+   ------------------------------------
+   -- Inherits_From_Tagged_Full_View --
+   ------------------------------------
+
+   function Inherits_From_Tagged_Full_View (Typ : Entity_Id) return Boolean is
+   begin
+      return Is_Private_Type (Typ)
+        and then Present (Full_View (Typ))
+        and then Is_Private_Type (Full_View (Typ))
+        and then not Is_Tagged_Type (Full_View (Typ))
+        and then Present (Underlying_Type (Full_View (Typ)))
+        and then Is_Tagged_Type (Underlying_Type (Full_View (Typ)));
+   end Inherits_From_Tagged_Full_View;
+
    ---------------------------------
    -- Insert_Explicit_Dereference --
    ---------------------------------
diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads
index 739a4d0..6cb7db8 100644
--- a/gcc/ada/sem_util.ads
+++ b/gcc/ada/sem_util.ads
@@ -1452,6 +1452,12 @@ package Sem_Util is
    --  Inherit the rep item chain of type From_Typ without clobbering any
    --  existing rep items on Typ's chain. Typ is the destination type.
 
+   function Inherits_From_Tagged_Full_View (Typ : Entity_Id) return Boolean;
+   pragma Inline (Inherits_From_Tagged_Full_View);
+   --  Return True if Typ is an untagged private type completed with a
+   --  derivation of an untagged private type declaration whose full view
+   --  is a tagged type.
+
    procedure Insert_Explicit_Dereference (N : Node_Id);
    --  In a context that requires a composite or subprogram type and where a
    --  prefix is an access type, rewrite the access type node N (which is the
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index bce064a..0305734 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,7 @@
+2018-05-29  Javier Miranda  <miranda@adacore.com>
+
+	* gnat.dg/equal2.adb: New testcase.
+
 2018-05-29  Ed Schonberg  <schonberg@adacore.com>
 
 	* gnat.dg/float_attributes_overflows.adb: New testcase.
diff --git a/gcc/testsuite/gnat.dg/equal2.adb b/gcc/testsuite/gnat.dg/equal2.adb
new file mode 100644
index 0000000..ca37177
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/equal2.adb
@@ -0,0 +1,41 @@
+--  { dg-do run }
+
+procedure Equal2 is
+
+   package L1 is
+      type T is private;
+      overriding function "=" (Left, Right : T) return Boolean;
+   private
+      type T is tagged record
+        I : Integer := 0;
+      end record;
+   end L1;
+
+   package L2 is
+      type T is private;
+   private
+      type T is new L1.T;
+      overriding function "=" (Left, Right : T) return Boolean;
+   end L2;
+
+   package body L1 is
+      overriding function "=" (Left, Right : T) return Boolean is
+      begin
+        return False;
+      end "=";
+   end L1;
+
+   package body L2 is
+      overriding function "=" (Left, Right : T) return Boolean is
+      begin
+        return True;
+      end "=";
+   end L2;
+
+   use type L2.T;
+   Left, Right : L2.T;
+begin
+   if Left /= Right then
+      raise Program_Error;
+   end if;
+end;