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-2018, 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 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 1620end Xr_Tabls; 1621