Patchwork [Ada] Illegal program not detected, self renames, PR15846

login
register
mail settings
Submitter coopht@gmail.com
Date Jan. 11, 2012, 8:48 p.m.
Message ID <4F0DF581.1090304@gmail.com>
Download mbox | patch
Permalink /patch/135500/
State New
Headers show

Comments

coopht@gmail.com - Jan. 11, 2012, 8:48 p.m.
Sorry,
fixed patch is attached.

12.01.2012 00:43, Alexander Basov пишет:
> 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
>

Patch

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 renamings1 is
+
+   type T1 is tagged null record;
+
+   function "=" (left, right : in T1) return Boolean
+     renames renamings1."=";  -- { dg-error "subprogram cannot rename itself" }
+
+end renamings1;
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 renamings2 is
+
+   type T1 is null record;
+
+   function "=" (left, right : in T1) return boolean
+     renames renamings2."=";  -- { dg-error "subprogram cannot rename itself" }
+
+end renamings2;