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