Subversion Repositories openrisc

------------------------------------------------------------------------------

--                                                                          --

--                         GNAT COMPILER COMPONENTS                         --

--                                                                          --

--                             S E M _ W A R N                              --

--                                                                          --

--                                 B o d y                                  --

--                                                                          --

--          Copyright (C) 1999-2011, 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- --

-- ware  Foundation;  either version 3,  or (at your option) any later ver- --

-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --

-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --

-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --

-- for  more details.  You should have  received  a copy of the GNU General --

-- Public License  distributed with GNAT; see file COPYING3.  If not, go to --

-- http://www.gnu.org/licenses for a complete copy of the license.          --

--                                                                          --

-- GNAT was originally developed  by the GNAT team at  New York University. --

-- Extensive contributions were provided by Ada Core Technologies Inc.      --

--                                                                          --

------------------------------------------------------------------------------

with Atree;    use Atree;

with Debug;    use Debug;

with Einfo;    use Einfo;

with Errout;   use Errout;

with Exp_Code; use Exp_Code;

with Fname;    use Fname;

with Lib;      use Lib;

with Namet;    use Namet;

with Nlists;   use Nlists;

with Opt;      use Opt;

with Par_SCO;  use Par_SCO;

with Rtsfind;  use Rtsfind;

with Sem;      use Sem;

with Sem_Ch8;  use Sem_Ch8;

with Sem_Aux;  use Sem_Aux;

with Sem_Eval; use Sem_Eval;

with Sem_Util; use Sem_Util;

with Sinfo;    use Sinfo;

with Sinput;   use Sinput;

with Snames;   use Snames;

with Stand;    use Stand;

with Stringt;  use Stringt;

with Uintp;    use Uintp;

package body Sem_Warn is

   --  The following table collects Id's of entities that are potentially

   --  unreferenced. See Check_Unset_Reference for further details.

   --  ??? Check_Unset_Reference has zero information about this table.

   package Unreferenced_Entities is new Table.Table (

     Table_Component_Type => Entity_Id,

     Table_Index_Type     => Nat,

     Table_Low_Bound      => 1,

     Table_Initial        => Alloc.Unreferenced_Entities_Initial,

     Table_Increment      => Alloc.Unreferenced_Entities_Increment,

     Table_Name           => "Unreferenced_Entities");

   --  The following table collects potential warnings for IN OUT parameters

   --  that are referenced but not modified. These warnings are processed when

   --  the front end calls the procedure Output_Non_Modified_In_Out_Warnings.

   --  The reason that we defer output of these messages is that we want to

   --  detect the case where the relevant procedure is used as a generic actual

   --  in an instantiation, since we suppress the warnings in this case. The

   --  flag Used_As_Generic_Actual will be set in this case, but only at the

   --  point of usage. Similarly, we suppress the message if the address of the

   --  procedure is taken, where the flag Address_Taken may be set later.

   package In_Out_Warnings is new Table.Table (

     Table_Component_Type => Entity_Id,

     Table_Index_Type     => Nat,

     Table_Low_Bound      => 1,

     Table_Initial        => Alloc.In_Out_Warnings_Initial,

     Table_Increment      => Alloc.In_Out_Warnings_Increment,

     Table_Name           => "In_Out_Warnings");

   --------------------------------------------------------

   -- Handling of Warnings Off, Unmodified, Unreferenced --

   --------------------------------------------------------

   --  The functions Has_Warnings_Off, Has_Unmodified, Has_Unreferenced must

   --  generally be used instead of Warnings_Off, Has_Pragma_Unmodified and

   --  Has_Pragma_Unreferenced, as noted in the specs in Einfo.

   --  In order to avoid losing warnings in -gnatw.w (warn on unnecessary

   --  warnings off pragma) mode, i.e. to avoid false negatives, the code

   --  must follow some important rules.

   --  Call these functions as late as possible, after completing all other

   --  tests, just before the warnings is given. For example, don't write:

   --     if not Has_Warnings_Off (E)

   --       and then some-other-predicate-on-E then ..

   --  Instead the following is preferred

   --     if some-other-predicate-on-E

   --       and then Has_Warnings_Off (E)

   --  This way if some-other-predicate is false, we avoid a false indication

   --  that a Warnings (Off,E) pragma was useful in preventing a warning.

   --  The second rule is that if both Has_Unmodified and Has_Warnings_Off, or

   --  Has_Unreferenced and Has_Warnings_Off are called, make sure that the

   --  call to Has_Unmodified/Has_Unreferenced comes first, this way we record

   --  that the Warnings (Off) could have been Unreferenced or Unmodified. In

   --  fact Has_Unmodified/Has_Unreferenced includes a test for Warnings Off,

   --  and so a subsequent test is not needed anyway (though it is harmless).

   -----------------------

   -- Local Subprograms --

   -----------------------

   function Generic_Package_Spec_Entity (E : Entity_Id) return Boolean;

   --  This returns true if the entity E is declared within a generic package.

   --  The point of this is to detect variables which are not assigned within

   --  the generic, but might be assigned outside the package for any given

   --  instance. These are cases where we leave the warnings to be posted for

   --  the instance, when we will know more.

   function Goto_Spec_Entity (E : Entity_Id) return Entity_Id;

   --  If E is a parameter entity for a subprogram body, then this function

   --  returns the corresponding spec entity, if not, E is returned unchanged.

   function Has_Pragma_Unmodified_Check_Spec (E : Entity_Id) return Boolean;

   --  Tests Has_Pragma_Unmodified flag for entity E. If E is not a formal,

   --  this is simply the setting of the flag Has_Pragma_Unmodified. If E is

   --  a body formal, the setting of the flag in the corresponding spec is

   --  also checked (and True returned if either flag is True).

   function Has_Pragma_Unreferenced_Check_Spec (E : Entity_Id) return Boolean;

   --  Tests Has_Pragma_Unreferenced flag for entity E. If E is not a formal,

   --  this is simply the setting of the flag Has_Pragma_Unreferenced. If E is

   --  a body formal, the setting of the flag in the corresponding spec is

   --  also checked (and True returned if either flag is True).

   function Never_Set_In_Source_Check_Spec (E : Entity_Id) return Boolean;

   --  Tests Never_Set_In_Source status for entity E. If E is not a formal,

   --  this is simply the setting of the flag Never_Set_In_Source. If E is

   --  a body formal, the setting of the flag in the corresponding spec is

   --  also checked (and False returned if either flag is False).

   function Operand_Has_Warnings_Suppressed (N : Node_Id) return Boolean;

   --  This function traverses the expression tree represented by the node N

   --  and determines if any sub-operand is a reference to an entity for which

   --  the Warnings_Off flag is set. True is returned if such an entity is

   --  encountered, and False otherwise.

   function Referenced_Check_Spec (E : Entity_Id) return Boolean;

   --  Tests Referenced status for entity E. If E is not a formal, this is

   --  simply the setting of the flag Referenced. If E is a body formal, the

   --  setting of the flag in the corresponding spec is also checked (and True

   --  returned if either flag is True).

   function Referenced_As_LHS_Check_Spec (E : Entity_Id) return Boolean;

   --  Tests Referenced_As_LHS status for entity E. If E is not a formal, this

   --  is simply the setting of the flag Referenced_As_LHS. If E is a body

   --  formal, the setting of the flag in the corresponding spec is also

   --  checked (and True returned if either flag is True).

   function Referenced_As_Out_Parameter_Check_Spec

     (E : Entity_Id) return Boolean;

   --  Tests Referenced_As_Out_Parameter status for entity E. If E is not a

   --  formal, this is simply the setting of Referenced_As_Out_Parameter. If E

   --  is a body formal, the setting of the flag in the corresponding spec is

   --  also checked (and True returned if either flag is True).

   procedure Warn_On_Unreferenced_Entity

     (Spec_E : Entity_Id;

      Body_E : Entity_Id := Empty);

   --  Output warnings for unreferenced entity E. For the case of an entry

   --  formal, Body_E is the corresponding body entity for a particular

   --  accept statement, and the message is posted on Body_E. In all other

   --  cases, Body_E is ignored and must be Empty.

   function Warnings_Off_Check_Spec (E : Entity_Id) return Boolean;

   --  Returns True if Warnings_Off is set for the entity E or (in the case

   --  where there is a Spec_Entity), Warnings_Off is set for the Spec_Entity.

   --------------------------

   -- Check_Code_Statement --

   --------------------------

   procedure Check_Code_Statement (N : Node_Id) is

   begin

      --  If volatile, nothing to worry about

      if Is_Asm_Volatile (N) then

         return;

      end if;

      --  Warn if no input or no output

      Setup_Asm_Inputs (N);

      if No (Asm_Input_Value) then

         Error_Msg_F

           ("?code statement with no inputs should usually be Volatile!", N);

         return;

      end if;

      Setup_Asm_Outputs (N);

      if No (Asm_Output_Variable) then

         Error_Msg_F

           ("?code statement with no outputs should usually be Volatile!", N);

         return;

      end if;

   end Check_Code_Statement;

   ---------------------------------

   -- Check_Infinite_Loop_Warning --

   ---------------------------------

   --  The case we look for is a while loop which tests a local variable, where

   --  there is no obvious direct or possible indirect update of the variable

   --  within the body of the loop.

   procedure Check_Infinite_Loop_Warning (Loop_Statement : Node_Id) is

      Expression : Node_Id := Empty;

      --  Set to WHILE or EXIT WHEN condition to be tested

      Ref : Node_Id := Empty;

      --  Reference in Expression to variable that might not be modified

      --  in loop, indicating a possible infinite loop.

      Var : Entity_Id := Empty;

      --  Corresponding entity (entity of Ref)

      Function_Call_Found : Boolean := False;

      --  True if Find_Var found a function call in the condition

      procedure Find_Var (N : Node_Id);

      --  Inspect condition to see if it depends on a single entity reference.

      --  If so, Ref is set to point to the reference node, and Var is set to

      --  the referenced Entity.

      function Has_Indirection (T : Entity_Id) return Boolean;

      --  If the controlling variable is an access type, or is a record type

      --  with access components, assume that it is changed indirectly and

      --  suppress the warning. As a concession to low-level programming, in

      --  particular within Declib, we also suppress warnings on a record

      --  type that contains components of type Address or Short_Address.

      function Is_Suspicious_Function_Name (E : Entity_Id) return Boolean;

      --  Given an entity name, see if the name appears to have something to

      --  do with I/O or network stuff, and if so, return True. Used to kill

      --  some false positives on a heuristic basis that such functions will

      --  likely have some strange side effect dependencies. A rather funny

      --  kludge, but warning messages are in the heuristics business.

      function Test_Ref (N : Node_Id) return Traverse_Result;

      --  Test for reference to variable in question. Returns Abandon if

      --  matching reference found. Used in instantiation of No_Ref_Found.

      function No_Ref_Found is new Traverse_Func (Test_Ref);

      --  Function to traverse body of procedure. Returns Abandon if matching

      --  reference found.

      --------------

      -- Find_Var --

      --------------

      procedure Find_Var (N : Node_Id) is

      begin

         --  Condition is a direct variable reference

         if Is_Entity_Name (N) then

            Ref := N;

            Var := Entity (Ref);

         --  Case of condition is a comparison with compile time known value

         elsif Nkind (N) in N_Op_Compare then

            if Compile_Time_Known_Value (Right_Opnd (N)) then

               Find_Var (Left_Opnd (N));

            elsif Compile_Time_Known_Value (Left_Opnd (N)) then

               Find_Var (Right_Opnd (N));

            --  Ignore any other comparison

            else

               return;

            end if;

         --  If condition is a negation, check its operand

         elsif Nkind (N) = N_Op_Not then

            Find_Var (Right_Opnd (N));

         --  Case of condition is function call

         elsif Nkind (N) = N_Function_Call then

            Function_Call_Found := True;

            --  Forget it if function name is not entity, who knows what

            --  we might be calling?

            if not Is_Entity_Name (Name (N)) then

               return;

            --  Forget it if function name is suspicious. A strange test

            --  but warning generation is in the heuristics business!

            elsif Is_Suspicious_Function_Name (Entity (Name (N))) then

               return;

            --  Forget it if warnings are suppressed on function entity

            elsif Has_Warnings_Off (Entity (Name (N))) then

               return;

            end if;

            --  OK, see if we have one argument

            declare

               PA : constant List_Id := Parameter_Associations (N);

            begin

               --  One argument, so check the argument

               if Present (PA)

                 and then List_Length (PA) = 1

               then

                  if Nkind (First (PA)) = N_Parameter_Association then

                     Find_Var (Explicit_Actual_Parameter (First (PA)));

                  else

                     Find_Var (First (PA));

                  end if;

               --  Not one argument

               else

                  return;

               end if;

            end;

         --  Any other kind of node is not something we warn for

         else

            return;

         end if;

      end Find_Var;

      ---------------------

      -- Has_Indirection --

      ---------------------

      function Has_Indirection (T : Entity_Id) return Boolean is

         Comp : Entity_Id;

         Rec  : Entity_Id;

      begin

         if Is_Access_Type (T) then

            return True;

         elsif Is_Private_Type (T)

           and then Present (Full_View (T))

           and then Is_Access_Type (Full_View (T))

         then

            return True;

         elsif Is_Record_Type (T) then

            Rec := T;

         elsif Is_Private_Type (T)

           and then Present (Full_View (T))

           and then Is_Record_Type (Full_View (T))

         then

            Rec := Full_View (T);

         else

            return False;

         end if;

         Comp := First_Component (Rec);

         while Present (Comp) loop

            if Is_Access_Type (Etype (Comp))

              or else Is_Descendent_Of_Address (Etype (Comp))

            then

               return True;

            end if;

            Next_Component (Comp);

         end loop;

         return False;

      end Has_Indirection;

      ---------------------------------

      -- Is_Suspicious_Function_Name --

      ---------------------------------

      function Is_Suspicious_Function_Name (E : Entity_Id) return Boolean is

         S : Entity_Id;

         function Substring_Present (S : String) return Boolean;

         --  Returns True if name buffer has given string delimited by non-

         --  alphabetic characters or by end of string. S is lower case.

         -----------------------

         -- Substring_Present --

         -----------------------

         function Substring_Present (S : String) return Boolean is

            Len : constant Natural := S'Length;

         begin

            for J in 1 .. Name_Len - (Len - 1) loop

               if Name_Buffer (J .. J + (Len - 1)) = S

                 and then

                   (J = 1

                     or else Name_Buffer (J - 1) not in 'a' .. 'z')

                 and then

                   (J + Len > Name_Len

                     or else Name_Buffer (J + Len) not in 'a' .. 'z')

               then

                  return True;

               end if;

            end loop;

            return False;

         end Substring_Present;

      --  Start of processing for Is_Suspicious_Function_Name

      begin

         S := E;

         while Present (S) and then S /= Standard_Standard loop

            Get_Name_String (Chars (S));

            if Substring_Present ("io")

              or else Substring_Present ("file")

              or else Substring_Present ("network")

            then

               return True;

            else

               S := Scope (S);

            end if;

         end loop;

         return False;

      end Is_Suspicious_Function_Name;

      --------------

      -- Test_Ref --

      --------------

      function Test_Ref (N : Node_Id) return Traverse_Result is

      begin

         --  Waste of time to look at the expression we are testing

         if N = Expression then

            return Skip;

         --  Direct reference to variable in question

         elsif Is_Entity_Name (N)

           and then Present (Entity (N))

           and then Entity (N) = Var

         then

            --  If this is an lvalue, then definitely abandon, since

            --  this could be a direct modification of the variable.

            if May_Be_Lvalue (N) then

               return Abandon;

            end if;

            --  If we appear in the context of a procedure call, then also

            --  abandon, since there may be issues of non-visible side

            --  effects going on in the call.

            declare

               P : Node_Id;

            begin

               P := N;

               loop

                  P := Parent (P);

                  exit when P = Loop_Statement;

                  --  Abandon if at procedure call, or something strange is

                  --  going on (perhaps a node with no parent that should

                  --  have one but does not?) As always, for a warning we

                  --  prefer to just abandon the warning than get into the

                  --  business of complaining about the tree structure here!

                  if No (P) or else Nkind (P) = N_Procedure_Call_Statement then

                     return Abandon;

                  end if;

               end loop;

            end;

            --  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;

            --  Call to subprogram

         elsif Nkind (N) = N_Procedure_Call_Statement

           or else Nkind (N) = N_Function_Call

         then

            --  If subprogram is within the scope of the entity we are dealing

            --  with as the loop variable, then it could modify this parameter,

            --  so we abandon in this case. In the case of a subprogram that is

            --  not an entity we also abandon. The check for no entity being

            --  present is a defense against previous errors.

            if not Is_Entity_Name (Name (N))

              or else No (Entity (Name (N)))

              or else Scope_Within (Entity (Name (N)), Scope (Var))

            then

               return Abandon;

            end if;

            --  If any of the arguments are of type access to subprogram, then

            --  we may have funny side effects, so no warning in this case.

            declare

               Actual : Node_Id;

            begin

               Actual := First_Actual (N);

               while Present (Actual) loop

                  if Is_Access_Subprogram_Type (Etype (Actual)) then

                     return Abandon;

                  else

                     Next_Actual (Actual);

                  end if;

               end loop;

            end;

         --  Declaration of the variable in question

         elsif Nkind (N) = N_Object_Declaration

           and then Defining_Identifier (N) = Var

         then

            return Abandon;

         end if;

         --  All OK, continue scan

         return OK;

      end Test_Ref;

   --  Start of processing for Check_Infinite_Loop_Warning

   begin

      --  Skip processing if debug flag gnatd.w is set

      if Debug_Flag_Dot_W then

         return;

      end if;

      --  Deal with Iteration scheme present

      declare

         Iter : constant Node_Id := Iteration_Scheme (Loop_Statement);

      begin

         if Present (Iter) then

            --  While iteration

            if 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);

            --  For iteration, do not process, since loop will always terminate

            elsif Present (Loop_Parameter_Specification (Iter)) then

               return;

            end if;

         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 (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

      --  with here.

      if No (Var)

        or else Ekind (Var) /= E_Variable

        or else Is_Library_Level_Entity (Var)

        or else not Comes_From_Source (Var)

        or else Nkind (Parent (Var)) = N_Object_Renaming_Declaration

      then

         return;

      --  Nothing to do if there is some indirection involved (assume that the

      --  designated variable might be modified in some way we don't see).

      --  However, if no function call was found, then we don't care about

      --  indirections, because the condition must be something like "while X

      --  /= null loop", so we don't care if X.all is modified in the loop.

      elsif Function_Call_Found and then Has_Indirection (Etype (Var)) then

         return;

      --  Same sort of thing for volatile variable, might be modified by

      --  some other task or by the operating system in some way.

      elsif Is_Volatile (Var) then

         return;

      end if;

      --  Filter out case of original statement sequence starting with delay.

      --  We assume this is a multi-tasking program and that the condition

      --  is affected by other threads (some kind of busy wait).

      declare

         Fstm : constant Node_Id :=

                  Original_Node (First (Statements (Loop_Statement)));

      begin

         if Nkind (Fstm) = N_Delay_Relative_Statement

           or else Nkind (Fstm) = N_Delay_Until_Statement

         then

            return;

         end if;

      end;

      --  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 No_Ref_Found (Loop_Statement) = OK then

         Error_Msg_NE

           ("?variable& is not modified in loop body!", Ref, Var);

         Error_Msg_N

           ("\?possible infinite loop!", Ref);

      end if;

   end Check_Infinite_Loop_Warning;

   ----------------------------

   -- Check_Low_Bound_Tested --

   ----------------------------

   procedure Check_Low_Bound_Tested (Expr : Node_Id) is

   begin

      if Comes_From_Source (Expr) then

         declare

            L : constant Node_Id := Left_Opnd (Expr);

            R : constant Node_Id := Right_Opnd (Expr);

         begin

            if Nkind (L) = N_Attribute_Reference

              and then Attribute_Name (L) = Name_First

              and then Is_Entity_Name (Prefix (L))

              and then Is_Formal (Entity (Prefix (L)))

            then

               Set_Low_Bound_Tested (Entity (Prefix (L)));

            end if;

            if Nkind (R) = N_Attribute_Reference

              and then Attribute_Name (R) = Name_First

              and then Is_Entity_Name (Prefix (R))

              and then Is_Formal (Entity (Prefix (R)))

            then

               Set_Low_Bound_Tested (Entity (Prefix (R)));

            end if;

         end;

      end if;

   end Check_Low_Bound_Tested;

   ----------------------

   -- Check_References --

   ----------------------

   procedure Check_References (E : Entity_Id; Anod : Node_Id := Empty) is

      E1  : Entity_Id;

      E1T : Entity_Id;

      UR  : Node_Id;

      function Body_Formal

        (E                : Entity_Id;

         Accept_Statement : Node_Id) return Entity_Id;

      --  For an entry formal entity from an entry declaration, find the

      --  corresponding body formal from the given accept statement.

      function Missing_Subunits return Boolean;

      --  We suppress warnings when there are missing subunits, because this

      --  may generate too many false positives: entities in a parent may only

      --  be referenced in one of the subunits. We make an exception for

      --  subunits that contain no other stubs.

      procedure Output_Reference_Error (M : String);

      --  Used to output an error message. Deals with posting the error on the

      --  body formal in the accept case.

      function Publicly_Referenceable (Ent : Entity_Id) return Boolean;

      --  This is true if the entity in question is potentially referenceable

      --  from another unit. This is true for entities in packages that are at

      --  the library level.

      function Warnings_Off_E1 return Boolean;

      --  Return True if Warnings_Off is set for E1, or for its Etype (E1T),

      --  or for the base type of E1T.

      -----------------

      -- Body_Formal --

      -----------------