diff options
Diffstat (limited to 'gcc-4.2.1/gcc/ada/xr_tabls.adb')
| -rw-r--r-- | gcc-4.2.1/gcc/ada/xr_tabls.adb | 1627 |
1 files changed, 0 insertions, 1627 deletions
diff --git a/gcc-4.2.1/gcc/ada/xr_tabls.adb b/gcc-4.2.1/gcc/ada/xr_tabls.adb deleted file mode 100644 index 0b11a5697..000000000 --- a/gcc-4.2.1/gcc/ada/xr_tabls.adb +++ /dev/null @@ -1,1627 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- X R _ T A B L S -- --- -- --- B o d y -- --- -- --- Copyright (C) 1998-2006, 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 2, 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 COPYING. If not, write -- --- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- --- Boston, MA 02110-1301, USA. -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Types; use Types; -with Osint; -with Hostparm; - -with Ada.Unchecked_Conversion; -with Ada.Unchecked_Deallocation; -with Ada.Strings.Fixed; -with Ada.Strings; -with Ada.Text_IO; -with Ada.Characters.Handling; use Ada.Characters.Handling; -with Ada.Strings.Unbounded; use Ada.Strings.Unbounded; - -with GNAT.OS_Lib; use GNAT.OS_Lib; -with GNAT.Directory_Operations; use GNAT.Directory_Operations; -with GNAT.HTable; use GNAT.HTable; -with GNAT.Heap_Sort_G; - -package body Xr_Tabls is - - type HTable_Headers is range 1 .. 10000; - - procedure Set_Next (E : File_Reference; Next : File_Reference); - function Next (E : File_Reference) return File_Reference; - function Get_Key (E : File_Reference) return Cst_String_Access; - function Hash (F : Cst_String_Access) return HTable_Headers; - function Equal (F1, F2 : Cst_String_Access) return Boolean; - -- The five subprograms above are used to instanciate the static - -- htable to store the files that should be processed. - - package File_HTable is new GNAT.HTable.Static_HTable - (Header_Num => HTable_Headers, - Element => File_Record, - Elmt_Ptr => File_Reference, - Null_Ptr => null, - Set_Next => Set_Next, - Next => Next, - Key => Cst_String_Access, - Get_Key => Get_Key, - Hash => Hash, - Equal => Equal); - -- A hash table to store all the files referenced in the - -- application. The keys in this htable are the name of the files - -- themselves, therefore it is assumed that the source path - -- doesn't contain twice the same source or ALI file name - - type Unvisited_Files_Record; - type Unvisited_Files_Access is access Unvisited_Files_Record; - type Unvisited_Files_Record is record - File : File_Reference; - Next : Unvisited_Files_Access; - end record; - -- A special list, in addition to File_HTable, that only stores - -- the files that haven't been visited so far. Note that the File - -- list points to some data in File_HTable, and thus should never be freed. - - function Next (E : Declaration_Reference) return Declaration_Reference; - procedure Set_Next (E, Next : Declaration_Reference); - function Get_Key (E : Declaration_Reference) return Cst_String_Access; - -- The subprograms above are used to instanciate the static - -- htable to store the entities that have been found in the application - - package Entities_HTable is new GNAT.HTable.Static_HTable - (Header_Num => HTable_Headers, - Element => Declaration_Record, - Elmt_Ptr => Declaration_Reference, - Null_Ptr => null, - Set_Next => Set_Next, - Next => Next, - Key => Cst_String_Access, - Get_Key => Get_Key, - Hash => Hash, - Equal => Equal); - -- A hash table to store all the entities defined in the - -- application. For each entity, we store a list of its reference - -- locations as well. - -- The keys in this htable should be created with Key_From_Ref, - -- and are the file, line and column of the declaration, which are - -- unique for every entity. - - Entities_Count : Natural := 0; - -- Number of entities in Entities_HTable. This is used in the end - -- when sorting the table. - - Longest_File_Name_In_Table : Natural := 0; - Unvisited_Files : Unvisited_Files_Access := null; - Directories : Project_File_Ptr; - Default_Match : Boolean := False; - -- The above need commenting ??? - - function Parse_Gnatls_Src return String; - -- Return the standard source directories (taking into account the - -- ADA_INCLUDE_PATH environment variable, if Osint.Add_Default_Search_Dirs - -- was called first). - - function Parse_Gnatls_Obj return String; - -- Return the standard object directories (taking into account the - -- ADA_OBJECTS_PATH environment variable). - - function Key_From_Ref - (File_Ref : File_Reference; - Line : Natural; - Column : Natural) - return String; - -- Return a key for the symbol declared at File_Ref, Line, - -- Column. This key should be used for lookup in Entity_HTable - - function Is_Less_Than (Decl1, Decl2 : Declaration_Reference) return Boolean; - -- Compare two declarations (the comparison is case-insensitive) - - function Is_Less_Than (Ref1, Ref2 : Reference) return Boolean; - -- Compare two references - - procedure Store_References - (Decl : Declaration_Reference; - Get_Writes : Boolean := False; - Get_Reads : Boolean := False; - Get_Bodies : Boolean := False; - Get_Declaration : Boolean := False; - Arr : in out Reference_Array; - Index : in out Natural); - -- Store in Arr, starting at Index, all the references to Decl. The Get_* - -- parameters can be used to indicate which references should be stored. - -- Constraint_Error will be raised if Arr is not big enough. - - procedure Sort (Arr : in out Reference_Array); - -- Sort an array of references (Arr'First must be 1) - - -------------- - -- Set_Next -- - -------------- - - procedure Set_Next (E : File_Reference; Next : File_Reference) is - begin - E.Next := Next; - end Set_Next; - - procedure Set_Next - (E : Declaration_Reference; Next : Declaration_Reference) is - begin - E.Next := Next; - end Set_Next; - - ------------- - -- Get_Key -- - ------------- - - function Get_Key (E : File_Reference) return Cst_String_Access is - begin - return E.File; - end Get_Key; - - function Get_Key (E : Declaration_Reference) return Cst_String_Access is - begin - return E.Key; - end Get_Key; - - ---------- - -- Hash -- - ---------- - - function Hash (F : Cst_String_Access) return HTable_Headers is - function H is new GNAT.HTable.Hash (HTable_Headers); - - begin - return H (F.all); - end Hash; - - ----------- - -- Equal -- - ----------- - - function Equal (F1, F2 : Cst_String_Access) return Boolean is - begin - return F1.all = F2.all; - end Equal; - - ------------------ - -- Key_From_Ref -- - ------------------ - - function Key_From_Ref - (File_Ref : File_Reference; - Line : Natural; - Column : Natural) - return String - is - begin - return File_Ref.File.all & Natural'Image (Line) & Natural'Image (Column); - end Key_From_Ref; - - --------------------- - -- Add_Declaration -- - --------------------- - - function Add_Declaration - (File_Ref : File_Reference; - Symbol : String; - Line : Natural; - Column : Natural; - Decl_Type : Character; - Remove_Only : Boolean := False; - Symbol_Match : Boolean := True) - return Declaration_Reference - is - procedure Unchecked_Free is new Ada.Unchecked_Deallocation - (Declaration_Record, Declaration_Reference); - - Key : aliased constant String := Key_From_Ref (File_Ref, Line, Column); - - New_Decl : Declaration_Reference := - Entities_HTable.Get (Key'Unchecked_Access); - - Is_Parameter : Boolean := False; - - begin - -- Insert the Declaration in the table. There might already be a - -- declaration in the table if the entity is a parameter, so we - -- need to check that first. - - if New_Decl /= null and then New_Decl.Symbol_Length = 0 then - Is_Parameter := New_Decl.Is_Parameter; - Entities_HTable.Remove (Key'Unrestricted_Access); - Entities_Count := Entities_Count - 1; - Free (New_Decl.Key); - Unchecked_Free (New_Decl); - New_Decl := null; - end if; - - -- The declaration might also already be there for parent types. In - -- this case, we should keep the entry, since some other entries are - -- pointing to it. - - if New_Decl = null - and then not Remove_Only - then - New_Decl := - new Declaration_Record' - (Symbol_Length => Symbol'Length, - Symbol => Symbol, - Key => new String'(Key), - Decl => new Reference_Record' - (File => File_Ref, - Line => Line, - Column => Column, - Source_Line => null, - Next => null), - Is_Parameter => Is_Parameter, - Decl_Type => Decl_Type, - Body_Ref => null, - Ref_Ref => null, - Modif_Ref => null, - Match => Symbol_Match - and then - (Default_Match - or else Match (File_Ref, Line, Column)), - Par_Symbol => null, - Next => null); - - Entities_HTable.Set (New_Decl); - Entities_Count := Entities_Count + 1; - - if New_Decl.Match then - Longest_File_Name_In_Table := - Natural'Max (File_Ref.File'Length, Longest_File_Name_In_Table); - end if; - - elsif New_Decl /= null - and then not New_Decl.Match - then - New_Decl.Match := Default_Match - or else Match (File_Ref, Line, Column); - end if; - - return New_Decl; - end Add_Declaration; - - ---------------------- - -- Add_To_Xref_File -- - ---------------------- - - function Add_To_Xref_File - (File_Name : String; - Visited : Boolean := True; - Emit_Warning : Boolean := False; - Gnatchop_File : String := ""; - Gnatchop_Offset : Integer := 0) return File_Reference - is - Base : aliased constant String := Base_Name (File_Name); - Dir : constant String := Dir_Name (File_Name); - Dir_Acc : GNAT.OS_Lib.String_Access := null; - Ref : File_Reference; - - begin - -- Do we have a directory name as well? - - if File_Name /= Base then - Dir_Acc := new String'(Dir); - end if; - - Ref := File_HTable.Get (Base'Unchecked_Access); - if Ref = null then - Ref := new File_Record' - (File => new String'(Base), - Dir => Dir_Acc, - Lines => null, - Visited => Visited, - Emit_Warning => Emit_Warning, - Gnatchop_File => new String'(Gnatchop_File), - Gnatchop_Offset => Gnatchop_Offset, - Next => null); - File_HTable.Set (Ref); - - if not Visited then - - -- Keep a separate list for faster access - - Set_Unvisited (Ref); - end if; - end if; - return Ref; - end Add_To_Xref_File; - - -------------- - -- Add_Line -- - -------------- - - procedure Add_Line - (File : File_Reference; - Line : Natural; - Column : Natural) - is - begin - File.Lines := new Ref_In_File'(Line => Line, - Column => Column, - Next => File.Lines); - end Add_Line; - - ---------------- - -- Add_Parent -- - ---------------- - - procedure Add_Parent - (Declaration : in out Declaration_Reference; - Symbol : String; - Line : Natural; - Column : Natural; - File_Ref : File_Reference) - is - begin - Declaration.Par_Symbol := - Add_Declaration - (File_Ref, Symbol, Line, Column, - Decl_Type => ' ', - Symbol_Match => False); - end Add_Parent; - - ------------------- - -- Add_Reference -- - ------------------- - - procedure Add_Reference - (Declaration : Declaration_Reference; - File_Ref : File_Reference; - Line : Natural; - Column : Natural; - Ref_Type : Character; - Labels_As_Ref : Boolean) - is - New_Ref : Reference; - - begin - case Ref_Type is - when 'b' | 'c' | 'm' | 'r' | 'i' | ' ' | 'x' => - null; - - when 'l' | 'w' => - if not Labels_As_Ref then - return; - end if; - - when '=' | '<' | '>' | '^' => - - -- Create a dummy declaration in the table to report it as a - -- parameter. Note that the current declaration for the subprogram - -- comes before the declaration of the parameter. - - declare - Key : constant String := - Key_From_Ref (File_Ref, Line, Column); - New_Decl : Declaration_Reference; - - begin - New_Decl := new Declaration_Record' - (Symbol_Length => 0, - Symbol => "", - Key => new String'(Key), - Decl => null, - Is_Parameter => True, - Decl_Type => ' ', - Body_Ref => null, - Ref_Ref => null, - Modif_Ref => null, - Match => False, - Par_Symbol => null, - Next => null); - Entities_HTable.Set (New_Decl); - Entities_Count := Entities_Count + 1; - end; - - when 'e' | 'z' | 't' | 'p' | 'P' | 'k' | 'd' => - return; - - when others => - Ada.Text_IO.Put_Line ("Unknown reference type: " & Ref_Type); - return; - end case; - - New_Ref := new Reference_Record' - (File => File_Ref, - Line => Line, - Column => Column, - Source_Line => null, - Next => null); - - -- We can insert the reference in the list directly, since all - -- the references will appear only once in the ALI file - -- corresponding to the file where they are referenced. - -- This saves a lot of time compared to checking the list to check - -- if it exists. - - case Ref_Type is - when 'b' | 'c' => - New_Ref.Next := Declaration.Body_Ref; - Declaration.Body_Ref := New_Ref; - - when 'r' | 'i' | 'l' | ' ' | 'x' | 'w' => - New_Ref.Next := Declaration.Ref_Ref; - Declaration.Ref_Ref := New_Ref; - - when 'm' => - New_Ref.Next := Declaration.Modif_Ref; - Declaration.Modif_Ref := New_Ref; - - when others => - null; - end case; - - if not Declaration.Match then - Declaration.Match := Match (File_Ref, Line, Column); - end if; - - if Declaration.Match then - Longest_File_Name_In_Table := - Natural'Max (File_Ref.File'Length, Longest_File_Name_In_Table); - end if; - end Add_Reference; - - ------------------- - -- ALI_File_Name -- - ------------------- - - function ALI_File_Name (Ada_File_Name : String) return String is - - -- ??? Should ideally be based on the naming scheme defined in - -- project files. - - Index : constant Natural := - Ada.Strings.Fixed.Index - (Ada_File_Name, ".", Going => Ada.Strings.Backward); - - begin - if Index /= 0 then - return Ada_File_Name (Ada_File_Name'First .. Index) & "ali"; - else - return Ada_File_Name & ".ali"; - end if; - end ALI_File_Name; - - ------------------ - -- Is_Less_Than -- - ------------------ - - function Is_Less_Than (Ref1, Ref2 : Reference) return Boolean is - begin - if Ref1 = null then - return False; - elsif Ref2 = null then - return True; - end if; - - if Ref1.File.File.all < Ref2.File.File.all then - return True; - - elsif Ref1.File.File.all = Ref2.File.File.all then - return (Ref1.Line < Ref2.Line - or else (Ref1.Line = Ref2.Line - and then Ref1.Column < Ref2.Column)); - end if; - - return False; - end Is_Less_Than; - - ------------------ - -- Is_Less_Than -- - ------------------ - - function Is_Less_Than (Decl1, Decl2 : Declaration_Reference) return Boolean - is - -- We cannot store the data case-insensitive in the table, - -- since we wouldn't be able to find the right casing for the - -- display later on. - - S1 : constant String := To_Lower (Decl1.Symbol); - S2 : constant String := To_Lower (Decl2.Symbol); - - begin - if S1 < S2 then - return True; - elsif S1 > S2 then - return False; - end if; - - return Decl1.Key.all < Decl2.Key.all; - end Is_Less_Than; - - ------------------------- - -- Create_Project_File -- - ------------------------- - - procedure Create_Project_File (Name : String) is - Obj_Dir : Unbounded_String := Null_Unbounded_String; - Src_Dir : Unbounded_String := Null_Unbounded_String; - Build_Dir : GNAT.OS_Lib.String_Access := new String'(""); - - F : File_Descriptor; - Len : Positive; - File_Name : aliased String := Name & ASCII.NUL; - - begin - -- Read the size of the file - - F := Open_Read (File_Name'Address, Text); - - -- Project file not found - - if F /= Invalid_FD then - Len := Positive (File_Length (F)); - - declare - Buffer : String (1 .. Len); - Index : Positive := Buffer'First; - Last : Positive; - - begin - Len := Read (F, Buffer'Address, Len); - Close (F); - - -- First, look for Build_Dir, since all the source and object - -- path are relative to it. - - while Index <= Buffer'Last loop - - -- Find the end of line - - Last := Index; - while Last <= Buffer'Last - and then Buffer (Last) /= ASCII.LF - and then Buffer (Last) /= ASCII.CR - loop - Last := Last + 1; - end loop; - - if Index <= Buffer'Last - 9 - and then Buffer (Index .. Index + 9) = "build_dir=" - then - Index := Index + 10; - while Index <= Last - and then (Buffer (Index) = ' ' - or else Buffer (Index) = ASCII.HT) - loop - Index := Index + 1; - end loop; - - Free (Build_Dir); - Build_Dir := new String'(Buffer (Index .. Last - 1)); - end if; - - Index := Last + 1; - - -- In case we had a ASCII.CR/ASCII.LF end of line, skip the - -- remaining symbol - - if Index <= Buffer'Last - and then Buffer (Index) = ASCII.LF - then - Index := Index + 1; - end if; - end loop; - - -- Now parse the source and object paths - - Index := Buffer'First; - while Index <= Buffer'Last loop - - -- Find the end of line - - Last := Index; - while Last <= Buffer'Last - and then Buffer (Last) /= ASCII.LF - and then Buffer (Last) /= ASCII.CR - loop - Last := Last + 1; - end loop; - - if Index <= Buffer'Last - 7 - and then Buffer (Index .. Index + 7) = "src_dir=" - then - Append (Src_Dir, Normalize_Pathname - (Name => Ada.Strings.Fixed.Trim - (Buffer (Index + 8 .. Last - 1), Ada.Strings.Both), - Directory => Build_Dir.all) & Path_Separator); - - elsif Index <= Buffer'Last - 7 - and then Buffer (Index .. Index + 7) = "obj_dir=" - then - Append (Obj_Dir, Normalize_Pathname - (Name => Ada.Strings.Fixed.Trim - (Buffer (Index + 8 .. Last - 1), Ada.Strings.Both), - Directory => Build_Dir.all) & Path_Separator); - end if; - - -- In case we had a ASCII.CR/ASCII.LF end of line, skip the - -- remaining symbol - Index := Last + 1; - - if Index <= Buffer'Last - and then Buffer (Index) = ASCII.LF - then - Index := Index + 1; - end if; - end loop; - end; - end if; - - Osint.Add_Default_Search_Dirs; - - declare - Src : constant String := Parse_Gnatls_Src; - Obj : constant String := Parse_Gnatls_Obj; - - begin - Directories := new Project_File' - (Src_Dir_Length => Length (Src_Dir) + Src'Length, - Obj_Dir_Length => Length (Obj_Dir) + Obj'Length, - Src_Dir => To_String (Src_Dir) & Src, - Obj_Dir => To_String (Obj_Dir) & Obj, - Src_Dir_Index => 1, - Obj_Dir_Index => 1, - Last_Obj_Dir_Start => 0); - end; - - Free (Build_Dir); - end Create_Project_File; - - --------------------- - -- Current_Obj_Dir -- - --------------------- - - function Current_Obj_Dir return String is - begin - return Directories.Obj_Dir - (Directories.Last_Obj_Dir_Start .. Directories.Obj_Dir_Index - 2); - end Current_Obj_Dir; - - ---------------- - -- Get_Column -- - ---------------- - - function Get_Column (Decl : Declaration_Reference) return String is - begin - return Ada.Strings.Fixed.Trim (Natural'Image (Decl.Decl.Column), - Ada.Strings.Left); - end Get_Column; - - function Get_Column (Ref : Reference) return String is - begin - return Ada.Strings.Fixed.Trim (Natural'Image (Ref.Column), - Ada.Strings.Left); - end Get_Column; - - --------------------- - -- Get_Declaration -- - --------------------- - - function Get_Declaration - (File_Ref : File_Reference; - Line : Natural; - Column : Natural) - return Declaration_Reference - is - Key : aliased constant String := Key_From_Ref (File_Ref, Line, Column); - - begin - return Entities_HTable.Get (Key'Unchecked_Access); - end Get_Declaration; - - ---------------------- - -- Get_Emit_Warning -- - ---------------------- - - function Get_Emit_Warning (File : File_Reference) return Boolean is - begin - return File.Emit_Warning; - end Get_Emit_Warning; - - -------------- - -- Get_File -- - -------------- - - function Get_File - (Decl : Declaration_Reference; - With_Dir : Boolean := False) return String - is - begin - return Get_File (Decl.Decl.File, With_Dir); - end Get_File; - - function Get_File - (Ref : Reference; - With_Dir : Boolean := False) return String - is - begin - return Get_File (Ref.File, With_Dir); - end Get_File; - - function Get_File - (File : File_Reference; - With_Dir : Boolean := False; - Strip : Natural := 0) return String - is - Tmp : GNAT.OS_Lib.String_Access; - - function Internal_Strip (Full_Name : String) return String; - -- Internal function to process the Strip parameter - - -------------------- - -- Internal_Strip -- - -------------------- - - function Internal_Strip (Full_Name : String) return String is - Unit_End : Natural; - Extension_Start : Natural; - S : Natural; - - begin - if Strip = 0 then - return Full_Name; - end if; - - -- Isolate the file extension - - Extension_Start := Full_Name'Last; - while Extension_Start >= Full_Name'First - and then Full_Name (Extension_Start) /= '.' - loop - Extension_Start := Extension_Start - 1; - end loop; - - -- Strip the right number of subunit_names - - S := Strip; - Unit_End := Extension_Start - 1; - while Unit_End >= Full_Name'First - and then S > 0 - loop - if Full_Name (Unit_End) = '-' then - S := S - 1; - end if; - - Unit_End := Unit_End - 1; - end loop; - - if Unit_End < Full_Name'First then - return ""; - else - return Full_Name (Full_Name'First .. Unit_End) - & Full_Name (Extension_Start .. Full_Name'Last); - end if; - end Internal_Strip; - - -- Start of processing for Get_File; - - begin - -- If we do not want the full path name - - if not With_Dir then - return Internal_Strip (File.File.all); - end if; - - if File.Dir = null then - if Ada.Strings.Fixed.Tail (File.File.all, 3) = "ali" then - Tmp := Locate_Regular_File - (Internal_Strip (File.File.all), Directories.Obj_Dir); - else - Tmp := Locate_Regular_File - (File.File.all, Directories.Src_Dir); - end if; - - if Tmp = null then - File.Dir := new String'(""); - else - File.Dir := new String'(Dir_Name (Tmp.all)); - Free (Tmp); - end if; - end if; - - return Internal_Strip (File.Dir.all & File.File.all); - end Get_File; - - ------------------ - -- Get_File_Ref -- - ------------------ - - function Get_File_Ref (Ref : Reference) return File_Reference is - begin - return Ref.File; - end Get_File_Ref; - - ----------------------- - -- Get_Gnatchop_File -- - ----------------------- - - function Get_Gnatchop_File - (File : File_Reference; - With_Dir : Boolean := False) - return String - is - begin - if File.Gnatchop_File.all = "" then - return Get_File (File, With_Dir); - else - return File.Gnatchop_File.all; - end if; - end Get_Gnatchop_File; - - function Get_Gnatchop_File - (Ref : Reference; - With_Dir : Boolean := False) - return String - is - begin - return Get_Gnatchop_File (Ref.File, With_Dir); - end Get_Gnatchop_File; - - function Get_Gnatchop_File - (Decl : Declaration_Reference; - With_Dir : Boolean := False) - return String - is - begin - return Get_Gnatchop_File (Decl.Decl.File, With_Dir); - end Get_Gnatchop_File; - - -------------- - -- Get_Line -- - -------------- - - function Get_Line (Decl : Declaration_Reference) return String is - begin - return Ada.Strings.Fixed.Trim (Natural'Image (Decl.Decl.Line), - Ada.Strings.Left); - end Get_Line; - - function Get_Line (Ref : Reference) return String is - begin - return Ada.Strings.Fixed.Trim (Natural'Image (Ref.Line), - Ada.Strings.Left); - end Get_Line; - - ---------------- - -- Get_Parent -- - ---------------- - - function Get_Parent - (Decl : Declaration_Reference) - return Declaration_Reference - is - begin - return Decl.Par_Symbol; - end Get_Parent; - - --------------------- - -- Get_Source_Line -- - --------------------- - - function Get_Source_Line (Ref : Reference) return String is - begin - if Ref.Source_Line /= null then - return Ref.Source_Line.all; - else - return ""; - end if; - end Get_Source_Line; - - function Get_Source_Line (Decl : Declaration_Reference) return String is - begin - if Decl.Decl.Source_Line /= null then - return Decl.Decl.Source_Line.all; - else - return ""; - end if; - end Get_Source_Line; - - ---------------- - -- Get_Symbol -- - ---------------- - - function Get_Symbol (Decl : Declaration_Reference) return String is - begin - return Decl.Symbol; - end Get_Symbol; - - -------------- - -- Get_Type -- - -------------- - - function Get_Type (Decl : Declaration_Reference) return Character is - begin - return Decl.Decl_Type; - end Get_Type; - - ---------- - -- Sort -- - ---------- - - procedure Sort (Arr : in out Reference_Array) is - Tmp : Reference; - - function Lt (Op1, Op2 : Natural) return Boolean; - procedure Move (From, To : Natural); - -- See GNAT.Heap_Sort_G - - -------- - -- Lt -- - -------- - - function Lt (Op1, Op2 : Natural) return Boolean is - begin - if Op1 = 0 then - return Is_Less_Than (Tmp, Arr (Op2)); - elsif Op2 = 0 then - return Is_Less_Than (Arr (Op1), Tmp); - else - return Is_Less_Than (Arr (Op1), Arr (Op2)); - end if; - end Lt; - - ---------- - -- Move -- - ---------- - - procedure Move (From, To : Natural) is - begin - if To = 0 then - Tmp := Arr (From); - elsif From = 0 then - Arr (To) := Tmp; - else - Arr (To) := Arr (From); - end if; - end Move; - - package Ref_Sort is new GNAT.Heap_Sort_G (Move, Lt); - - -- Start of processing for Sort - - begin - Ref_Sort.Sort (Arr'Last); - end Sort; - - ----------------------- - -- Grep_Source_Files -- - ----------------------- - - procedure Grep_Source_Files is - Length : Natural := 0; - Decl : Declaration_Reference := Entities_HTable.Get_First; - Arr : Reference_Array_Access; - Index : Natural; - End_Index : Natural; - Current_File : File_Reference; - Current_Line : Cst_String_Access; - Buffer : GNAT.OS_Lib.String_Access; - Ref : Reference; - Line : Natural; - - begin - -- Create a temporary array, where all references will be - -- sorted by files. This way, we only have to read the source - -- files once. - - while Decl /= null loop - - -- Add 1 for the declaration itself - - Length := Length + References_Count (Decl, True, True, True) + 1; - Decl := Entities_HTable.Get_Next; - end loop; - - Arr := new Reference_Array (1 .. Length); - Index := Arr'First; - - Decl := Entities_HTable.Get_First; - while Decl /= null loop - Store_References (Decl, True, True, True, True, Arr.all, Index); - Decl := Entities_HTable.Get_Next; - end loop; - - Sort (Arr.all); - - -- Now traverse the whole array and find the appropriate source - -- lines. - - for R in Arr'Range loop - Ref := Arr (R); - - if Ref.File /= Current_File then - Free (Buffer); - begin - Read_File (Get_File (Ref.File, With_Dir => True), Buffer); - End_Index := Buffer'First - 1; - Line := 0; - exception - when Ada.Text_IO.Name_Error | Ada.Text_IO.End_Error => - Line := Natural'Last; - end; - Current_File := Ref.File; - end if; - - if Ref.Line > Line then - - -- Do not free Current_Line, it is referenced by the last - -- Ref we processed. - - loop - Index := End_Index + 1; - - loop - End_Index := End_Index + 1; - exit when End_Index > Buffer'Last - or else Buffer (End_Index) = ASCII.LF; - end loop; - - -- Skip spaces at beginning of line - - while Index < End_Index and then - (Buffer (Index) = ' ' or else Buffer (Index) = ASCII.HT) - loop - Index := Index + 1; - end loop; - - Line := Line + 1; - exit when Ref.Line = Line; - end loop; - - Current_Line := new String'(Buffer (Index .. End_Index - 1)); - end if; - - Ref.Source_Line := Current_Line; - end loop; - - Free (Buffer); - Free (Arr); - end Grep_Source_Files; - - --------------- - -- Read_File -- - --------------- - - procedure Read_File - (File_Name : String; - Contents : out GNAT.OS_Lib.String_Access) - is - Name_0 : constant String := File_Name & ASCII.NUL; - FD : constant File_Descriptor := Open_Read (Name_0'Address, Binary); - Length : Natural; - - begin - if FD = Invalid_FD then - raise Ada.Text_IO.Name_Error; - end if; - - -- Include room for EOF char - - Length := Natural (File_Length (FD)); - - declare - Buffer : String (1 .. Length + 1); - This_Read : Integer; - Read_Ptr : Natural := 1; - - begin - loop - This_Read := Read (FD, - A => Buffer (Read_Ptr)'Address, - N => Length + 1 - Read_Ptr); - Read_Ptr := Read_Ptr + Integer'Max (This_Read, 0); - exit when This_Read <= 0; - end loop; - - Buffer (Read_Ptr) := EOF; - Contents := new String'(Buffer (1 .. Read_Ptr)); - - -- Things are not simple on VMS due to the plethora of file types - -- and organizations. It seems clear that there shouldn't be more - -- bytes read than are contained in the file though. - - if (Hostparm.OpenVMS and then Read_Ptr > Length + 1) - or else (not Hostparm.OpenVMS and then Read_Ptr /= Length + 1) - then - raise Ada.Text_IO.End_Error; - end if; - - Close (FD); - end; - end Read_File; - - ----------------------- - -- Longest_File_Name -- - ----------------------- - - function Longest_File_Name return Natural is - begin - return Longest_File_Name_In_Table; - end Longest_File_Name; - - ----------- - -- Match -- - ----------- - - function Match - (File : File_Reference; - Line : Natural; - Column : Natural) - return Boolean - is - Ref : Ref_In_File_Ptr := File.Lines; - - begin - while Ref /= null loop - if (Ref.Line = 0 or else Ref.Line = Line) - and then (Ref.Column = 0 or else Ref.Column = Column) - then - return True; - end if; - - Ref := Ref.Next; - end loop; - - return False; - end Match; - - ----------- - -- Match -- - ----------- - - function Match (Decl : Declaration_Reference) return Boolean is - begin - return Decl.Match; - end Match; - - ---------- - -- Next -- - ---------- - - function Next (E : File_Reference) return File_Reference is - begin - return E.Next; - end Next; - - function Next (E : Declaration_Reference) return Declaration_Reference is - begin - return E.Next; - end Next; - - ------------------ - -- Next_Obj_Dir -- - ------------------ - - function Next_Obj_Dir return String is - First : constant Integer := Directories.Obj_Dir_Index; - Last : Integer; - - begin - Last := Directories.Obj_Dir_Index; - - if Last > Directories.Obj_Dir_Length then - return String'(1 .. 0 => ' '); - end if; - - while Directories.Obj_Dir (Last) /= Path_Separator loop - Last := Last + 1; - end loop; - - Directories.Obj_Dir_Index := Last + 1; - Directories.Last_Obj_Dir_Start := First; - return Directories.Obj_Dir (First .. Last - 1); - end Next_Obj_Dir; - - ------------------------- - -- Next_Unvisited_File -- - ------------------------- - - function Next_Unvisited_File return File_Reference is - procedure Unchecked_Free is new Ada.Unchecked_Deallocation - (Unvisited_Files_Record, Unvisited_Files_Access); - - Ref : File_Reference; - Tmp : Unvisited_Files_Access; - - begin - if Unvisited_Files = null then - return Empty_File; - else - Tmp := Unvisited_Files; - Ref := Unvisited_Files.File; - Unvisited_Files := Unvisited_Files.Next; - Unchecked_Free (Tmp); - return Ref; - end if; - end Next_Unvisited_File; - - ---------------------- - -- Parse_Gnatls_Src -- - ---------------------- - - function Parse_Gnatls_Src return String is - Length : Natural; - - begin - Length := 0; - for J in 1 .. Osint.Nb_Dir_In_Src_Search_Path loop - if Osint.Dir_In_Src_Search_Path (J)'Length = 0 then - Length := Length + 2; - else - Length := Length + Osint.Dir_In_Src_Search_Path (J)'Length + 1; - end if; - end loop; - - declare - Result : String (1 .. Length); - L : Natural; - - begin - L := Result'First; - for J in 1 .. Osint.Nb_Dir_In_Src_Search_Path loop - if Osint.Dir_In_Src_Search_Path (J)'Length = 0 then - Result (L .. L + 1) := "." & Path_Separator; - L := L + 2; - - else - Result (L .. L + Osint.Dir_In_Src_Search_Path (J)'Length - 1) := - Osint.Dir_In_Src_Search_Path (J).all; - L := L + Osint.Dir_In_Src_Search_Path (J)'Length; - Result (L) := Path_Separator; - L := L + 1; - end if; - end loop; - - return Result; - end; - end Parse_Gnatls_Src; - - ---------------------- - -- Parse_Gnatls_Obj -- - ---------------------- - - function Parse_Gnatls_Obj return String is - Length : Natural; - - begin - Length := 0; - for J in 1 .. Osint.Nb_Dir_In_Obj_Search_Path loop - if Osint.Dir_In_Obj_Search_Path (J)'Length = 0 then - Length := Length + 2; - else - Length := Length + Osint.Dir_In_Obj_Search_Path (J)'Length + 1; - end if; - end loop; - - declare - Result : String (1 .. Length); - L : Natural; - - begin - L := Result'First; - for J in 1 .. Osint.Nb_Dir_In_Obj_Search_Path loop - if Osint.Dir_In_Obj_Search_Path (J)'Length = 0 then - Result (L .. L + 1) := "." & Path_Separator; - L := L + 2; - else - Result (L .. L + Osint.Dir_In_Obj_Search_Path (J)'Length - 1) := - Osint.Dir_In_Obj_Search_Path (J).all; - L := L + Osint.Dir_In_Obj_Search_Path (J)'Length; - Result (L) := Path_Separator; - L := L + 1; - end if; - end loop; - - return Result; - end; - end Parse_Gnatls_Obj; - - ------------------- - -- Reset_Obj_Dir -- - ------------------- - - procedure Reset_Obj_Dir is - begin - Directories.Obj_Dir_Index := 1; - end Reset_Obj_Dir; - - ----------------------- - -- Set_Default_Match -- - ----------------------- - - procedure Set_Default_Match (Value : Boolean) is - begin - Default_Match := Value; - end Set_Default_Match; - - ---------- - -- Free -- - ---------- - - procedure Free (Str : in out Cst_String_Access) is - function Convert is new Ada.Unchecked_Conversion - (Cst_String_Access, GNAT.OS_Lib.String_Access); - - S : GNAT.OS_Lib.String_Access := Convert (Str); - - begin - Free (S); - Str := null; - end Free; - - --------------------- - -- Reset_Directory -- - --------------------- - - procedure Reset_Directory (File : File_Reference) is - begin - Free (File.Dir); - end Reset_Directory; - - ------------------- - -- Set_Unvisited -- - ------------------- - - procedure Set_Unvisited (File_Ref : File_Reference) is - F : constant String := Get_File (File_Ref, With_Dir => False); - - begin - File_Ref.Visited := False; - - -- ??? Do not add a source file to the list. This is true at - -- least for gnatxref, and probably for gnatfind as wel - - if F'Length > 4 - and then F (F'Last - 3 .. F'Last) = ".ali" - then - Unvisited_Files := new Unvisited_Files_Record' - (File => File_Ref, - Next => Unvisited_Files); - end if; - end Set_Unvisited; - - ---------------------- - -- Get_Declarations -- - ---------------------- - - function Get_Declarations - (Sorted : Boolean := True) - return Declaration_Array_Access - is - Arr : constant Declaration_Array_Access := - new Declaration_Array (1 .. Entities_Count); - Decl : Declaration_Reference := Entities_HTable.Get_First; - Index : Natural := Arr'First; - Tmp : Declaration_Reference; - - procedure Move (From : Natural; To : Natural); - function Lt (Op1, Op2 : Natural) return Boolean; - -- See GNAT.Heap_Sort_G - - -------- - -- Lt -- - -------- - - function Lt (Op1, Op2 : Natural) return Boolean is - begin - if Op1 = 0 then - return Is_Less_Than (Tmp, Arr (Op2)); - elsif Op2 = 0 then - return Is_Less_Than (Arr (Op1), Tmp); - else - return Is_Less_Than (Arr (Op1), Arr (Op2)); - end if; - end Lt; - - ---------- - -- Move -- - ---------- - - procedure Move (From : Natural; To : Natural) is - begin - if To = 0 then - Tmp := Arr (From); - elsif From = 0 then - Arr (To) := Tmp; - else - Arr (To) := Arr (From); - end if; - end Move; - - package Decl_Sort is new GNAT.Heap_Sort_G (Move, Lt); - - -- Start of processing for Get_Declarations - - begin - while Decl /= null loop - Arr (Index) := Decl; - Index := Index + 1; - Decl := Entities_HTable.Get_Next; - end loop; - - if Sorted and then Arr'Length /= 0 then - Decl_Sort.Sort (Entities_Count); - end if; - - return Arr; - end Get_Declarations; - - ---------------------- - -- References_Count -- - ---------------------- - - function References_Count - (Decl : Declaration_Reference; - Get_Reads : Boolean := False; - Get_Writes : Boolean := False; - Get_Bodies : Boolean := False) - return Natural - is - function List_Length (E : Reference) return Natural; - -- Return the number of references in E - - ----------------- - -- List_Length -- - ----------------- - - function List_Length (E : Reference) return Natural is - L : Natural := 0; - E1 : Reference := E; - - begin - while E1 /= null loop - L := L + 1; - E1 := E1.Next; - end loop; - - return L; - end List_Length; - - Length : Natural := 0; - - -- Start of processing for References_Count - - begin - if Get_Reads then - Length := List_Length (Decl.Ref_Ref); - end if; - - if Get_Writes then - Length := Length + List_Length (Decl.Modif_Ref); - end if; - - if Get_Bodies then - Length := Length + List_Length (Decl.Body_Ref); - end if; - - return Length; - end References_Count; - - ---------------------- - -- Store_References -- - ---------------------- - - procedure Store_References - (Decl : Declaration_Reference; - Get_Writes : Boolean := False; - Get_Reads : Boolean := False; - Get_Bodies : Boolean := False; - Get_Declaration : Boolean := False; - Arr : in out Reference_Array; - Index : in out Natural) - is - procedure Add (List : Reference); - -- Add all the references in List to Arr - - --------- - -- Add -- - --------- - - procedure Add (List : Reference) is - E : Reference := List; - begin - while E /= null loop - Arr (Index) := E; - Index := Index + 1; - E := E.Next; - end loop; - end Add; - - -- Start of processing for Store_References - - begin - if Get_Declaration then - Add (Decl.Decl); - end if; - - if Get_Reads then - Add (Decl.Ref_Ref); - end if; - - if Get_Writes then - Add (Decl.Modif_Ref); - end if; - - if Get_Bodies then - Add (Decl.Body_Ref); - end if; - end Store_References; - - -------------------- - -- Get_References -- - -------------------- - - function Get_References - (Decl : Declaration_Reference; - Get_Reads : Boolean := False; - Get_Writes : Boolean := False; - Get_Bodies : Boolean := False) - return Reference_Array_Access - is - Length : constant Natural := - References_Count (Decl, Get_Reads, Get_Writes, Get_Bodies); - - Arr : constant Reference_Array_Access := - new Reference_Array (1 .. Length); - - Index : Natural := Arr'First; - - begin - Store_References - (Decl => Decl, - Get_Writes => Get_Writes, - Get_Reads => Get_Reads, - Get_Bodies => Get_Bodies, - Get_Declaration => False, - Arr => Arr.all, - Index => Index); - - if Arr'Length /= 0 then - Sort (Arr.all); - end if; - - return Arr; - end Get_References; - - ---------- - -- Free -- - ---------- - - procedure Free (Arr : in out Reference_Array_Access) is - procedure Internal is new Ada.Unchecked_Deallocation - (Reference_Array, Reference_Array_Access); - begin - Internal (Arr); - end Free; - - ------------------ - -- Is_Parameter -- - ------------------ - - function Is_Parameter (Decl : Declaration_Reference) return Boolean is - begin - return Decl.Is_Parameter; - end Is_Parameter; - -end Xr_Tabls; |