diff options
Diffstat (limited to 'gcc/ada/xr_tabls.adb')
| -rw-r--r-- | gcc/ada/xr_tabls.adb | 1702 |
1 files changed, 973 insertions, 729 deletions
diff --git a/gcc/ada/xr_tabls.adb b/gcc/ada/xr_tabls.adb index 93be4f86900..8e332ec6276 100644 --- a/gcc/ada/xr_tabls.adb +++ b/gcc/ada/xr_tabls.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1998-2002 Free Software Foundation, Inc. -- +-- Copyright (C) 1998-2003 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- -- @@ -19,105 +19,284 @@ -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- -- MA 02111-1307, USA. -- -- -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- 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 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 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 "") + 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; - Dir_Sep : Character renames GNAT.OS_Lib.Directory_Separator; + ----------- + -- Equal -- + ----------- - Files : File_Table; - Entities : Entity_Table; - Directories : Project_File_Ptr; - Default_Match : Boolean := False; + 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) - 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; @@ -127,52 +306,46 @@ package body Xr_Tabls is -- 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; + -- Keep a separate list for faster access - The_Files := The_Files.Next; - end loop; - - Ref := new File_Record' - (File_Length => Base'Length, - File => Base, - Dir => Dir_Acc, - Lines => null, - Visited => Visited, - Emit_Warning => Emit_Warning, - Gnatchop_File => new String' (Gnatchop_File), - Gnatchop_Offset => Gnatchop_Offset, - Next => Files.Table); - Files.Table := Ref; - File_Existed := False; + Set_Unvisited (Ref); + end if; + end if; + return Ref; end Add_To_Xref_File; -------------- @@ -202,21 +375,11 @@ package body Xr_Tabls is 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; ------------------- @@ -224,37 +387,55 @@ package body Xr_Tabls is ------------------- 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' | 'm' | 'r' | '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 => 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 => @@ -262,53 +443,43 @@ package body Xr_Tabls is 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 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. - 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' | 'i' | 'l' | ' ' | '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; @@ -317,150 +488,91 @@ package body Xr_Tabls is ------------------- 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"; + return Ada_File_Name (Ada_File_Name'First .. Index) & "ali"; else return Ada_File_Name & ".ali"; end if; end ALI_File_Name; - -------------------- - -- Base_File_Name -- - -------------------- - - function Base_File_Name (File : String) return String is - begin - for J in reverse File'Range loop - if File (J) = '/' or else File (J) = Dir_Sep then - return File (J + 1 .. File'Last); - end if; - end loop; - - return File; - end Base_File_Name; - - ------------- - -- Compare -- - ------------- + ------------------ + -- 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; + if S1 < S2 then + return True; + elsif S1 > S2 then + return False; end if; - if Decl1.Symbol < Symb2 then - return LessThan; - elsif Decl1.Symbol > Symb2 then - return GreaterThan; - end if; - - if Decl1.Decl.File.File < Get_File (File2) then - return LessThan; - - elsif Decl1.Decl.File.File = Get_File (File2) then - if Decl1.Decl.Line < Line2 then - return LessThan; - - elsif Decl1.Decl.Line = Line2 then - if Decl1.Decl.Column < Col2 then - return LessThan; - - elsif Decl1.Decl.Column = Col2 then - return Equal; - - else - return GreaterThan; - end if; - - else - return GreaterThan; - end if; - - else - return GreaterThan; - end if; - end Compare; + return Decl1.Key.all < Decl2.Key.all; + end Is_Less_Than; ------------------------- -- Create_Project_File -- ------------------------- - procedure Create_Project_File - (Name : String) - is + procedure Create_Project_File (Name : String) is use Ada.Strings.Unbounded; Obj_Dir : Unbounded_String := Null_Unbounded_String; Src_Dir : Unbounded_String := Null_Unbounded_String; - Build_Dir : Unbounded_String; - - Gnatls_Src_Cache : Unbounded_String; - Gnatls_Obj_Cache : Unbounded_String; + 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)); @@ -468,6 +580,7 @@ package body Xr_Tabls is Buffer : String (1 .. Len); Index : Positive := Buffer'First; Last : Positive; + begin Len := Read (F, Buffer'Address, Len); Close (F); @@ -477,7 +590,7 @@ package body Xr_Tabls is while Index <= Buffer'Last loop - -- find the end of line + -- Find the end of line Last := Index; while Last <= Buffer'Last @@ -498,11 +611,8 @@ package body Xr_Tabls is 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; @@ -522,7 +632,7 @@ package body Xr_Tabls is Index := Buffer'First; while Index <= Buffer'Last loop - -- find the end of line + -- Find the end of line Last := Index; while Last <= Buffer'Last @@ -535,40 +645,18 @@ package body Xr_Tabls is 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 @@ -584,16 +672,24 @@ package body Xr_Tabls is 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; --------------------- @@ -602,137 +698,10 @@ package body Xr_Tabls is 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, "__gnat_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 -- ---------------- @@ -759,20 +728,10 @@ package body Xr_Tabls is 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; ---------------------- @@ -809,9 +768,11 @@ package body Xr_Tabls is function Get_File (File : File_Reference; With_Dir : in Boolean := False; - Strip : Natural := 0) + 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 @@ -820,8 +781,10 @@ package body Xr_Tabls is -------------------- 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; @@ -838,6 +801,7 @@ package body Xr_Tabls is -- Strip the right number of subunit_names + S := Strip; Unit_End := Extension_Start - 1; while Unit_End >= Full_Name'First and then S > 0 @@ -845,6 +809,7 @@ package body Xr_Tabls is if Full_Name (Unit_End) = '-' then S := S - 1; end if; + Unit_End := Unit_End - 1; end loop; @@ -856,23 +821,33 @@ package body Xr_Tabls is 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) = "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 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; ------------------ @@ -889,7 +864,10 @@ package body Xr_Tabls is ----------------------- 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); @@ -898,22 +876,19 @@ package body Xr_Tabls is 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); @@ -941,7 +916,8 @@ package body Xr_Tabls is function Get_Parent (Decl : Declaration_Reference) - return Declaration_Reference is + return Declaration_Reference + is begin return Decl.Par_Symbol; end Get_Parent; @@ -952,12 +928,20 @@ package body Xr_Tabls is 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; ---------------- @@ -978,202 +962,201 @@ package body Xr_Tabls is 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; - procedure Insert_List_Ref (First_Ref : Reference) is - Ref : Reference := First_Ref; + 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 - 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 -- @@ -1181,7 +1164,7 @@ package body Xr_Tabls is function Longest_File_Name return Natural is begin - return Files.Longest_Name; + return Longest_File_Name_In_Table; end Longest_File_Name; ----------- @@ -1223,18 +1206,14 @@ package body Xr_Tabls is -- 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; ------------------ @@ -1242,15 +1221,17 @@ package body Xr_Tabls is ------------------ 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; @@ -1259,76 +1240,109 @@ package body Xr_Tabls is return Directories.Obj_Dir (First .. Last - 1); end Next_Obj_Dir; - ------------------ - -- Next_Src_Dir -- - ------------------ - - function Next_Src_Dir return String is - First : Integer := Directories.Src_Dir_Index; - Last : Integer := Directories.Src_Dir_Index; - - begin - if Last > Directories.Src_Dir_Length then - return String'(1 .. 0 => ' '); - end if; - - while Directories.Src_Dir (Last) /= ' ' loop - Last := Last + 1; - end loop; - - Directories.Src_Dir_Index := Last + 1; - return Directories.Src_Dir (First .. Last - 1); - end Next_Src_Dir; - ------------------------- -- Next_Unvisited_File -- ------------------------- function Next_Unvisited_File return File_Reference is - The_Files : File_Reference := Files.Table; - - begin - while The_Files /= null loop - if not The_Files.Visited then - The_Files.Visited := True; - return The_Files; - end if; + procedure Unchecked_Free is new Ada.Unchecked_Deallocation + (Unvisited_Files_Record, Unvisited_Files_Access); - The_Files := The_Files.Next; - end loop; + Ref : File_Reference; + Tmp : Unvisited_Files_Access; - 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 -- @@ -1339,15 +1353,6 @@ package body Xr_Tabls is 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 -- ----------------------- @@ -1357,34 +1362,273 @@ package body Xr_Tabls is 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 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 : 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; |