-- --
-- B o d y --
-- --
--- $Revision$
--- --
--- Copyright (C) 1998-2002 Free Software Foundation, Inc. --
+-- Copyright (C) 1998-2010, 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- --
+-- ware Foundation; either version 3, 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. --
+-- Public License distributed with GNAT; see file COPYING3. If not, go to --
+-- http://www.gnu.org/licenses for a complete copy of the license. --
-- --
--- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- GNAT was originally developed by the GNAT team at New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
+with Types; use Types;
with Osint;
-with Unchecked_Deallocation;
+with Hostparm;
-with Ada.IO_Exceptions;
+with Ada.Unchecked_Conversion;
+with Ada.Unchecked_Deallocation;
with Ada.Strings.Fixed;
with Ada.Strings;
with Ada.Text_IO;
-with Ada.Strings.Unbounded; use Ada.Strings.Unbounded;
+with Ada.Characters.Handling; use Ada.Characters.Handling;
+with Ada.Strings.Unbounded; use Ada.Strings.Unbounded;
-with GNAT.IO_Aux;
with GNAT.OS_Lib; use GNAT.OS_Lib;
with GNAT.Directory_Operations; use GNAT.Directory_Operations;
+with GNAT.HTable; use GNAT.HTable;
+with GNAT.Heap_Sort_G;
package body Xr_Tabls is
- function Base_File_Name (File : String) return String;
- -- Return the base file name for File (ie not including the directory)
+ type HTable_Headers is range 1 .. 10000;
+
+ procedure Set_Next (E : File_Reference; Next : File_Reference);
+ function Next (E : File_Reference) return File_Reference;
+ function Get_Key (E : File_Reference) return Cst_String_Access;
+ function Hash (F : Cst_String_Access) return HTable_Headers;
+ function Equal (F1, F2 : Cst_String_Access) return Boolean;
+ -- The five subprograms above are used to instantiate the static
+ -- htable to store the files that should be processed.
+
+ package File_HTable is new GNAT.HTable.Static_HTable
+ (Header_Num => HTable_Headers,
+ Element => File_Record,
+ Elmt_Ptr => File_Reference,
+ Null_Ptr => null,
+ Set_Next => Set_Next,
+ Next => Next,
+ Key => Cst_String_Access,
+ Get_Key => Get_Key,
+ Hash => Hash,
+ Equal => Equal);
+ -- A hash table to store all the files referenced in the
+ -- application. The keys in this htable are the name of the files
+ -- themselves, therefore it is assumed that the source path
+ -- doesn't contain twice the same source or ALI file name
+
+ type Unvisited_Files_Record;
+ type Unvisited_Files_Access is access Unvisited_Files_Record;
+ type Unvisited_Files_Record is record
+ File : File_Reference;
+ Next : Unvisited_Files_Access;
+ end record;
+ -- A special list, in addition to File_HTable, that only stores
+ -- the files that haven't been visited so far. Note that the File
+ -- list points to some data in File_HTable, and thus should never be freed.
+
+ function Next (E : Declaration_Reference) return Declaration_Reference;
+ procedure Set_Next (E, Next : Declaration_Reference);
+ function Get_Key (E : Declaration_Reference) return Cst_String_Access;
+ -- The subprograms above are used to instantiate the static
+ -- htable to store the entities that have been found in the application
+
+ package Entities_HTable is new GNAT.HTable.Static_HTable
+ (Header_Num => HTable_Headers,
+ Element => Declaration_Record,
+ Elmt_Ptr => Declaration_Reference,
+ Null_Ptr => null,
+ Set_Next => Set_Next,
+ Next => Next,
+ Key => Cst_String_Access,
+ Get_Key => Get_Key,
+ Hash => Hash,
+ Equal => Equal);
+ -- A hash table to store all the entities defined in the
+ -- application. For each entity, we store a list of its reference
+ -- locations as well.
+ -- The keys in this htable should be created with Key_From_Ref,
+ -- and are the file, line and column of the declaration, which are
+ -- unique for every entity.
+
+ Entities_Count : Natural := 0;
+ -- Number of entities in Entities_HTable. This is used in the end
+ -- when sorting the table.
+
+ Longest_File_Name_In_Table : Natural := 0;
+ Unvisited_Files : Unvisited_Files_Access := null;
+ Directories : Project_File_Ptr;
+ Default_Match : Boolean := False;
+ -- The above need commenting ???
+
+ function Parse_Gnatls_Src return String;
+ -- Return the standard source directories (taking into account the
+ -- ADA_INCLUDE_PATH environment variable, if Osint.Add_Default_Search_Dirs
+ -- was called first).
+
+ function Parse_Gnatls_Obj return String;
+ -- Return the standard object directories (taking into account the
+ -- ADA_OBJECTS_PATH environment variable).
+
+ function Key_From_Ref
+ (File_Ref : File_Reference;
+ Line : Natural;
+ Column : Natural)
+ return String;
+ -- Return a key for the symbol declared at File_Ref, Line,
+ -- Column. This key should be used for lookup in Entity_HTable
+
+ function Is_Less_Than (Decl1, Decl2 : Declaration_Reference) return Boolean;
+ -- Compare two declarations (the comparison is case-insensitive)
+
+ function Is_Less_Than (Ref1, Ref2 : Reference) return Boolean;
+ -- Compare two references
+
+ procedure Store_References
+ (Decl : Declaration_Reference;
+ Get_Writes : Boolean := False;
+ Get_Reads : Boolean := False;
+ Get_Bodies : Boolean := False;
+ Get_Declaration : Boolean := False;
+ Arr : in out Reference_Array;
+ Index : in out Natural);
+ -- Store in Arr, starting at Index, all the references to Decl. The Get_*
+ -- parameters can be used to indicate which references should be stored.
+ -- Constraint_Error will be raised if Arr is not big enough.
+
+ procedure Sort (Arr : in out Reference_Array);
+ -- Sort an array of references (Arr'First must be 1)
+
+ --------------
+ -- Set_Next --
+ --------------
+
+ procedure Set_Next (E : File_Reference; Next : File_Reference) is
+ begin
+ E.Next := Next;
+ end Set_Next;
+
+ procedure Set_Next
+ (E : Declaration_Reference; Next : Declaration_Reference) is
+ begin
+ E.Next := Next;
+ end Set_Next;
+
+ -------------
+ -- Get_Key --
+ -------------
+
+ function Get_Key (E : File_Reference) return Cst_String_Access is
+ begin
+ return E.File;
+ end Get_Key;
+
+ function Get_Key (E : Declaration_Reference) return Cst_String_Access is
+ begin
+ return E.Key;
+ end Get_Key;
+
+ ----------
+ -- Hash --
+ ----------
+
+ function Hash (F : Cst_String_Access) return HTable_Headers is
+ function H is new GNAT.HTable.Hash (HTable_Headers);
- 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 "")
+ begin
+ return H (F.all);
+ end Hash;
+
+ -----------
+ -- Equal --
+ -----------
- Dir_Sep : Character renames GNAT.OS_Lib.Directory_Separator;
+ function Equal (F1, F2 : Cst_String_Access) return Boolean is
+ begin
+ return F1.all = F2.all;
+ end Equal;
+
+ ------------------
+ -- Key_From_Ref --
+ ------------------
- Files : File_Table;
- Entities : Entity_Table;
- Directories : Project_File_Ptr;
- Default_Match : Boolean := False;
+ function Key_From_Ref
+ (File_Ref : File_Reference;
+ Line : Natural;
+ Column : Natural)
+ return String
+ is
+ begin
+ return File_Ref.File.all & Natural'Image (Line) & Natural'Image (Column);
+ end Key_From_Ref;
---------------------
-- Add_Declaration --
---------------------
function Add_Declaration
- (File_Ref : File_Reference;
- Symbol : String;
- Line : Natural;
- Column : Natural;
- Decl_Type : Character)
- return Declaration_Reference
+ (File_Ref : File_Reference;
+ Symbol : String;
+ Line : Natural;
+ Column : Natural;
+ Decl_Type : Character;
+ Remove_Only : Boolean := False;
+ Symbol_Match : Boolean := True)
+ return Declaration_Reference
is
- The_Entities : Declaration_Reference := Entities.Table;
- New_Decl : Declaration_Reference;
- Result : Compare_Result;
- Prev : Declaration_Reference := null;
+ procedure Unchecked_Free is new Ada.Unchecked_Deallocation
+ (Declaration_Record, Declaration_Reference);
- begin
- -- Check if the identifier already exists in the table
+ Key : aliased constant String := Key_From_Ref (File_Ref, Line, Column);
- while The_Entities /= null loop
- Result := Compare (The_Entities, File_Ref, Line, Column, Symbol);
- exit when Result = GreaterThan;
+ New_Decl : Declaration_Reference :=
+ Entities_HTable.Get (Key'Unchecked_Access);
- if Result = Equal then
- return The_Entities;
- end if;
+ Is_Parameter : Boolean := False;
- 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;
+ begin
+ -- Insert the Declaration in the table. There might already be a
+ -- declaration in the table if the entity is a parameter, so we
+ -- need to check that first.
+
+ if New_Decl /= null and then New_Decl.Symbol_Length = 0 then
+ Is_Parameter := New_Decl.Is_Parameter;
+ Entities_HTable.Remove (Key'Unrestricted_Access);
+ Entities_Count := Entities_Count - 1;
+ Free (New_Decl.Key);
+ Unchecked_Free (New_Decl);
+ New_Decl := null;
end if;
- if New_Decl.Match then
- Files.Longest_Name := Natural'Max (File_Ref.File'Length,
- Files.Longest_Name);
+ -- The declaration might also already be there for parent types. In
+ -- this case, we should keep the entry, since some other entries are
+ -- pointing to it.
+
+ if New_Decl = null
+ and then not Remove_Only
+ then
+ New_Decl :=
+ new Declaration_Record'
+ (Symbol_Length => Symbol'Length,
+ Symbol => Symbol,
+ Key => new String'(Key),
+ Decl => new Reference_Record'
+ (File => File_Ref,
+ Line => Line,
+ Column => Column,
+ Source_Line => null,
+ Next => null),
+ Is_Parameter => Is_Parameter,
+ Decl_Type => Decl_Type,
+ Body_Ref => null,
+ Ref_Ref => null,
+ Modif_Ref => null,
+ Match => Symbol_Match
+ and then
+ (Default_Match
+ or else Match (File_Ref, Line, Column)),
+ Par_Symbol => null,
+ Next => null);
+
+ Entities_HTable.Set (New_Decl);
+ Entities_Count := Entities_Count + 1;
+
+ if New_Decl.Match then
+ Longest_File_Name_In_Table :=
+ Natural'Max (File_Ref.File'Length, Longest_File_Name_In_Table);
+ end if;
+
+ elsif New_Decl /= null
+ and then not New_Decl.Match
+ then
+ New_Decl.Match := Default_Match
+ or else Match (File_Ref, Line, Column);
end if;
return New_Decl;
-- Add_To_Xref_File --
----------------------
- procedure Add_To_Xref_File
+ function Add_To_Xref_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)
+ Gnatchop_Offset : Integer := 0) return File_Reference
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;
+ Base : aliased constant String := Base_Name (File_Name);
+ Dir : constant String := Dir_Name (File_Name);
+ Dir_Acc : GNAT.OS_Lib.String_Access := null;
+ Ref : File_Reference;
begin
-- Do we have a directory name as well?
- if Dir /= "" then
- Dir_Acc := new String' (Dir);
+ if File_Name /= Base then
+ Dir_Acc := new String'(Dir);
end if;
- -- Check if the file already exists in the table
+ Ref := File_HTable.Get (Base'Unchecked_Access);
+ if Ref = null then
+ Ref := new File_Record'
+ (File => new String'(Base),
+ Dir => Dir_Acc,
+ Lines => null,
+ Visited => Visited,
+ Emit_Warning => Emit_Warning,
+ Gnatchop_File => new String'(Gnatchop_File),
+ Gnatchop_Offset => Gnatchop_Offset,
+ Next => null);
+ File_HTable.Set (Ref);
- while The_Files /= null loop
+ if not Visited then
- if The_Files.File = File_Name then
- File_Existed := True;
- Ref := The_Files;
- return;
- end if;
-
- The_Files := The_Files.Next;
- end loop;
+ -- Keep a separate list for faster access
- 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;
+ Set_Unvisited (Ref);
+ end if;
+ end if;
+ return Ref;
end Add_To_Xref_File;
--------------
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);
+ Declaration.Par_Symbol :=
+ Add_Declaration
+ (File_Ref, Symbol, Line, Column,
+ Decl_Type => ' ',
+ Symbol_Match => False);
end Add_Parent;
-------------------
-------------------
procedure Add_Reference
- (Declaration : Declaration_Reference;
- File_Ref : File_Reference;
- Line : Natural;
- Column : Natural;
- Ref_Type : Character)
+ (Declaration : Declaration_Reference;
+ File_Ref : File_Reference;
+ Line : Natural;
+ Column : Natural;
+ Ref_Type : Character;
+ Labels_As_Ref : Boolean)
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);
+ New_Ref : Reference;
begin
case Ref_Type is
- when 'b' | 'c' =>
- Ref := Declaration.Body_Ref;
+ when 'b' | 'c' | 'H' | 'm' | 'o' | 'r' | 'R' |
+ 's' | 'i' | ' ' | 'x' =>
+ null;
- when 'r' | 'i' | 'l' | ' ' | 'x' =>
- Ref := Declaration.Ref_Ref;
+ when 'l' | 'w' =>
+ if not Labels_As_Ref then
+ return;
+ end if;
- when 'm' =>
- Ref := Declaration.Modif_Ref;
+ when '=' | '<' | '>' | '^' =>
- when 'e' | 't' | 'p' =>
+ -- Create a dummy declaration in the table to report it as a
+ -- parameter. Note that the current declaration for the subprogram
+ -- comes before the declaration of the parameter.
+
+ declare
+ Key : constant String :=
+ Key_From_Ref (File_Ref, Line, Column);
+ New_Decl : Declaration_Reference;
+
+ begin
+ New_Decl := new Declaration_Record'
+ (Symbol_Length => 0,
+ Symbol => "",
+ Key => new String'(Key),
+ Decl => new Reference_Record'
+ (File => File_Ref,
+ Line => Line,
+ Column => Column,
+ Source_Line => null,
+ Next => null),
+ Is_Parameter => True,
+ Decl_Type => ' ',
+ Body_Ref => null,
+ Ref_Ref => null,
+ Modif_Ref => null,
+ Match => False,
+ Par_Symbol => null,
+ Next => null);
+ Entities_HTable.Set (New_Decl);
+ Entities_Count := Entities_Count + 1;
+ end;
+
+ when 'e' | 'z' | 't' | 'p' | 'P' | 'k' | 'd' =>
return;
when others =>
return;
end case;
- -- Check if the reference already exists
-
- while Ref /= null loop
- Result := Compare (New_Ref, Ref);
- exit when Result = LessThan;
+ New_Ref := new Reference_Record'
+ (File => File_Ref,
+ Line => Line,
+ Column => Column,
+ Source_Line => null,
+ Next => null);
- if Result = Equal then
- Free (New_Ref);
- return;
- end if;
+ -- We can insert the reference into the list directly, since all the
+ -- references will appear only once in the ALI file corresponding to the
+ -- file where they are referenced. This saves a lot of time compared to
+ -- checking the list to check if it exists.
- Prev := Ref;
- Ref := Ref.Next;
- end loop;
+ case Ref_Type is
+ when 'b' | 'c' =>
+ New_Ref.Next := Declaration.Body_Ref;
+ Declaration.Body_Ref := New_Ref;
- -- Insert it in the list
+ when 'r' | 'R' | 's' | 'H' | 'i' | 'l' | 'o' | ' ' | 'x' | 'w' =>
+ New_Ref.Next := Declaration.Ref_Ref;
+ Declaration.Ref_Ref := New_Ref;
- if Prev /= null then
- New_Ref.Next := Prev.Next;
- Prev.Next := New_Ref;
+ when 'm' =>
+ New_Ref.Next := Declaration.Modif_Ref;
+ Declaration.Modif_Ref := New_Ref;
- else
- case Ref_Type is
- when 'b' | 'c' =>
- New_Ref.Next := Declaration.Body_Ref;
- Declaration.Body_Ref := New_Ref;
-
- when 'r' | 'i' | 'l' | ' ' | 'x' =>
- 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;
+ when others =>
+ null;
+ end case;
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);
+ Longest_File_Name_In_Table :=
+ Natural'Max (File_Ref.File'Length, Longest_File_Name_In_Table);
end if;
end Add_Reference;
-------------------
function ALI_File_Name (Ada_File_Name : String) return String is
- Index : Natural := Ada.Strings.Fixed.Index
- (Ada_File_Name, ".", Going => Ada.Strings.Backward);
+
+ -- ??? Should ideally be based on the naming scheme defined in
+ -- project files.
+
+ Index : constant Natural :=
+ Ada.Strings.Fixed.Index
+ (Ada_File_Name, ".", Going => Ada.Strings.Backward);
begin
if Index /= 0 then
return Ada_File_Name (Ada_File_Name'First .. Index)
- & "ali";
+ & Osint.ALI_Suffix.all;
else
- return Ada_File_Name & ".ali";
+ return Ada_File_Name & "." & Osint.ALI_Suffix.all;
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 --
- -------------
+ ------------------
+ -- Is_Less_Than --
+ ------------------
- function Compare
- (Ref1 : Reference;
- Ref2 : Reference)
- return Compare_Result
- is
+ function Is_Less_Than (Ref1, Ref2 : Reference) return Boolean is
begin
if Ref1 = null then
- return GreaterThan;
+ return False;
elsif Ref2 = null then
- return LessThan;
+ return True;
end if;
- if Ref1.File.File < Ref2.File.File then
- return LessThan;
+ if Ref1.File.File.all < Ref2.File.File.all then
+ return True;
- elsif Ref1.File.File = Ref2.File.File then
- if Ref1.Line < Ref2.Line then
- return LessThan;
+ elsif Ref1.File.File.all = Ref2.File.File.all then
+ return (Ref1.Line < Ref2.Line
+ or else (Ref1.Line = Ref2.Line
+ and then Ref1.Column < Ref2.Column));
+ end if;
- 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;
+ return False;
+ end Is_Less_Than;
- else
- return GreaterThan;
- end if;
+ ------------------
+ -- Is_Less_Than --
+ ------------------
- else
- return GreaterThan;
- end if;
- end Compare;
+ function Is_Less_Than (Decl1, Decl2 : Declaration_Reference) return Boolean
+ is
+ -- We cannot store the data case-insensitive in the table,
+ -- since we wouldn't be able to find the right casing for the
+ -- display later on.
- -------------
- -- Compare --
- -------------
+ S1 : constant String := To_Lower (Decl1.Symbol);
+ S2 : constant String := To_Lower (Decl2.Symbol);
- 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;
+ if S1 < S2 then
+ return True;
+ elsif S1 > S2 then
+ return False;
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;
+ return Decl1.Key.all < Decl2.Key.all;
+ end Is_Less_Than;
-------------------------
-- Create_Project_File --
-------------------------
- procedure Create_Project_File
- (Name : String)
- is
- use Ada.Strings.Unbounded;
-
+ procedure Create_Project_File (Name : String) is
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;
+ Build_Dir : GNAT.OS_Lib.String_Access := new String'("");
F : File_Descriptor;
Len : Positive;
File_Name : aliased String := Name & ASCII.NUL;
begin
-
-- Read the size of the file
+
F := Open_Read (File_Name'Address, Text);
-- Project file not found
+
if F /= Invalid_FD then
Len := Positive (File_Length (F));
Buffer : String (1 .. Len);
Index : Positive := Buffer'First;
Last : Positive;
+
begin
Len := Read (F, Buffer'Address, Len);
Close (F);
while Index <= Buffer'Last loop
- -- find the end of line
+ -- Find the end of line
Last := Index;
while Last <= Buffer'Last
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;
+ Free (Build_Dir);
+ Build_Dir := new String'(Buffer (Index .. Last - 1));
end if;
Index := Last + 1;
Index := Buffer'First;
while Index <= Buffer'Last loop
- -- find the end of line
+ -- Find the end of line
Last := Index;
while Last <= Buffer'Last
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;
+ Append (Src_Dir, Normalize_Pathname
+ (Name => Ada.Strings.Fixed.Trim
+ (Buffer (Index + 8 .. Last - 1), Ada.Strings.Both),
+ Directory => Build_Dir.all) & Path_Separator);
elsif Index <= Buffer'Last - 7
and then Buffer (Index .. Index + 7) = "obj_dir="
then
- 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;
+ Append (Obj_Dir, Normalize_Pathname
+ (Name => Ada.Strings.Fixed.Trim
+ (Buffer (Index + 8 .. Last - 1), Ada.Strings.Both),
+ Directory => Build_Dir.all) & Path_Separator);
end if;
-- In case we had a ASCII.CR/ASCII.LF end of line, skip the
end;
end if;
- Parse_Gnatls (Gnatls_Src_Cache, Gnatls_Obj_Cache);
+ Osint.Add_Default_Search_Dirs;
- 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);
+ declare
+ Src : constant String := Parse_Gnatls_Src;
+ Obj : constant String := Parse_Gnatls_Obj;
+
+ begin
+ Directories := new Project_File'
+ (Src_Dir_Length => Length (Src_Dir) + Src'Length,
+ Obj_Dir_Length => Length (Obj_Dir) + Obj'Length,
+ Src_Dir => To_String (Src_Dir) & Src,
+ Obj_Dir => To_String (Obj_Dir) & Obj,
+ Src_Dir_Index => 1,
+ Obj_Dir_Index => 1,
+ Last_Obj_Dir_Start => 0);
+ end;
+
+ Free (Build_Dir);
end Create_Project_File;
---------------------
function Current_Obj_Dir return String is
begin
- return Directories.Obj_Dir (Directories.Last_Obj_Dir_Start
- .. Directories.Obj_Dir_Index - 2);
+ 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 --
----------------
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;
+ Key : aliased constant String := Key_From_Ref (File_Ref, Line, Column);
- return Empty_Declaration;
+ begin
+ return Entities_HTable.Get (Key'Unchecked_Access);
end Get_Declaration;
----------------------
function Get_File
(Decl : Declaration_Reference;
- With_Dir : Boolean := False)
- return String
+ With_Dir : Boolean := False) return String
is
begin
return Get_File (Decl.Decl.File, With_Dir);
function Get_File
(Ref : Reference;
- With_Dir : Boolean := False)
- return String
+ With_Dir : Boolean := False) return String
is
begin
return Get_File (Ref.File, With_Dir);
function Get_File
(File : File_Reference;
- With_Dir : in Boolean := False;
- Strip : Natural := 0)
- return String
+ With_Dir : Boolean := False;
+ Strip : Natural := 0) return String
is
+ Tmp : GNAT.OS_Lib.String_Access;
+
function Internal_Strip (Full_Name : String) return String;
-- Internal function to process the Strip parameter
--------------------
function Internal_Strip (Full_Name : String) return String is
- Unit_End, Extension_Start : Natural;
- S : Natural := Strip;
+ Unit_End : Natural;
+ Extension_Start : Natural;
+ S : Natural;
+
begin
if Strip = 0 then
return Full_Name;
-- Strip the right number of subunit_names
+ S := Strip;
Unit_End := Extension_Start - 1;
while Unit_End >= Full_Name'First
and then S > 0
if Full_Name (Unit_End) = '-' then
S := S - 1;
end if;
+
Unit_End := Unit_End - 1;
end loop;
end if;
end Internal_Strip;
+ -- Start of processing for Get_File;
+
begin
-- If we do not want the full path name
if not With_Dir then
- return Internal_Strip (File.File);
+ return Internal_Strip (File.File.all);
end if;
if File.Dir = null then
+ if Ada.Strings.Fixed.Tail (File.File.all, 3) =
+ Osint.ALI_Suffix.all
+ then
+ Tmp := Locate_Regular_File
+ (Internal_Strip (File.File.all), Directories.Obj_Dir);
+ else
+ Tmp := Locate_Regular_File
+ (File.File.all, Directories.Src_Dir);
+ end if;
- if Ada.Strings.Fixed.Tail (File.File, 3) = "ali" then
- File.Dir := new String'(Find_ALI_File (File.File));
+ if Tmp = null then
+ File.Dir := new String'("");
else
- File.Dir := new String'(Find_Source_File (File.File));
+ File.Dir := new String'(Dir_Name (Tmp.all));
+ Free (Tmp);
end if;
end if;
- return Internal_Strip (File.Dir.all & File.File);
+ return Internal_Strip (File.Dir.all & File.File.all);
end Get_File;
------------------
-----------------------
function Get_Gnatchop_File
- (File : File_Reference; With_Dir : Boolean := False) return String is
+ (File : File_Reference;
+ With_Dir : Boolean := False)
+ return String
+ is
begin
if File.Gnatchop_File.all = "" then
return Get_File (File, With_Dir);
end if;
end Get_Gnatchop_File;
- -----------------------
- -- Get_Gnatchop_File --
- -----------------------
-
function Get_Gnatchop_File
- (Ref : Reference; With_Dir : Boolean := False) return String is
+ (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
+ (Decl : Declaration_Reference;
+ With_Dir : Boolean := False)
+ return String
is
begin
return Get_Gnatchop_File (Decl.Decl.File, With_Dir);
function Get_Parent
(Decl : Declaration_Reference)
- return Declaration_Reference is
+ return Declaration_Reference
+ is
begin
return Decl.Par_Symbol;
end Get_Parent;
function Get_Source_Line (Ref : Reference) return String is
begin
- return To_String (Ref.Source_Line);
+ if Ref.Source_Line /= null then
+ return Ref.Source_Line.all;
+ else
+ return "";
+ end if;
end Get_Source_Line;
function Get_Source_Line (Decl : Declaration_Reference) return String is
begin
- return To_String (Decl.Decl.Source_Line);
+ if Decl.Decl.Source_Line /= null then
+ return Decl.Decl.Source_Line.all;
+ else
+ return "";
+ end if;
end Get_Source_Line;
----------------
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 avoiding
- -- parsing 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;
+ ----------
+ -- Sort --
+ ----------
- begin
- while List /= null loop
+ procedure Sort (Arr : in out Reference_Array) is
+ Tmp : Reference;
- -- Makes sure we can find and read the file
+ function Lt (Op1, Op2 : Natural) return Boolean;
+ procedure Move (From, To : Natural);
+ -- See GNAT.Heap_Sort_G
- Current_File := List.Ref.File;
- Line_Number := 0;
+ --------
+ -- Lt --
+ --------
- begin
- Ada.Text_IO.Open (File,
- Ada.Text_IO.In_File,
- Get_File (List.Ref, True));
+ function Lt (Op1, Op2 : Natural) return Boolean is
+ begin
+ if Op1 = 0 then
+ return Is_Less_Than (Tmp, Arr (Op2));
+ elsif Op2 = 0 then
+ return Is_Less_Than (Arr (Op1), Tmp);
+ else
+ return Is_Less_Than (Arr (Op1), Arr (Op2));
+ end if;
+ end Lt;
- -- Read the file and find every relevant lines
+ ----------
+ -- Move --
+ ----------
- 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;
+ procedure Move (From, To : Natural) is
+ begin
+ if To = 0 then
+ Tmp := Arr (From);
+ elsif From = 0 then
+ Arr (To) := Tmp;
+ else
+ Arr (To) := Arr (From);
+ end if;
+ end Move;
- while List /= null
- and then Line_Number = List.Ref.Line
- loop
+ package Ref_Sort is new GNAT.Heap_Sort_G (Move, Lt);
- -- Skip the leading blanks on the line
+ -- Start of processing for Sort
- Pos := 1;
- while Line (Pos) = ' '
- or else Line (Pos) = ASCII.HT
- loop
- Pos := Pos + 1;
- end loop;
+ begin
+ Ref_Sort.Sort (Arr'Last);
+ end Sort;
- List.Ref.Source_Line :=
- To_Unbounded_String (Line (Pos .. Last));
+ -----------------------
+ -- Grep_Source_Files --
+ -----------------------
- -- Find the next element in the list
+ procedure Grep_Source_Files is
+ Length : Natural := 0;
+ Decl : Declaration_Reference := Entities_HTable.Get_First;
+ Arr : Reference_Array_Access;
+ Index : Natural;
+ End_Index : Natural;
+ Current_File : File_Reference;
+ Current_Line : Cst_String_Access;
+ Buffer : GNAT.OS_Lib.String_Access;
+ Ref : Reference;
+ Line : Natural;
- List := List.Next;
- end loop;
+ begin
+ -- Create a temporary array, where all references will be
+ -- sorted by files. This way, we only have to read the source
+ -- files once.
- end loop;
+ while Decl /= null loop
- Ada.Text_IO.Close (File);
+ -- Add 1 for the declaration itself
- -- If the Current_File was not found, just skip it
+ Length := Length + References_Count (Decl, True, True, True) + 1;
+ Decl := Entities_HTable.Get_Next;
+ end loop;
- exception
- when Ada.IO_Exceptions.Name_Error =>
- null;
- end;
+ Arr := new Reference_Array (1 .. Length);
+ Index := Arr'First;
- -- If the line or the file were not found
+ Decl := Entities_HTable.Get_First;
+ while Decl /= null loop
+ Store_References (Decl, True, True, True, True, Arr.all, Index);
+ Decl := Entities_HTable.Get_Next;
+ end loop;
- while List /= null
- and then List.Ref.File = Current_File
- loop
- List := List.Next;
- end loop;
+ Sort (Arr.all);
- end loop;
+ -- Now traverse the whole array and find the appropriate source
+ -- lines.
- -- Clear the list
+ for R in Arr'Range loop
+ Ref := Arr (R);
- while Save_List /= null loop
- List := Save_List;
- Save_List := Save_List.Next;
- Free (List);
- end loop;
- end Grep_List;
+ if Ref.File /= Current_File then
+ Free (Buffer);
+ begin
+ Read_File (Get_File (Ref.File, With_Dir => True), Buffer);
+ End_Index := Buffer'First - 1;
+ Line := 0;
+ exception
+ when Ada.Text_IO.Name_Error | Ada.Text_IO.End_Error =>
+ Line := Natural'Last;
+ end;
+ Current_File := Ref.File;
+ end if;
- ---------------------
- -- Insert_In_Order --
- ---------------------
+ if Ref.Line > Line then
- procedure Insert_In_Order (Ref : Reference) is
- Iter : Simple_Ref_Access := List;
- Prev : Simple_Ref_Access := null;
+ -- Do not free Current_Line, it is referenced by the last
+ -- Ref we processed.
- begin
- while Iter /= null loop
+ loop
+ Index := End_Index + 1;
- -- If we have found the file, sort by lines
+ loop
+ End_Index := End_Index + 1;
+ exit when End_Index > Buffer'Last
+ or else Buffer (End_Index) = ASCII.LF;
+ end loop;
- if Iter.Ref.File = Ref.File then
+ -- Skip spaces at beginning of line
- while Iter /= null
- and then Iter.Ref.File = Ref.File
+ while Index < End_Index and then
+ (Buffer (Index) = ' ' or else Buffer (Index) = ASCII.HT)
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;
+ Index := Index + 1;
end loop;
- if Iter = List then
- List := new Simple_Ref'(Ref, List);
- else
- Prev.Next := new Simple_Ref'(Ref, Iter);
- end if;
+ Line := Line + 1;
+ exit when Ref.Line = Line;
+ end loop;
- return;
- end if;
+ Current_Line := new String'(Buffer (Index .. End_Index - 1));
+ end if;
- Prev := Iter;
- Iter := Iter.Next;
- end loop;
+ Ref.Source_Line := Current_Line;
+ end loop;
- -- The file was not already in the list, insert it
+ Free (Buffer);
+ Free (Arr);
+ end Grep_Source_Files;
- List := new Simple_Ref'(Ref, List);
- end Insert_In_Order;
+ ---------------
+ -- Read_File --
+ ---------------
- ---------------------
- -- Insert_List_Ref --
- ---------------------
+ procedure Read_File
+ (File_Name : String;
+ Contents : out GNAT.OS_Lib.String_Access)
+ is
+ Name_0 : constant String := File_Name & ASCII.NUL;
+ FD : constant File_Descriptor := Open_Read (Name_0'Address, Binary);
+ Length : Natural;
+
+ begin
+ if FD = Invalid_FD then
+ raise Ada.Text_IO.Name_Error;
+ end if;
- procedure Insert_List_Ref (First_Ref : Reference) is
- Ref : Reference := First_Ref;
+ -- Include room for EOF char
+
+ Length := Natural (File_Length (FD));
+
+ declare
+ Buffer : String (1 .. Length + 1);
+ This_Read : Integer;
+ Read_Ptr : Natural := 1;
begin
- while Ref /= Empty_Reference loop
- Insert_In_Order (Ref);
- Ref := Next (Ref);
+ loop
+ This_Read := Read (FD,
+ A => Buffer (Read_Ptr)'Address,
+ N => Length + 1 - Read_Ptr);
+ Read_Ptr := Read_Ptr + Integer'Max (This_Read, 0);
+ exit when This_Read <= 0;
end loop;
- end Insert_List_Ref;
- -- Start of processing for Grep_Source_Files
+ Buffer (Read_Ptr) := EOF;
+ Contents := new String'(Buffer (1 .. Read_Ptr));
- 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;
+ -- Things are not simple on VMS due to the plethora of file types
+ -- and organizations. It seems clear that there shouldn't be more
+ -- bytes read than are contained in the file though.
- Grep_List;
- end Grep_Source_Files;
+ if (Hostparm.OpenVMS and then Read_Ptr > Length + 1)
+ or else (not Hostparm.OpenVMS and then Read_Ptr /= Length + 1)
+ then
+ raise Ada.Text_IO.End_Error;
+ end if;
+
+ Close (FD);
+ end;
+ end Read_File;
-----------------------
-- Longest_File_Name --
function Longest_File_Name return Natural is
begin
- return Files.Longest_Name;
+ return Longest_File_Name_In_Table;
end Longest_File_Name;
-----------
-- Next --
----------
- function Next (Decl : Declaration_Reference) return Declaration_Reference is
+ function Next (E : File_Reference) return File_Reference is
begin
- return Decl.Next;
+ return E.Next;
end Next;
- ----------
- -- Next --
- ----------
-
- function Next (Ref : Reference) return Reference is
+ function Next (E : Declaration_Reference) return Declaration_Reference is
begin
- return Ref.Next;
+ return E.Next;
end Next;
------------------
------------------
function Next_Obj_Dir return String is
- First : Integer := Directories.Obj_Dir_Index;
- Last : Integer := Directories.Obj_Dir_Index;
+ First : constant Integer := Directories.Obj_Dir_Index;
+ Last : Integer;
begin
+ Last := Directories.Obj_Dir_Index;
+
if Last > Directories.Obj_Dir_Length then
return String'(1 .. 0 => ' ');
end if;
- while Directories.Obj_Dir (Last) /= ' ' loop
+ while Directories.Obj_Dir (Last) /= Path_Separator loop
Last := Last + 1;
end loop;
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;
+ procedure Unchecked_Free is new Ada.Unchecked_Deallocation
+ (Unvisited_Files_Record, Unvisited_Files_Access);
- begin
- while The_Files /= null loop
- if not The_Files.Visited then
- The_Files.Visited := True;
- return The_Files;
- end if;
+ Ref : File_Reference;
+ Tmp : Unvisited_Files_Access;
- The_Files := The_Files.Next;
- end loop;
-
- return Empty_File;
+ begin
+ if Unvisited_Files = null then
+ return Empty_File;
+ else
+ Tmp := Unvisited_Files;
+ Ref := Unvisited_Files.File;
+ Unvisited_Files := Unvisited_Files.Next;
+ Unchecked_Free (Tmp);
+ return Ref;
+ end if;
end Next_Unvisited_File;
- ------------------
- -- Parse_Gnatls --
- ------------------
+ ----------------------
+ -- Parse_Gnatls_Src --
+ ----------------------
- 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;
+ function Parse_Gnatls_Src return String is
+ Length : Natural;
+ begin
+ Length := 0;
for J in 1 .. Osint.Nb_Dir_In_Src_Search_Path loop
if Osint.Dir_In_Src_Search_Path (J)'Length = 0 then
- Ada.Strings.Unbounded.Append (Gnatls_Src_Cache, "./" & ' ');
+ Length := Length + 2;
else
- Ada.Strings.Unbounded.Append
- (Gnatls_Src_Cache, Osint.Dir_In_Src_Search_Path (J).all & ' ');
+ Length := Length + Osint.Dir_In_Src_Search_Path (J)'Length + 1;
end if;
end loop;
+ declare
+ Result : String (1 .. Length);
+ L : Natural;
+
+ begin
+ L := Result'First;
+ for J in 1 .. Osint.Nb_Dir_In_Src_Search_Path loop
+ if Osint.Dir_In_Src_Search_Path (J)'Length = 0 then
+ Result (L .. L + 1) := "." & Path_Separator;
+ L := L + 2;
+
+ else
+ Result (L .. L + Osint.Dir_In_Src_Search_Path (J)'Length - 1) :=
+ Osint.Dir_In_Src_Search_Path (J).all;
+ L := L + Osint.Dir_In_Src_Search_Path (J)'Length;
+ Result (L) := Path_Separator;
+ L := L + 1;
+ end if;
+ end loop;
+
+ return Result;
+ end;
+ end Parse_Gnatls_Src;
+
+ ----------------------
+ -- Parse_Gnatls_Obj --
+ ----------------------
+
+ function Parse_Gnatls_Obj return String is
+ Length : Natural;
+
+ begin
+ Length := 0;
for J in 1 .. Osint.Nb_Dir_In_Obj_Search_Path loop
if Osint.Dir_In_Obj_Search_Path (J)'Length = 0 then
- Ada.Strings.Unbounded.Append (Gnatls_Obj_Cache, "./" & ' ');
+ Length := Length + 2;
else
- Ada.Strings.Unbounded.Append
- (Gnatls_Obj_Cache, Osint.Dir_In_Obj_Search_Path (J).all & ' ');
+ Length := Length + Osint.Dir_In_Obj_Search_Path (J)'Length + 1;
end if;
end loop;
- end Parse_Gnatls;
+
+ declare
+ Result : String (1 .. Length);
+ L : Natural;
+
+ begin
+ L := Result'First;
+ for J in 1 .. Osint.Nb_Dir_In_Obj_Search_Path loop
+ if Osint.Dir_In_Obj_Search_Path (J)'Length = 0 then
+ Result (L .. L + 1) := "." & Path_Separator;
+ L := L + 2;
+ else
+ Result (L .. L + Osint.Dir_In_Obj_Search_Path (J)'Length - 1) :=
+ Osint.Dir_In_Obj_Search_Path (J).all;
+ L := L + Osint.Dir_In_Obj_Search_Path (J)'Length;
+ Result (L) := Path_Separator;
+ L := L + 1;
+ end if;
+ end loop;
+
+ return Result;
+ end;
+ end Parse_Gnatls_Obj;
-------------------
-- Reset_Obj_Dir --
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 --
-----------------------
Default_Match := Value;
end Set_Default_Match;
- -------------------
- -- Set_Directory --
- -------------------
+ ----------
+ -- Free --
+ ----------
- procedure Set_Directory
- (File : in File_Reference;
- Dir : in String)
- is
+ procedure Free (Str : in out Cst_String_Access) is
+ function Convert is new Ada.Unchecked_Conversion
+ (Cst_String_Access, GNAT.OS_Lib.String_Access);
+
+ S : GNAT.OS_Lib.String_Access := Convert (Str);
+
+ begin
+ Free (S);
+ Str := null;
+ end Free;
+
+ ---------------------
+ -- Reset_Directory --
+ ---------------------
+
+ procedure Reset_Directory (File : File_Reference) is
begin
- File.Dir := new String'(Dir);
- end Set_Directory;
+ Free (File.Dir);
+ end Reset_Directory;
-------------------
-- Set_Unvisited --
-------------------
- procedure Set_Unvisited (File_Ref : in File_Reference) is
- The_Files : File_Reference := Files.Table;
+ procedure Set_Unvisited (File_Ref : File_Reference) is
+ F : constant String := Get_File (File_Ref, With_Dir => False);
begin
- while The_Files /= null loop
- if The_Files = File_Ref then
- The_Files.Visited := False;
- return;
+ File_Ref.Visited := False;
+
+ -- ??? Do not add a source file to the list. This is true at
+ -- least for gnatxref, and probably for gnatfind as well
+
+ if F'Length > 4
+ and then F (F'Last - 3 .. F'Last) = "." & Osint.ALI_Suffix.all
+ then
+ Unvisited_Files := new Unvisited_Files_Record'
+ (File => File_Ref,
+ Next => Unvisited_Files);
+ end if;
+ end Set_Unvisited;
+
+ ----------------------
+ -- Get_Declarations --
+ ----------------------
+
+ function Get_Declarations
+ (Sorted : Boolean := True)
+ return Declaration_Array_Access
+ is
+ Arr : constant Declaration_Array_Access :=
+ new Declaration_Array (1 .. Entities_Count);
+ Decl : Declaration_Reference := Entities_HTable.Get_First;
+ Index : Natural := Arr'First;
+ Tmp : Declaration_Reference;
+
+ procedure Move (From : Natural; To : Natural);
+ function Lt (Op1, Op2 : Natural) return Boolean;
+ -- See GNAT.Heap_Sort_G
+
+ --------
+ -- Lt --
+ --------
+
+ function Lt (Op1, Op2 : Natural) return Boolean is
+ begin
+ if Op1 = 0 then
+ return Is_Less_Than (Tmp, Arr (Op2));
+ elsif Op2 = 0 then
+ return Is_Less_Than (Arr (Op1), Tmp);
+ else
+ return Is_Less_Than (Arr (Op1), Arr (Op2));
+ end if;
+ end Lt;
+
+ ----------
+ -- Move --
+ ----------
+
+ procedure Move (From : Natural; To : Natural) is
+ begin
+ if To = 0 then
+ Tmp := Arr (From);
+ elsif From = 0 then
+ Arr (To) := Tmp;
+ else
+ Arr (To) := Arr (From);
end if;
+ end Move;
+
+ package Decl_Sort is new GNAT.Heap_Sort_G (Move, Lt);
- The_Files := The_Files.Next;
+ -- Start of processing for Get_Declarations
+
+ begin
+ while Decl /= null loop
+ Arr (Index) := Decl;
+ Index := Index + 1;
+ Decl := Entities_HTable.Get_Next;
end loop;
- end Set_Unvisited;
+
+ if Sorted and then Arr'Length /= 0 then
+ Decl_Sort.Sort (Entities_Count);
+ end if;
+
+ return Arr;
+ end Get_Declarations;
+
+ ----------------------
+ -- References_Count --
+ ----------------------
+
+ function References_Count
+ (Decl : Declaration_Reference;
+ Get_Reads : Boolean := False;
+ Get_Writes : Boolean := False;
+ Get_Bodies : Boolean := False)
+ return Natural
+ is
+ function List_Length (E : Reference) return Natural;
+ -- Return the number of references in E
+
+ -----------------
+ -- List_Length --
+ -----------------
+
+ function List_Length (E : Reference) return Natural is
+ L : Natural := 0;
+ E1 : Reference := E;
+
+ begin
+ while E1 /= null loop
+ L := L + 1;
+ E1 := E1.Next;
+ end loop;
+
+ return L;
+ end List_Length;
+
+ Length : Natural := 0;
+
+ -- Start of processing for References_Count
+
+ begin
+ if Get_Reads then
+ Length := List_Length (Decl.Ref_Ref);
+ end if;
+
+ if Get_Writes then
+ Length := Length + List_Length (Decl.Modif_Ref);
+ end if;
+
+ if Get_Bodies then
+ Length := Length + List_Length (Decl.Body_Ref);
+ end if;
+
+ return Length;
+ end References_Count;
+
+ ----------------------
+ -- Store_References --
+ ----------------------
+
+ procedure Store_References
+ (Decl : Declaration_Reference;
+ Get_Writes : Boolean := False;
+ Get_Reads : Boolean := False;
+ Get_Bodies : Boolean := False;
+ Get_Declaration : Boolean := False;
+ Arr : in out Reference_Array;
+ Index : in out Natural)
+ is
+ procedure Add (List : Reference);
+ -- Add all the references in List to Arr
+
+ ---------
+ -- Add --
+ ---------
+
+ procedure Add (List : Reference) is
+ E : Reference := List;
+ begin
+ while E /= null loop
+ Arr (Index) := E;
+ Index := Index + 1;
+ E := E.Next;
+ end loop;
+ end Add;
+
+ -- Start of processing for Store_References
+
+ begin
+ if Get_Declaration then
+ Add (Decl.Decl);
+ end if;
+
+ if Get_Reads then
+ Add (Decl.Ref_Ref);
+ end if;
+
+ if Get_Writes then
+ Add (Decl.Modif_Ref);
+ end if;
+
+ if Get_Bodies then
+ Add (Decl.Body_Ref);
+ end if;
+ end Store_References;
+
+ --------------------
+ -- Get_References --
+ --------------------
+
+ function Get_References
+ (Decl : Declaration_Reference;
+ Get_Reads : Boolean := False;
+ Get_Writes : Boolean := False;
+ Get_Bodies : Boolean := False)
+ return Reference_Array_Access
+ is
+ Length : constant Natural :=
+ References_Count (Decl, Get_Reads, Get_Writes, Get_Bodies);
+
+ Arr : constant Reference_Array_Access :=
+ new Reference_Array (1 .. Length);
+
+ Index : Natural := Arr'First;
+
+ begin
+ Store_References
+ (Decl => Decl,
+ Get_Writes => Get_Writes,
+ Get_Reads => Get_Reads,
+ Get_Bodies => Get_Bodies,
+ Get_Declaration => False,
+ Arr => Arr.all,
+ Index => Index);
+
+ if Arr'Length /= 0 then
+ Sort (Arr.all);
+ end if;
+
+ return Arr;
+ end Get_References;
+
+ ----------
+ -- Free --
+ ----------
+
+ procedure Free (Arr : in out Reference_Array_Access) is
+ procedure Internal is new Ada.Unchecked_Deallocation
+ (Reference_Array, Reference_Array_Access);
+ begin
+ Internal (Arr);
+ end Free;
+
+ ------------------
+ -- Is_Parameter --
+ ------------------
+
+ function Is_Parameter (Decl : Declaration_Reference) return Boolean is
+ begin
+ return Decl.Is_Parameter;
+ end Is_Parameter;
end Xr_Tabls;
OSDN Git Service
