diff options
Diffstat (limited to 'src/xrefs.adb')
| -rw-r--r-- | src/xrefs.adb | 279 |
1 files changed, 279 insertions, 0 deletions
diff --git a/src/xrefs.adb b/src/xrefs.adb new file mode 100644 index 0000000..1569669 --- /dev/null +++ b/src/xrefs.adb @@ -0,0 +1,279 @@ +-- Cross references. +-- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL is distributed in the hope that it will be useful, but WITHOUT 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 +-- along with GHDL; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +with GNAT.Table; +with GNAT.Heap_Sort_A; +with Flags; +with Std_Package; +with Errorout; use Errorout; +with Nodes; + +package body Xrefs is + type Xref_Type is record + -- Where the cross-reference (or the name) appears. + Loc : Location_Type; + + -- What the name refer to. + Ref : Iir; + + -- Kind of reference (See package specification). + Kind : Xref_Kind; + end record; + + package Xref_Table is new GNAT.Table + (Table_Index_Type => Natural, + Table_Component_Type => Xref_Type, + Table_Low_Bound => 0, + Table_Initial => 128, + Table_Increment => 100); + + function Get_Xref_Location (N : Xref) return Location_Type is + begin + return Xref_Table.Table (N).Loc; + end Get_Xref_Location; + + function Get_Xref_Kind (N : Xref) return Xref_Kind is + begin + return Xref_Table.Table (N).Kind; + end Get_Xref_Kind; + + function Get_Xref_Node (N : Xref) return Iir is + begin + return Xref_Table.Table (N).Ref; + end Get_Xref_Node; + + function Get_Last_Xref return Xref is + begin + return Xref_Table.Last; + end Get_Last_Xref; + + procedure Init is + begin + Xref_Table.Set_Last (Bad_Xref); + end Init; + + procedure Add_Xref (Loc : Location_Type; Ref : Iir; Kind : Xref_Kind) is + begin + -- Check there is no xref for the same location to the same reference. + -- (Note that a designatore may reference several declarations, this + -- is possible in attribute specification for an overloadable name). + -- This is a simple heuristic as this catch only two referenced in the + -- row but efficient and should be enough to catch errors. + pragma Assert + (Xref_Table.Last < Xref_Table.First + or else Xref_Table.Table (Xref_Table.Last).Loc /= Loc + or else Xref_Table.Table (Xref_Table.Last).Ref /= Ref); + + Xref_Table.Append (Xref_Type'(Loc => Loc, + Ref => Ref, + Kind => Kind)); + end Add_Xref; + + procedure Xref_Decl (Decl : Iir) is + begin + if Flags.Flag_Xref then + Add_Xref (Get_Location (Decl), Decl, Xref_Decl); + end if; + end Xref_Decl; + + procedure Xref_Ref (Name : Iir; Decl : Iir) is + begin + if Flags.Flag_Xref then + Add_Xref (Get_Location (Name), Decl, Xref_Ref); + end if; + end Xref_Ref; + + procedure Xref_Body (Bod : Iir; Spec : Iir) is + begin + if Flags.Flag_Xref then + Add_Xref (Get_Location (Bod), Spec, Xref_Body); + end if; + end Xref_Body; + + procedure Xref_End (Loc : Location_Type; Decl : Iir) is + begin + if Flags.Flag_Xref then + Add_Xref (Loc, Decl, Xref_End); + end if; + end Xref_End; + + procedure Xref_Name_1 (Name : Iir) is + begin + case Get_Kind (Name) is + when Iir_Kind_Simple_Name + | Iir_Kind_Selected_Name + | Iir_Kind_Operator_Symbol + | Iir_Kind_Character_Literal => + declare + Res : constant Iir := Get_Named_Entity (Name); + begin + if Res = Std_Package.Error_Mark then + return; + end if; + Add_Xref (Get_Location (Name), Res, Xref_Ref); + end; + when Iir_Kind_Selected_Element => + Add_Xref (Get_Location (Name), + Get_Selected_Element (Name), Xref_Ref); + when Iir_Kind_Dereference + | Iir_Kind_Implicit_Dereference + | Iir_Kind_Slice_Name + | Iir_Kind_Indexed_Name + | Iir_Kind_Function_Call => + null; + when Iir_Kinds_Attribute => + null; + when Iir_Kind_Attribute_Name => + -- FIXME: user defined attributes. + null; + when Iir_Kind_Type_Conversion => + return; + when others => + Error_Kind ("xref_name_1", Name); + end case; + case Get_Kind (Name) is + when Iir_Kind_Simple_Name + | Iir_Kind_Operator_Symbol + | Iir_Kind_Character_Literal => + null; + when Iir_Kind_Selected_Name + | Iir_Kind_Selected_Element + | Iir_Kind_Attribute_Name + | Iir_Kind_Slice_Name + | Iir_Kind_Indexed_Name + | Iir_Kind_Dereference + | Iir_Kind_Implicit_Dereference + | Iir_Kinds_Attribute + | Iir_Kind_Function_Call => + Xref_Name_1 (Get_Prefix (Name)); + when others => + Error_Kind ("xref_name_1", Name); + end case; + end Xref_Name_1; + + procedure Xref_Name (Name : Iir) is + begin + if Flags.Flag_Xref and Name /= Null_Iir then + Xref_Name_1 (Name); + end if; + end Xref_Name; + + procedure Move (From : Natural; To : Natural) + is + Tmp : Xref_Type; + begin + Tmp := Xref_Table.Table (To); + Xref_Table.Table (To) := Xref_Table.Table (From); + Xref_Table.Table (From) := Tmp; + end Move; + + function Loc_Lt (Op1, Op2 : Natural) return Boolean + is + L1 : constant Location_Type := Xref_Table.Table (Op1).Loc; + L2 : constant Location_Type := Xref_Table.Table (Op2).Loc; + begin + return L1 < L2; + end Loc_Lt; + + procedure Sort_By_Location is + begin + GNAT.Heap_Sort_A.Sort (Xref_Table.Last, Move'Access, Loc_Lt'Access); + end Sort_By_Location; + + -- Sorting function by ref field. + -- If ref fields are the same, then compare by location. + function Node_Lt (Op1, Op2 : Natural) return Boolean + is + L1, L2 : Location_Type; + N1, N2 : Iir; + K1, K2 : Xref_Kind; + begin + L1 := Get_Location (Get_Xref_Node (Op1)); + L2 := Get_Location (Get_Xref_Node (Op2)); + + if L1 /= L2 then + return L1 < L2; + end if; + + -- L1 = L2. + -- Note: nodes of std_standard have the same location. FIXME ? + N1 := Get_Xref_Node (Op1); + N2 := Get_Xref_Node (Op2); + if Iirs."/=" (N1, N2) then + return Nodes."<" (N1, N2); + end if; + + -- Try to get declaration first. + K1 := Get_Xref_Kind (Op1); + K2 := Get_Xref_Kind (Op2); + if K1 /= K2 then + return K1 < K2; + end if; + L1 := Get_Xref_Location (Op1); + L2 := Get_Xref_Location (Op2); + return L1 < L2; + end Node_Lt; + + procedure Sort_By_Node_Location is + begin + GNAT.Heap_Sort_A.Sort (Xref_Table.Last, Move'Access, Node_Lt'Access); + end Sort_By_Node_Location; + + function Find (Loc : Location_Type) return Xref + is + Low : Xref; + High : Xref; + Mid : Xref; + Mid_Loc : Location_Type; + begin + Low := First_Xref; + High := Xref_Table.Last; + loop + Mid := (Low + High + 1) / 2; + Mid_Loc := Xref_Table.Table (Mid).Loc; + if Loc = Mid_Loc then + return Mid; + end if; + if Mid = Low then + return Bad_Xref; + end if; + if Loc > Mid_Loc then + Low := Mid + 1; + else + High := Mid - 1; + end if; + end loop; + end Find; + + procedure Fix_End_Xrefs + is + N : Iir; + begin + for I in First_Xref .. Get_Last_Xref loop + if Get_Xref_Kind (I) = Xref_End then + N := Get_Xref_Node (I); + case Get_Kind (N) is + when Iir_Kind_Function_Body + | Iir_Kind_Procedure_Body => + Xref_Table.Table (I).Ref := Get_Subprogram_Specification (N); + when others => + null; + end case; + end if; + end loop; + end Fix_End_Xrefs; +end Xrefs; |