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