From patchwork Mon Jun 14 12:47:18 2010
Content-Type: text/plain; charset="utf-8"
MIME-Version: 1.0
Content-Transfer-Encoding: 7bit
Subject: [Ada] Test for recursive subprogram call via a derived subprogram
Date: Mon, 14 Jun 2010 02:47:18 -0000
From: Arnaud Charlet <charlet@adacore.com>
X-Patchwork-Id: 55525
Message-Id: <20100614124718.GA26506@adacore.com>
To: gcc-patches@gcc.gnu.org
Cc: Gary Dismukes <dismukes@adacore.com>

We extend the checking for recursive calls to include the case of
a subprogram that calls itself via a call to a derive subprogram.

Compilation of the following package must report:

derived_op_recursion.adb:7:37: violation of restriction "No_Recursion" at derived_op_recursion.ads:1

pragma Restrictions (No_Recursion);

package Derived_Op_Recursion is
   
   type Int_Type is new Integer;
   
   function "*" (I1 : Int_Type; I2 : Int_Type) return Int_Type;
   
end Derived_Op_Recursion;

package body Derived_Op_Recursion is

   type New_Int is new Int_Type;  -- Inherits user-defined "*" from Int_Type

   function "*" (I1 : Int_Type; I2 : Int_Type) return Int_Type is
   begin
      return Int_Type (New_Int (I1) * New_Int (I2));  -- Recursive call to "*"
   end "*";

end Derived_Op_Recursion;

Tested on x86_64-pc-linux-gnu, committed on trunk

2010-06-14  Gary Dismukes  <dismukes@adacore.com>

	* sem_res.adb (Resolve_Call): For infinite recursion check, test
	whether the called subprogram is inherited from a containing subprogram.
	(Same_Or_Aliased_Subprograms): New function


Index: sem_res.adb
===================================================================
--- sem_res.adb	(revision 160718)
+++ sem_res.adb	(working copy)
@@ -4763,6 +4763,25 @@ package body Sem_Res is
       Scop    : Entity_Id;
       Rtype   : Entity_Id;
 
+      function Same_Or_Aliased_Subprograms
+        (S : Entity_Id;
+         E : Entity_Id) return Boolean;
+      --  Returns True if the subprogram entity S is the same as E or else
+      --  S is an alias of E.
+
+      function Same_Or_Aliased_Subprograms
+        (S : Entity_Id;
+         E : Entity_Id) return Boolean
+      is
+         Subp_Alias : constant Entity_Id := Alias (S);
+
+      begin
+         return S = E
+           or else (Present (Subp_Alias) and then Subp_Alias = E);
+      end Same_Or_Aliased_Subprograms;
+
+   --  Start of processing for Resolve_Call
+
    begin
       --  The context imposes a unique interpretation with type Typ on a
       --  procedure or function call. Find the entity of the subprogram that
@@ -5095,7 +5114,7 @@ package body Sem_Res is
          --  Issue warning for possible infinite recursion in the absence
          --  of the No_Recursion restriction.
 
-         if Nam = Scop
+         if Same_Or_Aliased_Subprograms (Nam, Scop)
            and then not Restriction_Active (No_Recursion)
            and then Check_Infinite_Recursion (N)
          then
@@ -5112,7 +5131,7 @@ package body Sem_Res is
 
          else
             Scope_Loop : while Scop /= Standard_Standard loop
-               if Nam = Scop then
+               if Same_Or_Aliased_Subprograms (Nam, Scop) then
 
                   --  Although in general case, recursion is not statically
                   --  checkable, the case of calling an immediately containing