File : xr_tabls.adb
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-2014, 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; use 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' | 'm' | 'o' | 'r' | 'R' |
405 's' | 'i' | ' ' | 'x' =>
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 'e' | 'E' | 'z' | 't' | 'p' | 'P' | 'k' | 'd' =>
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 'r' | 'R' | 's' | 'H' | 'i' | 'l' | 'o' | ' ' | 'x' | 'w' =>
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;