[Ada] Fix problem with misclassification of references

Arnaud Charlet charlet@adacore.com
Fri Jan 31 15:43:00 GMT 2014


This patch fixes a problem in the compiler of confusing references
with modifications in the xref listing. This is now fixed properly.
The following program

     1. procedure TooManyXrefs is
     2.    type r is record
     3.       a : integer;
     4.    end record;
     5.    type v is array (1 .. 10) of r;
     6.    vv : v;
     7. begin
     8.    vv (3).a := 2;
     9.    TooManyXrefs.vv (3).a := 2;
    10. end TooManyXrefs;

Should generate only three references to vv:

6a4 vv{5A9} 8m4 9m17

i.e. the definition and the two references, previously it generated
five references.

Tested on x86_64-pc-linux-gnu, committed on trunk

2014-01-31  Robert Dewar  <dewar@adacore.com>

	* exp_ch2.adb: New calling sequence for Is_LHS.
	* frontend.adb: Add call to Process_Deferred_References.
	* lib-xref.ads, lib-xref.adb (Process_Deferred_References): New.
	(Deferred_References): New table.
	* sem_ch8.adb (Find_Direct_Name): Make deferred reference table
	entries.
	(Find_Expanded_Name): Ditto.
	* sem_res.adb: New calling sequence for Is_LHS.
	* sem_util.ads, sem_util.adb (Is_LHS): New calling sequence.
	* sem_warn.adb: Call Process_Deferred_References before issuing
	warnings.

-------------- next part --------------
Index: frontend.adb
===================================================================
--- frontend.adb	(revision 207348)
+++ frontend.adb	(working copy)
@@ -36,6 +36,7 @@
 with Inline;   use Inline;
 with Lib;      use Lib;
 with Lib.Load; use Lib.Load;
+with Lib.Xref; use Lib.Xref;
 with Live;     use Live;
 with Namet;    use Namet;
 with Nlists;   use Nlists;
@@ -392,6 +393,7 @@
 
          --  Output waiting warning messages
 
+         Lib.Xref.Process_Deferred_References;
          Sem_Warn.Output_Non_Modified_In_Out_Warnings;
          Sem_Warn.Output_Unreferenced_Messages;
          Sem_Warn.Check_Unused_Withs;
Index: sem_util.adb
===================================================================
--- sem_util.adb	(revision 207348)
+++ sem_util.adb	(working copy)
@@ -5587,7 +5587,8 @@
       --  we exclude overloaded calls, since we don't know enough to be sure
       --  of giving the right answer in this case.
 
-      if Is_Entity_Name (Name (Call))
+      if Nkind_In (Call, N_Function_Call, N_Procedure_Call_Statement)
+        and then Is_Entity_Name (Name (Call))
         and then Present (Entity (Name (Call)))
         and then Is_Overloadable (Entity (Name (Call)))
         and then not Is_Overloaded (Name (Call))
@@ -9982,14 +9983,18 @@
    --  We seem to have a lot of overlapping functions that do similar things
    --  (testing for left hand sides or lvalues???).
 
-   function Is_LHS (N : Node_Id) return Boolean is
+   function Is_LHS (N : Node_Id) return Is_LHS_Result is
       P : constant Node_Id := Parent (N);
 
    begin
       --  Return True if we are the left hand side of an assignment statement
 
       if Nkind (P) = N_Assignment_Statement then
-         return Name (P) = N;
+         if Name (P) = N then
+            return Yes;
+         else
+            return No;
+         end if;
 
       --  Case of prefix of indexed or selected component or slice
 
@@ -10002,23 +10007,16 @@
          --  what we really have is N.all.Q (or N.all(Q .. R)). In either
          --  case this makes N.all a left hand side but not N itself.
 
-         --  Here follows a worrisome kludge. If Etype (N) is not set, which
-         --  for sure happens in the call from Find_Direct_Name, that means we
-         --  don't know if N is of an access type, so we can't give an accurate
-         --  answer. For now, we assume we do not have an access type, which
-         --  means for example that P.Q.R := X will look like a modification
-         --  of P, even if P.Q eventually turns out to be an access type. The
-         --  consequence is at least that in some cases we incorrectly identify
-         --  a reference as a modification. It is not clear if there are any
-         --  other bad consequences. ???
+         --  If we don't know the type yet, this is the case where we return
+         --  Unknown, since the answer depends on the type which is unknown.
 
          if No (Etype (N)) then
-            return False;
+            return Unknown;
 
          --  We have an Etype set, so we can check it
 
          elsif Is_Access_Type (Etype (N)) then
-            return False;
+            return No;
 
          --  OK, not access type case, so just test whole expression
 
@@ -10029,7 +10027,7 @@
       --  All other cases are not left hand sides
 
       else
-         return False;
+         return No;
       end if;
    end Is_LHS;
 
Index: sem_util.ads
===================================================================
--- sem_util.ads	(revision 207348)
+++ sem_util.ads	(working copy)
@@ -1164,8 +1164,15 @@
    --  AI05-0139-2: Check whether Typ is one of the predefined interfaces in
    --  Ada.Iterator_Interfaces, or it is derived from one.
 
-   function Is_LHS (N : Node_Id) return Boolean;
-   --  Returns True iff N is used as Name in an assignment statement
+   type Is_LHS_Result is (Yes, No, Unknown);
+   function Is_LHS (N : Node_Id) return Is_LHS_Result;
+   --  Returns Yes if N is definitely used as Name in an assignment statement.
+   --  Returns No if N is definitely NOT used as a Name in an assignment
+   --  statement. Returns Unknown if we can't tell at this stage (happens in
+   --  the case where we don't know the type of N yet, and we have something
+   --  like N.A := 3, where this counts as N being used on the left side of
+   --  an assignment only if N is not an access type. If it is an access type
+   --  then it is N.all.A that is assigned, not N.
 
    function Is_Library_Level_Entity (E : Entity_Id) return Boolean;
    --  A library-level declaration is one that is accessible from Standard,
Index: sem_res.adb
===================================================================
--- sem_res.adb	(revision 207348)
+++ sem_res.adb	(working copy)
@@ -7673,7 +7673,7 @@
                    or else (Is_Entity_Name (Prefix (N))
                              and then Is_Atomic (Entity (Prefix (N)))))
         and then Is_Bit_Packed_Array (Array_Type)
-        and then Is_LHS (N)
+        and then Is_LHS (N) = Yes
       then
          Error_Msg_N ("??assignment to component of packed atomic array",
                       Prefix (N));
@@ -9170,7 +9170,7 @@
                    or else (Is_Entity_Name (Prefix (N))
                              and then Is_Atomic (Entity (Prefix (N)))))
         and then Is_Packed (T)
-        and then Is_LHS (N)
+        and then Is_LHS (N) = Yes
       then
          Error_Msg_N
            ("??assignment to component of packed atomic record", Prefix (N));
Index: exp_ch2.adb
===================================================================
--- exp_ch2.adb	(revision 207348)
+++ exp_ch2.adb	(working copy)
@@ -380,7 +380,7 @@
         and then Is_Scalar_Type (Etype (N))
         and then (Is_Assignable (E) or else Is_Constant_Object (E))
         and then Comes_From_Source (N)
-        and then not Is_LHS (N)
+        and then Is_LHS (N) = No
         and then not Is_Actual_Out_Parameter (N)
         and then (Nkind (Parent (N)) /= N_Attribute_Reference
                    or else Attribute_Name (Parent (N)) /= Name_Valid)
Index: sem_ch8.adb
===================================================================
--- sem_ch8.adb	(revision 207348)
+++ sem_ch8.adb	(working copy)
@@ -5152,29 +5152,29 @@
 
             --  Normal case, not a label: generate reference
 
-            --    ??? It is too early to generate a reference here even if the
-            --    entity is unambiguous, because the tree is not sufficiently
-            --    typed at this point for Generate_Reference to determine
-            --    whether this reference modifies the denoted object (because
-            --    implicit dereferences cannot be identified prior to full type
-            --    resolution).
+            else
+               if not Is_Actual_Parameter then
 
-            --    The Is_Actual_Parameter routine takes care of one of these
-            --    cases but there are others probably ???
+                  --  Package or generic package is always a simple reference
 
-            --    If the entity is the LHS of an assignment, and is a variable
-            --    (rather than a package prefix), we can mark it as a
-            --    modification right away, to avoid duplicate references.
+                  if Ekind_In (E, E_Package, E_Generic_Package) then
+                     Generate_Reference (E, N, 'r');
 
-            else
-               if not Is_Actual_Parameter then
-                  if Is_LHS (N)
-                    and then Ekind (E) /= E_Package
-                    and then Ekind (E) /= E_Generic_Package
-                  then
-                     Generate_Reference (E, N, 'm');
+                  --  Else see if we have a left hand side
+
                   else
-                     Generate_Reference (E, N);
+                     case Is_LHS (N) is
+                        when Yes =>
+                           Generate_Reference (E, N, 'm');
+
+                        when No =>
+                           Generate_Reference (E, N, 'r');
+
+                        --  If we don't know now, generate reference later
+
+                     when Unknown =>
+                        Deferred_References.Append ((E, N));
+                     end case;
                   end if;
                end if;
 
@@ -5655,28 +5655,34 @@
 
       Change_Selected_Component_To_Expanded_Name (N);
 
+      --  Set appropriate type
+
+      if Is_Type (Id) then
+         Set_Etype (N, Id);
+      else
+         Set_Etype (N, Get_Full_View (Etype (Id)));
+      end if;
+
       --  Do style check and generate reference, but skip both steps if this
       --  entity has homonyms, since we may not have the right homonym set yet.
       --  The proper homonym will be set during the resolve phase.
 
       if Has_Homonym (Id) then
          Set_Entity (N, Id);
+
       else
          Set_Entity_Or_Discriminal (N, Id);
 
-         if Is_LHS (N) then
-            Generate_Reference (Id, N, 'm');
-         else
-            Generate_Reference (Id, N);
-         end if;
+         case Is_LHS (N) is
+            when Yes =>
+               Generate_Reference (Id, N, 'm');
+            when No =>
+               Generate_Reference (Id, N, 'r');
+            when Unknown =>
+               Deferred_References.Append ((Id, N));
+         end case;
       end if;
 
-      if Is_Type (Id) then
-         Set_Etype (N, Id);
-      else
-         Set_Etype (N, Get_Full_View (Etype (Id)));
-      end if;
-
       --  Check for violation of No_Wide_Characters
 
       Check_Wide_Character_Restriction (Id, N);
Index: sem_warn.adb
===================================================================
--- sem_warn.adb	(revision 207348)
+++ sem_warn.adb	(working copy)
@@ -30,6 +30,7 @@
 with Exp_Code; use Exp_Code;
 with Fname;    use Fname;
 with Lib;      use Lib;
+with Lib.Xref; use Lib.Xref;
 with Namet;    use Namet;
 with Nlists;   use Nlists;
 with Opt;      use Opt;
@@ -998,6 +999,8 @@
    --  Start of processing for Check_References
 
    begin
+      Process_Deferred_References;
+
       --  No messages if warnings are suppressed, or if we have detected any
       --  real errors so far (this last check avoids junk messages resulting
       --  from errors, e.g. a subunit that is not loaded).
@@ -2566,6 +2569,8 @@
          return;
       end if;
 
+      Process_Deferred_References;
+
       --  Flag any unused with clauses. For a subunit, check only the units
       --  in its context, not those of the parent, which may be needed by other
       --  subunits.  We will get the full warnings when we compile the parent,
Index: lib-xref.adb
===================================================================
--- lib-xref.adb	(revision 207348)
+++ lib-xref.adb	(working copy)
@@ -1705,8 +1705,8 @@
          end loop;
       end Handle_Orphan_Type_References;
 
-      --  Now we have all the references, including those for any embedded
-      --  type references, so we can sort them, and output them.
+      --  Now we have all the references, including those for any embedded type
+      --  references, so we can sort them, and output them.
 
       Output_Refs : declare
 
@@ -2563,6 +2563,38 @@
       end Output_Refs;
    end Output_References;
 
+   ---------------------------------
+   -- Process_Deferred_References --
+   ---------------------------------
+
+   procedure Process_Deferred_References is
+   begin
+      for J in Deferred_References.First .. Deferred_References.Last loop
+         declare
+            D : Deferred_Reference_Entry renames Deferred_References.Table (J);
+
+         begin
+            case Is_LHS (D.N) is
+               when Yes =>
+                  Generate_Reference (D.E, D.N, 'm');
+
+               when No =>
+                  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;
+
+      --  Clear processed entries from table
+
+      Deferred_References.Init;
+   end Process_Deferred_References;
+
 --  Start of elaboration for Lib.Xref
 
 begin
Index: lib-xref.ads
===================================================================
--- lib-xref.ads	(revision 207348)
+++ lib-xref.ads	(working copy)
@@ -600,6 +600,39 @@
    --  Export at line 4, that its body is exported to C, and that the link name
    --  as given in the pragma is "here".
 
+   -------------------------
+   -- Deferred_References --
+   -------------------------
+
+   --  Normally we generate references as we go along, but as discussed in
+   --  Sem_Util.Is_LHS, and Sem_Ch8.Find_Direct_Name/Find_Selected_Component,
+   --  we have one case where that is tricky, which is when we have something
+   --  like X.A := 3, where we don't know until we know the type of X whether
+   --  this is a reference (if X is an access type, so what we really have is
+   --  X.all.A := 3) or a modification, where X is not an access type.
+
+   --  What we do in such cases is to gather nodes, where we would have liked
+   --  to call Generate_Reference but we couldn't because we didn't know enough
+   --  into this table, Then we deal with generating references later on when
+   --  we have sufficient information to do it right.
+
+   type Deferred_Reference_Entry is record
+      E : Entity_Id;
+      N : Node_Id;
+   end record;
+   --  One entry, E, N are as required for Generate_Reference call
+
+   package Deferred_References is new Table.Table (
+     Table_Component_Type => Deferred_Reference_Entry,
+     Table_Index_Type     => Int,
+     Table_Low_Bound      => 0,
+     Table_Initial        => 512,
+     Table_Increment      => 200,
+     Table_Name           => "Name_Deferred_References");
+
+   procedure Process_Deferred_References;
+   --  This procedure is called from Frontend to process these table entries.
+
    -----------------------------
    -- SPARK Xrefs Information --
    -----------------------------


More information about the Gcc-patches mailing list