sem_warn.ads, [...] (Warnings_Off_Pragmas): New table
authorRobert Dewar <dewar@adacore.com>
Wed, 26 Mar 2008 07:42:47 +0000 (08:42 +0100)
committerArnaud Charlet <charlet@gcc.gnu.org>
Wed, 26 Mar 2008 07:42:47 +0000 (08:42 +0100)
2008-03-26  Robert Dewar  <dewar@adacore.com>

* sem_warn.ads, sem_warn.adb (Warnings_Off_Pragmas): New table
(Initialize): New procedure
(Output_Warnings_Off_Warnings): New procedure
(Check_References): Suppress certain msgs if Is_Trivial_Subprogram
(Output_Non_Modifed_In_Out_Warnings): Ditto
(Warn_On_Unreferenced_Entity): Ditto

From-SVN: r133580

gcc/ada/sem_warn.adb
gcc/ada/sem_warn.ads

index 46a6954bc21b3f5a413df0334376b839781761e0..81d866f5645cb8ce45251ae616543cf88a54c6fa 100644 (file)
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 1999-2007, Free Software Foundation, Inc.         --
+--          Copyright (C) 1999-2008, 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- --
@@ -23,7 +23,6 @@
 --                                                                          --
 ------------------------------------------------------------------------------
 
-with Alloc;
 with Atree;    use Atree;
 with Debug;    use Debug;
 with Einfo;    use Einfo;
@@ -44,7 +43,6 @@ with Sinput;   use Sinput;
 with Snames;   use Snames;
 with Stand;    use Stand;
 with Stringt;  use Stringt;
-with Table;
 with Uintp;    use Uintp;
 
 package body Sem_Warn is
@@ -67,9 +65,9 @@ package body Sem_Warn is
    --  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 instantation, since we suppress the warnings in this case. The
-   --  flag Used_As_Generic_Actual will be set in this case, but will not be
-   --  set till later. Similarly, we suppress the message if the address of
-   --  the procedure is taken, where the flag Address_Taken may be set later.
+   --  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,
@@ -79,6 +77,39 @@ package body Sem_Warn is
      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 somme-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 --
    -----------------------
@@ -145,6 +176,10 @@ package body Sem_Warn is
    --  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 --
    --------------------------
@@ -275,15 +310,15 @@ package body Sem_Warn is
             if not Is_Entity_Name (Name (N)) then
                return;
 
-            --  Forget it if warnings are suppressed on function entity
+            --  Forget it if function name is suspicious. A strange test
+            --  but warning generation is in the heuristics business!
 
-            elsif Warnings_Off (Entity (Name (N))) then
+            elsif Is_Suspicious_Function_Name (Entity (Name (N))) then
                return;
 
-               --  Forget it if function name is suspicious. A strange test
-               --  but warning generation is in the heuristics business!
+            --  Forget it if warnings are suppressed on function entity
 
-            elsif Is_Suspicious_Function_Name (Entity (Name (N))) then
+            elsif Has_Warnings_Off (Entity (Name (N))) then
                return;
             end if;
 
@@ -592,6 +627,40 @@ package body Sem_Warn is
       --  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 --
+      -----------------
+
+      function Body_Formal
+        (E                : Entity_Id;
+         Accept_Statement : Node_Id) return Entity_Id
+      is
+         Body_Param : Node_Id;
+         Body_E     : Entity_Id;
+
+      begin
+         --  Loop to find matching parameter in accept statement
+
+         Body_Param := First (Parameter_Specifications (Accept_Statement));
+         while Present (Body_Param) loop
+            Body_E := Defining_Identifier (Body_Param);
+
+            if Chars (Body_E) = Chars (E) then
+               return Body_E;
+            end if;
+
+            Next (Body_Param);
+         end loop;
+
+         --  Should never fall through, should always find a match
+
+         raise Program_Error;
+      end Body_Formal;
+
       ----------------------
       -- Missing_Subunits --
       ----------------------
@@ -634,36 +703,6 @@ package body Sem_Warn is
          end if;
       end Missing_Subunits;
 
-      -----------------
-      -- Body_Formal --
-      -----------------
-
-      function Body_Formal
-        (E                : Entity_Id;
-         Accept_Statement : Node_Id) return Entity_Id
-      is
-         Body_Param : Node_Id;
-         Body_E     : Entity_Id;
-
-      begin
-         --  Loop to find matching parameter in accept statement
-
-         Body_Param := First (Parameter_Specifications (Accept_Statement));
-         while Present (Body_Param) loop
-            Body_E := Defining_Identifier (Body_Param);
-
-            if Chars (Body_E) = Chars (E) then
-               return Body_E;
-            end if;
-
-            Next (Body_Param);
-         end loop;
-
-         --  Should never fall through, should always find a match
-
-         raise Program_Error;
-      end Body_Formal;
-
       ----------------------------
       -- Output_Reference_Error --
       ----------------------------
@@ -790,6 +829,17 @@ package body Sem_Warn is
          end loop;
       end Publicly_Referenceable;
 
+      ---------------------
+      -- Warnings_Off_E1 --
+      ---------------------
+
+      function Warnings_Off_E1 return Boolean is
+      begin
+         return Has_Warnings_Off (E1T)
+           or else Has_Warnings_Off (Base_Type (E1T))
+           or else Warnings_Off_Check_Spec (E1);
+      end Warnings_Off_E1;
+
    --  Start of processing for Check_References
 
    begin
@@ -817,15 +867,11 @@ package body Sem_Warn is
       while Present (E1) loop
          E1T := Etype (E1);
 
-         --  We only look at source entities with warning flag on. We also
-         --  ignore objects whose type or base type has warnings suppressed.
-         --  We also don't issue warnings within instances, since the proper
-         --  place for such warnings is on the template when it is compiled.
+         --  We are only interested in source entities. We also don't issue
+         --  warnings within instances, since the proper place for such
+         --  warnings is on the template when it is compiled.
 
          if Comes_From_Source (E1)
-           and then not Warnings_Off (E1)
-           and then not Warnings_Off (E1T)
-           and then not Warnings_Off (Base_Type (E1T))
            and then Instantiation_Location (Sloc (E1)) = No_Location
          then
             --  We are interested in variables and out/in-out parameters, but
@@ -850,18 +896,9 @@ package body Sem_Warn is
                   UR := Unset_Reference (E1);
                end if;
 
-               --  If the entity is an out parameter of the current subprogram
-               --  body, check the warning status of the parameter in the spec.
-
-               if Is_Formal (E1)
-                 and then Present (Spec_Entity (E1))
-                 and then Warnings_Off (Spec_Entity (E1))
-               then
-                  null;
-
                --  Special processing for access types
 
-               elsif Present (UR)
+               if Present (UR)
                  and then Is_Access_Type (E1T)
                then
                   --  For access types, the only time we made a UR entry was
@@ -872,7 +909,10 @@ package body Sem_Warn is
                   --  assignment of a pointer involving discriminant check
                   --  on the designated object).
 
-                  Error_Msg_NE ("?& may be null!", UR, E1);
+                  if not Warnings_Off_E1 then
+                     Error_Msg_NE ("?& may be null!", UR, E1);
+                  end if;
+
                   goto Continue;
 
                --  Case of variable that could be a constant. Note that we
@@ -916,10 +956,12 @@ package body Sem_Warn is
                           and then not Has_Pragma_Unreferenced_Check_Spec (E1)
                           and then not Has_Pragma_Unmodified_Check_Spec (E1)
                         then
-                           Error_Msg_N
-                             ("?& is not modified, "
-                              & "could be declared constant!",
-                              E1);
+                           if not Warnings_Off_E1 then
+                              Error_Msg_N
+                                ("?& is not modified, "
+                                 & "could be declared constant!",
+                                 E1);
+                           end if;
                         end if;
                      end if;
                   end if;
@@ -959,12 +1001,15 @@ package body Sem_Warn is
                             or else not Is_Fully_Initialized_Type (E1T))
                then
                   --  Do not output complaint about never being assigned a
-                  --  value if a pragma Unreferenced applies to the variable
+                  --  value if a pragma Unmodified applies to the variable
                   --  we are examining, or if it is a parameter, if there is
-                  --  a pragma Unreferenced for the corresponding spec.
+                  --  a pragma Unreferenced for the corresponding spec, of
+                  --  if the type is marked as having unreferenced objects.
+                  --  The last is a little peculiar, but better too few than
+                  --  too many warnings in this situation.
 
-                  if Has_Pragma_Unreferenced_Check_Spec (E1)
-                    or else Has_Pragma_Unreferenced_Objects (E1T)
+                  if Has_Pragma_Unreferenced_Objects (E1T)
+                    or else Has_Pragma_Unmodified_Check_Spec (E1)
                   then
                      null;
 
@@ -985,7 +1030,7 @@ package body Sem_Warn is
                      --  other method to achieve the local effect of a
                      --  modification. On the other hand if the spec and body
                      --  are in the same unit, we are in the package body and
-                     --  there we less  excuse for a junk IN OUT parameter.
+                     --  there we have less excuse for a junk IN OUT parameter.
 
                      if Has_Private_Declaration (E1T)
                        and then Present (Spec_Entity (E1))
@@ -996,8 +1041,8 @@ package body Sem_Warn is
                      --  Suppress warning for any parameter of a dispatching
                      --  operation, since it is quite reasonable to have an
                      --  operation that is overridden, and for some subclasses
-                     --  needs to be IN OUT and for others the parameter does
-                     --  not happen to be assigned.
+                     --  needs the formal to be IN OUT and for others happens
+                     --  not to assign it.
 
                      elsif Is_Dispatching_Operation
                              (Scope (Goto_Spec_Entity (E1)))
@@ -1030,25 +1075,38 @@ package body Sem_Warn is
                   --  Other cases of formals
 
                   elsif Is_Formal (E1) then
-                     if Referenced_Check_Spec (E1) then
-                        if not Has_Pragma_Unmodified_Check_Spec (E1) then
+                     if not Is_Trivial_Subprogram (Scope (E1)) then
+                        if Referenced_Check_Spec (E1) then
+                           if not Has_Pragma_Unmodified_Check_Spec (E1)
+                             and then not Warnings_Off_E1
+                           then
+                              Output_Reference_Error
+                                ("?formal parameter& is read but "
+                                 & "never assigned!");
+                           end if;
+
+                        elsif not Has_Pragma_Unreferenced_Check_Spec (E1)
+                          and then not Warnings_Off_E1
+                        then
                            Output_Reference_Error
-                             ("?formal parameter& is read but "
-                              & "never assigned!");
+                             ("?formal parameter& is not referenced!");
                         end if;
-
-                     else
-                        Output_Reference_Error
-                          ("?formal parameter& is not referenced!");
                      end if;
 
                   --  Case of variable
 
                   else
                      if Referenced (E1) then
-                        Output_Reference_Error
-                          ("?variable& is read but never assigned!");
-                     else
+                        if not Has_Unmodified (E1)
+                          and then not Warnings_Off_E1
+                        then
+                           Output_Reference_Error
+                             ("?variable& is read but never assigned!");
+                        end if;
+
+                     elsif not Has_Unreferenced (E1)
+                       and then not Warnings_Off_E1
+                     then
                         Output_Reference_Error
                           ("?variable& is never read and never assigned!");
                      end if;
@@ -1058,6 +1116,7 @@ package body Sem_Warn is
 
                      if Ekind (E1) = E_Variable
                        and then Present (Hiding_Loop_Variable (E1))
+                       and then not Warnings_Off_E1
                      then
                         Error_Msg_N
                           ("?for loop implicitly declares loop variable!",
@@ -1100,62 +1159,70 @@ package body Sem_Warn is
                   --  are only for functions, and functions do not allow OUT
                   --  parameters.)
 
-                  if Nkind (UR) = N_Simple_Return_Statement
-                    and then not Has_Pragma_Unmodified_Check_Spec (E1)
-                  then
-                     Error_Msg_NE
-                       ("?OUT parameter& not set before return", UR, E1);
+                  if not Is_Trivial_Subprogram (Scope (E1)) then
+                     if Nkind (UR) = N_Simple_Return_Statement
+                       and then not Has_Pragma_Unmodified_Check_Spec (E1)
+                     then
+                        if not Warnings_Off_E1 then
+                           Error_Msg_NE
+                             ("?OUT parameter& not set before return", UR, E1);
+                        end if;
 
-                  --  If the unset reference is prefix of a selected component
-                  --  that comes from source, mention the component as well. If
-                  --  the selected component comes from expansion, all we know
-                  --  is that the entity is not fully initialized at the point
-                  --  of the reference. Locate an unintialized component to get
-                  --  a better error message.
+                        --  If the unset reference is a selected component
+                        --  prefix from source, mention the component as well.
+                        --  If the selected component comes from expansion, all
+                        --  we know is that the entity is not fully initialized
+                        --  at the point of the reference. Locate a random
+                        --  unintialized component to get a better message.
 
-                  elsif Nkind (Parent (UR)) = N_Selected_Component then
-                     Error_Msg_Node_2 := Selector_Name (Parent (UR));
+                     elsif Nkind (Parent (UR)) = N_Selected_Component then
+                        Error_Msg_Node_2 := Selector_Name (Parent (UR));
 
-                     if not Comes_From_Source (Parent (UR)) then
-                        declare
-                           Comp : Entity_Id;
+                        if not Comes_From_Source (Parent (UR)) then
+                           declare
+                              Comp : Entity_Id;
 
-                        begin
-                           Comp := First_Entity (E1T);
-                           while Present (Comp) loop
-                              if Ekind (Comp) = E_Component
-                                and then Nkind (Parent (Comp)) =
-                                                      N_Component_Declaration
-                                and then No (Expression (Parent (Comp)))
-                              then
-                                 Error_Msg_Node_2 := Comp;
-                                 exit;
-                              end if;
+                           begin
+                              Comp := First_Entity (E1T);
+                              while Present (Comp) loop
+                                 if Ekind (Comp) = E_Component
+                                   and then Nkind (Parent (Comp)) =
+                                   N_Component_Declaration
+                                   and then No (Expression (Parent (Comp)))
+                                 then
+                                    Error_Msg_Node_2 := Comp;
+                                    exit;
+                                 end if;
+
+                                 Next_Entity (Comp);
+                              end loop;
+                           end;
+                        end if;
 
-                              Next_Entity (Comp);
-                           end loop;
-                        end;
-                     end if;
+                        --  Issue proper warning. This is a case of referencing
+                        --  a variable before it has been explicitly assigned.
+                        --  For access types, UR was only set for dereferences,
+                        --  so the issue is that the value may be null.
+
+                        if not Is_Trivial_Subprogram (Scope (E1)) then
+                           if not Warnings_Off_E1 then
+                              if Is_Access_Type (Etype (Parent (UR))) then
+                                 Error_Msg_N ("?`&.&` may be null!", UR);
+                              else
+                                 Error_Msg_N
+                                   ("?`&.&` may be referenced before "
+                                    & "it has a value!", UR);
+                              end if;
+                           end if;
+                        end if;
 
-                     --  Issue proper warning. This is a case of referencing
-                     --  a variable before it has been explicitly assigned.
-                     --  For access types, UR was only set for dereferences,
-                     --  so the issue is that the value may be null.
+                        --  All other cases of unset reference active
 
-                     if Is_Access_Type (Etype (Parent (UR))) then
-                        Error_Msg_N ("?`&.&` may be null!", UR);
-                     else
+                     elsif not Warnings_Off_E1 then
                         Error_Msg_N
-                          ("?`&.&` may be referenced before it has a value!",
+                          ("?& may be referenced before it has a value!",
                            UR);
                      end if;
-
-                  --  All other cases of unset reference active
-
-                  else
-                     Error_Msg_N
-                       ("?& may be referenced before it has a value!",
-                        UR);
                   end if;
 
                   goto Continue;
@@ -1163,12 +1230,17 @@ package body Sem_Warn is
             end if;
 
             --  Then check for unreferenced entities. Note that we are only
-            --  interested in entities which do not have the Referenced flag
-            --  set. The Referenced_As_LHS flag is interesting only if the
-            --  Referenced flag is not set.
+            --  interested in entities whose Referenced flag is not set.
 
             if not Referenced_Check_Spec (E1)
 
+               --  If Referenced_As_LHS is set, then that's still interesting
+               --  (potential "assigned but never read" case), but not if we
+               --  have pragma Unreferenced, which cancels this error.
+
+              and then (not Referenced_As_LHS_Check_Spec (E1)
+                          or else not Has_Unreferenced (E1))
+
                --  Check that warnings on unreferenced entities are enabled
 
               and then
@@ -1324,10 +1396,12 @@ package body Sem_Warn is
                      --  The unreferenced entity is E1, but post the warning
                      --  on the body entity for this accept statement.
 
-                     Warn_On_Unreferenced_Entity
-                       (E1, Body_Formal (E1, Accept_Statement => Anod));
+                     if not Warnings_Off_E1 then
+                        Warn_On_Unreferenced_Entity
+                          (E1, Body_Formal (E1, Accept_Statement => Anod));
+                     end if;
 
-                  else
+                  elsif not Warnings_Off_E1 then
                      Unreferenced_Entities.Append (E1);
                   end if;
                end if;
@@ -1343,11 +1417,13 @@ package body Sem_Warn is
               and then Instantiation_Depth (Sloc (E1)) = 0
               and then Warn_On_Redundant_Constructs
             then
-               Unreferenced_Entities.Append (E1);
+               if not Warnings_Off_E1 then
+                  Unreferenced_Entities.Append (E1);
 
                --  Force warning on entity
 
-               Set_Referenced (E1, False);
+                  Set_Referenced (E1, False);
+               end if;
             end if;
          end if;
 
@@ -1478,7 +1554,8 @@ package body Sem_Warn is
                             or else
                               Earlier_In_Extended_Unit
                                 (Sloc (N),  Sloc (Unset_Reference (E))))
-                 and then not Warnings_Off (E)
+                 and then not Has_Pragma_Unmodified_Check_Spec (E)
+                 and then not Warnings_Off_Check_Spec (E)
                then
                   --  We may have an unset reference. The first test is whether
                   --  this is an access to a discriminant of a record or a
@@ -1967,7 +2044,7 @@ package body Sem_Warn is
                --  is explicitly marked by a pragma Unreferenced).
 
                if not Referenced (Lunit)
-                 and then not Has_Pragma_Unreferenced (Lunit)
+                 and then not Has_Unreferenced (Lunit)
                then
                   --  Suppress warnings in internal units if not in -gnatg mode
                   --  (these would be junk warnings for an application program,
@@ -2060,8 +2137,8 @@ package body Sem_Warn is
                            --  Else give the warning
 
                            else
-                              if not Has_Pragma_Unreferenced
-                                       (Entity (Name (Item)))
+                              if not
+                                Has_Unreferenced (Entity (Name (Item)))
                               then
                                  Error_Msg_N
                                    ("?no entities of & are referenced!",
@@ -2076,8 +2153,8 @@ package body Sem_Warn is
                               Pack := Find_Package_Renaming (Munite, Lunit);
 
                               if Present (Pack)
-                                and then not Warnings_Off (Lunit)
-                                and then not Has_Pragma_Unreferenced (Pack)
+                                and then not Has_Warnings_Off (Lunit)
+                                and then not Has_Unreferenced (Pack)
                               then
                                  Error_Msg_NE
                                    ("?no entities of & are referenced!",
@@ -2276,11 +2353,16 @@ package body Sem_Warn is
    is
    begin
       if Is_Formal (E) and then Present (Spec_Entity (E)) then
-         return Has_Pragma_Unmodified (E)
-                  or else
-                Has_Pragma_Unmodified (Spec_Entity (E));
+
+         --  Note: use of OR instead of OR ELSE here is deliberate, we want
+         --  to mess with Unmodified flags on both body and spec entities.
+
+         return Has_Unmodified (E)
+                  or
+                Has_Unmodified (Spec_Entity (E));
+
       else
-         return Has_Pragma_Unmodified (E);
+         return Has_Unmodified (E);
       end if;
    end Has_Pragma_Unmodified_Check_Spec;
 
@@ -2293,14 +2375,30 @@ package body Sem_Warn is
    is
    begin
       if Is_Formal (E) and then Present (Spec_Entity (E)) then
-         return Has_Pragma_Unreferenced (E)
-                  or else
-                Has_Pragma_Unreferenced (Spec_Entity (E));
+
+         --  Note: use of OR here instead of OR ELSE is deliberate, we want
+         --  to mess with flags on both entities.
+
+         return Has_Unreferenced (E)
+                  or
+                Has_Unreferenced (Spec_Entity (E));
+
       else
-         return Has_Pragma_Unreferenced (E);
+         return Has_Unreferenced (E);
       end if;
    end Has_Pragma_Unreferenced_Check_Spec;
 
+   ----------------
+   -- Initialize --
+   ----------------
+
+   procedure Initialize is
+   begin
+      Warnings_Off_Pragmas.Init;
+      Unreferenced_Entities.Init;
+      In_Out_Warnings.Init;
+   end Initialize;
+
    ------------------------------------
    -- Never_Set_In_Source_Check_Spec --
    ------------------------------------
@@ -2341,7 +2439,7 @@ package body Sem_Warn is
       begin
          if Nkind (R) in N_Has_Entity
            and then Present (Entity (R))
-           and then Warnings_Off (Entity (R))
+           and then Has_Warnings_Off (Entity (R))
          then
             return Abandon;
          else
@@ -2383,16 +2481,33 @@ package body Sem_Warn is
       -----------------------
 
       function No_Warn_On_In_Out (E : Entity_Id) return Boolean is
-         S : constant Entity_Id := Scope (E);
+         S  : constant Entity_Id := Scope (E);
+         SE : constant Entity_Id := Spec_Entity (E);
+
       begin
-         if Warnings_Off (S) then
+         --  Do not warn if address is taken, since funny business may be going
+         --  on in treating the parameter indirectly as IN OUT.
+
+         if Address_Taken (S)
+           or else (Present (SE) and then Address_Taken (Scope (SE)))
+         then
             return True;
-         elsif Address_Taken (S) then
+
+         --  Do not warn if used as a generic actual, since the generic may be
+         --  what is forcing the use of an "unnecessary" IN OUT.
+
+         elsif Used_As_Generic_Actual (S)
+           or else (Present (SE) and then Used_As_Generic_Actual (Scope (SE)))
+         then
             return True;
-         elsif Used_As_Generic_Actual (S) then
+
+         --  Else test warnings off
+
+         elsif Warnings_Off_Check_Spec (S) then
             return True;
-         elsif Present (Spec_Entity (E)) then
-            return No_Warn_On_In_Out (Spec_Entity (E));
+
+         --  All tests for suppressing warning failed
+
          else
             return False;
          end if;
@@ -2411,8 +2526,8 @@ package body Sem_Warn is
             --  Suppress warning in specific cases (see details in comments for
             --  No_Warn_On_In_Out), or if there is a pragma Unmodified.
 
-            if No_Warn_On_In_Out (E1)
-              or else Has_Pragma_Unmodified_Check_Spec (E1)
+            if Has_Pragma_Unmodified_Check_Spec (E1)
+              or else No_Warn_On_In_Out (E1)
             then
                null;
 
@@ -2421,18 +2536,23 @@ package body Sem_Warn is
             else
                --  If -gnatwc is set then output message that we could be IN
 
-               if Warn_On_Constant then
-                  Error_Msg_N ("?formal parameter & is not modified!", E1);
-                  Error_Msg_N ("\?mode could be IN instead of `IN OUT`!", E1);
+               if not Is_Trivial_Subprogram (Scope (E1)) then
+                  if Warn_On_Constant then
+                     Error_Msg_N
+                       ("?formal parameter & is not modified!", E1);
+                     Error_Msg_N
+                       ("\?mode could be IN instead of `IN OUT`!", E1);
 
-               --  We do not generate warnings for IN OUT parameters unless we
-               --  have at least -gnatwu. This is deliberately inconsistent
-               --  with the treatment of variables, but otherwise we get too
-               --  many unexpected warnings in default mode.
+                     --  We do not generate warnings for IN OUT parameters
+                     --  unless we have at least -gnatwu. This is deliberately
+                     --  inconsistent with the treatment of variables, but
+                     --  otherwise we get too many unexpected warnings in
+                     --  default mode.
 
-               elsif Check_Unreferenced then
-                  Error_Msg_N ("?formal parameter& is read but "
-                               & "never assigned!", E1);
+                  elsif Check_Unreferenced then
+                     Error_Msg_N ("?formal parameter& is read but "
+                                  & "never assigned!", E1);
+                  end if;
                end if;
 
                --  Kill any other warnings on this entity, since this is the
@@ -2600,6 +2720,62 @@ package body Sem_Warn is
       end loop;
    end Output_Unreferenced_Messages;
 
+   -----------------------------------------
+   -- Output_Unused_Warnings_Off_Warnings --
+   -----------------------------------------
+
+   procedure Output_Unused_Warnings_Off_Warnings is
+   begin
+      for J in Warnings_Off_Pragmas.First .. Warnings_Off_Pragmas.Last loop
+         declare
+            Wentry : Warnings_Off_Entry renames Warnings_Off_Pragmas.Table (J);
+            N      : Node_Id renames Wentry.N;
+            E      : Node_Id renames Wentry.E;
+
+         begin
+            --  Turn off Warnings_Off, or we won't get the warning!
+
+            Set_Warnings_Off (E, False);
+
+            --  Nothing to do if pragma was used to suppress a general warning
+
+            if Warnings_Off_Used (E) then
+               null;
+
+            --  If pragma was used both in unmodified and unreferenced contexts
+            --  then that's as good as the general case, no warning.
+
+            elsif Warnings_Off_Used_Unmodified (E)
+                    and
+                  Warnings_Off_Used_Unreferenced (E)
+            then
+               null;
+
+            --  Used only in context where Unmodified would have worked
+
+            elsif Warnings_Off_Used_Unmodified (E) then
+               Error_Msg_NE
+                 ("?could use Unmodified instead of "
+                  & "Warnings Off for &", Pragma_Identifier (N), E);
+
+            --  Used only in context where Unreferenced would have worked
+
+            elsif Warnings_Off_Used_Unreferenced (E) then
+               Error_Msg_NE
+                 ("?could use Unreferenced instead of "
+                  & "Warnings Off for &", Pragma_Identifier (N), E);
+
+            --  Not used at all
+
+            else
+               Error_Msg_NE
+                 ("?pragma Warnings Off for & unused, "
+                  & "could be omitted", N, E);
+            end if;
+         end;
+      end loop;
+   end Output_Unused_Warnings_Off_Warnings;
+
    ---------------------------
    -- Referenced_Check_Spec --
    ---------------------------
@@ -2674,6 +2850,12 @@ package body Sem_Warn is
          when 'R' =>
             Warn_On_Object_Renames_Function     := False;
 
+         when 'w' =>
+            Warn_On_Warnings_Off                := True;
+
+         when 'W' =>
+            Warn_On_Warnings_Off                := False;
+
          when 'x' =>
             Warn_On_Non_Local_Exception         := True;
 
@@ -2746,6 +2928,7 @@ package body Sem_Warn is
             Warn_On_Unchecked_Conversion        := False;
             Warn_On_Unrecognized_Pragma         := False;
             Warn_On_Unrepped_Components         := False;
+            Warn_On_Warnings_Off                := False;
 
          when 'b' =>
             Warn_On_Bad_Fixed_Value             := True;
@@ -2997,7 +3180,7 @@ package body Sem_Warn is
             --  node, since assert pragmas get rewritten at analysis time.
 
             elsif Nkind (Original_Node (P)) = N_Pragma
-              and then Chars (Original_Node (P)) = Name_Assert
+              and then Pragma_Name (Original_Node (P)) = Name_Assert
             then
                return;
             end if;
@@ -3100,12 +3283,12 @@ package body Sem_Warn is
          if Is_Array_Type (Typ)
            and then not Is_Constrained (Typ)
            and then Number_Dimensions (Typ) = 1
-           and then not Warnings_Off (Typ)
            and then (Root_Type (Typ) = Standard_String
                        or else
                      Root_Type (Typ) = Standard_Wide_String
                        or else
                      Root_Type (Typ) = Standard_Wide_Wide_String)
+           and then not Has_Warnings_Off (Typ)
          then
             LB := Type_Low_Bound (Etype (First_Index (Typ)));
 
@@ -3412,7 +3595,10 @@ package body Sem_Warn is
       E : Entity_Id := Spec_E;
 
    begin
-      if not Referenced_Check_Spec (E) and then not Warnings_Off (E) then
+      if not Referenced_Check_Spec (E)
+        and then not Has_Pragma_Unreferenced_Check_Spec (E)
+        and then not Warnings_Off_Check_Spec (E)
+      then
          case Ekind (E) is
             when E_Variable =>
 
@@ -3494,8 +3680,12 @@ package body Sem_Warn is
                      if Present (Body_E) then
                         E := Body_E;
                      end if;
-                     Error_Msg_NE
-                       ("?formal parameter & is not referenced!", E, Spec_E);
+
+                     if not Is_Trivial_Subprogram (Scope (E)) then
+                        Error_Msg_NE
+                          ("?formal parameter & is not referenced!",
+                           E, Spec_E);
+                     end if;
                   end if;
                end if;
 
@@ -3585,20 +3775,19 @@ package body Sem_Warn is
       if Is_Assignable (Ent)
         and then not Is_Return_Object (Ent)
         and then Present (Last_Assignment (Ent))
-        and then not Warnings_Off (Ent)
-        and then not Has_Pragma_Unreferenced_Check_Spec (Ent)
         and then not Is_Imported (Ent)
         and then not Is_Exported (Ent)
         and then Safe_To_Capture_Value (N, Ent)
+        and then not Has_Pragma_Unreferenced_Check_Spec (Ent)
       then
          --  Before we issue the message, check covering exception handlers.
-         --  Search up tree for enclosing statement sequences and handlers
+         --  Search up tree for enclosing statement sequences and handlers.
 
          P := Parent (Last_Assignment (Ent));
          while Present (P) loop
 
-            --  Something is really wrong if we don't find a handled
-            --  statement sequence, so just suppress the warning.
+            --  Something is really wrong if we don't find a handled statement
+            --  sequence, so just suppress the warning.
 
             if No (P) then
                Set_Last_Assignment (Ent, Empty);
@@ -3712,4 +3901,24 @@ package body Sem_Warn is
       end if;
    end Warn_On_Useless_Assignments;
 
+   -----------------------------
+   -- Warnings_Off_Check_Spec --
+   -----------------------------
+
+   function Warnings_Off_Check_Spec (E : Entity_Id) return Boolean is
+   begin
+      if Is_Formal (E) and then Present (Spec_Entity (E)) then
+
+         --  Note: use of OR here instead of OR ELSE is deliberate, we want
+         --  to mess with flags on both entities.
+
+         return Has_Warnings_Off (E)
+                  or
+                Has_Warnings_Off (Spec_Entity (E));
+
+      else
+         return Has_Warnings_Off (E);
+      end if;
+   end Warnings_Off_Check_Spec;
+
 end Sem_Warn;
index ae93f5ada6a6d6d7a4ea78686b4650a1021af684..d78bba96ecaf17b9808d583594dd573c04bded04 100644 (file)
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 S p e c                                  --
 --                                                                          --
---          Copyright (C) 1999-2007, Free Software Foundation, Inc.         --
+--          Copyright (C) 1999-2008, 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- --
 --  about uses of uninitialized variables and unused with's. It also has
 --  some unrelated routines related to the generation of warnings.
 
+with Alloc; use Alloc;
+with Table;
 with Types; use Types;
 
 package Sem_Warn is
 
+   ------------------------
+   -- Warnings Off Table --
+   ------------------------
+
+   type Warnings_Off_Entry is record
+      N : Node_Id;
+      --  A pragma Warnings (Off, ent) node
+
+      E : Entity_Id;
+      --  The entity involved
+   end record;
+
+   --  An entry is made in the following table for any valid Pragma Warnings
+   --  (Off, entity) encountered while Opt.Warn_On_Warnings_Off is True. It
+   --  is used to generate warnings on any of these pragmas that turn out not
+   --  to be needed, or that could be replaced by Unmodified/Unreferenced.
+
+   package Warnings_Off_Pragmas is new Table.Table (
+     Table_Component_Type => Warnings_Off_Entry,
+     Table_Index_Type     => Int,
+     Table_Low_Bound      => 0,
+     Table_Initial        => Alloc.Warnings_Off_Pragmas_Initial,
+     Table_Increment      => Alloc.Warnings_Off_Pragmas_Increment,
+     Table_Name           => "Name_Warnings_Off_Pragmas");
+
    --------------------
    -- Initialization --
    --------------------
 
+   procedure Initialize;
+   --  Initialize this package for new compilation
+
    function Set_Warning_Switch (C : Character) return Boolean;
    --  This function sets the warning switch or switches corresponding to the
    --  given character. It is used to process a -gnatw switch on the command
@@ -121,6 +151,12 @@ package Sem_Warn is
    --  the compilation process (see Check_Unset_Reference for further
    --  details). This procedure outputs waiting warnings, if any.
 
+   procedure Output_Unused_Warnings_Off_Warnings;
+   --  Warnings about pragma Warnings (Off, ent) statements that are unused,
+   --  or could be replaced by Unmodified/Unreferenced pragmas, are collected
+   --  till the end of the compilation process. This procedure outputs waiting
+   --  warnings if any.
+
    ----------------------------
    -- Other Warning Routines --
    ----------------------------