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