+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- X R _ T A B L S --
--- --
--- B o d y --
--- --
--- $Revision: 1.1.16.1 $
--- --
--- 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. --
--- --
--- Extensive contributions were provided by Ada Core Technologies Inc. --
--- --
-------------------------------------------------------------------------------
-
-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;
projects / msp430-gcc.git / blobdiff