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