| ------------------------------------------------------------------------------ |
| -- -- |
| -- 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; |
