with Atree; use Atree;
with Csets; use Csets;
with Errout; use Errout;
with Lib.Util; use Lib.Util;
with Namet; use Namet;
with Opt; use Opt;
with Sinfo; use Sinfo;
with Sinput; use Sinput;
with Stand; use Stand;
with Table; use Table;
with Widechar; use Widechar;
with GNAT.Heap_Sort_A;
package body Lib.Xref is
subtype Xref_Entry_Number is Int;
type Xref_Entry is record
Ent : Entity_Id;
Def : Source_Ptr;
Loc : Source_Ptr;
Typ : Character;
Eun : Unit_Number_Type;
Lun : Unit_Number_Type;
end record;
package Xrefs is new Table.Table (
Table_Component_Type => Xref_Entry,
Table_Index_Type => Xref_Entry_Number,
Table_Low_Bound => 1,
Table_Initial => Alloc.Xrefs_Initial,
Table_Increment => Alloc.Xrefs_Increment,
Table_Name => "Xrefs");
procedure Generate_Definition (E : Entity_Id) is
Loc : Source_Ptr;
Indx : Nat;
begin
pragma Assert (Nkind (E) in N_Entity);
if Opt.Xref_Active
and then Comes_From_Source (E)
and then Sloc (E) > No_Location
and then Instantiation_Location (Sloc (E)) = No_Location
and then In_Extended_Main_Source_Unit (E)
and then not Is_Internal_Name (Chars (E))
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;
end if;
end Generate_Definition;
procedure Generate_Operator_Reference (N : Node_Id) is
begin
if not In_Extended_Main_Source_Unit (N) then
return;
end if;
if Sloc (Entity (N)) /= Standard_Location then
Generate_Reference (Entity (N), N);
if Nkind (N) = N_Op_Ne
and then not Comes_From_Source (Entity (N))
and then Present (Corresponding_Equality (Entity (N)))
then
Generate_Reference (Corresponding_Equality (Entity (N)), N);
end if;
else
if Nkind (N) = N_Op_Eq
or else Nkind (N) = N_Op_Ne
or else Nkind (N) = N_Op_Le
or else Nkind (N) = N_Op_Lt
or else Nkind (N) = N_Op_Ge
or else Nkind (N) = N_Op_Gt
then
Set_Referenced (First_Subtype (Etype (Right_Opnd (N))));
else
Set_Referenced (First_Subtype (Etype (N)));
end if;
end if;
end Generate_Operator_Reference;
procedure Generate_Reference
(E : Entity_Id;
N : Node_Id;
Typ : Character := 'r';
Set_Ref : Boolean := True;
Force : Boolean := False)
is
Indx : Nat;
Nod : Node_Id;
Ref : Source_Ptr;
Def : Source_Ptr;
Ent : Entity_Id;
begin
pragma Assert (Nkind (E) in N_Entity);
if not In_Extended_Main_Source_Unit (N)
and then Typ /= 'e'
and then Typ /= 'p'
then
return;
end if;
if Typ = 'p' and then not In_Extended_Main_Source_Unit (E) then
return;
end if;
if not Force and then not Comes_From_Source (N) then
return;
end if;
if Set_Ref then
Set_Referenced (E);
if Has_Pragma_Unreferenced (E) then
if Nkind (N) = N_Identifier
and then Nkind (Parent (N)) = N_Parameter_Association
and then Selector_Name (Parent (N)) = N
then
null;
else
Error_Msg_NE ("?pragma Unreferenced given for&", N, E);
end if;
end if;
if Is_Overloadable (E)
and then Is_Generic_Instance (E)
and then Present (Alias (E))
then
Set_Referenced (Alias (E));
end if;
end if;
if
Opt.Xref_Active
and then Xref_Entity_Letters (Ekind (E)) /= ' '
and then Sloc (E) > No_Location
and then Sloc (N) > No_Location
and then Instantiation_Location (Sloc (N)) = No_Location
and then Typ /= ' '
then
if Nkind (N) = N_Identifier
or else
Nkind (N) = N_Defining_Identifier
or else
Nkind (N) in N_Op
or else
Nkind (N) = N_Defining_Operator_Symbol
or else
(Nkind (N) = N_Character_Literal
and then Sloc (Entity (N)) /= Standard_Location)
or else
Nkind (N) = N_Defining_Character_Literal
then
Nod := N;
elsif Nkind (N) = N_Expanded_Name
or else
Nkind (N) = N_Selected_Component
then
Nod := Selector_Name (N);
else
return;
end if;
if Comes_From_Source (E) then
Ent := E;
elsif Is_Overloadable (E)
and then Present (Alias (E))
and then Comes_From_Source (Alias (E))
then
Ent := Alias (E);
else
return;
end if;
Ref := Original_Location (Sloc (Nod));
Def := Original_Location (Sloc (Ent));
Xrefs.Increment_Last;
Indx := Xrefs.Last;
Xrefs.Table (Indx).Loc := Ref;
Xrefs.Table (Indx).Typ := Typ;
Xrefs.Table (Indx).Eun := Get_Source_Unit (Def);
Xrefs.Table (Indx).Lun := Get_Source_Unit (Ref);
Xrefs.Table (Indx).Ent := Ent;
end if;
end Generate_Reference;
procedure Output_References is
Nrefs : constant Nat := Xrefs.Last;
Rnums : array (0 .. Nrefs) of Nat;
function Lt (Op1, Op2 : Natural) return Boolean;
procedure Move (From : Natural; To : Natural);
function Lt (Op1, Op2 : Natural) return Boolean is
T1 : Xref_Entry renames Xrefs.Table (Rnums (Nat (Op1)));
T2 : Xref_Entry renames Xrefs.Table (Rnums (Nat (Op2)));
begin
if T1.Eun /= T2.Eun then
return Dependency_Num (T1.Eun) < Dependency_Num (T2.Eun);
elsif T1.Def /= T2.Def then
return T1.Def < T2.Def;
elsif T1.Loc = No_Location then
return True;
elsif T2.Loc = No_Location then
return False;
elsif T1.Lun /= T2.Lun then
return Dependency_Num (T1.Lun) < Dependency_Num (T2.Lun);
elsif T1.Loc /= T2.Loc then
return T1.Loc < T2.Loc;
else
return T2.Typ = 'r';
end if;
end Lt;
procedure Move (From : Natural; To : Natural) is
begin
Rnums (Nat (To)) := Rnums (Nat (From));
end Move;
begin
if not Opt.Xref_Active then
return;
end if;
for J in 1 .. Nrefs loop
Rnums (J) := J;
Xrefs.Table (J).Def :=
Original_Location (Sloc (Xrefs.Table (J).Ent));
end loop;
GNAT.Heap_Sort_A.Sort
(Integer (Nrefs),
Move'Unrestricted_Access,
Lt'Unrestricted_Access);
Output_Refs : declare
Curxu : Unit_Number_Type;
Curru : Unit_Number_Type;
Cursrc : Source_Buffer_Ptr;
Curent : Entity_Id;
Curnam : String (1 .. Name_Buffer'Length);
Curlen : Natural;
Curdef : Source_Ptr;
Crloc : Source_Ptr;
Ctyp : Character;
Tref : Entity_Id;
Rref : Node_Id;
Trunit : Unit_Number_Type;
function Name_Change (X : Entity_Id) return Boolean;
function Name_Change (X : Entity_Id) return Boolean is
begin
Get_Unqualified_Name_String (Chars (X));
if Name_Len /= Curlen then
return True;
else
return Name_Buffer (1 .. Curlen) /= Curnam (1 .. Curlen);
end if;
end Name_Change;
begin
Curxu := No_Unit;
Curent := Empty;
Curdef := No_Location;
Curru := No_Unit;
Crloc := No_Location;
for Refno in 1 .. Nrefs loop
Output_One_Ref : declare
XE : Xref_Entry renames Xrefs.Table (Rnums (Refno));
P : Source_Ptr;
P2 : Source_Ptr;
WC : Char_Code;
Err : Boolean;
Ent : Entity_Id;
Sav : Entity_Id;
Left : Character;
Right : Character;
procedure Output_Instantiation_Refs (Loc : Source_Ptr);
procedure Output_Instantiation_Refs (Loc : Source_Ptr) is
Iloc : constant Source_Ptr := Instantiation_Location (Loc);
Lun : Unit_Number_Type;
begin
if Iloc = No_Location then
return;
end if;
Write_Info_Char ('[');
Lun := Get_Source_Unit (Iloc);
if Lun /= Curru then
Curru := XE.Lun;
Write_Info_Nat (Dependency_Num (Curru));
Write_Info_Char ('|');
end if;
Write_Info_Nat (Int (Get_Logical_Line_Number (Iloc)));
Output_Instantiation_Refs (Iloc);
Write_Info_Char (']');
return;
end Output_Instantiation_Refs;
begin
Ent := XE.Ent;
Ctyp := Xref_Entity_Letters (Ekind (Ent));
if XE.Typ = 'e'
and then Ent /= Curent
and then (Refno = Nrefs or else
Ent /= Xrefs.Table (Rnums (Refno + 1)).Ent)
and then
not In_Extended_Main_Source_Unit (Ent)
then
goto Continue;
end if;
if Ctyp = '+'
and then Present (Full_View (XE.Ent))
then
Ent := Underlying_Type (Ent);
if Present (Ent) then
Ctyp := Xref_Entity_Letters (Ekind (Ent));
end if;
end if;
if Ctyp = 'E' and then Is_Boolean_Type (Ent) then
Ctyp := 'B';
end if;
if Ctyp = '*' then
Ent := Etype (XE.Ent);
Ctyp := Fold_Lower (Xref_Entity_Letters (Ekind (Ent)));
if Ctyp = '+'
and then Present (Full_View (Etype (XE.Ent)))
then
Ent := Underlying_Type (Etype (XE.Ent));
if Present (Ent) then
Ctyp := Xref_Entity_Letters (Ekind (Ent));
end if;
end if;
if Ekind (Etype (XE.Ent)) = E_Anonymous_Access_Type
and then Is_Formal (XE.Ent)
then
Ctyp := 'p';
elsif Ctyp = 'e' and then Is_Boolean_Type (Ent) then
Ctyp := 'b';
end if;
end if;
if Ctyp /= ' '
and then XE.Loc /= XE.Def
and then (not Is_Formal (XE.Ent)
or else No (Spec_Entity (XE.Ent)))
then
if XE.Eun /= Curxu then
if Write_Info_Col > 1 then
Write_Info_EOL;
end if;
Curxu := XE.Eun;
Cursrc := Source_Text (Source_Index (Curxu));
Write_Info_Initiate ('X');
Write_Info_Char (' ');
Write_Info_Nat (Dependency_Num (XE.Eun));
Write_Info_Char (' ');
Write_Info_Name (Reference_Name (Source_Index (XE.Eun)));
end if;
if No (Curent)
or else
(XE.Ent /= Curent
and then
(Name_Change (XE.Ent) or else XE.Def /= Curdef))
then
Curent := XE.Ent;
Curdef := XE.Def;
Get_Unqualified_Name_String (Chars (XE.Ent));
Curlen := Name_Len;
Curnam (1 .. Curlen) := Name_Buffer (1 .. Curlen);
if Write_Info_Col > 1 then
Write_Info_EOL;
end if;
Write_Info_Nat (Int (Get_Logical_Line_Number (XE.Def)));
Write_Info_Char (Ctyp);
Write_Info_Nat (Int (Get_Column_Number (XE.Def)));
if Is_Public (Curent) and then not Is_Hidden (Curent) then
Write_Info_Char ('*');
else
Write_Info_Char (' ');
end if;
P := Original_Location (Sloc (XE.Ent));
if Cursrc (P) = ''' then
Write_Info_Char (Cursrc (P));
Write_Info_Char (Cursrc (P + 1));
Write_Info_Char (Cursrc (P + 2));
elsif Cursrc (P) = '"' or else Cursrc (P) = '%' then
Write_Info_Char (Cursrc (P));
P2 := P;
loop
P2 := P2 + 1;
Write_Info_Char (Cursrc (P2));
exit when Cursrc (P2) = Cursrc (P);
end loop;
else
loop
if Is_Start_Of_Wide_Char (Cursrc, P) then
Scan_Wide (Cursrc, P, WC, Err);
elsif not Identifier_Char (Cursrc (P)) then
exit;
else
P := P + 1;
end if;
end loop;
for J in
Original_Location (Sloc (XE.Ent)) .. P - 1
loop
Write_Info_Char (Cursrc (J));
end loop;
end if;
if Is_Object (XE.Ent)
and then Present (Renamed_Object (XE.Ent))
then
Rref := Renamed_Object (XE.Ent);
elsif Is_Overloadable (XE.Ent)
and then Nkind (Parent (Declaration_Node (XE.Ent))) =
N_Subprogram_Renaming_Declaration
then
Rref := Name (Parent (Declaration_Node (XE.Ent)));
elsif Ekind (XE.Ent) = E_Package
and then Nkind (Declaration_Node (XE.Ent)) =
N_Package_Renaming_Declaration
then
Rref := Name (Declaration_Node (XE.Ent));
else
Rref := Empty;
end if;
if Present (Rref) then
if Nkind (Rref) = N_Expanded_Name then
Rref := Selector_Name (Rref);
end if;
if Nkind (Rref) /= N_Identifier then
Rref := Empty;
end if;
end if;
if Present (Rref) then
Write_Info_Char ('=');
Write_Info_Nat
(Int (Get_Logical_Line_Number (Sloc (Rref))));
Write_Info_Char (':');
Write_Info_Nat
(Int (Get_Column_Number (Sloc (Rref))));
end if;
Tref := XE.Ent;
Left := '{';
Right := '}';
loop
Sav := Tref;
if Is_Type (Tref) then
if Base_Type (Tref) = Tref then
if Tref /= Etype (Tref) then
Tref := First_Subtype (Etype (Tref));
if Left /= '(' then
Left := '<';
Right := '>';
end if;
elsif Is_Access_Type (Tref) then
Tref := Designated_Type (Tref);
Left := '(';
Right := ')';
else
exit;
end if;
else
Tref := Ancestor_Subtype (Tref);
if No (Tref) then
Tref := Base_Type (Sav);
end if;
end if;
elsif Is_Object (Tref)
or else Ekind (Tref) = E_Enumeration_Literal
or else Ekind (Tref) = E_Function
or else Ekind (Tref) = E_Operator
then
Tref := Etype (Tref);
else
exit;
end if;
exit when No (Tref)
or else Tref = Sav
or else Tref = Standard_Void_Type;
if Sloc (Tref) = Standard_Location then
Write_Info_Char (Left);
Write_Info_Name (Chars (Tref));
Write_Info_Char (Right);
exit;
elsif Comes_From_Source (Tref) then
exit when not Referenced (Tref)
and then not In_Extended_Main_Source_Unit (Tref);
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))));
Write_Info_Char (Right);
exit;
else
null;
end if;
end loop;
Curru := Curxu;
Crloc := No_Location;
end if;
if XE.Loc /= No_Location
and then XE.Loc /= Crloc
then
Crloc := XE.Loc;
if Write_Info_Col > 72 then
Write_Info_EOL;
Write_Info_Initiate ('.');
end if;
Write_Info_Char (' ');
if XE.Lun /= Curru then
Curru := XE.Lun;
Write_Info_Nat (Dependency_Num (Curru));
Write_Info_Char ('|');
end if;
Write_Info_Nat (Int (Get_Logical_Line_Number (XE.Loc)));
Write_Info_Char (XE.Typ);
Write_Info_Nat (Int (Get_Column_Number (XE.Loc)));
Output_Instantiation_Refs (Sloc (XE.Ent));
end if;
end if;
end Output_One_Ref;
<<Continue>>
null;
end loop;
Write_Info_EOL;
end Output_Refs;
end Output_References;
end Lib.Xref;