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