1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1998-2010, 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
;
30 with Ada
.Unchecked_Conversion
;
31 with Ada
.Unchecked_Deallocation
;
32 with Ada
.Strings
.Fixed
;
35 with Ada
.Characters
.Handling
; use Ada
.Characters
.Handling
;
36 with Ada
.Strings
.Unbounded
; use Ada
.Strings
.Unbounded
;
38 with GNAT
.OS_Lib
; use GNAT
.OS_Lib
;
39 with GNAT
.Directory_Operations
; use GNAT
.Directory_Operations
;
40 with GNAT
.HTable
; use GNAT
.HTable
;
41 with GNAT
.Heap_Sort_G
;
43 package body Xr_Tabls
is
45 type HTable_Headers
is range 1 .. 10000;
47 procedure Set_Next
(E
: File_Reference
; Next
: File_Reference
);
48 function Next
(E
: File_Reference
) return File_Reference
;
49 function Get_Key
(E
: File_Reference
) return Cst_String_Access
;
50 function Hash
(F
: Cst_String_Access
) return HTable_Headers
;
51 function Equal
(F1
, F2
: Cst_String_Access
) return Boolean;
52 -- The five subprograms above are used to instantiate the static
53 -- htable to store the files that should be processed.
55 package File_HTable
is new GNAT
.HTable
.Static_HTable
56 (Header_Num
=> HTable_Headers
,
57 Element
=> File_Record
,
58 Elmt_Ptr
=> File_Reference
,
62 Key
=> Cst_String_Access
,
66 -- A hash table to store all the files referenced in the
67 -- application. The keys in this htable are the name of the files
68 -- themselves, therefore it is assumed that the source path
69 -- doesn't contain twice the same source or ALI file name
71 type Unvisited_Files_Record
;
72 type Unvisited_Files_Access
is access Unvisited_Files_Record
;
73 type Unvisited_Files_Record
is record
74 File
: File_Reference
;
75 Next
: Unvisited_Files_Access
;
77 -- A special list, in addition to File_HTable, that only stores
78 -- the files that haven't been visited so far. Note that the File
79 -- list points to some data in File_HTable, and thus should never be freed.
81 function Next
(E
: Declaration_Reference
) return Declaration_Reference
;
82 procedure Set_Next
(E
, Next
: Declaration_Reference
);
83 function Get_Key
(E
: Declaration_Reference
) return Cst_String_Access
;
84 -- The subprograms above are used to instantiate the static
85 -- htable to store the entities that have been found in the application
87 package Entities_HTable
is new GNAT
.HTable
.Static_HTable
88 (Header_Num
=> HTable_Headers
,
89 Element
=> Declaration_Record
,
90 Elmt_Ptr
=> Declaration_Reference
,
94 Key
=> Cst_String_Access
,
98 -- A hash table to store all the entities defined in the
99 -- application. For each entity, we store a list of its reference
100 -- locations as well.
101 -- The keys in this htable should be created with Key_From_Ref,
102 -- and are the file, line and column of the declaration, which are
103 -- unique for every entity.
105 Entities_Count
: Natural := 0;
106 -- Number of entities in Entities_HTable. This is used in the end
107 -- when sorting the table.
109 Longest_File_Name_In_Table
: Natural := 0;
110 Unvisited_Files
: Unvisited_Files_Access
:= null;
111 Directories
: Project_File_Ptr
;
112 Default_Match
: Boolean := False;
113 -- The above need commenting ???
115 function Parse_Gnatls_Src
return String;
116 -- Return the standard source directories (taking into account the
117 -- ADA_INCLUDE_PATH environment variable, if Osint.Add_Default_Search_Dirs
118 -- was called first).
120 function Parse_Gnatls_Obj
return String;
121 -- Return the standard object directories (taking into account the
122 -- ADA_OBJECTS_PATH environment variable).
124 function Key_From_Ref
125 (File_Ref
: File_Reference
;
129 -- Return a key for the symbol declared at File_Ref, Line,
130 -- Column. This key should be used for lookup in Entity_HTable
132 function Is_Less_Than
(Decl1
, Decl2
: Declaration_Reference
) return Boolean;
133 -- Compare two declarations (the comparison is case-insensitive)
135 function Is_Less_Than
(Ref1
, Ref2
: Reference
) return Boolean;
136 -- Compare two references
138 procedure Store_References
139 (Decl
: Declaration_Reference
;
140 Get_Writes
: Boolean := False;
141 Get_Reads
: Boolean := False;
142 Get_Bodies
: Boolean := False;
143 Get_Declaration
: Boolean := False;
144 Arr
: in out Reference_Array
;
145 Index
: in out Natural);
146 -- Store in Arr, starting at Index, all the references to Decl. The Get_*
147 -- parameters can be used to indicate which references should be stored.
148 -- Constraint_Error will be raised if Arr is not big enough.
150 procedure Sort
(Arr
: in out Reference_Array
);
151 -- Sort an array of references (Arr'First must be 1)
157 procedure Set_Next
(E
: File_Reference
; Next
: File_Reference
) is
163 (E
: Declaration_Reference
; Next
: Declaration_Reference
) is
172 function Get_Key
(E
: File_Reference
) return Cst_String_Access
is
177 function Get_Key
(E
: Declaration_Reference
) return Cst_String_Access
is
186 function Hash
(F
: Cst_String_Access
) return HTable_Headers
is
187 function H
is new GNAT
.HTable
.Hash
(HTable_Headers
);
197 function Equal
(F1
, F2
: Cst_String_Access
) return Boolean is
199 return F1
.all = F2
.all;
206 function Key_From_Ref
207 (File_Ref
: File_Reference
;
213 return File_Ref
.File
.all & Natural'Image (Line
) & Natural'Image (Column
);
216 ---------------------
217 -- Add_Declaration --
218 ---------------------
220 function Add_Declaration
221 (File_Ref
: File_Reference
;
225 Decl_Type
: Character;
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_Parameter
: Boolean := False;
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_Parameter
:= 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_Parameter,
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);
302 ----------------------
303 -- Add_To_Xref_File --
304 ----------------------
306 function Add_To_Xref_File
308 Visited : Boolean := True;
309 Emit_Warning : Boolean := False;
310 Gnatchop_File : String := "";
311 Gnatchop_Offset : Integer := 0) return File_Reference
313 Base : aliased constant String := Base_Name (File_Name);
314 Dir : constant String := Dir_Name (File_Name);
315 Dir_Acc : GNAT.OS_Lib.String_Access := null;
316 Ref : File_Reference;
319 -- Do we have a directory name as well?
321 if File_Name /= Base then
322 Dir_Acc := new String'(Dir
);
325 Ref
:= File_HTable
.Get
(Base
'Unchecked_Access);
327 Ref
:= new File_Record
'
328 (File => new String'(Base
),
332 Emit_Warning
=> Emit_Warning
,
333 Gnatchop_File
=> new String'(Gnatchop_File),
334 Gnatchop_Offset => Gnatchop_Offset,
336 File_HTable.Set (Ref);
340 -- Keep a separate list for faster access
346 end Add_To_Xref_File;
353 (File : File_Reference;
358 File.Lines := new Ref_In_File'(Line
=> Line
,
368 (Declaration
: in out Declaration_Reference
;
372 File_Ref
: File_Reference
)
375 Declaration
.Par_Symbol
:=
377 (File_Ref
, Symbol
, Line
, Column
,
379 Symbol_Match
=> False);
386 procedure Add_Reference
387 (Declaration
: Declaration_Reference
;
388 File_Ref
: File_Reference
;
391 Ref_Type
: Character;
392 Labels_As_Ref
: Boolean)
398 when 'b' |
'c' |
'H' |
'm' |
'o' |
'r' |
'R' |
399 's' |
'i' |
' ' |
'x' =>
403 if not Labels_As_Ref
then
407 when '=' |
'<' |
'>' |
'^' =>
409 -- Create a dummy declaration in the table to report it as a
410 -- parameter. Note that the current declaration for the subprogram
411 -- comes before the declaration of the parameter.
414 Key
: constant String :=
415 Key_From_Ref
(File_Ref
, Line
, Column
);
416 New_Decl
: Declaration_Reference
;
419 New_Decl
:= new Declaration_Record
'
422 Key => new String'(Key
),
423 Decl
=> new Reference_Record
'
429 Is_Parameter => True,
437 Entities_HTable.Set (New_Decl);
438 Entities_Count := Entities_Count + 1;
441 when 'e
' | 'z
' | 't
' | 'p
' | 'P
' | 'k
' | 'd
' =>
445 Ada.Text_IO.Put_Line ("Unknown reference type: " & Ref_Type);
449 New_Ref := new Reference_Record'
456 -- We can insert the reference into the list directly, since all the
457 -- references will appear only once in the ALI file corresponding to the
458 -- file where they are referenced. This saves a lot of time compared to
459 -- checking the list to check if it exists.
463 New_Ref
.Next
:= Declaration
.Body_Ref
;
464 Declaration
.Body_Ref
:= New_Ref
;
466 when 'r' |
'R' |
's' |
'H' |
'i' |
'l' |
'o' |
' ' |
'x' |
'w' =>
467 New_Ref
.Next
:= Declaration
.Ref_Ref
;
468 Declaration
.Ref_Ref
:= New_Ref
;
471 New_Ref
.Next
:= Declaration
.Modif_Ref
;
472 Declaration
.Modif_Ref
:= New_Ref
;
478 if not Declaration
.Match
then
479 Declaration
.Match
:= Match
(File_Ref
, Line
, Column
);
482 if Declaration
.Match
then
483 Longest_File_Name_In_Table
:=
484 Natural'Max (File_Ref
.File
'Length, Longest_File_Name_In_Table
);
492 function ALI_File_Name
(Ada_File_Name
: String) return String is
494 -- ??? Should ideally be based on the naming scheme defined in
497 Index
: constant Natural :=
498 Ada
.Strings
.Fixed
.Index
499 (Ada_File_Name
, ".", Going
=> Ada
.Strings
.Backward
);
503 return Ada_File_Name
(Ada_File_Name
'First .. Index
)
504 & Osint
.ALI_Suffix
.all;
506 return Ada_File_Name
& "." & Osint
.ALI_Suffix
.all;
514 function Is_Less_Than
(Ref1
, Ref2
: Reference
) return Boolean is
518 elsif Ref2
= null then
522 if Ref1
.File
.File
.all < Ref2
.File
.File
.all then
525 elsif Ref1
.File
.File
.all = Ref2
.File
.File
.all then
526 return (Ref1
.Line
< Ref2
.Line
527 or else (Ref1
.Line
= Ref2
.Line
528 and then Ref1
.Column
< Ref2
.Column
));
538 function Is_Less_Than
(Decl1
, Decl2
: Declaration_Reference
) return Boolean
540 -- We cannot store the data case-insensitive in the table,
541 -- since we wouldn't be able to find the right casing for the
544 S1
: constant String := To_Lower
(Decl1
.Symbol
);
545 S2
: constant String := To_Lower
(Decl2
.Symbol
);
554 return Decl1
.Key
.all < Decl2
.Key
.all;
557 -------------------------
558 -- Create_Project_File --
559 -------------------------
561 procedure Create_Project_File
(Name
: String) is
562 Obj_Dir
: Unbounded_String
:= Null_Unbounded_String
;
563 Src_Dir
: Unbounded_String
:= Null_Unbounded_String
;
564 Build_Dir
: GNAT
.OS_Lib
.String_Access
:= new String'("");
568 File_Name : aliased String := Name & ASCII.NUL;
571 -- Read the size of the file
573 F := Open_Read (File_Name'Address, Text);
575 -- Project file not found
577 if F /= Invalid_FD then
578 Len := Positive (File_Length (F));
581 Buffer : String (1 .. Len);
582 Index : Positive := Buffer'First;
586 Len := Read (F, Buffer'Address, Len);
589 -- First, look for Build_Dir, since all the source and object
590 -- path are relative to it.
592 while Index <= Buffer'Last loop
594 -- Find the end of line
597 while Last <= Buffer'Last
598 and then Buffer (Last) /= ASCII.LF
599 and then Buffer (Last) /= ASCII.CR
604 if Index <= Buffer'Last - 9
605 and then Buffer (Index .. Index + 9) = "build_dir="
609 and then (Buffer (Index) = ' '
610 or else Buffer (Index) = ASCII.HT)
616 Build_Dir := new String'(Buffer
(Index
.. Last
- 1));
621 -- In case we had a ASCII.CR/ASCII.LF end of line, skip the
624 if Index
<= Buffer
'Last
625 and then Buffer
(Index
) = ASCII
.LF
631 -- Now parse the source and object paths
633 Index
:= Buffer
'First;
634 while Index
<= Buffer
'Last loop
636 -- Find the end of line
639 while Last
<= Buffer
'Last
640 and then Buffer
(Last
) /= ASCII
.LF
641 and then Buffer
(Last
) /= ASCII
.CR
646 if Index
<= Buffer
'Last - 7
647 and then Buffer
(Index
.. Index
+ 7) = "src_dir="
649 Append
(Src_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
);
654 elsif Index
<= Buffer
'Last - 7
655 and then Buffer
(Index
.. Index
+ 7) = "obj_dir="
657 Append
(Obj_Dir
, Normalize_Pathname
658 (Name
=> Ada
.Strings
.Fixed
.Trim
659 (Buffer
(Index
+ 8 .. Last
- 1), Ada
.Strings
.Both
),
660 Directory
=> Build_Dir
.all) & Path_Separator
);
663 -- In case we had a ASCII.CR/ASCII.LF end of line, skip the
667 if Index
<= Buffer
'Last
668 and then Buffer
(Index
) = ASCII
.LF
676 Osint
.Add_Default_Search_Dirs
;
679 Src
: constant String := Parse_Gnatls_Src
;
680 Obj
: constant String := Parse_Gnatls_Obj
;
683 Directories
:= new Project_File
'
684 (Src_Dir_Length => Length (Src_Dir) + Src'Length,
685 Obj_Dir_Length => Length (Obj_Dir) + Obj'Length,
686 Src_Dir => To_String (Src_Dir) & Src,
687 Obj_Dir => To_String (Obj_Dir) & Obj,
690 Last_Obj_Dir_Start => 0);
694 end Create_Project_File;
696 ---------------------
697 -- Current_Obj_Dir --
698 ---------------------
700 function Current_Obj_Dir return String is
702 return Directories.Obj_Dir
703 (Directories.Last_Obj_Dir_Start .. Directories.Obj_Dir_Index - 2);
710 function Get_Column (Decl : Declaration_Reference) return String is
712 return Ada.Strings.Fixed.Trim (Natural'Image (Decl.Decl.Column),
716 function Get_Column (Ref : Reference) return String is
718 return Ada.Strings.Fixed.Trim (Natural'Image (Ref.Column),
722 ---------------------
723 -- Get_Declaration --
724 ---------------------
726 function Get_Declaration
727 (File_Ref : File_Reference;
730 return Declaration_Reference
732 Key : aliased constant String := Key_From_Ref (File_Ref, Line, Column);
735 return Entities_HTable.Get (Key'Unchecked_Access);
738 ----------------------
739 -- Get_Emit_Warning --
740 ----------------------
742 function Get_Emit_Warning (File : File_Reference) return Boolean is
744 return File.Emit_Warning;
745 end Get_Emit_Warning;
752 (Decl : Declaration_Reference;
753 With_Dir : Boolean := False) return String
756 return Get_File (Decl.Decl.File, With_Dir);
761 With_Dir : Boolean := False) return String
764 return Get_File (Ref.File, With_Dir);
768 (File : File_Reference;
769 With_Dir : Boolean := False;
770 Strip : Natural := 0) return String
772 Tmp : GNAT.OS_Lib.String_Access;
774 function Internal_Strip (Full_Name : String) return String;
775 -- Internal function to process the Strip parameter
781 function Internal_Strip (Full_Name : String) return String is
783 Extension_Start : Natural;
791 -- Isolate the file extension
793 Extension_Start := Full_Name'Last;
794 while Extension_Start >= Full_Name'First
795 and then Full_Name (Extension_Start) /= '.'
797 Extension_Start := Extension_Start - 1;
800 -- Strip the right number of subunit_names
803 Unit_End := Extension_Start - 1;
804 while Unit_End >= Full_Name'First
807 if Full_Name (Unit_End) = '-' then
811 Unit_End := Unit_End - 1;
814 if Unit_End < Full_Name'First then
817 return Full_Name (Full_Name'First .. Unit_End)
818 & Full_Name (Extension_Start .. Full_Name'Last);
822 -- Start of processing for Get_File;
825 -- If we do not want the full path name
828 return Internal_Strip (File.File.all);
831 if File.Dir = null then
832 if Ada.Strings.Fixed.Tail (File.File.all, 3) =
835 Tmp := Locate_Regular_File
836 (Internal_Strip (File.File.all), Directories.Obj_Dir);
838 Tmp := Locate_Regular_File
839 (File.File.all, Directories.Src_Dir);
843 File.Dir := new String'("");
845 File
.Dir
:= new String'(Dir_Name (Tmp.all));
850 return Internal_Strip (File.Dir.all & File.File.all);
857 function Get_File_Ref (Ref : Reference) return File_Reference is
862 -----------------------
863 -- Get_Gnatchop_File --
864 -----------------------
866 function Get_Gnatchop_File
867 (File : File_Reference;
868 With_Dir : Boolean := False)
872 if File.Gnatchop_File.all = "" then
873 return Get_File (File, With_Dir);
875 return File.Gnatchop_File.all;
877 end Get_Gnatchop_File;
879 function Get_Gnatchop_File
881 With_Dir : Boolean := False)
885 return Get_Gnatchop_File (Ref.File, With_Dir);
886 end Get_Gnatchop_File;
888 function Get_Gnatchop_File
889 (Decl : Declaration_Reference;
890 With_Dir : Boolean := False)
894 return Get_Gnatchop_File (Decl.Decl.File, With_Dir);
895 end Get_Gnatchop_File;
901 function Get_Line (Decl : Declaration_Reference) return String is
903 return Ada.Strings.Fixed.Trim (Natural'Image (Decl.Decl.Line),
907 function Get_Line (Ref : Reference) return String is
909 return Ada.Strings.Fixed.Trim (Natural'Image (Ref.Line),
918 (Decl : Declaration_Reference)
919 return Declaration_Reference
922 return Decl.Par_Symbol;
925 ---------------------
926 -- Get_Source_Line --
927 ---------------------
929 function Get_Source_Line (Ref : Reference) return String is
931 if Ref.Source_Line /= null then
932 return Ref.Source_Line.all;
938 function Get_Source_Line (Decl : Declaration_Reference) return String is
940 if Decl.Decl.Source_Line /= null then
941 return Decl.Decl.Source_Line.all;
951 function Get_Symbol (Decl : Declaration_Reference) return String is
960 function Get_Type (Decl : Declaration_Reference) return Character is
962 return Decl.Decl_Type;
969 procedure Sort (Arr : in out Reference_Array) is
972 function Lt (Op1, Op2 : Natural) return Boolean;
973 procedure Move (From, To : Natural);
974 -- See GNAT.Heap_Sort_G
980 function Lt (Op1, Op2 : Natural) return Boolean is
983 return Is_Less_Than (Tmp, Arr (Op2));
985 return Is_Less_Than (Arr (Op1), Tmp);
987 return Is_Less_Than (Arr (Op1), Arr (Op2));
995 procedure Move (From, To : Natural) is
1002 Arr (To) := Arr (From);
1006 package Ref_Sort is new GNAT.Heap_Sort_G (Move, Lt);
1008 -- Start of processing for Sort
1011 Ref_Sort.Sort (Arr'Last);
1014 -----------------------
1015 -- Grep_Source_Files --
1016 -----------------------
1018 procedure Grep_Source_Files is
1019 Length : Natural := 0;
1020 Decl : Declaration_Reference := Entities_HTable.Get_First;
1021 Arr : Reference_Array_Access;
1023 End_Index : Natural;
1024 Current_File : File_Reference;
1025 Current_Line : Cst_String_Access;
1026 Buffer : GNAT.OS_Lib.String_Access;
1031 -- Create a temporary array, where all references will be
1032 -- sorted by files. This way, we only have to read the source
1035 while Decl /= null loop
1037 -- Add 1 for the declaration itself
1039 Length := Length + References_Count (Decl, True, True, True) + 1;
1040 Decl := Entities_HTable.Get_Next;
1043 Arr := new Reference_Array (1 .. Length);
1046 Decl := Entities_HTable.Get_First;
1047 while Decl /= null loop
1048 Store_References (Decl, True, True, True, True, Arr.all, Index);
1049 Decl := Entities_HTable.Get_Next;
1054 -- Now traverse the whole array and find the appropriate source
1057 for R in Arr'Range loop
1060 if Ref.File /= Current_File then
1063 Read_File (Get_File (Ref.File, With_Dir => True), Buffer);
1064 End_Index := Buffer'First - 1;
1067 when Ada.Text_IO.Name_Error | Ada.Text_IO.End_Error =>
1068 Line := Natural'Last;
1070 Current_File := Ref.File;
1073 if Ref.Line > Line then
1075 -- Do not free Current_Line, it is referenced by the last
1076 -- Ref we processed.
1079 Index := End_Index + 1;
1082 End_Index := End_Index + 1;
1083 exit when End_Index > Buffer'Last
1084 or else Buffer (End_Index) = ASCII.LF;
1087 -- Skip spaces at beginning of line
1089 while Index < End_Index and then
1090 (Buffer (Index) = ' ' or else Buffer (Index) = ASCII.HT)
1096 exit when Ref.Line = Line;
1099 Current_Line := new String'(Buffer
(Index
.. End_Index
- 1));
1102 Ref
.Source_Line
:= Current_Line
;
1107 end Grep_Source_Files
;
1114 (File_Name
: String;
1115 Contents
: out GNAT
.OS_Lib
.String_Access
)
1117 Name_0
: constant String := File_Name
& ASCII
.NUL
;
1118 FD
: constant File_Descriptor
:= Open_Read
(Name_0
'Address, Binary
);
1122 if FD
= Invalid_FD
then
1123 raise Ada
.Text_IO
.Name_Error
;
1126 -- Include room for EOF char
1128 Length
:= Natural (File_Length
(FD
));
1131 Buffer
: String (1 .. Length
+ 1);
1132 This_Read
: Integer;
1133 Read_Ptr
: Natural := 1;
1137 This_Read
:= Read
(FD
,
1138 A
=> Buffer
(Read_Ptr
)'Address,
1139 N
=> Length
+ 1 - Read_Ptr
);
1140 Read_Ptr
:= Read_Ptr
+ Integer'Max (This_Read
, 0);
1141 exit when This_Read
<= 0;
1144 Buffer
(Read_Ptr
) := EOF
;
1145 Contents
:= new String'(Buffer (1 .. Read_Ptr));
1147 -- Things are not simple on VMS due to the plethora of file types
1148 -- and organizations. It seems clear that there shouldn't be more
1149 -- bytes read than are contained in the file though.
1151 if (Hostparm.OpenVMS and then Read_Ptr > Length + 1)
1152 or else (not Hostparm.OpenVMS and then Read_Ptr /= Length + 1)
1154 raise Ada.Text_IO.End_Error;
1161 -----------------------
1162 -- Longest_File_Name --
1163 -----------------------
1165 function Longest_File_Name return Natural is
1167 return Longest_File_Name_In_Table;
1168 end Longest_File_Name;
1175 (File : File_Reference;
1180 Ref : Ref_In_File_Ptr := File.Lines;
1183 while Ref /= null loop
1184 if (Ref.Line = 0 or else Ref.Line = Line)
1185 and then (Ref.Column = 0 or else Ref.Column = Column)
1200 function Match (Decl : Declaration_Reference) return Boolean is
1209 function Next (E : File_Reference) return File_Reference is
1214 function Next (E : Declaration_Reference) return Declaration_Reference is
1223 function Next_Obj_Dir return String is
1224 First : constant Integer := Directories.Obj_Dir_Index;
1228 Last := Directories.Obj_Dir_Index;
1230 if Last > Directories.Obj_Dir_Length then
1231 return String'(1 .. 0 => ' ');
1234 while Directories
.Obj_Dir
(Last
) /= Path_Separator
loop
1238 Directories
.Obj_Dir_Index
:= Last
+ 1;
1239 Directories
.Last_Obj_Dir_Start
:= First
;
1240 return Directories
.Obj_Dir
(First
.. Last
- 1);
1243 -------------------------
1244 -- Next_Unvisited_File --
1245 -------------------------
1247 function Next_Unvisited_File
return File_Reference
is
1248 procedure Unchecked_Free
is new Ada
.Unchecked_Deallocation
1249 (Unvisited_Files_Record
, Unvisited_Files_Access
);
1251 Ref
: File_Reference
;
1252 Tmp
: Unvisited_Files_Access
;
1255 if Unvisited_Files
= null then
1258 Tmp
:= Unvisited_Files
;
1259 Ref
:= Unvisited_Files
.File
;
1260 Unvisited_Files
:= Unvisited_Files
.Next
;
1261 Unchecked_Free
(Tmp
);
1264 end Next_Unvisited_File
;
1266 ----------------------
1267 -- Parse_Gnatls_Src --
1268 ----------------------
1270 function Parse_Gnatls_Src
return String is
1275 for J
in 1 .. Osint
.Nb_Dir_In_Src_Search_Path
loop
1276 if Osint
.Dir_In_Src_Search_Path
(J
)'Length = 0 then
1277 Length
:= Length
+ 2;
1279 Length
:= Length
+ Osint
.Dir_In_Src_Search_Path
(J
)'Length + 1;
1284 Result
: String (1 .. Length
);
1289 for J
in 1 .. Osint
.Nb_Dir_In_Src_Search_Path
loop
1290 if Osint
.Dir_In_Src_Search_Path
(J
)'Length = 0 then
1291 Result
(L
.. L
+ 1) := "." & Path_Separator
;
1295 Result
(L
.. L
+ Osint
.Dir_In_Src_Search_Path
(J
)'Length - 1) :=
1296 Osint
.Dir_In_Src_Search_Path
(J
).all;
1297 L
:= L
+ Osint
.Dir_In_Src_Search_Path
(J
)'Length;
1298 Result
(L
) := Path_Separator
;
1305 end Parse_Gnatls_Src
;
1307 ----------------------
1308 -- Parse_Gnatls_Obj --
1309 ----------------------
1311 function Parse_Gnatls_Obj
return String is
1316 for J
in 1 .. Osint
.Nb_Dir_In_Obj_Search_Path
loop
1317 if Osint
.Dir_In_Obj_Search_Path
(J
)'Length = 0 then
1318 Length
:= Length
+ 2;
1320 Length
:= Length
+ Osint
.Dir_In_Obj_Search_Path
(J
)'Length + 1;
1325 Result
: String (1 .. Length
);
1330 for J
in 1 .. Osint
.Nb_Dir_In_Obj_Search_Path
loop
1331 if Osint
.Dir_In_Obj_Search_Path
(J
)'Length = 0 then
1332 Result
(L
.. L
+ 1) := "." & Path_Separator
;
1335 Result
(L
.. L
+ Osint
.Dir_In_Obj_Search_Path
(J
)'Length - 1) :=
1336 Osint
.Dir_In_Obj_Search_Path
(J
).all;
1337 L
:= L
+ Osint
.Dir_In_Obj_Search_Path
(J
)'Length;
1338 Result
(L
) := Path_Separator
;
1345 end Parse_Gnatls_Obj
;
1351 procedure Reset_Obj_Dir
is
1353 Directories
.Obj_Dir_Index
:= 1;
1356 -----------------------
1357 -- Set_Default_Match --
1358 -----------------------
1360 procedure Set_Default_Match
(Value
: Boolean) is
1362 Default_Match
:= Value
;
1363 end Set_Default_Match
;
1369 procedure Free
(Str
: in out Cst_String_Access
) is
1370 function Convert
is new Ada
.Unchecked_Conversion
1371 (Cst_String_Access
, GNAT
.OS_Lib
.String_Access
);
1373 S
: GNAT
.OS_Lib
.String_Access
:= Convert
(Str
);
1380 ---------------------
1381 -- Reset_Directory --
1382 ---------------------
1384 procedure Reset_Directory
(File
: File_Reference
) is
1387 end Reset_Directory
;
1393 procedure Set_Unvisited
(File_Ref
: File_Reference
) is
1394 F
: constant String := Get_File
(File_Ref
, With_Dir
=> False);
1397 File_Ref
.Visited
:= False;
1399 -- ??? Do not add a source file to the list. This is true at
1400 -- least for gnatxref, and probably for gnatfind as well
1403 and then F
(F
'Last - 3 .. F
'Last) = "." & Osint
.ALI_Suffix
.all
1405 Unvisited_Files
:= new Unvisited_Files_Record
'
1407 Next => Unvisited_Files);
1411 ----------------------
1412 -- Get_Declarations --
1413 ----------------------
1415 function Get_Declarations
1416 (Sorted : Boolean := True)
1417 return Declaration_Array_Access
1419 Arr : constant Declaration_Array_Access :=
1420 new Declaration_Array (1 .. Entities_Count);
1421 Decl : Declaration_Reference := Entities_HTable.Get_First;
1422 Index : Natural := Arr'First;
1423 Tmp : Declaration_Reference;
1425 procedure Move (From : Natural; To : Natural);
1426 function Lt (Op1, Op2 : Natural) return Boolean;
1427 -- See GNAT.Heap_Sort_G
1433 function Lt (Op1, Op2 : Natural) return Boolean is
1436 return Is_Less_Than (Tmp, Arr (Op2));
1438 return Is_Less_Than (Arr (Op1), Tmp);
1440 return Is_Less_Than (Arr (Op1), Arr (Op2));
1448 procedure Move (From : Natural; To : Natural) is
1455 Arr (To) := Arr (From);
1459 package Decl_Sort is new GNAT.Heap_Sort_G (Move, Lt);
1461 -- Start of processing for Get_Declarations
1464 while Decl /= null loop
1465 Arr (Index) := Decl;
1467 Decl := Entities_HTable.Get_Next;
1470 if Sorted and then Arr'Length /= 0 then
1471 Decl_Sort.Sort (Entities_Count);
1475 end Get_Declarations;
1477 ----------------------
1478 -- References_Count --
1479 ----------------------
1481 function References_Count
1482 (Decl : Declaration_Reference;
1483 Get_Reads : Boolean := False;
1484 Get_Writes : Boolean := False;
1485 Get_Bodies : Boolean := False)
1488 function List_Length (E : Reference) return Natural;
1489 -- Return the number of references in E
1495 function List_Length (E : Reference) return Natural is
1497 E1 : Reference := E;
1500 while E1 /= null loop
1508 Length : Natural := 0;
1510 -- Start of processing for References_Count
1514 Length := List_Length (Decl.Ref_Ref);
1518 Length := Length + List_Length (Decl.Modif_Ref);
1522 Length := Length + List_Length (Decl.Body_Ref);
1526 end References_Count;
1528 ----------------------
1529 -- Store_References --
1530 ----------------------
1532 procedure Store_References
1533 (Decl : Declaration_Reference;
1534 Get_Writes : Boolean := False;
1535 Get_Reads : Boolean := False;
1536 Get_Bodies : Boolean := False;
1537 Get_Declaration : Boolean := False;
1538 Arr : in out Reference_Array;
1539 Index : in out Natural)
1541 procedure Add (List : Reference);
1542 -- Add all the references in List to Arr
1548 procedure Add (List : Reference) is
1549 E : Reference := List;
1551 while E /= null loop
1558 -- Start of processing for Store_References
1561 if Get_Declaration then
1570 Add (Decl.Modif_Ref);
1574 Add (Decl.Body_Ref);
1576 end Store_References;
1578 --------------------
1579 -- Get_References --
1580 --------------------
1582 function Get_References
1583 (Decl : Declaration_Reference;
1584 Get_Reads : Boolean := False;
1585 Get_Writes : Boolean := False;
1586 Get_Bodies : Boolean := False)
1587 return Reference_Array_Access
1589 Length : constant Natural :=
1590 References_Count (Decl, Get_Reads, Get_Writes, Get_Bodies);
1592 Arr : constant Reference_Array_Access :=
1593 new Reference_Array (1 .. Length);
1595 Index : Natural := Arr'First;
1600 Get_Writes => Get_Writes,
1601 Get_Reads => Get_Reads,
1602 Get_Bodies => Get_Bodies,
1603 Get_Declaration => False,
1607 if Arr'Length /= 0 then
1618 procedure Free (Arr : in out Reference_Array_Access) is
1619 procedure Internal is new Ada.Unchecked_Deallocation
1620 (Reference_Array, Reference_Array_Access);
1629 function Is_Parameter (Decl : Declaration_Reference) return Boolean is
1631 return Decl.Is_Parameter;