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.
Tested on x86_64-pc-linux-gnu, committed on trunk
2018-11-14 Javier Miranda <mira...@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.--- gcc/ada/exp_disp.adb
+++ 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);
--- /dev/null
new file mode 100644
+++ 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;
--- /dev/null
new file mode 100644
+++ 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;
