===================================================================
@@ -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);
===================================================================
@@ -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
===================================================================
@@ -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);
===================================================================
@@ -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
===================================================================
@@ -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");
===================================================================
@@ -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);
===================================================================
@@ -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;
===================================================================
@@ -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
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