diff options
Diffstat (limited to 'gcc-4.7/gcc/ada/lib-xref-alfa.adb')
| -rw-r--r-- | gcc-4.7/gcc/ada/lib-xref-alfa.adb | 1427 |
1 files changed, 0 insertions, 1427 deletions
diff --git a/gcc-4.7/gcc/ada/lib-xref-alfa.adb b/gcc-4.7/gcc/ada/lib-xref-alfa.adb deleted file mode 100644 index cc0aa3ac8..000000000 --- a/gcc-4.7/gcc/ada/lib-xref-alfa.adb +++ /dev/null @@ -1,1427 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- L I B . X R E F . A L F A -- --- -- --- B o d y -- --- -- --- Copyright (C) 2011, 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- -- --- ware Foundation; either version 3, or (at your option) any later ver- -- --- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- --- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- --- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- --- for more details. You should have received a copy of the GNU General -- --- Public License distributed with GNAT; see file COPYING3. If not, go to -- --- http://www.gnu.org/licenses for a complete copy of the license. -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Alfa; use Alfa; -with Einfo; use Einfo; -with Nmake; use Nmake; -with Put_Alfa; - -with GNAT.HTable; - -separate (Lib.Xref) -package body Alfa is - - --------------------- - -- Local Constants -- - --------------------- - - -- Table of Alfa_Entities, True for each entity kind used in Alfa - - Alfa_Entities : constant array (Entity_Kind) of Boolean := - (E_Void => False, - E_Variable => True, - E_Component => False, - E_Constant => True, - E_Discriminant => False, - - E_Loop_Parameter => True, - E_In_Parameter => True, - E_Out_Parameter => True, - E_In_Out_Parameter => True, - E_Generic_In_Out_Parameter => False, - - E_Generic_In_Parameter => False, - E_Named_Integer => False, - E_Named_Real => False, - E_Enumeration_Type => False, - E_Enumeration_Subtype => False, - - E_Signed_Integer_Type => False, - E_Signed_Integer_Subtype => False, - E_Modular_Integer_Type => False, - E_Modular_Integer_Subtype => False, - E_Ordinary_Fixed_Point_Type => False, - - E_Ordinary_Fixed_Point_Subtype => False, - E_Decimal_Fixed_Point_Type => False, - E_Decimal_Fixed_Point_Subtype => False, - E_Floating_Point_Type => False, - E_Floating_Point_Subtype => False, - - E_Access_Type => False, - E_Access_Subtype => False, - E_Access_Attribute_Type => False, - E_Allocator_Type => False, - E_General_Access_Type => False, - - E_Access_Subprogram_Type => False, - E_Access_Protected_Subprogram_Type => False, - E_Anonymous_Access_Subprogram_Type => False, - E_Anonymous_Access_Protected_Subprogram_Type => False, - E_Anonymous_Access_Type => False, - - E_Array_Type => False, - E_Array_Subtype => False, - E_String_Type => False, - E_String_Subtype => False, - E_String_Literal_Subtype => False, - - E_Class_Wide_Type => False, - E_Class_Wide_Subtype => False, - E_Record_Type => False, - E_Record_Subtype => False, - E_Record_Type_With_Private => False, - - E_Record_Subtype_With_Private => False, - E_Private_Type => False, - E_Private_Subtype => False, - E_Limited_Private_Type => False, - E_Limited_Private_Subtype => False, - - E_Incomplete_Type => False, - E_Incomplete_Subtype => False, - E_Task_Type => False, - E_Task_Subtype => False, - E_Protected_Type => False, - - E_Protected_Subtype => False, - E_Exception_Type => False, - E_Subprogram_Type => False, - E_Enumeration_Literal => False, - E_Function => True, - - E_Operator => True, - E_Procedure => True, - E_Entry => False, - E_Entry_Family => False, - E_Block => False, - - E_Entry_Index_Parameter => False, - E_Exception => False, - E_Generic_Function => False, - E_Generic_Package => False, - E_Generic_Procedure => False, - - E_Label => False, - E_Loop => False, - E_Return_Statement => False, - E_Package => False, - - E_Package_Body => False, - E_Protected_Object => False, - E_Protected_Body => False, - E_Task_Body => False, - E_Subprogram_Body => False); - - -- True for each reference type used in Alfa - Alfa_References : constant array (Character) of Boolean := - ('m' => True, - 'r' => True, - 's' => True, - others => False); - - type Entity_Hashed_Range is range 0 .. 255; - -- Size of hash table headers - - --------------------- - -- Local Variables -- - --------------------- - - package Drefs 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 => "Drefs"); - -- Table of cross-references for reads and writes through explicit - -- dereferences, that are output as reads/writes to the special variable - -- "Heap". These references are added to the regular references when - -- computing Alfa cross-references. - - ----------------------- - -- Local Subprograms -- - ----------------------- - - procedure Add_Alfa_File (U : Unit_Number_Type; D : Nat); - -- Add file U and all scopes in U to the tables Alfa_File_Table and - -- Alfa_Scope_Table. - - procedure Add_Alfa_Scope (N : Node_Id); - -- Add scope N to the table Alfa_Scope_Table - - procedure Add_Alfa_Xrefs; - -- Filter table Xrefs to add all references used in Alfa to the table - -- Alfa_Xref_Table. - - procedure Detect_And_Add_Alfa_Scope (N : Node_Id); - -- Call Add_Alfa_Scope on scopes - - function Entity_Hash (E : Entity_Id) return Entity_Hashed_Range; - -- Hash function for hash table - - procedure Traverse_Declarations_Or_Statements - (L : List_Id; - Process : Node_Processing; - Inside_Stubs : Boolean); - procedure Traverse_Handled_Statement_Sequence - (N : Node_Id; - Process : Node_Processing; - Inside_Stubs : Boolean); - procedure Traverse_Package_Body - (N : Node_Id; - Process : Node_Processing; - Inside_Stubs : Boolean); - procedure Traverse_Package_Declaration - (N : Node_Id; - Process : Node_Processing; - Inside_Stubs : Boolean); - procedure Traverse_Subprogram_Body - (N : Node_Id; - Process : Node_Processing; - Inside_Stubs : Boolean); - -- Traverse the corresponding constructs, calling Process on all - -- declarations. - - ------------------- - -- Add_Alfa_File -- - ------------------- - - procedure Add_Alfa_File (U : Unit_Number_Type; D : Nat) is - From : Scope_Index; - - S : constant Source_File_Index := Source_Index (U); - - begin - -- Source file could be inexistant as a result of an error, if option - -- gnatQ is used. - - if S = No_Source_File then - return; - end if; - - From := Alfa_Scope_Table.Last + 1; - - Traverse_Compilation_Unit (Cunit (U), Detect_And_Add_Alfa_Scope'Access, - Inside_Stubs => False); - - -- Update scope numbers - - declare - Count : Nat; - - begin - Count := 1; - for S in From .. Alfa_Scope_Table.Last loop - declare - E : Entity_Id renames Alfa_Scope_Table.Table (S).Scope_Entity; - - begin - if Lib.Get_Source_Unit (E) = U then - Alfa_Scope_Table.Table (S).Scope_Num := Count; - Alfa_Scope_Table.Table (S).File_Num := D; - Count := Count + 1; - - else - -- Mark for removal a scope S which is not located in unit - -- U, for example for scope inside generics that get - -- instantiated. - - Alfa_Scope_Table.Table (S).Scope_Num := 0; - end if; - end; - end loop; - end; - - declare - Snew : Scope_Index; - - begin - Snew := From; - for S in From .. Alfa_Scope_Table.Last loop - -- Remove those scopes previously marked for removal - - if Alfa_Scope_Table.Table (S).Scope_Num /= 0 then - Alfa_Scope_Table.Table (Snew) := Alfa_Scope_Table.Table (S); - Snew := Snew + 1; - end if; - end loop; - - Alfa_Scope_Table.Set_Last (Snew - 1); - end; - - -- Make entry for new file in file table - - Get_Name_String (Reference_Name (S)); - - Alfa_File_Table.Append ( - (File_Name => new String'(Name_Buffer (1 .. Name_Len)), - File_Num => D, - From_Scope => From, - To_Scope => Alfa_Scope_Table.Last)); - end Add_Alfa_File; - - -------------------- - -- Add_Alfa_Scope -- - -------------------- - - procedure Add_Alfa_Scope (N : Node_Id) is - E : constant Entity_Id := Defining_Entity (N); - Loc : constant Source_Ptr := Sloc (E); - Typ : Character; - - begin - -- Ignore scopes without a proper location - - if Sloc (N) = No_Location then - return; - end if; - - case Ekind (E) is - when E_Function | E_Generic_Function => - Typ := 'V'; - - when E_Procedure | E_Generic_Procedure => - Typ := 'U'; - - when E_Subprogram_Body => - declare - Spec : Node_Id; - - begin - Spec := Parent (E); - - if Nkind (Spec) = N_Defining_Program_Unit_Name then - Spec := Parent (Spec); - end if; - - if Nkind (Spec) = N_Function_Specification then - Typ := 'V'; - else - pragma Assert - (Nkind (Spec) = N_Procedure_Specification); - Typ := 'U'; - end if; - end; - - when E_Package | E_Package_Body | E_Generic_Package => - Typ := 'K'; - - when E_Void => - -- Compilation of prj-attr.adb with -gnatn creates a node with - -- entity E_Void for the package defined at a-charac.ads16:13 - - -- ??? TBD - - return; - - when others => - raise Program_Error; - end case; - - -- File_Num and Scope_Num are filled later. From_Xref and To_Xref are - -- filled even later, but are initialized to represent an empty range. - - Alfa_Scope_Table.Append ( - (Scope_Name => new String'(Unique_Name (E)), - File_Num => 0, - Scope_Num => 0, - Spec_File_Num => 0, - Spec_Scope_Num => 0, - Line => Nat (Get_Logical_Line_Number (Loc)), - Stype => Typ, - Col => Nat (Get_Column_Number (Loc)), - From_Xref => 1, - To_Xref => 0, - Scope_Entity => E)); - end Add_Alfa_Scope; - - -------------------- - -- Add_Alfa_Xrefs -- - -------------------- - - procedure Add_Alfa_Xrefs is - Cur_Scope_Idx : Scope_Index; - From_Xref_Idx : Xref_Index; - Cur_Entity : Entity_Id; - Cur_Entity_Name : String_Ptr; - - package Scopes is - No_Scope : constant Nat := 0; - function Get_Scope_Num (N : Entity_Id) return Nat; - procedure Set_Scope_Num (N : Entity_Id; Num : Nat); - end Scopes; - - ------------ - -- Scopes -- - ------------ - - package body Scopes is - type Scope is record - Num : Nat; - Entity : Entity_Id; - end record; - - package Scopes is new GNAT.HTable.Simple_HTable - (Header_Num => Entity_Hashed_Range, - Element => Scope, - No_Element => (Num => No_Scope, Entity => Empty), - Key => Entity_Id, - Hash => Entity_Hash, - Equal => "="); - - ------------------- - -- Get_Scope_Num -- - ------------------- - - function Get_Scope_Num (N : Entity_Id) return Nat is - begin - return Scopes.Get (N).Num; - end Get_Scope_Num; - - ------------------- - -- Set_Scope_Num -- - ------------------- - - procedure Set_Scope_Num (N : Entity_Id; Num : Nat) is - begin - Scopes.Set (K => N, E => Scope'(Num => Num, Entity => N)); - end Set_Scope_Num; - end Scopes; - - use Scopes; - - Nrefs : Nat := Xrefs.Last; - -- Number of references in table. This value may get reset (reduced) - -- when we eliminate duplicate reference entries as well as references - -- not suitable for local cross-references. - - Nrefs_Add : constant Nat := Drefs.Last; - - Rnums : array (0 .. Nrefs + Nrefs_Add) of Nat; - -- This array contains numbers of references in the Xrefs table. This - -- list is sorted in output order. The extra 0'th entry is convenient - -- for the call to sort. When we sort the table, we move the entries in - -- Rnums around, but we do not move the original table entries. - - function Lt (Op1, Op2 : Natural) return Boolean; - -- Comparison function for Sort call - - procedure Move (From : Natural; To : Natural); - -- Move procedure for Sort call - - package Sorting is new GNAT.Heap_Sort_G (Move, Lt); - - -------- - -- Lt -- - -------- - - function Lt (Op1, Op2 : Natural) return Boolean is - T1 : constant Xref_Entry := Xrefs.Table (Rnums (Nat (Op1))); - T2 : constant Xref_Entry := Xrefs.Table (Rnums (Nat (Op2))); - - begin - -- First test: if entity is in different unit, sort by unit. Note: - -- that we use Ent_Scope_File rather than Eun, as Eun may refer to - -- the file where the generic scope is defined, which may differ from - -- the file where the enclosing scope is defined. It is the latter - -- which matters for a correct order here. - - if T1.Ent_Scope_File /= T2.Ent_Scope_File then - return Dependency_Num (T1.Ent_Scope_File) < - Dependency_Num (T2.Ent_Scope_File); - - -- Second test: within same unit, sort by location of the scope of - -- the entity definition. - - elsif Get_Scope_Num (T1.Key.Ent_Scope) /= - Get_Scope_Num (T2.Key.Ent_Scope) - then - 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. - - elsif T1.Def /= T2.Def then - return T1.Def < T2.Def; - - -- Fourth test: if reference is in same unit as entity definition, - -- sort first. - - elsif - T1.Key.Lun /= T2.Key.Lun and then T1.Ent_Scope_File = T1.Key.Lun - then - return True; - - 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.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.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.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.Key.Ref_Scope) /= - Get_Scope_Num (T2.Key.Ref_Scope) - then - 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.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 - -- 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; - - ---------- - -- Move -- - ---------- - - procedure Move (From : Natural; To : Natural) is - begin - Rnums (Nat (To)) := Rnums (Nat (From)); - end Move; - - Heap : Entity_Id; - - -- Start of processing for Add_Alfa_Xrefs - - begin - for J in Alfa_Scope_Table.First .. Alfa_Scope_Table.Last loop - Set_Scope_Num (N => Alfa_Scope_Table.Table (J).Scope_Entity, - Num => Alfa_Scope_Table.Table (J).Scope_Num); - end loop; - - -- Set up the pointer vector for the sort - - for J in 1 .. Nrefs loop - Rnums (J) := J; - end loop; - - -- Add dereferences to the set of regular references, by creating a - -- special "Heap" variable for these special references. - - Name_Len := Name_Of_Heap_Variable'Length; - Name_Buffer (1 .. Name_Len) := Name_Of_Heap_Variable; - - Atree.Unlock; - Nlists.Unlock; - Heap := Make_Defining_Identifier (Standard_Location, Name_Enter); - Atree.Lock; - Nlists.Lock; - - Set_Ekind (Heap, E_Variable); - Set_Is_Internal (Heap, True); - Set_Has_Fully_Qualified_Name (Heap); - - for J in Drefs.First .. Drefs.Last loop - Xrefs.Append (Drefs.Table (J)); - - -- Set entity at this point with newly created "Heap" variable - - Xrefs.Table (Xrefs.Last).Key.Ent := Heap; - - Nrefs := Nrefs + 1; - Rnums (Nrefs) := Xrefs.Last; - end loop; - - -- Eliminate entries not appropriate for Alfa. Done prior to sorting - -- cross-references, as it discards useless references which do not have - -- a proper format for the comparison function (like no location). - - Eliminate_Before_Sort : declare - NR : Nat; - - function Is_Alfa_Reference - (E : Entity_Id; - Typ : Character) return Boolean; - -- Return whether entity reference E meets Alfa requirements. Typ - -- is the reference type. - - function Is_Alfa_Scope (E : Entity_Id) return Boolean; - -- Return whether the entity or reference scope meets requirements - -- for being an Alfa scope. - - function Is_Global_Constant (E : Entity_Id) return Boolean; - -- Return True if E is a global constant for which we should ignore - -- reads in Alfa. - - ----------------------- - -- Is_Alfa_Reference -- - ----------------------- - - function Is_Alfa_Reference - (E : Entity_Id; - Typ : Character) return Boolean - is - begin - -- The only references of interest on callable entities are calls. - -- On non-callable entities, the only references of interest are - -- reads and writes. - - if Ekind (E) in Overloadable_Kind then - return Typ = 's'; - - -- References to constant objects are not considered in Alfa - -- section, as these will be translated as constants in the - -- intermediate language for formal verification, and should - -- therefore never appear in frame conditions. - - elsif Is_Constant_Object (E) then - return False; - - -- Objects of Task type or protected type are not Alfa references - - elsif Present (Etype (E)) - and then Ekind (Etype (E)) in Concurrent_Kind - then - return False; - - -- In all other cases, result is true for reference/modify cases, - -- and false for all other cases. - - else - return Typ = 'r' or else Typ = 'm'; - end if; - end Is_Alfa_Reference; - - ------------------- - -- Is_Alfa_Scope -- - ------------------- - - function Is_Alfa_Scope (E : Entity_Id) return Boolean is - begin - return Present (E) - and then not Is_Generic_Unit (E) - and then Renamed_Entity (E) = Empty - and then Get_Scope_Num (E) /= No_Scope; - end Is_Alfa_Scope; - - ------------------------ - -- Is_Global_Constant -- - ------------------------ - - function Is_Global_Constant (E : Entity_Id) return Boolean is - begin - return Ekind (E) = E_Constant - and then Ekind_In (Scope (E), E_Package, E_Package_Body); - end Is_Global_Constant; - - -- Start of processing for Eliminate_Before_Sort - - begin - NR := Nrefs; - Nrefs := 0; - - for J in 1 .. NR loop - 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); - end if; - end loop; - end Eliminate_Before_Sort; - - -- Sort the references - - Sorting.Sort (Integer (Nrefs)); - - Eliminate_After_Sort : declare - NR : Nat; - - Crloc : Source_Ptr; - -- Current reference location - - Prevt : Character; - -- reference kind of previous reference - - begin - -- Eliminate duplicate entries - - -- 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 Nrefs >= 2 then - NR := Nrefs; - 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; - - -- Eliminate the reference if it is at the same location as the - -- previous one, unless it is a read-reference indicating that the - -- entity is an in-out actual in a call. - - NR := Nrefs; - Nrefs := 0; - Crloc := No_Location; - Prevt := 'm'; - - for J in 1 .. NR loop - if Xrefs.Table (Rnums (J)).Key.Loc /= Crloc - or else (Prevt = 'm' - and then Xrefs.Table (Rnums (J)).Key.Typ = 'r') - then - Crloc := Xrefs.Table (Rnums (J)).Key.Loc; - Prevt := Xrefs.Table (Rnums (J)).Key.Typ; - Nrefs := Nrefs + 1; - Rnums (Nrefs) := Rnums (J); - end if; - end loop; - end Eliminate_After_Sort; - - -- Initialize loop - - Cur_Scope_Idx := 1; - From_Xref_Idx := 1; - Cur_Entity := Empty; - - if Alfa_Scope_Table.Last = 0 then - return; - end if; - - -- Loop to output references - - for Refno in 1 .. Nrefs loop - Add_One_Xref : declare - - ----------------------- - -- Local Subprograms -- - ----------------------- - - function Cur_Scope return Node_Id; - -- Return scope entity which corresponds to index Cur_Scope_Idx in - -- table Alfa_Scope_Table. - - function Get_Entity_Type (E : Entity_Id) return Character; - -- Return a character representing the type of entity - - function Is_Future_Scope_Entity (E : Entity_Id) return Boolean; - -- Check whether entity E is in Alfa_Scope_Table at index - -- Cur_Scope_Idx or higher. - - function Is_Past_Scope_Entity (E : Entity_Id) return Boolean; - -- Check whether entity E is in Alfa_Scope_Table at index strictly - -- lower than Cur_Scope_Idx. - - --------------- - -- Cur_Scope -- - --------------- - - function Cur_Scope return Node_Id is - begin - return Alfa_Scope_Table.Table (Cur_Scope_Idx).Scope_Entity; - end Cur_Scope; - - --------------------- - -- Get_Entity_Type -- - --------------------- - - function Get_Entity_Type (E : Entity_Id) return Character is - C : Character; - begin - case Ekind (E) is - when E_Out_Parameter => C := '<'; - when E_In_Out_Parameter => C := '='; - when E_In_Parameter => C := '>'; - when others => C := '*'; - end case; - return C; - end Get_Entity_Type; - - ---------------------------- - -- Is_Future_Scope_Entity -- - ---------------------------- - - function Is_Future_Scope_Entity (E : Entity_Id) return Boolean is - begin - for J in Cur_Scope_Idx .. Alfa_Scope_Table.Last loop - if E = Alfa_Scope_Table.Table (J).Scope_Entity then - return True; - end if; - end loop; - - -- If this assertion fails, this means that the scope which we - -- are looking for has been treated already, which reveals a - -- problem in the order of cross-references. - - pragma Assert (not Is_Past_Scope_Entity (E)); - - return False; - end Is_Future_Scope_Entity; - - -------------------------- - -- Is_Past_Scope_Entity -- - -------------------------- - - function Is_Past_Scope_Entity (E : Entity_Id) return Boolean is - begin - for J in Alfa_Scope_Table.First .. Cur_Scope_Idx - 1 loop - if E = Alfa_Scope_Table.Table (J).Scope_Entity then - return True; - end if; - end loop; - - return False; - end Is_Past_Scope_Entity; - - --------------------- - -- Local Variables -- - --------------------- - - XE : Xref_Entry renames Xrefs.Table (Rnums (Refno)); - - begin - -- If this assertion fails, the scope which we are looking for is - -- not in Alfa scope table, which reveals either a problem in the - -- construction of the scope table, or an erroneous scope for the - -- current cross-reference. - - 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.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 := - Alfa_Xref_Table.Last; - From_Xref_Idx := Alfa_Xref_Table.Last + 1; - end if; - - 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.Key.Ent /= Cur_Entity then - Cur_Entity_Name := - new String'(Unique_Name (XE.Key.Ent)); - end if; - - if XE.Key.Ent = Heap then - Alfa_Xref_Table.Append ( - (Entity_Name => Cur_Entity_Name, - Entity_Line => 0, - Etype => Get_Entity_Type (XE.Key.Ent), - Entity_Col => 0, - 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.Key.Ent), - Entity_Col => Int (Get_Column_Number (XE.Def)), - 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; - - -- Update the range of cross references to which the scope refers to - - Alfa_Scope_Table.Table (Cur_Scope_Idx).From_Xref := From_Xref_Idx; - Alfa_Scope_Table.Table (Cur_Scope_Idx).To_Xref := Alfa_Xref_Table.Last; - end Add_Alfa_Xrefs; - - ------------------ - -- Collect_Alfa -- - ------------------ - - procedure Collect_Alfa (Sdep_Table : Unit_Ref_Table; Num_Sdep : Nat) is - begin - -- Cross-references should have been computed first - - pragma Assert (Xrefs.Last /= 0); - - Initialize_Alfa_Tables; - - -- Generate file and scope Alfa information - - for D in 1 .. Num_Sdep loop - Add_Alfa_File (U => Sdep_Table (D), D => D); - end loop; - - -- Fill in the spec information when relevant - - declare - package Entity_Hash_Table is new - GNAT.HTable.Simple_HTable - (Header_Num => Entity_Hashed_Range, - Element => Scope_Index, - No_Element => 0, - Key => Entity_Id, - Hash => Entity_Hash, - Equal => "="); - - begin - -- Fill in the hash-table - - for S in Alfa_Scope_Table.First .. Alfa_Scope_Table.Last loop - declare - Srec : Alfa_Scope_Record renames Alfa_Scope_Table.Table (S); - begin - Entity_Hash_Table.Set (Srec.Scope_Entity, S); - end; - end loop; - - -- Use the hash-table to locate spec entities - - for S in Alfa_Scope_Table.First .. Alfa_Scope_Table.Last loop - declare - Srec : Alfa_Scope_Record renames Alfa_Scope_Table.Table (S); - - Spec_Entity : constant Entity_Id := - Unique_Entity (Srec.Scope_Entity); - Spec_Scope : constant Scope_Index := - Entity_Hash_Table.Get (Spec_Entity); - - begin - -- Spec of generic may be missing, in which case Spec_Scope is - -- zero. - - if Spec_Entity /= Srec.Scope_Entity - and then Spec_Scope /= 0 - then - Srec.Spec_File_Num := - Alfa_Scope_Table.Table (Spec_Scope).File_Num; - Srec.Spec_Scope_Num := - Alfa_Scope_Table.Table (Spec_Scope).Scope_Num; - end if; - end; - end loop; - end; - - -- Generate cross reference Alfa information - - Add_Alfa_Xrefs; - end Collect_Alfa; - - ------------------------------- - -- Detect_And_Add_Alfa_Scope -- - ------------------------------- - - procedure Detect_And_Add_Alfa_Scope (N : Node_Id) is - begin - if Nkind_In (N, N_Subprogram_Declaration, - N_Subprogram_Body, - N_Subprogram_Body_Stub, - N_Package_Declaration, - N_Package_Body) - then - Add_Alfa_Scope (N); - end if; - end Detect_And_Add_Alfa_Scope; - - ------------------------------------- - -- Enclosing_Subprogram_Or_Package -- - ------------------------------------- - - function Enclosing_Subprogram_Or_Package (N : Node_Id) return Entity_Id is - Result : Entity_Id; - - begin - -- If N is the defining identifier for a subprogram, then return the - -- enclosing subprogram or package, not this subprogram. - - if Nkind_In (N, N_Defining_Identifier, N_Defining_Operator_Symbol) - and then Nkind (Parent (N)) in N_Subprogram_Specification - then - Result := Parent (Parent (Parent (N))); - else - Result := N; - end if; - - loop - exit when No (Result); - - case Nkind (Result) is - when N_Package_Specification => - Result := Defining_Unit_Name (Result); - exit; - - when N_Package_Body => - Result := Defining_Unit_Name (Result); - exit; - - when N_Subprogram_Specification => - Result := Defining_Unit_Name (Result); - exit; - - when N_Subprogram_Declaration => - Result := Defining_Unit_Name (Specification (Result)); - exit; - - when N_Subprogram_Body => - Result := Defining_Unit_Name (Specification (Result)); - exit; - - -- The enclosing subprogram for a pre- or postconditions should be - -- the subprogram to which the pragma is attached. This is not - -- always the case in the AST, as the pragma may be declared after - -- the declaration of the subprogram. Return Empty in this case. - - when N_Pragma => - if Get_Pragma_Id (Result) = Pragma_Precondition - or else - Get_Pragma_Id (Result) = Pragma_Postcondition - then - return Empty; - else - Result := Parent (Result); - end if; - - when others => - Result := Parent (Result); - end case; - end loop; - - if Nkind (Result) = N_Defining_Program_Unit_Name then - Result := Defining_Identifier (Result); - end if; - - -- Do no return a scope without a proper location - - if Present (Result) - and then Sloc (Result) = No_Location - then - return Empty; - end if; - - return Result; - end Enclosing_Subprogram_Or_Package; - - ----------------- - -- Entity_Hash -- - ----------------- - - function Entity_Hash (E : Entity_Id) return Entity_Hashed_Range is - begin - return - Entity_Hashed_Range (E mod (Entity_Id (Entity_Hashed_Range'Last) + 1)); - end Entity_Hash; - - -------------------------- - -- Generate_Dereference -- - -------------------------- - - procedure Generate_Dereference - (N : Node_Id; - Typ : Character := 'r') - is - Indx : Nat; - Ref : Source_Ptr; - Ref_Scope : Entity_Id; - - begin - Ref := Original_Location (Sloc (N)); - - if Ref > No_Location then - Drefs.Increment_Last; - Indx := Drefs.Last; - - Ref_Scope := Enclosing_Subprogram_Or_Package (N); - - -- Entity is filled later on with the special "Heap" variable - - Drefs.Table (Indx).Key.Ent := Empty; - - Drefs.Table (Indx).Def := No_Location; - 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).Key.Eun := Get_Source_Unit (Ref); - Drefs.Table (Indx).Key.Lun := Get_Source_Unit (Ref); - - 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; - - ------------------------------------ - -- Traverse_All_Compilation_Units -- - ------------------------------------ - - procedure Traverse_All_Compilation_Units (Process : Node_Processing) is - begin - for U in Units.First .. Last_Unit loop - Traverse_Compilation_Unit (Cunit (U), Process, Inside_Stubs => False); - end loop; - end Traverse_All_Compilation_Units; - - ------------------------------- - -- Traverse_Compilation_Unit -- - ------------------------------- - - procedure Traverse_Compilation_Unit - (CU : Node_Id; - Process : Node_Processing; - Inside_Stubs : Boolean) - is - Lu : Node_Id; - - begin - -- Get Unit (checking case of subunit) - - Lu := Unit (CU); - - if Nkind (Lu) = N_Subunit then - Lu := Proper_Body (Lu); - end if; - - -- Call Process on all declarations - - if Nkind (Lu) in N_Declaration - or else Nkind (Lu) in N_Later_Decl_Item - then - Process (Lu); - end if; - - -- Traverse the unit - - if Nkind (Lu) = N_Subprogram_Body then - Traverse_Subprogram_Body (Lu, Process, Inside_Stubs); - - elsif Nkind (Lu) = N_Subprogram_Declaration then - null; - - elsif Nkind (Lu) = N_Package_Declaration then - Traverse_Package_Declaration (Lu, Process, Inside_Stubs); - - elsif Nkind (Lu) = N_Package_Body then - Traverse_Package_Body (Lu, Process, Inside_Stubs); - - -- ??? TBD - - elsif Nkind (Lu) = N_Generic_Package_Declaration then - null; - - -- ??? TBD - - elsif Nkind (Lu) in N_Generic_Instantiation then - null; - - -- All other cases of compilation units (e.g. renamings), are not - -- declarations. - - else - null; - end if; - end Traverse_Compilation_Unit; - - ----------------------------------------- - -- Traverse_Declarations_Or_Statements -- - ----------------------------------------- - - procedure Traverse_Declarations_Or_Statements - (L : List_Id; - Process : Node_Processing; - Inside_Stubs : Boolean) - is - N : Node_Id; - - begin - -- Loop through statements or declarations - - N := First (L); - while Present (N) loop - -- Call Process on all declarations - - if Nkind (N) in N_Declaration - or else - Nkind (N) in N_Later_Decl_Item - then - Process (N); - end if; - - case Nkind (N) is - - -- Package declaration - - when N_Package_Declaration => - Traverse_Package_Declaration (N, Process, Inside_Stubs); - - -- Generic package declaration ??? TBD - - when N_Generic_Package_Declaration => - null; - - -- Package body - - when N_Package_Body => - if Ekind (Defining_Entity (N)) /= E_Generic_Package then - Traverse_Package_Body (N, Process, Inside_Stubs); - end if; - - when N_Package_Body_Stub => - if Present (Library_Unit (N)) then - declare - Body_N : constant Node_Id := Get_Body_From_Stub (N); - begin - if Inside_Stubs - and then - Ekind (Defining_Entity (Body_N)) /= E_Generic_Package - then - Traverse_Package_Body (Body_N, Process, Inside_Stubs); - end if; - end; - end if; - - -- Subprogram declaration - - when N_Subprogram_Declaration => - null; - - -- Generic subprogram declaration ??? TBD - - when N_Generic_Subprogram_Declaration => - null; - - -- Subprogram body - - when N_Subprogram_Body => - if not Is_Generic_Subprogram (Defining_Entity (N)) then - Traverse_Subprogram_Body (N, Process, Inside_Stubs); - end if; - - when N_Subprogram_Body_Stub => - if Present (Library_Unit (N)) then - declare - Body_N : constant Node_Id := Get_Body_From_Stub (N); - begin - if Inside_Stubs - and then - not Is_Generic_Subprogram (Defining_Entity (Body_N)) - then - Traverse_Subprogram_Body - (Body_N, Process, Inside_Stubs); - end if; - end; - end if; - - -- Block statement - - when N_Block_Statement => - Traverse_Declarations_Or_Statements - (Declarations (N), Process, Inside_Stubs); - Traverse_Handled_Statement_Sequence - (Handled_Statement_Sequence (N), Process, Inside_Stubs); - - when N_If_Statement => - - -- Traverse the statements in the THEN part - - Traverse_Declarations_Or_Statements - (Then_Statements (N), Process, Inside_Stubs); - - -- Loop through ELSIF parts if present - - if Present (Elsif_Parts (N)) then - declare - Elif : Node_Id := First (Elsif_Parts (N)); - - begin - while Present (Elif) loop - Traverse_Declarations_Or_Statements - (Then_Statements (Elif), Process, Inside_Stubs); - Next (Elif); - end loop; - end; - end if; - - -- Finally traverse the ELSE statements if present - - Traverse_Declarations_Or_Statements - (Else_Statements (N), Process, Inside_Stubs); - - -- Case statement - - when N_Case_Statement => - - -- Process case branches - - declare - Alt : Node_Id; - begin - Alt := First (Alternatives (N)); - while Present (Alt) loop - Traverse_Declarations_Or_Statements - (Statements (Alt), Process, Inside_Stubs); - Next (Alt); - end loop; - end; - - -- Extended return statement - - when N_Extended_Return_Statement => - Traverse_Handled_Statement_Sequence - (Handled_Statement_Sequence (N), Process, Inside_Stubs); - - -- Loop - - when N_Loop_Statement => - Traverse_Declarations_Or_Statements - (Statements (N), Process, Inside_Stubs); - - when others => - null; - end case; - - Next (N); - end loop; - end Traverse_Declarations_Or_Statements; - - ----------------------------------------- - -- Traverse_Handled_Statement_Sequence -- - ----------------------------------------- - - procedure Traverse_Handled_Statement_Sequence - (N : Node_Id; - Process : Node_Processing; - Inside_Stubs : Boolean) - is - Handler : Node_Id; - - begin - if Present (N) then - Traverse_Declarations_Or_Statements - (Statements (N), Process, Inside_Stubs); - - if Present (Exception_Handlers (N)) then - Handler := First (Exception_Handlers (N)); - while Present (Handler) loop - Traverse_Declarations_Or_Statements - (Statements (Handler), Process, Inside_Stubs); - Next (Handler); - end loop; - end if; - end if; - end Traverse_Handled_Statement_Sequence; - - --------------------------- - -- Traverse_Package_Body -- - --------------------------- - - procedure Traverse_Package_Body - (N : Node_Id; - Process : Node_Processing; - Inside_Stubs : Boolean) is - begin - Traverse_Declarations_Or_Statements - (Declarations (N), Process, Inside_Stubs); - Traverse_Handled_Statement_Sequence - (Handled_Statement_Sequence (N), Process, Inside_Stubs); - end Traverse_Package_Body; - - ---------------------------------- - -- Traverse_Package_Declaration -- - ---------------------------------- - - procedure Traverse_Package_Declaration - (N : Node_Id; - Process : Node_Processing; - Inside_Stubs : Boolean) - is - Spec : constant Node_Id := Specification (N); - begin - Traverse_Declarations_Or_Statements - (Visible_Declarations (Spec), Process, Inside_Stubs); - Traverse_Declarations_Or_Statements - (Private_Declarations (Spec), Process, Inside_Stubs); - end Traverse_Package_Declaration; - - ------------------------------ - -- Traverse_Subprogram_Body -- - ------------------------------ - - procedure Traverse_Subprogram_Body - (N : Node_Id; - Process : Node_Processing; - Inside_Stubs : Boolean) is - begin - Traverse_Declarations_Or_Statements - (Declarations (N), Process, Inside_Stubs); - Traverse_Handled_Statement_Sequence - (Handled_Statement_Sequence (N), Process, Inside_Stubs); - end Traverse_Subprogram_Body; - -end Alfa; |