From: Javier Miranda Date: Wed, 14 Nov 2018 11:42:10 +0000 (+0000) Subject: [Ada] Crash on interface equality covered by a renaming declaration X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=4faf522bacd66cd03826c645b30c68f0fd785177;p=gcc.git [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 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 900d23a50d3..7390a5c5291 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,12 @@ +2018-11-14 Javier Miranda + + * 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 * 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 f36cd1f8aed..5a9124976f7 100644 --- 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 00ad237ac25..1a5888b7c44 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,7 @@ +2018-11-14 Javier Miranda + + * gnat.dg/equal5.adb, gnat.dg/equal5.ads: New testcase. + 2018-11-14 Eric Botcazou * 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 index 00000000000..d98cff8cea6 --- /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 index 00000000000..0bf3be0bf7f --- /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;