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