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