From: Robert Dewar Date: Tue, 31 Oct 2006 18:07:33 +0000 (+0100) Subject: sem_ch5.ads, [...] (Analyze_Loop_Statement): Add circuit to warn on infinite loops. X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=2a806772b8dfacc2c8cd8dcfbaf83c034634e4da;p=gcc.git sem_ch5.ads, [...] (Analyze_Loop_Statement): Add circuit to warn on infinite loops. 2006-10-31 Robert Dewar Ed Schonberg Gary Dismukes * sem_ch5.ads, sem_ch5.adb (Analyze_Loop_Statement): Add circuit to warn on infinite loops. Add \\ to some continuation messages (Analyze_Assignment_Statement): Call Warn_On_Useless_Assignment (Process_Bounds): If the bounds are integer literals that result from constant-folding, and they carry a user-defined type, preserve that type rather than treating this as an integer range. (Analyze_Exit_Statement): Test for E_Return_Statement in legality check. (Analyze_Goto_Statement): Test for E_Return_Stateemnt in legality check. (Analyze_Assignment_Statement): Add call to Check_Elab_Assign for left hand side of assignment. (Analyze_Assignment): Add suport to manage assigments to the attribute priority of a protected object. (Check_Possible_Current_Value_Condition): Allow fully qualified names not just identifiers. (Check_Possible_Current_Value_Condition): Acquire left operand of AND or AND THEN for possible tracking. (Analyze_Iteration_Scheme): Check for setting Current_Value for the case of while loops so we can track values in the loop body. From-SVN: r118303 --- diff --git a/gcc/ada/sem_ch5.adb b/gcc/ada/sem_ch5.adb index 241b838eb7e..f74cfa99175 100644 --- a/gcc/ada/sem_ch5.adb +++ b/gcc/ada/sem_ch5.adb @@ -26,25 +26,30 @@ with Atree; use Atree; with Checks; use Checks; +with Debug; use Debug; with Einfo; use Einfo; with Errout; use Errout; with Expander; use Expander; with Exp_Util; use Exp_Util; with Freeze; use Freeze; +with Lib; use Lib; with Lib.Xref; use Lib.Xref; with Nlists; use Nlists; with Nmake; use Nmake; with Opt; use Opt; +with Rtsfind; use Rtsfind; with Sem; use Sem; with Sem_Case; use Sem_Case; with Sem_Ch3; use Sem_Ch3; with Sem_Ch8; use Sem_Ch8; with Sem_Disp; use Sem_Disp; +with Sem_Elab; use Sem_Elab; with Sem_Eval; use Sem_Eval; with Sem_Res; use Sem_Res; with Sem_Type; use Sem_Type; with Sem_Util; use Sem_Util; with Sem_Warn; use Sem_Warn; +with Snames; use Snames; with Stand; use Stand; with Sinfo; use Sinfo; with Targparm; use Targparm; @@ -56,8 +61,8 @@ package body Sem_Ch5 is Unblocked_Exit_Count : Nat := 0; -- This variable is used when processing if statements, case statements, -- and block statements. It counts the number of exit points that are - -- not blocked by unconditional transfer instructions (for IF and CASE, - -- these are the branches of the conditional, for a block, they are the + -- not blocked by unconditional transfer instructions: for IF and CASE, + -- these are the branches of the conditional; for a block, they are the -- statement sequence of the block, and the statement sequences of any -- exception handlers that are part of the block. When processing is -- complete, if this count is zero, it means that control cannot fall @@ -338,6 +343,74 @@ package body Sem_Ch5 is Resolve (Lhs, T1); if not Is_Variable (Lhs) then + + -- Ada 2005 (AI-327): Check assignment to the attribute Priority of + -- a protected object. + + declare + Ent : Entity_Id; + S : Entity_Id; + + begin + if Ada_Version >= Ada_05 then + + -- Handle chains of renamings + + Ent := Lhs; + while Nkind (Ent) in N_Has_Entity + and then Present (Entity (Ent)) + and then Present (Renamed_Object (Entity (Ent))) + loop + Ent := Renamed_Object (Entity (Ent)); + end loop; + + if (Nkind (Ent) = N_Attribute_Reference + and then Attribute_Name (Ent) = Name_Priority) + + -- Renamings of the attribute Priority applied to protected + -- objects have been previously expanded into calls to the + -- Get_Ceiling run-time subprogram. + + or else + (Nkind (Ent) = N_Function_Call + and then (Entity (Name (Ent)) = RTE (RE_Get_Ceiling) + or else + Entity (Name (Ent)) = RTE (RO_PE_Get_Ceiling))) + then + -- The enclosing subprogram cannot be a protected function + + S := Current_Scope; + while not (Is_Subprogram (S) + and then Convention (S) = Convention_Protected) + and then S /= Standard_Standard + loop + S := Scope (S); + end loop; + + if Ekind (S) = E_Function + and then Convention (S) = Convention_Protected + then + Error_Msg_N + ("protected function cannot modify protected object", + Lhs); + end if; + + -- Changes of the ceiling priority of the protected object + -- are only effective if the Ceiling_Locking policy is in + -- effect (AARM D.5.2 (5/2)). + + if Locking_Policy /= 'C' then + Error_Msg_N ("assignment to the attribute PRIORITY has " & + "no effect?", Lhs); + Error_Msg_N ("\since no Locking_Policy has been " & + "specified", Lhs); + end if; + + return; + end if; + end if; + end; + Diagnose_Non_Variable_Lhs (Lhs); return; @@ -520,7 +593,7 @@ package body Sem_Ch5 is -- ??? a real accessibility check is needed when ??? - -- Post warning for useless assignment + -- Post warning for redundant assignment or variable to itself if Warn_On_Redundant_Constructs @@ -555,6 +628,12 @@ package body Sem_Ch5 is Error_Msg_CRT ("composite assignment", N); end if; + -- Check elaboration warning for left side if not in elab code + + if not In_Subprogram_Or_Concurrent_Unit then + Check_Elab_Assign (Lhs); + end if; + -- Final step. If left side is an entity, then we may be able to -- reset the current tracked values to new safe values. We only have -- something to do if the left side is an entity name, and expansion @@ -570,6 +649,22 @@ package body Sem_Ch5 is begin if Safe_To_Capture_Value (N, Ent) then + -- If simple variable on left side, warn if this assignment + -- blots out another one (rendering it useless) and note + -- location of assignment in case no one references value. + -- We only do this for source assignments, otherwise we can + -- generate bogus warnings when an assignment is rewritten as + -- another assignment, and gets tied up with itself. + + if Warn_On_Modified_Unread + and then Ekind (Ent) = E_Variable + and then Comes_From_Source (N) + and then In_Extended_Main_Source_Unit (Ent) + then + Warn_On_Useless_Assignment (Ent, Sloc (N)); + Set_Last_Assignment (Ent, Lhs); + end if; + -- If we are assigning an access type and the left side is an -- entity, then make sure that the Is_Known_[Non_]Null flags -- properly reflect the state of the entity after assignment. @@ -714,6 +809,7 @@ package body Sem_Ch5 is end if; Check_References (Ent); + Warn_On_Useless_Assignments (Ent); End_Scope; if Unblocked_Exit_Count = 0 then @@ -992,7 +1088,10 @@ package body Sem_Ch5 is Set_Has_Exit (Scope_Id); exit; - elsif Kind = E_Block or else Kind = E_Loop then + elsif Kind = E_Block + or else Kind = E_Loop + or else Kind = E_Return_Statement + then null; else @@ -1043,7 +1142,8 @@ package body Sem_Ch5 is if Label_Scope = Scope_Id or else (Ekind (Scope_Id) /= E_Block - and then Ekind (Scope_Id) /= E_Loop) + and then Ekind (Scope_Id) /= E_Loop + and then Ekind (Scope_Id) /= E_Return_Statement) then if Scope_Id /= Label_Scope then Error_Msg_N @@ -1102,7 +1202,7 @@ package body Sem_Ch5 is Unblocked_Exit_Count := Unblocked_Exit_Count + 1; Analyze_And_Resolve (Cond, Any_Boolean); Check_Unset_Reference (Cond); - Check_Possible_Current_Value_Condition (Cnode); + Set_Current_Value_Condition (Cnode); -- If already deleting, then just analyze then statements @@ -1372,8 +1472,8 @@ package body Sem_Ch5 is ("ambiguous bounds in range of iteration", R_Copy); Error_Msg_N ("\possible interpretations:", R_Copy); - Error_Msg_NE ("\} ", R_Copy, Found); - Error_Msg_NE ("\} ", R_Copy, It.Typ); + Error_Msg_NE ("\\} ", R_Copy, Found); + Error_Msg_NE ("\\} ", R_Copy, It.Typ); exit; end if; end if; @@ -1392,10 +1492,26 @@ package body Sem_Ch5 is -- If the type of the discrete range is Universal_Integer, then -- the bound's type must be resolved to Integer, and any object - -- used to hold the bound must also have type Integer. + -- used to hold the bound must also have type Integer, unless the + -- literal bounds are constant-folded expressions that carry a user- + -- defined type. if Typ = Universal_Integer then - Typ := Standard_Integer; + if Nkind (Lo) = N_Integer_Literal + and then Present (Etype (Lo)) + and then Scope (Etype (Lo)) /= Standard_Standard + then + Typ := Etype (Lo); + + elsif Nkind (Hi) = N_Integer_Literal + and then Present (Etype (Hi)) + and then Scope (Etype (Hi)) /= Standard_Standard + then + Typ := Etype (Hi); + + else + Typ := Standard_Integer; + end if; end if; Set_Etype (R, Typ); @@ -1486,6 +1602,8 @@ package body Sem_Ch5 is if Present (Cond) then Analyze_And_Resolve (Cond, Any_Boolean); Check_Unset_Reference (Cond); + Set_Current_Value_Condition (N); + return; -- Else we have a FOR loop @@ -1686,8 +1804,9 @@ package body Sem_Ch5 is ---------------------------- procedure Analyze_Loop_Statement (N : Node_Id) is - Id : constant Node_Id := Identifier (N); - Ent : Entity_Id; + Id : constant Node_Id := Identifier (N); + Iter : constant Node_Id := Iteration_Scheme (N); + Ent : Entity_Id; begin if Present (Id) then @@ -1729,11 +1848,165 @@ package body Sem_Ch5 is Kill_Current_Values; New_Scope (Ent); - Analyze_Iteration_Scheme (Iteration_Scheme (N)); + Analyze_Iteration_Scheme (Iter); Analyze_Statements (Statements (N)); Process_End_Label (N, 'e', Ent); End_Scope; Kill_Current_Values; + + -- Check for possible infinite loop which we can diagnose successfully. + -- The case we look for is a while loop which tests a local variable, + -- where there is no obvious direct or indirect update of the variable + -- within the body of the loop. + + -- Note: we don't try to give a warning if condition actions are + -- present, since the loop structure can be very complex in this case. + + if No (Iter) + or else No (Condition (Iter)) + or else Present (Condition_Actions (Iter)) + or else Debug_Flag_Dot_W + then + return; + end if; + + -- Initial conditions met, see if condition is of right form + + declare + Cond : constant Node_Id := Condition (Iter); + Var : Entity_Id; + Loc : Node_Id; + + begin + -- Condition is a direct variable reference + + if Is_Entity_Name (Cond) + and then not Is_Library_Level_Entity (Entity (Cond)) + then + Loc := Cond; + + -- Case of condition is a comparison with compile time known value + + elsif Nkind (Cond) in N_Op_Compare then + if Is_Entity_Name (Left_Opnd (Cond)) + and then Compile_Time_Known_Value (Right_Opnd (Cond)) + then + Loc := Left_Opnd (Cond); + + elsif Is_Entity_Name (Right_Opnd (Cond)) + and then Compile_Time_Known_Value (Left_Opnd (Cond)) + then + Loc := Right_Opnd (Cond); + + else + return; + end if; + + -- Case of condition is function call with one parameter + + elsif Nkind (Cond) = N_Function_Call then + declare + PA : constant List_Id := Parameter_Associations (Cond); + begin + if Present (PA) + and then List_Length (PA) = 1 + and then Is_Entity_Name (First (PA)) + then + Loc := First (PA); + else + return; + end if; + end; + + else + return; + end if; + + -- If we fall through Loc is set to the node that is an entity ref + + Var := Entity (Loc); + + if Present (Var) + and then Ekind (Var) = E_Variable + and then not Is_Library_Level_Entity (Var) + and then Comes_From_Source (Var) + then + null; + else + return; + end if; + + -- Search for reference to variable in loop + + Ref_Search : declare + function Test_Ref (N : Node_Id) return Traverse_Result; + -- Test for reference to variable in question. Returns Abandon + -- if matching reference found. + + function Find_Ref is new Traverse_Func (Test_Ref); + -- Function to traverse body of procedure. Returns Abandon if + -- matching reference found. + + -------------- + -- Test_Ref -- + -------------- + + function Test_Ref (N : Node_Id) return Traverse_Result is + begin + -- Waste of time to look at iteration scheme + + if N = Iter then + return Skip; + + -- Direct reference to variable in question + + elsif Is_Entity_Name (N) + and then Present (Entity (N)) + and then Entity (N) = Var + and then May_Be_Lvalue (N) + then + return Abandon; + + -- Reference to variable renaming variable in question + + elsif Is_Entity_Name (N) + and then Present (Entity (N)) + and then Ekind (Entity (N)) = E_Variable + and then Present (Renamed_Object (Entity (N))) + and then Is_Entity_Name (Renamed_Object (Entity (N))) + and then Entity (Renamed_Object (Entity (N))) = Var + and then May_Be_Lvalue (N) + then + return Abandon; + + -- Check for call to other than library level subprogram + + elsif Nkind (N) = N_Procedure_Call_Statement + or else Nkind (N) = N_Function_Call + then + if not Is_Entity_Name (Name (N)) + or else not Is_Library_Level_Entity (Entity (Name (N))) + then + return Abandon; + end if; + end if; + + -- All OK, continue scan + + return OK; + end Test_Ref; + + -- Start of processing for Ref_Search + + begin + if Find_Ref (N) = OK then + Error_Msg_NE + ("variable& is not modified in loop body?", Loc, Var); + Error_Msg_N + ("\possible infinite loop", Loc); + end if; + end Ref_Search; + end; end Analyze_Loop_Statement; ---------------------------- @@ -1823,72 +2096,6 @@ package body Sem_Ch5 is end loop; end Analyze_Statements; - -------------------------------------------- - -- Check_Possible_Current_Value_Condition -- - -------------------------------------------- - - procedure Check_Possible_Current_Value_Condition (Cnode : Node_Id) is - Cond : Node_Id; - - begin - -- Loop to deal with (ignore for now) any NOT operators present - - Cond := Condition (Cnode); - while Nkind (Cond) = N_Op_Not loop - Cond := Right_Opnd (Cond); - end loop; - - -- Check possible relational operator - - if Nkind (Cond) = N_Op_Eq - or else - Nkind (Cond) = N_Op_Ne - or else - Nkind (Cond) = N_Op_Ge - or else - Nkind (Cond) = N_Op_Le - or else - Nkind (Cond) = N_Op_Gt - or else - Nkind (Cond) = N_Op_Lt - then - if Compile_Time_Known_Value (Right_Opnd (Cond)) - and then Nkind (Left_Opnd (Cond)) = N_Identifier - then - declare - Ent : constant Entity_Id := Entity (Left_Opnd (Cond)); - - begin - if Ekind (Ent) = E_Variable - or else - Ekind (Ent) = E_Constant - or else - Is_Formal (Ent) - or else - Ekind (Ent) = E_Loop_Parameter - then - -- Here we have a case where the Current_Value field - -- may need to be set. We set it if it is not already - -- set to a compile time expression value. - - -- Note that this represents a decision that one - -- condition blots out another previous one. That's - -- certainly right if they occur at the same level. - -- If the second one is nested, then the decision is - -- neither right nor wrong (it would be equally OK - -- to leave the outer one in place, or take the new - -- inner one. Really we should record both, but our - -- data structures are not that elaborate. - - if Nkind (Current_Value (Ent)) not in N_Subexpr then - Set_Current_Value (Ent, Cnode); - end if; - end if; - end; - end if; - end if; - end Check_Possible_Current_Value_Condition; - ---------------------------- -- Check_Unreachable_Code -- ---------------------------- diff --git a/gcc/ada/sem_ch5.ads b/gcc/ada/sem_ch5.ads index 0ea538eb118..47358830c56 100644 --- a/gcc/ada/sem_ch5.ads +++ b/gcc/ada/sem_ch5.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2005, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2006, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -47,15 +47,6 @@ package Sem_Ch5 is -- care of setting Reachable, since labels defined by the expander can -- be assumed to be reachable. - procedure Check_Possible_Current_Value_Condition (Cnode : Node_Id); - -- Cnode is N_If_Statement, N_Elsif_Part, or N_Iteration_Scheme - -- (the latter when a WHILE condition is present). This call checks - -- if Condition (Cnode) is of the form ([NOT] var op val), where var - -- is a simple object, val is known at compile time, and op is one - -- of the six relational operators. If this is the case, and the - -- Current_Value field of "var" is not set, then it is set to Cnode. - -- See Exp_Util.Set_Current_Value_Condition for further details. - procedure Check_Unreachable_Code (N : Node_Id); -- This procedure is called with N being the node for a statement that -- is an unconditional transfer of control. It checks to see if the