[Ada] Crash on interface equality covered by a renaming declaration

The frontend crashes processing a tagged type that implements an
interface which has an equality primitive (that is, "=") and covers such
primitive by means of a renaming declaration.

2018-11-14  Javier Miranda  <miranda@adacore.com>

gcc/ada/

	* exp_disp.adb (Expand_Interface_Thunk): Extend handling of
	renamings of the predefined equality primitive.
	(Make_Secondary_DT): When calling Expand_Interface_Thunk() pass
	it the primitive, instead of its Ultimate_Alias; required to
	allow the called routine to identify renamings of the predefined
	equality operation.

gcc/testsuite/

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

From-SVN: r266130

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 900d23a..7390a5c 100644 (file)
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,12 @@
+2018-11-14  Javier Miranda  <miranda@adacore.com>
+
+       * exp_disp.adb (Expand_Interface_Thunk): Extend handling of
+       renamings of the predefined equality primitive.
+       (Make_Secondary_DT): When calling Expand_Interface_Thunk() pass
+       it the primitive, instead of its Ultimate_Alias; required to
+       allow the called routine to identify renamings of the predefined
+       equality operation.
+
 2018-11-14  Hristian Kirtchev  <kirtchev@adacore.com>
 
        * freeze.adb (Check_Pragma_Thread_Local_Storage): New routine. A

diff --git a/gcc/ada/exp_disp.adb b/gcc/ada/exp_disp.adb
index f36cd1f..5a91249 100644 (file)
--- a/gcc/ada/exp_disp.adb
+++ b/gcc/ada/exp_disp.adb
@@ -1828,6 +1828,9 @@ package body Exp_Disp is
       Formal        : Node_Id;
       Ftyp          : Entity_Id;
       Iface_Formal  : Node_Id := Empty;  -- initialize to prevent warning
+      Is_Predef_Op  : constant Boolean :=
+                        Is_Predefined_Dispatching_Operation (Prim)
+                          or else Is_Predefined_Dispatching_Operation (Target);
       New_Arg       : Node_Id;
       Offset_To_Top : Node_Id;
       Target_Formal : Entity_Id;
@@ -1838,7 +1841,7 @@ package body Exp_Disp is
 
       --  No thunk needed if the primitive has been eliminated
 
-      if Is_Eliminated (Ultimate_Alias (Prim)) then
+      if Is_Eliminated (Target) then
          return;
 
       --  In case of primitives that are functions without formals and a
@@ -1859,9 +1862,10 @@ package body Exp_Disp is
       --  actual object) generate code that modify its contents.
 
       --  Note: This special management is not done for predefined primitives
-      --  because???
+      --  because they don't have available the Interface_Alias attribute (see
+      --  Sem_Ch3.Add_Internal_Interface_Entities).
 
-      if not Is_Predefined_Dispatching_Operation (Prim) then
+      if not Is_Predef_Op then
          Iface_Formal := First_Formal (Interface_Alias (Prim));
       end if;
 
@@ -1872,9 +1876,7 @@ package body Exp_Disp is
          --  Use the interface type as the type of the controlling formal (see
          --  comment above).
 
-         if not Is_Controlling_Formal (Formal)
-           or else Is_Predefined_Dispatching_Operation (Prim)
-         then
+         if not Is_Controlling_Formal (Formal) or else Is_Predef_Op then
             Ftyp := Etype (Formal);
             Expr := New_Copy_Tree (Expression (Parent (Formal)));
          else
@@ -1892,7 +1894,7 @@ package body Exp_Disp is
              Parameter_Type => New_Occurrence_Of (Ftyp, Loc),
              Expression => Expr));
 
-         if not Is_Predefined_Dispatching_Operation (Prim) then
+         if not Is_Predef_Op then
             Next_Formal (Iface_Formal);
          end if;
 
@@ -4061,8 +4063,7 @@ package body Exp_Disp is
                           Alias (Prim);
 
                      else
-                        Expand_Interface_Thunk
-                          (Ultimate_Alias (Prim), Thunk_Id, Thunk_Code);
+                        Expand_Interface_Thunk (Prim, Thunk_Id, Thunk_Code);
 
                         if Present (Thunk_Id) then
                            Append_To (Result, Thunk_Code);

diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 00ad237..1a5888b 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,7 @@
+2018-11-14  Javier Miranda  <miranda@adacore.com>
+
+       * gnat.dg/equal5.adb, gnat.dg/equal5.ads: New testcase.
+
 2018-11-14  Eric Botcazou  <ebotcazou@adacore.com>
 
        * gnat.dg/compile_time_error1.adb,

diff --git a/gcc/testsuite/gnat.dg/equal5.adb b/gcc/testsuite/gnat.dg/equal5.adb
new file mode 100644 (file)
index 0000000..d98cff8
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/equal5.adb
@@ -0,0 +1,13 @@
+--  { dg-do compile }
+
+package body Equal5 is
+   function "="
+     (Left  : Eq_Parent;
+      Right : Eq_Parent) return Boolean is (True);
+
+   procedure Op (Obj : Child_6) is null;
+
+   function Equals
+     (Left  : Child_6;
+      Right : Child_6) return Boolean is (True);
+end Equal5;

diff --git a/gcc/testsuite/gnat.dg/equal5.ads b/gcc/testsuite/gnat.dg/equal5.ads
new file mode 100644 (file)
index 0000000..0bf3be0
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/equal5.ads
@@ -0,0 +1,31 @@
+package Equal5 is
+   type Eq_Parent is tagged null record;
+
+   function "="
+     (Left  : Eq_Parent;
+      Right : Eq_Parent) return Boolean;
+
+   type Eq_Iface is interface;
+
+   function "="
+     (Left  : Eq_Iface;
+      Right : Eq_Iface) return Boolean is abstract;
+   procedure Op (Obj : Eq_Iface) is abstract;
+
+   -----------------
+   -- Derivations --
+   -----------------
+
+   type Child_6 is new Eq_Parent and Eq_Iface with null record;
+
+   procedure Op (Obj : Child_6);
+
+   function Equals
+     (Left  : Child_6;
+      Right : Child_6) return Boolean;
+
+   function "="
+     (Left  : Child_6;
+      Right : Child_6) return Boolean renames Equals;  --  Test
+
+end Equal5;