This reformatting is meant to clarify the code generating Alfa cross-references so that it can be updated to take into account instantiations.
Tested on x86_64-pc-linux-gnu, committed on trunk 2012-03-30 Yannick Moy <m...@adacore.com> * lib-xref-alfa.adb, lib-xref.adb: Code clean ups.
Index: lib-xref-alfa.adb =================================================================== --- lib-xref-alfa.adb (revision 185997) +++ lib-xref-alfa.adb (working copy) @@ -40,101 +40,17 @@ -- 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_Constant => True, + E_Function => True, + E_In_Out_Parameter => True, + E_In_Parameter => True, + E_Loop_Parameter => True, + E_Operator => True, + E_Out_Parameter => True, + E_Procedure => True, + E_Variable => True, + others => 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, @@ -149,6 +65,9 @@ -- Local Variables -- --------------------- + Heap : Entity_Id := Empty; + -- A special entity which denotes the heap object + package Drefs is new Table.Table ( Table_Component_Type => Xref_Entry, Table_Index_Type => Xref_Entry_Number, @@ -210,8 +129,8 @@ ------------------- procedure Add_Alfa_File (U : Unit_Number_Type; D : Nat) is + File : constant Source_File_Index := Source_Index (U); From : Scope_Index; - S : constant Source_File_Index := Source_Index (U); File_Name : String_Ptr; Unit_File_Name : String_Ptr; @@ -220,7 +139,7 @@ -- Source file could be inexistant as a result of an error, if option -- gnatQ is used. - if S = No_Source_File then + if File = No_Source_File then return; end if; @@ -230,67 +149,64 @@ -- filling Sdep_Table in Write_ALI. if Present (Cunit (U)) then - Traverse_Compilation_Unit (Cunit (U), - Detect_And_Add_Alfa_Scope'Access, - Inside_Stubs => False); + Traverse_Compilation_Unit + (CU => Cunit (U), + Process => Detect_And_Add_Alfa_Scope'Access, + Inside_Stubs => False); end if; -- Update scope numbers declare - Count : Nat; + Scope_Id : Int; begin - Count := 1; - for S in From .. Alfa_Scope_Table.Last loop + Scope_Id := 1; + for Index in From .. Alfa_Scope_Table.Last loop declare - E : Entity_Id renames Alfa_Scope_Table.Table (S).Scope_Entity; + S : Alfa_Scope_Record renames Alfa_Scope_Table.Table (Index); 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; + S.Scope_Num := Scope_Id; + S.File_Num := D; + Scope_Id := Scope_Id + 1; end; end loop; end; + -- Remove those scopes previously marked for removal + declare - Snew : Scope_Index; + Scope_Id : Scope_Index; begin - Snew := From; - for S in From .. Alfa_Scope_Table.Last loop - -- Remove those scopes previously marked for removal + Scope_Id := From; + for Index in From .. Alfa_Scope_Table.Last loop + declare + S : Alfa_Scope_Record renames Alfa_Scope_Table.Table (Index); - 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; + begin + if S.Scope_Num /= 0 then + Alfa_Scope_Table.Table (Scope_Id) := S; + Scope_Id := Scope_Id + 1; + end if; + end; end loop; - Alfa_Scope_Table.Set_Last (Snew - 1); + Alfa_Scope_Table.Set_Last (Scope_Id - 1); end; -- Make entry for new file in file table - Get_Name_String (Reference_Name (S)); + Get_Name_String (Reference_Name (File)); File_Name := new String'(Name_Buffer (1 .. Name_Len)); -- For subunits, also retrieve the file name of the unit. Only do so if -- unit U has an associated compilation unit. if Present (Cunit (U)) - and then Present (Cunit (Unit (S))) - and then Nkind (Unit (Cunit (Unit (S)))) = N_Subunit + and then Present (Cunit (Unit (File))) + and then Nkind (Unit (Cunit (Unit (File)))) = N_Subunit then Get_Name_String (Reference_Name (Main_Source_File)); Unit_File_Name := new String'(Name_Buffer (1 .. Name_Len)); @@ -384,11 +300,45 @@ -------------------- procedure Add_Alfa_Xrefs is - Cur_Scope_Idx : Scope_Index; - From_Xref_Idx : Xref_Index; - Cur_Entity : Entity_Id; - Cur_Entity_Name : String_Ptr; + function Entity_Of_Scope (S : Scope_Index) return Entity_Id; + -- Return the entity which maps to the input scope index + function Get_Entity_Type (E : Entity_Id) return Character; + -- Return a character representing the type of entity + + 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_Future_Scope_Entity + (E : Entity_Id; + S : Scope_Index) return Boolean; + -- Check whether entity E is in Alfa_Scope_Table at index S or higher + + 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. + + function Lt (Op1 : Natural; Op2 : Natural) return Boolean; + -- Comparison function for Sort call + + procedure Move (From : Natural; To : Natural); + -- Move procedure for Sort call + + procedure Update_Scope_Range + (S : Scope_Index; + From : Xref_Index; + To : Xref_Index); + -- Update the scope which maps to S with the new range From .. To + + package Sorting is new GNAT.Heap_Sort_G (Move, Lt); + package Scopes is No_Scope : constant Nat := 0; function Get_Scope_Num (N : Entity_Id) return Nat; @@ -447,14 +397,145 @@ -- 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 + --------------------- + -- Entity_Of_Scope -- + --------------------- - procedure Move (From : Natural; To : Natural); - -- Move procedure for Sort call + function Entity_Of_Scope (S : Scope_Index) return Entity_Id is + begin + return Alfa_Scope_Table.Table (S).Scope_Entity; + end Entity_Of_Scope; - package Sorting is new GNAT.Heap_Sort_G (Move, Lt); + --------------------- + -- 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_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_Future_Scope_Entity -- + ---------------------------- + + function Is_Future_Scope_Entity + (E : Entity_Id; + S : Scope_Index) return Boolean + is + function Is_Past_Scope_Entity return Boolean; + -- Check whether entity E is in Alfa_Scope_Table at index strictly + -- lower than S. + + -------------------------- + -- Is_Past_Scope_Entity -- + -------------------------- + + function Is_Past_Scope_Entity return Boolean is + begin + for Index in Alfa_Scope_Table.First .. S - 1 loop + if Alfa_Scope_Table.Table (Index).Scope_Entity = E then + declare + Dummy : constant Alfa_Scope_Record := + Alfa_Scope_Table.Table (Index); + pragma Unreferenced (Dummy); + begin + return True; + end; + end if; + end loop; + + return False; + end Is_Past_Scope_Entity; + + -- Start of processing for Is_Future_Scope_Entity + + begin + for Index in S .. Alfa_Scope_Table.Last loop + if Alfa_Scope_Table.Table (Index).Scope_Entity = E 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); + + return False; + end Is_Future_Scope_Entity; + + ------------------------ + -- 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; + -------- -- Lt -- -------- @@ -492,13 +573,13 @@ -- 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 + 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 + elsif T1.Key.Lun /= T2.Key.Lun + and then T2.Ent_Scope_File = T2.Key.Lun then return False; @@ -510,6 +591,7 @@ 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 @@ -554,45 +636,53 @@ Rnums (Nat (To)) := Rnums (Nat (From)); end Move; - Heap : Entity_Id; + ------------------------ + -- Update_Scope_Range -- + ------------------------ + procedure Update_Scope_Range + (S : Scope_Index; + From : Xref_Index; + To : Xref_Index) + is + begin + Alfa_Scope_Table.Table (S).From_Xref := From; + Alfa_Scope_Table.Table (S).To_Xref := To; + end Update_Scope_Range; + + -- Local variables + + Col : Nat; + From_Index : Xref_Index; + Line : Nat; + Loc : Source_Ptr; + Prev_Typ : Character; + Ref_Count : Nat; + Ref_Id : Entity_Id; + Ref_Name : String_Ptr; + Scope_Id : Scope_Index; + -- 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); + for Index in Alfa_Scope_Table.First .. Alfa_Scope_Table.Last loop + declare + S : Alfa_Scope_Record renames Alfa_Scope_Table.Table (Index); + + begin + Set_Scope_Num (S.Scope_Entity, S.Scope_Num); + end; end loop; -- Set up the pointer vector for the sort - for J in 1 .. Nrefs loop - Rnums (J) := J; + for Index in 1 .. Nrefs loop + Rnums (Index) := Index; end loop; - -- Add dereferences to the set of regular references, by creating a - -- special "Heap" variable for these special references. + for Index in Drefs.First .. Drefs.Last loop + Xrefs.Append (Drefs.Table (Index)); - 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; @@ -601,323 +691,158 @@ -- 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; + Ref_Count := Nrefs; + Nrefs := 0; - function Is_Alfa_Reference - (E : Entity_Id; - Typ : Character) return Boolean; - -- Return whether entity reference E meets Alfa requirements. Typ - -- is the reference type. + for Index in 1 .. Ref_Count loop + declare + Ref : Xref_Key renames Xrefs.Table (Rnums (Index)).Key; - 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 Alfa_Entities (Ekind (Ref.Ent)) + and then Alfa_References (Ref.Typ) + and then Is_Alfa_Scope (Ref.Ent_Scope) + and then Is_Alfa_Scope (Ref.Ref_Scope) + and then not Is_Global_Constant (Ref.Ent) + and then Is_Alfa_Reference (Ref.Ent, Ref.Typ) - if Ekind (E) in Overloadable_Kind then - return Typ = 's'; + -- Discard references from unknown scopes, such as generic + -- scopes. - -- 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 + and then Get_Scope_Num (Ref.Ent_Scope) /= No_Scope + and then Get_Scope_Num (Ref.Ref_Scope) /= No_Scope 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'; + Nrefs := Nrefs + 1; + Rnums (Nrefs) := Rnums (Index); end if; - end Is_Alfa_Reference; + end; + end loop; - ------------------- - -- Is_Alfa_Scope -- - ------------------- + -- Sort the references - 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; + Sorting.Sort (Integer (Nrefs)); - ------------------------ - -- Is_Global_Constant -- - ------------------------ + -- Eliminate duplicate entries - 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; + -- We need this test for Ref_Count 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. - -- Start of processing for Eliminate_Before_Sort + if Nrefs >= 2 then + Ref_Count := Nrefs; + Nrefs := 1; - 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) + for Index in 2 .. Ref_Count loop + if Xrefs.Table (Rnums (Index)) /= + Xrefs.Table (Rnums (Nrefs)) then - Nrefs := Nrefs + 1; - Rnums (Nrefs) := Rnums (J); + Nrefs := Nrefs + 1; + Rnums (Nrefs) := Rnums (Index); end if; end loop; - end Eliminate_Before_Sort; + end if; - -- Sort the references + -- 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. - Sorting.Sort (Integer (Nrefs)); + Ref_Count := Nrefs; + Nrefs := 0; + Loc := No_Location; + Prev_Typ := 'm'; - Eliminate_After_Sort : declare - NR : Nat; + for Index in 1 .. Ref_Count loop + declare + Ref : Xref_Key renames Xrefs.Table (Rnums (Index)).Key; - 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') + begin + if Ref.Loc /= Loc + or else (Prev_Typ = 'm' + and then Ref.Typ = 'r') then - Crloc := Xrefs.Table (Rnums (J)).Key.Loc; - Prevt := Xrefs.Table (Rnums (J)).Key.Typ; + Loc := Ref.Loc; + Prev_Typ := Ref.Typ; Nrefs := Nrefs + 1; - Rnums (Nrefs) := Rnums (J); + Rnums (Nrefs) := Rnums (Index); end if; - end loop; - end Eliminate_After_Sort; + end; + end loop; - -- Initialize loop + -- The two steps have eliminated all references, nothing to do - Cur_Scope_Idx := 1; - From_Xref_Idx := 1; - Cur_Entity := Empty; - if Alfa_Scope_Table.Last = 0 then return; end if; + Ref_Id := Empty; + Scope_Id := 1; + From_Index := 1; + -- Loop to output references for Refno in 1 .. Nrefs loop - Add_One_Xref : declare + declare + Ref_Entry : Xref_Entry renames Xrefs.Table (Rnums (Refno)); + Ref : Xref_Key renames Ref_Entry.Key; - ----------------------- - -- 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)); + pragma Assert + (Is_Future_Scope_Entity (Ref.Ent_Scope, Scope_Id)); -- 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; + if Ref.Ent_Scope /= Entity_Of_Scope (Scope_Id) then + Update_Scope_Range + (S => Scope_Id, + From => From_Index, + To => Alfa_Xref_Table.Last); + + From_Index := 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); + while Ref.Ent_Scope /= Entity_Of_Scope (Scope_Id) loop + Scope_Id := Scope_Id + 1; + pragma Assert (Scope_Id <= Alfa_Scope_Table.Last); end loop; - if XE.Key.Ent /= Cur_Entity then - Cur_Entity_Name := - new String'(Unique_Name (XE.Key.Ent)); + if Ref.Ent /= Ref_Id then + Ref_Name := new String'(Unique_Name (Ref.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)))); - + if Ref.Ent = Heap then + Line := 0; + Col := 0; 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)))); + Line := Int (Get_Logical_Line_Number (Ref_Entry.Def)); + Col := Int (Get_Column_Number (Ref_Entry.Def)); end if; - end Add_One_Xref; + + Alfa_Xref_Table.Append ( + (Entity_Name => Ref_Name, + Entity_Line => Line, + Etype => Get_Entity_Type (Ref.Ent), + Entity_Col => Col, + File_Num => Dependency_Num (Ref.Lun), + Scope_Num => Get_Scope_Num (Ref.Ref_Scope), + Line => Int (Get_Logical_Line_Number (Ref.Loc)), + Rtype => Ref.Typ, + Col => Int (Get_Column_Number (Ref.Loc)))); + end; 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; + Update_Scope_Range + (S => Scope_Id, + From => From_Index, + To => Alfa_Xref_Table.Last); end Add_Alfa_Xrefs; ------------------ @@ -1028,9 +953,7 @@ Result := N; end if; - loop - exit when No (Result); - + while Present (Result) loop case Nkind (Result) is when N_Package_Specification => Result := Defining_Unit_Name (Result); @@ -1105,36 +1028,69 @@ (N : Node_Id; Typ : Character := 'r') is - Indx : Nat; + procedure Create_Heap; + -- Create and decorate the special entity which denotes the heap + + ----------------- + -- Create_Heap -- + ----------------- + + procedure Create_Heap is + begin + Name_Len := Name_Of_Heap_Variable'Length; + Name_Buffer (1 .. Name_Len) := Name_Of_Heap_Variable; + + Heap := Make_Defining_Identifier (Standard_Location, Name_Enter); + + Set_Ekind (Heap, E_Variable); + Set_Is_Internal (Heap, True); + Set_Has_Fully_Qualified_Name (Heap); + end Create_Heap; + + -- Local variables + + Loc : constant Source_Ptr := Sloc (N); + Index : Nat; Ref : Source_Ptr; Ref_Scope : Entity_Id; + -- Start of processing for Generate_Dereference + begin - Ref := Original_Location (Sloc (N)); + Ref := Original_Location (Loc); if Ref > No_Location then Drefs.Increment_Last; - Indx := Drefs.Last; + Index := Drefs.Last; - Ref_Scope := Enclosing_Subprogram_Or_Package (N); + declare + Deref_Entry : Xref_Entry renames Drefs.Table (Index); + Deref : Xref_Key renames Deref_Entry.Key; - -- Entity is filled later on with the special "Heap" variable + begin + if No (Heap) then + Create_Heap; + end if; - Drefs.Table (Indx).Key.Ent := Empty; + Ref_Scope := Enclosing_Subprogram_Or_Package (N); - Drefs.Table (Indx).Def := No_Location; - Drefs.Table (Indx).Key.Loc := Ref; - Drefs.Table (Indx).Key.Typ := Typ; + Deref.Ent := Heap; + Deref.Loc := Ref; + Deref.Typ := Typ; - -- It is as if the special "Heap" was defined in every scope where it - -- is referenced. + -- 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); + Deref.Eun := Get_Source_Unit (Ref); + Deref.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); + Deref.Ref_Scope := Ref_Scope; + Deref.Ent_Scope := Ref_Scope; + + Deref_Entry.Def := No_Location; + + Deref_Entry.Ent_Scope_File := Get_Source_Unit (Ref_Scope); + end; end if; end Generate_Dereference; Index: lib-xref.adb =================================================================== --- lib-xref.adb (revision 185995) +++ lib-xref.adb (working copy) @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1998-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 1998-2012, 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- -- @@ -161,6 +161,9 @@ -- 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 @@ -170,9 +173,6 @@ 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 -- --------------- @@ -373,24 +373,18 @@ Set_Ref : Boolean := True; Force : Boolean := False) is - Nod : Node_Id; - Ref : Source_Ptr; - Def : Source_Ptr; - Ent : Entity_Id; - - Actual_Typ : Character := Typ; - - Ref_Scope : Entity_Id; + Actual_Typ : Character := Typ; + Call : Node_Id; + Def : Source_Ptr; + Ent : Entity_Id; Ent_Scope : Entity_Id; Ent_Scope_File : Unit_Number_Type; + Formal : Entity_Id; + Kind : Entity_Kind; + Nod : Node_Id; + Ref : Source_Ptr; + Ref_Scope : 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 - 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. @@ -884,11 +878,13 @@ 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 then - (Instantiation_Location (Sloc (N)) = No_Location or else Typ = 'i') + (Instantiation_Location (Sloc (N)) = No_Location + or else Typ = 'i') -- Ignore dummy references @@ -1003,14 +999,14 @@ Def := Original_Location (Sloc (Ent)); if Actual_Typ = 'p' - and then Is_Subprogram (N) - and then Present (Overridden_Operation (N)) + and then Is_Subprogram (Nod) + and then Present (Overridden_Operation (Nod)) then Actual_Typ := 'P'; end if; if Alfa_Mode then - Ref_Scope := Alfa.Enclosing_Subprogram_Or_Package (N); + Ref_Scope := Alfa.Enclosing_Subprogram_Or_Package (Nod); Ent_Scope := Alfa.Enclosing_Subprogram_Or_Package (Ent); -- Since we are reaching through renamings in Alfa mode, we may @@ -2434,6 +2430,8 @@ end Output_Refs; end Output_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.