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