Merge from trunk revision 8dc2499aa62f768c6395c9754b8cabc1ce25c494

1 files changed, 99 insertions, 182 deletions

diff --git a/gcc/ada/lib-xref.adb b/gcc/ada/lib-xref.adb
index 2c3c372..359e006 100644
--- a/gcc/ada/lib-xref.adb
+++ b/gcc/ada/lib-xref.adb
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 1998-2021, Free Software Foundation, Inc.         --
+--          Copyright (C) 1998-2022, 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- --
@@ -415,22 +415,6 @@ package body Lib.Xref is
       --  Get the enclosing entity through renamings, which may come from
       --  source or from the translation of generic instantiations.
 
-      function Is_On_LHS (Node : Node_Id) return Boolean;
-      --  Used to check if a node is on the left hand side of an assignment.
-      --  The following cases are handled:
-      --
-      --   Variable    Node is a direct descendant of left hand side of an
-      --               assignment statement.
-      --
-      --   Prefix      Of an indexed or selected component that is present in
-      --               a subtree rooted by an assignment statement. There is
-      --               no restriction of nesting of components, thus cases
-      --               such as A.B (C).D are handled properly. However a prefix
-      --               of a dereference (either implicit or explicit) is never
-      --               considered as on a LHS.
-      --
-      --   Out param   Same as above cases, but OUT parameter
-
       function OK_To_Set_Referenced return Boolean;
       --  Returns True if the Referenced flag can be set. There are a few
       --  exceptions where we do not want to set this flag, see body for
@@ -499,85 +483,6 @@ package body Lib.Xref is
          end case;
       end Get_Through_Renamings;
 
-      ---------------
-      -- Is_On_LHS --
-      ---------------
-
-      --  ??? There are several routines here and there that perform a similar
-      --      (but subtly different) computation, which should be factored:
-
-      --      Sem_Util.Is_LHS
-      --      Sem_Util.May_Be_Lvalue
-      --      Sem_Util.Known_To_Be_Assigned
-      --      Exp_Ch2.Expand_Entry_Parameter.In_Assignment_Context
-      --      Exp_Smem.Is_Out_Actual
-
-      function Is_On_LHS (Node : Node_Id) return Boolean is
-         N : Node_Id;
-         P : Node_Id;
-         K : Node_Kind;
-
-      begin
-         --  Only identifiers are considered, is this necessary???
-
-         if Nkind (Node) /= N_Identifier then
-            return False;
-         end if;
-
-         --  Immediate return if appeared as OUT parameter
-
-         if Kind = E_Out_Parameter then
-            return True;
-         end if;
-
-         --  Search for assignment statement subtree root
-
-         N := Node;
-         loop
-            P := Parent (N);
-            K := Nkind (P);
-
-            if K = N_Assignment_Statement then
-               return Name (P) = N;
-
-            --  Check whether the parent is a component and the current node is
-            --  its prefix, but return False if the current node has an access
-            --  type, as in that case the selected or indexed component is an
-            --  implicit dereference, and the LHS is the designated object, not
-            --  the access object.
-
-            --  ??? case of a slice assignment?
-
-            elsif (K = N_Selected_Component or else K = N_Indexed_Component)
-              and then Prefix (P) = N
-            then
-               --  Check for access type. First a special test, In some cases
-               --  this is called too early (see comments in Find_Direct_Name),
-               --  at a point where the tree is not fully typed yet. In that
-               --  case we may lack an Etype for N, and we can't check the
-               --  Etype. For now, we always return False in such a case,
-               --  but this is clearly not right in all cases ???
-
-               if No (Etype (N)) then
-                  return False;
-
-               elsif Is_Access_Type (Etype (N)) then
-                  return False;
-
-               --  Access type case dealt with, keep going
-
-               else
-                  N := P;
-               end if;
-
-            --  All other cases, definitely not on left side
-
-            else
-               return False;
-            end if;
-         end loop;
-      end Is_On_LHS;
-
       ---------------------------
       -- OK_To_Set_Referenced --
       ---------------------------
@@ -822,46 +727,32 @@ package body Lib.Xref is
 
       if Set_Ref then
 
-         --  Assignable object appearing on left side of assignment or as
-         --  an out parameter.
+         --  When E itself is an IN OUT parameter mark it referenced
 
          if Is_Assignable (E)
-           and then Is_On_LHS (N)
-           and then Ekind (E) /= E_In_Out_Parameter
+           and then Ekind (E) = E_In_Out_Parameter
+           and then Known_To_Be_Assigned (N)
          then
-            --  For objects that are renamings, just set as simply referenced
-            --  we do not try to do assignment type tracking in this case.
-
-            if Present (Renamed_Object (E)) then
-               Set_Referenced (E);
-
-            --  Out parameter case
-
-            elsif Kind = E_Out_Parameter then
-
-               --  If warning mode for all out parameters is set, or this is
-               --  the only warning parameter, then we want to mark this for
-               --  later warning logic by setting Referenced_As_Out_Parameter
+            Set_Referenced (E);
 
-               if Warn_On_Modified_As_Out_Parameter (Formal) then
-                  Set_Referenced_As_Out_Parameter (E, True);
-                  Set_Referenced_As_LHS (E, False);
+         --  For the case where the entity is on the left hand side of an
+         --  assignment statment, we do nothing here.
 
-               --  For OUT parameter not covered by the above cases, we simply
-               --  regard it as a normal reference (in this case we do not
-               --  want any of the warning machinery for out parameters).
+         --  The processing for Analyze_Assignment_Statement will set the
+         --  Referenced_As_LHS flag.
 
-               else
-                  Set_Referenced (E);
-               end if;
+         elsif Is_Assignable (E)
+           and then Known_To_Be_Assigned (N, Only_LHS => True)
+         then
+            null;
 
-            --  For the left hand of an assignment case, we do nothing here.
-            --  The processing for Analyze_Assignment will set the
-            --  Referenced_As_LHS flag.
+         --  For objects that are renamings, just set as simply referenced.
+         --  We do not try to do assignment type tracking in this case.
 
-            else
-               null;
-            end if;
+         elsif Is_Assignable (E)
+           and then Present (Renamed_Object (E))
+         then
+            Set_Referenced (E);
 
          --  Check for a reference in a pragma that should not count as a
          --  making the variable referenced for warning purposes.
@@ -901,58 +792,75 @@ package body Lib.Xref is
          then
             null;
 
-         --  All other cases
+         --  Out parameter case
 
-         else
-            --  Special processing for IN OUT parameters, where we have an
-            --  implicit assignment to a simple variable.
+         elsif Kind = E_Out_Parameter
+           and then Is_Assignable (E)
+         then
+            --  If warning mode for all out parameters is set, or this is
+            --  the only warning parameter, then we want to mark this for
+            --  later warning logic by setting Referenced_As_Out_Parameter
 
-            if Kind = E_In_Out_Parameter
-              and then Is_Assignable (E)
-            then
-               --  For sure this counts as a normal read reference
+            if Warn_On_Modified_As_Out_Parameter (Formal) then
+               Set_Referenced_As_Out_Parameter (E, True);
+               Set_Referenced_As_LHS (E, False);
+
+            --  For OUT parameter not covered by the above cases, we simply
+            --  regard it as a non-reference.
 
+            else
+               Set_Referenced_As_Out_Parameter (E);
                Set_Referenced (E);
-               Set_Last_Assignment (E, Empty);
+            end if;
 
-               --  We count it as being referenced as an out parameter if the
-               --  option is set to warn on all out parameters, except that we
-               --  have a special exclusion for an intrinsic subprogram, which
-               --  is most likely an instantiation of Unchecked_Deallocation
-               --  which we do not want to consider as an assignment since it
-               --  generates false positives. We also exclude the case of an
-               --  IN OUT parameter if the name of the procedure is Free,
-               --  since we suspect similar semantics.
-
-               if Warn_On_All_Unread_Out_Parameters
-                 and then Is_Entity_Name (Name (Call))
-                 and then not Is_Intrinsic_Subprogram (Entity (Name (Call)))
-                 and then Chars (Name (Call)) /= Name_Free
-               then
-                  Set_Referenced_As_Out_Parameter (E, True);
-                  Set_Referenced_As_LHS (E, False);
-               end if;
+         --  Special processing for IN OUT parameters, where we have an
+         --  implicit assignment to a simple variable.
 
-            --  Don't count a recursive reference within a subprogram as a
-            --  reference (that allows detection of a recursive subprogram
-            --  whose only references are recursive calls as unreferenced).
+         elsif Kind = E_In_Out_Parameter
+           and then Is_Assignable (E)
+         then
+            --  For sure this counts as a normal read reference
 
-            elsif Is_Subprogram (E)
-              and then E = Nearest_Dynamic_Scope (Current_Scope)
+            Set_Referenced (E);
+            Set_Last_Assignment (E, Empty);
+
+            --  We count it as being referenced as an out parameter if the
+            --  option is set to warn on all out parameters, except that we
+            --  have a special exclusion for an intrinsic subprogram, which
+            --  is most likely an instantiation of Unchecked_Deallocation
+            --  which we do not want to consider as an assignment since it
+            --  generates false positives. We also exclude the case of an
+            --  IN OUT parameter if the name of the procedure is Free,
+            --  since we suspect similar semantics.
+
+            if Warn_On_All_Unread_Out_Parameters
+              and then Is_Entity_Name (Name (Call))
+              and then not Is_Intrinsic_Subprogram (Entity (Name (Call)))
+              and then Chars (Name (Call)) /= Name_Free
             then
-               null;
+               Set_Referenced_As_Out_Parameter (E, True);
+               Set_Referenced_As_LHS (E, False);
+            end if;
 
-            --  Any other occurrence counts as referencing the entity
+         --  Don't count a recursive reference within a subprogram as a
+         --  reference (that allows detection of a recursive subprogram
+         --  whose only references are recursive calls as unreferenced).
 
-            elsif OK_To_Set_Referenced then
-               Set_Referenced (E);
+         elsif Is_Subprogram (E)
+           and then E = Nearest_Dynamic_Scope (Current_Scope)
+         then
+            null;
 
-               --  If variable, this is an OK reference after an assignment
-               --  so we can clear the Last_Assignment indication.
+         --  Any other occurrence counts as referencing the entity
 
-               if Is_Assignable (E) then
-                  Set_Last_Assignment (E, Empty);
-               end if;
+         elsif OK_To_Set_Referenced then
+            Set_Referenced (E);
+
+            --  If variable, this is an OK reference after an assignment
+            --  so we can clear the Last_Assignment indication.
+
+            if Is_Assignable (E) then
+               Set_Last_Assignment (E, Empty);
             end if;
          end if;
 
@@ -965,7 +873,7 @@ package body Lib.Xref is
            and then In_Same_Extended_Unit (E, N)
          then
             --  A reference as a named parameter in a call does not count as a
-            --  violation of pragma Unreferenced for this purpose...
+            --  violation of pragma Unreferenced for this purpose.
 
             if Nkind (N) = N_Identifier
               and then Nkind (Parent (N)) = N_Parameter_Association
@@ -973,10 +881,24 @@ package body Lib.Xref is
             then
                null;
 
-            --  ... Neither does a reference to a variable on the left side of
-            --  an assignment.
-
-            elsif Is_On_LHS (N) then
+            --  Neither does a reference to a variable on the left side of
+            --  an assignment or use of an out parameter with warnings for
+            --  unread out parameters specified (via -gnatw.o).
+
+            --  The reason for treating unread out parameters in a special
+            --  way is so that when pragma Unreferenced is specified on such
+            --  an out parameter we do not want to issue a warning about the
+            --  pragma being unnecessary - because the purpose of the flag
+            --  is to warn about them not being read (e.g. unreferenced)
+            --  after use.
+
+            elsif (Known_To_Be_Assigned (N, Only_LHS => True)
+                    or else (Present (Formal)
+                              and then Ekind (Formal) = E_Out_Parameter
+                              and then Warn_On_All_Unread_Out_Parameters))
+              and then not (Ekind (E) = E_In_Out_Parameter
+                             and then Known_To_Be_Assigned (N))
+            then
                null;
 
             --  Do not consider F'Result as a violation of pragma Unreferenced
@@ -1755,7 +1677,7 @@ package body Lib.Xref is
       --  declared in the main unit.
 
       Handle_Prim_Ops : declare
-         Ent  : Entity_Id;
+         Ent : Entity_Id;
 
       begin
          for J in 1 .. Xrefs.Last loop
@@ -2841,18 +2763,13 @@ package body Lib.Xref is
             D : Deferred_Reference_Entry renames Deferred_References.Table (J);
 
          begin
-            case Is_LHS (D.N) is
-               when Yes =>
+            case Known_To_Be_Assigned (D.N) is
+               when True =>
                   Generate_Reference (D.E, D.N, 'm');
 
-               when No =>
+               when False =>
                   Generate_Reference (D.E, D.N, 'r');
 
-               --  Not clear if Unknown can occur at this stage, but if it
-               --  does we will treat it as a normal reference.
-
-               when Unknown =>
-                  Generate_Reference (D.E, D.N, 'r');
             end case;
          end;
       end loop;