[Ada] Crash on tagged equality

This patch corrects the retrieval of the equality function when it is
inherited from a parent tagged type.

2018-11-14  Hristian Kirtchev  <kirtchev@adacore.com>

gcc/ada/

	* exp_ch4.adb (Expand_N_Op_Eq): Remove duplicated code and use
	routine Find_Equality instead.
	(Find_Equality): New routine.

gcc/testsuite/

	* gnat.dg/equal4.adb, gnat.dg/equal4.ads,
	gnat.dg/equal4_controlled_filter.ads,
	gnat.dg/equal4_full_selector_filter.ads,
	gnat.dg/equal4_smart_pointers.ads: New testcase.

From-SVN: r266114

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index b1531d1c9282218e5cba653f0130287005da7544..cea73e9451f00ff1db8fdc418b4eb6315b5a92e9 100644 (file)
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,9 @@
+2018-11-14  Hristian Kirtchev  <kirtchev@adacore.com>
+
+       * exp_ch4.adb (Expand_N_Op_Eq): Remove duplicated code and use
+       routine Find_Equality instead.
+       (Find_Equality): New routine.
+
 2018-11-14  Piotr Trojanek  <trojanek@adacore.com>
 
        * sem_util.adb (First_From_Global_List): Do not expect

diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb
index 98c1d31753408afa1f3f229cf2360c2ff818fa54..079d64544a871a4549246db7122a8d97c6530bc6 100644 (file)
--- a/gcc/ada/exp_ch4.adb
+++ b/gcc/ada/exp_ch4.adb
@@ -7298,16 +7298,16 @@ package body Exp_Ch4 is
       Bodies : constant List_Id    := New_List;
       A_Typ  : constant Entity_Id  := Etype (Lhs);
 
-      Typl    : Entity_Id := A_Typ;
-      Op_Name : Entity_Id;
-      Prim    : Elmt_Id;
-
       procedure Build_Equality_Call (Eq : Entity_Id);
       --  If a constructed equality exists for the type or for its parent,
       --  build and analyze call, adding conversions if the operation is
       --  inherited.
 
-      function Has_Unconstrained_UU_Component (Typ : Node_Id) return Boolean;
+      function Find_Equality (Prims : Elist_Id) return Entity_Id;
+      --  Find a primitive equality function within primitive operation list
+      --  Prims.
+
+      function Has_Unconstrained_UU_Component (Typ : Entity_Id) return Boolean;
       --  Determines whether a type has a subcomponent of an unconstrained
       --  Unchecked_Union subtype. Typ is a record type.
 
@@ -7456,7 +7456,6 @@ package body Exp_Ch4 is
                --  Infer the discriminant values from the constraint.
 
                else
-
                   Discr := First_Discriminant (Lhs_Type);
                   while Present (Discr) loop
                      Append_Elmt
@@ -7556,12 +7555,70 @@ package body Exp_Ch4 is
          Analyze_And_Resolve (N, Standard_Boolean, Suppress => All_Checks);
       end Build_Equality_Call;
 
+      -------------------
+      -- Find_Equality --
+      -------------------
+
+      function Find_Equality (Prims : Elist_Id) return Entity_Id is
+         Formal_1  : Entity_Id;
+         Formal_2  : Entity_Id;
+         Prim      : Entity_Id;
+         Prim_Elmt : Elmt_Id;
+
+      begin
+         --  Assume that the tagged type lacks an equality
+
+         Prim := Empty;
+
+         --  Inspect the list of primitives looking for a suitable equality
+
+         Prim_Elmt := First_Elmt (Prims);
+         while Present (Prim_Elmt) loop
+
+            --  Traverse a potential chain of derivations to recover the parent
+            --  equality.
+
+            Prim := Ultimate_Alias (Node (Prim_Elmt));
+
+            --  The current primitives denotes function "=" that returns a
+            --  Boolean. This could be the suitable equality if the formal
+            --  parameters agree.
+
+            if Ekind (Prim) = E_Function
+              and then Chars (Prim) = Name_Op_Eq
+              and then Base_Type (Etype (Prim)) = Standard_Boolean
+            then
+               Formal_1 := First_Formal (Prim);
+               Formal_2 := Empty;
+
+               if Present (Formal_1) then
+                  Formal_2 := Next_Formal (Formal_1);
+               end if;
+
+               if Present (Formal_1)
+                 and then Present (Formal_2)
+                 and then Etype (Formal_1) = Etype (Formal_2)
+               then
+                  exit;
+               end if;
+            end if;
+
+            Next_Elmt (Prim_Elmt);
+         end loop;
+
+         --  A tagged type should have an equality in its list of primitives
+
+         pragma Assert (Present (Prim));
+
+         return Prim;
+      end Find_Equality;
+
       ------------------------------------
       -- Has_Unconstrained_UU_Component --
       ------------------------------------
 
       function Has_Unconstrained_UU_Component
-        (Typ : Node_Id) return Boolean
+        (Typ : Entity_Id) return Boolean
       is
          Tdef  : constant Node_Id :=
                    Type_Definition (Declaration_Node (Base_Type (Typ)));
@@ -7697,6 +7754,10 @@ package body Exp_Ch4 is
          return False;
       end Has_Unconstrained_UU_Component;
 
+      --  Local variables
+
+      Typl : Entity_Id;
+
    --  Start of processing for Expand_N_Op_Eq
 
    begin
@@ -7704,12 +7765,13 @@ package body Exp_Ch4 is
 
       --  Deal with private types
 
+      Typl := A_Typ;
+
       if Ekind (Typl) = E_Private_Type then
          Typl := Underlying_Type (Typl);
+
       elsif Ekind (Typl) = E_Private_Subtype then
          Typl := Underlying_Type (Base_Type (Typl));
-      else
-         null;
       end if;
 
       --  It may happen in error situations that the underlying type is not
@@ -7851,25 +7913,8 @@ package body Exp_Ch4 is
             --  primitive may have been overridden in its untagged full view).
 
             if Inherits_From_Tagged_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.
-
-               Prim := First_Elmt (Collect_Primitive_Operations (A_Typ));
-
-               while Present (Prim) loop
-                  exit when Chars (Node (Prim)) = Name_Op_Eq
-                    and then Etype (First_Formal (Node (Prim))) =
-                             Etype (Next_Formal (First_Formal (Node (Prim))))
-                    and then
-                      Base_Type (Etype (Node (Prim))) = Standard_Boolean;
-
-                  Next_Elmt (Prim);
-               end loop;
-
-               pragma Assert (Present (Prim));
-               Op_Name := Node (Prim);
+               Build_Equality_Call
+                 (Find_Equality (Collect_Primitive_Operations (A_Typ)));
 
             --  Find the type's predefined equality or an overriding
             --  user-defined equality. The reason for not simply calling
@@ -7883,23 +7928,10 @@ package body Exp_Ch4 is
                   Typl := Find_Specific_Type (Typl);
                end if;
 
-               Prim := First_Elmt (Primitive_Operations (Typl));
-               while Present (Prim) loop
-                  exit when Chars (Node (Prim)) = Name_Op_Eq
-                    and then Etype (First_Formal (Node (Prim))) =
-                             Etype (Next_Formal (First_Formal (Node (Prim))))
-                    and then
-                      Base_Type (Etype (Node (Prim))) = Standard_Boolean;
-
-                  Next_Elmt (Prim);
-               end loop;
-
-               pragma Assert (Present (Prim));
-               Op_Name := Node (Prim);
+               Build_Equality_Call
+                 (Find_Equality (Primitive_Operations (Typl)));
             end if;
 
-            Build_Equality_Call (Op_Name);
-
          --  Ada 2005 (AI-216): Program_Error is raised when evaluating the
          --  predefined equality operator for a type which has a subcomponent
          --  of an Unchecked_Union type whose nominal subtype is unconstrained.
@@ -7967,22 +7999,9 @@ package body Exp_Ch4 is
          --  the root Super_String type.
 
          elsif Is_Bounded_String (Typl) then
-            Prim :=
-              First_Elmt (Collect_Primitive_Operations (Root_Type (Typl)));
-
-            while Present (Prim) loop
-               exit when Chars (Node (Prim)) = Name_Op_Eq
-                 and then Etype (First_Formal (Node (Prim))) =
-                          Etype (Next_Formal (First_Formal (Node (Prim))))
-                 and then Base_Type (Etype (Node (Prim))) = Standard_Boolean;
-
-               Next_Elmt (Prim);
-            end loop;
-
-            --  A Super_String type should always have a primitive equality
-
-            pragma Assert (Present (Prim));
-            Build_Equality_Call (Node (Prim));
+            Build_Equality_Call
+              (Find_Equality
+                (Collect_Primitive_Operations (Root_Type (Typl))));
 
          --  Otherwise expand the component by component equality. Note that
          --  we never use block-bit comparisons for records, because of the

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 5536abd8401afb8bb4e10cb043c78f951913f7ca..43bfc8a78a4e61b78fa9ae6f49aad4f5ac948033 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,10 @@
+2018-11-14  Hristian Kirtchev  <kirtchev@adacore.com>
+
+       * gnat.dg/equal4.adb, gnat.dg/equal4.ads,
+       gnat.dg/equal4_controlled_filter.ads,
+       gnat.dg/equal4_full_selector_filter.ads,
+       gnat.dg/equal4_smart_pointers.ads: New testcase.
+
 2018-11-14  Piotr Trojanek  <trojanek@adacore.com>
 
        * gnat.dg/generic_actuals.adb: New testcase.

diff --git a/gcc/testsuite/gnat.dg/equal4.adb b/gcc/testsuite/gnat.dg/equal4.adb
new file mode 100644 (file)
index 0000000..9c68617
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/equal4.adb
@@ -0,0 +1,12 @@
+--  { dg-do compile }
+
+package body Equal4 is
+   procedure Compare (Obj : Equal4_Full_Selector_Filter.Object_T) is
+      use type Equal4_Full_Selector_Filter.Object_T;
+
+   begin
+      if Obj = Equal4_Full_Selector_Filter.True then
+         null;
+      end if;
+   end Compare;
+end Equal4;

diff --git a/gcc/testsuite/gnat.dg/equal4.ads b/gcc/testsuite/gnat.dg/equal4.ads
new file mode 100644 (file)
index 0000000..0bc2113
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/equal4.ads
@@ -0,0 +1,5 @@
+with Equal4_Full_Selector_Filter;
+
+package Equal4 is
+   procedure Compare (Obj : Equal4_Full_Selector_Filter.Object_T);
+end Equal4;

diff --git a/gcc/testsuite/gnat.dg/equal4_controlled_filter.ads b/gcc/testsuite/gnat.dg/equal4_controlled_filter.ads
new file mode 100644 (file)
index 0000000..d7f1dd4
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/equal4_controlled_filter.ads
@@ -0,0 +1,13 @@
+with Equal4_Smart_Pointers;
+
+generic
+package Equal4_Controlled_Filter is
+   type Object_T is private;
+
+   function True return Object_T;
+
+private
+   package Smart is new Equal4_Smart_Pointers;
+
+   type Object_T is new Smart.Pointer;
+end Equal4_Controlled_Filter;

diff --git a/gcc/testsuite/gnat.dg/equal4_full_selector_filter.ads b/gcc/testsuite/gnat.dg/equal4_full_selector_filter.ads
new file mode 100644 (file)
index 0000000..106df5b
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/equal4_full_selector_filter.ads
@@ -0,0 +1,7 @@
+with Equal4_Controlled_Filter;
+
+package Equal4_Full_Selector_Filter is
+   package Equal4_Controlled_Filter_Instance is new Equal4_Controlled_Filter;
+
+   type Object_T is new Equal4_Controlled_Filter_Instance.Object_T;
+end Equal4_Full_Selector_Filter;

diff --git a/gcc/testsuite/gnat.dg/equal4_smart_pointers.ads b/gcc/testsuite/gnat.dg/equal4_smart_pointers.ads
new file mode 100644 (file)
index 0000000..c5e03f5
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/equal4_smart_pointers.ads
@@ -0,0 +1,11 @@
+with Ada.Finalization;
+
+generic
+package Equal4_Smart_Pointers is
+   type Pointer is private;
+
+private
+   type Pointer is new Ada.Finalization.Controlled with record
+      Data : Integer;
+   end record;
+end Equal4_Smart_Pointers;