gcc/ada/prj-env.adb

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