1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- P R J . E N V -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 2001-2013, 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 Fmap; 27with Hostparm; 28with Makeutl; use Makeutl; 29with Opt; 30with Osint; use Osint; 31with Output; use Output; 32with Prj.Com; use Prj.Com; 33with Sdefault; 34with Tempdir; 35 36with GNAT.Directory_Operations; use GNAT.Directory_Operations; 37 38package body Prj.Env is 39 40 Buffer_Initial : constant := 1_000; 41 -- Initial size of Buffer 42 43 Uninitialized_Prefix : constant String := '#' & Path_Separator; 44 -- Prefix to indicate that the project path has not been initialized yet. 45 -- Must be two characters long 46 47 No_Project_Default_Dir : constant String := "-"; 48 -- Indicator in the project path to indicate that the default search 49 -- directories should not be added to the path 50 51 ----------------------- 52 -- Local Subprograms -- 53 ----------------------- 54 55 package Source_Path_Table is new GNAT.Dynamic_Tables 56 (Table_Component_Type => Name_Id, 57 Table_Index_Type => Natural, 58 Table_Low_Bound => 1, 59 Table_Initial => 50, 60 Table_Increment => 100); 61 -- A table to store the source dirs before creating the source path file 62 63 package Object_Path_Table is new GNAT.Dynamic_Tables 64 (Table_Component_Type => Path_Name_Type, 65 Table_Index_Type => Natural, 66 Table_Low_Bound => 1, 67 Table_Initial => 50, 68 Table_Increment => 100); 69 -- A table to store the object dirs, before creating the object path file 70 71 procedure Add_To_Buffer 72 (S : String; 73 Buffer : in out String_Access; 74 Buffer_Last : in out Natural); 75 -- Add a string to Buffer, extending Buffer if needed 76 77 procedure Add_To_Path 78 (Source_Dirs : String_List_Id; 79 Shared : Shared_Project_Tree_Data_Access; 80 Buffer : in out String_Access; 81 Buffer_Last : in out Natural); 82 -- Add to Ada_Path_Buffer all the source directories in string list 83 -- Source_Dirs, if any. 84 85 procedure Add_To_Path 86 (Dir : String; 87 Buffer : in out String_Access; 88 Buffer_Last : in out Natural); 89 -- If Dir is not already in the global variable Ada_Path_Buffer, add it. 90 -- If Buffer_Last /= 0, prepend a Path_Separator character to Path. 91 92 procedure Add_To_Source_Path 93 (Source_Dirs : String_List_Id; 94 Shared : Shared_Project_Tree_Data_Access; 95 Source_Paths : in out Source_Path_Table.Instance); 96 -- Add to Ada_Path_B all the source directories in string list 97 -- Source_Dirs, if any. Increment Ada_Path_Length. 98 99 procedure Add_To_Object_Path 100 (Object_Dir : Path_Name_Type; 101 Object_Paths : in out Object_Path_Table.Instance); 102 -- Add Object_Dir to object path table. Make sure it is not duplicate 103 -- and it is the last one in the current table. 104 105 ---------------------- 106 -- Ada_Include_Path -- 107 ---------------------- 108 109 function Ada_Include_Path 110 (Project : Project_Id; 111 In_Tree : Project_Tree_Ref; 112 Recursive : Boolean := False) return String 113 is 114 Buffer : String_Access; 115 Buffer_Last : Natural := 0; 116 117 procedure Add 118 (Project : Project_Id; 119 In_Tree : Project_Tree_Ref; 120 Dummy : in out Boolean); 121 -- Add source dirs of Project to the path 122 123 --------- 124 -- Add -- 125 --------- 126 127 procedure Add 128 (Project : Project_Id; 129 In_Tree : Project_Tree_Ref; 130 Dummy : in out Boolean) 131 is 132 pragma Unreferenced (Dummy); 133 begin 134 Add_To_Path 135 (Project.Source_Dirs, In_Tree.Shared, Buffer, Buffer_Last); 136 end Add; 137 138 procedure For_All_Projects is 139 new For_Every_Project_Imported (Boolean, Add); 140 141 Dummy : Boolean := False; 142 143 -- Start of processing for Ada_Include_Path 144 145 begin 146 if Recursive then 147 148 -- If it is the first time we call this function for 149 -- this project, compute the source path 150 151 if Project.Ada_Include_Path = null then 152 Buffer := new String (1 .. 4096); 153 For_All_Projects 154 (Project, In_Tree, Dummy, Include_Aggregated => True); 155 Project.Ada_Include_Path := new String'(Buffer (1 .. Buffer_Last)); 156 Free (Buffer); 157 end if; 158 159 return Project.Ada_Include_Path.all; 160 161 else 162 Buffer := new String (1 .. 4096); 163 Add_To_Path 164 (Project.Source_Dirs, In_Tree.Shared, Buffer, Buffer_Last); 165 166 declare 167 Result : constant String := Buffer (1 .. Buffer_Last); 168 begin 169 Free (Buffer); 170 return Result; 171 end; 172 end if; 173 end Ada_Include_Path; 174 175 ---------------------- 176 -- Ada_Objects_Path -- 177 ---------------------- 178 179 function Ada_Objects_Path 180 (Project : Project_Id; 181 In_Tree : Project_Tree_Ref; 182 Including_Libraries : Boolean := True) return String_Access 183 is 184 Buffer : String_Access; 185 Buffer_Last : Natural := 0; 186 187 procedure Add 188 (Project : Project_Id; 189 In_Tree : Project_Tree_Ref; 190 Dummy : in out Boolean); 191 -- Add all the object directories of a project to the path 192 193 --------- 194 -- Add -- 195 --------- 196 197 procedure Add 198 (Project : Project_Id; 199 In_Tree : Project_Tree_Ref; 200 Dummy : in out Boolean) 201 is 202 pragma Unreferenced (Dummy, In_Tree); 203 204 Path : constant Path_Name_Type := 205 Get_Object_Directory 206 (Project, 207 Including_Libraries => Including_Libraries, 208 Only_If_Ada => False); 209 begin 210 if Path /= No_Path then 211 Add_To_Path (Get_Name_String (Path), Buffer, Buffer_Last); 212 end if; 213 end Add; 214 215 procedure For_All_Projects is 216 new For_Every_Project_Imported (Boolean, Add); 217 218 Dummy : Boolean := False; 219 220 -- Start of processing for Ada_Objects_Path 221 222 begin 223 -- If it is the first time we call this function for 224 -- this project, compute the objects path 225 226 if Project.Ada_Objects_Path = null then 227 Buffer := new String (1 .. 4096); 228 For_All_Projects (Project, In_Tree, Dummy); 229 230 Project.Ada_Objects_Path := new String'(Buffer (1 .. Buffer_Last)); 231 Free (Buffer); 232 end if; 233 234 return Project.Ada_Objects_Path; 235 end Ada_Objects_Path; 236 237 ------------------- 238 -- Add_To_Buffer -- 239 ------------------- 240 241 procedure Add_To_Buffer 242 (S : String; 243 Buffer : in out String_Access; 244 Buffer_Last : in out Natural) 245 is 246 Last : constant Natural := Buffer_Last + S'Length; 247 248 begin 249 while Last > Buffer'Last loop 250 declare 251 New_Buffer : constant String_Access := 252 new String (1 .. 2 * Buffer'Last); 253 begin 254 New_Buffer (1 .. Buffer_Last) := Buffer (1 .. Buffer_Last); 255 Free (Buffer); 256 Buffer := New_Buffer; 257 end; 258 end loop; 259 260 Buffer (Buffer_Last + 1 .. Last) := S; 261 Buffer_Last := Last; 262 end Add_To_Buffer; 263 264 ------------------------ 265 -- Add_To_Object_Path -- 266 ------------------------ 267 268 procedure Add_To_Object_Path 269 (Object_Dir : Path_Name_Type; 270 Object_Paths : in out Object_Path_Table.Instance) 271 is 272 begin 273 -- Check if the directory is already in the table 274 275 for Index in 276 Object_Path_Table.First .. Object_Path_Table.Last (Object_Paths) 277 loop 278 279 -- If it is, remove it, and add it as the last one 280 281 if Object_Paths.Table (Index) = Object_Dir then 282 for Index2 in 283 Index + 1 .. Object_Path_Table.Last (Object_Paths) 284 loop 285 Object_Paths.Table (Index2 - 1) := Object_Paths.Table (Index2); 286 end loop; 287 288 Object_Paths.Table 289 (Object_Path_Table.Last (Object_Paths)) := Object_Dir; 290 return; 291 end if; 292 end loop; 293 294 -- The directory is not already in the table, add it 295 296 Object_Path_Table.Append (Object_Paths, Object_Dir); 297 end Add_To_Object_Path; 298 299 ----------------- 300 -- Add_To_Path -- 301 ----------------- 302 303 procedure Add_To_Path 304 (Source_Dirs : String_List_Id; 305 Shared : Shared_Project_Tree_Data_Access; 306 Buffer : in out String_Access; 307 Buffer_Last : in out Natural) 308 is 309 Current : String_List_Id := Source_Dirs; 310 Source_Dir : String_Element; 311 begin 312 while Current /= Nil_String loop 313 Source_Dir := Shared.String_Elements.Table (Current); 314 Add_To_Path (Get_Name_String (Source_Dir.Display_Value), 315 Buffer, Buffer_Last); 316 Current := Source_Dir.Next; 317 end loop; 318 end Add_To_Path; 319 320 procedure Add_To_Path 321 (Dir : String; 322 Buffer : in out String_Access; 323 Buffer_Last : in out Natural) 324 is 325 Len : Natural; 326 New_Buffer : String_Access; 327 Min_Len : Natural; 328 329 function Is_Present (Path : String; Dir : String) return Boolean; 330 -- Return True if Dir is part of Path 331 332 ---------------- 333 -- Is_Present -- 334 ---------------- 335 336 function Is_Present (Path : String; Dir : String) return Boolean is 337 Last : constant Integer := Path'Last - Dir'Length + 1; 338 339 begin 340 for J in Path'First .. Last loop 341 342 -- Note: the order of the conditions below is important, since 343 -- it ensures a minimal number of string comparisons. 344 345 if (J = Path'First 346 or else Path (J - 1) = Path_Separator) 347 and then 348 (J + Dir'Length > Path'Last 349 or else Path (J + Dir'Length) = Path_Separator) 350 and then Dir = Path (J .. J + Dir'Length - 1) 351 then 352 return True; 353 end if; 354 end loop; 355 356 return False; 357 end Is_Present; 358 359 -- Start of processing for Add_To_Path 360 361 begin 362 if Is_Present (Buffer (1 .. Buffer_Last), Dir) then 363 364 -- Dir is already in the path, nothing to do 365 366 return; 367 end if; 368 369 Min_Len := Buffer_Last + Dir'Length; 370 371 if Buffer_Last > 0 then 372 373 -- Add 1 for the Path_Separator character 374 375 Min_Len := Min_Len + 1; 376 end if; 377 378 -- If Ada_Path_Buffer is too small, increase it 379 380 Len := Buffer'Last; 381 382 if Len < Min_Len then 383 loop 384 Len := Len * 2; 385 exit when Len >= Min_Len; 386 end loop; 387 388 New_Buffer := new String (1 .. Len); 389 New_Buffer (1 .. Buffer_Last) := Buffer (1 .. Buffer_Last); 390 Free (Buffer); 391 Buffer := New_Buffer; 392 end if; 393 394 if Buffer_Last > 0 then 395 Buffer_Last := Buffer_Last + 1; 396 Buffer (Buffer_Last) := Path_Separator; 397 end if; 398 399 Buffer (Buffer_Last + 1 .. Buffer_Last + Dir'Length) := Dir; 400 Buffer_Last := Buffer_Last + Dir'Length; 401 end Add_To_Path; 402 403 ------------------------ 404 -- Add_To_Source_Path -- 405 ------------------------ 406 407 procedure Add_To_Source_Path 408 (Source_Dirs : String_List_Id; 409 Shared : Shared_Project_Tree_Data_Access; 410 Source_Paths : in out Source_Path_Table.Instance) 411 is 412 Current : String_List_Id := Source_Dirs; 413 Source_Dir : String_Element; 414 Add_It : Boolean; 415 416 begin 417 -- Add each source directory 418 419 while Current /= Nil_String loop 420 Source_Dir := Shared.String_Elements.Table (Current); 421 Add_It := True; 422 423 -- Check if the source directory is already in the table 424 425 for Index in 426 Source_Path_Table.First .. Source_Path_Table.Last (Source_Paths) 427 loop 428 -- If it is already, no need to add it 429 430 if Source_Paths.Table (Index) = Source_Dir.Value then 431 Add_It := False; 432 exit; 433 end if; 434 end loop; 435 436 if Add_It then 437 Source_Path_Table.Append (Source_Paths, Source_Dir.Display_Value); 438 end if; 439 440 -- Next source directory 441 442 Current := Source_Dir.Next; 443 end loop; 444 end Add_To_Source_Path; 445 446 -------------------------------- 447 -- Create_Config_Pragmas_File -- 448 -------------------------------- 449 450 procedure Create_Config_Pragmas_File 451 (For_Project : Project_Id; 452 In_Tree : Project_Tree_Ref) 453 is 454 type Naming_Id is new Nat; 455 package Naming_Table is new GNAT.Dynamic_Tables 456 (Table_Component_Type => Lang_Naming_Data, 457 Table_Index_Type => Naming_Id, 458 Table_Low_Bound => 1, 459 Table_Initial => 5, 460 Table_Increment => 100); 461 462 Default_Naming : constant Naming_Id := Naming_Table.First; 463 Namings : Naming_Table.Instance; 464 -- Table storing the naming data for gnatmake/gprmake 465 466 Buffer : String_Access := new String (1 .. Buffer_Initial); 467 Buffer_Last : Natural := 0; 468 469 File_Name : Path_Name_Type := No_Path; 470 File : File_Descriptor := Invalid_FD; 471 472 Current_Naming : Naming_Id; 473 474 procedure Check 475 (Project : Project_Id; 476 In_Tree : Project_Tree_Ref; 477 State : in out Integer); 478 -- Recursive procedure that put in the config pragmas file any non 479 -- standard naming schemes, if it is not already in the file, then call 480 -- itself for any imported project. 481 482 procedure Put (Source : Source_Id); 483 -- Put an SFN pragma in the temporary file 484 485 procedure Put (S : String); 486 procedure Put_Line (S : String); 487 -- Output procedures, analogous to normal Text_IO procs of same name. 488 -- The text is put in Buffer, then it will be written into a temporary 489 -- file with procedure Write_Temp_File below. 490 491 procedure Write_Temp_File; 492 -- Create a temporary file and put the content of the buffer in it 493 494 ----------- 495 -- Check -- 496 ----------- 497 498 procedure Check 499 (Project : Project_Id; 500 In_Tree : Project_Tree_Ref; 501 State : in out Integer) 502 is 503 pragma Unreferenced (State); 504 505 Lang : constant Language_Ptr := 506 Get_Language_From_Name (Project, "ada"); 507 Naming : Lang_Naming_Data; 508 Iter : Source_Iterator; 509 Source : Source_Id; 510 511 begin 512 if Current_Verbosity = High then 513 Debug_Output ("Checking project file:", Project.Name); 514 end if; 515 516 if Lang = null then 517 if Current_Verbosity = High then 518 Debug_Output ("Languages does not contain Ada, nothing to do"); 519 end if; 520 521 return; 522 end if; 523 524 -- Visit all the files and process those that need an SFN pragma 525 526 Iter := For_Each_Source (In_Tree, Project); 527 while Element (Iter) /= No_Source loop 528 Source := Element (Iter); 529 530 if not Source.Locally_Removed 531 and then Source.Unit /= null 532 and then 533 (Source.Index >= 1 or else Source.Naming_Exception /= No) 534 then 535 Put (Source); 536 end if; 537 538 Next (Iter); 539 end loop; 540 541 Naming := Lang.Config.Naming_Data; 542 543 -- Is the naming scheme of this project one that we know? 544 545 Current_Naming := Default_Naming; 546 while Current_Naming <= Naming_Table.Last (Namings) 547 and then Namings.Table (Current_Naming).Dot_Replacement = 548 Naming.Dot_Replacement 549 and then Namings.Table (Current_Naming).Casing = 550 Naming.Casing 551 and then Namings.Table (Current_Naming).Separate_Suffix = 552 Naming.Separate_Suffix 553 loop 554 Current_Naming := Current_Naming + 1; 555 end loop; 556 557 -- If we don't know it, add it 558 559 if Current_Naming > Naming_Table.Last (Namings) then 560 Naming_Table.Increment_Last (Namings); 561 Namings.Table (Naming_Table.Last (Namings)) := Naming; 562 563 -- Put the SFN pragmas for the naming scheme 564 565 -- Spec 566 567 Put_Line 568 ("pragma Source_File_Name_Project"); 569 Put_Line 570 (" (Spec_File_Name => ""*" & 571 Get_Name_String (Naming.Spec_Suffix) & ""","); 572 Put_Line 573 (" Casing => " & 574 Image (Naming.Casing) & ","); 575 Put_Line 576 (" Dot_Replacement => """ & 577 Get_Name_String (Naming.Dot_Replacement) & """);"); 578 579 -- and body 580 581 Put_Line 582 ("pragma Source_File_Name_Project"); 583 Put_Line 584 (" (Body_File_Name => ""*" & 585 Get_Name_String (Naming.Body_Suffix) & ""","); 586 Put_Line 587 (" Casing => " & 588 Image (Naming.Casing) & ","); 589 Put_Line 590 (" Dot_Replacement => """ & 591 Get_Name_String (Naming.Dot_Replacement) & 592 """);"); 593 594 -- and maybe separate 595 596 if Naming.Body_Suffix /= Naming.Separate_Suffix then 597 Put_Line ("pragma Source_File_Name_Project"); 598 Put_Line 599 (" (Subunit_File_Name => ""*" & 600 Get_Name_String (Naming.Separate_Suffix) & ""","); 601 Put_Line 602 (" Casing => " & 603 Image (Naming.Casing) & ","); 604 Put_Line 605 (" Dot_Replacement => """ & 606 Get_Name_String (Naming.Dot_Replacement) & 607 """);"); 608 end if; 609 end if; 610 end Check; 611 612 --------- 613 -- Put -- 614 --------- 615 616 procedure Put (Source : Source_Id) is 617 begin 618 -- Put the pragma SFN for the unit kind (spec or body) 619 620 Put ("pragma Source_File_Name_Project ("); 621 Put (Namet.Get_Name_String (Source.Unit.Name)); 622 623 if Source.Kind = Spec then 624 Put (", Spec_File_Name => """); 625 else 626 Put (", Body_File_Name => """); 627 end if; 628 629 Put (Namet.Get_Name_String (Source.File)); 630 Put (""""); 631 632 if Source.Index /= 0 then 633 Put (", Index =>"); 634 Put (Source.Index'Img); 635 end if; 636 637 Put_Line (");"); 638 end Put; 639 640 procedure Put (S : String) is 641 begin 642 Add_To_Buffer (S, Buffer, Buffer_Last); 643 644 if Current_Verbosity = High then 645 Write_Str (S); 646 end if; 647 end Put; 648 649 -------------- 650 -- Put_Line -- 651 -------------- 652 653 procedure Put_Line (S : String) is 654 begin 655 -- Add an ASCII.LF to the string. As this config file is supposed to 656 -- be used only by the compiler, we don't care about the characters 657 -- for the end of line. In fact we could have put a space, but 658 -- it is more convenient to be able to read gnat.adc during 659 -- development, for which the ASCII.LF is fine. 660 661 Put (S); 662 Put (S => (1 => ASCII.LF)); 663 end Put_Line; 664 665 --------------------- 666 -- Write_Temp_File -- 667 --------------------- 668 669 procedure Write_Temp_File is 670 Status : Boolean := False; 671 Last : Natural; 672 673 begin 674 Tempdir.Create_Temp_File (File, File_Name); 675 676 if File /= Invalid_FD then 677 Last := Write (File, Buffer (1)'Address, Buffer_Last); 678 679 if Last = Buffer_Last then 680 Close (File, Status); 681 end if; 682 end if; 683 684 if not Status then 685 Prj.Com.Fail ("unable to create temporary file"); 686 end if; 687 end Write_Temp_File; 688 689 procedure Check_Imported_Projects is 690 new For_Every_Project_Imported (Integer, Check); 691 692 Dummy : Integer := 0; 693 694 -- Start of processing for Create_Config_Pragmas_File 695 696 begin 697 if not For_Project.Config_Checked then 698 Naming_Table.Init (Namings); 699 700 -- Check the naming schemes 701 702 Check_Imported_Projects 703 (For_Project, In_Tree, Dummy, Imported_First => False); 704 705 -- If there are no non standard naming scheme, issue the GNAT 706 -- standard naming scheme. This will tell the compiler that 707 -- a project file is used and will forbid any pragma SFN. 708 709 if Buffer_Last = 0 then 710 711 Put_Line ("pragma Source_File_Name_Project"); 712 Put_Line (" (Spec_File_Name => ""*.ads"","); 713 Put_Line (" Dot_Replacement => ""-"","); 714 Put_Line (" Casing => lowercase);"); 715 716 Put_Line ("pragma Source_File_Name_Project"); 717 Put_Line (" (Body_File_Name => ""*.adb"","); 718 Put_Line (" Dot_Replacement => ""-"","); 719 Put_Line (" Casing => lowercase);"); 720 end if; 721 722 -- Close the temporary file 723 724 Write_Temp_File; 725 726 if Opt.Verbose_Mode then 727 Write_Str ("Created configuration file """); 728 Write_Str (Get_Name_String (File_Name)); 729 Write_Line (""""); 730 end if; 731 732 For_Project.Config_File_Name := File_Name; 733 For_Project.Config_File_Temp := True; 734 For_Project.Config_Checked := True; 735 end if; 736 737 Free (Buffer); 738 end Create_Config_Pragmas_File; 739 740 -------------------- 741 -- Create_Mapping -- 742 -------------------- 743 744 procedure Create_Mapping (In_Tree : Project_Tree_Ref) is 745 Data : Source_Id; 746 Iter : Source_Iterator; 747 748 begin 749 Fmap.Reset_Tables; 750 751 Iter := For_Each_Source (In_Tree); 752 loop 753 Data := Element (Iter); 754 exit when Data = No_Source; 755 756 if Data.Unit /= No_Unit_Index then 757 if Data.Locally_Removed and then not Data.Suppressed then 758 Fmap.Add_Forbidden_File_Name (Data.File); 759 else 760 Fmap.Add_To_File_Map 761 (Unit_Name => Unit_Name_Type (Data.Unit.Name), 762 File_Name => Data.File, 763 Path_Name => File_Name_Type (Data.Path.Display_Name)); 764 end if; 765 end if; 766 767 Next (Iter); 768 end loop; 769 end Create_Mapping; 770 771 ------------------------- 772 -- Create_Mapping_File -- 773 ------------------------- 774 775 procedure Create_Mapping_File 776 (Project : Project_Id; 777 Language : Name_Id; 778 In_Tree : Project_Tree_Ref; 779 Name : out Path_Name_Type) 780 is 781 File : File_Descriptor := Invalid_FD; 782 Buffer : String_Access := new String (1 .. Buffer_Initial); 783 Buffer_Last : Natural := 0; 784 785 procedure Put_Name_Buffer; 786 -- Put the line contained in the Name_Buffer in the global buffer 787 788 procedure Process 789 (Project : Project_Id; 790 In_Tree : Project_Tree_Ref; 791 State : in out Integer); 792 -- Generate the mapping file for Project (not recursively) 793 794 --------------------- 795 -- Put_Name_Buffer -- 796 --------------------- 797 798 procedure Put_Name_Buffer is 799 begin 800 if Current_Verbosity = High then 801 Debug_Output (Name_Buffer (1 .. Name_Len)); 802 end if; 803 804 Name_Len := Name_Len + 1; 805 Name_Buffer (Name_Len) := ASCII.LF; 806 Add_To_Buffer (Name_Buffer (1 .. Name_Len), Buffer, Buffer_Last); 807 end Put_Name_Buffer; 808 809 ------------- 810 -- Process -- 811 ------------- 812 813 procedure Process 814 (Project : Project_Id; 815 In_Tree : Project_Tree_Ref; 816 State : in out Integer) 817 is 818 pragma Unreferenced (State); 819 820 Source : Source_Id; 821 Suffix : File_Name_Type; 822 Iter : Source_Iterator; 823 824 begin 825 Debug_Output ("Add mapping for project", Project.Name); 826 Iter := For_Each_Source (In_Tree, Project, Language => Language); 827 828 loop 829 Source := Prj.Element (Iter); 830 exit when Source = No_Source; 831 832 if not Source.Suppressed 833 and then Source.Replaced_By = No_Source 834 and then Source.Path.Name /= No_Path 835 and then (Source.Language.Config.Kind = File_Based 836 or else Source.Unit /= No_Unit_Index) 837 then 838 if Source.Unit /= No_Unit_Index then 839 840 -- Put the encoded unit name in the name buffer 841 842 declare 843 Uname : constant String := 844 Get_Name_String (Source.Unit.Name); 845 846 begin 847 Name_Len := 0; 848 for J in Uname'Range loop 849 if Uname (J) in Upper_Half_Character then 850 Store_Encoded_Character (Get_Char_Code (Uname (J))); 851 else 852 Add_Char_To_Name_Buffer (Uname (J)); 853 end if; 854 end loop; 855 end; 856 857 if Source.Language.Config.Kind = Unit_Based then 858 859 -- ??? Mapping_Spec_Suffix could be set in the case of 860 -- gnatmake as well 861 862 Add_Char_To_Name_Buffer ('%'); 863 864 if Source.Kind = Spec then 865 Add_Char_To_Name_Buffer ('s'); 866 else 867 Add_Char_To_Name_Buffer ('b'); 868 end if; 869 870 else 871 case Source.Kind is 872 when Spec => 873 Suffix := 874 Source.Language.Config.Mapping_Spec_Suffix; 875 when Impl | Sep => 876 Suffix := 877 Source.Language.Config.Mapping_Body_Suffix; 878 end case; 879 880 if Suffix /= No_File then 881 Add_Str_To_Name_Buffer (Get_Name_String (Suffix)); 882 end if; 883 end if; 884 885 Put_Name_Buffer; 886 end if; 887 888 Get_Name_String (Source.Display_File); 889 Put_Name_Buffer; 890 891 if Source.Locally_Removed then 892 Name_Len := 1; 893 Name_Buffer (1) := '/'; 894 else 895 Get_Name_String (Source.Path.Display_Name); 896 end if; 897 898 Put_Name_Buffer; 899 end if; 900 901 Next (Iter); 902 end loop; 903 end Process; 904 905 procedure For_Every_Imported_Project is new 906 For_Every_Project_Imported (State => Integer, Action => Process); 907 908 -- Local variables 909 910 Dummy : Integer := 0; 911 912 -- Start of processing for Create_Mapping_File 913 914 begin 915 if Current_Verbosity = High then 916 Debug_Output ("Create mapping file for", Debug_Name (In_Tree)); 917 end if; 918 919 Create_Temp_File (In_Tree.Shared, File, Name, "mapping"); 920 921 if Current_Verbosity = High then 922 Debug_Increase_Indent ("Create mapping file ", Name_Id (Name)); 923 end if; 924 925 For_Every_Imported_Project 926 (Project, In_Tree, Dummy, Include_Aggregated => False); 927 928 declare 929 Last : Natural; 930 Status : Boolean := False; 931 932 begin 933 if File /= Invalid_FD then 934 Last := Write (File, Buffer (1)'Address, Buffer_Last); 935 936 if Last = Buffer_Last then 937 GNAT.OS_Lib.Close (File, Status); 938 end if; 939 end if; 940 941 if not Status then 942 Prj.Com.Fail ("could not write mapping file"); 943 end if; 944 end; 945 946 Free (Buffer); 947 948 Debug_Decrease_Indent ("Done create mapping file"); 949 end Create_Mapping_File; 950 951 ---------------------- 952 -- Create_Temp_File -- 953 ---------------------- 954 955 procedure Create_Temp_File 956 (Shared : Shared_Project_Tree_Data_Access; 957 Path_FD : out File_Descriptor; 958 Path_Name : out Path_Name_Type; 959 File_Use : String) 960 is 961 begin 962 Tempdir.Create_Temp_File (Path_FD, Path_Name); 963 964 if Path_Name /= No_Path then 965 if Current_Verbosity = High then 966 Write_Line ("Create temp file (" & File_Use & ") " 967 & Get_Name_String (Path_Name)); 968 end if; 969 970 Record_Temp_File (Shared, Path_Name); 971 972 else 973 Prj.Com.Fail 974 ("unable to create temporary " & File_Use & " file"); 975 end if; 976 end Create_Temp_File; 977 978 -------------------------- 979 -- Create_New_Path_File -- 980 -------------------------- 981 982 procedure Create_New_Path_File 983 (Shared : Shared_Project_Tree_Data_Access; 984 Path_FD : out File_Descriptor; 985 Path_Name : out Path_Name_Type) 986 is 987 begin 988 Create_Temp_File (Shared, Path_FD, Path_Name, "path file"); 989 end Create_New_Path_File; 990 991 ------------------------------------ 992 -- File_Name_Of_Library_Unit_Body -- 993 ------------------------------------ 994 995 function File_Name_Of_Library_Unit_Body 996 (Name : String; 997 Project : Project_Id; 998 In_Tree : Project_Tree_Ref; 999 Main_Project_Only : Boolean := True; 1000 Full_Path : Boolean := False) return String 1001 is 1002 1003 Lang : constant Language_Ptr := 1004 Get_Language_From_Name (Project, "ada"); 1005 The_Project : Project_Id := Project; 1006 Original_Name : String := Name; 1007 1008 Unit : Unit_Index; 1009 The_Original_Name : Name_Id; 1010 The_Spec_Name : Name_Id; 1011 The_Body_Name : Name_Id; 1012 1013 begin 1014 -- ??? Same block in Project_Of 1015 Canonical_Case_File_Name (Original_Name); 1016 Name_Len := Original_Name'Length; 1017 Name_Buffer (1 .. Name_Len) := Original_Name; 1018 The_Original_Name := Name_Find; 1019 1020 if Lang /= null then 1021 declare 1022 Naming : constant Lang_Naming_Data := Lang.Config.Naming_Data; 1023 Extended_Spec_Name : String := 1024 Name & Namet.Get_Name_String 1025 (Naming.Spec_Suffix); 1026 Extended_Body_Name : String := 1027 Name & Namet.Get_Name_String 1028 (Naming.Body_Suffix); 1029 1030 begin 1031 Canonical_Case_File_Name (Extended_Spec_Name); 1032 Name_Len := Extended_Spec_Name'Length; 1033 Name_Buffer (1 .. Name_Len) := Extended_Spec_Name; 1034 The_Spec_Name := Name_Find; 1035 1036 Canonical_Case_File_Name (Extended_Body_Name); 1037 Name_Len := Extended_Body_Name'Length; 1038 Name_Buffer (1 .. Name_Len) := Extended_Body_Name; 1039 The_Body_Name := Name_Find; 1040 end; 1041 1042 else 1043 Name_Len := Name'Length; 1044 Name_Buffer (1 .. Name_Len) := Name; 1045 Canonical_Case_File_Name (Name_Buffer); 1046 The_Spec_Name := Name_Find; 1047 The_Body_Name := The_Spec_Name; 1048 end if; 1049 1050 if Current_Verbosity = High then 1051 Write_Str ("Looking for file name of """); 1052 Write_Str (Name); 1053 Write_Char ('"'); 1054 Write_Eol; 1055 Write_Str (" Extended Spec Name = """); 1056 Write_Str (Get_Name_String (The_Spec_Name)); 1057 Write_Char ('"'); 1058 Write_Eol; 1059 Write_Str (" Extended Body Name = """); 1060 Write_Str (Get_Name_String (The_Body_Name)); 1061 Write_Char ('"'); 1062 Write_Eol; 1063 end if; 1064 1065 -- For extending project, search in the extended project if the source 1066 -- is not found. For non extending projects, this loop will be run only 1067 -- once. 1068 1069 loop 1070 -- Loop through units 1071 1072 Unit := Units_Htable.Get_First (In_Tree.Units_HT); 1073 while Unit /= null loop 1074 -- Check for body 1075 1076 if not Main_Project_Only 1077 or else 1078 (Unit.File_Names (Impl) /= null 1079 and then Unit.File_Names (Impl).Project = The_Project) 1080 then 1081 declare 1082 Current_Name : File_Name_Type; 1083 begin 1084 -- Case of a body present 1085 1086 if Unit.File_Names (Impl) /= null then 1087 Current_Name := Unit.File_Names (Impl).File; 1088 1089 if Current_Verbosity = High then 1090 Write_Str (" Comparing with """); 1091 Write_Str (Get_Name_String (Current_Name)); 1092 Write_Char ('"'); 1093 Write_Eol; 1094 end if; 1095 1096 -- If it has the name of the original name, return the 1097 -- original name. 1098 1099 if Unit.Name = The_Original_Name 1100 or else 1101 Current_Name = File_Name_Type (The_Original_Name) 1102 then 1103 if Current_Verbosity = High then 1104 Write_Line (" OK"); 1105 end if; 1106 1107 if Full_Path then 1108 return Get_Name_String 1109 (Unit.File_Names (Impl).Path.Name); 1110 1111 else 1112 return Get_Name_String (Current_Name); 1113 end if; 1114 1115 -- If it has the name of the extended body name, 1116 -- return the extended body name 1117 1118 elsif Current_Name = File_Name_Type (The_Body_Name) then 1119 if Current_Verbosity = High then 1120 Write_Line (" OK"); 1121 end if; 1122 1123 if Full_Path then 1124 return Get_Name_String 1125 (Unit.File_Names (Impl).Path.Name); 1126 1127 else 1128 return Get_Name_String (The_Body_Name); 1129 end if; 1130 1131 else 1132 if Current_Verbosity = High then 1133 Write_Line (" not good"); 1134 end if; 1135 end if; 1136 end if; 1137 end; 1138 end if; 1139 1140 -- Check for spec 1141 1142 if not Main_Project_Only 1143 or else (Unit.File_Names (Spec) /= null 1144 and then Unit.File_Names (Spec).Project = The_Project) 1145 then 1146 declare 1147 Current_Name : File_Name_Type; 1148 1149 begin 1150 -- Case of spec present 1151 1152 if Unit.File_Names (Spec) /= null then 1153 Current_Name := Unit.File_Names (Spec).File; 1154 if Current_Verbosity = High then 1155 Write_Str (" Comparing with """); 1156 Write_Str (Get_Name_String (Current_Name)); 1157 Write_Char ('"'); 1158 Write_Eol; 1159 end if; 1160 1161 -- If name same as original name, return original name 1162 1163 if Unit.Name = The_Original_Name 1164 or else 1165 Current_Name = File_Name_Type (The_Original_Name) 1166 then 1167 if Current_Verbosity = High then 1168 Write_Line (" OK"); 1169 end if; 1170 1171 if Full_Path then 1172 return Get_Name_String 1173 (Unit.File_Names (Spec).Path.Name); 1174 else 1175 return Get_Name_String (Current_Name); 1176 end if; 1177 1178 -- If it has the same name as the extended spec name, 1179 -- return the extended spec name. 1180 1181 elsif Current_Name = File_Name_Type (The_Spec_Name) then 1182 if Current_Verbosity = High then 1183 Write_Line (" OK"); 1184 end if; 1185 1186 if Full_Path then 1187 return Get_Name_String 1188 (Unit.File_Names (Spec).Path.Name); 1189 else 1190 return Get_Name_String (The_Spec_Name); 1191 end if; 1192 1193 else 1194 if Current_Verbosity = High then 1195 Write_Line (" not good"); 1196 end if; 1197 end if; 1198 end if; 1199 end; 1200 end if; 1201 1202 Unit := Units_Htable.Get_Next (In_Tree.Units_HT); 1203 end loop; 1204 1205 -- If we are not in an extending project, give up 1206 1207 exit when not Main_Project_Only 1208 or else The_Project.Extends = No_Project; 1209 1210 -- Otherwise, look in the project we are extending 1211 1212 The_Project := The_Project.Extends; 1213 end loop; 1214 1215 -- We don't know this file name, return an empty string 1216 1217 return ""; 1218 end File_Name_Of_Library_Unit_Body; 1219 1220 ------------------------- 1221 -- For_All_Object_Dirs -- 1222 ------------------------- 1223 1224 procedure For_All_Object_Dirs 1225 (Project : Project_Id; 1226 Tree : Project_Tree_Ref) 1227 is 1228 procedure For_Project 1229 (Prj : Project_Id; 1230 Tree : Project_Tree_Ref; 1231 Dummy : in out Integer); 1232 -- Get all object directories of Prj 1233 1234 ----------------- 1235 -- For_Project -- 1236 ----------------- 1237 1238 procedure For_Project 1239 (Prj : Project_Id; 1240 Tree : Project_Tree_Ref; 1241 Dummy : in out Integer) 1242 is 1243 pragma Unreferenced (Dummy, Tree); 1244 1245 begin 1246 -- ??? Set_Ada_Paths has a different behavior for library project 1247 -- files, should we have the same ? 1248 1249 if Prj.Object_Directory /= No_Path_Information then 1250 Get_Name_String (Prj.Object_Directory.Display_Name); 1251 Action (Name_Buffer (1 .. Name_Len)); 1252 end if; 1253 end For_Project; 1254 1255 procedure Get_Object_Dirs is 1256 new For_Every_Project_Imported (Integer, For_Project); 1257 Dummy : Integer := 1; 1258 1259 -- Start of processing for For_All_Object_Dirs 1260 1261 begin 1262 Get_Object_Dirs (Project, Tree, Dummy); 1263 end For_All_Object_Dirs; 1264 1265 ------------------------- 1266 -- For_All_Source_Dirs -- 1267 ------------------------- 1268 1269 procedure For_All_Source_Dirs 1270 (Project : Project_Id; 1271 In_Tree : Project_Tree_Ref) 1272 is 1273 procedure For_Project 1274 (Prj : Project_Id; 1275 In_Tree : Project_Tree_Ref; 1276 Dummy : in out Integer); 1277 -- Get all object directories of Prj 1278 1279 ----------------- 1280 -- For_Project -- 1281 ----------------- 1282 1283 procedure For_Project 1284 (Prj : Project_Id; 1285 In_Tree : Project_Tree_Ref; 1286 Dummy : in out Integer) 1287 is 1288 pragma Unreferenced (Dummy); 1289 1290 Current : String_List_Id := Prj.Source_Dirs; 1291 The_String : String_Element; 1292 1293 begin 1294 -- If there are Ada sources, call action with the name of every 1295 -- source directory. 1296 1297 if Has_Ada_Sources (Prj) then 1298 while Current /= Nil_String loop 1299 The_String := In_Tree.Shared.String_Elements.Table (Current); 1300 Action (Get_Name_String (The_String.Display_Value)); 1301 Current := The_String.Next; 1302 end loop; 1303 end if; 1304 end For_Project; 1305 1306 procedure Get_Source_Dirs is 1307 new For_Every_Project_Imported (Integer, For_Project); 1308 Dummy : Integer := 1; 1309 1310 -- Start of processing for For_All_Source_Dirs 1311 1312 begin 1313 Get_Source_Dirs (Project, In_Tree, Dummy); 1314 end For_All_Source_Dirs; 1315 1316 ------------------- 1317 -- Get_Reference -- 1318 ------------------- 1319 1320 procedure Get_Reference 1321 (Source_File_Name : String; 1322 In_Tree : Project_Tree_Ref; 1323 Project : out Project_Id; 1324 Path : out Path_Name_Type) 1325 is 1326 begin 1327 -- Body below could use some comments ??? 1328 1329 if Current_Verbosity > Default then 1330 Write_Str ("Getting Reference_Of ("""); 1331 Write_Str (Source_File_Name); 1332 Write_Str (""") ... "); 1333 end if; 1334 1335 declare 1336 Original_Name : String := Source_File_Name; 1337 Unit : Unit_Index; 1338 1339 begin 1340 Canonical_Case_File_Name (Original_Name); 1341 Unit := Units_Htable.Get_First (In_Tree.Units_HT); 1342 1343 while Unit /= null loop 1344 if Unit.File_Names (Spec) /= null 1345 and then not Unit.File_Names (Spec).Locally_Removed 1346 and then Unit.File_Names (Spec).File /= No_File 1347 and then 1348 (Namet.Get_Name_String 1349 (Unit.File_Names (Spec).File) = Original_Name 1350 or else (Unit.File_Names (Spec).Path /= No_Path_Information 1351 and then 1352 Namet.Get_Name_String 1353 (Unit.File_Names (Spec).Path.Name) = 1354 Original_Name)) 1355 then 1356 Project := 1357 Ultimate_Extending_Project_Of 1358 (Unit.File_Names (Spec).Project); 1359 Path := Unit.File_Names (Spec).Path.Display_Name; 1360 1361 if Current_Verbosity > Default then 1362 Write_Str ("Done: Spec."); 1363 Write_Eol; 1364 end if; 1365 1366 return; 1367 1368 elsif Unit.File_Names (Impl) /= null 1369 and then Unit.File_Names (Impl).File /= No_File 1370 and then not Unit.File_Names (Impl).Locally_Removed 1371 and then 1372 (Namet.Get_Name_String 1373 (Unit.File_Names (Impl).File) = Original_Name 1374 or else (Unit.File_Names (Impl).Path /= No_Path_Information 1375 and then Namet.Get_Name_String 1376 (Unit.File_Names (Impl).Path.Name) = 1377 Original_Name)) 1378 then 1379 Project := 1380 Ultimate_Extending_Project_Of 1381 (Unit.File_Names (Impl).Project); 1382 Path := Unit.File_Names (Impl).Path.Display_Name; 1383 1384 if Current_Verbosity > Default then 1385 Write_Str ("Done: Body."); 1386 Write_Eol; 1387 end if; 1388 1389 return; 1390 end if; 1391 1392 Unit := Units_Htable.Get_Next (In_Tree.Units_HT); 1393 end loop; 1394 end; 1395 1396 Project := No_Project; 1397 Path := No_Path; 1398 1399 if Current_Verbosity > Default then 1400 Write_Str ("Cannot be found."); 1401 Write_Eol; 1402 end if; 1403 end Get_Reference; 1404 1405 ---------------------- 1406 -- Get_Runtime_Path -- 1407 ---------------------- 1408 1409 function Get_Runtime_Path 1410 (Self : Project_Search_Path; 1411 Name : String) return String_Access 1412 is 1413 function Is_Base_Name (Path : String) return Boolean; 1414 -- Returns True if Path has no directory separator 1415 1416 ------------------ 1417 -- Is_Base_Name -- 1418 ------------------ 1419 1420 function Is_Base_Name (Path : String) return Boolean is 1421 begin 1422 for J in Path'Range loop 1423 if Path (J) = Directory_Separator or else Path (J) = '/' then 1424 return False; 1425 end if; 1426 end loop; 1427 1428 return True; 1429 end Is_Base_Name; 1430 1431 function Find_Rts_In_Path is new Prj.Env.Find_Name_In_Path 1432 (Check_Filename => Is_Directory); 1433 1434 -- Start of processing for Get_Runtime_Path 1435 1436 begin 1437 if not Is_Base_Name (Name) then 1438 return Find_Rts_In_Path (Self, Name); 1439 else 1440 return null; 1441 end if; 1442 end Get_Runtime_Path; 1443 1444 ---------------- 1445 -- Initialize -- 1446 ---------------- 1447 1448 procedure Initialize (In_Tree : Project_Tree_Ref) is 1449 begin 1450 In_Tree.Shared.Private_Part.Current_Source_Path_File := No_Path; 1451 In_Tree.Shared.Private_Part.Current_Object_Path_File := No_Path; 1452 end Initialize; 1453 1454 ------------------- 1455 -- Print_Sources -- 1456 ------------------- 1457 1458 -- Could use some comments in this body ??? 1459 1460 procedure Print_Sources (In_Tree : Project_Tree_Ref) is 1461 Unit : Unit_Index; 1462 1463 begin 1464 Write_Line ("List of Sources:"); 1465 1466 Unit := Units_Htable.Get_First (In_Tree.Units_HT); 1467 1468 while Unit /= No_Unit_Index loop 1469 Write_Str (" "); 1470 Write_Line (Namet.Get_Name_String (Unit.Name)); 1471 1472 if Unit.File_Names (Spec).File /= No_File then 1473 if Unit.File_Names (Spec).Project = No_Project then 1474 Write_Line (" No project"); 1475 1476 else 1477 Write_Str (" Project: "); 1478 Get_Name_String 1479 (Unit.File_Names (Spec).Project.Path.Name); 1480 Write_Line (Name_Buffer (1 .. Name_Len)); 1481 end if; 1482 1483 Write_Str (" spec: "); 1484 Write_Line 1485 (Namet.Get_Name_String 1486 (Unit.File_Names (Spec).File)); 1487 end if; 1488 1489 if Unit.File_Names (Impl).File /= No_File then 1490 if Unit.File_Names (Impl).Project = No_Project then 1491 Write_Line (" No project"); 1492 1493 else 1494 Write_Str (" Project: "); 1495 Get_Name_String 1496 (Unit.File_Names (Impl).Project.Path.Name); 1497 Write_Line (Name_Buffer (1 .. Name_Len)); 1498 end if; 1499 1500 Write_Str (" body: "); 1501 Write_Line 1502 (Namet.Get_Name_String (Unit.File_Names (Impl).File)); 1503 end if; 1504 1505 Unit := Units_Htable.Get_Next (In_Tree.Units_HT); 1506 end loop; 1507 1508 Write_Line ("end of List of Sources."); 1509 end Print_Sources; 1510 1511 ---------------- 1512 -- Project_Of -- 1513 ---------------- 1514 1515 function Project_Of 1516 (Name : String; 1517 Main_Project : Project_Id; 1518 In_Tree : Project_Tree_Ref) return Project_Id 1519 is 1520 Result : Project_Id := No_Project; 1521 1522 Original_Name : String := Name; 1523 1524 Lang : constant Language_Ptr := 1525 Get_Language_From_Name (Main_Project, "ada"); 1526 1527 Unit : Unit_Index; 1528 1529 Current_Name : File_Name_Type; 1530 The_Original_Name : File_Name_Type; 1531 The_Spec_Name : File_Name_Type; 1532 The_Body_Name : File_Name_Type; 1533 1534 begin 1535 -- ??? Same block in File_Name_Of_Library_Unit_Body 1536 Canonical_Case_File_Name (Original_Name); 1537 Name_Len := Original_Name'Length; 1538 Name_Buffer (1 .. Name_Len) := Original_Name; 1539 The_Original_Name := Name_Find; 1540 1541 if Lang /= null then 1542 declare 1543 Naming : Lang_Naming_Data renames Lang.Config.Naming_Data; 1544 Extended_Spec_Name : String := 1545 Name & Namet.Get_Name_String 1546 (Naming.Spec_Suffix); 1547 Extended_Body_Name : String := 1548 Name & Namet.Get_Name_String 1549 (Naming.Body_Suffix); 1550 1551 begin 1552 Canonical_Case_File_Name (Extended_Spec_Name); 1553 Name_Len := Extended_Spec_Name'Length; 1554 Name_Buffer (1 .. Name_Len) := Extended_Spec_Name; 1555 The_Spec_Name := Name_Find; 1556 1557 Canonical_Case_File_Name (Extended_Body_Name); 1558 Name_Len := Extended_Body_Name'Length; 1559 Name_Buffer (1 .. Name_Len) := Extended_Body_Name; 1560 The_Body_Name := Name_Find; 1561 end; 1562 1563 else 1564 The_Spec_Name := The_Original_Name; 1565 The_Body_Name := The_Original_Name; 1566 end if; 1567 1568 Unit := Units_Htable.Get_First (In_Tree.Units_HT); 1569 while Unit /= null loop 1570 1571 -- Case of a body present 1572 1573 if Unit.File_Names (Impl) /= null then 1574 Current_Name := Unit.File_Names (Impl).File; 1575 1576 -- If it has the name of the original name or the body name, 1577 -- we have found the project. 1578 1579 if Unit.Name = Name_Id (The_Original_Name) 1580 or else Current_Name = The_Original_Name 1581 or else Current_Name = The_Body_Name 1582 then 1583 Result := Unit.File_Names (Impl).Project; 1584 exit; 1585 end if; 1586 end if; 1587 1588 -- Check for spec 1589 1590 if Unit.File_Names (Spec) /= null then 1591 Current_Name := Unit.File_Names (Spec).File; 1592 1593 -- If name same as the original name, or the spec name, we have 1594 -- found the project. 1595 1596 if Unit.Name = Name_Id (The_Original_Name) 1597 or else Current_Name = The_Original_Name 1598 or else Current_Name = The_Spec_Name 1599 then 1600 Result := Unit.File_Names (Spec).Project; 1601 exit; 1602 end if; 1603 end if; 1604 1605 Unit := Units_Htable.Get_Next (In_Tree.Units_HT); 1606 end loop; 1607 1608 return Ultimate_Extending_Project_Of (Result); 1609 end Project_Of; 1610 1611 ------------------- 1612 -- Set_Ada_Paths -- 1613 ------------------- 1614 1615 procedure Set_Ada_Paths 1616 (Project : Project_Id; 1617 In_Tree : Project_Tree_Ref; 1618 Including_Libraries : Boolean; 1619 Include_Path : Boolean := True; 1620 Objects_Path : Boolean := True) 1621 1622 is 1623 Shared : constant Shared_Project_Tree_Data_Access := In_Tree.Shared; 1624 1625 Source_Paths : Source_Path_Table.Instance; 1626 Object_Paths : Object_Path_Table.Instance; 1627 -- List of source or object dirs. Only computed the first time this 1628 -- procedure is called (since Source_FD is then reused) 1629 1630 Source_FD : File_Descriptor := Invalid_FD; 1631 Object_FD : File_Descriptor := Invalid_FD; 1632 -- The temporary files to store the paths. These are only created the 1633 -- first time this procedure is called, and reused from then on. 1634 1635 Process_Source_Dirs : Boolean := False; 1636 Process_Object_Dirs : Boolean := False; 1637 1638 Status : Boolean; 1639 -- For calls to Close 1640 1641 Last : Natural; 1642 Buffer : String_Access := new String (1 .. Buffer_Initial); 1643 Buffer_Last : Natural := 0; 1644 1645 procedure Recursive_Add 1646 (Project : Project_Id; 1647 In_Tree : Project_Tree_Ref; 1648 Dummy : in out Boolean); 1649 -- Recursive procedure to add the source/object paths of extended/ 1650 -- imported projects. 1651 1652 ------------------- 1653 -- Recursive_Add -- 1654 ------------------- 1655 1656 procedure Recursive_Add 1657 (Project : Project_Id; 1658 In_Tree : Project_Tree_Ref; 1659 Dummy : in out Boolean) 1660 is 1661 pragma Unreferenced (Dummy, In_Tree); 1662 1663 Path : Path_Name_Type; 1664 1665 begin 1666 -- ??? This is almost the equivalent of For_All_Source_Dirs 1667 1668 if Process_Source_Dirs then 1669 1670 -- Add to path all source directories of this project if there are 1671 -- Ada sources. 1672 1673 if Has_Ada_Sources (Project) then 1674 Add_To_Source_Path (Project.Source_Dirs, Shared, Source_Paths); 1675 end if; 1676 end if; 1677 1678 if Process_Object_Dirs then 1679 Path := Get_Object_Directory 1680 (Project, 1681 Including_Libraries => Including_Libraries, 1682 Only_If_Ada => True); 1683 1684 if Path /= No_Path then 1685 Add_To_Object_Path (Path, Object_Paths); 1686 end if; 1687 end if; 1688 end Recursive_Add; 1689 1690 procedure For_All_Projects is 1691 new For_Every_Project_Imported (Boolean, Recursive_Add); 1692 1693 Dummy : Boolean := False; 1694 1695 -- Start of processing for Set_Ada_Paths 1696 1697 begin 1698 -- If it is the first time we call this procedure for this project, 1699 -- compute the source path and/or the object path. 1700 1701 if Include_Path and then Project.Include_Path_File = No_Path then 1702 Source_Path_Table.Init (Source_Paths); 1703 Process_Source_Dirs := True; 1704 Create_New_Path_File (Shared, Source_FD, Project.Include_Path_File); 1705 end if; 1706 1707 -- For the object path, we make a distinction depending on 1708 -- Including_Libraries. 1709 1710 if Objects_Path and Including_Libraries then 1711 if Project.Objects_Path_File_With_Libs = No_Path then 1712 Object_Path_Table.Init (Object_Paths); 1713 Process_Object_Dirs := True; 1714 Create_New_Path_File 1715 (Shared, Object_FD, Project.Objects_Path_File_With_Libs); 1716 end if; 1717 1718 elsif Objects_Path then 1719 if Project.Objects_Path_File_Without_Libs = No_Path then 1720 Object_Path_Table.Init (Object_Paths); 1721 Process_Object_Dirs := True; 1722 Create_New_Path_File 1723 (Shared, Object_FD, Project.Objects_Path_File_Without_Libs); 1724 end if; 1725 end if; 1726 1727 -- If there is something to do, set Seen to False for all projects, 1728 -- then call the recursive procedure Add for Project. 1729 1730 if Process_Source_Dirs or Process_Object_Dirs then 1731 For_All_Projects (Project, In_Tree, Dummy); 1732 end if; 1733 1734 -- Write and close any file that has been created. Source_FD is not set 1735 -- when this subprogram is called a second time or more, since we reuse 1736 -- the previous version of the file. 1737 1738 if Source_FD /= Invalid_FD then 1739 Buffer_Last := 0; 1740 1741 for Index in 1742 Source_Path_Table.First .. Source_Path_Table.Last (Source_Paths) 1743 loop 1744 Get_Name_String (Source_Paths.Table (Index)); 1745 Name_Len := Name_Len + 1; 1746 Name_Buffer (Name_Len) := ASCII.LF; 1747 Add_To_Buffer (Name_Buffer (1 .. Name_Len), Buffer, Buffer_Last); 1748 end loop; 1749 1750 Last := Write (Source_FD, Buffer (1)'Address, Buffer_Last); 1751 1752 if Last = Buffer_Last then 1753 Close (Source_FD, Status); 1754 1755 else 1756 Status := False; 1757 end if; 1758 1759 if not Status then 1760 Prj.Com.Fail ("could not write temporary file"); 1761 end if; 1762 end if; 1763 1764 if Object_FD /= Invalid_FD then 1765 Buffer_Last := 0; 1766 1767 for Index in 1768 Object_Path_Table.First .. Object_Path_Table.Last (Object_Paths) 1769 loop 1770 Get_Name_String (Object_Paths.Table (Index)); 1771 Name_Len := Name_Len + 1; 1772 Name_Buffer (Name_Len) := ASCII.LF; 1773 Add_To_Buffer (Name_Buffer (1 .. Name_Len), Buffer, Buffer_Last); 1774 end loop; 1775 1776 Last := Write (Object_FD, Buffer (1)'Address, Buffer_Last); 1777 1778 if Last = Buffer_Last then 1779 Close (Object_FD, Status); 1780 else 1781 Status := False; 1782 end if; 1783 1784 if not Status then 1785 Prj.Com.Fail ("could not write temporary file"); 1786 end if; 1787 end if; 1788 1789 -- Set the env vars, if they need to be changed, and set the 1790 -- corresponding flags. 1791 1792 if Include_Path 1793 and then 1794 Shared.Private_Part.Current_Source_Path_File /= 1795 Project.Include_Path_File 1796 then 1797 Shared.Private_Part.Current_Source_Path_File := 1798 Project.Include_Path_File; 1799 Set_Path_File_Var 1800 (Project_Include_Path_File, 1801 Get_Name_String (Shared.Private_Part.Current_Source_Path_File)); 1802 end if; 1803 1804 if Objects_Path then 1805 if Including_Libraries then 1806 if Shared.Private_Part.Current_Object_Path_File /= 1807 Project.Objects_Path_File_With_Libs 1808 then 1809 Shared.Private_Part.Current_Object_Path_File := 1810 Project.Objects_Path_File_With_Libs; 1811 Set_Path_File_Var 1812 (Project_Objects_Path_File, 1813 Get_Name_String 1814 (Shared.Private_Part.Current_Object_Path_File)); 1815 end if; 1816 1817 else 1818 if Shared.Private_Part.Current_Object_Path_File /= 1819 Project.Objects_Path_File_Without_Libs 1820 then 1821 Shared.Private_Part.Current_Object_Path_File := 1822 Project.Objects_Path_File_Without_Libs; 1823 Set_Path_File_Var 1824 (Project_Objects_Path_File, 1825 Get_Name_String 1826 (Shared.Private_Part.Current_Object_Path_File)); 1827 end if; 1828 end if; 1829 end if; 1830 1831 Free (Buffer); 1832 end Set_Ada_Paths; 1833 1834 --------------------- 1835 -- Add_Directories -- 1836 --------------------- 1837 1838 procedure Add_Directories 1839 (Self : in out Project_Search_Path; 1840 Path : String; 1841 Prepend : Boolean := False) 1842 is 1843 Tmp : String_Access; 1844 begin 1845 if Self.Path = null then 1846 Self.Path := new String'(Uninitialized_Prefix & Path); 1847 else 1848 Tmp := Self.Path; 1849 if Prepend then 1850 Self.Path := new String'(Path & Path_Separator & Tmp.all); 1851 else 1852 Self.Path := new String'(Tmp.all & Path_Separator & Path); 1853 end if; 1854 Free (Tmp); 1855 end if; 1856 1857 if Current_Verbosity = High then 1858 Debug_Output ("Adding directories to Project_Path: """ 1859 & Path & '"'); 1860 end if; 1861 end Add_Directories; 1862 1863 -------------------- 1864 -- Is_Initialized -- 1865 -------------------- 1866 1867 function Is_Initialized (Self : Project_Search_Path) return Boolean is 1868 begin 1869 return Self.Path /= null 1870 and then (Self.Path'Length = 0 1871 or else Self.Path (Self.Path'First) /= '#'); 1872 end Is_Initialized; 1873 1874 ---------------------- 1875 -- Initialize_Empty -- 1876 ---------------------- 1877 1878 procedure Initialize_Empty (Self : in out Project_Search_Path) is 1879 begin 1880 Free (Self.Path); 1881 Self.Path := new String'(""); 1882 end Initialize_Empty; 1883 1884 ------------------------------------- 1885 -- Initialize_Default_Project_Path -- 1886 ------------------------------------- 1887 1888 procedure Initialize_Default_Project_Path 1889 (Self : in out Project_Search_Path; 1890 Target_Name : String) 1891 is 1892 Add_Default_Dir : Boolean := True; 1893 First : Positive; 1894 Last : Positive; 1895 New_Len : Positive; 1896 New_Last : Positive; 1897 1898 Ada_Project_Path : constant String := "ADA_PROJECT_PATH"; 1899 Gpr_Project_Path : constant String := "GPR_PROJECT_PATH"; 1900 -- Name of alternate env. variable that contain path name(s) of 1901 -- directories where project files may reside. GPR_PROJECT_PATH has 1902 -- precedence over ADA_PROJECT_PATH. 1903 1904 Gpr_Prj_Path : String_Access; 1905 Ada_Prj_Path : String_Access; 1906 -- The path name(s) of directories where project files may reside. 1907 -- May be empty. 1908 1909 begin 1910 if Is_Initialized (Self) then 1911 return; 1912 end if; 1913 1914 -- The current directory is always first in the search path. Since the 1915 -- Project_Path currently starts with '#:' as a sign that it isn't 1916 -- initialized, we simply replace '#' with '.' 1917 1918 if Self.Path = null then 1919 Self.Path := new String'('.' & Path_Separator); 1920 else 1921 Self.Path (Self.Path'First) := '.'; 1922 end if; 1923 1924 -- Then the reset of the project path (if any) currently contains the 1925 -- directories added through Add_Search_Project_Directory 1926 1927 -- If environment variables are defined and not empty, add their content 1928 1929 Gpr_Prj_Path := Getenv (Gpr_Project_Path); 1930 Ada_Prj_Path := Getenv (Ada_Project_Path); 1931 1932 if Gpr_Prj_Path.all /= "" then 1933 Add_Directories (Self, Gpr_Prj_Path.all); 1934 end if; 1935 1936 Free (Gpr_Prj_Path); 1937 1938 if Ada_Prj_Path.all /= "" then 1939 Add_Directories (Self, Ada_Prj_Path.all); 1940 end if; 1941 1942 Free (Ada_Prj_Path); 1943 1944 -- Copy to Name_Buffer, since we will need to manipulate the path 1945 1946 Name_Len := Self.Path'Length; 1947 Name_Buffer (1 .. Name_Len) := Self.Path.all; 1948 1949 -- Scan the directory path to see if "-" is one of the directories. 1950 -- Remove each occurrence of "-" and set Add_Default_Dir to False. 1951 -- Also resolve relative paths and symbolic links. 1952 1953 First := 3; 1954 loop 1955 while First <= Name_Len 1956 and then (Name_Buffer (First) = Path_Separator) 1957 loop 1958 First := First + 1; 1959 end loop; 1960 1961 exit when First > Name_Len; 1962 1963 Last := First; 1964 1965 while Last < Name_Len 1966 and then Name_Buffer (Last + 1) /= Path_Separator 1967 loop 1968 Last := Last + 1; 1969 end loop; 1970 1971 -- If the directory is "-", set Add_Default_Dir to False and 1972 -- remove from path. 1973 1974 if Name_Buffer (First .. Last) = No_Project_Default_Dir then 1975 Add_Default_Dir := False; 1976 1977 for J in Last + 1 .. Name_Len loop 1978 Name_Buffer (J - No_Project_Default_Dir'Length - 1) := 1979 Name_Buffer (J); 1980 end loop; 1981 1982 Name_Len := Name_Len - No_Project_Default_Dir'Length - 1; 1983 1984 -- After removing the '-', go back one character to get the next 1985 -- directory correctly. 1986 1987 Last := Last - 1; 1988 1989 elsif not Hostparm.OpenVMS 1990 or else not Is_Absolute_Path (Name_Buffer (First .. Last)) 1991 then 1992 -- On VMS, only expand relative path names, as absolute paths 1993 -- may correspond to multi-valued VMS logical names. 1994 1995 declare 1996 New_Dir : constant String := 1997 Normalize_Pathname 1998 (Name_Buffer (First .. Last), 1999 Resolve_Links => Opt.Follow_Links_For_Dirs); 2000 2001 begin 2002 -- If the absolute path was resolved and is different from 2003 -- the original, replace original with the resolved path. 2004 2005 if New_Dir /= Name_Buffer (First .. Last) 2006 and then New_Dir'Length /= 0 2007 then 2008 New_Len := Name_Len + New_Dir'Length - (Last - First + 1); 2009 New_Last := First + New_Dir'Length - 1; 2010 Name_Buffer (New_Last + 1 .. New_Len) := 2011 Name_Buffer (Last + 1 .. Name_Len); 2012 Name_Buffer (First .. New_Last) := New_Dir; 2013 Name_Len := New_Len; 2014 Last := New_Last; 2015 end if; 2016 end; 2017 end if; 2018 2019 First := Last + 1; 2020 end loop; 2021 2022 Free (Self.Path); 2023 2024 -- Set the initial value of Current_Project_Path 2025 2026 if Add_Default_Dir then 2027 declare 2028 Prefix : String_Ptr; 2029 2030 begin 2031 if Sdefault.Search_Dir_Prefix = null then 2032 2033 -- gprbuild case 2034 2035 Prefix := new String'(Executable_Prefix_Path); 2036 2037 else 2038 Prefix := new String'(Sdefault.Search_Dir_Prefix.all 2039 & ".." & Dir_Separator 2040 & ".." & Dir_Separator 2041 & ".." & Dir_Separator 2042 & ".." & Dir_Separator); 2043 end if; 2044 2045 if Prefix.all /= "" then 2046 if Target_Name /= "" then 2047 2048 -- $prefix/$target/lib/gnat 2049 2050 Add_Str_To_Name_Buffer 2051 (Path_Separator & Prefix.all & Target_Name); 2052 2053 -- Note: Target_Name has a trailing / when it comes from 2054 -- Sdefault. 2055 2056 if Name_Buffer (Name_Len) /= '/' then 2057 Add_Char_To_Name_Buffer (Directory_Separator); 2058 end if; 2059 2060 Add_Str_To_Name_Buffer 2061 ("lib" & Directory_Separator & "gnat"); 2062 end if; 2063 2064 -- $prefix/share/gpr 2065 2066 Add_Str_To_Name_Buffer 2067 (Path_Separator & Prefix.all & 2068 "share" & Directory_Separator & "gpr"); 2069 2070 -- $prefix/lib/gnat 2071 2072 Add_Str_To_Name_Buffer 2073 (Path_Separator & Prefix.all & 2074 "lib" & Directory_Separator & "gnat"); 2075 end if; 2076 2077 Free (Prefix); 2078 end; 2079 end if; 2080 2081 Self.Path := new String'(Name_Buffer (1 .. Name_Len)); 2082 end Initialize_Default_Project_Path; 2083 2084 -------------- 2085 -- Get_Path -- 2086 -------------- 2087 2088 procedure Get_Path (Self : Project_Search_Path; Path : out String_Access) is 2089 begin 2090 pragma Assert (Is_Initialized (Self)); 2091 Path := Self.Path; 2092 end Get_Path; 2093 2094 -------------- 2095 -- Set_Path -- 2096 -------------- 2097 2098 procedure Set_Path (Self : in out Project_Search_Path; Path : String) is 2099 begin 2100 Free (Self.Path); 2101 Self.Path := new String'(Path); 2102 Projects_Paths.Reset (Self.Cache); 2103 end Set_Path; 2104 2105 ----------------------- 2106 -- Find_Name_In_Path -- 2107 ----------------------- 2108 2109 function Find_Name_In_Path 2110 (Self : Project_Search_Path; 2111 Path : String) return String_Access 2112 is 2113 First : Natural; 2114 Last : Natural; 2115 2116 begin 2117 if Current_Verbosity = High then 2118 Debug_Output ("Trying " & Path); 2119 end if; 2120 2121 if Is_Absolute_Path (Path) then 2122 if Check_Filename (Path) then 2123 return new String'(Path); 2124 else 2125 return null; 2126 end if; 2127 2128 else 2129 -- Because we don't want to resolve symbolic links, we cannot use 2130 -- Locate_Regular_File. So, we try each possible path successively. 2131 2132 First := Self.Path'First; 2133 while First <= Self.Path'Last loop 2134 while First <= Self.Path'Last 2135 and then Self.Path (First) = Path_Separator 2136 loop 2137 First := First + 1; 2138 end loop; 2139 2140 exit when First > Self.Path'Last; 2141 2142 Last := First; 2143 while Last < Self.Path'Last 2144 and then Self.Path (Last + 1) /= Path_Separator 2145 loop 2146 Last := Last + 1; 2147 end loop; 2148 2149 Name_Len := 0; 2150 2151 if not Is_Absolute_Path (Self.Path (First .. Last)) then 2152 Add_Str_To_Name_Buffer (Get_Current_Dir); -- ??? System call 2153 Add_Char_To_Name_Buffer (Directory_Separator); 2154 end if; 2155 2156 Add_Str_To_Name_Buffer (Self.Path (First .. Last)); 2157 Add_Char_To_Name_Buffer (Directory_Separator); 2158 Add_Str_To_Name_Buffer (Path); 2159 2160 if Current_Verbosity = High then 2161 Debug_Output ("Testing file " & Name_Buffer (1 .. Name_Len)); 2162 end if; 2163 2164 if Check_Filename (Name_Buffer (1 .. Name_Len)) then 2165 return new String'(Name_Buffer (1 .. Name_Len)); 2166 end if; 2167 2168 First := Last + 1; 2169 end loop; 2170 end if; 2171 2172 return null; 2173 end Find_Name_In_Path; 2174 2175 ------------------ 2176 -- Find_Project -- 2177 ------------------ 2178 2179 procedure Find_Project 2180 (Self : in out Project_Search_Path; 2181 Project_File_Name : String; 2182 Directory : String; 2183 Path : out Namet.Path_Name_Type) 2184 is 2185 File : constant String := Project_File_Name; 2186 -- Have to do a copy, in case the parameter is Name_Buffer, which we 2187 -- modify below 2188 2189 function Try_Path_Name is new Find_Name_In_Path 2190 (Check_Filename => Is_Regular_File); 2191 -- Find a file in the project search path 2192 2193 -- Local Declarations 2194 2195 Result : String_Access; 2196 Has_Dot : Boolean := False; 2197 Key : Name_Id; 2198 2199 -- Start of processing for Find_Project 2200 2201 begin 2202 pragma Assert (Is_Initialized (Self)); 2203 2204 if Current_Verbosity = High then 2205 Debug_Increase_Indent 2206 ("Searching for project """ & File & """ in """ 2207 & Directory & '"'); 2208 end if; 2209 2210 -- Check the project cache 2211 2212 Name_Len := File'Length; 2213 Name_Buffer (1 .. Name_Len) := File; 2214 Key := Name_Find; 2215 Path := Projects_Paths.Get (Self.Cache, Key); 2216 2217 if Path /= No_Path then 2218 Debug_Decrease_Indent; 2219 return; 2220 end if; 2221 2222 -- Check if File contains an extension (a dot before a 2223 -- directory separator). If it is the case we do not try project file 2224 -- with an added extension as it is not possible to have multiple dots 2225 -- on a project file name. 2226 2227 Check_Dot : for K in reverse File'Range loop 2228 if File (K) = '.' then 2229 Has_Dot := True; 2230 exit Check_Dot; 2231 end if; 2232 2233 exit Check_Dot when File (K) = Directory_Separator 2234 or else File (K) = '/'; 2235 end loop Check_Dot; 2236 2237 if not Is_Absolute_Path (File) then 2238 2239 -- First we try <directory>/<file_name>.<extension> 2240 2241 if not Has_Dot then 2242 Result := Try_Path_Name 2243 (Self, 2244 Directory & Directory_Separator & 2245 File & Project_File_Extension); 2246 end if; 2247 2248 -- Then we try <directory>/<file_name> 2249 2250 if Result = null then 2251 Result := Try_Path_Name 2252 (Self, Directory & Directory_Separator & File); 2253 end if; 2254 end if; 2255 2256 -- Then we try <file_name>.<extension> 2257 2258 if Result = null and then not Has_Dot then 2259 Result := Try_Path_Name (Self, File & Project_File_Extension); 2260 end if; 2261 2262 -- Then we try <file_name> 2263 2264 if Result = null then 2265 Result := Try_Path_Name (Self, File); 2266 end if; 2267 2268 -- If we cannot find the project file, we return an empty string 2269 2270 if Result = null then 2271 Path := Namet.No_Path; 2272 return; 2273 2274 else 2275 declare 2276 Final_Result : constant String := 2277 GNAT.OS_Lib.Normalize_Pathname 2278 (Result.all, 2279 Directory => Directory, 2280 Resolve_Links => Opt.Follow_Links_For_Files, 2281 Case_Sensitive => True); 2282 begin 2283 Free (Result); 2284 Name_Len := Final_Result'Length; 2285 Name_Buffer (1 .. Name_Len) := Final_Result; 2286 Path := Name_Find; 2287 Projects_Paths.Set (Self.Cache, Key, Path); 2288 end; 2289 end if; 2290 2291 Debug_Decrease_Indent; 2292 end Find_Project; 2293 2294 ---------- 2295 -- Free -- 2296 ---------- 2297 2298 procedure Free (Self : in out Project_Search_Path) is 2299 begin 2300 Free (Self.Path); 2301 Projects_Paths.Reset (Self.Cache); 2302 end Free; 2303 2304 ---------- 2305 -- Copy -- 2306 ---------- 2307 2308 procedure Copy (From : Project_Search_Path; To : out Project_Search_Path) is 2309 begin 2310 Free (To); 2311 2312 if From.Path /= null then 2313 To.Path := new String'(From.Path.all); 2314 end if; 2315 2316 -- No need to copy the Cache, it will be recomputed as needed 2317 end Copy; 2318 2319end Prj.Env; 2320