Commit 4faf522b by Javier Miranda Committed by Pierre-Marie de Rodat

[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
parent b6eb7548
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> 2018-11-14 Hristian Kirtchev <kirtchev@adacore.com>
* freeze.adb (Check_Pragma_Thread_Local_Storage): New routine. A * freeze.adb (Check_Pragma_Thread_Local_Storage): New routine. A
......
...@@ -1828,6 +1828,9 @@ package body Exp_Disp is ...@@ -1828,6 +1828,9 @@ package body Exp_Disp is
Formal : Node_Id; Formal : Node_Id;
Ftyp : Entity_Id; Ftyp : Entity_Id;
Iface_Formal : Node_Id := Empty; -- initialize to prevent warning 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; New_Arg : Node_Id;
Offset_To_Top : Node_Id; Offset_To_Top : Node_Id;
Target_Formal : Entity_Id; Target_Formal : Entity_Id;
...@@ -1838,7 +1841,7 @@ package body Exp_Disp is ...@@ -1838,7 +1841,7 @@ package body Exp_Disp is
-- No thunk needed if the primitive has been eliminated -- No thunk needed if the primitive has been eliminated
if Is_Eliminated (Ultimate_Alias (Prim)) then if Is_Eliminated (Target) then
return; return;
-- In case of primitives that are functions without formals and a -- In case of primitives that are functions without formals and a
...@@ -1859,9 +1862,10 @@ package body Exp_Disp is ...@@ -1859,9 +1862,10 @@ package body Exp_Disp is
-- actual object) generate code that modify its contents. -- actual object) generate code that modify its contents.
-- Note: This special management is not done for predefined primitives -- 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)); Iface_Formal := First_Formal (Interface_Alias (Prim));
end if; end if;
...@@ -1872,9 +1876,7 @@ package body Exp_Disp is ...@@ -1872,9 +1876,7 @@ package body Exp_Disp is
-- Use the interface type as the type of the controlling formal (see -- Use the interface type as the type of the controlling formal (see
-- comment above). -- comment above).
if not Is_Controlling_Formal (Formal) if not Is_Controlling_Formal (Formal) or else Is_Predef_Op then
or else Is_Predefined_Dispatching_Operation (Prim)
then
Ftyp := Etype (Formal); Ftyp := Etype (Formal);
Expr := New_Copy_Tree (Expression (Parent (Formal))); Expr := New_Copy_Tree (Expression (Parent (Formal)));
else else
...@@ -1892,7 +1894,7 @@ package body Exp_Disp is ...@@ -1892,7 +1894,7 @@ package body Exp_Disp is
Parameter_Type => New_Occurrence_Of (Ftyp, Loc), Parameter_Type => New_Occurrence_Of (Ftyp, Loc),
Expression => Expr)); Expression => Expr));
if not Is_Predefined_Dispatching_Operation (Prim) then if not Is_Predef_Op then
Next_Formal (Iface_Formal); Next_Formal (Iface_Formal);
end if; end if;
...@@ -4061,8 +4063,7 @@ package body Exp_Disp is ...@@ -4061,8 +4063,7 @@ package body Exp_Disp is
Alias (Prim); Alias (Prim);
else else
Expand_Interface_Thunk Expand_Interface_Thunk (Prim, Thunk_Id, Thunk_Code);
(Ultimate_Alias (Prim), Thunk_Id, Thunk_Code);
if Present (Thunk_Id) then if Present (Thunk_Id) then
Append_To (Result, Thunk_Code); Append_To (Result, Thunk_Code);
......
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> 2018-11-14 Eric Botcazou <ebotcazou@adacore.com>
* gnat.dg/compile_time_error1.adb, * gnat.dg/compile_time_error1.adb,
......
-- { 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;
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;
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment