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