diff options
author | kenner <kenner@138bc75d-0d04-0410-961f-82ee72b054a4> | 2001-10-02 14:57:59 +0000 |
---|---|---|
committer | kenner <kenner@138bc75d-0d04-0410-961f-82ee72b054a4> | 2001-10-02 14:57:59 +0000 |
commit | 6f1e2b25e3063f24afbd430b2ec17a738b39a6d6 (patch) | |
tree | 4ef27cb0e7d117a7b5941427f004d4d06fc8675b /gcc/ada/xr_tabls.adb | |
parent | d6f39728ae3cc12d4f867eeb4659d01322643264 (diff) | |
download | ppe42-gcc-6f1e2b25e3063f24afbd430b2ec17a738b39a6d6.tar.gz ppe42-gcc-6f1e2b25e3063f24afbd430b2ec17a738b39a6d6.zip |
New Language: Ada
git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@45960 138bc75d-0d04-0410-961f-82ee72b054a4
Diffstat (limited to 'gcc/ada/xr_tabls.adb')
-rw-r--r-- | gcc/ada/xr_tabls.adb | 1376 |
1 files changed, 1376 insertions, 0 deletions
diff --git a/gcc/ada/xr_tabls.adb b/gcc/ada/xr_tabls.adb new file mode 100644 index 00000000000..02af07e75ec --- /dev/null +++ b/gcc/ada/xr_tabls.adb @@ -0,0 +1,1376 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- X R _ T A B L S -- +-- -- +-- B o d y -- +-- -- +-- $Revision: 1.36 $ +-- -- +-- Copyright (C) 1998-2001 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, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). -- +-- -- +------------------------------------------------------------------------------ + +with Ada.IO_Exceptions; +with Ada.Strings.Fixed; +with Ada.Strings; +with Ada.Text_IO; +with Hostparm; +with GNAT.IO_Aux; +with Unchecked_Deallocation; +with GNAT.OS_Lib; use GNAT.OS_Lib; +with GNAT.Directory_Operations; use GNAT.Directory_Operations; +with Osint; + +with Ada.Strings.Unbounded; use Ada.Strings.Unbounded; + +package body Xr_Tabls is + + subtype Line_String is String (1 .. Hostparm.Max_Line_Length); + subtype File_Name_String is String (1 .. Hostparm.Max_Name_Length); + + function Base_File_Name (File : String) return String; + -- Return the base file name for File (ie not including the directory) + + function Dir_Name (File : String; Base : String := "") return String; + -- Return the directory name of File, or "" if there is no directory part + -- in File. + -- This includes the last separator at the end, and always return an + -- absolute path name (directories are relative to Base, or the current + -- directory if Base is "") + + Dir_Sep : Character renames GNAT.OS_Lib.Directory_Separator; + + Files : File_Table; + Entities : Entity_Table; + Directories : Project_File_Ptr; + Default_Match : Boolean := False; + + --------------------- + -- Add_Declaration -- + --------------------- + + function Add_Declaration + (File_Ref : File_Reference; + Symbol : String; + Line : Natural; + Column : Natural; + Decl_Type : Character) + return Declaration_Reference + is + The_Entities : Declaration_Reference := Entities.Table; + New_Decl : Declaration_Reference; + Result : Compare_Result; + Prev : Declaration_Reference := null; + + begin + -- Check if the identifier already exists in the table + + while The_Entities /= null loop + Result := Compare (The_Entities, File_Ref, Line, Column, Symbol); + exit when Result = GreaterThan; + + if Result = Equal then + return The_Entities; + end if; + + Prev := The_Entities; + The_Entities := The_Entities.Next; + end loop; + + -- Insert the Declaration in the table + + New_Decl := new Declaration_Record' + (Symbol_Length => Symbol'Length, + Symbol => Symbol, + Decl => (File => File_Ref, + Line => Line, + Column => Column, + Source_Line => Null_Unbounded_String, + Next => null), + Decl_Type => Decl_Type, + Body_Ref => null, + Ref_Ref => null, + Modif_Ref => null, + Match => Default_Match or else Match (File_Ref, Line, Column), + Par_Symbol => null, + Next => null); + + if Prev = null then + New_Decl.Next := Entities.Table; + Entities.Table := New_Decl; + else + New_Decl.Next := Prev.Next; + Prev.Next := New_Decl; + end if; + + if New_Decl.Match then + Files.Longest_Name := Natural'Max (File_Ref.File'Length, + Files.Longest_Name); + end if; + + return New_Decl; + end Add_Declaration; + + -------------- + -- Add_File -- + -------------- + + procedure Add_File + (File_Name : String; + File_Existed : out Boolean; + Ref : out File_Reference; + Visited : Boolean := True; + Emit_Warning : Boolean := False; + Gnatchop_File : String := ""; + Gnatchop_Offset : Integer := 0) + is + The_Files : File_Reference := Files.Table; + Base : constant String := Base_File_Name (File_Name); + Dir : constant String := Xr_Tabls.Dir_Name (File_Name); + Dir_Acc : String_Access := null; + + begin + -- Do we have a directory name as well ? + if Dir /= "" then + Dir_Acc := new String' (Dir); + end if; + + -- Check if the file already exists in the table + + while The_Files /= null loop + + if The_Files.File = File_Name then + File_Existed := True; + Ref := The_Files; + return; + end if; + + The_Files := The_Files.Next; + end loop; + + Ref := new File_Record' + (File_Length => Base'Length, + File => Base, + Dir => Dir_Acc, + Lines => null, + Visited => Visited, + Emit_Warning => Emit_Warning, + Gnatchop_File => new String' (Gnatchop_File), + Gnatchop_Offset => Gnatchop_Offset, + Next => Files.Table); + Files.Table := Ref; + File_Existed := False; + end Add_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 := new Declaration_Record' + (Symbol_Length => Symbol'Length, + Symbol => Symbol, + Decl => (File => File_Ref, + Line => Line, + Column => Column, + Source_Line => Null_Unbounded_String, + Next => null), + Decl_Type => ' ', + Body_Ref => null, + Ref_Ref => null, + Modif_Ref => null, + Match => False, + Par_Symbol => null, + Next => null); + end Add_Parent; + + ------------------- + -- Add_Reference -- + ------------------- + + procedure Add_Reference + (Declaration : Declaration_Reference; + File_Ref : File_Reference; + Line : Natural; + Column : Natural; + Ref_Type : Character) + is + procedure Free is new Unchecked_Deallocation + (Reference_Record, Reference); + + Ref : Reference; + Prev : Reference := null; + Result : Compare_Result; + New_Ref : Reference := new Reference_Record' + (File => File_Ref, + Line => Line, + Column => Column, + Source_Line => Null_Unbounded_String, + Next => null); + + begin + case Ref_Type is + when 'b' | 'c' => Ref := Declaration.Body_Ref; + when 'r' | 'i' => Ref := Declaration.Ref_Ref; + when 'm' => Ref := Declaration.Modif_Ref; + when others => return; + end case; + + -- Check if the reference already exists + + while Ref /= null loop + Result := Compare (New_Ref, Ref); + exit when Result = LessThan; + + if Result = Equal then + Free (New_Ref); + return; + end if; + + Prev := Ref; + Ref := Ref.Next; + end loop; + + -- Insert it in the list + + if Prev /= null then + New_Ref.Next := Prev.Next; + Prev.Next := New_Ref; + + else + case Ref_Type is + when 'b' | 'c' => + New_Ref.Next := Declaration.Body_Ref; + Declaration.Body_Ref := New_Ref; + when 'r' | 'i' => + 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; + end if; + + if not Declaration.Match then + Declaration.Match := Match (File_Ref, Line, Column); + end if; + + if Declaration.Match then + Files.Longest_Name := Natural'Max (File_Ref.File'Length, + Files.Longest_Name); + end if; + end Add_Reference; + + ------------------- + -- ALI_File_Name -- + ------------------- + + function ALI_File_Name (Ada_File_Name : String) return String is + Index : 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; + + -------------------- + -- Base_File_Name -- + -------------------- + + function Base_File_Name (File : String) return String is + begin + for J in reverse File'Range loop + if File (J) = '/' or else File (J) = Dir_Sep then + return File (J + 1 .. File'Last); + end if; + end loop; + return File; + end Base_File_Name; + + ------------- + -- Compare -- + ------------- + + function Compare + (Ref1 : Reference; + Ref2 : Reference) + return Compare_Result + is + begin + if Ref1 = null then + return GreaterThan; + elsif Ref2 = null then + return LessThan; + end if; + + if Ref1.File.File < Ref2.File.File then + return LessThan; + + elsif Ref1.File.File = Ref2.File.File then + if Ref1.Line < Ref2.Line then + return LessThan; + + elsif Ref1.Line = Ref2.Line then + if Ref1.Column < Ref2.Column then + return LessThan; + elsif Ref1.Column = Ref2.Column then + return Equal; + else + return GreaterThan; + end if; + + else + return GreaterThan; + end if; + + else + return GreaterThan; + end if; + end Compare; + + ------------- + -- Compare -- + ------------- + + function Compare + (Decl1 : Declaration_Reference; + File2 : File_Reference; + Line2 : Integer; + Col2 : Integer; + Symb2 : String) + return Compare_Result + is + begin + if Decl1 = null then + return GreaterThan; + end if; + + if Decl1.Symbol < Symb2 then + return LessThan; + elsif Decl1.Symbol > Symb2 then + return GreaterThan; + end if; + + if Decl1.Decl.File.File < Get_File (File2) then + return LessThan; + + elsif Decl1.Decl.File.File = Get_File (File2) then + if Decl1.Decl.Line < Line2 then + return LessThan; + + elsif Decl1.Decl.Line = Line2 then + if Decl1.Decl.Column < Col2 then + return LessThan; + + elsif Decl1.Decl.Column = Col2 then + return Equal; + + else + return GreaterThan; + end if; + + else + return GreaterThan; + end if; + + else + return GreaterThan; + end if; + end Compare; + + ------------------------- + -- Create_Project_File -- + ------------------------- + + procedure Create_Project_File + (Name : String) + is + use Ada.Strings.Unbounded; + + Obj_Dir : Unbounded_String := Null_Unbounded_String; + Src_Dir : Unbounded_String := Null_Unbounded_String; + Build_Dir : Unbounded_String; + + Gnatls_Src_Cache : Unbounded_String; + Gnatls_Obj_Cache : Unbounded_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; + + Build_Dir := + To_Unbounded_String (Buffer (Index .. Last - 1)); + if Buffer (Last - 1) /= Dir_Sep then + Append (Build_Dir, Dir_Sep); + end if; + 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 + declare + S : String := Ada.Strings.Fixed.Trim + (Buffer (Index + 8 .. Last - 1), Ada.Strings.Both); + begin + -- A relative directory ? + if S (S'First) /= Dir_Sep then + Append (Src_Dir, Build_Dir); + end if; + + if S (S'Last) = Dir_Sep then + Append (Src_Dir, S & " "); + else + Append (Src_Dir, S & Dir_Sep & " "); + end if; + end; + + elsif Index <= Buffer'Last - 7 + and then Buffer (Index .. Index + 7) = "obj_dir=" + then + declare + S : String := Ada.Strings.Fixed.Trim + (Buffer (Index + 8 .. Last - 1), Ada.Strings.Both); + begin + -- A relative directory ? + if S (S'First) /= Dir_Sep then + Append (Obj_Dir, Build_Dir); + end if; + + if S (S'Last) = Dir_Sep then + Append (Obj_Dir, S & " "); + else + Append (Obj_Dir, S & Dir_Sep & " "); + end if; + end; + 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; + + Parse_Gnatls (Gnatls_Src_Cache, Gnatls_Obj_Cache); + + Directories := new Project_File' + (Src_Dir_Length => Length (Src_Dir) + Length (Gnatls_Src_Cache), + Obj_Dir_Length => Length (Obj_Dir) + Length (Gnatls_Obj_Cache), + Src_Dir => To_String (Src_Dir & Gnatls_Src_Cache), + Obj_Dir => To_String (Obj_Dir & Gnatls_Obj_Cache), + Src_Dir_Index => 1, + Obj_Dir_Index => 1, + Last_Obj_Dir_Start => 0); + 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; + + -------------- + -- Dir_Name -- + -------------- + + function Dir_Name (File : String; Base : String := "") return String is + begin + for J in reverse File'Range loop + if File (J) = '/' or else File (J) = Dir_Sep then + + -- Is this an absolute directory ? + if File (File'First) = '/' + or else File (File'First) = Dir_Sep + then + return File (File'First .. J); + + -- Else do we know the base directory ? + elsif Base /= "" then + return Base & File (File'First .. J); + + else + declare + Max_Path : Integer; + pragma Import (C, Max_Path, "max_path_len"); + + Base2 : Dir_Name_Str (1 .. Max_Path); + Last : Natural; + begin + Get_Current_Dir (Base2, Last); + return Base2 (Base2'First .. Last) & File (File'First .. J); + end; + end if; + end if; + end loop; + return ""; + end Dir_Name; + + ------------------- + -- Find_ALI_File -- + ------------------- + + function Find_ALI_File (Short_Name : String) return String is + use type Ada.Strings.Unbounded.String_Access; + Old_Obj_Dir : constant Integer := Directories.Obj_Dir_Index; + + begin + Reset_Obj_Dir; + + loop + declare + Obj_Dir : String := Next_Obj_Dir; + begin + exit when Obj_Dir'Length = 0; + if GNAT.IO_Aux.File_Exists (Obj_Dir & Short_Name) then + Directories.Obj_Dir_Index := Old_Obj_Dir; + return Obj_Dir; + end if; + end; + end loop; + + -- Finally look in the standard directories + + Directories.Obj_Dir_Index := Old_Obj_Dir; + return ""; + end Find_ALI_File; + + ---------------------- + -- Find_Source_File -- + ---------------------- + + function Find_Source_File (Short_Name : String) return String is + use type Ada.Strings.Unbounded.String_Access; + + begin + Reset_Src_Dir; + loop + declare + Src_Dir : String := Next_Src_Dir; + begin + exit when Src_Dir'Length = 0; + + if GNAT.IO_Aux.File_Exists (Src_Dir & Short_Name) then + return Src_Dir; + end if; + end; + end loop; + + -- Finally look in the standard directories + + return ""; + end Find_Source_File; + + ---------------- + -- First_Body -- + ---------------- + + function First_Body (Decl : Declaration_Reference) return Reference is + begin + return Decl.Body_Ref; + end First_Body; + + ----------------------- + -- First_Declaration -- + ----------------------- + + function First_Declaration return Declaration_Reference is + begin + return Entities.Table; + end First_Declaration; + + ----------------- + -- First_Modif -- + ----------------- + + function First_Modif (Decl : Declaration_Reference) return Reference is + begin + return Decl.Modif_Ref; + end First_Modif; + + --------------------- + -- First_Reference -- + --------------------- + + function First_Reference (Decl : Declaration_Reference) return Reference is + begin + return Decl.Ref_Ref; + end First_Reference; + + ---------------- + -- 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 + The_Entities : Declaration_Reference := Entities.Table; + begin + while The_Entities /= null loop + if The_Entities.Decl.Line = Line + and then The_Entities.Decl.Column = Column + and then The_Entities.Decl.File = File_Ref + then + return The_Entities; + else + The_Entities := The_Entities.Next; + end if; + end loop; + + return Empty_Declaration; + 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 : in Boolean := False; + Strip : Natural := 0) + return String + is + 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, Extension_Start : Natural; + S : Natural := Strip; + 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 + + 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; + + begin + -- If we do not want the full path name + + if not With_Dir then + return Internal_Strip (File.File); + end if; + + if File.Dir = null then + + if Ada.Strings.Fixed.Tail (File.File, 3) = "ali" then + File.Dir := new String'(Find_ALI_File (File.File)); + else + File.Dir := new String'(Find_Source_File (File.File)); + end if; + end if; + + return Internal_Strip (File.Dir.all & File.File); + 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; + + ----------------------- + -- 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; + + ----------------------- + -- 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 + return To_String (Ref.Source_Line); + end Get_Source_Line; + + function Get_Source_Line (Decl : Declaration_Reference) return String is + begin + return To_String (Decl.Decl.Source_Line); + 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; + + ----------------------- + -- Grep_Source_Files -- + ----------------------- + + procedure Grep_Source_Files is + Decl : Declaration_Reference := First_Declaration; + + type Simple_Ref; + type Simple_Ref_Access is access Simple_Ref; + type Simple_Ref is + record + Ref : Reference; + Next : Simple_Ref_Access; + end record; + List : Simple_Ref_Access := null; + -- This structure is used to speed up the parsing of Ada sources: + -- Every reference found by parsing the .ali files is inserted in this + -- list, sorted by filename and line numbers. + -- This allows use not to parse a same ada file multiple times + + procedure Free is new Unchecked_Deallocation + (Simple_Ref, Simple_Ref_Access); + -- Clear an element of the list + + procedure Grep_List; + -- For each reference in the list, parse the file and find the + -- source line + + procedure Insert_In_Order (Ref : Reference); + -- Insert a new reference in the list, ordered by line numbers + + procedure Insert_List_Ref (First_Ref : Reference); + -- Process a list of references + + --------------- + -- Grep_List -- + --------------- + + procedure Grep_List is + Line : String (1 .. 1024); + Last : Natural; + File : Ada.Text_IO.File_Type; + Line_Number : Natural; + Pos : Natural; + Save_List : Simple_Ref_Access := List; + Current_File : File_Reference; + + begin + while List /= null loop + + -- Makes sure we can find and read the file + + Current_File := List.Ref.File; + Line_Number := 0; + + begin + Ada.Text_IO.Open (File, + Ada.Text_IO.In_File, + Get_File (List.Ref, True)); + + -- Read the file and find every relevant lines + + while List /= null + and then List.Ref.File = Current_File + and then not Ada.Text_IO.End_Of_File (File) + loop + Ada.Text_IO.Get_Line (File, Line, Last); + Line_Number := Line_Number + 1; + + while List /= null + and then Line_Number = List.Ref.Line + loop + + -- Skip the leading blanks on the line + + Pos := 1; + while Line (Pos) = ' ' + or else Line (Pos) = ASCII.HT + loop + Pos := Pos + 1; + end loop; + + List.Ref.Source_Line := + To_Unbounded_String (Line (Pos .. Last)); + + -- Find the next element in the list + + List := List.Next; + end loop; + + end loop; + + Ada.Text_IO.Close (File); + + -- If the Current_File was not found, just skip it + + exception + when Ada.IO_Exceptions.Name_Error => + null; + end; + + -- If the line or the file were not found + + while List /= null + and then List.Ref.File = Current_File + loop + List := List.Next; + end loop; + + end loop; + + -- Clear the list + + while Save_List /= null loop + List := Save_List; + Save_List := Save_List.Next; + Free (List); + end loop; + end Grep_List; + + --------------------- + -- Insert_In_Order -- + --------------------- + + procedure Insert_In_Order (Ref : Reference) is + Iter : Simple_Ref_Access := List; + Prev : Simple_Ref_Access := null; + + begin + while Iter /= null loop + + -- If we have found the file, sort by lines + + if Iter.Ref.File = Ref.File then + + while Iter /= null + and then Iter.Ref.File = Ref.File + loop + if Iter.Ref.Line > Ref.Line then + + if Iter = List then + List := new Simple_Ref'(Ref, List); + else + Prev.Next := new Simple_Ref'(Ref, Iter); + end if; + return; + end if; + + Prev := Iter; + Iter := Iter.Next; + end loop; + + if Iter = List then + List := new Simple_Ref'(Ref, List); + else + Prev.Next := new Simple_Ref'(Ref, Iter); + end if; + return; + end if; + + Prev := Iter; + Iter := Iter.Next; + end loop; + + -- The file was not already in the list, insert it + + List := new Simple_Ref'(Ref, List); + end Insert_In_Order; + + --------------------- + -- Insert_List_Ref -- + --------------------- + + procedure Insert_List_Ref (First_Ref : Reference) is + Ref : Reference := First_Ref; + + begin + while Ref /= Empty_Reference loop + Insert_In_Order (Ref); + Ref := Next (Ref); + end loop; + end Insert_List_Ref; + + -- Start of processing for Grep_Source_Files + + begin + while Decl /= Empty_Declaration loop + Insert_In_Order (Decl.Decl'Access); + Insert_List_Ref (First_Body (Decl)); + Insert_List_Ref (First_Reference (Decl)); + Insert_List_Ref (First_Modif (Decl)); + Decl := Next (Decl); + end loop; + + Grep_List; + end Grep_Source_Files; + + ----------------------- + -- Longest_File_Name -- + ----------------------- + + function Longest_File_Name return Natural is + begin + return Files.Longest_Name; + 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 (Decl : Declaration_Reference) return Declaration_Reference is + begin + return Decl.Next; + end Next; + + ---------- + -- Next -- + ---------- + + function Next (Ref : Reference) return Reference is + begin + return Ref.Next; + end Next; + + ------------------ + -- Next_Obj_Dir -- + ------------------ + + function Next_Obj_Dir return String is + First : Integer := Directories.Obj_Dir_Index; + Last : Integer := Directories.Obj_Dir_Index; + + begin + if Last > Directories.Obj_Dir_Length then + return String'(1 .. 0 => ' '); + end if; + + while Directories.Obj_Dir (Last) /= ' ' 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_Src_Dir -- + ------------------ + + function Next_Src_Dir return String is + First : Integer := Directories.Src_Dir_Index; + Last : Integer := Directories.Src_Dir_Index; + + begin + if Last > Directories.Src_Dir_Length then + return String'(1 .. 0 => ' '); + end if; + + while Directories.Src_Dir (Last) /= ' ' loop + Last := Last + 1; + end loop; + + Directories.Src_Dir_Index := Last + 1; + return Directories.Src_Dir (First .. Last - 1); + end Next_Src_Dir; + + ------------------------- + -- Next_Unvisited_File -- + ------------------------- + + function Next_Unvisited_File return File_Reference is + The_Files : File_Reference := Files.Table; + + begin + while The_Files /= null loop + if not The_Files.Visited then + The_Files.Visited := True; + return The_Files; + end if; + + The_Files := The_Files.Next; + end loop; + + return Empty_File; + end Next_Unvisited_File; + + ------------------ + -- Parse_Gnatls -- + ------------------ + + procedure Parse_Gnatls + (Gnatls_Src_Cache : out Ada.Strings.Unbounded.Unbounded_String; + Gnatls_Obj_Cache : out Ada.Strings.Unbounded.Unbounded_String) + is + begin + Osint.Add_Default_Search_Dirs; + + for J in 1 .. Osint.Nb_Dir_In_Src_Search_Path loop + if Osint.Dir_In_Src_Search_Path (J)'Length = 0 then + Ada.Strings.Unbounded.Append (Gnatls_Src_Cache, "./" & ' '); + else + Ada.Strings.Unbounded.Append + (Gnatls_Src_Cache, Osint.Dir_In_Src_Search_Path (J).all & ' '); + end if; + end loop; + + for J in 1 .. Osint.Nb_Dir_In_Obj_Search_Path loop + if Osint.Dir_In_Obj_Search_Path (J)'Length = 0 then + Ada.Strings.Unbounded.Append (Gnatls_Obj_Cache, "./" & ' '); + else + Ada.Strings.Unbounded.Append + (Gnatls_Obj_Cache, Osint.Dir_In_Obj_Search_Path (J).all & ' '); + end if; + end loop; + end Parse_Gnatls; + + ------------------- + -- Reset_Obj_Dir -- + ------------------- + + procedure Reset_Obj_Dir is + begin + Directories.Obj_Dir_Index := 1; + end Reset_Obj_Dir; + + ------------------- + -- Reset_Src_Dir -- + ------------------- + + procedure Reset_Src_Dir is + begin + Directories.Src_Dir_Index := 1; + end Reset_Src_Dir; + + ----------------------- + -- Set_Default_Match -- + ----------------------- + + procedure Set_Default_Match (Value : Boolean) is + begin + Default_Match := Value; + end Set_Default_Match; + + ------------------- + -- Set_Directory -- + ------------------- + + procedure Set_Directory + (File : in File_Reference; + Dir : in String) + is + begin + File.Dir := new String'(Dir); + end Set_Directory; + + ------------------- + -- Set_Unvisited -- + ------------------- + + procedure Set_Unvisited (File_Ref : in File_Reference) is + The_Files : File_Reference := Files.Table; + + begin + while The_Files /= null loop + if The_Files = File_Ref then + The_Files.Visited := False; + return; + end if; + + The_Files := The_Files.Next; + end loop; + end Set_Unvisited; + +end Xr_Tabls; |