-- --
-- B o d y --
-- --
--- Copyright (C) 1998-2010, Free Software Foundation, Inc. --
+-- Copyright (C) 1998-2020, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
with Stringt; use Stringt;
with Stand; use Stand;
with Table; use Table;
-with Widechar; use Widechar;
with GNAT.Heap_Sort_G;
+with GNAT.HTable;
package body Lib.Xref is
-- Declarations --
------------------
+ 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");
+
-- The Xref table is used to record references. The Loc field is set
-- to No_Location for a definition entry.
subtype Xref_Entry_Number is Int;
- type Xref_Entry is record
+ type Xref_Key is record
+ -- These are the components of Xref_Entry that participate in hash
+ -- lookups.
+
Ent : Entity_Id;
-- Entity referenced (E parameter to Generate_Reference)
- Def : Source_Ptr;
- -- Original source location for entity being referenced. Note that these
- -- values are used only during the output process, they are not set when
- -- the entries are originally built. This is because private entities
- -- can be swapped when the initial call is made.
-
Loc : Source_Ptr;
-- Location of reference (Original_Location (Sloc field of N parameter
- -- to Generate_Reference). Set to No_Location for the case of a
+ -- to Generate_Reference)). Set to No_Location for the case of a
-- defining occurrence.
Typ : Character;
-- Unit number corresponding to Loc. Value is undefined and not
-- referenced if Loc is set to No_Location.
+ -- The following components are only used for SPARK cross-references
+
+ Ref_Scope : Entity_Id;
+ -- Entity of the closest subprogram or package enclosing the reference
+
+ Ent_Scope : Entity_Id;
+ -- Entity of the closest subprogram or package enclosing the definition,
+ -- which should be located in the same file as the definition itself.
+ end record;
+
+ type Xref_Entry is record
+ Key : Xref_Key;
+
+ Ent_Scope_File : Unit_Number_Type;
+ -- File for entity Ent_Scope
+
+ Def : Source_Ptr;
+ -- Original source location for entity being referenced. Note that these
+ -- values are used only during the output process, they are not set when
+ -- the entries are originally built. This is because private entities
+ -- can be swapped when the initial call is made.
+
+ HTable_Next : Xref_Entry_Number;
+ -- For use only by Static_HTable
end record;
package Xrefs is new Table.Table (
Table_Increment => Alloc.Xrefs_Increment,
Table_Name => "Xrefs");
+ --------------
+ -- Xref_Set --
+ --------------
+
+ -- We keep a set of xref entries, in order to avoid inserting duplicate
+ -- entries into the above Xrefs table. An entry is in Xref_Set if and only
+ -- if it is in Xrefs.
+
+ Num_Buckets : constant := 2**16;
+
+ subtype Header_Num is Integer range 0 .. Num_Buckets - 1;
+ type Null_Type is null record;
+ pragma Unreferenced (Null_Type);
+
+ function Hash (F : Xref_Entry_Number) return Header_Num;
+
+ function Equal (F1, F2 : Xref_Entry_Number) return Boolean;
+
+ procedure HT_Set_Next (E : Xref_Entry_Number; Next : Xref_Entry_Number);
+
+ function HT_Next (E : Xref_Entry_Number) return Xref_Entry_Number;
+
+ function Get_Key (E : Xref_Entry_Number) return Xref_Entry_Number;
+
+ pragma Inline (Hash, Equal, HT_Set_Next, HT_Next, Get_Key);
+
+ package Xref_Set is new GNAT.HTable.Static_HTable (
+ Header_Num,
+ Element => Xref_Entry,
+ Elmt_Ptr => Xref_Entry_Number,
+ Null_Ptr => 0,
+ Set_Next => HT_Set_Next,
+ Next => HT_Next,
+ Key => Xref_Entry_Number,
+ Get_Key => Get_Key,
+ Hash => Hash,
+ Equal => Equal);
+
+ -----------------------------
+ -- SPARK Xrefs Information --
+ -----------------------------
+
+ package body SPARK_Specific is separate;
+
------------------------
-- Local Subprograms --
------------------------
+ procedure Add_Entry (Key : Xref_Key; Ent_Scope_File : Unit_Number_Type);
+ -- Add an entry to the tables of Xref_Entries, avoiding duplicates
+
procedure Generate_Prim_Op_References (Typ : Entity_Id);
-- For a tagged type, generate implicit references to its primitive
-- operations, for source navigation. This is done right before emitting
-- cross-reference information rather than at the freeze point of the type
-- in order to handle late bodies that are primitive operations.
+ function Lt (T1, T2 : Xref_Entry) return Boolean;
+ -- Order cross-references
+
+ ---------------
+ -- Add_Entry --
+ ---------------
+
+ procedure Add_Entry (Key : Xref_Key; Ent_Scope_File : Unit_Number_Type) is
+ begin
+ Xrefs.Increment_Last; -- tentative
+ Xrefs.Table (Xrefs.Last).Key := Key;
+
+ -- Set the entry in Xref_Set, and if newly set, keep the above
+ -- tentative increment.
+
+ if Xref_Set.Set_If_Not_Present (Xrefs.Last) then
+ Xrefs.Table (Xrefs.Last).Ent_Scope_File := Ent_Scope_File;
+ -- Leave Def and HTable_Next uninitialized
+
+ Set_Has_Xref_Entry (Key.Ent);
+
+ -- It was already in Xref_Set, so throw away the tentatively-added entry
+
+ else
+ Xrefs.Decrement_Last;
+ end if;
+ end Add_Entry;
+
+ ---------------------
+ -- Defer_Reference --
+ ---------------------
+
+ procedure Defer_Reference (Deferred_Reference : Deferred_Reference_Entry) is
+ begin
+ -- If Get_Ignore_Errors, then we are in Preanalyze_Without_Errors, and
+ -- we should not record cross references, because that will cause
+ -- duplicates when we call Analyze.
+
+ if not Get_Ignore_Errors then
+ Deferred_References.Append (Deferred_Reference);
+ end if;
+ end Defer_Reference;
+
+ -----------
+ -- Equal --
+ -----------
+
+ function Equal (F1, F2 : Xref_Entry_Number) return Boolean is
+ Result : constant Boolean :=
+ Xrefs.Table (F1).Key = Xrefs.Table (F2).Key;
+ begin
+ return Result;
+ end Equal;
+
-------------------------
-- Generate_Definition --
-------------------------
procedure Generate_Definition (E : Entity_Id) is
- Loc : Source_Ptr;
- Indx : Nat;
-
begin
pragma Assert (Nkind (E) in N_Entity);
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).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);
+ Add_Entry
+ ((Ent => E,
+ Loc => No_Location,
+ Typ => ' ',
+ Eun => Get_Source_Unit (Original_Location (Sloc (E))),
+ Lun => No_Unit,
+ Ref_Scope => Empty,
+ Ent_Scope => Empty),
+ Ent_Scope_File => No_Unit);
if In_Inlined_Body then
Set_Referenced (E);
return;
end if;
- -- Ada 2005 (AI-345): For synchronized types generate reference
- -- to the wrapper that allow us to dispatch calls through their
- -- implemented abstract interface types.
+ -- Ada 2005 (AI-345): For synchronized types generate reference to the
+ -- wrapper that allow us to dispatch calls through their implemented
+ -- abstract interface types.
- -- The check for Present here is to protect against previously
- -- reported critical errors.
+ -- The check for Present here is to protect against previously reported
+ -- critical errors.
Prim_List := Primitive_Operations (Base_T);
Set_Ref : Boolean := True;
Force : Boolean := False)
is
- Indx : Nat;
- Nod : Node_Id;
- Ref : Source_Ptr;
- Def : Source_Ptr;
- Ent : Entity_Id;
-
- Call : Node_Id;
- Formal : Entity_Id;
- -- Used for call to Find_Actual
-
- Kind : Entity_Kind;
- -- If Formal is non-Empty, then its Ekind, otherwise E_Void
+ Actual_Typ : Character := Typ;
+ Call : Node_Id;
+ Def : Source_Ptr;
+ Ent : Entity_Id;
+ Ent_Scope : Entity_Id;
+ Formal : Entity_Id;
+ Kind : Entity_Kind;
+ Nod : Node_Id;
+ Ref : Source_Ptr;
+ Ref_Scope : Entity_Id;
+
+ function Get_Through_Renamings (E : Entity_Id) return Entity_Id;
+ -- Get the enclosing entity through renamings, which may come from
+ -- source or from the translation of generic instantiations.
function Is_On_LHS (Node : Node_Id) return Boolean;
-- Used to check if a node is on the left hand side of an assignment.
-- exceptions where we do not want to set this flag, see body for
-- details of these exceptional cases.
+ ---------------------------
+ -- Get_Through_Renamings --
+ ---------------------------
+
+ function Get_Through_Renamings (E : Entity_Id) return Entity_Id is
+ begin
+ case Ekind (E) is
+
+ -- For subprograms we just need to check once if they are have a
+ -- Renamed_Entity, because Renamed_Entity is set transitively.
+
+ when Subprogram_Kind =>
+ declare
+ Renamed : constant Entity_Id := Renamed_Entity (E);
+
+ begin
+ if Present (Renamed) then
+ return Renamed;
+ else
+ return E;
+ end if;
+ end;
+
+ -- For objects we need to repeatedly call Renamed_Object, because
+ -- it is not transitive.
+
+ when Object_Kind =>
+ declare
+ Obj : Entity_Id := E;
+
+ begin
+ loop
+ pragma Assert (Present (Obj));
+
+ declare
+ Renamed : constant Entity_Id := Renamed_Object (Obj);
+
+ begin
+ if Present (Renamed) then
+ Obj := Get_Enclosing_Object (Renamed);
+
+ -- The renamed expression denotes a non-object,
+ -- e.g. function call, slicing of a function call,
+ -- pointer dereference, etc.
+
+ if No (Obj) then
+ return Empty;
+ end if;
+ else
+ return Obj;
+ end if;
+ end;
+ end loop;
+ end;
+
+ when others =>
+ return E;
+
+ end case;
+ end Get_Through_Renamings;
+
---------------
-- Is_On_LHS --
---------------
-- ??? There are several routines here and there that perform a similar
-- (but subtly different) computation, which should be factored:
+ -- Sem_Util.Is_LHS
-- Sem_Util.May_Be_Lvalue
-- Sem_Util.Known_To_Be_Assigned
-- Exp_Ch2.Expand_Entry_Parameter.In_Assignment_Context
-- ??? case of a slice assignment?
- -- ??? Note that in some cases this is called too early
- -- (see comments in Sem_Ch8.Find_Direct_Name), at a point where
- -- the tree is not fully typed yet. In that case we may lack
- -- an Etype for N, and we must disable the check for an implicit
- -- dereference. If the dereference is on an LHS, this causes a
- -- false positive.
-
elsif (K = N_Selected_Component or else K = N_Indexed_Component)
and then Prefix (P) = N
- and then not (Present (Etype (N))
- and then
- Is_Access_Type (Etype (N)))
then
- N := P;
+ -- Check for access type. First a special test, In some cases
+ -- this is called too early (see comments in Find_Direct_Name),
+ -- at a point where the tree is not fully typed yet. In that
+ -- case we may lack an Etype for N, and we can't check the
+ -- Etype. For now, we always return False in such a case,
+ -- but this is clearly not right in all cases ???
+
+ if No (Etype (N)) then
+ return False;
+
+ elsif Is_Access_Type (Etype (N)) then
+ return False;
+
+ -- Access type case dealt with, keep going
+
+ else
+ N := P;
+ end if;
-- All other cases, definitely not on left side
P := Parent (P);
if Nkind (P) = N_Pragma then
- if Pragma_Name (P) = Name_Warnings
- or else
- Pragma_Name (P) = Name_Unmodified
- or else
- Pragma_Name (P) = Name_Unreferenced
+ if Pragma_Name_Unmapped (P) in Name_Warnings
+ | Name_Unmodified
+ | Name_Unreferenced
then
return False;
end if;
end if;
+
+ -- A reference to a formal in a named parameter association does
+ -- not make the formal referenced. Formals that are unused in the
+ -- subprogram body are properly flagged as such, even if calls
+ -- elsewhere use named notation.
+
+ elsif Nkind (P) = N_Parameter_Association
+ and then N = Selector_Name (P)
+ then
+ return False;
end if;
end if;
-- Start of processing for Generate_Reference
begin
- pragma Assert (Nkind (E) in N_Entity);
+ -- If Get_Ignore_Errors, then we are in Preanalyze_Without_Errors, and
+ -- we should not record cross references, because that will cause
+ -- duplicates when we call Analyze.
+
+ if Get_Ignore_Errors then
+ return;
+ end if;
+
+ -- May happen in case of severe errors
+
+ if Nkind (E) not in N_Entity then
+ return;
+ end if;
+
Find_Actual (N, Formal, Call);
if Present (Formal) then
-- doing in such cases. For example the calls in Ada.Characters.Handling
-- to its own obsolescent subprograms are just fine.
- -- In any case we do not generate warnings within the extended source
- -- unit of the entity in question, since we assume the source unit
- -- itself knows what is going on (and for sure we do not want silly
- -- warnings, e.g. on the end line of an obsolescent procedure body).
+ -- In any case we only generate warnings if we are in the extended main
+ -- source unit, and the entity itself is not in the extended main source
+ -- unit, since we assume the source unit itself knows what is going on
+ -- (and for sure we do not want silly warnings, e.g. on the end line of
+ -- an obsolescent procedure body).
if Is_Obsolescent (E)
and then not GNAT_Mode
and then not In_Extended_Main_Source_Unit (E)
+ and then In_Extended_Main_Source_Unit (N)
then
Check_Restriction (No_Obsolescent_Features, N);
and then Warn_On_Ada_2005_Compatibility
and then (Typ = 'm' or else Typ = 'r' or else Typ = 's')
then
- Error_Msg_NE ("& is only defined in Ada 2005?", N, E);
+ Error_Msg_NE ("& is only defined in Ada 2005?y?", N, E);
end if;
-- Warn if reference to Ada 2012 entity not in Ada 2012 mode. We only
and then Warn_On_Ada_2012_Compatibility
and then (Typ = 'm' or else Typ = 'r')
then
- Error_Msg_NE ("& is only defined in Ada 2012?", N, E);
+ Error_Msg_NE ("& is only defined in Ada 2012?y?", N, E);
+ end if;
+
+ -- Do not generate references if we are within a postcondition sub-
+ -- program, because the reference does not comes from source, and the
+ -- preanalysis of the aspect has already created an entry for the ALI
+ -- file at the proper source location.
+
+ if Chars (Current_Scope) = Name_uPostconditions then
+ return;
end if;
-- Never collect references if not in main source unit. However, we omit
-- For the same reason we accept an implicit reference generated for
-- a default in an instance.
+ -- We also set the referenced flag in a generic package that is not in
+ -- then main source unit, when the variable is of a formal private type,
+ -- to warn in the instance if the corresponding type is not a fully
+ -- initialized type.
+
if not In_Extended_Main_Source_Unit (N) then
- if Typ = 'e'
- or else Typ = 'p'
- or else Typ = 'i'
- or else Typ = 'k'
+ if Typ = 'e' or else
+ Typ = 'I' or else
+ Typ = 'p' or else
+ Typ = 'i' or else
+ Typ = 'k'
or else (Typ = 'b' and then Is_Generic_Instance (E))
+
+ -- Allow the generation of references to reads, writes and calls
+ -- in SPARK mode when the related context comes from an instance.
+
+ or else
+ (GNATprove_Mode
+ and then In_Extended_Main_Code_Unit (N)
+ and then (Typ = 'm' or else Typ = 'r' or else Typ = 's'))
then
null;
+
+ elsif In_Instance_Body
+ and then In_Extended_Main_Code_Unit (N)
+ and then Is_Generic_Type (Etype (E))
+ then
+ Set_Referenced (E);
+ return;
+
+ elsif Inside_A_Generic
+ and then Is_Generic_Type (Etype (E))
+ then
+ Set_Referenced (E);
+ return;
+
else
return;
end if;
-- Check for pragma Unreferenced given and reference is within
-- this source unit (occasion for possible warning to be issued).
+ -- Note that the entity may be marked as unreferenced by pragma
+ -- Unused.
if Has_Unreferenced (E)
and then In_Same_Extended_Unit (E, N)
then
- -- A reference as a named parameter in a call does not count
- -- as a violation of pragma Unreferenced for this purpose...
+ -- A reference as a named parameter in a call does not count as a
+ -- violation of pragma Unreferenced for this purpose...
if Nkind (N) = N_Identifier
and then Nkind (Parent (N)) = N_Parameter_Association
then
null;
- -- ... Neither does a reference to a variable on the left side
- -- of an assignment.
+ -- ... Neither does a reference to a variable on the left side of
+ -- an assignment.
elsif Is_On_LHS (N) then
null;
+ -- Do not consider F'Result as a violation of pragma Unreferenced
+ -- since the attribute acts as an anonymous alias of the function
+ -- result and not as a real reference to the function.
+
+ elsif Ekind (E) in E_Function | E_Generic_Function
+ and then Is_Entity_Name (N)
+ and then Is_Attribute_Result (Parent (N))
+ then
+ null;
+
+ -- No warning if the reference is in a call that does not come
+ -- from source (e.g. a call to a controlled type primitive).
+
+ elsif not Comes_From_Source (Parent (N))
+ and then Nkind (Parent (N)) = N_Procedure_Call_Statement
+ then
+ null;
+
-- For entry formals, we want to place the warning message on the
-- corresponding entity in the accept statement. The current scope
-- is the body of the accept, so we find the formal whose name
BE := First_Entity (Current_Scope);
while Present (BE) loop
if Chars (BE) = Chars (E) then
- Error_Msg_NE -- CODEFIX
- ("?pragma Unreferenced given for&!", N, BE);
+ if Has_Pragma_Unused (E) then
+ Error_Msg_NE -- CODEFIX
+ ("??pragma Unused given for&!", N, BE);
+ else
+ Error_Msg_NE -- CODEFIX
+ ("??pragma Unreferenced given for&!", N, BE);
+ end if;
exit;
end if;
-- Here we issue the warning, since this is a real reference
+ elsif Has_Pragma_Unused (E) then
+ Error_Msg_NE -- CODEFIX
+ ("??pragma Unused given for&!", N, E);
else
Error_Msg_NE -- CODEFIX
- ("?pragma Unreferenced given for&!", N, E);
+ ("??pragma Unreferenced given for&!", N, E);
end if;
end if;
and then Sloc (E) > No_Location
and then Sloc (N) > No_Location
- -- We ignore references from within an instance, except for default
- -- subprograms, for which we generate an implicit reference.
+ -- Ignore references from within an instance. The only exceptions to
+ -- this are default subprograms, for which we generate an implicit
+ -- reference and compilations in SPARK mode.
and then
- (Instantiation_Location (Sloc (N)) = No_Location or else Typ = 'i')
+ (Instantiation_Location (Sloc (N)) = No_Location
+ or else Typ = 'i'
+ or else GNATprove_Mode)
- -- Ignore dummy references
+ -- Ignore dummy references
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_Operator_Symbol
- or else
- (Nkind (N) = N_Character_Literal
- and then Sloc (Entity (N)) /= Standard_Location)
- or else
- Nkind (N) = N_Defining_Character_Literal
+ if Nkind (N) in N_Identifier
+ | N_Defining_Identifier
+ | N_Defining_Operator_Symbol
+ | N_Operator_Symbol
+ | N_Defining_Character_Literal
+ | N_Op
+ or else (Nkind (N) = N_Character_Literal
+ and then Sloc (Entity (N)) /= Standard_Location)
then
Nod := N;
- elsif Nkind (N) = N_Expanded_Name
- or else
- Nkind (N) = N_Selected_Component
- then
+ elsif Nkind (N) in N_Expanded_Name | N_Selected_Component then
Nod := Selector_Name (N);
else
if Comes_From_Source (E) then
Ent := E;
+ -- Because a declaration may be generated for a subprogram body
+ -- without declaration in GNATprove mode, for inlining, some
+ -- parameters may end up being marked as not coming from source
+ -- although they are. Take these into account specially.
+
+ elsif GNATprove_Mode and then Is_Formal (E) then
+ Ent := E;
+
-- Entity does not come from source, but is a derived subprogram and
-- the derived subprogram comes from source (after one or more
-- derivations) in which case the reference is to parent subprogram.
then
Ent := E;
+ -- Ditto for the formals of such a subprogram
+
+ elsif Is_Overloadable (Scope (E))
+ and then Is_Child_Unit (Scope (E))
+ then
+ Ent := E;
+
-- Record components of discriminated subtypes or derived types must
-- be treated as references to the original component.
-- original discriminant, which gets the reference.
elsif Ekind (E) = E_In_Parameter
- and then Present (Discriminal_Link (E))
+ and then Present (Discriminal_Link (E))
then
Ent := Discriminal_Link (E);
Set_Referenced (Ent);
return;
end if;
- -- Record reference to entity
+ -- In SPARK mode, consider the underlying entity renamed instead of
+ -- the renaming, which is needed to compute a valid set of effects
+ -- (reads, writes) for the enclosing subprogram.
+
+ if GNATprove_Mode then
+ Ent := Get_Through_Renamings (Ent);
- Ref := Original_Location (Sloc (Nod));
- Def := Original_Location (Sloc (Ent));
+ -- If no enclosing object, then it could be a reference to any
+ -- location not tracked individually, like heap-allocated data.
+ -- Conservatively approximate this possibility by generating a
+ -- dereference, and return.
- Xrefs.Increment_Last;
- Indx := Xrefs.Last;
+ if No (Ent) then
+ if Actual_Typ = 'w' then
+ SPARK_Specific.Generate_Dereference (Nod, 'r');
+ SPARK_Specific.Generate_Dereference (Nod, 'w');
+ else
+ SPARK_Specific.Generate_Dereference (Nod, 'r');
+ end if;
- Xrefs.Table (Indx).Loc := Ref;
+ return;
+ end if;
+ end if;
- -- Overriding operations are marked with 'P'
+ -- Record reference to entity
- if Typ = 'p'
- and then Is_Subprogram (N)
- and then Is_Overriding_Operation (N)
+ if Actual_Typ = 'p'
+ and then Is_Subprogram (Nod)
+ and then Present (Overridden_Operation (Nod))
then
- Xrefs.Table (Indx).Typ := 'P';
- else
- Xrefs.Table (Indx).Typ := Typ;
+ Actual_Typ := 'P';
end if;
- Xrefs.Table (Indx).Eun := Get_Source_Unit (Def);
- Xrefs.Table (Indx).Lun := Get_Source_Unit (Ref);
- Xrefs.Table (Indx).Ent := Ent;
- Set_Has_Xref_Entry (Ent);
+ -- Comment needed here for special SPARK code ???
+
+ if GNATprove_Mode then
+
+ -- Ignore references to an entity which is a Part_Of single
+ -- concurrent object. Ideally we would prefer to add it as a
+ -- reference to the corresponding concurrent type, but it is quite
+ -- difficult (as such references are not currently added even for)
+ -- reads/writes of private protected components) and not worth the
+ -- effort.
+
+ if Ekind (Ent) in E_Abstract_State | E_Constant | E_Variable
+ and then Present (Encapsulating_State (Ent))
+ and then Is_Single_Concurrent_Object (Encapsulating_State (Ent))
+ then
+ return;
+ end if;
+
+ Ref := Sloc (Nod);
+ Def := Sloc (Ent);
+
+ Ref_Scope :=
+ SPARK_Specific.Enclosing_Subprogram_Or_Library_Package (Nod);
+ Ent_Scope :=
+ SPARK_Specific.Enclosing_Subprogram_Or_Library_Package (Ent);
+
+ -- Since we are reaching through renamings in SPARK mode, we may
+ -- end up with standard constants. Ignore those.
+
+ if Sloc (Ent_Scope) <= Standard_Location
+ or else Def <= Standard_Location
+ then
+ return;
+ end if;
+
+ Add_Entry
+ ((Ent => Ent,
+ Loc => Ref,
+ Typ => Actual_Typ,
+ Eun => Get_Top_Level_Code_Unit (Def),
+ Lun => Get_Top_Level_Code_Unit (Ref),
+ Ref_Scope => Ref_Scope,
+ Ent_Scope => Ent_Scope),
+ Ent_Scope_File => Get_Top_Level_Code_Unit (Ent));
+
+ else
+ Ref := Original_Location (Sloc (Nod));
+ Def := Original_Location (Sloc (Ent));
+
+ -- If this is an operator symbol, skip the initial quote for
+ -- navigation purposes. This is not done for the end label,
+ -- where we want the actual position after the closing quote.
+
+ if Typ = 't' then
+ null;
+
+ elsif Nkind (N) = N_Defining_Operator_Symbol
+ or else Nkind (Nod) = N_Operator_Symbol
+ then
+ Ref := Ref + 1;
+ end if;
+
+ Add_Entry
+ ((Ent => Ent,
+ Loc => Ref,
+ Typ => Actual_Typ,
+ Eun => Get_Source_Unit (Def),
+ Lun => Get_Source_Unit (Ref),
+ Ref_Scope => Empty,
+ Ent_Scope => Empty),
+ Ent_Scope_File => No_Unit);
+
+ -- Generate reference to the first private entity
+
+ if Typ = 'e'
+ and then Comes_From_Source (E)
+ and then Nkind (Ent) = N_Defining_Identifier
+ and then (Is_Package_Or_Generic_Package (Ent)
+ or else Is_Concurrent_Type (Ent))
+ and then Present (First_Private_Entity (E))
+ and then In_Extended_Main_Source_Unit (N)
+ then
+ -- Handle case in which the full-view and partial-view of the
+ -- first private entity are swapped.
+
+ declare
+ First_Private : Entity_Id := First_Private_Entity (E);
+
+ begin
+ if Is_Private_Type (First_Private)
+ and then Present (Full_View (First_Private))
+ then
+ First_Private := Full_View (First_Private);
+ end if;
+
+ Add_Entry
+ ((Ent => Ent,
+ Loc => Sloc (First_Private),
+ Typ => 'E',
+ Eun => Get_Source_Unit (Def),
+ Lun => Get_Source_Unit (Ref),
+ Ref_Scope => Empty,
+ Ent_Scope => Empty),
+ Ent_Scope_File => No_Unit);
+ end;
+ end if;
+ end if;
end if;
end Generate_Reference;
Next_Entity (Formal);
end loop;
+ elsif Ekind (E) in Access_Subprogram_Kind then
+ Formal := First_Formal (Designated_Type (E));
+
else
Formal := First_Formal (E);
end if;
while Present (Formal) loop
if Ekind (Formal) = E_In_Parameter then
- if Nkind (Parameter_Type (Parent (Formal)))
- = N_Access_Definition
+ if Nkind (Parameter_Type (Parent (Formal))) = N_Access_Definition
then
Generate_Reference (E, Formal, '^', False);
else
end loop;
end Generate_Reference_To_Generic_Formals;
+ -------------
+ -- Get_Key --
+ -------------
+
+ function Get_Key (E : Xref_Entry_Number) return Xref_Entry_Number is
+ begin
+ return E;
+ end Get_Key;
+
+ ----------------------------
+ -- Has_Deferred_Reference --
+ ----------------------------
+
+ function Has_Deferred_Reference (Ent : Entity_Id) return Boolean is
+ begin
+ for J in Deferred_References.First .. Deferred_References.Last loop
+ if Deferred_References.Table (J).E = Ent then
+ return True;
+ end if;
+ end loop;
+
+ return False;
+ end Has_Deferred_Reference;
+
+ ----------
+ -- Hash --
+ ----------
+
+ function Hash (F : Xref_Entry_Number) return Header_Num is
+ -- It is unlikely to have two references to the same entity at the same
+ -- source location, so the hash function depends only on the Ent and Loc
+ -- fields.
+
+ XE : Xref_Entry renames Xrefs.Table (F);
+ type M is mod 2**32;
+
+ H : constant M := M (XE.Key.Ent) + 2 ** 7 * M (abs XE.Key.Loc);
+ -- It would be more natural to write:
+ --
+ -- H : constant M := M'Mod (XE.Key.Ent) + 2**7 * M'Mod (XE.Key.Loc);
+ --
+ -- But we can't use M'Mod, because it prevents bootstrapping with older
+ -- compilers. Loc can be negative, so we do "abs" before converting.
+ -- One day this can be cleaned up ???
+
+ begin
+ return Header_Num (H mod Num_Buckets);
+ end Hash;
+
+ -----------------
+ -- HT_Set_Next --
+ -----------------
+
+ procedure HT_Set_Next (E : Xref_Entry_Number; Next : Xref_Entry_Number) is
+ begin
+ Xrefs.Table (E).HTable_Next := Next;
+ end HT_Set_Next;
+
+ -------------
+ -- HT_Next --
+ -------------
+
+ function HT_Next (E : Xref_Entry_Number) return Xref_Entry_Number is
+ begin
+ return Xrefs.Table (E).HTable_Next;
+ end HT_Next;
+
----------------
-- Initialize --
----------------
Xrefs.Init;
end Initialize;
+ --------
+ -- Lt --
+ --------
+
+ function Lt (T1, T2 : Xref_Entry) return Boolean is
+ begin
+ -- First test: if entity is in different unit, sort by unit
+
+ if T1.Key.Eun /= T2.Key.Eun then
+ return Dependency_Num (T1.Key.Eun) < Dependency_Num (T2.Key.Eun);
+
+ -- Second test: within same unit, sort by entity Sloc
+
+ elsif T1.Def /= T2.Def then
+ return T1.Def < T2.Def;
+
+ -- Third test: sort definitions ahead of references
+
+ elsif T1.Key.Loc = No_Location then
+ return True;
+
+ elsif T2.Key.Loc = No_Location then
+ return False;
+
+ -- Fourth test: for same entity, sort by reference location unit
+
+ elsif T1.Key.Lun /= T2.Key.Lun then
+ return Dependency_Num (T1.Key.Lun) < Dependency_Num (T2.Key.Lun);
+
+ -- Fifth test: order of location within referencing unit
+
+ elsif T1.Key.Loc /= T2.Key.Loc then
+ return T1.Key.Loc < T2.Key.Loc;
+
+ -- Finally, for two locations at the same address, we prefer
+ -- the one that does NOT have the type 'r' so that a modification
+ -- or extension takes preference, when there are more than one
+ -- reference at the same location. As a result, in the case of
+ -- entities that are in-out actuals, the read reference follows
+ -- the modify reference.
+
+ else
+ return T2.Key.Typ = 'r';
+ end if;
+ end Lt;
+
-----------------------
-- Output_References --
-----------------------
procedure Output_Import_Export_Info (Ent : Entity_Id);
-- Output language and external name information for an interfaced
- -- entity, using the format <language, external_name>,
+ -- entity, using the format <language, external_name>.
------------------------
-- Get_Type_Reference --
Right := '>';
end if;
- -- If non-derived ptr, get directly designated type.
+ -- If the completion of a private type is itself a derived
+ -- type, we need the parent of the full view.
+
+ elsif Is_Private_Type (Tref)
+ and then Present (Full_View (Tref))
+ and then Etype (Full_View (Tref)) /= Full_View (Tref)
+ then
+ Tref := Etype (Full_View (Tref));
+
+ if Left /= '(' then
+ Left := '<';
+ Right := '>';
+ end if;
+
+ -- If non-derived pointer, get directly designated type.
-- If the type has a full view, all references are on the
- -- partial view, that is seen first.
+ -- partial view that is seen first.
elsif Is_Access_Type (Tref) then
Tref := Directly_Designated_Type (Tref);
then
Tref := Etype (Tref);
+ -- Another special case: an object of a classwide type
+ -- initialized with a tag-indeterminate call gets a subtype
+ -- of the classwide type during expansion. See if the original
+ -- type in the declaration is named, and return it instead
+ -- of going to the root type. The expression may be a class-
+ -- wide function call whose result is on the secondary stack,
+ -- which forces the declaration to be rewritten as a renaming,
+ -- so examine the source declaration.
+
+ if Ekind (Tref) = E_Class_Wide_Subtype then
+ declare
+ Decl : constant Node_Id := Original_Node (Parent (Ent));
+ begin
+ if Nkind (Decl) = N_Object_Declaration
+ and then Is_Entity_Name
+ (Original_Node (Object_Definition (Decl)))
+ then
+ Tref :=
+ Entity (Original_Node (Object_Definition (Decl)));
+ end if;
+ end;
+
+ -- For a function that returns a class-wide type, Tref is
+ -- already correct.
+
+ elsif Is_Overloadable (Ent)
+ and then Is_Class_Wide_Type (Tref)
+ then
+ return;
+ end if;
+
-- For anything else, exit
else
begin
-- Generate language name from convention
- if Conv = Convention_C then
+ if Conv = Convention_C or else Conv in Convention_C_Variadic then
Language_Name := Name_C;
elsif Conv = Convention_CPP then
-- Start of processing for Output_References
begin
- if not Opt.Xref_Active then
- return;
- end if;
-
- -- First we add references to the primitive operations of tagged
- -- types declared in the main unit.
+ -- First we add references to the primitive operations of tagged types
+ -- declared in the main unit.
Handle_Prim_Ops : declare
Ent : Entity_Id;
begin
for J in 1 .. Xrefs.Last loop
- Ent := Xrefs.Table (J).Ent;
+ Ent := Xrefs.Table (J).Key.Ent;
if Is_Type (Ent)
and then Is_Tagged_Type (Ent)
- and then Ent = Base_Type (Ent)
+ and then Is_Base_Type (Ent)
and then In_Extended_Main_Source_Unit (Ent)
then
Generate_Prim_Op_References (Ent);
Handle_Orphan_Type_References : declare
J : Nat;
Tref : Entity_Id;
- Indx : Nat;
Ent : Entity_Id;
- Loc : Source_Ptr;
L, R : Character;
pragma Warnings (Off, L);
procedure New_Entry (E : Entity_Id) is
begin
- if Present (E)
- and then not Has_Xref_Entry (E)
+ pragma Assert (Present (E));
+
+ if not Has_Xref_Entry (Implementation_Base_Type (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);
+ Add_Entry
+ ((Ent => E,
+ Loc => No_Location,
+ Typ => Character'First,
+ Eun => Get_Source_Unit (Original_Location (Sloc (E))),
+ Lun => No_Unit,
+ Ref_Scope => Empty,
+ Ent_Scope => Empty),
+ Ent_Scope_File => No_Unit);
end if;
end New_Entry;
J := 1;
while J <= Xrefs.Last loop
- Ent := Xrefs.Table (J).Ent;
+ Ent := Xrefs.Table (J).Key.Ent;
+
+ -- Do not generate reference information for an ignored Ghost
+ -- entity because neither the entity nor its references will
+ -- appear in the final tree.
+
+ if Is_Ignored_Ghost_Entity (Ent) then
+ goto Orphan_Continue;
+ end if;
+
Get_Type_Reference (Ent, Tref, L, R);
if Present (Tref)
if Is_Type (Ent)
and then Is_Tagged_Type (Ent)
and then Is_Derived_Type (Ent)
- and then Ent = Base_Type (Ent)
+ and then Is_Base_Type (Ent)
and then In_Extended_Main_Source_Unit (Ent)
then
declare
Prim := Parent_Op (Node (Op));
if Present (Prim) then
- Xrefs.Increment_Last;
- Indx := Xrefs.Last;
- Loc := Original_Location (Sloc (Prim));
- Xrefs.Table (Indx).Ent := Prim;
- Xrefs.Table (Indx).Loc := No_Location;
- Xrefs.Table (Indx).Eun :=
- Get_Source_Unit (Sloc (Prim));
- Xrefs.Table (Indx).Lun := No_Unit;
- Set_Has_Xref_Entry (Prim);
+ Add_Entry
+ ((Ent => Prim,
+ Loc => No_Location,
+ Typ => Character'First,
+ Eun => Get_Source_Unit (Sloc (Prim)),
+ Lun => No_Unit,
+ Ref_Scope => Empty,
+ Ent_Scope => Empty),
+ Ent_Scope_File => No_Unit);
end if;
Next_Elmt (Op);
end;
end if;
+ <<Orphan_Continue>>
J := J + 1;
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
-
- Nrefs : Nat := Xrefs.Last;
- -- Number of references in table. This value may get reset (reduced)
- -- when we eliminate duplicate reference entries.
+ Nrefs : constant Nat := Xrefs.Last;
+ -- Number of references in table
Rnums : array (0 .. Nrefs) of Nat;
-- This array contains numbers of references in the Xrefs table.
Curru : Unit_Number_Type;
-- Current reference unit for one entity
- Cursrc : Source_Buffer_Ptr;
- -- Current xref unit source text
-
Curent : Entity_Id;
-- Current entity
Ctyp : Character;
-- Entity type character
+ Prevt : Character;
+ -- reference kind of previous reference
+
Tref : Entity_Id;
-- Type reference
T2 : Xref_Entry renames Xrefs.Table (Rnums (Nat (Op2)));
begin
- -- First test: if entity is in different unit, sort by unit
-
- if T1.Eun /= T2.Eun then
- return Dependency_Num (T1.Eun) < Dependency_Num (T2.Eun);
-
- -- Second test: within same unit, sort by entity Sloc
-
- elsif T1.Def /= T2.Def then
- return T1.Def < T2.Def;
-
- -- Third test: sort definitions ahead of references
-
- elsif T1.Loc = No_Location then
- return True;
-
- elsif T2.Loc = No_Location then
- return False;
-
- -- Fourth test: for same entity, sort by reference location unit
-
- elsif T1.Lun /= T2.Lun then
- return Dependency_Num (T1.Lun) < Dependency_Num (T2.Lun);
-
- -- Fifth test: order of location within referencing unit
-
- elsif T1.Loc /= T2.Loc then
- return T1.Loc < T2.Loc;
-
- -- Finally, for two locations at the same address, we prefer
- -- the one that does NOT have the type 'r' so that a modification
- -- or extension takes preference, when there are more than one
- -- reference at the same location.
-
- else
- return T2.Typ = 'r';
- end if;
+ return Lt (T1, T2);
end Lt;
----------
-- types may be swapped, and the Sloc value may be incorrect. We
-- also set up the pointer vector for the sort.
+ -- For user-defined operators we need to skip the initial quote and
+ -- point to the first character of the name, for navigation purposes.
+
for J in 1 .. Nrefs loop
- Rnums (J) := J;
- Xrefs.Table (J).Def :=
- Original_Location (Sloc (Xrefs.Table (J).Ent));
+ declare
+ E : constant Entity_Id := Xrefs.Table (J).Key.Ent;
+ Loc : constant Source_Ptr := Original_Location (Sloc (E));
+
+ begin
+ Rnums (J) := J;
+
+ if Nkind (E) = N_Defining_Operator_Symbol then
+ Xrefs.Table (J).Def := Loc + 1;
+ else
+ Xrefs.Table (J).Def := Loc;
+ end if;
+ end;
end loop;
-- Sort the references
Sorting.Sort (Integer (Nrefs));
- -- Eliminate duplicate entries
-
- declare
- NR : constant Nat := Nrefs;
-
- begin
- -- We need this test for NR because if we force ALI file
- -- generation in case of errors detected, it may be the case
- -- that Nrefs is 0, so we should not reset it here
-
- if NR >= 2 then
- Nrefs := 1;
-
- for J in 2 .. NR loop
- if Xrefs.Table (Rnums (J)) /=
- Xrefs.Table (Rnums (Nrefs))
- then
- Nrefs := Nrefs + 1;
- Rnums (Nrefs) := Rnums (J);
- end if;
- end loop;
- end if;
- end;
-
-- Initialize loop through references
Curxu := No_Unit;
Curdef := No_Location;
Curru := No_Unit;
Crloc := No_Location;
+ Prevt := 'm';
-- Loop to output references
for Refno in 1 .. Nrefs loop
Output_One_Ref : declare
- P2 : Source_Ptr;
Ent : Entity_Id;
- WC : Char_Code;
- Err : Boolean;
- pragma Warnings (Off, WC);
- pragma Warnings (Off, Err);
-
XE : Xref_Entry renames Xrefs.Table (Rnums (Refno));
-- The current entry to be accessed
- P : Source_Ptr;
- -- Used to index into source buffer to get entity name
-
Left : Character;
Right : Character;
-- Used for {} or <> or () for type reference
procedure Check_Type_Reference
(Ent : Entity_Id;
- List_Interface : Boolean);
+ List_Interface : Boolean;
+ Is_Component : Boolean := False);
-- 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.
+ -- without looking for a type reference for it. Flag is also
+ -- used for index types of an array type, where the caller
+ -- supplies the intended type reference. Is_Component serves
+ -- the same purpose, to display the component type of a
+ -- derived array type, for which only the parent type has
+ -- ben displayed so far.
procedure Output_Instantiation_Refs (Loc : Source_Ptr);
-- Recursive procedure to output instantiation references for
procedure Check_Type_Reference
(Ent : Entity_Id;
- List_Interface : Boolean)
+ List_Interface : Boolean;
+ Is_Component : Boolean := False)
is
begin
if List_Interface then
Left := '<';
Right := '>';
+ -- The following is not documented in lib-xref.ads ???
+
+ elsif Is_Component then
+ Tref := Ent;
+ Left := '(';
+ Right := ')';
+
else
Get_Type_Reference (Ent, Tref, Left, Right);
end if;
Op := Ultimate_Alias (Old_E);
- -- Normal case of no alias present
+ -- Normal case of no alias present. We omit generated
+ -- primitives like tagged equality, that have no source
+ -- representation.
else
Op := Old_E;
if Present (Op)
and then Sloc (Op) /= Standard_Location
+ and then Comes_From_Source (Op)
then
declare
Loc : constant Source_Ptr := Sloc (Op);
-- Start of processing for Output_One_Ref
begin
- Ent := XE.Ent;
+ Ent := XE.Key.Ent;
+
+ -- Do not generate reference information for an ignored Ghost
+ -- entity because neither the entity nor its references will
+ -- appear in the final tree.
+
+ if Is_Ignored_Ghost_Entity (Ent) then
+ goto Continue;
+ end if;
+
Ctyp := Xref_Entity_Letters (Ekind (Ent));
-- Skip reference if it is the only reference to an entity,
-- consisting only of packages with END lines, where no
-- entity from the package is actually referenced.
- if XE.Typ = 'e'
+ if XE.Key.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)
+ and then (Refno = Nrefs
+ or else
+ Ent /= Xrefs.Table (Rnums (Refno + 1)).Key.Ent)
+ and then not In_Extended_Main_Source_Unit (Ent)
then
goto Continue;
end if;
-- For private type, get full view type
if Ctyp = '+'
- and then Present (Full_View (XE.Ent))
+ and then Present (Full_View (XE.Key.Ent))
then
Ent := Underlying_Type (Ent);
-- For variable reference, get corresponding type
if Ctyp = '*' then
- Ent := Etype (XE.Ent);
+ Ent := Etype (XE.Key.Ent);
Ctyp := Fold_Lower (Xref_Entity_Letters (Ekind (Ent)));
-- If variable is private type, get full view type
if Ctyp = '+'
- and then Present (Full_View (Etype (XE.Ent)))
+ and then Present (Full_View (Etype (XE.Key.Ent)))
then
- Ent := Underlying_Type (Etype (XE.Ent));
+ Ent := Underlying_Type (Etype (XE.Key.Ent));
if Present (Ent) then
Ctyp := Fold_Lower (Xref_Entity_Letters (Ekind (Ent)));
Ctyp := '*';
end if;
- -- Special handling for access parameters and objects of
- -- an anonymous access type.
+ -- Special handling for access parameters and objects and
+ -- components of an anonymous access type.
- if Ekind_In (Etype (XE.Ent),
- E_Anonymous_Access_Type,
- E_Anonymous_Access_Subprogram_Type,
- E_Anonymous_Access_Protected_Subprogram_Type)
+ if Ekind (Etype (XE.Key.Ent)) in
+ E_Anonymous_Access_Type
+ | E_Anonymous_Access_Subprogram_Type
+ | E_Anonymous_Access_Protected_Subprogram_Type
then
- if Is_Formal (XE.Ent)
- or else Ekind_In (XE.Ent, E_Variable, E_Constant)
+ if Is_Formal (XE.Key.Ent)
+ or else
+ Ekind (XE.Key.Ent) in
+ E_Variable | E_Constant | E_Component
then
Ctyp := 'p';
end if;
-- Special handling for abstract types and operations
- if Is_Overloadable (XE.Ent)
- and then Is_Abstract_Subprogram (XE.Ent)
+ if Is_Overloadable (XE.Key.Ent)
+ and then Is_Abstract_Subprogram (XE.Key.Ent)
then
if Ctyp = 'U' then
Ctyp := 'x'; -- Abstract procedure
Ctyp := 'y'; -- Abstract function
end if;
- elsif Is_Type (XE.Ent)
- and then Is_Abstract_Type (XE.Ent)
+ elsif Is_Type (XE.Key.Ent)
+ and then Is_Abstract_Type (XE.Key.Ent)
then
- if Is_Interface (XE.Ent) then
+ if Is_Interface (XE.Key.Ent) then
Ctyp := 'h';
elsif Ctyp = 'R' then
end if;
end if;
- -- Only output reference if interesting type of entity, and
- -- suppress self references, except for bodies that act as
- -- specs. Also suppress definitions of body formals (we only
+ -- Only output reference if interesting type of entity
+
+ if Ctyp = ' '
+
+ -- Suppress references to object definitions, used for local
+ -- references.
+
+ or else XE.Key.Typ = 'D'
+ or else XE.Key.Typ = 'I'
+
+ -- Suppress self references, except for bodies that act as
+ -- specs.
+
+ or else (XE.Key.Loc = XE.Def
+ and then
+ (XE.Key.Typ /= 'b'
+ or else not Is_Subprogram (XE.Key.Ent)))
+
+ -- Also suppress definitions of body formals (we only
-- treat these as references, and the references were
-- separately recorded).
- if Ctyp = ' '
- or else (XE.Loc = XE.Def
- and then
- (XE.Typ /= 'b'
- or else not Is_Subprogram (XE.Ent)))
- or else (Is_Formal (XE.Ent)
- and then Present (Spec_Entity (XE.Ent)))
+ or else (Is_Formal (XE.Key.Ent)
+ and then Present (Spec_Entity (XE.Key.Ent)))
then
null;
else
-- Start new Xref section if new xref unit
- if XE.Eun /= Curxu then
+ if XE.Key.Eun /= Curxu then
if Write_Info_Col > 1 then
Write_Info_EOL;
end if;
- Curxu := XE.Eun;
- Cursrc := Source_Text (Source_Index (Curxu));
+ Curxu := XE.Key.Eun;
Write_Info_Initiate ('X');
Write_Info_Char (' ');
- Write_Info_Nat (Dependency_Num (XE.Eun));
+ Write_Info_Nat (Dependency_Num (XE.Key.Eun));
Write_Info_Char (' ');
- Write_Info_Name (Reference_Name (Source_Index (XE.Eun)));
+ Write_Info_Name
+ (Reference_Name (Source_Index (XE.Key.Eun)));
end if;
-- Start new Entity line if new entity. Note that we
if No (Curent)
or else
- (XE.Ent /= Curent
+ (XE.Key.Ent /= Curent
and then
- (Name_Change (XE.Ent) or else XE.Def /= Curdef))
+ (Name_Change (XE.Key.Ent) or else XE.Def /= Curdef))
then
- Curent := XE.Ent;
+ Curent := XE.Key.Ent;
Curdef := XE.Def;
- Get_Unqualified_Name_String (Chars (XE.Ent));
+ Get_Unqualified_Name_String (Chars (XE.Key.Ent));
Curlen := Name_Len;
Curnam (1 .. Curlen) := Name_Buffer (1 .. Curlen);
-- Output entity name. We use the occurrence from the
-- actual source program at the definition point.
- P := Original_Location (Sloc (XE.Ent));
-
- -- Entity is character literal
-
- if Cursrc (P) = ''' then
- Write_Info_Char (Cursrc (P));
- Write_Info_Char (Cursrc (P + 1));
- Write_Info_Char (Cursrc (P + 2));
-
- -- Entity is operator symbol
-
- 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;
-
- -- Entity is identifier
-
- 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;
-
- -- Write out the identifier by copying the exact
- -- source characters used in its declaration. Note
- -- that this means wide characters will be in their
- -- original encoded form.
-
- for J in
- Original_Location (Sloc (XE.Ent)) .. P - 1
- loop
- Write_Info_Char (Cursrc (J));
+ declare
+ Ent_Name : constant String :=
+ Exact_Source_Name (Sloc (XE.Key.Ent));
+ begin
+ for C in Ent_Name'Range loop
+ Write_Info_Char (Ent_Name (C));
end loop;
- end if;
+ end;
-- See if we have a renaming reference
- if Is_Object (XE.Ent)
- and then Present (Renamed_Object (XE.Ent))
+ if Is_Object (XE.Key.Ent)
+ and then Present (Renamed_Object (XE.Key.Ent))
then
- Rref := Renamed_Object (XE.Ent);
+ Rref := Renamed_Object (XE.Key.Ent);
- elsif Is_Overloadable (XE.Ent)
- and then Nkind (Parent (Declaration_Node (XE.Ent))) =
- N_Subprogram_Renaming_Declaration
+ elsif Is_Overloadable (XE.Key.Ent)
+ and then Nkind (Parent (Declaration_Node (XE.Key.Ent)))
+ = N_Subprogram_Renaming_Declaration
then
- Rref := Name (Parent (Declaration_Node (XE.Ent)));
+ Rref := Name (Parent (Declaration_Node (XE.Key.Ent)));
- elsif Ekind (XE.Ent) = E_Package
- and then Nkind (Declaration_Node (XE.Ent)) =
+ elsif Ekind (XE.Key.Ent) = E_Package
+ and then Nkind (Declaration_Node (XE.Key.Ent)) =
N_Package_Renaming_Declaration
then
- Rref := Name (Declaration_Node (XE.Ent));
+ Rref := Name (Declaration_Node (XE.Key.Ent));
else
Rref := Empty;
-- Write out information about generic parent, if entity
-- is an instance.
- if Is_Generic_Instance (XE.Ent) then
+ if Is_Generic_Instance (XE.Key.Ent) then
declare
Gen_Par : constant Entity_Id :=
Generic_Parent
(Specification
- (Unit_Declaration_Node (XE.Ent)));
+ (Unit_Declaration_Node
+ (XE.Key.Ent)));
Loc : constant Source_Ptr := Sloc (Gen_Par);
Gen_U : constant Unit_Number_Type :=
Get_Source_Unit (Loc);
-- See if we have a type reference and if so output
- Check_Type_Reference (XE.Ent, False);
+ Check_Type_Reference (XE.Key.Ent, False);
- -- Additional information for types with progenitors
+ -- Additional information for types with progenitors,
+ -- including synchronized tagged types.
- if Is_Record_Type (XE.Ent)
- and then Present (Interfaces (XE.Ent))
- then
- declare
- Elmt : Elmt_Id := First_Elmt (Interfaces (XE.Ent));
- begin
- while Present (Elmt) loop
- Check_Type_Reference (Node (Elmt), True);
- Next_Elmt (Elmt);
- end loop;
- end;
+ declare
+ Typ : constant Entity_Id := XE.Key.Ent;
+ Elmt : Elmt_Id;
+
+ begin
+ if Is_Record_Type (Typ)
+ and then Present (Interfaces (Typ))
+ then
+ Elmt := First_Elmt (Interfaces (Typ));
+
+ elsif Is_Concurrent_Type (Typ)
+ and then Present (Corresponding_Record_Type (Typ))
+ and then Present (
+ Interfaces (Corresponding_Record_Type (Typ)))
+ then
+ Elmt :=
+ First_Elmt (
+ Interfaces (Corresponding_Record_Type (Typ)));
+
+ else
+ Elmt := No_Elmt;
+ end if;
+
+ while Present (Elmt) loop
+ Check_Type_Reference (Node (Elmt), True);
+ Next_Elmt (Elmt);
+ end loop;
+ end;
-- For array types, list index types as well. (This is
-- not C, indexes have distinct types).
- elsif Is_Array_Type (XE.Ent) then
+ if Is_Array_Type (XE.Key.Ent) then
declare
+ A_Typ : constant Entity_Id := XE.Key.Ent;
Indx : Node_Id;
+
begin
- Indx := First_Index (XE.Ent);
+ -- If this is a derived array type, we have
+ -- output the parent type, so add the component
+ -- type now.
+
+ if Is_Derived_Type (A_Typ) then
+ Check_Type_Reference
+ (Component_Type (A_Typ), False, True);
+ end if;
+
+ -- Add references to index types.
+
+ Indx := First_Index (XE.Key.Ent);
while Present (Indx) loop
Check_Type_Reference
(First_Subtype (Etype (Indx)), True);
-- If the entity is an overriding operation, write info
-- on operation that was overridden.
- if Is_Subprogram (XE.Ent)
- and then Is_Overriding_Operation (XE.Ent)
+ if Is_Subprogram (XE.Key.Ent)
+ and then Present (Overridden_Operation (XE.Key.Ent))
then
- Output_Overridden_Op (Overridden_Operation (XE.Ent));
+ Output_Overridden_Op
+ (Overridden_Operation (XE.Key.Ent));
end if;
-- End of processing for entity output
Crloc := No_Location;
end if;
- -- Output the reference
+ -- Output the reference if it is not as the same location
+ -- as the previous one, or it is a read-reference that
+ -- indicates that the entity is an in-out actual in a call.
- if XE.Loc /= No_Location
- and then XE.Loc /= Crloc
+ if XE.Key.Loc /= No_Location
+ and then
+ (XE.Key.Loc /= Crloc
+ or else (Prevt = 'm' and then XE.Key.Typ = 'r'))
then
- Crloc := XE.Loc;
+ Crloc := XE.Key.Loc;
+ Prevt := XE.Key.Typ;
-- Start continuation if line full, else blank
-- Output file number if changed
- if XE.Lun /= Curru then
- Curru := XE.Lun;
+ if XE.Key.Lun /= Curru then
+ Curru := XE.Key.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_Logical_Line_Number (XE.Key.Loc)));
+ Write_Info_Char (XE.Key.Typ);
- if Is_Overloadable (XE.Ent)
- and then Is_Imported (XE.Ent)
- and then XE.Typ = 'b'
- then
- Output_Import_Export_Info (XE.Ent);
+ if Is_Overloadable (XE.Key.Ent) then
+ if (Is_Imported (XE.Key.Ent) and then XE.Key.Typ = 'b')
+ or else
+ (Is_Exported (XE.Key.Ent) and then XE.Key.Typ = 'i')
+ then
+ Output_Import_Export_Info (XE.Key.Ent);
+ end if;
end if;
- Write_Info_Nat (Int (Get_Column_Number (XE.Loc)));
+ Write_Info_Nat (Int (Get_Column_Number (XE.Key.Loc)));
- Output_Instantiation_Refs (Sloc (XE.Ent));
+ Output_Instantiation_Refs (Sloc (XE.Key.Ent));
end if;
end if;
end Output_One_Ref;
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
+ -- Reset is necessary because Elmt_Ptr does not default to Null_Ptr,
+ -- because it's not an access type.
+
+ Xref_Set.Reset;
end Lib.Xref;
projects / gcc.git / blobdiff