1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1998-2005 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 2, 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 COPYING. If not, write --
19 -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
20 -- Boston, MA 02110-1301, USA. --
22 -- GNAT was originally developed by the GNAT team at New York University. --
23 -- Extensive contributions were provided by Ada Core Technologies Inc. --
25 ------------------------------------------------------------------------------
27 with Types
; use Types
;
31 with Ada
.Unchecked_Conversion
;
32 with Ada
.Unchecked_Deallocation
;
33 with Ada
.Strings
.Fixed
;
36 with Ada
.Characters
.Handling
; use Ada
.Characters
.Handling
;
37 with Ada
.Strings
.Unbounded
; use Ada
.Strings
.Unbounded
;
39 with GNAT
.OS_Lib
; use GNAT
.OS_Lib
;
40 with GNAT
.Directory_Operations
; use GNAT
.Directory_Operations
;
41 with GNAT
.HTable
; use GNAT
.HTable
;
42 with GNAT
.Heap_Sort_G
;
44 package body Xr_Tabls
is
46 type HTable_Headers
is range 1 .. 10000;
48 procedure Set_Next
(E
: File_Reference
; Next
: File_Reference
);
49 function Next
(E
: File_Reference
) return File_Reference
;
50 function Get_Key
(E
: File_Reference
) return Cst_String_Access
;
51 function Hash
(F
: Cst_String_Access
) return HTable_Headers
;
52 function Equal
(F1
, F2
: Cst_String_Access
) return Boolean;
53 -- The five subprograms above are used to instanciate the static
54 -- htable to store the files that should be processed.
56 package File_HTable
is new GNAT
.HTable
.Static_HTable
57 (Header_Num
=> HTable_Headers
,
58 Element
=> File_Record
,
59 Elmt_Ptr
=> File_Reference
,
63 Key
=> Cst_String_Access
,
67 -- A hash table to store all the files referenced in the
68 -- application. The keys in this htable are the name of the files
69 -- themselves, therefore it is assumed that the source path
70 -- doesn't contain twice the same source or ALI file name
72 type Unvisited_Files_Record
;
73 type Unvisited_Files_Access
is access Unvisited_Files_Record
;
74 type Unvisited_Files_Record
is record
75 File
: File_Reference
;
76 Next
: Unvisited_Files_Access
;
78 -- A special list, in addition to File_HTable, that only stores
79 -- the files that haven't been visited so far. Note that the File
80 -- list points to some data in File_HTable, and thus should never be freed.
82 function Next
(E
: Declaration_Reference
) return Declaration_Reference
;
83 procedure Set_Next
(E
, Next
: Declaration_Reference
);
84 function Get_Key
(E
: Declaration_Reference
) return Cst_String_Access
;
85 -- The subprograms above are used to instanciate the static
86 -- htable to store the entities that have been found in the application
88 package Entities_HTable
is new GNAT
.HTable
.Static_HTable
89 (Header_Num
=> HTable_Headers
,
90 Element
=> Declaration_Record
,
91 Elmt_Ptr
=> Declaration_Reference
,
95 Key
=> Cst_String_Access
,
99 -- A hash table to store all the entities defined in the
100 -- application. For each entity, we store a list of its reference
101 -- locations as well.
102 -- The keys in this htable should be created with Key_From_Ref,
103 -- and are the file, line and column of the declaration, which are
104 -- unique for every entity.
106 Entities_Count
: Natural := 0;
107 -- Number of entities in Entities_HTable. This is used in the end
108 -- when sorting the table.
110 Longest_File_Name_In_Table
: Natural := 0;
111 Unvisited_Files
: Unvisited_Files_Access
:= null;
112 Directories
: Project_File_Ptr
;
113 Default_Match
: Boolean := False;
114 -- The above need commenting ???
116 function Parse_Gnatls_Src
return String;
117 -- Return the standard source directories (taking into account the
118 -- ADA_INCLUDE_PATH environment variable, if Osint.Add_Default_Search_Dirs
119 -- was called first).
121 function Parse_Gnatls_Obj
return String;
122 -- Return the standard object directories (taking into account the
123 -- ADA_OBJECTS_PATH environment variable).
125 function Key_From_Ref
126 (File_Ref
: File_Reference
;
130 -- Return a key for the symbol declared at File_Ref, Line,
131 -- Column. This key should be used for lookup in Entity_HTable
133 function Is_Less_Than
(Decl1
, Decl2
: Declaration_Reference
) return Boolean;
134 -- Compare two declarations. The comparison is case-insensitive.
136 function Is_Less_Than
(Ref1
, Ref2
: Reference
) return Boolean;
137 -- Compare two references
139 procedure Store_References
140 (Decl
: Declaration_Reference
;
141 Get_Writes
: Boolean := False;
142 Get_Reads
: Boolean := False;
143 Get_Bodies
: Boolean := False;
144 Get_Declaration
: Boolean := False;
145 Arr
: in out Reference_Array
;
146 Index
: in out Natural);
147 -- Store in Arr, starting at Index, all the references to Decl.
148 -- The Get_* parameters can be used to indicate which references should be
150 -- Constraint_Error will be raised if Arr is not big enough.
152 procedure Sort
(Arr
: in out Reference_Array
);
153 -- Sort an array of references.
154 -- Arr'First must be 1.
160 procedure Set_Next
(E
: File_Reference
; Next
: File_Reference
) is
166 (E
: Declaration_Reference
; Next
: Declaration_Reference
) is
175 function Get_Key
(E
: File_Reference
) return Cst_String_Access
is
180 function Get_Key
(E
: Declaration_Reference
) return Cst_String_Access
is
189 function Hash
(F
: Cst_String_Access
) return HTable_Headers
is
190 function H
is new GNAT
.HTable
.Hash
(HTable_Headers
);
200 function Equal
(F1
, F2
: Cst_String_Access
) return Boolean is
202 return F1
.all = F2
.all;
209 function Key_From_Ref
210 (File_Ref
: File_Reference
;
216 return File_Ref
.File
.all & Natural'Image (Line
) & Natural'Image (Column
);
219 ---------------------
220 -- Add_Declaration --
221 ---------------------
223 function Add_Declaration
224 (File_Ref
: File_Reference
;
228 Decl_Type
: Character;
229 Remove_Only
: Boolean := False;
230 Symbol_Match
: Boolean := True)
231 return Declaration_Reference
233 procedure Unchecked_Free
is new Ada
.Unchecked_Deallocation
234 (Declaration_Record
, Declaration_Reference
);
236 Key
: aliased constant String := Key_From_Ref
(File_Ref
, Line
, Column
);
238 New_Decl
: Declaration_Reference
:=
239 Entities_HTable
.Get
(Key
'Unchecked_Access);
241 Is_Parameter
: Boolean := False;
244 -- Insert the Declaration in the table. There might already be a
245 -- declaration in the table if the entity is a parameter, so we
246 -- need to check that first.
248 if New_Decl
/= null and then New_Decl
.Symbol_Length
= 0 then
249 Is_Parameter
:= New_Decl
.Is_Parameter
;
250 Entities_HTable
.Remove
(Key
'Unrestricted_Access);
251 Entities_Count
:= Entities_Count
- 1;
253 Unchecked_Free
(New_Decl
);
257 -- The declaration might also already be there for parent types. In
258 -- this case, we should keep the entry, since some other entries are
262 and then not Remove_Only
265 new Declaration_Record
'
266 (Symbol_Length => Symbol'Length,
268 Key => new String'(Key
),
269 Decl
=> new Reference_Record
'
275 Is_Parameter => Is_Parameter,
276 Decl_Type => Decl_Type,
280 Match => Symbol_Match
283 or else Match (File_Ref, Line, Column)),
287 Entities_HTable.Set (New_Decl);
288 Entities_Count := Entities_Count + 1;
290 if New_Decl.Match then
291 Longest_File_Name_In_Table :=
292 Natural'Max (File_Ref.File'Length, Longest_File_Name_In_Table);
295 elsif New_Decl /= null
296 and then not New_Decl.Match
298 New_Decl.Match := Default_Match
299 or else Match (File_Ref, Line, Column);
305 ----------------------
306 -- Add_To_Xref_File --
307 ----------------------
309 function Add_To_Xref_File
311 Visited : Boolean := True;
312 Emit_Warning : Boolean := False;
313 Gnatchop_File : String := "";
314 Gnatchop_Offset : Integer := 0) return File_Reference
316 Base : aliased constant String := Base_Name (File_Name);
317 Dir : constant String := Dir_Name (File_Name);
318 Dir_Acc : GNAT.OS_Lib.String_Access := null;
319 Ref : File_Reference;
322 -- Do we have a directory name as well?
324 if File_Name /= Base then
325 Dir_Acc := new String'(Dir
);
328 Ref
:= File_HTable
.Get
(Base
'Unchecked_Access);
330 Ref
:= new File_Record
'
331 (File => new String'(Base
),
335 Emit_Warning
=> Emit_Warning
,
336 Gnatchop_File
=> new String'(Gnatchop_File),
337 Gnatchop_Offset => Gnatchop_Offset,
339 File_HTable.Set (Ref);
343 -- Keep a separate list for faster access
349 end Add_To_Xref_File;
356 (File : File_Reference;
361 File.Lines := new Ref_In_File'(Line
=> Line
,
371 (Declaration
: in out Declaration_Reference
;
375 File_Ref
: File_Reference
)
378 Declaration
.Par_Symbol
:=
380 (File_Ref
, Symbol
, Line
, Column
,
382 Symbol_Match
=> False);
389 procedure Add_Reference
390 (Declaration
: Declaration_Reference
;
391 File_Ref
: File_Reference
;
394 Ref_Type
: Character;
395 Labels_As_Ref
: Boolean)
401 when 'b' |
'c' |
'm' |
'r' |
'i' |
' ' |
'x' =>
405 if not Labels_As_Ref
then
409 when '=' |
'<' |
'>' |
'^' =>
411 -- Create a dummy declaration in the table to report it as a
412 -- parameter. Note that the current declaration for the subprogram
413 -- comes before the declaration of the parameter.
416 Key
: constant String :=
417 Key_From_Ref
(File_Ref
, Line
, Column
);
418 New_Decl
: Declaration_Reference
;
421 New_Decl
:= new Declaration_Record
'
424 Key => new String'(Key
),
426 Is_Parameter
=> True,
434 Entities_HTable
.Set
(New_Decl
);
435 Entities_Count
:= Entities_Count
+ 1;
438 when 'e' |
'z' |
't' |
'p' |
'P' |
'k' |
'd' =>
442 Ada
.Text_IO
.Put_Line
("Unknown reference type: " & Ref_Type
);
446 New_Ref
:= new Reference_Record
'
453 -- We can insert the reference in the list directly, since all
454 -- the references will appear only once in the ALI file
455 -- corresponding to the file where they are referenced.
456 -- This saves a lot of time compared to checking the list to check
461 New_Ref.Next := Declaration.Body_Ref;
462 Declaration.Body_Ref := New_Ref;
464 when 'r
' | 'i
' | 'l
' | ' ' | 'x
' | 'w
' =>
465 New_Ref.Next := Declaration.Ref_Ref;
466 Declaration.Ref_Ref := New_Ref;
469 New_Ref.Next := Declaration.Modif_Ref;
470 Declaration.Modif_Ref := New_Ref;
476 if not Declaration.Match then
477 Declaration.Match := Match (File_Ref, Line, Column);
480 if Declaration.Match then
481 Longest_File_Name_In_Table :=
482 Natural'Max (File_Ref.File'Length, Longest_File_Name_In_Table);
490 function ALI_File_Name (Ada_File_Name : String) return String is
492 -- ??? Should ideally be based on the naming scheme defined in
495 Index : constant Natural :=
496 Ada.Strings.Fixed.Index
497 (Ada_File_Name, ".", Going => Ada.Strings.Backward);
501 return Ada_File_Name (Ada_File_Name'First .. Index) & "ali";
503 return Ada_File_Name & ".ali";
511 function Is_Less_Than (Ref1, Ref2 : Reference) return Boolean is
515 elsif Ref2 = null then
519 if Ref1.File.File.all < Ref2.File.File.all then
522 elsif Ref1.File.File.all = Ref2.File.File.all then
523 return (Ref1.Line < Ref2.Line
524 or else (Ref1.Line = Ref2.Line
525 and then Ref1.Column < Ref2.Column));
535 function Is_Less_Than (Decl1, Decl2 : Declaration_Reference) return Boolean
537 -- We cannot store the data case-insensitive in the table,
538 -- since we wouldn't be able to find the right casing for the
541 S1 : constant String := To_Lower (Decl1.Symbol);
542 S2 : constant String := To_Lower (Decl2.Symbol);
551 return Decl1.Key.all < Decl2.Key.all;
554 -------------------------
555 -- Create_Project_File --
556 -------------------------
558 procedure Create_Project_File (Name : String) is
559 Obj_Dir : Unbounded_String := Null_Unbounded_String;
560 Src_Dir : Unbounded_String := Null_Unbounded_String;
561 Build_Dir : GNAT.OS_Lib.String_Access := new String'("");
565 File_Name
: aliased String := Name
& ASCII
.NUL
;
568 -- Read the size of the file
570 F
:= Open_Read
(File_Name
'Address, Text
);
572 -- Project file not found
574 if F
/= Invalid_FD
then
575 Len
:= Positive (File_Length
(F
));
578 Buffer
: String (1 .. Len
);
579 Index
: Positive := Buffer
'First;
583 Len
:= Read
(F
, Buffer
'Address, Len
);
586 -- First, look for Build_Dir, since all the source and object
587 -- path are relative to it.
589 while Index
<= Buffer
'Last loop
591 -- Find the end of line
594 while Last
<= Buffer
'Last
595 and then Buffer
(Last
) /= ASCII
.LF
596 and then Buffer
(Last
) /= ASCII
.CR
601 if Index
<= Buffer
'Last - 9
602 and then Buffer
(Index
.. Index
+ 9) = "build_dir="
606 and then (Buffer
(Index
) = ' '
607 or else Buffer
(Index
) = ASCII
.HT
)
613 Build_Dir
:= new String'(Buffer (Index .. Last - 1));
618 -- In case we had a ASCII.CR/ASCII.LF end of line, skip the
621 if Index <= Buffer'Last
622 and then Buffer (Index) = ASCII.LF
628 -- Now parse the source and object paths
630 Index := Buffer'First;
631 while Index <= Buffer'Last loop
633 -- Find the end of line
636 while Last <= Buffer'Last
637 and then Buffer (Last) /= ASCII.LF
638 and then Buffer (Last) /= ASCII.CR
643 if Index <= Buffer'Last - 7
644 and then Buffer (Index .. Index + 7) = "src_dir="
646 Append (Src_Dir, Normalize_Pathname
647 (Name => Ada.Strings.Fixed.Trim
648 (Buffer (Index + 8 .. Last - 1), Ada.Strings.Both),
649 Directory => Build_Dir.all) & Path_Separator);
651 elsif Index <= Buffer'Last - 7
652 and then Buffer (Index .. Index + 7) = "obj_dir="
654 Append (Obj_Dir, Normalize_Pathname
655 (Name => Ada.Strings.Fixed.Trim
656 (Buffer (Index + 8 .. Last - 1), Ada.Strings.Both),
657 Directory => Build_Dir.all) & Path_Separator);
660 -- In case we had a ASCII.CR/ASCII.LF end of line, skip the
664 if Index <= Buffer'Last
665 and then Buffer (Index) = ASCII.LF
673 Osint.Add_Default_Search_Dirs;
676 Src : constant String := Parse_Gnatls_Src;
677 Obj : constant String := Parse_Gnatls_Obj;
680 Directories := new Project_File'
681 (Src_Dir_Length
=> Length
(Src_Dir
) + Src
'Length,
682 Obj_Dir_Length
=> Length
(Obj_Dir
) + Obj
'Length,
683 Src_Dir
=> To_String
(Src_Dir
) & Src
,
684 Obj_Dir
=> To_String
(Obj_Dir
) & Obj
,
687 Last_Obj_Dir_Start
=> 0);
691 end Create_Project_File
;
693 ---------------------
694 -- Current_Obj_Dir --
695 ---------------------
697 function Current_Obj_Dir
return String is
699 return Directories
.Obj_Dir
700 (Directories
.Last_Obj_Dir_Start
.. Directories
.Obj_Dir_Index
- 2);
707 function Get_Column
(Decl
: Declaration_Reference
) return String is
709 return Ada
.Strings
.Fixed
.Trim
(Natural'Image (Decl
.Decl
.Column
),
713 function Get_Column
(Ref
: Reference
) return String is
715 return Ada
.Strings
.Fixed
.Trim
(Natural'Image (Ref
.Column
),
719 ---------------------
720 -- Get_Declaration --
721 ---------------------
723 function Get_Declaration
724 (File_Ref
: File_Reference
;
727 return Declaration_Reference
729 Key
: aliased constant String := Key_From_Ref
(File_Ref
, Line
, Column
);
732 return Entities_HTable
.Get
(Key
'Unchecked_Access);
735 ----------------------
736 -- Get_Emit_Warning --
737 ----------------------
739 function Get_Emit_Warning
(File
: File_Reference
) return Boolean is
741 return File
.Emit_Warning
;
742 end Get_Emit_Warning
;
749 (Decl
: Declaration_Reference
;
750 With_Dir
: Boolean := False) return String
753 return Get_File
(Decl
.Decl
.File
, With_Dir
);
758 With_Dir
: Boolean := False) return String
761 return Get_File
(Ref
.File
, With_Dir
);
765 (File
: File_Reference
;
766 With_Dir
: in Boolean := False;
767 Strip
: Natural := 0) return String
769 Tmp
: GNAT
.OS_Lib
.String_Access
;
771 function Internal_Strip
(Full_Name
: String) return String;
772 -- Internal function to process the Strip parameter
778 function Internal_Strip
(Full_Name
: String) return String is
780 Extension_Start
: Natural;
788 -- Isolate the file extension
790 Extension_Start
:= Full_Name
'Last;
791 while Extension_Start
>= Full_Name
'First
792 and then Full_Name
(Extension_Start
) /= '.'
794 Extension_Start
:= Extension_Start
- 1;
797 -- Strip the right number of subunit_names
800 Unit_End
:= Extension_Start
- 1;
801 while Unit_End
>= Full_Name
'First
804 if Full_Name
(Unit_End
) = '-' then
808 Unit_End
:= Unit_End
- 1;
811 if Unit_End
< Full_Name
'First then
814 return Full_Name
(Full_Name
'First .. Unit_End
)
815 & Full_Name
(Extension_Start
.. Full_Name
'Last);
819 -- Start of processing for Get_File;
822 -- If we do not want the full path name
825 return Internal_Strip
(File
.File
.all);
828 if File
.Dir
= null then
829 if Ada
.Strings
.Fixed
.Tail
(File
.File
.all, 3) = "ali" then
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 -- Things are not simple on VMS due to the plethora of file types
1143 -- and organizations. It seems clear that there shouldn't be more
1144 -- bytes read than are contained in the file though.
1146 if (Hostparm
.OpenVMS
and then Read_Ptr
> Length
+ 1)
1147 or else (not Hostparm
.OpenVMS
and then Read_Ptr
/= Length
+ 1)
1149 raise Ada
.Text_IO
.End_Error
;
1156 -----------------------
1157 -- Longest_File_Name --
1158 -----------------------
1160 function Longest_File_Name
return Natural is
1162 return Longest_File_Name_In_Table
;
1163 end Longest_File_Name
;
1170 (File
: File_Reference
;
1175 Ref
: Ref_In_File_Ptr
:= File
.Lines
;
1178 while Ref
/= null loop
1179 if (Ref
.Line
= 0 or else Ref
.Line
= Line
)
1180 and then (Ref
.Column
= 0 or else Ref
.Column
= Column
)
1195 function Match
(Decl
: Declaration_Reference
) return Boolean is
1204 function Next
(E
: File_Reference
) return File_Reference
is
1209 function Next
(E
: Declaration_Reference
) return Declaration_Reference
is
1218 function Next_Obj_Dir
return String is
1219 First
: constant Integer := Directories
.Obj_Dir_Index
;
1223 Last
:= Directories
.Obj_Dir_Index
;
1225 if Last
> Directories
.Obj_Dir_Length
then
1226 return String'(1 .. 0 => ' ');
1229 while Directories.Obj_Dir (Last) /= Path_Separator loop
1233 Directories.Obj_Dir_Index := Last + 1;
1234 Directories.Last_Obj_Dir_Start := First;
1235 return Directories.Obj_Dir (First .. Last - 1);
1238 -------------------------
1239 -- Next_Unvisited_File --
1240 -------------------------
1242 function Next_Unvisited_File return File_Reference is
1243 procedure Unchecked_Free is new Ada.Unchecked_Deallocation
1244 (Unvisited_Files_Record, Unvisited_Files_Access);
1246 Ref : File_Reference;
1247 Tmp : Unvisited_Files_Access;
1250 if Unvisited_Files = null then
1253 Tmp := Unvisited_Files;
1254 Ref := Unvisited_Files.File;
1255 Unvisited_Files := Unvisited_Files.Next;
1256 Unchecked_Free (Tmp);
1259 end Next_Unvisited_File;
1261 ----------------------
1262 -- Parse_Gnatls_Src --
1263 ----------------------
1265 function Parse_Gnatls_Src return String is
1270 for J in 1 .. Osint.Nb_Dir_In_Src_Search_Path loop
1271 if Osint.Dir_In_Src_Search_Path (J)'Length = 0 then
1272 Length := Length + 2;
1274 Length := Length + Osint.Dir_In_Src_Search_Path (J)'Length + 1;
1279 Result : String (1 .. Length);
1284 for J in 1 .. Osint.Nb_Dir_In_Src_Search_Path loop
1285 if Osint.Dir_In_Src_Search_Path (J)'Length = 0 then
1286 Result (L .. L + 1) := "." & Path_Separator;
1290 Result (L .. L + Osint.Dir_In_Src_Search_Path (J)'Length - 1) :=
1291 Osint.Dir_In_Src_Search_Path (J).all;
1292 L := L + Osint.Dir_In_Src_Search_Path (J)'Length;
1293 Result (L) := Path_Separator;
1300 end Parse_Gnatls_Src;
1302 ----------------------
1303 -- Parse_Gnatls_Obj --
1304 ----------------------
1306 function Parse_Gnatls_Obj return String is
1311 for J in 1 .. Osint.Nb_Dir_In_Obj_Search_Path loop
1312 if Osint.Dir_In_Obj_Search_Path (J)'Length = 0 then
1313 Length := Length + 2;
1315 Length := Length + Osint.Dir_In_Obj_Search_Path (J)'Length + 1;
1320 Result : String (1 .. Length);
1325 for J in 1 .. Osint.Nb_Dir_In_Obj_Search_Path loop
1326 if Osint.Dir_In_Obj_Search_Path (J)'Length = 0 then
1327 Result (L .. L + 1) := "." & Path_Separator;
1330 Result (L .. L + Osint.Dir_In_Obj_Search_Path (J)'Length - 1) :=
1331 Osint.Dir_In_Obj_Search_Path (J).all;
1332 L := L + Osint.Dir_In_Obj_Search_Path (J)'Length;
1333 Result (L) := Path_Separator;
1340 end Parse_Gnatls_Obj;
1346 procedure Reset_Obj_Dir is
1348 Directories.Obj_Dir_Index := 1;
1351 -----------------------
1352 -- Set_Default_Match --
1353 -----------------------
1355 procedure Set_Default_Match (Value : Boolean) is
1357 Default_Match := Value;
1358 end Set_Default_Match;
1364 procedure Free (Str : in out Cst_String_Access) is
1365 function Convert is new Ada.Unchecked_Conversion
1366 (Cst_String_Access, GNAT.OS_Lib.String_Access);
1368 S : GNAT.OS_Lib.String_Access := Convert (Str);
1375 ---------------------
1376 -- Reset_Directory --
1377 ---------------------
1379 procedure Reset_Directory (File : File_Reference) is
1382 end Reset_Directory;
1388 procedure Set_Unvisited (File_Ref : File_Reference) is
1389 F : constant String := Get_File (File_Ref, With_Dir => False);
1392 File_Ref.Visited := False;
1394 -- ??? Do not add a source file to the list. This is true at
1395 -- least for gnatxref, and probably for gnatfind as wel
1398 and then F (F'Last - 3 .. F'Last) = ".ali"
1400 Unvisited_Files := new Unvisited_Files_Record'
1402 Next
=> Unvisited_Files
);
1406 ----------------------
1407 -- Get_Declarations --
1408 ----------------------
1410 function Get_Declarations
1411 (Sorted
: Boolean := True)
1412 return Declaration_Array_Access
1414 Arr
: constant Declaration_Array_Access
:=
1415 new Declaration_Array
(1 .. Entities_Count
);
1416 Decl
: Declaration_Reference
:= Entities_HTable
.Get_First
;
1417 Index
: Natural := Arr
'First;
1418 Tmp
: Declaration_Reference
;
1420 procedure Move
(From
: Natural; To
: Natural);
1421 function Lt
(Op1
, Op2
: Natural) return Boolean;
1422 -- See GNAT.Heap_Sort_G
1428 function Lt
(Op1
, Op2
: Natural) return Boolean is
1431 return Is_Less_Than
(Tmp
, Arr
(Op2
));
1433 return Is_Less_Than
(Arr
(Op1
), Tmp
);
1435 return Is_Less_Than
(Arr
(Op1
), Arr
(Op2
));
1443 procedure Move
(From
: Natural; To
: Natural) is
1450 Arr
(To
) := Arr
(From
);
1454 package Decl_Sort
is new GNAT
.Heap_Sort_G
(Move
, Lt
);
1456 -- Start of processing for Get_Declarations
1459 while Decl
/= null loop
1460 Arr
(Index
) := Decl
;
1462 Decl
:= Entities_HTable
.Get_Next
;
1465 if Sorted
and then Arr
'Length /= 0 then
1466 Decl_Sort
.Sort
(Entities_Count
);
1470 end Get_Declarations
;
1472 ----------------------
1473 -- References_Count --
1474 ----------------------
1476 function References_Count
1477 (Decl
: Declaration_Reference
;
1478 Get_Reads
: Boolean := False;
1479 Get_Writes
: Boolean := False;
1480 Get_Bodies
: Boolean := False)
1483 function List_Length
(E
: Reference
) return Natural;
1484 -- Return the number of references in E
1490 function List_Length
(E
: Reference
) return Natural is
1492 E1
: Reference
:= E
;
1495 while E1
/= null loop
1503 Length
: Natural := 0;
1505 -- Start of processing for References_Count
1509 Length
:= List_Length
(Decl
.Ref_Ref
);
1513 Length
:= Length
+ List_Length
(Decl
.Modif_Ref
);
1517 Length
:= Length
+ List_Length
(Decl
.Body_Ref
);
1521 end References_Count
;
1523 ----------------------
1524 -- Store_References --
1525 ----------------------
1527 procedure Store_References
1528 (Decl
: Declaration_Reference
;
1529 Get_Writes
: Boolean := False;
1530 Get_Reads
: Boolean := False;
1531 Get_Bodies
: Boolean := False;
1532 Get_Declaration
: Boolean := False;
1533 Arr
: in out Reference_Array
;
1534 Index
: in out Natural)
1536 procedure Add
(List
: Reference
);
1537 -- Add all the references in List to Arr
1543 procedure Add
(List
: Reference
) is
1544 E
: Reference
:= List
;
1546 while E
/= null loop
1553 -- Start of processing for Store_References
1556 if Get_Declaration
then
1565 Add
(Decl
.Modif_Ref
);
1569 Add
(Decl
.Body_Ref
);
1571 end Store_References
;
1573 --------------------
1574 -- Get_References --
1575 --------------------
1577 function Get_References
1578 (Decl
: Declaration_Reference
;
1579 Get_Reads
: Boolean := False;
1580 Get_Writes
: Boolean := False;
1581 Get_Bodies
: Boolean := False)
1582 return Reference_Array_Access
1584 Length
: constant Natural :=
1585 References_Count
(Decl
, Get_Reads
, Get_Writes
, Get_Bodies
);
1587 Arr
: constant Reference_Array_Access
:=
1588 new Reference_Array
(1 .. Length
);
1590 Index
: Natural := Arr
'First;
1595 Get_Writes
=> Get_Writes
,
1596 Get_Reads
=> Get_Reads
,
1597 Get_Bodies
=> Get_Bodies
,
1598 Get_Declaration
=> False,
1602 if Arr
'Length /= 0 then
1613 procedure Free
(Arr
: in out Reference_Array_Access
) is
1614 procedure Internal
is new Ada
.Unchecked_Deallocation
1615 (Reference_Array
, Reference_Array_Access
);
1624 function Is_Parameter
(Decl
: Declaration_Reference
) return Boolean is
1626 return Decl
.Is_Parameter
;