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