Skip to content

R
riscv-gcc-1
Commit ecf8118f by Ed Schonberg Committed by Arnaud Charlet
Options

lib-xref.ads, [...]: Modify the loop that collects type references... 

2007-04-06  Ed Schonberg  <schonberg@adacore.com>
	    Javier Miranda  <miranda@adacore.com>

	* lib-xref.ads, lib-xref.adb: 
	Modify the loop that collects type references, to include interface
	types that the type implements. List each of these interfaces when
	building the entry for the type.
	(Generate_Definition): Initialize component Def and Typ of new entry
	in table Xrefs, to avoid to have these components unitialized.
	(Output_References): Split Is_Abstract flag into
	Is_Abstract_Subprogram and Is_Abstract_Type.
	(Generate_Reference): Add barrier to do not generate the warning
	associated with Ada 2005 entities with entities generated by the
	expander.

From-SVN: r123583
parent ff5066d4
Showing with 177 additions and 75 deletions
gcc/ada/lib-xref.adb
......@@ -137,7 +137,9 @@ package body Lib.Xref is
Loc := Original_Location (Sloc (E));
Xrefs.Table (Indx).Ent := E;
Xrefs.Table (Indx).Def := No_Location;
Xrefs.Table (Indx).Loc := No_Location;
Xrefs.Table (Indx).Typ := ' ';
Xrefs.Table (Indx).Eun := Get_Source_Unit (Loc);
Xrefs.Table (Indx).Lun := No_Unit;
Set_Has_Xref_Entry (E);
......@@ -306,7 +308,8 @@ package body Lib.Xref is
-- Warn if reference to Ada 2005 entity not in Ada 2005 mode. We only
-- detect real explicit references (modifications and references).
if Is_Ada_2005_Only (E)
if Comes_From_Source (N)
and then Is_Ada_2005_Only (E)
and then Ada_Version < Ada_05
and then Warn_On_Ada_2005_Compatibility
and then (Typ = 'm' or else Typ = 'r')
......@@ -920,18 +923,18 @@ package body Lib.Xref is
-- referenced in the main unit, which may mean that there is no xref
-- entry for this entity yet in the list of references.
-- If we don't do something about this, we will end with an orphan
-- type reference, i.e. it will point to an entity that does not
-- appear within the generated references in the ali file. That is
-- not good for tools using the xref information.
-- If we don't do something about this, we will end with an orphan type
-- reference, i.e. it will point to an entity that does not appear
-- within the generated references in the ali file. That is not good for
-- tools using the xref information.
-- To fix this, we go through the references adding definition
-- entries for any unreferenced entities that can be referenced
-- in a type reference. There is a recursion problem here, and
-- that is dealt with by making sure that this traversal also
-- traverses any entries that get added by the traversal.
-- To fix this, we go through the references adding definition entries
-- for any unreferenced entities that can be referenced in a type
-- reference. There is a recursion problem here, and that is dealt with
-- by making sure that this traversal also traverses any entries that
-- get added by the traversal.
declare
Handle_Orphan_Type_References : declare
J : Nat;
Tref : Entity_Id;
L, R : Character;
......@@ -939,10 +942,38 @@ package body Lib.Xref is
Ent : Entity_Id;
Loc : Source_Ptr;
procedure New_Entry (E : Entity_Id);
-- Make an additional entry into the Xref table for a type entity
-- that is related to the current entity (parent, type. ancestor,
-- progenitor, etc.).
----------------
-- New_Entry --
----------------
procedure New_Entry (E : Entity_Id) is
begin
if Present (E)
and then not Has_Xref_Entry (E)
and then Sloc (E) > No_Location
then
Xrefs.Increment_Last;
Indx := Xrefs.Last;
Loc := Original_Location (Sloc (E));
Xrefs.Table (Indx).Ent := E;
Xrefs.Table (Indx).Loc := No_Location;
Xrefs.Table (Indx).Eun := Get_Source_Unit (Loc);
Xrefs.Table (Indx).Lun := No_Unit;
Set_Has_Xref_Entry (E);
end if;
end New_Entry;
-- Start of processing for Handle_Orphan_Type_References
begin
-- Note that this is not a for loop for a very good reason. The
-- processing of items in the table can add new items to the
-- table, and they must be processed as well
-- processing of items in the table can add new items to the table,
-- and they must be processed as well
J := 1;
while J <= Xrefs.Last loop
......@@ -953,14 +984,25 @@ package body Lib.Xref is
and then not Has_Xref_Entry (Tref)
and then Sloc (Tref) > No_Location
then
Xrefs.Increment_Last;
Indx := Xrefs.Last;
Loc := Original_Location (Sloc (Tref));
Xrefs.Table (Indx).Ent := Tref;
Xrefs.Table (Indx).Loc := No_Location;
Xrefs.Table (Indx).Eun := Get_Source_Unit (Loc);
Xrefs.Table (Indx).Lun := No_Unit;
Set_Has_Xref_Entry (Tref);
New_Entry (Tref);
if Is_Record_Type (Ent)
and then Present (Abstract_Interfaces (Ent))
then
-- Add an entry for each one of the given interfaces
-- implemented by type Ent.
declare
Elmt : Elmt_Id;
begin
Elmt := First_Elmt (Abstract_Interfaces (Ent));
while Present (Elmt) loop
New_Entry (Node (Elmt));
Next_Elmt (Elmt);
end loop;
end;
end if;
end if;
-- Collect inherited primitive operations that may be
......@@ -1021,7 +1063,7 @@ package body Lib.Xref is
J := J + 1;
end loop;
end;
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.
......@@ -1228,6 +1270,15 @@ package body Lib.Xref is
Right : Character;
-- Used for {} or <> or () for type reference
procedure Check_Type_Reference
(Ent : Entity_Id;
List_Interface : Boolean);
-- Find whether there is a meaningful type reference for
-- Ent, and display it accordingly. If List_Interface is
-- true, then Ent is a progenitor interface of the current
-- type entity being listed. In that case list it as is,
-- without looking for a type reference for it.
procedure Output_Instantiation_Refs (Loc : Source_Ptr);
-- Recursive procedure to output instantiation references for
-- the given source ptr in [file|line[...]] form. No output
......@@ -1237,6 +1288,82 @@ package body Lib.Xref is
-- For a subprogram that is overriding, display information
-- about the inherited operation that it overrides.
--------------------------
-- Check_Type_Reference --
--------------------------
procedure Check_Type_Reference
(Ent : Entity_Id;
List_Interface : Boolean)
is
begin
if List_Interface then
-- This is a progenitor interface of the type for
-- which xref information is being generated.
Tref := Ent;
Left := '<';
Right := '>';
else
Get_Type_Reference (Ent, Tref, Left, Right);
end if;
if Present (Tref) then
-- Case of standard entity, output name
if Sloc (Tref) = Standard_Location then
Write_Info_Char (Left);
Write_Info_Name (Chars (Tref));
Write_Info_Char (Right);
-- Case of source entity, output location
else
Write_Info_Char (Left);
Trunit := Get_Source_Unit (Sloc (Tref));
if Trunit /= Curxu then
Write_Info_Nat (Dependency_Num (Trunit));
Write_Info_Char ('|');
end if;
Write_Info_Nat
(Int (Get_Logical_Line_Number (Sloc (Tref))));
declare
Ent : Entity_Id := Tref;
Kind : constant Entity_Kind := Ekind (Ent);
Ctyp : Character := Xref_Entity_Letters (Kind);
begin
if Ctyp = '+'
and then Present (Full_View (Ent))
then
Ent := Underlying_Type (Ent);
if Present (Ent) then
Ctyp := Xref_Entity_Letters (Ekind (Ent));
end if;
end if;
Write_Info_Char (Ctyp);
end;
Write_Info_Nat
(Int (Get_Column_Number (Sloc (Tref))));
-- If the type comes from an instantiation,
-- add the corresponding info.
Output_Instantiation_Refs (Sloc (Tref));
Write_Info_Char (Right);
end if;
end if;
end Check_Type_Reference;
-------------------------------
-- Output_Instantiation_Refs --
-------------------------------
......@@ -1397,12 +1524,21 @@ package body Lib.Xref is
-- Special handling for abstract types and operations
if Is_Abstract (XE.Ent) then
if Is_Overloadable (XE.Ent)
and then Is_Abstract_Subprogram (XE.Ent)
then
if Ctyp = 'U' then
Ctyp := 'x'; -- abstract procedure
elsif Ctyp = 'V' then
Ctyp := 'y'; -- abstract function
end if;
elsif Is_Type (XE.Ent)
and then Is_Abstract_Type (XE.Ent)
then
if Is_Interface (XE.Ent) then
Ctyp := 'h';
elsif Ctyp = 'R' then
Ctyp := 'H'; -- abstract type
......@@ -1705,59 +1841,21 @@ package body Lib.Xref is
-- See if we have a type reference and if so output
Get_Type_Reference (XE.Ent, Tref, Left, Right);
if Present (Tref) then
-- Case of standard entity, output name
if Sloc (Tref) = Standard_Location then
Write_Info_Char (Left);
Write_Info_Name (Chars (Tref));
Write_Info_Char (Right);
Check_Type_Reference (XE.Ent, False);
-- Case of source entity, output location
else
Write_Info_Char (Left);
Trunit := Get_Source_Unit (Sloc (Tref));
if Trunit /= Curxu then
Write_Info_Nat (Dependency_Num (Trunit));
Write_Info_Char ('|');
end if;
Write_Info_Nat
(Int (Get_Logical_Line_Number (Sloc (Tref))));
declare
Ent : Entity_Id := Tref;
Kind : constant Entity_Kind := Ekind (Ent);
Ctyp : Character := Xref_Entity_Letters (Kind);
begin
if Ctyp = '+'
and then Present (Full_View (Ent))
then
Ent := Underlying_Type (Ent);
if Present (Ent) then
Ctyp := Xref_Entity_Letters (Ekind (Ent));
end if;
end if;
Write_Info_Char (Ctyp);
end;
Write_Info_Nat
(Int (Get_Column_Number (Sloc (Tref))));
-- If the type comes from an instantiation,
-- add the corresponding info.
if Is_Record_Type (XE.Ent)
and then Present (Abstract_Interfaces (XE.Ent))
then
declare
Elmt : Elmt_Id;
Output_Instantiation_Refs (Sloc (Tref));
Write_Info_Char (Right);
end if;
begin
Elmt := First_Elmt (Abstract_Interfaces (XE.Ent));
while Present (Elmt) loop
Check_Type_Reference (Node (Elmt), True);
Next_Elmt (Elmt);
end loop;
end;
end if;
-- If the entity is an overriding operation, write
......
gcc/ada/lib-xref.ads
......@@ -114,6 +114,10 @@ package Lib.Xref is
-- enumeration literals (points to enum type) LR={}
-- objects and components (points to type) LR={}
-- For a type that implements multiple interfaces, there is an
-- entry of the form LR=<> for each of the interfaces appearing
-- in the type declaration.
-- In the above list LR shows the brackets used in the output,
-- which has one of the two following forms:
......@@ -493,7 +497,7 @@ package Lib.Xref is
-- e non-Boolean enumeration object non_Boolean enumeration type
-- f floating-point object floating-point type
-- g (unused) (unused)
-- h (unused) Abstract type
-- h Interface (Ada 2005) Abstract type
-- i signed integer object signed integer type
-- j (unused) (unused)
-- k generic package package
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment