Hi,
this patch fixes problem when gnat is not able
to detect illegal program with self renaming of predefined operation,
when renaming operation is defined with selected component of the same
package as renaming declaration.
(please correct me if I wrong in my explanation)
And also this patch fixes ICE when T1 type is tagged record.
package renaming6 is
type T1 is null record;
function "=" (left, right : in T1) return boolean
renames renaming6."="; -- { dg-error "subprogram cannot rename
itself" }
end renaming6;
Tested on x86_64-pc-linux-gnu.
ChangeLog:
* gcc/ada/exp_disp.adb (Make_DT):
Check if flag Is_Dispatching_Operation is True before getting
DT_Position flag ,
present in function and procedure entities which are dispatching
* gcc/ada/sem_ch8.adb (Analyze_Subprogram_Renaming):
Added check if renaming entity package is the same as
renaming_declaration package,
in case if both operations has the same names.
* gcc/testsuite/gnat.dg/specs/renamings1.ads: new testcase
* gcc/testsuite/gnat.dg/specs/renamings2.ads: new testcase
--
Best regards,
Alexander Basov
Index: gcc/ada/exp_disp.adb
===================================================================
--- gcc/ada/exp_disp.adb (revision 183094)
+++ gcc/ada/exp_disp.adb (working copy)
@@ -4135,6 +4135,7 @@
Prim := Node (Prim_Elmt);
if Present (Interface_Alias (Prim))
+ and then Is_Dispatching_Operation (Prim)
and then Find_Dispatching_Type
(Interface_Alias (Prim)) = Iface
then
@@ -4247,7 +4248,6 @@
while Present (Prim_Elmt) loop
Prim := Node (Prim_Elmt);
E := Ultimate_Alias (Prim);
- Prim_Pos := UI_To_Int (DT_Position (E));
-- Do not reference predefined primitives because they are
-- located in a separate dispatch table; skip abstract and
@@ -4260,7 +4260,8 @@
and then not Is_Abstract_Subprogram (Alias (Prim))
and then not Is_Eliminated (Alias (Prim))
and then (not Is_CPP_Class (Root_Type (Typ))
- or else Prim_Pos > CPP_Nb_Prims)
+ or else UI_To_Int
+ (DT_Position (E)) > CPP_Nb_Prims)
and then Find_Dispatching_Type
(Interface_Alias (Prim)) = Iface
@@ -5764,7 +5765,6 @@
E : Entity_Id;
Prim : Entity_Id;
Prim_Elmt : Elmt_Id;
- Prim_Pos : Nat;
Prim_Table : array (Nat range 1 .. Nb_Prim) of Entity_Id;
begin
@@ -5777,8 +5777,7 @@
-- Retrieve the ultimate alias of the primitive for proper
-- handling of renamings and eliminated primitives.
- E := Ultimate_Alias (Prim);
- Prim_Pos := UI_To_Int (DT_Position (E));
+ E := Ultimate_Alias (Prim);
-- Do not reference predefined primitives because they are
-- located in a separate dispatch table; skip entities with
@@ -5794,7 +5793,8 @@
and then not Is_Abstract_Subprogram (E)
and then not Is_Eliminated (E)
and then (not Is_CPP_Class (Root_Type (Typ))
- or else Prim_Pos > CPP_Nb_Prims)
+ or else UI_To_Int
+ (DT_Position (E)) > CPP_Nb_Prims)
then
pragma Assert
(UI_To_Int (DT_Position (Prim)) <= Nb_Prim);
Index: gcc/ada/sem_ch8.adb
===================================================================
--- gcc/ada/sem_ch8.adb (revision 183094)
+++ gcc/ada/sem_ch8.adb (working copy)
@@ -2662,10 +2662,13 @@
end if;
end if;
- if not Is_Actual
- and then (Old_S = New_S
- or else (Nkind (Nam) /= N_Expanded_Name
- and then Chars (Old_S) = Chars (New_S)))
+ if not Is_Actual and then
+ (Old_S = New_S
+ or else (Nkind (Nam) /= N_Expanded_Name
+ and then Chars (Old_S) = Chars (New_S))
+ or else (Nkind (Nam) = N_Expanded_Name
+ and then Scope (New_S) = Entity (Prefix (Nam))
+ and then Chars (Old_S) = Chars (New_S)))
then
Error_Msg_N ("subprogram cannot rename itself", N);
end if;
Index: gcc/testsuite/gnat.dg/specs/renamings1.ads
===================================================================
--- gcc/testsuite/gnat.dg/specs/renamings1.ads (revision 0)
+++ gcc/testsuite/gnat.dg/specs/renamings1.ads (working copy)
@@ -0,0 +1,10 @@
+-- { dg-do compile}
+
+package renaming5 is
+
+ type T1 is tagged null record;
+
+ function "=" (left, right : in T1) return Boolean
+ renames renaming5."="; -- { dg-error "subprogram cannot rename itself" }
+
+end renaming5;
Index: gcc/testsuite/gnat.dg/specs/renamings2.ads
===================================================================
--- gcc/testsuite/gnat.dg/specs/renamings2.ads (revision 0)
+++ gcc/testsuite/gnat.dg/specs/renamings2.ads (working copy)
@@ -0,0 +1,10 @@
+-- { dg-do compile}
+
+package renaming6 is
+
+ type T1 is null record;
+
+ function "=" (left, right : in T1) return boolean
+ renames renaming6."="; -- { dg-error "subprogram cannot rename itself" }
+
+end renaming6;
