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