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 <de...@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.
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 --
-----------------------------
