[Ada] Fix compiler crash for tagged private types

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

gcc/ada/

	* sem_util.ads, sem_util.adb (Find_Primitive_Eq): New subprogram.
	* exp_ch4.adb (Expand_Composite_Equality): Use the new subprogram
	Find_Primitive_Eq to search for the primitive of types whose underlying
	type is a tagged type.

gcc/testsuite/

	* gnat.dg/tagged1.adb, gnat.dg/tagged1.ads: New testcase.

From-SVN: r260997

gcc/ada/ChangeLog

+2018-05-31  Javier Miranda  <miranda@adacore.com>
+
+	* sem_util.ads, sem_util.adb (Find_Primitive_Eq): New subprogram.
+	* exp_ch4.adb (Expand_Composite_Equality): Use the new subprogram
+	Find_Primitive_Eq to search for the primitive of types whose underlying
+	type is a tagged type.
+
 2018-05-31  Yannick Moy  <moy@adacore.com>
 
 	* sem_prag.adb (Analyze_Pragma.Check_Loop_Pragma_Placement): Inverse

gcc/ada/exp_ch4.adb

@@ -2335,7 +2335,6 @@ package body Exp_Ch4 is
    is
       Loc       : constant Source_Ptr := Sloc (Nod);
       Full_Type : Entity_Id;
-      Prim      : Elmt_Id;
       Eq_Op     : Entity_Id;
 
       function Find_Primitive_Eq return Node_Id;
@@ -2481,36 +2480,8 @@ package body Exp_Ch4 is
       --  Case of tagged record types
 
       elsif Is_Tagged_Type (Full_Type) then
-
-         --  Call the primitive operation "=" of this type
-
-         if Is_Class_Wide_Type (Full_Type) then
-            Full_Type := Root_Type (Full_Type);
-         end if;
-
-         --  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));
-         end if;
-
-         loop
-            Eq_Op := Node (Prim);
-            exit when Chars (Eq_Op) = Name_Op_Eq
-              and then Etype (First_Formal (Eq_Op)) =
-                       Etype (Next_Formal (First_Formal (Eq_Op)))
-              and then Base_Type (Etype (Eq_Op)) = Standard_Boolean;
-            Next_Elmt (Prim);
-            pragma Assert (Present (Prim));
-         end loop;
-
-         Eq_Op := Node (Prim);
+         Eq_Op := Find_Primitive_Eq (Typ);
+         pragma Assert (Present (Eq_Op));
 
          return
            Make_Function_Call (Loc,

gcc/ada/sem_util.adb

@@ -8325,6 +8325,93 @@ package body Sem_Util is
       end loop;
    end Find_Placement_In_State_Space;
 
+   -----------------------
+   -- Find_Primitive_Eq --
+   -----------------------
+
+   function Find_Primitive_Eq (Typ : Entity_Id) return Entity_Id is
+      function Find_Eq_Prim (Prims_List : Elist_Id) return Entity_Id;
+      --  Search for the equality primitive; return Empty if the primitive is
+      --  not found.
+
+      function Find_Eq_Prim (Prims_List : Elist_Id) return Entity_Id is
+         Prim_E : Elmt_Id := First_Elmt (Prims_List);
+         Prim   : Entity_Id;
+
+      begin
+         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 Base_Type (Etype (Prim)) = Standard_Boolean
+            then
+               return Prim;
+            end if;
+
+            Next_Elmt (Prim_E);
+         end loop;
+
+         return Empty;
+      end Find_Eq_Prim;
+
+      --  Local Variables
+
+      Full_Type : Entity_Id;
+      Eq_Prim   : Entity_Id;
+
+   --  Start of processing for Find_Primitive_Eq
+
+   begin
+      if Is_Private_Type (Typ) then
+         Full_Type := Underlying_Type (Typ);
+      else
+         Full_Type := Typ;
+      end if;
+
+      if No (Full_Type) then
+         return Empty;
+      end if;
+
+      Full_Type := Base_Type (Full_Type);
+
+      --  When the base type itself is private, use the full view
+
+      if Is_Private_Type (Full_Type) then
+         Full_Type := Underlying_Type (Full_Type);
+      end if;
+
+      if Is_Class_Wide_Type (Full_Type) then
+         Full_Type := Root_Type (Full_Type);
+      end if;
+
+      if not Is_Tagged_Type (Full_Type) then
+         Eq_Prim := Find_Eq_Prim (Collect_Primitive_Operations (Typ));
+
+      --  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 no equality was
+      --  defined for it then take its dispatching equality primitive.
+
+      elsif Inherits_From_Tagged_Full_View (Typ) then
+         Eq_Prim := Find_Eq_Prim (Collect_Primitive_Operations (Typ));
+
+         if No (Eq_Prim) then
+            Eq_Prim := Find_Eq_Prim (Primitive_Operations (Full_Type));
+         end if;
+
+      else
+         Eq_Prim := Find_Eq_Prim (Primitive_Operations (Full_Type));
+      end if;
+
+      return Eq_Prim;
+   end Find_Primitive_Eq;
+
    ------------------------
    -- Find_Specific_Type --
    ------------------------

gcc/ada/sem_util.ads

@@ -877,6 +877,10 @@ package Sem_Util is
    --  If the state space is that of a package, Pack_Id denotes its entity,
    --  otherwise Pack_Id is Empty.
 
+   function Find_Primitive_Eq (Typ : Entity_Id) return Entity_Id;
+   --  Locate primitive equality for type if it exists. Return Empty if it is
+   --  not available.
+
    function Find_Specific_Type (CW : Entity_Id) return Entity_Id;
    --  Find specific type of a class-wide type, and handle the case of an
    --  incomplete type coming either from a limited_with clause or from an

gcc/testsuite/ChangeLog

+2018-05-31  Javier Miranda  <miranda@adacore.com>
+
+	* gnat.dg/tagged1.adb, gnat.dg/tagged1.ads: New testcase.
+
 2018-05-31  Sameera Deshpande  <sameera.deshpande@linaro.org>
 
 	* gcc.target/aarch64/advsimd-intrinsics/vld1x3.c: New test for

gcc/testsuite/gnat.dg/tagged1.adb

+--  { dg-do compile }
+
+package body Tagged1 is
+   procedure Dummy is null;
+end Tagged1;

gcc/testsuite/gnat.dg/tagged1.ads

+with Ada.Containers.Vectors;
+with Ada.Containers;
+with Ada.Finalization;
+
+package Tagged1 is
+
+   generic
+      type Target_Type (<>) is limited private;
+   package A is
+      type Smart_Pointer_Type is private;
+   private
+      type Smart_Pointer_Type
+        is new Ada.Finalization.Controlled with null record;
+   end;
+
+   generic
+      type Target_Type (<>) is limited private;
+   package SP is
+      type Smart_Pointer_Type is private;
+   private
+      package S is new A (Integer);
+      type Smart_Pointer_Type is new S.Smart_Pointer_Type;
+   end;
+
+   type Root_Type is tagged record
+      Orders : Integer;
+   end record;
+   package Smarts is new SP
+     (Target_Type => Root_Type'Class);
+
+   type Fat_Reference_Type is new Smarts.Smart_Pointer_Type;
+   type EST is record
+      Orders : Fat_Reference_Type;
+   end record;
+
+   package V is new Ada.Containers.Vectors (Positive, EST);
+
+   procedure Dummy;
+end;