|
111
|
1 ------------------------------------------------------------------------------
|
|
|
2 -- --
|
|
|
3 -- GNAT COMPILER COMPONENTS --
|
|
|
4 -- --
|
|
|
5 -- X R _ T A B L S --
|
|
|
6 -- --
|
|
|
7 -- B o d y --
|
|
|
8 -- --
|
|
131
|
9 -- Copyright (C) 1998-2018, Free Software Foundation, Inc. --
|
|
111
|
10 -- --
|
|
|
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. --
|
|
|
20 -- --
|
|
|
21 -- GNAT was originally developed by the GNAT team at New York University. --
|
|
|
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
|
|
|
23 -- --
|
|
|
24 ------------------------------------------------------------------------------
|
|
|
25
|
|
|
26 with Types; use Types;
|
|
|
27 with Osint;
|
|
|
28
|
|
|
29 with Ada.Unchecked_Conversion;
|
|
|
30 with Ada.Unchecked_Deallocation;
|
|
|
31 with Ada.Strings.Fixed;
|
|
|
32 with Ada.Strings;
|
|
|
33 with Ada.Text_IO;
|
|
|
34 with Ada.Characters.Handling; use Ada.Characters.Handling;
|
|
|
35 with Ada.Strings.Unbounded; use Ada.Strings.Unbounded;
|
|
|
36
|
|
|
37 with GNAT.OS_Lib; use GNAT.OS_Lib;
|
|
|
38 with GNAT.Directory_Operations; use GNAT.Directory_Operations;
|
|
|
39 with GNAT.HTable;
|
|
|
40 with GNAT.Heap_Sort_G;
|
|
|
41
|
|
|
42 package body Xr_Tabls is
|
|
|
43
|
|
|
44 type HTable_Headers is range 1 .. 10000;
|
|
|
45
|
|
|
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.
|
|
|
53
|
|
|
54 package File_HTable is new GNAT.HTable.Static_HTable
|
|
|
55 (Header_Num => HTable_Headers,
|
|
|
56 Element => File_Record,
|
|
|
57 Elmt_Ptr => File_Reference,
|
|
|
58 Null_Ptr => null,
|
|
|
59 Set_Next => Set_Next,
|
|
|
60 Next => Next,
|
|
|
61 Key => Cst_String_Access,
|
|
|
62 Get_Key => Get_Key,
|
|
|
63 Hash => Hash,
|
|
|
64 Equal => Equal);
|
|
|
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
|
|
|
69
|
|
|
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;
|
|
|
75 end record;
|
|
|
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.
|
|
|
79
|
|
|
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
|
|
|
85
|
|
|
86 package Entities_HTable is new GNAT.HTable.Static_HTable
|
|
|
87 (Header_Num => HTable_Headers,
|
|
|
88 Element => Declaration_Record,
|
|
|
89 Elmt_Ptr => Declaration_Reference,
|
|
|
90 Null_Ptr => null,
|
|
|
91 Set_Next => Set_Next,
|
|
|
92 Next => Next,
|
|
|
93 Key => Cst_String_Access,
|
|
|
94 Get_Key => Get_Key,
|
|
|
95 Hash => Hash,
|
|
|
96 Equal => Equal);
|
|
|
97 -- A hash table to store all the entities defined in the
|
|
|
98 -- application. For each entity, we store a list of its reference
|
|
|
99 -- locations as well.
|
|
|
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.
|
|
|
103
|
|
|
104 Entities_Count : Natural := 0;
|
|
|
105 -- Number of entities in Entities_HTable. This is used in the end
|
|
|
106 -- when sorting the table.
|
|
|
107
|
|
|
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 ???
|
|
|
113
|
|
|
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).
|
|
|
118
|
|
|
119 function Parse_Gnatls_Obj return String;
|
|
|
120 -- Return the standard object directories (taking into account the
|
|
|
121 -- ADA_OBJECTS_PATH environment variable).
|
|
|
122
|
|
|
123 function Key_From_Ref
|
|
|
124 (File_Ref : File_Reference;
|
|
|
125 Line : Natural;
|
|
|
126 Column : Natural)
|
|
|
127 return String;
|
|
|
128 -- Return a key for the symbol declared at File_Ref, Line,
|
|
|
129 -- Column. This key should be used for lookup in Entity_HTable
|
|
|
130
|
|
|
131 function Is_Less_Than (Decl1, Decl2 : Declaration_Reference) return Boolean;
|
|
|
132 -- Compare two declarations (the comparison is case-insensitive)
|
|
|
133
|
|
|
134 function Is_Less_Than (Ref1, Ref2 : Reference) return Boolean;
|
|
|
135 -- Compare two references
|
|
|
136
|
|
|
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.
|
|
|
148
|
|
|
149 procedure Sort (Arr : in out Reference_Array);
|
|
|
150 -- Sort an array of references (Arr'First must be 1)
|
|
|
151
|
|
|
152 --------------
|
|
|
153 -- Set_Next --
|
|
|
154 --------------
|
|
|
155
|
|
|
156 procedure Set_Next (E : File_Reference; Next : File_Reference) is
|
|
|
157 begin
|
|
|
158 E.Next := Next;
|
|
|
159 end Set_Next;
|
|
|
160
|
|
|
161 procedure Set_Next
|
|
|
162 (E : Declaration_Reference; Next : Declaration_Reference) is
|
|
|
163 begin
|
|
|
164 E.Next := Next;
|
|
|
165 end Set_Next;
|
|
|
166
|
|
|
167 -------------
|
|
|
168 -- Get_Key --
|
|
|
169 -------------
|
|
|
170
|
|
|
171 function Get_Key (E : File_Reference) return Cst_String_Access is
|
|
|
172 begin
|
|
|
173 return E.File;
|
|
|
174 end Get_Key;
|
|
|
175
|
|
|
176 function Get_Key (E : Declaration_Reference) return Cst_String_Access is
|
|
|
177 begin
|
|
|
178 return E.Key;
|
|
|
179 end Get_Key;
|
|
|
180
|
|
|
181 ----------
|
|
|
182 -- Hash --
|
|
|
183 ----------
|
|
|
184
|
|
|
185 function Hash (F : Cst_String_Access) return HTable_Headers is
|
|
|
186 function H is new GNAT.HTable.Hash (HTable_Headers);
|
|
|
187
|
|
|
188 begin
|
|
|
189 return H (F.all);
|
|
|
190 end Hash;
|
|
|
191
|
|
|
192 -----------
|
|
|
193 -- Equal --
|
|
|
194 -----------
|
|
|
195
|
|
|
196 function Equal (F1, F2 : Cst_String_Access) return Boolean is
|
|
|
197 begin
|
|
|
198 return F1.all = F2.all;
|
|
|
199 end Equal;
|
|
|
200
|
|
|
201 ------------------
|
|
|
202 -- Key_From_Ref --
|
|
|
203 ------------------
|
|
|
204
|
|
|
205 function Key_From_Ref
|
|
|
206 (File_Ref : File_Reference;
|
|
|
207 Line : Natural;
|
|
|
208 Column : Natural)
|
|
|
209 return String
|
|
|
210 is
|
|
|
211 begin
|
|
|
212 return File_Ref.File.all & Natural'Image (Line) & Natural'Image (Column);
|
|
|
213 end Key_From_Ref;
|
|
|
214
|
|
|
215 ---------------------
|
|
|
216 -- Add_Declaration --
|
|
|
217 ---------------------
|
|
|
218
|
|
|
219 function Add_Declaration
|
|
|
220 (File_Ref : File_Reference;
|
|
|
221 Symbol : String;
|
|
|
222 Line : Natural;
|
|
|
223 Column : Natural;
|
|
|
224 Decl_Type : Character;
|
|
|
225 Is_Parameter : Boolean := False;
|
|
|
226 Remove_Only : Boolean := False;
|
|
|
227 Symbol_Match : Boolean := True)
|
|
|
228 return Declaration_Reference
|
|
|
229 is
|
|
|
230 procedure Unchecked_Free is new Ada.Unchecked_Deallocation
|
|
|
231 (Declaration_Record, Declaration_Reference);
|
|
|
232
|
|
|
233 Key : aliased constant String := Key_From_Ref (File_Ref, Line, Column);
|
|
|
234
|
|
|
235 New_Decl : Declaration_Reference :=
|
|
|
236 Entities_HTable.Get (Key'Unchecked_Access);
|
|
|
237
|
|
|
238 Is_Param : Boolean := Is_Parameter;
|
|
|
239
|
|
|
240 begin
|
|
|
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.
|
|
|
244
|
|
|
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;
|
|
|
249 Free (New_Decl.Key);
|
|
|
250 Unchecked_Free (New_Decl);
|
|
|
251 New_Decl := null;
|
|
|
252 end if;
|
|
|
253
|
|
|
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
|
|
|
256 -- pointing to it.
|
|
|
257
|
|
|
258 if New_Decl = null
|
|
|
259 and then not Remove_Only
|
|
|
260 then
|
|
|
261 New_Decl :=
|
|
|
262 new Declaration_Record'
|
|
|
263 (Symbol_Length => Symbol'Length,
|
|
|
264 Symbol => Symbol,
|
|
|
265 Key => new String'(Key),
|
|
|
266 Decl => new Reference_Record'
|
|
|
267 (File => File_Ref,
|
|
|
268 Line => Line,
|
|
|
269 Column => Column,
|
|
|
270 Source_Line => null,
|
|
|
271 Next => null),
|
|
|
272 Is_Parameter => Is_Param,
|
|
|
273 Decl_Type => Decl_Type,
|
|
|
274 Body_Ref => null,
|
|
|
275 Ref_Ref => null,
|
|
|
276 Modif_Ref => null,
|
|
|
277 Match => Symbol_Match
|
|
|
278 and then
|
|
|
279 (Default_Match
|
|
|
280 or else Match (File_Ref, Line, Column)),
|
|
|
281 Par_Symbol => null,
|
|
|
282 Next => null);
|
|
|
283
|
|
|
284 Entities_HTable.Set (New_Decl);
|
|
|
285 Entities_Count := Entities_Count + 1;
|
|
|
286
|
|
|
287 if New_Decl.Match then
|
|
|
288 Longest_File_Name_In_Table :=
|
|
|
289 Natural'Max (File_Ref.File'Length, Longest_File_Name_In_Table);
|
|
|
290 end if;
|
|
|
291
|
|
|
292 elsif New_Decl /= null
|
|
|
293 and then not New_Decl.Match
|
|
|
294 then
|
|
|
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;
|
|
|
298
|
|
|
299 elsif New_Decl /= null then
|
|
|
300 New_Decl.Is_Parameter := New_Decl.Is_Parameter or Is_Param;
|
|
|
301 end if;
|
|
|
302
|
|
|
303 return New_Decl;
|
|
|
304 end Add_Declaration;
|
|
|
305
|
|
|
306 ----------------------
|
|
|
307 -- Add_To_Xref_File --
|
|
|
308 ----------------------
|
|
|
309
|
|
|
310 function Add_To_Xref_File
|
|
|
311 (File_Name : String;
|
|
|
312 Visited : Boolean := True;
|
|
|
313 Emit_Warning : Boolean := False;
|
|
|
314 Gnatchop_File : String := "";
|
|
|
315 Gnatchop_Offset : Integer := 0) return File_Reference
|
|
|
316 is
|
|
|
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;
|
|
|
321
|
|
|
322 begin
|
|
|
323 -- Do we have a directory name as well?
|
|
|
324
|
|
|
325 if File_Name /= Base then
|
|
|
326 Dir_Acc := new String'(Dir);
|
|
|
327 end if;
|
|
|
328
|
|
|
329 Ref := File_HTable.Get (Base'Unchecked_Access);
|
|
|
330 if Ref = null then
|
|
|
331 Ref := new File_Record'
|
|
|
332 (File => new String'(Base),
|
|
|
333 Dir => Dir_Acc,
|
|
|
334 Lines => null,
|
|
|
335 Visited => Visited,
|
|
|
336 Emit_Warning => Emit_Warning,
|
|
|
337 Gnatchop_File => new String'(Gnatchop_File),
|
|
|
338 Gnatchop_Offset => Gnatchop_Offset,
|
|
|
339 Next => null);
|
|
|
340 File_HTable.Set (Ref);
|
|
|
341
|
|
|
342 if not Visited then
|
|
|
343
|
|
|
344 -- Keep a separate list for faster access
|
|
|
345
|
|
|
346 Set_Unvisited (Ref);
|
|
|
347 end if;
|
|
|
348 end if;
|
|
|
349 return Ref;
|
|
|
350 end Add_To_Xref_File;
|
|
|
351
|
|
|
352 --------------
|
|
|
353 -- Add_Line --
|
|
|
354 --------------
|
|
|
355
|
|
|
356 procedure Add_Line
|
|
|
357 (File : File_Reference;
|
|
|
358 Line : Natural;
|
|
|
359 Column : Natural)
|
|
|
360 is
|
|
|
361 begin
|
|
|
362 File.Lines := new Ref_In_File'(Line => Line,
|
|
|
363 Column => Column,
|
|
|
364 Next => File.Lines);
|
|
|
365 end Add_Line;
|
|
|
366
|
|
|
367 ----------------
|
|
|
368 -- Add_Parent --
|
|
|
369 ----------------
|
|
|
370
|
|
|
371 procedure Add_Parent
|
|
|
372 (Declaration : in out Declaration_Reference;
|
|
|
373 Symbol : String;
|
|
|
374 Line : Natural;
|
|
|
375 Column : Natural;
|
|
|
376 File_Ref : File_Reference)
|
|
|
377 is
|
|
|
378 begin
|
|
|
379 Declaration.Par_Symbol :=
|
|
|
380 Add_Declaration
|
|
|
381 (File_Ref, Symbol, Line, Column,
|
|
|
382 Decl_Type => ' ',
|
|
|
383 Symbol_Match => False);
|
|
|
384 end Add_Parent;
|
|
|
385
|
|
|
386 -------------------
|
|
|
387 -- Add_Reference --
|
|
|
388 -------------------
|
|
|
389
|
|
|
390 procedure Add_Reference
|
|
|
391 (Declaration : Declaration_Reference;
|
|
|
392 File_Ref : File_Reference;
|
|
|
393 Line : Natural;
|
|
|
394 Column : Natural;
|
|
|
395 Ref_Type : Character;
|
|
|
396 Labels_As_Ref : Boolean)
|
|
|
397 is
|
|
|
398 New_Ref : Reference;
|
|
|
399 New_Decl : Declaration_Reference;
|
|
|
400 pragma Unreferenced (New_Decl);
|
|
|
401
|
|
|
402 begin
|
|
|
403 case Ref_Type is
|
|
|
404 when ' ' | 'b' | 'c' | 'H' | 'i' | 'm' | 'o' | 'r' | 'R' | 's' | 'x'
|
|
|
405 =>
|
|
|
406 null;
|
|
|
407
|
|
|
408 when 'l' | 'w' =>
|
|
|
409 if not Labels_As_Ref then
|
|
|
410 return;
|
|
|
411 end if;
|
|
|
412
|
|
|
413 when '=' | '<' | '>' | '^' =>
|
|
|
414
|
|
|
415 -- Create dummy declaration in table to report it as a parameter
|
|
|
416
|
|
|
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.
|
|
|
423
|
|
|
424 New_Decl :=
|
|
|
425 Add_Declaration
|
|
|
426 (File_Ref => File_Ref,
|
|
|
427 Symbol => "",
|
|
|
428 Line => Line,
|
|
|
429 Column => Column,
|
|
|
430 Decl_Type => ' ',
|
|
|
431 Is_Parameter => True);
|
|
|
432
|
|
|
433 when 'd' | 'e' | 'E' | 'k' | 'p' | 'P' | 't' | 'z' =>
|
|
|
434 return;
|
|
|
435
|
|
|
436 when others =>
|
|
|
437 Ada.Text_IO.Put_Line ("Unknown reference type: " & Ref_Type);
|
|
|
438 return;
|
|
|
439 end case;
|
|
|
440
|
|
|
441 New_Ref := new Reference_Record'
|
|
|
442 (File => File_Ref,
|
|
|
443 Line => Line,
|
|
|
444 Column => Column,
|
|
|
445 Source_Line => null,
|
|
|
446 Next => null);
|
|
|
447
|
|
|
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.
|
|
|
452
|
|
|
453 case Ref_Type is
|
|
|
454 when 'b' | 'c' =>
|
|
|
455 New_Ref.Next := Declaration.Body_Ref;
|
|
|
456 Declaration.Body_Ref := New_Ref;
|
|
|
457
|
|
|
458 when ' ' | 'H' | 'i' | 'l' | 'o' | 'r' | 'R' | 's' | 'w' | 'x' =>
|
|
|
459 New_Ref.Next := Declaration.Ref_Ref;
|
|
|
460 Declaration.Ref_Ref := New_Ref;
|
|
|
461
|
|
|
462 when 'm' =>
|
|
|
463 New_Ref.Next := Declaration.Modif_Ref;
|
|
|
464 Declaration.Modif_Ref := New_Ref;
|
|
|
465
|
|
|
466 when others =>
|
|
|
467 null;
|
|
|
468 end case;
|
|
|
469
|
|
|
470 if not Declaration.Match then
|
|
|
471 Declaration.Match := Match (File_Ref, Line, Column);
|
|
|
472 end if;
|
|
|
473
|
|
|
474 if Declaration.Match then
|
|
|
475 Longest_File_Name_In_Table :=
|
|
|
476 Natural'Max (File_Ref.File'Length, Longest_File_Name_In_Table);
|
|
|
477 end if;
|
|
|
478 end Add_Reference;
|
|
|
479
|
|
|
480 -------------------
|
|
|
481 -- ALI_File_Name --
|
|
|
482 -------------------
|
|
|
483
|
|
|
484 function ALI_File_Name (Ada_File_Name : String) return String is
|
|
|
485
|
|
|
486 -- ??? Should ideally be based on the naming scheme defined in
|
|
|
487 -- project files.
|
|
|
488
|
|
|
489 Index : constant Natural :=
|
|
|
490 Ada.Strings.Fixed.Index
|
|
|
491 (Ada_File_Name, ".", Going => Ada.Strings.Backward);
|
|
|
492
|
|
|
493 begin
|
|
|
494 if Index /= 0 then
|
|
|
495 return Ada_File_Name (Ada_File_Name'First .. Index)
|
|
|
496 & Osint.ALI_Suffix.all;
|
|
|
497 else
|
|
|
498 return Ada_File_Name & "." & Osint.ALI_Suffix.all;
|
|
|
499 end if;
|
|
|
500 end ALI_File_Name;
|
|
|
501
|
|
|
502 ------------------
|
|
|
503 -- Is_Less_Than --
|
|
|
504 ------------------
|
|
|
505
|
|
|
506 function Is_Less_Than (Ref1, Ref2 : Reference) return Boolean is
|
|
|
507 begin
|
|
|
508 if Ref1 = null then
|
|
|
509 return False;
|
|
|
510 elsif Ref2 = null then
|
|
|
511 return True;
|
|
|
512 end if;
|
|
|
513
|
|
|
514 if Ref1.File.File.all < Ref2.File.File.all then
|
|
|
515 return True;
|
|
|
516
|
|
|
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));
|
|
|
521 end if;
|
|
|
522
|
|
|
523 return False;
|
|
|
524 end Is_Less_Than;
|
|
|
525
|
|
|
526 ------------------
|
|
|
527 -- Is_Less_Than --
|
|
|
528 ------------------
|
|
|
529
|
|
|
530 function Is_Less_Than (Decl1, Decl2 : Declaration_Reference) return Boolean
|
|
|
531 is
|
|
|
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
|
|
|
534 -- display later on.
|
|
|
535
|
|
|
536 S1 : constant String := To_Lower (Decl1.Symbol);
|
|
|
537 S2 : constant String := To_Lower (Decl2.Symbol);
|
|
|
538
|
|
|
539 begin
|
|
|
540 if S1 < S2 then
|
|
|
541 return True;
|
|
|
542 elsif S1 > S2 then
|
|
|
543 return False;
|
|
|
544 end if;
|
|
|
545
|
|
|
546 return Decl1.Key.all < Decl2.Key.all;
|
|
|
547 end Is_Less_Than;
|
|
|
548
|
|
|
549 -------------------------
|
|
|
550 -- Create_Project_File --
|
|
|
551 -------------------------
|
|
|
552
|
|
|
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'("");
|
|
|
557
|
|
|
558 F : File_Descriptor;
|
|
|
559 Len : Positive;
|
|
|
560 File_Name : aliased String := Name & ASCII.NUL;
|
|
|
561
|
|
|
562 begin
|
|
|
563 -- Read the size of the file
|
|
|
564
|
|
|
565 F := Open_Read (File_Name'Address, Text);
|
|
|
566
|
|
|
567 -- Project file not found
|
|
|
568
|
|
|
569 if F /= Invalid_FD then
|
|
|
570 Len := Positive (File_Length (F));
|
|
|
571
|
|
|
572 declare
|
|
|
573 Buffer : String (1 .. Len);
|
|
|
574 Index : Positive := Buffer'First;
|
|
|
575 Last : Positive;
|
|
|
576
|
|
|
577 begin
|
|
|
578 Len := Read (F, Buffer'Address, Len);
|
|
|
579 Close (F);
|
|
|
580
|
|
|
581 -- First, look for Build_Dir, since all the source and object
|
|
|
582 -- path are relative to it.
|
|
|
583
|
|
|
584 while Index <= Buffer'Last loop
|
|
|
585
|
|
|
586 -- Find the end of line
|
|
|
587
|
|
|
588 Last := Index;
|
|
|
589 while Last <= Buffer'Last
|
|
|
590 and then Buffer (Last) /= ASCII.LF
|
|
|
591 and then Buffer (Last) /= ASCII.CR
|
|
|
592 loop
|
|
|
593 Last := Last + 1;
|
|
|
594 end loop;
|
|
|
595
|
|
|
596 if Index <= Buffer'Last - 9
|
|
|
597 and then Buffer (Index .. Index + 9) = "build_dir="
|
|
|
598 then
|
|
|
599 Index := Index + 10;
|
|
|
600 while Index <= Last
|
|
|
601 and then (Buffer (Index) = ' '
|
|
|
602 or else Buffer (Index) = ASCII.HT)
|
|
|
603 loop
|
|
|
604 Index := Index + 1;
|
|
|
605 end loop;
|
|
|
606
|
|
|
607 Free (Build_Dir);
|
|
|
608 Build_Dir := new String'(Buffer (Index .. Last - 1));
|
|
|
609 end if;
|
|
|
610
|
|
|
611 Index := Last + 1;
|
|
|
612
|
|
|
613 -- In case we had a ASCII.CR/ASCII.LF end of line, skip the
|
|
|
614 -- remaining symbol
|
|
|
615
|
|
|
616 if Index <= Buffer'Last
|
|
|
617 and then Buffer (Index) = ASCII.LF
|
|
|
618 then
|
|
|
619 Index := Index + 1;
|
|
|
620 end if;
|
|
|
621 end loop;
|
|
|
622
|
|
|
623 -- Now parse the source and object paths
|
|
|
624
|
|
|
625 Index := Buffer'First;
|
|
|
626 while Index <= Buffer'Last loop
|
|
|
627
|
|
|
628 -- Find the end of line
|
|
|
629
|
|
|
630 Last := Index;
|
|
|
631 while Last <= Buffer'Last
|
|
|
632 and then Buffer (Last) /= ASCII.LF
|
|
|
633 and then Buffer (Last) /= ASCII.CR
|
|
|
634 loop
|
|
|
635 Last := Last + 1;
|
|
|
636 end loop;
|
|
|
637
|
|
|
638 if Index <= Buffer'Last - 7
|
|
|
639 and then Buffer (Index .. Index + 7) = "src_dir="
|
|
|
640 then
|
|
|
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);
|
|
|
645
|
|
|
646 elsif Index <= Buffer'Last - 7
|
|
|
647 and then Buffer (Index .. Index + 7) = "obj_dir="
|
|
|
648 then
|
|
|
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);
|
|
|
653 end if;
|
|
|
654
|
|
|
655 -- In case we had a ASCII.CR/ASCII.LF end of line, skip the
|
|
|
656 -- remaining symbol
|
|
|
657 Index := Last + 1;
|
|
|
658
|
|
|
659 if Index <= Buffer'Last
|
|
|
660 and then Buffer (Index) = ASCII.LF
|
|
|
661 then
|
|
|
662 Index := Index + 1;
|
|
|
663 end if;
|
|
|
664 end loop;
|
|
|
665 end;
|
|
|
666 end if;
|
|
|
667
|
|
|
668 Osint.Add_Default_Search_Dirs;
|
|
|
669
|
|
|
670 declare
|
|
|
671 Src : constant String := Parse_Gnatls_Src;
|
|
|
672 Obj : constant String := Parse_Gnatls_Obj;
|
|
|
673
|
|
|
674 begin
|
|
|
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,
|
|
|
680 Src_Dir_Index => 1,
|
|
|
681 Obj_Dir_Index => 1,
|
|
|
682 Last_Obj_Dir_Start => 0);
|
|
|
683 end;
|
|
|
684
|
|
|
685 Free (Build_Dir);
|
|
|
686 end Create_Project_File;
|
|
|
687
|
|
|
688 ---------------------
|
|
|
689 -- Current_Obj_Dir --
|
|
|
690 ---------------------
|
|
|
691
|
|
|
692 function Current_Obj_Dir return String is
|
|
|
693 begin
|
|
|
694 return Directories.Obj_Dir
|
|
|
695 (Directories.Last_Obj_Dir_Start .. Directories.Obj_Dir_Index - 2);
|
|
|
696 end Current_Obj_Dir;
|
|
|
697
|
|
|
698 ----------------
|
|
|
699 -- Get_Column --
|
|
|
700 ----------------
|
|
|
701
|
|
|
702 function Get_Column (Decl : Declaration_Reference) return String is
|
|
|
703 begin
|
|
|
704 return Ada.Strings.Fixed.Trim (Natural'Image (Decl.Decl.Column),
|
|
|
705 Ada.Strings.Left);
|
|
|
706 end Get_Column;
|
|
|
707
|
|
|
708 function Get_Column (Ref : Reference) return String is
|
|
|
709 begin
|
|
|
710 return Ada.Strings.Fixed.Trim (Natural'Image (Ref.Column),
|
|
|
711 Ada.Strings.Left);
|
|
|
712 end Get_Column;
|
|
|
713
|
|
|
714 ---------------------
|
|
|
715 -- Get_Declaration --
|
|
|
716 ---------------------
|
|
|
717
|
|
|
718 function Get_Declaration
|
|
|
719 (File_Ref : File_Reference;
|
|
|
720 Line : Natural;
|
|
|
721 Column : Natural)
|
|
|
722 return Declaration_Reference
|
|
|
723 is
|
|
|
724 Key : aliased constant String := Key_From_Ref (File_Ref, Line, Column);
|
|
|
725
|
|
|
726 begin
|
|
|
727 return Entities_HTable.Get (Key'Unchecked_Access);
|
|
|
728 end Get_Declaration;
|
|
|
729
|
|
|
730 ----------------------
|
|
|
731 -- Get_Emit_Warning --
|
|
|
732 ----------------------
|
|
|
733
|
|
|
734 function Get_Emit_Warning (File : File_Reference) return Boolean is
|
|
|
735 begin
|
|
|
736 return File.Emit_Warning;
|
|
|
737 end Get_Emit_Warning;
|
|
|
738
|
|
|
739 --------------
|
|
|
740 -- Get_File --
|
|
|
741 --------------
|
|
|
742
|
|
|
743 function Get_File
|
|
|
744 (Decl : Declaration_Reference;
|
|
|
745 With_Dir : Boolean := False) return String
|
|
|
746 is
|
|
|
747 begin
|
|
|
748 return Get_File (Decl.Decl.File, With_Dir);
|
|
|
749 end Get_File;
|
|
|
750
|
|
|
751 function Get_File
|
|
|
752 (Ref : Reference;
|
|
|
753 With_Dir : Boolean := False) return String
|
|
|
754 is
|
|
|
755 begin
|
|
|
756 return Get_File (Ref.File, With_Dir);
|
|
|
757 end Get_File;
|
|
|
758
|
|
|
759 function Get_File
|
|
|
760 (File : File_Reference;
|
|
|
761 With_Dir : Boolean := False;
|
|
|
762 Strip : Natural := 0) return String
|
|
|
763 is
|
|
131
|
764 pragma Annotate (CodePeer, Skip_Analysis);
|
|
|
765 -- ??? To disable false positives currently generated
|
|
|
766
|
|
111
|
767 Tmp : GNAT.OS_Lib.String_Access;
|
|
|
768
|
|
|
769 function Internal_Strip (Full_Name : String) return String;
|
|
|
770 -- Internal function to process the Strip parameter
|
|
|
771
|
|
|
772 --------------------
|
|
|
773 -- Internal_Strip --
|
|
|
774 --------------------
|
|
|
775
|
|
|
776 function Internal_Strip (Full_Name : String) return String is
|
|
|
777 Unit_End : Natural;
|
|
|
778 Extension_Start : Natural;
|
|
|
779 S : Natural;
|
|
|
780
|
|
|
781 begin
|
|
|
782 if Strip = 0 then
|
|
|
783 return Full_Name;
|
|
|
784 end if;
|
|
|
785
|
|
|
786 -- Isolate the file extension
|
|
|
787
|
|
|
788 Extension_Start := Full_Name'Last;
|
|
|
789 while Extension_Start >= Full_Name'First
|
|
|
790 and then Full_Name (Extension_Start) /= '.'
|
|
|
791 loop
|
|
|
792 Extension_Start := Extension_Start - 1;
|
|
|
793 end loop;
|
|
|
794
|
|
|
795 -- Strip the right number of subunit_names
|
|
|
796
|
|
|
797 S := Strip;
|
|
|
798 Unit_End := Extension_Start - 1;
|
|
|
799 while Unit_End >= Full_Name'First
|
|
|
800 and then S > 0
|
|
|
801 loop
|
|
|
802 if Full_Name (Unit_End) = '-' then
|
|
|
803 S := S - 1;
|
|
|
804 end if;
|
|
|
805
|
|
|
806 Unit_End := Unit_End - 1;
|
|
|
807 end loop;
|
|
|
808
|
|
|
809 if Unit_End < Full_Name'First then
|
|
|
810 return "";
|
|
|
811 else
|
|
|
812 return Full_Name (Full_Name'First .. Unit_End)
|
|
|
813 & Full_Name (Extension_Start .. Full_Name'Last);
|
|
|
814 end if;
|
|
|
815 end Internal_Strip;
|
|
|
816
|
|
|
817 -- Start of processing for Get_File;
|
|
|
818
|
|
|
819 begin
|
|
|
820 -- If we do not want the full path name
|
|
|
821
|
|
|
822 if not With_Dir then
|
|
|
823 return Internal_Strip (File.File.all);
|
|
|
824 end if;
|
|
|
825
|
|
|
826 if File.Dir = null then
|
|
|
827 if Ada.Strings.Fixed.Tail (File.File.all, 3) =
|
|
|
828 Osint.ALI_Suffix.all
|
|
|
829 then
|
|
|
830 Tmp := Locate_Regular_File
|
|
|
831 (Internal_Strip (File.File.all), Directories.Obj_Dir);
|
|
|
832 else
|
|
|
833 Tmp := Locate_Regular_File
|
|
|
834 (File.File.all, Directories.Src_Dir);
|
|
|
835 end if;
|
|
|
836
|
|
|
837 if Tmp = null then
|
|
|
838 File.Dir := new String'("");
|
|
|
839 else
|
|
|
840 File.Dir := new String'(Dir_Name (Tmp.all));
|
|
|
841 Free (Tmp);
|
|
|
842 end if;
|
|
|
843 end if;
|
|
|
844
|
|
|
845 return Internal_Strip (File.Dir.all & File.File.all);
|
|
|
846 end Get_File;
|
|
|
847
|
|
|
848 ------------------
|
|
|
849 -- Get_File_Ref --
|
|
|
850 ------------------
|
|
|
851
|
|
|
852 function Get_File_Ref (Ref : Reference) return File_Reference is
|
|
|
853 begin
|
|
|
854 return Ref.File;
|
|
|
855 end Get_File_Ref;
|
|
|
856
|
|
|
857 -----------------------
|
|
|
858 -- Get_Gnatchop_File --
|
|
|
859 -----------------------
|
|
|
860
|
|
|
861 function Get_Gnatchop_File
|
|
|
862 (File : File_Reference;
|
|
|
863 With_Dir : Boolean := False)
|
|
|
864 return String
|
|
|
865 is
|
|
|
866 begin
|
|
|
867 if File.Gnatchop_File.all = "" then
|
|
|
868 return Get_File (File, With_Dir);
|
|
|
869 else
|
|
|
870 return File.Gnatchop_File.all;
|
|
|
871 end if;
|
|
|
872 end Get_Gnatchop_File;
|
|
|
873
|
|
|
874 function Get_Gnatchop_File
|
|
|
875 (Ref : Reference;
|
|
|
876 With_Dir : Boolean := False)
|
|
|
877 return String
|
|
|
878 is
|
|
|
879 begin
|
|
|
880 return Get_Gnatchop_File (Ref.File, With_Dir);
|
|
|
881 end Get_Gnatchop_File;
|
|
|
882
|
|
|
883 function Get_Gnatchop_File
|
|
|
884 (Decl : Declaration_Reference;
|
|
|
885 With_Dir : Boolean := False)
|
|
|
886 return String
|
|
|
887 is
|
|
|
888 begin
|
|
|
889 return Get_Gnatchop_File (Decl.Decl.File, With_Dir);
|
|
|
890 end Get_Gnatchop_File;
|
|
|
891
|
|
|
892 --------------
|
|
|
893 -- Get_Line --
|
|
|
894 --------------
|
|
|
895
|
|
|
896 function Get_Line (Decl : Declaration_Reference) return String is
|
|
|
897 begin
|
|
|
898 return Ada.Strings.Fixed.Trim (Natural'Image (Decl.Decl.Line),
|
|
|
899 Ada.Strings.Left);
|
|
|
900 end Get_Line;
|
|
|
901
|
|
|
902 function Get_Line (Ref : Reference) return String is
|
|
|
903 begin
|
|
|
904 return Ada.Strings.Fixed.Trim (Natural'Image (Ref.Line),
|
|
|
905 Ada.Strings.Left);
|
|
|
906 end Get_Line;
|
|
|
907
|
|
|
908 ----------------
|
|
|
909 -- Get_Parent --
|
|
|
910 ----------------
|
|
|
911
|
|
|
912 function Get_Parent
|
|
|
913 (Decl : Declaration_Reference)
|
|
|
914 return Declaration_Reference
|
|
|
915 is
|
|
|
916 begin
|
|
|
917 return Decl.Par_Symbol;
|
|
|
918 end Get_Parent;
|
|
|
919
|
|
|
920 ---------------------
|
|
|
921 -- Get_Source_Line --
|
|
|
922 ---------------------
|
|
|
923
|
|
|
924 function Get_Source_Line (Ref : Reference) return String is
|
|
|
925 begin
|
|
|
926 if Ref.Source_Line /= null then
|
|
|
927 return Ref.Source_Line.all;
|
|
|
928 else
|
|
|
929 return "";
|
|
|
930 end if;
|
|
|
931 end Get_Source_Line;
|
|
|
932
|
|
|
933 function Get_Source_Line (Decl : Declaration_Reference) return String is
|
|
|
934 begin
|
|
|
935 if Decl.Decl.Source_Line /= null then
|
|
|
936 return Decl.Decl.Source_Line.all;
|
|
|
937 else
|
|
|
938 return "";
|
|
|
939 end if;
|
|
|
940 end Get_Source_Line;
|
|
|
941
|
|
|
942 ----------------
|
|
|
943 -- Get_Symbol --
|
|
|
944 ----------------
|
|
|
945
|
|
|
946 function Get_Symbol (Decl : Declaration_Reference) return String is
|
|
|
947 begin
|
|
|
948 return Decl.Symbol;
|
|
|
949 end Get_Symbol;
|
|
|
950
|
|
|
951 --------------
|
|
|
952 -- Get_Type --
|
|
|
953 --------------
|
|
|
954
|
|
|
955 function Get_Type (Decl : Declaration_Reference) return Character is
|
|
|
956 begin
|
|
|
957 return Decl.Decl_Type;
|
|
|
958 end Get_Type;
|
|
|
959
|
|
|
960 ----------
|
|
|
961 -- Sort --
|
|
|
962 ----------
|
|
|
963
|
|
|
964 procedure Sort (Arr : in out Reference_Array) is
|
|
|
965 Tmp : Reference;
|
|
|
966
|
|
|
967 function Lt (Op1, Op2 : Natural) return Boolean;
|
|
|
968 procedure Move (From, To : Natural);
|
|
|
969 -- See GNAT.Heap_Sort_G
|
|
|
970
|
|
|
971 --------
|
|
|
972 -- Lt --
|
|
|
973 --------
|
|
|
974
|
|
|
975 function Lt (Op1, Op2 : Natural) return Boolean is
|
|
|
976 begin
|
|
|
977 if Op1 = 0 then
|
|
|
978 return Is_Less_Than (Tmp, Arr (Op2));
|
|
|
979 elsif Op2 = 0 then
|
|
|
980 return Is_Less_Than (Arr (Op1), Tmp);
|
|
|
981 else
|
|
|
982 return Is_Less_Than (Arr (Op1), Arr (Op2));
|
|
|
983 end if;
|
|
|
984 end Lt;
|
|
|
985
|
|
|
986 ----------
|
|
|
987 -- Move --
|
|
|
988 ----------
|
|
|
989
|
|
|
990 procedure Move (From, To : Natural) is
|
|
|
991 begin
|
|
|
992 if To = 0 then
|
|
|
993 Tmp := Arr (From);
|
|
|
994 elsif From = 0 then
|
|
|
995 Arr (To) := Tmp;
|
|
|
996 else
|
|
|
997 Arr (To) := Arr (From);
|
|
|
998 end if;
|
|
|
999 end Move;
|
|
|
1000
|
|
|
1001 package Ref_Sort is new GNAT.Heap_Sort_G (Move, Lt);
|
|
|
1002
|
|
|
1003 -- Start of processing for Sort
|
|
|
1004
|
|
|
1005 begin
|
|
|
1006 Ref_Sort.Sort (Arr'Last);
|
|
|
1007 end Sort;
|
|
|
1008
|
|
|
1009 -----------------------
|
|
|
1010 -- Grep_Source_Files --
|
|
|
1011 -----------------------
|
|
|
1012
|
|
|
1013 procedure Grep_Source_Files is
|
|
|
1014 Length : Natural := 0;
|
|
|
1015 Decl : Declaration_Reference := Entities_HTable.Get_First;
|
|
|
1016 Arr : Reference_Array_Access;
|
|
|
1017 Index : Natural;
|
|
|
1018 End_Index : Natural;
|
|
|
1019 Current_File : File_Reference;
|
|
|
1020 Current_Line : Cst_String_Access;
|
|
|
1021 Buffer : GNAT.OS_Lib.String_Access;
|
|
|
1022 Ref : Reference;
|
|
|
1023 Line : Natural;
|
|
|
1024
|
|
|
1025 begin
|
|
|
1026 -- Create a temporary array, where all references will be
|
|
|
1027 -- sorted by files. This way, we only have to read the source
|
|
|
1028 -- files once.
|
|
|
1029
|
|
|
1030 while Decl /= null loop
|
|
|
1031
|
|
|
1032 -- Add 1 for the declaration itself
|
|
|
1033
|
|
|
1034 Length := Length + References_Count (Decl, True, True, True) + 1;
|
|
|
1035 Decl := Entities_HTable.Get_Next;
|
|
|
1036 end loop;
|
|
|
1037
|
|
|
1038 Arr := new Reference_Array (1 .. Length);
|
|
|
1039 Index := Arr'First;
|
|
|
1040
|
|
|
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;
|
|
|
1045 end loop;
|
|
|
1046
|
|
|
1047 Sort (Arr.all);
|
|
|
1048
|
|
|
1049 -- Now traverse the whole array and find the appropriate source
|
|
|
1050 -- lines.
|
|
|
1051
|
|
|
1052 for R in Arr'Range loop
|
|
|
1053 Ref := Arr (R);
|
|
|
1054
|
|
|
1055 if Ref.File /= Current_File then
|
|
|
1056 Free (Buffer);
|
|
|
1057 begin
|
|
|
1058 Read_File (Get_File (Ref.File, With_Dir => True), Buffer);
|
|
|
1059 End_Index := Buffer'First - 1;
|
|
|
1060 Line := 0;
|
|
|
1061 exception
|
|
|
1062 when Ada.Text_IO.Name_Error | Ada.Text_IO.End_Error =>
|
|
|
1063 Line := Natural'Last;
|
|
|
1064 end;
|
|
|
1065 Current_File := Ref.File;
|
|
|
1066 end if;
|
|
|
1067
|
|
|
1068 if Ref.Line > Line then
|
|
|
1069
|
|
|
1070 -- Do not free Current_Line, it is referenced by the last
|
|
|
1071 -- Ref we processed.
|
|
|
1072
|
|
|
1073 loop
|
|
|
1074 Index := End_Index + 1;
|
|
|
1075
|
|
|
1076 loop
|
|
|
1077 End_Index := End_Index + 1;
|
|
|
1078 exit when End_Index > Buffer'Last
|
|
|
1079 or else Buffer (End_Index) = ASCII.LF;
|
|
|
1080 end loop;
|
|
|
1081
|
|
|
1082 -- Skip spaces at beginning of line
|
|
|
1083
|
|
|
1084 while Index < End_Index and then
|
|
|
1085 (Buffer (Index) = ' ' or else Buffer (Index) = ASCII.HT)
|
|
|
1086 loop
|
|
|
1087 Index := Index + 1;
|
|
|
1088 end loop;
|
|
|
1089
|
|
|
1090 Line := Line + 1;
|
|
|
1091 exit when Ref.Line = Line;
|
|
|
1092 end loop;
|
|
|
1093
|
|
|
1094 Current_Line := new String'(Buffer (Index .. End_Index - 1));
|
|
|
1095 end if;
|
|
|
1096
|
|
|
1097 Ref.Source_Line := Current_Line;
|
|
|
1098 end loop;
|
|
|
1099
|
|
|
1100 Free (Buffer);
|
|
|
1101 Free (Arr);
|
|
|
1102 end Grep_Source_Files;
|
|
|
1103
|
|
|
1104 ---------------
|
|
|
1105 -- Read_File --
|
|
|
1106 ---------------
|
|
|
1107
|
|
|
1108 procedure Read_File
|
|
|
1109 (File_Name : String;
|
|
|
1110 Contents : out GNAT.OS_Lib.String_Access)
|
|
|
1111 is
|
|
|
1112 Name_0 : constant String := File_Name & ASCII.NUL;
|
|
|
1113 FD : constant File_Descriptor := Open_Read (Name_0'Address, Binary);
|
|
|
1114 Length : Natural;
|
|
|
1115
|
|
|
1116 begin
|
|
|
1117 if FD = Invalid_FD then
|
|
|
1118 raise Ada.Text_IO.Name_Error;
|
|
|
1119 end if;
|
|
|
1120
|
|
|
1121 -- Include room for EOF char
|
|
|
1122
|
|
|
1123 Length := Natural (File_Length (FD));
|
|
|
1124
|
|
|
1125 declare
|
|
|
1126 Buffer : String (1 .. Length + 1);
|
|
|
1127 This_Read : Integer;
|
|
|
1128 Read_Ptr : Natural := 1;
|
|
|
1129
|
|
|
1130 begin
|
|
|
1131 loop
|
|
|
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;
|
|
|
1137 end loop;
|
|
|
1138
|
|
|
1139 Buffer (Read_Ptr) := EOF;
|
|
|
1140 Contents := new String'(Buffer (1 .. Read_Ptr));
|
|
|
1141
|
|
|
1142 if Read_Ptr /= Length + 1 then
|
|
|
1143 raise Ada.Text_IO.End_Error;
|
|
|
1144 end if;
|
|
|
1145
|
|
|
1146 Close (FD);
|
|
|
1147 end;
|
|
|
1148 end Read_File;
|
|
|
1149
|
|
|
1150 -----------------------
|
|
|
1151 -- Longest_File_Name --
|
|
|
1152 -----------------------
|
|
|
1153
|
|
|
1154 function Longest_File_Name return Natural is
|
|
|
1155 begin
|
|
|
1156 return Longest_File_Name_In_Table;
|
|
|
1157 end Longest_File_Name;
|
|
|
1158
|
|
|
1159 -----------
|
|
|
1160 -- Match --
|
|
|
1161 -----------
|
|
|
1162
|
|
|
1163 function Match
|
|
|
1164 (File : File_Reference;
|
|
|
1165 Line : Natural;
|
|
|
1166 Column : Natural)
|
|
|
1167 return Boolean
|
|
|
1168 is
|
|
|
1169 Ref : Ref_In_File_Ptr := File.Lines;
|
|
|
1170
|
|
|
1171 begin
|
|
|
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)
|
|
|
1175 then
|
|
|
1176 return True;
|
|
|
1177 end if;
|
|
|
1178
|
|
|
1179 Ref := Ref.Next;
|
|
|
1180 end loop;
|
|
|
1181
|
|
|
1182 return False;
|
|
|
1183 end Match;
|
|
|
1184
|
|
|
1185 -----------
|
|
|
1186 -- Match --
|
|
|
1187 -----------
|
|
|
1188
|
|
|
1189 function Match (Decl : Declaration_Reference) return Boolean is
|
|
|
1190 begin
|
|
|
1191 return Decl.Match;
|
|
|
1192 end Match;
|
|
|
1193
|
|
|
1194 ----------
|
|
|
1195 -- Next --
|
|
|
1196 ----------
|
|
|
1197
|
|
|
1198 function Next (E : File_Reference) return File_Reference is
|
|
|
1199 begin
|
|
|
1200 return E.Next;
|
|
|
1201 end Next;
|
|
|
1202
|
|
|
1203 function Next (E : Declaration_Reference) return Declaration_Reference is
|
|
|
1204 begin
|
|
|
1205 return E.Next;
|
|
|
1206 end Next;
|
|
|
1207
|
|
|
1208 ------------------
|
|
|
1209 -- Next_Obj_Dir --
|
|
|
1210 ------------------
|
|
|
1211
|
|
|
1212 function Next_Obj_Dir return String is
|
|
|
1213 First : constant Integer := Directories.Obj_Dir_Index;
|
|
|
1214 Last : Integer;
|
|
|
1215
|
|
|
1216 begin
|
|
|
1217 Last := Directories.Obj_Dir_Index;
|
|
|
1218
|
|
|
1219 if Last > Directories.Obj_Dir_Length then
|
|
|
1220 return String'(1 .. 0 => ' ');
|
|
|
1221 end if;
|
|
|
1222
|
|
|
1223 while Directories.Obj_Dir (Last) /= Path_Separator loop
|
|
|
1224 Last := Last + 1;
|
|
|
1225 end loop;
|
|
|
1226
|
|
|
1227 Directories.Obj_Dir_Index := Last + 1;
|
|
|
1228 Directories.Last_Obj_Dir_Start := First;
|
|
|
1229 return Directories.Obj_Dir (First .. Last - 1);
|
|
|
1230 end Next_Obj_Dir;
|
|
|
1231
|
|
|
1232 -------------------------
|
|
|
1233 -- Next_Unvisited_File --
|
|
|
1234 -------------------------
|
|
|
1235
|
|
|
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);
|
|
|
1239
|
|
|
1240 Ref : File_Reference;
|
|
|
1241 Tmp : Unvisited_Files_Access;
|
|
|
1242
|
|
|
1243 begin
|
|
|
1244 if Unvisited_Files = null then
|
|
|
1245 return Empty_File;
|
|
|
1246 else
|
|
|
1247 Tmp := Unvisited_Files;
|
|
|
1248 Ref := Unvisited_Files.File;
|
|
|
1249 Unvisited_Files := Unvisited_Files.Next;
|
|
|
1250 Unchecked_Free (Tmp);
|
|
|
1251 return Ref;
|
|
|
1252 end if;
|
|
|
1253 end Next_Unvisited_File;
|
|
|
1254
|
|
|
1255 ----------------------
|
|
|
1256 -- Parse_Gnatls_Src --
|
|
|
1257 ----------------------
|
|
|
1258
|
|
|
1259 function Parse_Gnatls_Src return String is
|
|
|
1260 Length : Natural;
|
|
|
1261
|
|
|
1262 begin
|
|
|
1263 Length := 0;
|
|
|
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;
|
|
|
1267 else
|
|
|
1268 Length := Length + Osint.Dir_In_Src_Search_Path (J)'Length + 1;
|
|
|
1269 end if;
|
|
|
1270 end loop;
|
|
|
1271
|
|
|
1272 declare
|
|
|
1273 Result : String (1 .. Length);
|
|
|
1274 L : Natural;
|
|
|
1275
|
|
|
1276 begin
|
|
|
1277 L := Result'First;
|
|
|
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;
|
|
|
1281 L := L + 2;
|
|
|
1282
|
|
|
1283 else
|
|
|
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;
|
|
|
1288 L := L + 1;
|
|
|
1289 end if;
|
|
|
1290 end loop;
|
|
|
1291
|
|
|
1292 return Result;
|
|
|
1293 end;
|
|
|
1294 end Parse_Gnatls_Src;
|
|
|
1295
|
|
|
1296 ----------------------
|
|
|
1297 -- Parse_Gnatls_Obj --
|
|
|
1298 ----------------------
|
|
|
1299
|
|
|
1300 function Parse_Gnatls_Obj return String is
|
|
|
1301 Length : Natural;
|
|
|
1302
|
|
|
1303 begin
|
|
|
1304 Length := 0;
|
|
|
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;
|
|
|
1308 else
|
|
|
1309 Length := Length + Osint.Dir_In_Obj_Search_Path (J)'Length + 1;
|
|
|
1310 end if;
|
|
|
1311 end loop;
|
|
|
1312
|
|
|
1313 declare
|
|
|
1314 Result : String (1 .. Length);
|
|
|
1315 L : Natural;
|
|
|
1316
|
|
|
1317 begin
|
|
|
1318 L := Result'First;
|
|
|
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;
|
|
|
1322 L := L + 2;
|
|
|
1323 else
|
|
|
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;
|
|
|
1328 L := L + 1;
|
|
|
1329 end if;
|
|
|
1330 end loop;
|
|
|
1331
|
|
|
1332 return Result;
|
|
|
1333 end;
|
|
|
1334 end Parse_Gnatls_Obj;
|
|
|
1335
|
|
|
1336 -------------------
|
|
|
1337 -- Reset_Obj_Dir --
|
|
|
1338 -------------------
|
|
|
1339
|
|
|
1340 procedure Reset_Obj_Dir is
|
|
|
1341 begin
|
|
|
1342 Directories.Obj_Dir_Index := 1;
|
|
|
1343 end Reset_Obj_Dir;
|
|
|
1344
|
|
|
1345 -----------------------
|
|
|
1346 -- Set_Default_Match --
|
|
|
1347 -----------------------
|
|
|
1348
|
|
|
1349 procedure Set_Default_Match (Value : Boolean) is
|
|
|
1350 begin
|
|
|
1351 Default_Match := Value;
|
|
|
1352 end Set_Default_Match;
|
|
|
1353
|
|
|
1354 ----------
|
|
|
1355 -- Free --
|
|
|
1356 ----------
|
|
|
1357
|
|
|
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);
|
|
|
1361
|
|
|
1362 S : GNAT.OS_Lib.String_Access := Convert (Str);
|
|
|
1363
|
|
|
1364 begin
|
|
|
1365 Free (S);
|
|
|
1366 Str := null;
|
|
|
1367 end Free;
|
|
|
1368
|
|
|
1369 ---------------------
|
|
|
1370 -- Reset_Directory --
|
|
|
1371 ---------------------
|
|
|
1372
|
|
|
1373 procedure Reset_Directory (File : File_Reference) is
|
|
|
1374 begin
|
|
|
1375 Free (File.Dir);
|
|
|
1376 end Reset_Directory;
|
|
|
1377
|
|
|
1378 -------------------
|
|
|
1379 -- Set_Unvisited --
|
|
|
1380 -------------------
|
|
|
1381
|
|
|
1382 procedure Set_Unvisited (File_Ref : File_Reference) is
|
|
|
1383 F : constant String := Get_File (File_Ref, With_Dir => False);
|
|
|
1384
|
|
|
1385 begin
|
|
|
1386 File_Ref.Visited := False;
|
|
|
1387
|
|
|
1388 -- ??? Do not add a source file to the list. This is true at
|
|
|
1389 -- least for gnatxref, and probably for gnatfind as well
|
|
|
1390
|
|
|
1391 if F'Length > 4
|
|
|
1392 and then F (F'Last - 3 .. F'Last) = "." & Osint.ALI_Suffix.all
|
|
|
1393 then
|
|
|
1394 Unvisited_Files := new Unvisited_Files_Record'
|
|
|
1395 (File => File_Ref,
|
|
|
1396 Next => Unvisited_Files);
|
|
|
1397 end if;
|
|
|
1398 end Set_Unvisited;
|
|
|
1399
|
|
|
1400 ----------------------
|
|
|
1401 -- Get_Declarations --
|
|
|
1402 ----------------------
|
|
|
1403
|
|
|
1404 function Get_Declarations
|
|
|
1405 (Sorted : Boolean := True)
|
|
|
1406 return Declaration_Array_Access
|
|
|
1407 is
|
|
|
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;
|
|
|
1413
|
|
|
1414 procedure Move (From : Natural; To : Natural);
|
|
|
1415 function Lt (Op1, Op2 : Natural) return Boolean;
|
|
|
1416 -- See GNAT.Heap_Sort_G
|
|
|
1417
|
|
|
1418 --------
|
|
|
1419 -- Lt --
|
|
|
1420 --------
|
|
|
1421
|
|
|
1422 function Lt (Op1, Op2 : Natural) return Boolean is
|
|
|
1423 begin
|
|
|
1424 if Op1 = 0 then
|
|
|
1425 return Is_Less_Than (Tmp, Arr (Op2));
|
|
|
1426 elsif Op2 = 0 then
|
|
|
1427 return Is_Less_Than (Arr (Op1), Tmp);
|
|
|
1428 else
|
|
|
1429 return Is_Less_Than (Arr (Op1), Arr (Op2));
|
|
|
1430 end if;
|
|
|
1431 end Lt;
|
|
|
1432
|
|
|
1433 ----------
|
|
|
1434 -- Move --
|
|
|
1435 ----------
|
|
|
1436
|
|
|
1437 procedure Move (From : Natural; To : Natural) is
|
|
|
1438 begin
|
|
|
1439 if To = 0 then
|
|
|
1440 Tmp := Arr (From);
|
|
|
1441 elsif From = 0 then
|
|
|
1442 Arr (To) := Tmp;
|
|
|
1443 else
|
|
|
1444 Arr (To) := Arr (From);
|
|
|
1445 end if;
|
|
|
1446 end Move;
|
|
|
1447
|
|
|
1448 package Decl_Sort is new GNAT.Heap_Sort_G (Move, Lt);
|
|
|
1449
|
|
|
1450 -- Start of processing for Get_Declarations
|
|
|
1451
|
|
|
1452 begin
|
|
|
1453 while Decl /= null loop
|
|
|
1454 Arr (Index) := Decl;
|
|
|
1455 Index := Index + 1;
|
|
|
1456 Decl := Entities_HTable.Get_Next;
|
|
|
1457 end loop;
|
|
|
1458
|
|
|
1459 if Sorted and then Arr'Length /= 0 then
|
|
|
1460 Decl_Sort.Sort (Entities_Count);
|
|
|
1461 end if;
|
|
|
1462
|
|
|
1463 return Arr;
|
|
|
1464 end Get_Declarations;
|
|
|
1465
|
|
|
1466 ----------------------
|
|
|
1467 -- References_Count --
|
|
|
1468 ----------------------
|
|
|
1469
|
|
|
1470 function References_Count
|
|
|
1471 (Decl : Declaration_Reference;
|
|
|
1472 Get_Reads : Boolean := False;
|
|
|
1473 Get_Writes : Boolean := False;
|
|
|
1474 Get_Bodies : Boolean := False)
|
|
|
1475 return Natural
|
|
|
1476 is
|
|
|
1477 function List_Length (E : Reference) return Natural;
|
|
|
1478 -- Return the number of references in E
|
|
|
1479
|
|
|
1480 -----------------
|
|
|
1481 -- List_Length --
|
|
|
1482 -----------------
|
|
|
1483
|
|
|
1484 function List_Length (E : Reference) return Natural is
|
|
|
1485 L : Natural := 0;
|
|
|
1486 E1 : Reference := E;
|
|
|
1487
|
|
|
1488 begin
|
|
|
1489 while E1 /= null loop
|
|
|
1490 L := L + 1;
|
|
|
1491 E1 := E1.Next;
|
|
|
1492 end loop;
|
|
|
1493
|
|
|
1494 return L;
|
|
|
1495 end List_Length;
|
|
|
1496
|
|
|
1497 Length : Natural := 0;
|
|
|
1498
|
|
|
1499 -- Start of processing for References_Count
|
|
|
1500
|
|
|
1501 begin
|
|
|
1502 if Get_Reads then
|
|
|
1503 Length := List_Length (Decl.Ref_Ref);
|
|
|
1504 end if;
|
|
|
1505
|
|
|
1506 if Get_Writes then
|
|
|
1507 Length := Length + List_Length (Decl.Modif_Ref);
|
|
|
1508 end if;
|
|
|
1509
|
|
|
1510 if Get_Bodies then
|
|
|
1511 Length := Length + List_Length (Decl.Body_Ref);
|
|
|
1512 end if;
|
|
|
1513
|
|
|
1514 return Length;
|
|
|
1515 end References_Count;
|
|
|
1516
|
|
|
1517 ----------------------
|
|
|
1518 -- Store_References --
|
|
|
1519 ----------------------
|
|
|
1520
|
|
|
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)
|
|
|
1529 is
|
|
|
1530 procedure Add (List : Reference);
|
|
|
1531 -- Add all the references in List to Arr
|
|
|
1532
|
|
|
1533 ---------
|
|
|
1534 -- Add --
|
|
|
1535 ---------
|
|
|
1536
|
|
|
1537 procedure Add (List : Reference) is
|
|
|
1538 E : Reference := List;
|
|
|
1539 begin
|
|
|
1540 while E /= null loop
|
|
|
1541 Arr (Index) := E;
|
|
|
1542 Index := Index + 1;
|
|
|
1543 E := E.Next;
|
|
|
1544 end loop;
|
|
|
1545 end Add;
|
|
|
1546
|
|
|
1547 -- Start of processing for Store_References
|
|
|
1548
|
|
|
1549 begin
|
|
|
1550 if Get_Declaration then
|
|
|
1551 Add (Decl.Decl);
|
|
|
1552 end if;
|
|
|
1553
|
|
|
1554 if Get_Reads then
|
|
|
1555 Add (Decl.Ref_Ref);
|
|
|
1556 end if;
|
|
|
1557
|
|
|
1558 if Get_Writes then
|
|
|
1559 Add (Decl.Modif_Ref);
|
|
|
1560 end if;
|
|
|
1561
|
|
|
1562 if Get_Bodies then
|
|
|
1563 Add (Decl.Body_Ref);
|
|
|
1564 end if;
|
|
|
1565 end Store_References;
|
|
|
1566
|
|
|
1567 --------------------
|
|
|
1568 -- Get_References --
|
|
|
1569 --------------------
|
|
|
1570
|
|
|
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
|
|
|
1577 is
|
|
|
1578 Length : constant Natural :=
|
|
|
1579 References_Count (Decl, Get_Reads, Get_Writes, Get_Bodies);
|
|
|
1580
|
|
|
1581 Arr : constant Reference_Array_Access :=
|
|
|
1582 new Reference_Array (1 .. Length);
|
|
|
1583
|
|
|
1584 Index : Natural := Arr'First;
|
|
|
1585
|
|
|
1586 begin
|
|
|
1587 Store_References
|
|
|
1588 (Decl => Decl,
|
|
|
1589 Get_Writes => Get_Writes,
|
|
|
1590 Get_Reads => Get_Reads,
|
|
|
1591 Get_Bodies => Get_Bodies,
|
|
|
1592 Get_Declaration => False,
|
|
|
1593 Arr => Arr.all,
|
|
|
1594 Index => Index);
|
|
|
1595
|
|
|
1596 if Arr'Length /= 0 then
|
|
|
1597 Sort (Arr.all);
|
|
|
1598 end if;
|
|
|
1599
|
|
|
1600 return Arr;
|
|
|
1601 end Get_References;
|
|
|
1602
|
|
|
1603 ----------
|
|
|
1604 -- Free --
|
|
|
1605 ----------
|
|
|
1606
|
|
|
1607 procedure Free (Arr : in out Reference_Array_Access) is
|
|
|
1608 procedure Internal is new Ada.Unchecked_Deallocation
|
|
|
1609 (Reference_Array, Reference_Array_Access);
|
|
|
1610 begin
|
|
|
1611 Internal (Arr);
|
|
|
1612 end Free;
|
|
|
1613
|
|
|
1614 ------------------
|
|
|
1615 -- Is_Parameter --
|
|
|
1616 ------------------
|
|
|
1617
|
|
|
1618 function Is_Parameter (Decl : Declaration_Reference) return Boolean is
|
|
|
1619 begin
|
|
|
1620 return Decl.Is_Parameter;
|
|
|
1621 end Is_Parameter;
|
|
|
1622
|
|
|
1623 end Xr_Tabls;
|
