|
111
|
1 ------------------------------------------------------------------------------
|
|
|
2 -- --
|
|
|
3 -- GNAT COMPILER COMPONENTS --
|
|
|
4 -- --
|
|
|
5 -- X R _ T A B L S --
|
|
|
6 -- --
|
|
|
7 -- B o d y --
|
|
|
8 -- --
|
|
|
9 -- Copyright (C) 1998-2017, Free Software Foundation, Inc. --
|
|
|
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
|
|
|
764 Tmp : GNAT.OS_Lib.String_Access;
|
|
|
765
|
|
|
766 function Internal_Strip (Full_Name : String) return String;
|
|
|
767 -- Internal function to process the Strip parameter
|
|
|
768
|
|
|
769 --------------------
|
|
|
770 -- Internal_Strip --
|
|
|
771 --------------------
|
|
|
772
|
|
|
773 function Internal_Strip (Full_Name : String) return String is
|
|
|
774 Unit_End : Natural;
|
|
|
775 Extension_Start : Natural;
|
|
|
776 S : Natural;
|
|
|
777
|
|
|
778 begin
|
|
|
779 if Strip = 0 then
|
|
|
780 return Full_Name;
|
|
|
781 end if;
|
|
|
782
|
|
|
783 -- Isolate the file extension
|
|
|
784
|
|
|
785 Extension_Start := Full_Name'Last;
|
|
|
786 while Extension_Start >= Full_Name'First
|
|
|
787 and then Full_Name (Extension_Start) /= '.'
|
|
|
788 loop
|
|
|
789 Extension_Start := Extension_Start - 1;
|
|
|
790 end loop;
|
|
|
791
|
|
|
792 -- Strip the right number of subunit_names
|
|
|
793
|
|
|
794 S := Strip;
|
|
|
795 Unit_End := Extension_Start - 1;
|
|
|
796 while Unit_End >= Full_Name'First
|
|
|
797 and then S > 0
|
|
|
798 loop
|
|
|
799 if Full_Name (Unit_End) = '-' then
|
|
|
800 S := S - 1;
|
|
|
801 end if;
|
|
|
802
|
|
|
803 Unit_End := Unit_End - 1;
|
|
|
804 end loop;
|
|
|
805
|
|
|
806 if Unit_End < Full_Name'First then
|
|
|
807 return "";
|
|
|
808 else
|
|
|
809 return Full_Name (Full_Name'First .. Unit_End)
|
|
|
810 & Full_Name (Extension_Start .. Full_Name'Last);
|
|
|
811 end if;
|
|
|
812 end Internal_Strip;
|
|
|
813
|
|
|
814 -- Start of processing for Get_File;
|
|
|
815
|
|
|
816 begin
|
|
|
817 -- If we do not want the full path name
|
|
|
818
|
|
|
819 if not With_Dir then
|
|
|
820 return Internal_Strip (File.File.all);
|
|
|
821 end if;
|
|
|
822
|
|
|
823 if File.Dir = null then
|
|
|
824 if Ada.Strings.Fixed.Tail (File.File.all, 3) =
|
|
|
825 Osint.ALI_Suffix.all
|
|
|
826 then
|
|
|
827 Tmp := Locate_Regular_File
|
|
|
828 (Internal_Strip (File.File.all), Directories.Obj_Dir);
|
|
|
829 else
|
|
|
830 Tmp := Locate_Regular_File
|
|
|
831 (File.File.all, Directories.Src_Dir);
|
|
|
832 end if;
|
|
|
833
|
|
|
834 if Tmp = null then
|
|
|
835 File.Dir := new String'("");
|
|
|
836 else
|
|
|
837 File.Dir := new String'(Dir_Name (Tmp.all));
|
|
|
838 Free (Tmp);
|
|
|
839 end if;
|
|
|
840 end if;
|
|
|
841
|
|
|
842 return Internal_Strip (File.Dir.all & File.File.all);
|
|
|
843 end Get_File;
|
|
|
844
|
|
|
845 ------------------
|
|
|
846 -- Get_File_Ref --
|
|
|
847 ------------------
|
|
|
848
|
|
|
849 function Get_File_Ref (Ref : Reference) return File_Reference is
|
|
|
850 begin
|
|
|
851 return Ref.File;
|
|
|
852 end Get_File_Ref;
|
|
|
853
|
|
|
854 -----------------------
|
|
|
855 -- Get_Gnatchop_File --
|
|
|
856 -----------------------
|
|
|
857
|
|
|
858 function Get_Gnatchop_File
|
|
|
859 (File : File_Reference;
|
|
|
860 With_Dir : Boolean := False)
|
|
|
861 return String
|
|
|
862 is
|
|
|
863 begin
|
|
|
864 if File.Gnatchop_File.all = "" then
|
|
|
865 return Get_File (File, With_Dir);
|
|
|
866 else
|
|
|
867 return File.Gnatchop_File.all;
|
|
|
868 end if;
|
|
|
869 end Get_Gnatchop_File;
|
|
|
870
|
|
|
871 function Get_Gnatchop_File
|
|
|
872 (Ref : Reference;
|
|
|
873 With_Dir : Boolean := False)
|
|
|
874 return String
|
|
|
875 is
|
|
|
876 begin
|
|
|
877 return Get_Gnatchop_File (Ref.File, With_Dir);
|
|
|
878 end Get_Gnatchop_File;
|
|
|
879
|
|
|
880 function Get_Gnatchop_File
|
|
|
881 (Decl : Declaration_Reference;
|
|
|
882 With_Dir : Boolean := False)
|
|
|
883 return String
|
|
|
884 is
|
|
|
885 begin
|
|
|
886 return Get_Gnatchop_File (Decl.Decl.File, With_Dir);
|
|
|
887 end Get_Gnatchop_File;
|
|
|
888
|
|
|
889 --------------
|
|
|
890 -- Get_Line --
|
|
|
891 --------------
|
|
|
892
|
|
|
893 function Get_Line (Decl : Declaration_Reference) return String is
|
|
|
894 begin
|
|
|
895 return Ada.Strings.Fixed.Trim (Natural'Image (Decl.Decl.Line),
|
|
|
896 Ada.Strings.Left);
|
|
|
897 end Get_Line;
|
|
|
898
|
|
|
899 function Get_Line (Ref : Reference) return String is
|
|
|
900 begin
|
|
|
901 return Ada.Strings.Fixed.Trim (Natural'Image (Ref.Line),
|
|
|
902 Ada.Strings.Left);
|
|
|
903 end Get_Line;
|
|
|
904
|
|
|
905 ----------------
|
|
|
906 -- Get_Parent --
|
|
|
907 ----------------
|
|
|
908
|
|
|
909 function Get_Parent
|
|
|
910 (Decl : Declaration_Reference)
|
|
|
911 return Declaration_Reference
|
|
|
912 is
|
|
|
913 begin
|
|
|
914 return Decl.Par_Symbol;
|
|
|
915 end Get_Parent;
|
|
|
916
|
|
|
917 ---------------------
|
|
|
918 -- Get_Source_Line --
|
|
|
919 ---------------------
|
|
|
920
|
|
|
921 function Get_Source_Line (Ref : Reference) return String is
|
|
|
922 begin
|
|
|
923 if Ref.Source_Line /= null then
|
|
|
924 return Ref.Source_Line.all;
|
|
|
925 else
|
|
|
926 return "";
|
|
|
927 end if;
|
|
|
928 end Get_Source_Line;
|
|
|
929
|
|
|
930 function Get_Source_Line (Decl : Declaration_Reference) return String is
|
|
|
931 begin
|
|
|
932 if Decl.Decl.Source_Line /= null then
|
|
|
933 return Decl.Decl.Source_Line.all;
|
|
|
934 else
|
|
|
935 return "";
|
|
|
936 end if;
|
|
|
937 end Get_Source_Line;
|
|
|
938
|
|
|
939 ----------------
|
|
|
940 -- Get_Symbol --
|
|
|
941 ----------------
|
|
|
942
|
|
|
943 function Get_Symbol (Decl : Declaration_Reference) return String is
|
|
|
944 begin
|
|
|
945 return Decl.Symbol;
|
|
|
946 end Get_Symbol;
|
|
|
947
|
|
|
948 --------------
|
|
|
949 -- Get_Type --
|
|
|
950 --------------
|
|
|
951
|
|
|
952 function Get_Type (Decl : Declaration_Reference) return Character is
|
|
|
953 begin
|
|
|
954 return Decl.Decl_Type;
|
|
|
955 end Get_Type;
|
|
|
956
|
|
|
957 ----------
|
|
|
958 -- Sort --
|
|
|
959 ----------
|
|
|
960
|
|
|
961 procedure Sort (Arr : in out Reference_Array) is
|
|
|
962 Tmp : Reference;
|
|
|
963
|
|
|
964 function Lt (Op1, Op2 : Natural) return Boolean;
|
|
|
965 procedure Move (From, To : Natural);
|
|
|
966 -- See GNAT.Heap_Sort_G
|
|
|
967
|
|
|
968 --------
|
|
|
969 -- Lt --
|
|
|
970 --------
|
|
|
971
|
|
|
972 function Lt (Op1, Op2 : Natural) return Boolean is
|
|
|
973 begin
|
|
|
974 if Op1 = 0 then
|
|
|
975 return Is_Less_Than (Tmp, Arr (Op2));
|
|
|
976 elsif Op2 = 0 then
|
|
|
977 return Is_Less_Than (Arr (Op1), Tmp);
|
|
|
978 else
|
|
|
979 return Is_Less_Than (Arr (Op1), Arr (Op2));
|
|
|
980 end if;
|
|
|
981 end Lt;
|
|
|
982
|
|
|
983 ----------
|
|
|
984 -- Move --
|
|
|
985 ----------
|
|
|
986
|
|
|
987 procedure Move (From, To : Natural) is
|
|
|
988 begin
|
|
|
989 if To = 0 then
|
|
|
990 Tmp := Arr (From);
|
|
|
991 elsif From = 0 then
|
|
|
992 Arr (To) := Tmp;
|
|
|
993 else
|
|
|
994 Arr (To) := Arr (From);
|
|
|
995 end if;
|
|
|
996 end Move;
|
|
|
997
|
|
|
998 package Ref_Sort is new GNAT.Heap_Sort_G (Move, Lt);
|
|
|
999
|
|
|
1000 -- Start of processing for Sort
|
|
|
1001
|
|
|
1002 begin
|
|
|
1003 Ref_Sort.Sort (Arr'Last);
|
|
|
1004 end Sort;
|
|
|
1005
|
|
|
1006 -----------------------
|
|
|
1007 -- Grep_Source_Files --
|
|
|
1008 -----------------------
|
|
|
1009
|
|
|
1010 procedure Grep_Source_Files is
|
|
|
1011 Length : Natural := 0;
|
|
|
1012 Decl : Declaration_Reference := Entities_HTable.Get_First;
|
|
|
1013 Arr : Reference_Array_Access;
|
|
|
1014 Index : Natural;
|
|
|
1015 End_Index : Natural;
|
|
|
1016 Current_File : File_Reference;
|
|
|
1017 Current_Line : Cst_String_Access;
|
|
|
1018 Buffer : GNAT.OS_Lib.String_Access;
|
|
|
1019 Ref : Reference;
|
|
|
1020 Line : Natural;
|
|
|
1021
|
|
|
1022 begin
|
|
|
1023 -- Create a temporary array, where all references will be
|
|
|
1024 -- sorted by files. This way, we only have to read the source
|
|
|
1025 -- files once.
|
|
|
1026
|
|
|
1027 while Decl /= null loop
|
|
|
1028
|
|
|
1029 -- Add 1 for the declaration itself
|
|
|
1030
|
|
|
1031 Length := Length + References_Count (Decl, True, True, True) + 1;
|
|
|
1032 Decl := Entities_HTable.Get_Next;
|
|
|
1033 end loop;
|
|
|
1034
|
|
|
1035 Arr := new Reference_Array (1 .. Length);
|
|
|
1036 Index := Arr'First;
|
|
|
1037
|
|
|
1038 Decl := Entities_HTable.Get_First;
|
|
|
1039 while Decl /= null loop
|
|
|
1040 Store_References (Decl, True, True, True, True, Arr.all, Index);
|
|
|
1041 Decl := Entities_HTable.Get_Next;
|
|
|
1042 end loop;
|
|
|
1043
|
|
|
1044 Sort (Arr.all);
|
|
|
1045
|
|
|
1046 -- Now traverse the whole array and find the appropriate source
|
|
|
1047 -- lines.
|
|
|
1048
|
|
|
1049 for R in Arr'Range loop
|
|
|
1050 Ref := Arr (R);
|
|
|
1051
|
|
|
1052 if Ref.File /= Current_File then
|
|
|
1053 Free (Buffer);
|
|
|
1054 begin
|
|
|
1055 Read_File (Get_File (Ref.File, With_Dir => True), Buffer);
|
|
|
1056 End_Index := Buffer'First - 1;
|
|
|
1057 Line := 0;
|
|
|
1058 exception
|
|
|
1059 when Ada.Text_IO.Name_Error | Ada.Text_IO.End_Error =>
|
|
|
1060 Line := Natural'Last;
|
|
|
1061 end;
|
|
|
1062 Current_File := Ref.File;
|
|
|
1063 end if;
|
|
|
1064
|
|
|
1065 if Ref.Line > Line then
|
|
|
1066
|
|
|
1067 -- Do not free Current_Line, it is referenced by the last
|
|
|
1068 -- Ref we processed.
|
|
|
1069
|
|
|
1070 loop
|
|
|
1071 Index := End_Index + 1;
|
|
|
1072
|
|
|
1073 loop
|
|
|
1074 End_Index := End_Index + 1;
|
|
|
1075 exit when End_Index > Buffer'Last
|
|
|
1076 or else Buffer (End_Index) = ASCII.LF;
|
|
|
1077 end loop;
|
|
|
1078
|
|
|
1079 -- Skip spaces at beginning of line
|
|
|
1080
|
|
|
1081 while Index < End_Index and then
|
|
|
1082 (Buffer (Index) = ' ' or else Buffer (Index) = ASCII.HT)
|
|
|
1083 loop
|
|
|
1084 Index := Index + 1;
|
|
|
1085 end loop;
|
|
|
1086
|
|
|
1087 Line := Line + 1;
|
|
|
1088 exit when Ref.Line = Line;
|
|
|
1089 end loop;
|
|
|
1090
|
|
|
1091 Current_Line := new String'(Buffer (Index .. End_Index - 1));
|
|
|
1092 end if;
|
|
|
1093
|
|
|
1094 Ref.Source_Line := Current_Line;
|
|
|
1095 end loop;
|
|
|
1096
|
|
|
1097 Free (Buffer);
|
|
|
1098 Free (Arr);
|
|
|
1099 end Grep_Source_Files;
|
|
|
1100
|
|
|
1101 ---------------
|
|
|
1102 -- Read_File --
|
|
|
1103 ---------------
|
|
|
1104
|
|
|
1105 procedure Read_File
|
|
|
1106 (File_Name : String;
|
|
|
1107 Contents : out GNAT.OS_Lib.String_Access)
|
|
|
1108 is
|
|
|
1109 Name_0 : constant String := File_Name & ASCII.NUL;
|
|
|
1110 FD : constant File_Descriptor := Open_Read (Name_0'Address, Binary);
|
|
|
1111 Length : Natural;
|
|
|
1112
|
|
|
1113 begin
|
|
|
1114 if FD = Invalid_FD then
|
|
|
1115 raise Ada.Text_IO.Name_Error;
|
|
|
1116 end if;
|
|
|
1117
|
|
|
1118 -- Include room for EOF char
|
|
|
1119
|
|
|
1120 Length := Natural (File_Length (FD));
|
|
|
1121
|
|
|
1122 declare
|
|
|
1123 Buffer : String (1 .. Length + 1);
|
|
|
1124 This_Read : Integer;
|
|
|
1125 Read_Ptr : Natural := 1;
|
|
|
1126
|
|
|
1127 begin
|
|
|
1128 loop
|
|
|
1129 This_Read := Read (FD,
|
|
|
1130 A => Buffer (Read_Ptr)'Address,
|
|
|
1131 N => Length + 1 - Read_Ptr);
|
|
|
1132 Read_Ptr := Read_Ptr + Integer'Max (This_Read, 0);
|
|
|
1133 exit when This_Read <= 0;
|
|
|
1134 end loop;
|
|
|
1135
|
|
|
1136 Buffer (Read_Ptr) := EOF;
|
|
|
1137 Contents := new String'(Buffer (1 .. Read_Ptr));
|
|
|
1138
|
|
|
1139 if Read_Ptr /= Length + 1 then
|
|
|
1140 raise Ada.Text_IO.End_Error;
|
|
|
1141 end if;
|
|
|
1142
|
|
|
1143 Close (FD);
|
|
|
1144 end;
|
|
|
1145 end Read_File;
|
|
|
1146
|
|
|
1147 -----------------------
|
|
|
1148 -- Longest_File_Name --
|
|
|
1149 -----------------------
|
|
|
1150
|
|
|
1151 function Longest_File_Name return Natural is
|
|
|
1152 begin
|
|
|
1153 return Longest_File_Name_In_Table;
|
|
|
1154 end Longest_File_Name;
|
|
|
1155
|
|
|
1156 -----------
|
|
|
1157 -- Match --
|
|
|
1158 -----------
|
|
|
1159
|
|
|
1160 function Match
|
|
|
1161 (File : File_Reference;
|
|
|
1162 Line : Natural;
|
|
|
1163 Column : Natural)
|
|
|
1164 return Boolean
|
|
|
1165 is
|
|
|
1166 Ref : Ref_In_File_Ptr := File.Lines;
|
|
|
1167
|
|
|
1168 begin
|
|
|
1169 while Ref /= null loop
|
|
|
1170 if (Ref.Line = 0 or else Ref.Line = Line)
|
|
|
1171 and then (Ref.Column = 0 or else Ref.Column = Column)
|
|
|
1172 then
|
|
|
1173 return True;
|
|
|
1174 end if;
|
|
|
1175
|
|
|
1176 Ref := Ref.Next;
|
|
|
1177 end loop;
|
|
|
1178
|
|
|
1179 return False;
|
|
|
1180 end Match;
|
|
|
1181
|
|
|
1182 -----------
|
|
|
1183 -- Match --
|
|
|
1184 -----------
|
|
|
1185
|
|
|
1186 function Match (Decl : Declaration_Reference) return Boolean is
|
|
|
1187 begin
|
|
|
1188 return Decl.Match;
|
|
|
1189 end Match;
|
|
|
1190
|
|
|
1191 ----------
|
|
|
1192 -- Next --
|
|
|
1193 ----------
|
|
|
1194
|
|
|
1195 function Next (E : File_Reference) return File_Reference is
|
|
|
1196 begin
|
|
|
1197 return E.Next;
|
|
|
1198 end Next;
|
|
|
1199
|
|
|
1200 function Next (E : Declaration_Reference) return Declaration_Reference is
|
|
|
1201 begin
|
|
|
1202 return E.Next;
|
|
|
1203 end Next;
|
|
|
1204
|
|
|
1205 ------------------
|
|
|
1206 -- Next_Obj_Dir --
|
|
|
1207 ------------------
|
|
|
1208
|
|
|
1209 function Next_Obj_Dir return String is
|
|
|
1210 First : constant Integer := Directories.Obj_Dir_Index;
|
|
|
1211 Last : Integer;
|
|
|
1212
|
|
|
1213 begin
|
|
|
1214 Last := Directories.Obj_Dir_Index;
|
|
|
1215
|
|
|
1216 if Last > Directories.Obj_Dir_Length then
|
|
|
1217 return String'(1 .. 0 => ' ');
|
|
|
1218 end if;
|
|
|
1219
|
|
|
1220 while Directories.Obj_Dir (Last) /= Path_Separator loop
|
|
|
1221 Last := Last + 1;
|
|
|
1222 end loop;
|
|
|
1223
|
|
|
1224 Directories.Obj_Dir_Index := Last + 1;
|
|
|
1225 Directories.Last_Obj_Dir_Start := First;
|
|
|
1226 return Directories.Obj_Dir (First .. Last - 1);
|
|
|
1227 end Next_Obj_Dir;
|
|
|
1228
|
|
|
1229 -------------------------
|
|
|
1230 -- Next_Unvisited_File --
|
|
|
1231 -------------------------
|
|
|
1232
|
|
|
1233 function Next_Unvisited_File return File_Reference is
|
|
|
1234 procedure Unchecked_Free is new Ada.Unchecked_Deallocation
|
|
|
1235 (Unvisited_Files_Record, Unvisited_Files_Access);
|
|
|
1236
|
|
|
1237 Ref : File_Reference;
|
|
|
1238 Tmp : Unvisited_Files_Access;
|
|
|
1239
|
|
|
1240 begin
|
|
|
1241 if Unvisited_Files = null then
|
|
|
1242 return Empty_File;
|
|
|
1243 else
|
|
|
1244 Tmp := Unvisited_Files;
|
|
|
1245 Ref := Unvisited_Files.File;
|
|
|
1246 Unvisited_Files := Unvisited_Files.Next;
|
|
|
1247 Unchecked_Free (Tmp);
|
|
|
1248 return Ref;
|
|
|
1249 end if;
|
|
|
1250 end Next_Unvisited_File;
|
|
|
1251
|
|
|
1252 ----------------------
|
|
|
1253 -- Parse_Gnatls_Src --
|
|
|
1254 ----------------------
|
|
|
1255
|
|
|
1256 function Parse_Gnatls_Src return String is
|
|
|
1257 Length : Natural;
|
|
|
1258
|
|
|
1259 begin
|
|
|
1260 Length := 0;
|
|
|
1261 for J in 1 .. Osint.Nb_Dir_In_Src_Search_Path loop
|
|
|
1262 if Osint.Dir_In_Src_Search_Path (J)'Length = 0 then
|
|
|
1263 Length := Length + 2;
|
|
|
1264 else
|
|
|
1265 Length := Length + Osint.Dir_In_Src_Search_Path (J)'Length + 1;
|
|
|
1266 end if;
|
|
|
1267 end loop;
|
|
|
1268
|
|
|
1269 declare
|
|
|
1270 Result : String (1 .. Length);
|
|
|
1271 L : Natural;
|
|
|
1272
|
|
|
1273 begin
|
|
|
1274 L := Result'First;
|
|
|
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 Result (L .. L + 1) := "." & Path_Separator;
|
|
|
1278 L := L + 2;
|
|
|
1279
|
|
|
1280 else
|
|
|
1281 Result (L .. L + Osint.Dir_In_Src_Search_Path (J)'Length - 1) :=
|
|
|
1282 Osint.Dir_In_Src_Search_Path (J).all;
|
|
|
1283 L := L + Osint.Dir_In_Src_Search_Path (J)'Length;
|
|
|
1284 Result (L) := Path_Separator;
|
|
|
1285 L := L + 1;
|
|
|
1286 end if;
|
|
|
1287 end loop;
|
|
|
1288
|
|
|
1289 return Result;
|
|
|
1290 end;
|
|
|
1291 end Parse_Gnatls_Src;
|
|
|
1292
|
|
|
1293 ----------------------
|
|
|
1294 -- Parse_Gnatls_Obj --
|
|
|
1295 ----------------------
|
|
|
1296
|
|
|
1297 function Parse_Gnatls_Obj return String is
|
|
|
1298 Length : Natural;
|
|
|
1299
|
|
|
1300 begin
|
|
|
1301 Length := 0;
|
|
|
1302 for J in 1 .. Osint.Nb_Dir_In_Obj_Search_Path loop
|
|
|
1303 if Osint.Dir_In_Obj_Search_Path (J)'Length = 0 then
|
|
|
1304 Length := Length + 2;
|
|
|
1305 else
|
|
|
1306 Length := Length + Osint.Dir_In_Obj_Search_Path (J)'Length + 1;
|
|
|
1307 end if;
|
|
|
1308 end loop;
|
|
|
1309
|
|
|
1310 declare
|
|
|
1311 Result : String (1 .. Length);
|
|
|
1312 L : Natural;
|
|
|
1313
|
|
|
1314 begin
|
|
|
1315 L := Result'First;
|
|
|
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 Result (L .. L + 1) := "." & Path_Separator;
|
|
|
1319 L := L + 2;
|
|
|
1320 else
|
|
|
1321 Result (L .. L + Osint.Dir_In_Obj_Search_Path (J)'Length - 1) :=
|
|
|
1322 Osint.Dir_In_Obj_Search_Path (J).all;
|
|
|
1323 L := L + Osint.Dir_In_Obj_Search_Path (J)'Length;
|
|
|
1324 Result (L) := Path_Separator;
|
|
|
1325 L := L + 1;
|
|
|
1326 end if;
|
|
|
1327 end loop;
|
|
|
1328
|
|
|
1329 return Result;
|
|
|
1330 end;
|
|
|
1331 end Parse_Gnatls_Obj;
|
|
|
1332
|
|
|
1333 -------------------
|
|
|
1334 -- Reset_Obj_Dir --
|
|
|
1335 -------------------
|
|
|
1336
|
|
|
1337 procedure Reset_Obj_Dir is
|
|
|
1338 begin
|
|
|
1339 Directories.Obj_Dir_Index := 1;
|
|
|
1340 end Reset_Obj_Dir;
|
|
|
1341
|
|
|
1342 -----------------------
|
|
|
1343 -- Set_Default_Match --
|
|
|
1344 -----------------------
|
|
|
1345
|
|
|
1346 procedure Set_Default_Match (Value : Boolean) is
|
|
|
1347 begin
|
|
|
1348 Default_Match := Value;
|
|
|
1349 end Set_Default_Match;
|
|
|
1350
|
|
|
1351 ----------
|
|
|
1352 -- Free --
|
|
|
1353 ----------
|
|
|
1354
|
|
|
1355 procedure Free (Str : in out Cst_String_Access) is
|
|
|
1356 function Convert is new Ada.Unchecked_Conversion
|
|
|
1357 (Cst_String_Access, GNAT.OS_Lib.String_Access);
|
|
|
1358
|
|
|
1359 S : GNAT.OS_Lib.String_Access := Convert (Str);
|
|
|
1360
|
|
|
1361 begin
|
|
|
1362 Free (S);
|
|
|
1363 Str := null;
|
|
|
1364 end Free;
|
|
|
1365
|
|
|
1366 ---------------------
|
|
|
1367 -- Reset_Directory --
|
|
|
1368 ---------------------
|
|
|
1369
|
|
|
1370 procedure Reset_Directory (File : File_Reference) is
|
|
|
1371 begin
|
|
|
1372 Free (File.Dir);
|
|
|
1373 end Reset_Directory;
|
|
|
1374
|
|
|
1375 -------------------
|
|
|
1376 -- Set_Unvisited --
|
|
|
1377 -------------------
|
|
|
1378
|
|
|
1379 procedure Set_Unvisited (File_Ref : File_Reference) is
|
|
|
1380 F : constant String := Get_File (File_Ref, With_Dir => False);
|
|
|
1381
|
|
|
1382 begin
|
|
|
1383 File_Ref.Visited := False;
|
|
|
1384
|
|
|
1385 -- ??? Do not add a source file to the list. This is true at
|
|
|
1386 -- least for gnatxref, and probably for gnatfind as well
|
|
|
1387
|
|
|
1388 if F'Length > 4
|
|
|
1389 and then F (F'Last - 3 .. F'Last) = "." & Osint.ALI_Suffix.all
|
|
|
1390 then
|
|
|
1391 Unvisited_Files := new Unvisited_Files_Record'
|
|
|
1392 (File => File_Ref,
|
|
|
1393 Next => Unvisited_Files);
|
|
|
1394 end if;
|
|
|
1395 end Set_Unvisited;
|
|
|
1396
|
|
|
1397 ----------------------
|
|
|
1398 -- Get_Declarations --
|
|
|
1399 ----------------------
|
|
|
1400
|
|
|
1401 function Get_Declarations
|
|
|
1402 (Sorted : Boolean := True)
|
|
|
1403 return Declaration_Array_Access
|
|
|
1404 is
|
|
|
1405 Arr : constant Declaration_Array_Access :=
|
|
|
1406 new Declaration_Array (1 .. Entities_Count);
|
|
|
1407 Decl : Declaration_Reference := Entities_HTable.Get_First;
|
|
|
1408 Index : Natural := Arr'First;
|
|
|
1409 Tmp : Declaration_Reference;
|
|
|
1410
|
|
|
1411 procedure Move (From : Natural; To : Natural);
|
|
|
1412 function Lt (Op1, Op2 : Natural) return Boolean;
|
|
|
1413 -- See GNAT.Heap_Sort_G
|
|
|
1414
|
|
|
1415 --------
|
|
|
1416 -- Lt --
|
|
|
1417 --------
|
|
|
1418
|
|
|
1419 function Lt (Op1, Op2 : Natural) return Boolean is
|
|
|
1420 begin
|
|
|
1421 if Op1 = 0 then
|
|
|
1422 return Is_Less_Than (Tmp, Arr (Op2));
|
|
|
1423 elsif Op2 = 0 then
|
|
|
1424 return Is_Less_Than (Arr (Op1), Tmp);
|
|
|
1425 else
|
|
|
1426 return Is_Less_Than (Arr (Op1), Arr (Op2));
|
|
|
1427 end if;
|
|
|
1428 end Lt;
|
|
|
1429
|
|
|
1430 ----------
|
|
|
1431 -- Move --
|
|
|
1432 ----------
|
|
|
1433
|
|
|
1434 procedure Move (From : Natural; To : Natural) is
|
|
|
1435 begin
|
|
|
1436 if To = 0 then
|
|
|
1437 Tmp := Arr (From);
|
|
|
1438 elsif From = 0 then
|
|
|
1439 Arr (To) := Tmp;
|
|
|
1440 else
|
|
|
1441 Arr (To) := Arr (From);
|
|
|
1442 end if;
|
|
|
1443 end Move;
|
|
|
1444
|
|
|
1445 package Decl_Sort is new GNAT.Heap_Sort_G (Move, Lt);
|
|
|
1446
|
|
|
1447 -- Start of processing for Get_Declarations
|
|
|
1448
|
|
|
1449 begin
|
|
|
1450 while Decl /= null loop
|
|
|
1451 Arr (Index) := Decl;
|
|
|
1452 Index := Index + 1;
|
|
|
1453 Decl := Entities_HTable.Get_Next;
|
|
|
1454 end loop;
|
|
|
1455
|
|
|
1456 if Sorted and then Arr'Length /= 0 then
|
|
|
1457 Decl_Sort.Sort (Entities_Count);
|
|
|
1458 end if;
|
|
|
1459
|
|
|
1460 return Arr;
|
|
|
1461 end Get_Declarations;
|
|
|
1462
|
|
|
1463 ----------------------
|
|
|
1464 -- References_Count --
|
|
|
1465 ----------------------
|
|
|
1466
|
|
|
1467 function References_Count
|
|
|
1468 (Decl : Declaration_Reference;
|
|
|
1469 Get_Reads : Boolean := False;
|
|
|
1470 Get_Writes : Boolean := False;
|
|
|
1471 Get_Bodies : Boolean := False)
|
|
|
1472 return Natural
|
|
|
1473 is
|
|
|
1474 function List_Length (E : Reference) return Natural;
|
|
|
1475 -- Return the number of references in E
|
|
|
1476
|
|
|
1477 -----------------
|
|
|
1478 -- List_Length --
|
|
|
1479 -----------------
|
|
|
1480
|
|
|
1481 function List_Length (E : Reference) return Natural is
|
|
|
1482 L : Natural := 0;
|
|
|
1483 E1 : Reference := E;
|
|
|
1484
|
|
|
1485 begin
|
|
|
1486 while E1 /= null loop
|
|
|
1487 L := L + 1;
|
|
|
1488 E1 := E1.Next;
|
|
|
1489 end loop;
|
|
|
1490
|
|
|
1491 return L;
|
|
|
1492 end List_Length;
|
|
|
1493
|
|
|
1494 Length : Natural := 0;
|
|
|
1495
|
|
|
1496 -- Start of processing for References_Count
|
|
|
1497
|
|
|
1498 begin
|
|
|
1499 if Get_Reads then
|
|
|
1500 Length := List_Length (Decl.Ref_Ref);
|
|
|
1501 end if;
|
|
|
1502
|
|
|
1503 if Get_Writes then
|
|
|
1504 Length := Length + List_Length (Decl.Modif_Ref);
|
|
|
1505 end if;
|
|
|
1506
|
|
|
1507 if Get_Bodies then
|
|
|
1508 Length := Length + List_Length (Decl.Body_Ref);
|
|
|
1509 end if;
|
|
|
1510
|
|
|
1511 return Length;
|
|
|
1512 end References_Count;
|
|
|
1513
|
|
|
1514 ----------------------
|
|
|
1515 -- Store_References --
|
|
|
1516 ----------------------
|
|
|
1517
|
|
|
1518 procedure Store_References
|
|
|
1519 (Decl : Declaration_Reference;
|
|
|
1520 Get_Writes : Boolean := False;
|
|
|
1521 Get_Reads : Boolean := False;
|
|
|
1522 Get_Bodies : Boolean := False;
|
|
|
1523 Get_Declaration : Boolean := False;
|
|
|
1524 Arr : in out Reference_Array;
|
|
|
1525 Index : in out Natural)
|
|
|
1526 is
|
|
|
1527 procedure Add (List : Reference);
|
|
|
1528 -- Add all the references in List to Arr
|
|
|
1529
|
|
|
1530 ---------
|
|
|
1531 -- Add --
|
|
|
1532 ---------
|
|
|
1533
|
|
|
1534 procedure Add (List : Reference) is
|
|
|
1535 E : Reference := List;
|
|
|
1536 begin
|
|
|
1537 while E /= null loop
|
|
|
1538 Arr (Index) := E;
|
|
|
1539 Index := Index + 1;
|
|
|
1540 E := E.Next;
|
|
|
1541 end loop;
|
|
|
1542 end Add;
|
|
|
1543
|
|
|
1544 -- Start of processing for Store_References
|
|
|
1545
|
|
|
1546 begin
|
|
|
1547 if Get_Declaration then
|
|
|
1548 Add (Decl.Decl);
|
|
|
1549 end if;
|
|
|
1550
|
|
|
1551 if Get_Reads then
|
|
|
1552 Add (Decl.Ref_Ref);
|
|
|
1553 end if;
|
|
|
1554
|
|
|
1555 if Get_Writes then
|
|
|
1556 Add (Decl.Modif_Ref);
|
|
|
1557 end if;
|
|
|
1558
|
|
|
1559 if Get_Bodies then
|
|
|
1560 Add (Decl.Body_Ref);
|
|
|
1561 end if;
|
|
|
1562 end Store_References;
|
|
|
1563
|
|
|
1564 --------------------
|
|
|
1565 -- Get_References --
|
|
|
1566 --------------------
|
|
|
1567
|
|
|
1568 function Get_References
|
|
|
1569 (Decl : Declaration_Reference;
|
|
|
1570 Get_Reads : Boolean := False;
|
|
|
1571 Get_Writes : Boolean := False;
|
|
|
1572 Get_Bodies : Boolean := False)
|
|
|
1573 return Reference_Array_Access
|
|
|
1574 is
|
|
|
1575 Length : constant Natural :=
|
|
|
1576 References_Count (Decl, Get_Reads, Get_Writes, Get_Bodies);
|
|
|
1577
|
|
|
1578 Arr : constant Reference_Array_Access :=
|
|
|
1579 new Reference_Array (1 .. Length);
|
|
|
1580
|
|
|
1581 Index : Natural := Arr'First;
|
|
|
1582
|
|
|
1583 begin
|
|
|
1584 Store_References
|
|
|
1585 (Decl => Decl,
|
|
|
1586 Get_Writes => Get_Writes,
|
|
|
1587 Get_Reads => Get_Reads,
|
|
|
1588 Get_Bodies => Get_Bodies,
|
|
|
1589 Get_Declaration => False,
|
|
|
1590 Arr => Arr.all,
|
|
|
1591 Index => Index);
|
|
|
1592
|
|
|
1593 if Arr'Length /= 0 then
|
|
|
1594 Sort (Arr.all);
|
|
|
1595 end if;
|
|
|
1596
|
|
|
1597 return Arr;
|
|
|
1598 end Get_References;
|
|
|
1599
|
|
|
1600 ----------
|
|
|
1601 -- Free --
|
|
|
1602 ----------
|
|
|
1603
|
|
|
1604 procedure Free (Arr : in out Reference_Array_Access) is
|
|
|
1605 procedure Internal is new Ada.Unchecked_Deallocation
|
|
|
1606 (Reference_Array, Reference_Array_Access);
|
|
|
1607 begin
|
|
|
1608 Internal (Arr);
|
|
|
1609 end Free;
|
|
|
1610
|
|
|
1611 ------------------
|
|
|
1612 -- Is_Parameter --
|
|
|
1613 ------------------
|
|
|
1614
|
|
|
1615 function Is_Parameter (Decl : Declaration_Reference) return Boolean is
|
|
|
1616 begin
|
|
|
1617 return Decl.Is_Parameter;
|
|
|
1618 end Is_Parameter;
|
|
|
1619
|
|
|
1620 end Xr_Tabls;
|
