diff mbox

[Ada] Check infinite loop warning for exit when statement

Message ID 20100614134706.GA12735@adacore.com
State New
Headers show

Commit Message

Arnaud Charlet June 14, 2010, 1:47 p.m. UTC
This patch generalizes the Check_Infinite_Loop_Warning proceddure so
that it can be used for exit when tests as well as while tests, and
adds the appropriate call to Analyze_Exit_Statement.

The following test program compiled with -gnatwa shows the new
warning in action:

     1. procedure exitwarn (m : integer) is
     2.    g : integer := 3;
     3.    x : integer := m;
     4.
     5. begin
     6.    x := x + 1;
     7.    while x > 5 loop
                 |
        >>> warning: variable "x" is not modified in loop body
        >>> warning: possible infinite loop

     8.       g := g + 1;
     9.    end loop;
    10.
    11.    loop
    12.       exit when x <= 5;
                        |
        >>> warning: variable "x" is not modified in loop body
        >>> warning: possible infinite loop

    13.       g := g + 1;
    14.    end loop;
    15.
    16.    loop
    17.       exit when x <= 5;
    18.       x := x - 1;
    19.    end loop;
    20. end;

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

2010-06-14  Robert Dewar  <dewar@adacore.com>

	* debug.adb: Entry for gnatw.d no longer specific for while loops
	* einfo.adb (First_Exit_Statement): New attribute for E_Loop
	* einfo.ads (First_Exit_Statement): New attribute for E_Loop
	* sem_ch5.adb (Analyze_Loop_Statement): Check_Infinite_Loop_Warning has
	new calling sequence to include test for EXIT WHEN.
	(Analyze_Exit_Statement): Chain EXIT statement into exit statement chain
	* sem_warn.ads, sem_warn.adb (Check_Infinite_Loop_Warning): Now handles
	EXIT WHEN case.
	* sinfo.adb (Next_Exit_Statement): New attribute of N_Exit_Statement
	node.
	* sinfo.ads (N_Pragma): Correct comment on Sloc field (points to
	PRAGMA, not to pragma identifier).
	(Next_Exit_Statement): New attribute of N_Exit_Statement node
diff mbox

Patch

Index: sem_ch5.adb
===================================================================
--- sem_ch5.adb	(revision 160705)
+++ sem_ch5.adb	(working copy)
@@ -1209,6 +1209,11 @@  package body Sem_Ch5 is
          Check_Unset_Reference (Cond);
       end if;
 
+      --  Chain exit statement to associated loop entity
+
+      Set_Next_Exit_Statement  (N, First_Exit_Statement (Scope_Id));
+      Set_First_Exit_Statement (Scope_Id, N);
+
       --  Since the exit may take us out of a loop, any previous assignment
       --  statement is not useless, so clear last assignment indications. It
       --  is OK to keep other current values, since if the exit statement
@@ -2060,8 +2065,12 @@  package body Sem_Ch5 is
       End_Scope;
       Kill_Current_Values;
 
-      --  Check for infinite loop. We skip this check for generated code, since
-      --  it justs waste time and makes debugging the routine called harder.
+      --  Check for infinite loop. Skip check for generated code, since it
+      --  justs waste time and makes debugging the routine called harder.
+
+      --  Note that we have to wait till the body of the loop is fully analyzed
+      --  before making this call, since Check_Infinite_Loop_Warning relies on
+      --  being able to use semantic visibility information to find references.
 
       if Comes_From_Source (N) then
          Check_Infinite_Loop_Warning (N);
Index: sinfo.adb
===================================================================
--- sinfo.adb	(revision 160725)
+++ sinfo.adb	(working copy)
@@ -2021,6 +2021,14 @@  package body Sinfo is
       return Node2 (N);
    end Next_Entity;
 
+   function Next_Exit_Statement
+     (N : Node_Id) return Node_Id is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Exit_Statement);
+      return Node3 (N);
+   end Next_Exit_Statement;
+
    function Next_Implicit_With
      (N : Node_Id) return Node_Id is
    begin
@@ -4907,6 +4915,14 @@  package body Sinfo is
       Set_Node2 (N, Val); -- semantic field, no parent set
    end Set_Next_Entity;
 
+   procedure Set_Next_Exit_Statement
+      (N : Node_Id; Val : Node_Id) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Exit_Statement);
+      Set_Node3 (N, Val); -- semantic field, no parent set
+   end Set_Next_Exit_Statement;
+
    procedure Set_Next_Implicit_With
       (N : Node_Id; Val : Node_Id) is
    begin
Index: sinfo.ads
===================================================================
--- sinfo.ads	(revision 160725)
+++ sinfo.ads	(working copy)
@@ -1395,6 +1395,12 @@  package Sinfo is
    --    scope are chained, and this field is used as the forward pointer for
    --    this list. See Einfo for further details.
 
+   --  Next_Exit_Statement (Node3-Sem)
+   --    Present in N_Exit_Statement nodes. The exit statements for a loop are
+   --    chained (in reverse order of appearence) from the First_Exit_Statement
+   --    field of the E_Loop entity for the loop. Next_Exit_Statement points to
+   --    the next entry on this chain (Empty = end of list).
+
    --  Next_Implicit_With (Node3-Sem)
    --    Present in N_With_Clause. Part of a chain of with_clauses generated
    --    in rtsfind to indicate implicit dependencies on predefined units. Used
@@ -1980,7 +1986,7 @@  package Sinfo is
       --  which are explicitly documented.
 
       --  N_Pragma
-      --  Sloc points to pragma identifier
+      --  Sloc points to PRAGMA
       --  Next_Pragma (Node1-Sem)
       --  Pragma_Argument_Associations (List2) (set to No_List if none)
       --  Debug_Statement (Node3) (set to Empty if not Debug, Assert)
@@ -4040,6 +4046,13 @@  package Sinfo is
       --  Is_Null_Loop (Flag16)
       --  Suppress_Loop_Warnings (Flag17)
 
+      --  Note: the parser fills in the Identifier field if there is an
+      --  explicit loop identifier. Otherwise the parser leaves this field
+      --  set to Empty, and then the semantic processing for a loop statement
+      --  creates an identifier, setting the Has_Created_Identifier flag to
+      --  True. So after semantic anlaysis, the Identifier is always set,
+      --  referencing an identifier whose entity has an Ekind of E_Loop.
+
       --------------------------
       -- 5.5 Iteration Scheme --
       --------------------------
@@ -4128,7 +4141,8 @@  package Sinfo is
       --  N_Exit_Statement
       --  Sloc points to EXIT
       --  Name (Node2) (set to Empty if no loop name present)
-      --  Condition (Node1) (set to Empty if no when part present)
+      --  Condition (Node1) (set to Empty if no WHEN part present)
+      --  Next_Exit_Statement (Node3-Sem): Next exit on chain
 
       -------------------------
       -- 5.9  Goto Statement --
@@ -8247,6 +8261,9 @@  package Sinfo is
    function Next_Entity
      (N : Node_Id) return Node_Id;    -- Node2
 
+   function Next_Exit_Statement
+     (N : Node_Id) return Node_Id;    -- Node3
+
    function Next_Implicit_With
      (N : Node_Id) return Node_Id;    -- Node3
 
@@ -9168,6 +9185,9 @@  package Sinfo is
    procedure Set_Next_Entity
      (N : Node_Id; Val : Node_Id);            -- Node2
 
+   procedure Set_Next_Exit_Statement
+     (N : Node_Id; Val : Node_Id);            -- Node3
+
    procedure Set_Next_Implicit_With
      (N : Node_Id; Val : Node_Id);            -- Node3
 
@@ -11360,6 +11380,7 @@  package Sinfo is
    pragma Inline (Name);
    pragma Inline (Names);
    pragma Inline (Next_Entity);
+   pragma Inline (Next_Exit_Statement);
    pragma Inline (Next_Implicit_With);
    pragma Inline (Next_Named_Actual);
    pragma Inline (Next_Pragma);
@@ -11664,6 +11685,7 @@  package Sinfo is
    pragma Inline (Set_Name);
    pragma Inline (Set_Names);
    pragma Inline (Set_Next_Entity);
+   pragma Inline (Set_Next_Exit_Statement);
    pragma Inline (Set_Next_Implicit_With);
    pragma Inline (Set_Next_Named_Actual);
    pragma Inline (Set_Next_Pragma);
Index: debug.adb
===================================================================
--- debug.adb	(revision 160705)
+++ debug.adb	(working copy)
@@ -113,7 +113,7 @@  package body Debug is
    --  d.t  Disable static allocation of library level dispatch tables
    --  d.u
    --  d.v  Enable OK_To_Reorder_Components in variant records
-   --  d.w  Do not check for infinite while loops
+   --  d.w  Do not check for infinite loops
    --  d.x  No exception handlers
    --  d.y
    --  d.z
@@ -548,7 +548,7 @@  package body Debug is
    --  d.v  Forces the flag OK_To_Reorder_Components to be set in all record
    --       base types that have at least one discriminant (v = variant).
 
-   --  d.w  This flag turns off the scanning of while loops to detect possible
+   --  d.w  This flag turns off the scanning of loops to detect possible
    --       infinite loops.
 
    --  d.x  No exception handlers in generated code. This causes exception
Index: einfo.adb
===================================================================
--- einfo.adb	(revision 160705)
+++ einfo.adb	(working copy)
@@ -79,6 +79,7 @@  package body Einfo is
    --    Normalized_First_Bit            Uint8
    --    Postcondition_Proc              Node8
    --    Return_Applies_To               Node8
+   --    First_Exit_Statement            Node8
 
    --    Class_Wide_Type                 Node9
    --    Current_Value                   Node9
@@ -1053,6 +1054,12 @@  package body Einfo is
       return Node17 (Id);
    end First_Entity;
 
+   function First_Exit_Statement (Id : E) return N is
+   begin
+      pragma Assert (Ekind (Id) = E_Loop);
+      return Node8 (Id);
+   end First_Exit_Statement;
+
    function First_Index (Id : E) return N is
    begin
       pragma Assert (Is_Array_Type (Id) or else Is_String_Type (Id));
@@ -3492,6 +3499,12 @@  package body Einfo is
       Set_Node17 (Id, V);
    end Set_First_Entity;
 
+   procedure Set_First_Exit_Statement (Id : E; V : N) is
+   begin
+      pragma Assert (Ekind (Id) = E_Loop);
+      Set_Node8 (Id, V);
+   end Set_First_Exit_Statement;
+
    procedure Set_First_Index (Id : E; V : N) is
    begin
       pragma Assert (Is_Array_Type (Id) or else Is_String_Type (Id));
@@ -7236,6 +7249,9 @@  package body Einfo is
          when Type_Kind                                    =>
             Write_Str ("Associated_Node_For_Itype");
 
+         when E_Loop                                       =>
+            Write_Str ("First_Exit_Statement");
+
          when E_Package                                    =>
             Write_Str ("Dependent_Instances");
 
Index: einfo.ads
===================================================================
--- einfo.ads	(revision 160705)
+++ einfo.ads	(working copy)
@@ -1116,6 +1116,13 @@  package Einfo is
 --       Points to a list of associated entities using the Next_Entity field
 --       as a chain pointer with Empty marking the end of the list.
 
+--    First_Exit_Statement (Node8)
+--       Present in E_Loop entity. The exit statements for a loop are chained
+--       (in reverse order of appearence) using this field to point to the
+--       first entry in the chain (last exit statement in the loop). The
+--       entries are chained through the Next_Exit_Statement field of the
+--       N_Exit_Statement node with Empty marking the end of the list.
+
 --    First_Formal (synthesized)
 --       Applies to subprograms and subprogram types, and also in entries
 --       and entry families. Returns first formal of the subprogram or entry.
@@ -5063,6 +5070,7 @@  package Einfo is
    --    (plus type attributes)
 
    --  E_Loop
+   --    First_Exit_Statement                (Node8)
    --    Has_Exit                            (Flag47)
    --    Has_Master_Entity                   (Flag21)
    --    Has_Nested_Block_With_Handler       (Flag101)
@@ -5743,6 +5751,7 @@  package Einfo is
    function Finalization_Chain_Entity           (Id : E) return E;
    function Finalize_Storage_Only               (Id : E) return B;
    function First_Entity                        (Id : E) return E;
+   function First_Exit_Statement                (Id : E) return N;
    function First_Index                         (Id : E) return N;
    function First_Literal                       (Id : E) return E;
    function First_Optional_Parameter            (Id : E) return E;
@@ -6291,6 +6300,7 @@  package Einfo is
    procedure Set_Finalization_Chain_Entity       (Id : E; V : E);
    procedure Set_Finalize_Storage_Only           (Id : E; V : B := True);
    procedure Set_First_Entity                    (Id : E; V : E);
+   procedure Set_First_Exit_Statement            (Id : E; V : N);
    procedure Set_First_Index                     (Id : E; V : N);
    procedure Set_First_Literal                   (Id : E; V : E);
    procedure Set_First_Optional_Parameter        (Id : E; V : E);
@@ -6945,6 +6955,7 @@  package Einfo is
    pragma Inline (Can_Use_Internal_Rep);
    pragma Inline (Finalization_Chain_Entity);
    pragma Inline (First_Entity);
+   pragma Inline (First_Exit_Statement);
    pragma Inline (First_Index);
    pragma Inline (First_Literal);
    pragma Inline (First_Optional_Parameter);
@@ -7376,6 +7387,7 @@  package Einfo is
    pragma Inline (Set_Can_Use_Internal_Rep);
    pragma Inline (Set_Finalization_Chain_Entity);
    pragma Inline (Set_First_Entity);
+   pragma Inline (Set_First_Exit_Statement);
    pragma Inline (Set_First_Index);
    pragma Inline (Set_First_Literal);
    pragma Inline (Set_First_Optional_Parameter);
Index: sem_warn.adb
===================================================================
--- sem_warn.adb	(revision 160705)
+++ sem_warn.adb	(working copy)
@@ -234,10 +234,11 @@  package body Sem_Warn is
    --  within the body of the loop.
 
    procedure Check_Infinite_Loop_Warning (Loop_Statement : Node_Id) is
-      Iter : constant Node_Id := Iteration_Scheme (Loop_Statement);
+      Expression : Node_Id := Empty;
+      --  Set to WHILE or EXIT WHEN condition to be tested
 
       Ref : Node_Id := Empty;
-      --  Reference in iteration scheme to variable that might not be modified
+      --  Reference in Expression to variable that might not be modified
       --  in loop, indicating a possible infinite loop.
 
       Var : Entity_Id := Empty;
@@ -267,9 +268,9 @@  package body Sem_Warn is
 
       function Test_Ref (N : Node_Id) return Traverse_Result;
       --  Test for reference to variable in question. Returns Abandon if
-      --  matching reference found.
+      --  matching reference found. Used in instantiation of No_Ref_Found.
 
-      function Find_Ref is new Traverse_Func (Test_Ref);
+      function No_Ref_Found is new Traverse_Func (Test_Ref);
       --  Function to traverse body of procedure. Returns Abandon if matching
       --  reference found.
 
@@ -465,9 +466,9 @@  package body Sem_Warn is
 
       function Test_Ref (N : Node_Id) return Traverse_Result is
       begin
-         --  Waste of time to look at iteration scheme
+         --  Waste of time to look at the expression we are testing
 
-         if N = Iter then
+         if N = Expression then
             return Skip;
 
          --  Direct reference to variable in question
@@ -547,20 +548,86 @@  package body Sem_Warn is
    --  Start of processing for Check_Infinite_Loop_Warning
 
    begin
-      --  We need a while iteration with no condition actions. Condition
-      --  actions just make things too complicated to get the warning right.
+      --  Skip processing if debug flag gnatd.w is set
 
-      if No (Iter)
-        or else No (Condition (Iter))
-        or else Present (Condition_Actions (Iter))
-        or else Debug_Flag_Dot_W
-      then
+      if Debug_Flag_Dot_W then
+         return;
+      end if;
+
+      --  Case of WHILE loop
+
+      declare
+         Iter : constant Node_Id := Iteration_Scheme (Loop_Statement);
+
+      begin
+         if Present (Iter) and then Present (Condition (Iter)) then
+
+            --  Skip processing for while iteration with conditions actions,
+            --  since they make it too complicated to get the warning right.
+
+            if Present (Condition_Actions (Iter)) then
+               return;
+            end if;
+
+            --  Capture WHILE condition
+
+            Expression := Condition (Iter);
+         end if;
+      end;
+
+      --  Check chain of EXIT statements, we only process loops that have a
+      --  single exit condition (either a single EXIT WHEN statement, or a
+      --  WHILE loop not containing any EXIT WHEN statements).
+
+      declare
+         Ident     : constant Node_Id := Identifier (Loop_Statement);
+         Exit_Stmt : Node_Id;
+
+      begin
+         --  If we don't have a proper chain set, ignore call entirely. This
+         --  happens because of previous errors.
+
+         if No (Entity (Ident))
+           or else Ekind (Entity (Ident)) /= E_Loop
+         then
+            return;
+         end if;
+
+         --  Otherwise prepare to scan list of EXIT statements
+
+         Exit_Stmt := First_Exit_Statement (Entity (Ident));
+         while Present (Exit_Stmt) loop
+
+            --  Check for EXIT WHEN
+
+            if Present (Condition (Exit_Stmt)) then
+
+               --  Quit processing if EXIT WHEN in WHILE loop, or more than
+               --  one EXIT WHEN statement present in the loop.
+
+               if Present (Expression) then
+                  return;
+
+               --  Otherwise capture condition from EXIT WHEN statement
+
+               else
+                  Expression := Condition (Exit_Stmt);
+               end if;
+            end if;
+
+            Exit_Stmt := Next_Exit_Statement (Exit_Stmt);
+         end loop;
+      end;
+
+      --  Return if no condition to test
+
+      if No (Expression) then
          return;
       end if;
 
       --  Initial conditions met, see if condition is of right form
 
-      Find_Var (Condition (Iter));
+      Find_Var (Expression);
 
       --  Nothing to do if local variable from source not found. If it's a
       --  renaming, it is probably renaming something too complicated to deal
@@ -608,7 +675,7 @@  package body Sem_Warn is
       --  We have a variable reference of the right form, now we scan the loop
       --  body to see if it looks like it might not be modified
 
-      if Find_Ref (Loop_Statement) = OK then
+      if No_Ref_Found (Loop_Statement) = OK then
          Error_Msg_NE
            ("?variable& is not modified in loop body!", Ref, Var);
          Error_Msg_N
@@ -3432,9 +3499,7 @@  package body Sem_Warn is
             Sloc_Range (Orig, Start, Dummy);
             Atrue := Test_Result;
 
-            if Present (Parent (C))
-              and then Nkind (Parent (C)) = N_Op_Not
-            then
+            if Present (Parent (C)) and then Nkind (Parent (C)) = N_Op_Not then
                Atrue := not Atrue;
             end if;
 
Index: sem_warn.ads
===================================================================
--- sem_warn.ads	(revision 160705)
+++ sem_warn.ads	(working copy)
@@ -170,7 +170,8 @@  package Sem_Warn is
 
    procedure Check_Infinite_Loop_Warning (Loop_Statement : Node_Id);
    --  N is the node for a loop statement. This procedure checks if a warning
-   --  should be given for a possible infinite loop, and if so issues it.
+   --  for a possible infinite loop should be given for a suspicious WHILE or
+   --  EXIT WHEN condition.
 
    procedure Check_Low_Bound_Tested (Expr : Node_Id);
    --  Expr is the node for a comparison operation. This procedure checks if