sem_ch5.ads, [...] (Analyze_Loop_Statement): Add circuit to warn on infinite loops.

2006-10-31  Robert Dewar  <dewar@adacore.com>
	    Ed Schonberg  <schonberg@adacore.com>
	    Gary Dismukes  <dismukes@adacore.com>

	* 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

2 files changed, 287 insertions, 89 deletions

diff --git a/gcc/ada/sem_ch5.adb b/gcc/ada/sem_ch5.adb
index 241b838..f74cfa9 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 0ea538e..4735883 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