Expr := N;
end if;
- Ptr_Typ := Base_Type (Etype (Expr));
+ -- In certain cases an allocator with a qualified expression may
+ -- be relocated and used as the initialization expression of a
+ -- temporary:
+
+ -- before:
+ -- Obj : Ptr_Typ := new Desig_Typ'(...);
+
+ -- after:
+ -- Tmp : Ptr_Typ := new Desig_Typ'(...);
+ -- Obj : Ptr_Typ := Tmp;
+
+ -- Since the allocator is always marked as analyzed to avoid infinite
+ -- expansion, it will never be processed by this routine given that
+ -- the designated type needs finalization actions. Detect this case
+ -- and complete the expansion of the allocator.
+
+ if Nkind (Expr) = N_Identifier
+ and then Nkind (Parent (Entity (Expr))) = N_Object_Declaration
+ and then Nkind (Expression (Parent (Entity (Expr)))) = N_Allocator
+ then
+ Build_Allocate_Deallocate_Proc (Parent (Entity (Expr)), True);
+ return;
+ end if;
- -- The allocator may have been rewritten into something else
+ -- The allocator may have been rewritten into something else in which
+ -- case the expansion performed by this routine does not apply.
- if Nkind (Expr) = N_Allocator then
- Proc_To_Call := Procedure_To_Call (Expr);
+ if Nkind (Expr) /= N_Allocator then
+ return;
end if;
+
+ Ptr_Typ := Base_Type (Etype (Expr));
+ Proc_To_Call := Procedure_To_Call (Expr);
end if;
Pool_Id := Associated_Storage_Pool (Ptr_Typ);
(Decl : Node_Id;
Rel_Node : Node_Id) return Boolean
is
- Obj_Id : constant Entity_Id := Defining_Identifier (Decl);
- Obj_Typ : constant Entity_Id := Base_Type (Etype (Obj_Id));
- Desig : Entity_Id := Obj_Typ;
- Has_Rens : Boolean := True;
- Ren_Obj : Entity_Id;
+ Obj_Id : constant Entity_Id := Defining_Identifier (Decl);
+ Obj_Typ : constant Entity_Id := Base_Type (Etype (Obj_Id));
+ Desig : Entity_Id := Obj_Typ;
function Initialized_By_Access (Trans_Id : Entity_Id) return Boolean;
-- Determine whether transient object Trans_Id is initialized either
-- value 1 and BIPaccess is not null. This case creates an aliasing
-- between the returned value and the value denoted by BIPaccess.
- function Is_Allocated (Trans_Id : Entity_Id) return Boolean;
- -- Determine whether transient object Trans_Id is allocated on the heap
-
- function Is_Renamed
+ function Is_Aliased
(Trans_Id : Entity_Id;
First_Stmt : Node_Id) return Boolean;
- -- Determine whether transient object Trans_Id has been renamed in the
- -- statement list starting from First_Stmt.
+ -- Determine whether transient object Trans_Id has been renamed or
+ -- aliased through 'reference in the statement list starting from
+ -- First_Stmt.
+
+ function Is_Allocated (Trans_Id : Entity_Id) return Boolean;
+ -- Determine whether transient object Trans_Id is allocated on the heap
---------------------------
-- Initialized_By_Access --
return False;
end Initialized_By_Aliased_BIP_Func_Call;
- ------------------
- -- Is_Allocated --
- ------------------
-
- function Is_Allocated (Trans_Id : Entity_Id) return Boolean is
- Expr : constant Node_Id := Expression (Parent (Trans_Id));
-
- begin
- return
- Is_Access_Type (Etype (Trans_Id))
- and then Present (Expr)
- and then Nkind (Expr) = N_Allocator;
- end Is_Allocated;
-
----------------
- -- Is_Renamed --
+ -- Is_Aliased --
----------------
- function Is_Renamed
+ function Is_Aliased
(Trans_Id : Entity_Id;
First_Stmt : Node_Id) return Boolean
is
- Stmt : Node_Id;
-
function Extract_Renamed_Object
(Ren_Decl : Node_Id) return Entity_Id;
-- Given an object renaming declaration, retrieve the entity of the
return Empty;
end Extract_Renamed_Object;
- -- Start of processing for Is_Renamed
-
- begin
- -- If a previous invocation of this routine has determined that a
- -- list has no renamings, then no point in repeating the same scan.
-
- if not Has_Rens then
- return False;
- end if;
+ -- Local variables
- -- Assume that the statement list does not have a renaming. This is a
- -- minor optimization.
+ Expr : Node_Id;
+ Ren_Obj : Entity_Id;
+ Stmt : Node_Id;
- Has_Rens := False;
+ -- Start of processing for Is_Aliased
+ begin
Stmt := First_Stmt;
while Present (Stmt) loop
- if Nkind (Stmt) = N_Object_Renaming_Declaration then
- Has_Rens := True;
- Ren_Obj := Extract_Renamed_Object (Stmt);
+ if Nkind (Stmt) = N_Object_Declaration then
+ Expr := Expression (Stmt);
+
+ if Present (Expr)
+ and then Nkind (Expr) = N_Reference
+ and then Nkind (Prefix (Expr)) = N_Identifier
+ and then Entity (Prefix (Expr)) = Trans_Id
+ then
+ return True;
+ end if;
+
+ elsif Nkind (Stmt) = N_Object_Renaming_Declaration then
+ Ren_Obj := Extract_Renamed_Object (Stmt);
if Present (Ren_Obj)
and then Ren_Obj = Trans_Id
end loop;
return False;
- end Is_Renamed;
+ end Is_Aliased;
+
+ ------------------
+ -- Is_Allocated --
+ ------------------
+
+ function Is_Allocated (Trans_Id : Entity_Id) return Boolean is
+ Expr : constant Node_Id := Expression (Parent (Trans_Id));
+
+ begin
+ return
+ Is_Access_Type (Etype (Trans_Id))
+ and then Present (Expr)
+ and then Nkind (Expr) = N_Allocator;
+ end Is_Allocated;
-- Start of processing for Is_Finalizable_Transient
and then Requires_Transient_Scope (Desig)
and then Nkind (Rel_Node) /= N_Simple_Return_Statement
+ -- Do not consider renamed or 'reference-d transient objects because
+ -- the act of renaming extends the object's lifetime.
+
+ and then not Is_Aliased (Obj_Id, Decl)
+
-- Do not consider transient objects allocated on the heap since they
-- are attached to a finalization master.
and then not Initialized_By_Aliased_BIP_Func_Call (Obj_Id)
- -- Do not consider renamed transient objects because the act of
- -- renaming extends the object's lifetime.
-
- and then not Is_Renamed (Obj_Id, Decl)
-
-- Do not consider conversions of tags to class-wide types
and then not Is_Tag_To_CW_Conversion (Obj_Id);
-- Second test: within same unit, sort by location of the scope of
-- the entity definition.
- elsif Get_Scope_Num (T1.Ent_Scope) /=
- Get_Scope_Num (T2.Ent_Scope)
+ elsif Get_Scope_Num (T1.Key.Ent_Scope) /=
+ Get_Scope_Num (T2.Key.Ent_Scope)
then
- return Get_Scope_Num (T1.Ent_Scope) < Get_Scope_Num (T2.Ent_Scope);
+ return Get_Scope_Num (T1.Key.Ent_Scope) <
+ Get_Scope_Num (T2.Key.Ent_Scope);
-- Third test: within same unit and scope, sort by location of
-- entity definition.
-- Fourth test: if reference is in same unit as entity definition,
-- sort first.
- elsif T1.Lun /= T2.Lun and then T1.Ent_Scope_File = T1.Lun then
+ elsif
+ T1.Key.Lun /= T2.Key.Lun and then T1.Ent_Scope_File = T1.Key.Lun
+ then
return True;
- elsif T1.Lun /= T2.Lun and then T2.Ent_Scope_File = T2.Lun then
+
+ elsif
+ T1.Key.Lun /= T2.Key.Lun and then T2.Ent_Scope_File = T2.Key.Lun
+ then
return False;
-- Fifth test: if reference is in same unit and same scope as entity
-- definition, sort first.
- elsif T1.Ent_Scope_File = T1.Lun
- and then T1.Ref_Scope /= T2.Ref_Scope
- and then T1.Ent_Scope = T1.Ref_Scope
+ elsif T1.Ent_Scope_File = T1.Key.Lun
+ and then T1.Key.Ref_Scope /= T2.Key.Ref_Scope
+ and then T1.Key.Ent_Scope = T1.Key.Ref_Scope
then
return True;
- elsif T1.Ent_Scope_File = T1.Lun
- and then T1.Ref_Scope /= T2.Ref_Scope
- and then T2.Ent_Scope = T2.Ref_Scope
+ elsif T1.Ent_Scope_File = T1.Key.Lun
+ and then T1.Key.Ref_Scope /= T2.Key.Ref_Scope
+ and then T2.Key.Ent_Scope = T2.Key.Ref_Scope
then
return False;
-- Sixth test: for same entity, sort by reference location unit
- elsif T1.Lun /= T2.Lun then
- return Dependency_Num (T1.Lun) < Dependency_Num (T2.Lun);
+ elsif T1.Key.Lun /= T2.Key.Lun then
+ return Dependency_Num (T1.Key.Lun) < Dependency_Num (T2.Key.Lun);
-- Seventh test: for same entity, sort by reference location scope
- elsif Get_Scope_Num (T1.Ref_Scope) /=
- Get_Scope_Num (T2.Ref_Scope)
+ elsif Get_Scope_Num (T1.Key.Ref_Scope) /=
+ Get_Scope_Num (T2.Key.Ref_Scope)
then
- return Get_Scope_Num (T1.Ref_Scope) < Get_Scope_Num (T2.Ref_Scope);
+ return Get_Scope_Num (T1.Key.Ref_Scope) <
+ Get_Scope_Num (T2.Key.Ref_Scope);
-- Eighth test: order of location within referencing unit
- elsif T1.Loc /= T2.Loc then
- return T1.Loc < T2.Loc;
+ elsif T1.Key.Loc /= T2.Key.Loc then
+ return T1.Key.Loc < T2.Key.Loc;
-- Finally, for two locations at the same address prefer the one that
-- does NOT have the type 'r', so that a modification or extension
-- in-out actuals, the read reference follows the modify reference.
else
- return T2.Typ = 'r';
+ return T2.Key.Typ = 'r';
end if;
end Lt;
-- Set entity at this point with newly created "Heap" variable
- Xrefs.Table (Xrefs.Last).Ent := Heap;
+ Xrefs.Table (Xrefs.Last).Key.Ent := Heap;
Nrefs := Nrefs + 1;
Rnums (Nrefs) := Xrefs.Last;
Nrefs := 0;
for J in 1 .. NR loop
- if Alfa_Entities (Ekind (Xrefs.Table (Rnums (J)).Ent))
- and then Alfa_References (Xrefs.Table (Rnums (J)).Typ)
- and then Is_Alfa_Scope (Xrefs.Table (Rnums (J)).Ent_Scope)
- and then Is_Alfa_Scope (Xrefs.Table (Rnums (J)).Ref_Scope)
- and then not Is_Global_Constant (Xrefs.Table (Rnums (J)).Ent)
- and then Is_Alfa_Reference (Xrefs.Table (Rnums (J)).Ent,
- Xrefs.Table (Rnums (J)).Typ)
+ if Alfa_Entities (Ekind (Xrefs.Table (Rnums (J)).Key.Ent))
+ and then Alfa_References (Xrefs.Table (Rnums (J)).Key.Typ)
+ and then Is_Alfa_Scope (Xrefs.Table (Rnums (J)).Key.Ent_Scope)
+ and then Is_Alfa_Scope (Xrefs.Table (Rnums (J)).Key.Ref_Scope)
+ and then not Is_Global_Constant (Xrefs.Table (Rnums (J)).Key.Ent)
+ and then Is_Alfa_Reference (Xrefs.Table (Rnums (J)).Key.Ent,
+ Xrefs.Table (Rnums (J)).Key.Typ)
then
Nrefs := Nrefs + 1;
Rnums (Nrefs) := Rnums (J);
Prevt := 'm';
for J in 1 .. NR loop
- if Xrefs.Table (Rnums (J)).Loc /= Crloc
+ if Xrefs.Table (Rnums (J)).Key.Loc /= Crloc
or else (Prevt = 'm'
- and then Xrefs.Table (Rnums (J)).Typ = 'r')
+ and then Xrefs.Table (Rnums (J)).Key.Typ = 'r')
then
- Crloc := Xrefs.Table (Rnums (J)).Loc;
- Prevt := Xrefs.Table (Rnums (J)).Typ;
+ Crloc := Xrefs.Table (Rnums (J)).Key.Loc;
+ Prevt := Xrefs.Table (Rnums (J)).Key.Typ;
Nrefs := Nrefs + 1;
Rnums (Nrefs) := Rnums (J);
end if;
-- construction of the scope table, or an erroneous scope for the
-- current cross-reference.
- pragma Assert (Is_Future_Scope_Entity (XE.Ent_Scope));
+ pragma Assert (Is_Future_Scope_Entity (XE.Key.Ent_Scope));
-- Update the range of cross references to which the current scope
-- refers to. This may be the empty range only for the first scope
-- considered.
- if XE.Ent_Scope /= Cur_Scope then
+ if XE.Key.Ent_Scope /= Cur_Scope then
Alfa_Scope_Table.Table (Cur_Scope_Idx).From_Xref :=
From_Xref_Idx;
Alfa_Scope_Table.Table (Cur_Scope_Idx).To_Xref :=
From_Xref_Idx := Alfa_Xref_Table.Last + 1;
end if;
- while XE.Ent_Scope /= Cur_Scope loop
+ while XE.Key.Ent_Scope /= Cur_Scope loop
Cur_Scope_Idx := Cur_Scope_Idx + 1;
pragma Assert (Cur_Scope_Idx <= Alfa_Scope_Table.Last);
end loop;
- if XE.Ent /= Cur_Entity then
+ if XE.Key.Ent /= Cur_Entity then
Cur_Entity_Name :=
- new String'(Unique_Name (XE.Ent));
+ new String'(Unique_Name (XE.Key.Ent));
end if;
- if XE.Ent = Heap then
+ if XE.Key.Ent = Heap then
Alfa_Xref_Table.Append (
(Entity_Name => Cur_Entity_Name,
Entity_Line => 0,
- Etype => Get_Entity_Type (XE.Ent),
+ Etype => Get_Entity_Type (XE.Key.Ent),
Entity_Col => 0,
- File_Num => Dependency_Num (XE.Lun),
- Scope_Num => Get_Scope_Num (XE.Ref_Scope),
- Line => Int (Get_Logical_Line_Number (XE.Loc)),
- Rtype => XE.Typ,
- Col => Int (Get_Column_Number (XE.Loc))));
+ File_Num => Dependency_Num (XE.Key.Lun),
+ Scope_Num => Get_Scope_Num (XE.Key.Ref_Scope),
+ Line => Int (Get_Logical_Line_Number (XE.Key.Loc)),
+ Rtype => XE.Key.Typ,
+ Col => Int (Get_Column_Number (XE.Key.Loc))));
else
Alfa_Xref_Table.Append (
(Entity_Name => Cur_Entity_Name,
Entity_Line => Int (Get_Logical_Line_Number (XE.Def)),
- Etype => Get_Entity_Type (XE.Ent),
+ Etype => Get_Entity_Type (XE.Key.Ent),
Entity_Col => Int (Get_Column_Number (XE.Def)),
- File_Num => Dependency_Num (XE.Lun),
- Scope_Num => Get_Scope_Num (XE.Ref_Scope),
- Line => Int (Get_Logical_Line_Number (XE.Loc)),
- Rtype => XE.Typ,
- Col => Int (Get_Column_Number (XE.Loc))));
+ File_Num => Dependency_Num (XE.Key.Lun),
+ Scope_Num => Get_Scope_Num (XE.Key.Ref_Scope),
+ Line => Int (Get_Logical_Line_Number (XE.Key.Loc)),
+ Rtype => XE.Key.Typ,
+ Col => Int (Get_Column_Number (XE.Key.Loc))));
end if;
end Add_One_Xref;
end loop;
-- Entity is filled later on with the special "Heap" variable
- Drefs.Table (Indx).Ent := Empty;
+ Drefs.Table (Indx).Key.Ent := Empty;
Drefs.Table (Indx).Def := No_Location;
- Drefs.Table (Indx).Loc := Ref;
- Drefs.Table (Indx).Typ := Typ;
+ Drefs.Table (Indx).Key.Loc := Ref;
+ Drefs.Table (Indx).Key.Typ := Typ;
-- It is as if the special "Heap" was defined in every scope where it
-- is referenced.
- Drefs.Table (Indx).Eun := Get_Source_Unit (Ref);
- Drefs.Table (Indx).Lun := Get_Source_Unit (Ref);
+ Drefs.Table (Indx).Key.Eun := Get_Source_Unit (Ref);
+ Drefs.Table (Indx).Key.Lun := Get_Source_Unit (Ref);
- Drefs.Table (Indx).Ref_Scope := Ref_Scope;
- Drefs.Table (Indx).Ent_Scope := Ref_Scope;
+ Drefs.Table (Indx).Key.Ref_Scope := Ref_Scope;
+ Drefs.Table (Indx).Key.Ent_Scope := Ref_Scope;
Drefs.Table (Indx).Ent_Scope_File := Get_Source_Unit (Ref_Scope);
end if;
end Generate_Dereference;
with Table; use Table;
with GNAT.Heap_Sort_G;
+with GNAT.HTable;
package body Lib.Xref is
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
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);
+
----------------------
-- Alfa Information --
----------------------
function Lt (T1, T2 : Xref_Entry) return Boolean;
-- Order cross-references
+ procedure Add_Entry (Key : Xref_Key; Ent_Scope_File : Unit_Number_Type);
+ -- Add an entry to the tables of Xref_Entries, avoiding duplicates
+
+ ---------------
+ -- 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;
+
+ -----------
+ -- 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).Typ := ' ';
- Xrefs.Table (Indx).Def := No_Location;
- Xrefs.Table (Indx).Loc := No_Location;
-
- Xrefs.Table (Indx).Eun := Get_Source_Unit (Loc);
-
- Xrefs.Table (Indx).Ref_Scope := Empty;
- Xrefs.Table (Indx).Ent_Scope := Empty;
- Xrefs.Table (Indx).Ent_Scope_File := 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);
Set_Ref : Boolean := True;
Force : Boolean := False)
is
- Indx : Nat;
Nod : Node_Id;
Ref : Source_Ptr;
Def : Source_Ptr;
Ent : Entity_Id;
- Ref_Scope : Entity_Id;
- Ent_Scope : Entity_Id;
+ Actual_Typ : Character := Typ;
+
+ Ref_Scope : Entity_Id;
+ Ent_Scope : Entity_Id;
+ Ent_Scope_File : Unit_Number_Type;
Call : Node_Id;
Formal : Entity_Id;
Ref := Original_Location (Sloc (Nod));
Def := Original_Location (Sloc (Ent));
- Ref_Scope := Alfa.Enclosing_Subprogram_Or_Package (N);
- Ent_Scope := Alfa.Enclosing_Subprogram_Or_Package (Ent);
-
- Xrefs.Increment_Last;
- Indx := Xrefs.Last;
-
- Xrefs.Table (Indx).Loc := Ref;
-
- -- Overriding operations are marked with 'P'
-
- if Typ = 'p'
+ if Actual_Typ = 'p'
and then Is_Subprogram (N)
and then Present (Overridden_Operation (N))
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;
+ if Alfa_Mode then
+ Ref_Scope := Alfa.Enclosing_Subprogram_Or_Package (N);
+ Ent_Scope := Alfa.Enclosing_Subprogram_Or_Package (Ent);
+ Ent_Scope_File := Get_Source_Unit (Ent_Scope);
- Xrefs.Table (Indx).Ref_Scope := Ref_Scope;
- Xrefs.Table (Indx).Ent_Scope := Ent_Scope;
- Xrefs.Table (Indx).Ent_Scope_File := Get_Source_Unit (Ent_Scope);
+ else
+ Ref_Scope := Empty;
+ Ent_Scope := Empty;
+ Ent_Scope_File := No_Unit;
+ end if;
- Set_Has_Xref_Entry (Ent);
+ Add_Entry
+ ((Ent => Ent,
+ Loc => Ref,
+ Typ => Actual_Typ,
+ Eun => Get_Source_Unit (Def),
+ Lun => Get_Source_Unit (Ref),
+ Ref_Scope => Ref_Scope,
+ Ent_Scope => Ent_Scope),
+ Ent_Scope_File => Ent_Scope_File);
end if;
end Generate_Reference;
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;
+
+ ----------
+ -- 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'Mod (XE.Key.Ent) + 2**7 * M'Mod (XE.Key.Loc);
+ 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 --
----------------
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);
+ 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
-- Third test: sort definitions ahead of references
- elsif T1.Loc = No_Location then
+ elsif T1.Key.Loc = No_Location then
return True;
- elsif T2.Loc = No_Location then
+ elsif T2.Key.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);
+ 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.Loc /= T2.Loc then
- return T1.Loc < T2.Loc;
+ 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
-- the modify reference.
else
- return T2.Typ = 'r';
+ return T2.Key.Typ = 'r';
end if;
end Lt;
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)
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;
Get_Type_Reference (Ent, Tref, L, R);
if Present (Tref)
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);
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.
for J in 1 .. Nrefs loop
Rnums (J) := J;
Xrefs.Table (J).Def :=
- Original_Location (Sloc (Xrefs.Table (J).Ent));
+ Original_Location (Sloc (Xrefs.Table (J).Key.Ent));
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;
-- Start of processing for Output_One_Ref
begin
- Ent := XE.Ent;
+ Ent := XE.Key.Ent;
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)
+ Ent /= Xrefs.Table (Rnums (Refno + 1)).Key.Ent)
and then
not In_Extended_Main_Source_Unit (Ent)
then
-- 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)));
-- Special handling for access parameters and objects of
-- an anonymous access type.
- if Ekind_In (Etype (XE.Ent),
+ if Ekind_In (Etype (XE.Key.Ent),
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_In (XE.Key.Ent, E_Variable, E_Constant)
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
-- Suppress references to object definitions, used for local
-- references.
- or else XE.Typ = 'D'
- or else XE.Typ = 'I'
+ 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.Loc = XE.Def
+ or else (XE.Key.Loc = XE.Def
and then
- (XE.Typ /= 'b'
- or else not Is_Subprogram (XE.Ent)))
+ (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).
- 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;
+ 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);
declare
Ent_Name : constant String :=
- Exact_Source_Name (Sloc (XE.Ent));
+ Exact_Source_Name (Sloc (XE.Key.Ent));
begin
for C in Ent_Name'Range loop
Write_Info_Char (Ent_Name (C));
-- 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
- if Is_Record_Type (XE.Ent)
- and then Present (Interfaces (XE.Ent))
+ if Is_Record_Type (XE.Key.Ent)
+ and then Present (Interfaces (XE.Key.Ent))
then
declare
- Elmt : Elmt_Id := First_Elmt (Interfaces (XE.Ent));
+ Elmt : Elmt_Id :=
+ First_Elmt (Interfaces (XE.Key.Ent));
begin
while Present (Elmt) loop
Check_Type_Reference (Node (Elmt), True);
-- For array types, list index types as well. (This is
-- not C, indexes have distinct types).
- elsif Is_Array_Type (XE.Ent) then
+ elsif Is_Array_Type (XE.Key.Ent) then
declare
Indx : Node_Id;
begin
- Indx := First_Index (XE.Ent);
+ 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 Present (Overridden_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
-- 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
+ if XE.Key.Loc /= No_Location
and then
- (XE.Loc /= Crloc
- or else (Prevt = 'm' and then XE.Typ = 'r'))
+ (XE.Key.Loc /= Crloc
+ or else (Prevt = 'm' and then XE.Key.Typ = 'r'))
then
- Crloc := XE.Loc;
- Prevt := XE.Typ;
+ 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'
+ if Is_Overloadable (XE.Key.Ent)
+ and then Is_Imported (XE.Key.Ent)
+ and then XE.Key.Typ = 'b'
then
- Output_Import_Export_Info (XE.Ent);
+ Output_Import_Export_Info (XE.Key.Ent);
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;
+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 / platform / upstream / linaro-gcc.git / commitdiff