From patchwork Mon Jun 14 13:47:06 2010 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Arnaud Charlet X-Patchwork-Id: 55534 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@bilbo.ozlabs.org Received: from sourceware.org (server1.sourceware.org [209.132.180.131]) by ozlabs.org (Postfix) with SMTP id 54B5AB7D84 for ; Mon, 14 Jun 2010 23:47:07 +1000 (EST) Received: (qmail 31290 invoked by alias); 14 Jun 2010 13:47:05 -0000 Received: (qmail 31276 invoked by uid 22791); 14 Jun 2010 13:47:02 -0000 X-SWARE-Spam-Status: No, hits=-0.5 required=5.0 tests=AWL, BAYES_50, TW_TM, T_RP_MATCHES_RCVD X-Spam-Check-By: sourceware.org Received: from mel.act-europe.fr (HELO mel.act-europe.fr) (212.99.106.210) by sourceware.org (qpsmtpd/0.43rc1) with ESMTP; Mon, 14 Jun 2010 13:46:56 +0000 Received: from localhost (localhost [127.0.0.1]) by filtered-smtp.eu.adacore.com (Postfix) with ESMTP id 28F73CB024C; Mon, 14 Jun 2010 15:46:59 +0200 (CEST) Received: from mel.act-europe.fr ([127.0.0.1]) by localhost (smtp.eu.adacore.com [127.0.0.1]) (amavisd-new, port 10024) with ESMTP id cYQD1E8Vkihh; Mon, 14 Jun 2010 15:46:59 +0200 (CEST) Received: from saumur.act-europe.fr (saumur.act-europe.fr [10.10.0.183]) by mel.act-europe.fr (Postfix) with ESMTP id 14754CB021C; Mon, 14 Jun 2010 15:46:59 +0200 (CEST) Received: by saumur.act-europe.fr (Postfix, from userid 525) id 3B13AD9B31; Mon, 14 Jun 2010 15:47:06 +0200 (CEST) Date: Mon, 14 Jun 2010 15:47:06 +0200 From: Arnaud Charlet To: gcc-patches@gcc.gnu.org Cc: Robert Dewar Subject: [Ada] Check infinite loop warning for exit when statement Message-ID: <20100614134706.GA12735@adacore.com> Mime-Version: 1.0 Content-Disposition: inline User-Agent: Mutt/1.5.9i X-IsSubscribed: yes Mailing-List: contact gcc-patches-help@gcc.gnu.org; run by ezmlm Precedence: bulk List-Id: List-Unsubscribe: List-Archive: List-Post: List-Help: Sender: gcc-patches-owner@gcc.gnu.org Delivered-To: mailing list gcc-patches@gcc.gnu.org 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 * 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 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