1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1998-2019, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 with Types; use Types;
29 with Ada.Unchecked_Conversion;
30 with Ada.Unchecked_Deallocation;
31 with Ada.Strings.Fixed;
34 with Ada.Characters.Handling; use Ada.Characters.Handling;
35 with Ada.Strings.Unbounded; use Ada.Strings.Unbounded;
37 with GNAT.OS_Lib; use GNAT.OS_Lib;
38 with GNAT.Directory_Operations; use GNAT.Directory_Operations;
40 with GNAT.Heap_Sort_G;
42 package body Xr_Tabls is
44 type HTable_Headers is range 1 .. 10000;
46 procedure Set_Next (E : File_Reference; Next : File_Reference);
47 function Next (E : File_Reference) return File_Reference;
48 function Get_Key (E : File_Reference) return Cst_String_Access;
49 function Hash (F : Cst_String_Access) return HTable_Headers;
50 function Equal (F1, F2 : Cst_String_Access) return Boolean;
51 -- The five subprograms above are used to instantiate the static
52 -- htable to store the files that should be processed.
54 package File_HTable is new GNAT.HTable.Static_HTable
55 (Header_Num => HTable_Headers,
56 Element => File_Record,
57 Elmt_Ptr => File_Reference,
61 Key => Cst_String_Access,
65 -- A hash table to store all the files referenced in the
66 -- application. The keys in this htable are the name of the files
67 -- themselves, therefore it is assumed that the source path
68 -- doesn't contain twice the same source or ALI file name
70 type Unvisited_Files_Record;
71 type Unvisited_Files_Access is access Unvisited_Files_Record;
72 type Unvisited_Files_Record is record
73 File : File_Reference;
74 Next : Unvisited_Files_Access;
76 -- A special list, in addition to File_HTable, that only stores
77 -- the files that haven't been visited so far. Note that the File
78 -- list points to some data in File_HTable, and thus should never be freed.
80 function Next (E : Declaration_Reference) return Declaration_Reference;
81 procedure Set_Next (E, Next : Declaration_Reference);
82 function Get_Key (E : Declaration_Reference) return Cst_String_Access;
83 -- The subprograms above are used to instantiate the static
84 -- htable to store the entities that have been found in the application
86 package Entities_HTable is new GNAT.HTable.Static_HTable
87 (Header_Num => HTable_Headers,
88 Element => Declaration_Record,
89 Elmt_Ptr => Declaration_Reference,
93 Key => Cst_String_Access,
97 -- A hash table to store all the entities defined in the
98 -- application. For each entity, we store a list of its reference
100 -- The keys in this htable should be created with Key_From_Ref,
101 -- and are the file, line and column of the declaration, which are
102 -- unique for every entity.
104 Entities_Count : Natural := 0;
105 -- Number of entities in Entities_HTable. This is used in the end
106 -- when sorting the table.
108 Longest_File_Name_In_Table : Natural := 0;
109 Unvisited_Files : Unvisited_Files_Access := null;
110 Directories : Project_File_Ptr;
111 Default_Match : Boolean := False;
112 -- The above need commenting ???
114 function Parse_Gnatls_Src return String;
115 -- Return the standard source directories (taking into account the
116 -- ADA_INCLUDE_PATH environment variable, if Osint.Add_Default_Search_Dirs
117 -- was called first).
119 function Parse_Gnatls_Obj return String;
120 -- Return the standard object directories (taking into account the
121 -- ADA_OBJECTS_PATH environment variable).
123 function Key_From_Ref
124 (File_Ref : File_Reference;
128 -- Return a key for the symbol declared at File_Ref, Line,
129 -- Column. This key should be used for lookup in Entity_HTable
131 function Is_Less_Than (Decl1, Decl2 : Declaration_Reference) return Boolean;
132 -- Compare two declarations (the comparison is case-insensitive)
134 function Is_Less_Than (Ref1, Ref2 : Reference) return Boolean;
135 -- Compare two references
137 procedure Store_References
138 (Decl : Declaration_Reference;
139 Get_Writes : Boolean := False;
140 Get_Reads : Boolean := False;
141 Get_Bodies : Boolean := False;
142 Get_Declaration : Boolean := False;
143 Arr : in out Reference_Array;
144 Index : in out Natural);
145 -- Store in Arr, starting at Index, all the references to Decl. The Get_*
146 -- parameters can be used to indicate which references should be stored.
147 -- Constraint_Error will be raised if Arr is not big enough.
149 procedure Sort (Arr : in out Reference_Array);
150 -- Sort an array of references (Arr'First must be 1)
156 procedure Set_Next (E : File_Reference; Next : File_Reference) is
162 (E : Declaration_Reference; Next : Declaration_Reference) is
171 function Get_Key (E : File_Reference) return Cst_String_Access is
176 function Get_Key (E : Declaration_Reference) return Cst_String_Access is
185 function Hash (F : Cst_String_Access) return HTable_Headers is
186 function H is new GNAT.HTable.Hash (HTable_Headers);
196 function Equal (F1, F2 : Cst_String_Access) return Boolean is
198 return F1.all = F2.all;
205 function Key_From_Ref
206 (File_Ref : File_Reference;
212 return File_Ref.File.all & Natural'Image (Line) & Natural'Image (Column);
215 ---------------------
216 -- Add_Declaration --
217 ---------------------
219 function Add_Declaration
220 (File_Ref : File_Reference;
224 Decl_Type : Character;
225 Is_Parameter : Boolean := False;
226 Remove_Only : Boolean := False;
227 Symbol_Match : Boolean := True)
228 return Declaration_Reference
230 procedure Unchecked_Free is new Ada.Unchecked_Deallocation
231 (Declaration_Record, Declaration_Reference);
233 Key : aliased constant String := Key_From_Ref (File_Ref, Line, Column);
235 New_Decl : Declaration_Reference :=
236 Entities_HTable.Get (Key'Unchecked_Access);
238 Is_Param : Boolean := Is_Parameter;
241 -- Insert the Declaration in the table. There might already be a
242 -- declaration in the table if the entity is a parameter, so we
243 -- need to check that first.
245 if New_Decl /= null and then New_Decl.Symbol_Length = 0 then
246 Is_Param := Is_Parameter or else New_Decl.Is_Parameter;
247 Entities_HTable.Remove (Key'Unrestricted_Access);
248 Entities_Count := Entities_Count - 1;
250 Unchecked_Free (New_Decl);
254 -- The declaration might also already be there for parent types. In
255 -- this case, we should keep the entry, since some other entries are
259 and then not Remove_Only
262 new Declaration_Record'
263 (Symbol_Length => Symbol'Length,
265 Key => new String'(Key),
266 Decl => new Reference_Record'
272 Is_Parameter => Is_Param,
273 Decl_Type => Decl_Type,
277 Match => Symbol_Match
280 or else Match (File_Ref, Line, Column)),
284 Entities_HTable.Set (New_Decl);
285 Entities_Count := Entities_Count + 1;
287 if New_Decl.Match then
288 Longest_File_Name_In_Table :=
289 Natural'Max (File_Ref.File'Length, Longest_File_Name_In_Table);
292 elsif New_Decl /= null
293 and then not New_Decl.Match
295 New_Decl.Match := Default_Match
296 or else Match (File_Ref, Line, Column);
297 New_Decl.Is_Parameter := New_Decl.Is_Parameter or Is_Param;
299 elsif New_Decl /= null then
300 New_Decl.Is_Parameter := New_Decl.Is_Parameter or Is_Param;
306 ----------------------
307 -- Add_To_Xref_File --
308 ----------------------
310 function Add_To_Xref_File
312 Visited : Boolean := True;
313 Emit_Warning : Boolean := False;
314 Gnatchop_File : String := "";
315 Gnatchop_Offset : Integer := 0) return File_Reference
317 Base : aliased constant String := Base_Name (File_Name);
318 Dir : constant String := Dir_Name (File_Name);
319 Dir_Acc : GNAT.OS_Lib.String_Access := null;
320 Ref : File_Reference;
323 -- Do we have a directory name as well?
325 if File_Name /= Base then
326 Dir_Acc := new String'(Dir);
329 Ref := File_HTable.Get (Base'Unchecked_Access);
331 Ref := new File_Record'
332 (File => new String'(Base),
336 Emit_Warning => Emit_Warning,
337 Gnatchop_File => new String'(Gnatchop_File),
338 Gnatchop_Offset => Gnatchop_Offset,
340 File_HTable.Set (Ref);
344 -- Keep a separate list for faster access
350 end Add_To_Xref_File;
357 (File : File_Reference;
362 File.Lines := new Ref_In_File'(Line => Line,
372 (Declaration : in out Declaration_Reference;
376 File_Ref : File_Reference)
379 Declaration.Par_Symbol :=
381 (File_Ref, Symbol, Line, Column,
383 Symbol_Match => False);
390 procedure Add_Reference
391 (Declaration : Declaration_Reference;
392 File_Ref : File_Reference;
395 Ref_Type : Character;
396 Labels_As_Ref : Boolean)
399 New_Decl : Declaration_Reference;
400 pragma Unreferenced (New_Decl);
404 when ' ' | 'b' | 'c' | 'H' | 'i' | 'm' | 'o' | 'r' | 'R' | 's' | 'x'
409 if not Labels_As_Ref then
413 when '=' | '<' | '>' | '^' =>
415 -- Create dummy declaration in table to report it as a parameter
417 -- In a given ALI file, the declaration of the subprogram comes
418 -- before the declaration of the parameter. However, it is
419 -- possible that another ALI file has been parsed that also
420 -- references the parameter (for instance a named parameter in
421 -- a call), so we need to check whether there already exists a
422 -- declaration for the parameter.
426 (File_Ref => File_Ref,
431 Is_Parameter => True);
433 when 'd' | 'e' | 'E' | 'k' | 'p' | 'P' | 't' | 'z' =>
437 Ada.Text_IO.Put_Line ("Unknown reference type: " & Ref_Type);
441 New_Ref := new Reference_Record'
448 -- We can insert the reference into the list directly, since all the
449 -- references will appear only once in the ALI file corresponding to the
450 -- file where they are referenced. This saves a lot of time compared to
451 -- checking the list to check if it exists.
455 New_Ref.Next := Declaration.Body_Ref;
456 Declaration.Body_Ref := New_Ref;
458 when ' ' | 'H' | 'i' | 'l' | 'o' | 'r' | 'R' | 's' | 'w' | 'x' =>
459 New_Ref.Next := Declaration.Ref_Ref;
460 Declaration.Ref_Ref := New_Ref;
463 New_Ref.Next := Declaration.Modif_Ref;
464 Declaration.Modif_Ref := New_Ref;
470 if not Declaration.Match then
471 Declaration.Match := Match (File_Ref, Line, Column);
474 if Declaration.Match then
475 Longest_File_Name_In_Table :=
476 Natural'Max (File_Ref.File'Length, Longest_File_Name_In_Table);
484 function ALI_File_Name (Ada_File_Name : String) return String is
486 -- ??? Should ideally be based on the naming scheme defined in
489 Index : constant Natural :=
490 Ada.Strings.Fixed.Index
491 (Ada_File_Name, ".", Going => Ada.Strings.Backward);
495 return Ada_File_Name (Ada_File_Name'First .. Index)
496 & Osint.ALI_Suffix.all;
498 return Ada_File_Name & "." & Osint.ALI_Suffix.all;
506 function Is_Less_Than (Ref1, Ref2 : Reference) return Boolean is
510 elsif Ref2 = null then
514 if Ref1.File.File.all < Ref2.File.File.all then
517 elsif Ref1.File.File.all = Ref2.File.File.all then
518 return (Ref1.Line < Ref2.Line
519 or else (Ref1.Line = Ref2.Line
520 and then Ref1.Column < Ref2.Column));
530 function Is_Less_Than (Decl1, Decl2 : Declaration_Reference) return Boolean
532 -- We cannot store the data case-insensitive in the table,
533 -- since we wouldn't be able to find the right casing for the
536 S1 : constant String := To_Lower (Decl1.Symbol);
537 S2 : constant String := To_Lower (Decl2.Symbol);
546 return Decl1.Key.all < Decl2.Key.all;
549 -------------------------
550 -- Create_Project_File --
551 -------------------------
553 procedure Create_Project_File (Name : String) is
554 Obj_Dir : Unbounded_String := Null_Unbounded_String;
555 Src_Dir : Unbounded_String := Null_Unbounded_String;
556 Build_Dir : GNAT.OS_Lib.String_Access := new String'("");
560 File_Name : aliased String := Name & ASCII.NUL;
563 -- Read the size of the file
565 F := Open_Read (File_Name'Address, Text);
567 -- Project file not found
569 if F /= Invalid_FD then
570 Len := Positive (File_Length (F));
573 Buffer : String (1 .. Len);
574 Index : Positive := Buffer'First;
578 Len := Read (F, Buffer'Address, Len);
581 -- First, look for Build_Dir, since all the source and object
582 -- path are relative to it.
584 while Index <= Buffer'Last loop
586 -- Find the end of line
589 while Last <= Buffer'Last
590 and then Buffer (Last) /= ASCII.LF
591 and then Buffer (Last) /= ASCII.CR
596 if Index <= Buffer'Last - 9
597 and then Buffer (Index .. Index + 9) = "build_dir="
601 and then (Buffer (Index) = ' '
602 or else Buffer (Index) = ASCII.HT)
608 Build_Dir := new String'(Buffer (Index .. Last - 1));
613 -- In case we had a ASCII.CR/ASCII.LF end of line, skip the
616 if Index <= Buffer'Last
617 and then Buffer (Index) = ASCII.LF
623 -- Now parse the source and object paths
625 Index := Buffer'First;
626 while Index <= Buffer'Last loop
628 -- Find the end of line
631 while Last <= Buffer'Last
632 and then Buffer (Last) /= ASCII.LF
633 and then Buffer (Last) /= ASCII.CR
638 if Index <= Buffer'Last - 7
639 and then Buffer (Index .. Index + 7) = "src_dir="
641 Append (Src_Dir, Normalize_Pathname
642 (Name => Ada.Strings.Fixed.Trim
643 (Buffer (Index + 8 .. Last - 1), Ada.Strings.Both),
644 Directory => Build_Dir.all) & Path_Separator);
646 elsif Index <= Buffer'Last - 7
647 and then Buffer (Index .. Index + 7) = "obj_dir="
649 Append (Obj_Dir, Normalize_Pathname
650 (Name => Ada.Strings.Fixed.Trim
651 (Buffer (Index + 8 .. Last - 1), Ada.Strings.Both),
652 Directory => Build_Dir.all) & Path_Separator);
655 -- In case we had a ASCII.CR/ASCII.LF end of line, skip the
659 if Index <= Buffer'Last
660 and then Buffer (Index) = ASCII.LF
668 Osint.Add_Default_Search_Dirs;
671 Src : constant String := Parse_Gnatls_Src;
672 Obj : constant String := Parse_Gnatls_Obj;
675 Directories := new Project_File'
676 (Src_Dir_Length => Length (Src_Dir) + Src'Length,
677 Obj_Dir_Length => Length (Obj_Dir) + Obj'Length,
678 Src_Dir => To_String (Src_Dir) & Src,
679 Obj_Dir => To_String (Obj_Dir) & Obj,
682 Last_Obj_Dir_Start => 0);
686 end Create_Project_File;
688 ---------------------
689 -- Current_Obj_Dir --
690 ---------------------
692 function Current_Obj_Dir return String is
694 return Directories.Obj_Dir
695 (Directories.Last_Obj_Dir_Start .. Directories.Obj_Dir_Index - 2);
702 function Get_Column (Decl : Declaration_Reference) return String is
704 return Ada.Strings.Fixed.Trim (Natural'Image (Decl.Decl.Column),
708 function Get_Column (Ref : Reference) return String is
710 return Ada.Strings.Fixed.Trim (Natural'Image (Ref.Column),
714 ---------------------
715 -- Get_Declaration --
716 ---------------------
718 function Get_Declaration
719 (File_Ref : File_Reference;
722 return Declaration_Reference
724 Key : aliased constant String := Key_From_Ref (File_Ref, Line, Column);
727 return Entities_HTable.Get (Key'Unchecked_Access);
730 ----------------------
731 -- Get_Emit_Warning --
732 ----------------------
734 function Get_Emit_Warning (File : File_Reference) return Boolean is
736 return File.Emit_Warning;
737 end Get_Emit_Warning;
744 (Decl : Declaration_Reference;
745 With_Dir : Boolean := False) return String
748 return Get_File (Decl.Decl.File, With_Dir);
753 With_Dir : Boolean := False) return String
756 return Get_File (Ref.File, With_Dir);
760 (File : File_Reference;
761 With_Dir : Boolean := False;
762 Strip : Natural := 0) return String
764 pragma Annotate (CodePeer, Skip_Analysis);
765 -- ??? To disable false positives currently generated
767 Tmp : GNAT.OS_Lib.String_Access;
769 function Internal_Strip (Full_Name : String) return String;
770 -- Internal function to process the Strip parameter
776 function Internal_Strip (Full_Name : String) return String is
778 Extension_Start : Natural;
786 -- Isolate the file extension
788 Extension_Start := Full_Name'Last;
789 while Extension_Start >= Full_Name'First
790 and then Full_Name (Extension_Start) /= '.'
792 Extension_Start := Extension_Start - 1;
795 -- Strip the right number of subunit_names
798 Unit_End := Extension_Start - 1;
799 while Unit_End >= Full_Name'First
802 if Full_Name (Unit_End) = '-' then
806 Unit_End := Unit_End - 1;
809 if Unit_End < Full_Name'First then
812 return Full_Name (Full_Name'First .. Unit_End)
813 & Full_Name (Extension_Start .. Full_Name'Last);
817 -- Start of processing for Get_File;
820 -- If we do not want the full path name
823 return Internal_Strip (File.File.all);
826 if File.Dir = null then
827 if Ada.Strings.Fixed.Tail (File.File.all, 3) =
830 Tmp := Locate_Regular_File
831 (Internal_Strip (File.File.all), Directories.Obj_Dir);
833 Tmp := Locate_Regular_File
834 (File.File.all, Directories.Src_Dir);
838 File.Dir := new String'("");
840 File.Dir := new String'(Dir_Name (Tmp.all));
845 return Internal_Strip (File.Dir.all & File.File.all);
852 function Get_File_Ref (Ref : Reference) return File_Reference is
857 -----------------------
858 -- Get_Gnatchop_File --
859 -----------------------
861 function Get_Gnatchop_File
862 (File : File_Reference;
863 With_Dir : Boolean := False)
867 if File.Gnatchop_File.all = "" then
868 return Get_File (File, With_Dir);
870 return File.Gnatchop_File.all;
872 end Get_Gnatchop_File;
874 function Get_Gnatchop_File
876 With_Dir : Boolean := False)
880 return Get_Gnatchop_File (Ref.File, With_Dir);
881 end Get_Gnatchop_File;
883 function Get_Gnatchop_File
884 (Decl : Declaration_Reference;
885 With_Dir : Boolean := False)
889 return Get_Gnatchop_File (Decl.Decl.File, With_Dir);
890 end Get_Gnatchop_File;
896 function Get_Line (Decl : Declaration_Reference) return String is
898 return Ada.Strings.Fixed.Trim (Natural'Image (Decl.Decl.Line),
902 function Get_Line (Ref : Reference) return String is
904 return Ada.Strings.Fixed.Trim (Natural'Image (Ref.Line),
913 (Decl : Declaration_Reference)
914 return Declaration_Reference
917 return Decl.Par_Symbol;
920 ---------------------
921 -- Get_Source_Line --
922 ---------------------
924 function Get_Source_Line (Ref : Reference) return String is
926 if Ref.Source_Line /= null then
927 return Ref.Source_Line.all;
933 function Get_Source_Line (Decl : Declaration_Reference) return String is
935 if Decl.Decl.Source_Line /= null then
936 return Decl.Decl.Source_Line.all;
946 function Get_Symbol (Decl : Declaration_Reference) return String is
955 function Get_Type (Decl : Declaration_Reference) return Character is
957 return Decl.Decl_Type;
964 procedure Sort (Arr : in out Reference_Array) is
967 function Lt (Op1, Op2 : Natural) return Boolean;
968 procedure Move (From, To : Natural);
969 -- See GNAT.Heap_Sort_G
975 function Lt (Op1, Op2 : Natural) return Boolean is
978 return Is_Less_Than (Tmp, Arr (Op2));
980 return Is_Less_Than (Arr (Op1), Tmp);
982 return Is_Less_Than (Arr (Op1), Arr (Op2));
990 procedure Move (From, To : Natural) is
997 Arr (To) := Arr (From);
1001 package Ref_Sort is new GNAT.Heap_Sort_G (Move, Lt);
1003 -- Start of processing for Sort
1006 Ref_Sort.Sort (Arr'Last);
1009 -----------------------
1010 -- Grep_Source_Files --
1011 -----------------------
1013 procedure Grep_Source_Files is
1014 Length : Natural := 0;
1015 Decl : Declaration_Reference := Entities_HTable.Get_First;
1016 Arr : Reference_Array_Access;
1018 End_Index : Natural;
1019 Current_File : File_Reference;
1020 Current_Line : Cst_String_Access;
1021 Buffer : GNAT.OS_Lib.String_Access;
1026 -- Create a temporary array, where all references will be
1027 -- sorted by files. This way, we only have to read the source
1030 while Decl /= null loop
1032 -- Add 1 for the declaration itself
1034 Length := Length + References_Count (Decl, True, True, True) + 1;
1035 Decl := Entities_HTable.Get_Next;
1038 Arr := new Reference_Array (1 .. Length);
1041 Decl := Entities_HTable.Get_First;
1042 while Decl /= null loop
1043 Store_References (Decl, True, True, True, True, Arr.all, Index);
1044 Decl := Entities_HTable.Get_Next;
1049 -- Now traverse the whole array and find the appropriate source
1052 for R in Arr'Range loop
1055 if Ref.File /= Current_File then
1058 Read_File (Get_File (Ref.File, With_Dir => True), Buffer);
1059 End_Index := Buffer'First - 1;
1062 when Ada.Text_IO.Name_Error | Ada.Text_IO.End_Error =>
1063 Line := Natural'Last;
1065 Current_File := Ref.File;
1068 if Ref.Line > Line then
1070 -- Do not free Current_Line, it is referenced by the last
1071 -- Ref we processed.
1074 Index := End_Index + 1;
1077 End_Index := End_Index + 1;
1078 exit when End_Index > Buffer'Last
1079 or else Buffer (End_Index) = ASCII.LF;
1082 -- Skip spaces at beginning of line
1084 while Index < End_Index and then
1085 (Buffer (Index) = ' ' or else Buffer (Index) = ASCII.HT)
1091 exit when Ref.Line = Line;
1094 Current_Line := new String'(Buffer (Index .. End_Index - 1));
1097 Ref.Source_Line := Current_Line;
1102 end Grep_Source_Files;
1109 (File_Name : String;
1110 Contents : out GNAT.OS_Lib.String_Access)
1112 Name_0 : constant String := File_Name & ASCII.NUL;
1113 FD : constant File_Descriptor := Open_Read (Name_0'Address, Binary);
1117 if FD = Invalid_FD then
1118 raise Ada.Text_IO.Name_Error;
1121 -- Include room for EOF char
1123 Length := Natural (File_Length (FD));
1126 Buffer : String (1 .. Length + 1);
1127 This_Read : Integer;
1128 Read_Ptr : Natural := 1;
1132 This_Read := Read (FD,
1133 A => Buffer (Read_Ptr)'Address,
1134 N => Length + 1 - Read_Ptr);
1135 Read_Ptr := Read_Ptr + Integer'Max (This_Read, 0);
1136 exit when This_Read <= 0;
1139 Buffer (Read_Ptr) := EOF;
1140 Contents := new String'(Buffer (1 .. Read_Ptr));
1142 if Read_Ptr /= Length + 1 then
1143 raise Ada.Text_IO.End_Error;
1150 -----------------------
1151 -- Longest_File_Name --
1152 -----------------------
1154 function Longest_File_Name return Natural is
1156 return Longest_File_Name_In_Table;
1157 end Longest_File_Name;
1164 (File : File_Reference;
1169 Ref : Ref_In_File_Ptr := File.Lines;
1172 while Ref /= null loop
1173 if (Ref.Line = 0 or else Ref.Line = Line)
1174 and then (Ref.Column = 0 or else Ref.Column = Column)
1189 function Match (Decl : Declaration_Reference) return Boolean is
1198 function Next (E : File_Reference) return File_Reference is
1203 function Next (E : Declaration_Reference) return Declaration_Reference is
1212 function Next_Obj_Dir return String is
1213 First : constant Integer := Directories.Obj_Dir_Index;
1217 Last := Directories.Obj_Dir_Index;
1219 if Last > Directories.Obj_Dir_Length then
1220 return String'(1 .. 0 => ' ');
1223 while Directories.Obj_Dir (Last) /= Path_Separator loop
1227 Directories.Obj_Dir_Index := Last + 1;
1228 Directories.Last_Obj_Dir_Start := First;
1229 return Directories.Obj_Dir (First .. Last - 1);
1232 -------------------------
1233 -- Next_Unvisited_File --
1234 -------------------------
1236 function Next_Unvisited_File return File_Reference is
1237 procedure Unchecked_Free is new Ada.Unchecked_Deallocation
1238 (Unvisited_Files_Record, Unvisited_Files_Access);
1240 Ref : File_Reference;
1241 Tmp : Unvisited_Files_Access;
1244 if Unvisited_Files = null then
1247 Tmp := Unvisited_Files;
1248 Ref := Unvisited_Files.File;
1249 Unvisited_Files := Unvisited_Files.Next;
1250 Unchecked_Free (Tmp);
1253 end Next_Unvisited_File;
1255 ----------------------
1256 -- Parse_Gnatls_Src --
1257 ----------------------
1259 function Parse_Gnatls_Src return String is
1264 for J in 1 .. Osint.Nb_Dir_In_Src_Search_Path loop
1265 if Osint.Dir_In_Src_Search_Path (J)'Length = 0 then
1266 Length := Length + 2;
1268 Length := Length + Osint.Dir_In_Src_Search_Path (J)'Length + 1;
1273 Result : String (1 .. Length);
1278 for J in 1 .. Osint.Nb_Dir_In_Src_Search_Path loop
1279 if Osint.Dir_In_Src_Search_Path (J)'Length = 0 then
1280 Result (L .. L + 1) := "." & Path_Separator;
1284 Result (L .. L + Osint.Dir_In_Src_Search_Path (J)'Length - 1) :=
1285 Osint.Dir_In_Src_Search_Path (J).all;
1286 L := L + Osint.Dir_In_Src_Search_Path (J)'Length;
1287 Result (L) := Path_Separator;
1294 end Parse_Gnatls_Src;
1296 ----------------------
1297 -- Parse_Gnatls_Obj --
1298 ----------------------
1300 function Parse_Gnatls_Obj return String is
1305 for J in 1 .. Osint.Nb_Dir_In_Obj_Search_Path loop
1306 if Osint.Dir_In_Obj_Search_Path (J)'Length = 0 then
1307 Length := Length + 2;
1309 Length := Length + Osint.Dir_In_Obj_Search_Path (J)'Length + 1;
1314 Result : String (1 .. Length);
1319 for J in 1 .. Osint.Nb_Dir_In_Obj_Search_Path loop
1320 if Osint.Dir_In_Obj_Search_Path (J)'Length = 0 then
1321 Result (L .. L + 1) := "." & Path_Separator;
1324 Result (L .. L + Osint.Dir_In_Obj_Search_Path (J)'Length - 1) :=
1325 Osint.Dir_In_Obj_Search_Path (J).all;
1326 L := L + Osint.Dir_In_Obj_Search_Path (J)'Length;
1327 Result (L) := Path_Separator;
1334 end Parse_Gnatls_Obj;
1340 procedure Reset_Obj_Dir is
1342 Directories.Obj_Dir_Index := 1;
1345 -----------------------
1346 -- Set_Default_Match --
1347 -----------------------
1349 procedure Set_Default_Match (Value : Boolean) is
1351 Default_Match := Value;
1352 end Set_Default_Match;
1358 procedure Free (Str : in out Cst_String_Access) is
1359 function Convert is new Ada.Unchecked_Conversion
1360 (Cst_String_Access, GNAT.OS_Lib.String_Access);
1362 S : GNAT.OS_Lib.String_Access := Convert (Str);
1369 ---------------------
1370 -- Reset_Directory --
1371 ---------------------
1373 procedure Reset_Directory (File : File_Reference) is
1376 end Reset_Directory;
1382 procedure Set_Unvisited (File_Ref : File_Reference) is
1383 F : constant String := Get_File (File_Ref, With_Dir => False);
1386 File_Ref.Visited := False;
1388 -- ??? Do not add a source file to the list. This is true at
1389 -- least for gnatxref, and probably for gnatfind as well
1392 and then F (F'Last - 3 .. F'Last) = "." & Osint.ALI_Suffix.all
1394 Unvisited_Files := new Unvisited_Files_Record'
1396 Next => Unvisited_Files);
1400 ----------------------
1401 -- Get_Declarations --
1402 ----------------------
1404 function Get_Declarations
1405 (Sorted : Boolean := True)
1406 return Declaration_Array_Access
1408 Arr : constant Declaration_Array_Access :=
1409 new Declaration_Array (1 .. Entities_Count);
1410 Decl : Declaration_Reference := Entities_HTable.Get_First;
1411 Index : Natural := Arr'First;
1412 Tmp : Declaration_Reference;
1414 procedure Move (From : Natural; To : Natural);
1415 function Lt (Op1, Op2 : Natural) return Boolean;
1416 -- See GNAT.Heap_Sort_G
1422 function Lt (Op1, Op2 : Natural) return Boolean is
1425 return Is_Less_Than (Tmp, Arr (Op2));
1427 return Is_Less_Than (Arr (Op1), Tmp);
1429 return Is_Less_Than (Arr (Op1), Arr (Op2));
1437 procedure Move (From : Natural; To : Natural) is
1444 Arr (To) := Arr (From);
1448 package Decl_Sort is new GNAT.Heap_Sort_G (Move, Lt);
1450 -- Start of processing for Get_Declarations
1453 while Decl /= null loop
1454 Arr (Index) := Decl;
1456 Decl := Entities_HTable.Get_Next;
1459 if Sorted and then Arr'Length /= 0 then
1460 Decl_Sort.Sort (Entities_Count);
1464 end Get_Declarations;
1466 ----------------------
1467 -- References_Count --
1468 ----------------------
1470 function References_Count
1471 (Decl : Declaration_Reference;
1472 Get_Reads : Boolean := False;
1473 Get_Writes : Boolean := False;
1474 Get_Bodies : Boolean := False)
1477 function List_Length (E : Reference) return Natural;
1478 -- Return the number of references in E
1484 function List_Length (E : Reference) return Natural is
1486 E1 : Reference := E;
1489 while E1 /= null loop
1497 Length : Natural := 0;
1499 -- Start of processing for References_Count
1503 Length := List_Length (Decl.Ref_Ref);
1507 Length := Length + List_Length (Decl.Modif_Ref);
1511 Length := Length + List_Length (Decl.Body_Ref);
1515 end References_Count;
1517 ----------------------
1518 -- Store_References --
1519 ----------------------
1521 procedure Store_References
1522 (Decl : Declaration_Reference;
1523 Get_Writes : Boolean := False;
1524 Get_Reads : Boolean := False;
1525 Get_Bodies : Boolean := False;
1526 Get_Declaration : Boolean := False;
1527 Arr : in out Reference_Array;
1528 Index : in out Natural)
1530 procedure Add (List : Reference);
1531 -- Add all the references in List to Arr
1537 procedure Add (List : Reference) is
1538 E : Reference := List;
1540 while E /= null loop
1547 -- Start of processing for Store_References
1550 if Get_Declaration then
1559 Add (Decl.Modif_Ref);
1563 Add (Decl.Body_Ref);
1565 end Store_References;
1567 --------------------
1568 -- Get_References --
1569 --------------------
1571 function Get_References
1572 (Decl : Declaration_Reference;
1573 Get_Reads : Boolean := False;
1574 Get_Writes : Boolean := False;
1575 Get_Bodies : Boolean := False)
1576 return Reference_Array_Access
1578 Length : constant Natural :=
1579 References_Count (Decl, Get_Reads, Get_Writes, Get_Bodies);
1581 Arr : constant Reference_Array_Access :=
1582 new Reference_Array (1 .. Length);
1584 Index : Natural := Arr'First;
1589 Get_Writes => Get_Writes,
1590 Get_Reads => Get_Reads,
1591 Get_Bodies => Get_Bodies,
1592 Get_Declaration => False,
1596 if Arr'Length /= 0 then
1607 procedure Free (Arr : in out Reference_Array_Access) is
1608 procedure Internal is new Ada.Unchecked_Deallocation
1609 (Reference_Array, Reference_Array_Access);
1618 function Is_Parameter (Decl : Declaration_Reference) return Boolean is
1620 return Decl.Is_Parameter;