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-2009, 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 Opt;
  28 with Osint;    use Osint;
  29 with Output;   use Output;
  30 with Prj.Com;  use Prj.Com;
  31 with Tempdir;
  32
  33 package body Prj.Env is
  34
  35    Buffer_Initial : constant := 1_000;
  36    --  Initial size of Buffer
  37
  38    -----------------------
  39    -- Local Subprograms --
  40    -----------------------
  41
  42    package Source_Path_Table is new GNAT.Dynamic_Tables
  43      (Table_Component_Type => Name_Id,
  44       Table_Index_Type     => Natural,
  45       Table_Low_Bound      => 1,
  46       Table_Initial        => 50,
  47       Table_Increment      => 100);
  48    --  A table to store the source dirs before creating the source path file
  49
  50    package Object_Path_Table is new GNAT.Dynamic_Tables
  51      (Table_Component_Type => Path_Name_Type,
  52       Table_Index_Type     => Natural,
  53       Table_Low_Bound      => 1,
  54       Table_Initial        => 50,
  55       Table_Increment      => 100);
  56    --  A table to store the object dirs, before creating the object path file
  57
  58    procedure Add_To_Buffer
  59      (S           : String;
  60       Buffer      : in out String_Access;
  61       Buffer_Last : in out Natural);
  62    --  Add a string to Buffer, extending Buffer if needed
  63
  64    procedure Add_To_Path
  65      (Source_Dirs : String_List_Id;
  66       In_Tree     : Project_Tree_Ref;
  67       Buffer      : in out String_Access;
  68       Buffer_Last : in out Natural);
  69    --  Add to Ada_Path_Buffer all the source directories in string list
  70    --  Source_Dirs, if any.
  71
  72    procedure Add_To_Path
  73      (Dir         : String;
  74       Buffer      : in out String_Access;
  75       Buffer_Last : in out Natural);
  76    --  If Dir is not already in the global variable Ada_Path_Buffer, add it.
  77    --  If Buffer_Last /= 0, prepend a Path_Separator character to Path.
  78
  79    procedure Add_To_Source_Path
  80      (Source_Dirs  : String_List_Id;
  81       In_Tree      : Project_Tree_Ref;
  82       Source_Paths : in out Source_Path_Table.Instance);
  83    --  Add to Ada_Path_B all the source directories in string list
  84    --  Source_Dirs, if any. Increment Ada_Path_Length.
  85
  86    procedure Add_To_Object_Path
  87      (Object_Dir   : Path_Name_Type;
  88       Object_Paths : in out Object_Path_Table.Instance);
  89    --  Add Object_Dir to object path table. Make sure it is not duplicate
  90    --  and it is the last one in the current table.
  91
  92    procedure Set_Path_File_Var (Name : String; Value : String);
  93    --  Call Setenv, after calling To_Host_File_Spec
  94
  95    function Ultimate_Extension_Of
  96      (Project : Project_Id) return Project_Id;
  97    --  Return a project that is either Project or an extended ancestor of
  98    --  Project that itself is not extended.
  99
 100    ----------------------
 101    -- Ada_Include_Path --
 102    ----------------------
 103
 104    function Ada_Include_Path
 105      (Project   : Project_Id;
 106       In_Tree   : Project_Tree_Ref;
 107       Recursive : Boolean := False) return String
 108    is
 109       Buffer      : String_Access;
 110       Buffer_Last : Natural := 0;
 111
 112       procedure Add (Project : Project_Id; Dummy : in out Boolean);
 113       --  Add source dirs of Project to the path
 114
 115       ---------
 116       -- Add --
 117       ---------
 118
 119       procedure Add (Project : Project_Id; Dummy : in out Boolean) is
 120          pragma Unreferenced (Dummy);
 121       begin
 122          Add_To_Path (Project.Source_Dirs, In_Tree, Buffer, Buffer_Last);
 123       end Add;
 124
 125       procedure For_All_Projects is
 126         new For_Every_Project_Imported (Boolean, Add);
 127
 128       Dummy : Boolean := False;
 129
 130    --  Start of processing for Ada_Include_Path
 131
 132    begin
 133       if Recursive then
 134
 135          --  If it is the first time we call this function for
 136          --  this project, compute the source path
 137
 138          if Project.Ada_Include_Path = null then
 139             Buffer := new String (1 .. 4096);
 140             For_All_Projects (Project, Dummy);
 141             Project.Ada_Include_Path := new String'(Buffer (1 .. Buffer_Last));
 142             Free (Buffer);
 143          end if;
 144
 145          return Project.Ada_Include_Path.all;
 146
 147       else
 148          Buffer := new String (1 .. 4096);
 149          Add_To_Path (Project.Source_Dirs, In_Tree, Buffer, Buffer_Last);
 150
 151          declare
 152             Result : constant String := Buffer (1 .. Buffer_Last);
 153          begin
 154             Free (Buffer);
 155             return Result;
 156          end;
 157       end if;
 158    end Ada_Include_Path;
 159
 160    ----------------------
 161    -- Ada_Objects_Path --
 162    ----------------------
 163
 164    function Ada_Objects_Path
 165      (Project             : Project_Id;
 166       Including_Libraries : Boolean := True) return String_Access
 167    is
 168       Buffer      : String_Access;
 169       Buffer_Last : Natural := 0;
 170
 171       procedure Add (Project : Project_Id; Dummy : in out Boolean);
 172       --  Add all the object directories of a project to the path
 173
 174       ---------
 175       -- Add --
 176       ---------
 177
 178       procedure Add (Project : Project_Id; Dummy : in out Boolean) is
 179          pragma Unreferenced (Dummy);
 180          Path : constant Path_Name_Type :=
 181                   Get_Object_Directory
 182                     (Project,
 183                      Including_Libraries => Including_Libraries,
 184                      Only_If_Ada         => False);
 185       begin
 186          if Path /= No_Path then
 187             Add_To_Path (Get_Name_String (Path), Buffer, Buffer_Last);
 188          end if;
 189       end Add;
 190
 191       procedure For_All_Projects is
 192         new For_Every_Project_Imported (Boolean, Add);
 193
 194       Dummy : Boolean := False;
 195
 196    --  Start of processing for Ada_Objects_Path
 197
 198    begin
 199       --  If it is the first time we call this function for
 200       --  this project, compute the objects path
 201
 202       if Project.Ada_Objects_Path = null then
 203          Buffer := new String (1 .. 4096);
 204          For_All_Projects (Project, Dummy);
 205
 206          Project.Ada_Objects_Path := new String'(Buffer (1 .. Buffer_Last));
 207          Free (Buffer);
 208       end if;
 209
 210       return Project.Ada_Objects_Path;
 211    end Ada_Objects_Path;
 212
 213    -------------------
 214    -- Add_To_Buffer --
 215    -------------------
 216
 217    procedure Add_To_Buffer
 218      (S           : String;
 219       Buffer      : in out String_Access;
 220       Buffer_Last : in out Natural)
 221    is
 222       Last : constant Natural := Buffer_Last + S'Length;
 223
 224    begin
 225       while Last > Buffer'Last loop
 226          declare
 227             New_Buffer : constant String_Access :=
 228                            new String (1 .. 2 * Buffer'Last);
 229          begin
 230             New_Buffer (1 .. Buffer_Last) := Buffer (1 .. Buffer_Last);
 231             Free (Buffer);
 232             Buffer := New_Buffer;
 233          end;
 234       end loop;
 235
 236       Buffer (Buffer_Last + 1 .. Last) := S;
 237       Buffer_Last := Last;
 238    end Add_To_Buffer;
 239
 240    ------------------------
 241    -- Add_To_Object_Path --
 242    ------------------------
 243
 244    procedure Add_To_Object_Path
 245      (Object_Dir   : Path_Name_Type;
 246       Object_Paths : in out Object_Path_Table.Instance)
 247    is
 248    begin
 249       --  Check if the directory is already in the table
 250
 251       for Index in Object_Path_Table.First ..
 252                    Object_Path_Table.Last (Object_Paths)
 253       loop
 254
 255          --  If it is, remove it, and add it as the last one
 256
 257          if Object_Paths.Table (Index) = Object_Dir then
 258             for Index2 in Index + 1 ..
 259                           Object_Path_Table.Last (Object_Paths)
 260             loop
 261                Object_Paths.Table (Index2 - 1) := Object_Paths.Table (Index2);
 262             end loop;
 263
 264             Object_Paths.Table
 265               (Object_Path_Table.Last (Object_Paths)) := Object_Dir;
 266             return;
 267          end if;
 268       end loop;
 269
 270       --  The directory is not already in the table, add it
 271
 272       Object_Path_Table.Append (Object_Paths, Object_Dir);
 273    end Add_To_Object_Path;
 274
 275    -----------------
 276    -- Add_To_Path --
 277    -----------------
 278
 279    procedure Add_To_Path
 280      (Source_Dirs : String_List_Id;
 281       In_Tree     : Project_Tree_Ref;
 282       Buffer      : in out String_Access;
 283       Buffer_Last : in out Natural)
 284    is
 285       Current    : String_List_Id := Source_Dirs;
 286       Source_Dir : String_Element;
 287    begin
 288       while Current /= Nil_String loop
 289          Source_Dir := In_Tree.String_Elements.Table (Current);
 290          Add_To_Path (Get_Name_String (Source_Dir.Display_Value),
 291                       Buffer, Buffer_Last);
 292          Current := Source_Dir.Next;
 293       end loop;
 294    end Add_To_Path;
 295
 296    procedure Add_To_Path
 297      (Dir         : String;
 298       Buffer      : in out String_Access;
 299       Buffer_Last : in out Natural)
 300    is
 301       Len        : Natural;
 302       New_Buffer : String_Access;
 303       Min_Len    : Natural;
 304
 305       function Is_Present (Path : String; Dir : String) return Boolean;
 306       --  Return True if Dir is part of Path
 307
 308       ----------------
 309       -- Is_Present --
 310       ----------------
 311
 312       function Is_Present (Path : String; Dir : String) return Boolean is
 313          Last : constant Integer := Path'Last - Dir'Length + 1;
 314
 315       begin
 316          for J in Path'First .. Last loop
 317
 318             --  Note: the order of the conditions below is important, since
 319             --  it ensures a minimal number of string comparisons.
 320
 321             if (J = Path'First
 322                 or else Path (J - 1) = Path_Separator)
 323               and then
 324                 (J + Dir'Length > Path'Last
 325                  or else Path (J + Dir'Length) = Path_Separator)
 326               and then Dir = Path (J .. J + Dir'Length - 1)
 327             then
 328                return True;
 329             end if;
 330          end loop;
 331
 332          return False;
 333       end Is_Present;
 334
 335    --  Start of processing for Add_To_Path
 336
 337    begin
 338       if Is_Present (Buffer (1 .. Buffer_Last), Dir) then
 339
 340          --  Dir is already in the path, nothing to do
 341
 342          return;
 343       end if;
 344
 345       Min_Len := Buffer_Last + Dir'Length;
 346
 347       if Buffer_Last > 0 then
 348
 349          --  Add 1 for the Path_Separator character
 350
 351          Min_Len := Min_Len + 1;
 352       end if;
 353
 354       --  If Ada_Path_Buffer is too small, increase it
 355
 356       Len := Buffer'Last;
 357
 358       if Len < Min_Len then
 359          loop
 360             Len := Len * 2;
 361             exit when Len >= Min_Len;
 362          end loop;
 363
 364          New_Buffer := new String (1 .. Len);
 365          New_Buffer (1 .. Buffer_Last) := Buffer (1 .. Buffer_Last);
 366          Free (Buffer);
 367          Buffer := New_Buffer;
 368       end if;
 369
 370       if Buffer_Last > 0 then
 371          Buffer_Last := Buffer_Last + 1;
 372          Buffer (Buffer_Last) := Path_Separator;
 373       end if;
 374
 375       Buffer (Buffer_Last + 1 .. Buffer_Last + Dir'Length) := Dir;
 376       Buffer_Last := Buffer_Last + Dir'Length;
 377    end Add_To_Path;
 378
 379    ------------------------
 380    -- Add_To_Source_Path --
 381    ------------------------
 382
 383    procedure Add_To_Source_Path
 384      (Source_Dirs  : String_List_Id;
 385       In_Tree      : Project_Tree_Ref;
 386       Source_Paths : in out Source_Path_Table.Instance)
 387    is
 388       Current    : String_List_Id := Source_Dirs;
 389       Source_Dir : String_Element;
 390       Add_It     : Boolean;
 391
 392    begin
 393       --  Add each source directory
 394
 395       while Current /= Nil_String loop
 396          Source_Dir := In_Tree.String_Elements.Table (Current);
 397          Add_It := True;
 398
 399          --  Check if the source directory is already in the table
 400
 401          for Index in Source_Path_Table.First ..
 402                       Source_Path_Table.Last (Source_Paths)
 403          loop
 404             --  If it is already, no need to add it
 405
 406             if Source_Paths.Table (Index) = Source_Dir.Value then
 407                Add_It := False;
 408                exit;
 409             end if;
 410          end loop;
 411
 412          if Add_It then
 413             Source_Path_Table.Append (Source_Paths, Source_Dir.Display_Value);
 414          end if;
 415
 416          --  Next source directory
 417
 418          Current := Source_Dir.Next;
 419       end loop;
 420    end Add_To_Source_Path;
 421
 422    --------------------------------
 423    -- Create_Config_Pragmas_File --
 424    --------------------------------
 425
 426    procedure Create_Config_Pragmas_File
 427      (For_Project : Project_Id;
 428       In_Tree     : Project_Tree_Ref)
 429    is
 430       type Naming_Id is new Nat;
 431       package Naming_Table is new GNAT.Dynamic_Tables
 432         (Table_Component_Type => Lang_Naming_Data,
 433          Table_Index_Type     => Naming_Id,
 434          Table_Low_Bound      => 1,
 435          Table_Initial        => 5,
 436          Table_Increment      => 100);
 437       Default_Naming : constant Naming_Id := Naming_Table.First;
 438       Namings        : Naming_Table.Instance;
 439       --  Table storing the naming data for gnatmake/gprmake
 440
 441       Buffer      : String_Access := new String (1 .. Buffer_Initial);
 442       Buffer_Last : Natural := 0;
 443
 444       File_Name : Path_Name_Type  := No_Path;
 445       File      : File_Descriptor := Invalid_FD;
 446
 447       Current_Naming  : Naming_Id;
 448       Iter            : Source_Iterator;
 449       Source          : Source_Id;
 450
 451       procedure Check (Project : Project_Id; State : in out Integer);
 452       --  Recursive procedure that put in the config pragmas file any non
 453       --  standard naming schemes, if it is not already in the file, then call
 454       --  itself for any imported project.
 455
 456       procedure Put (Source : Source_Id);
 457       --  Put an SFN pragma in the temporary file
 458
 459       procedure Put (S : String);
 460       procedure Put_Line (S : String);
 461       --  Output procedures, analogous to normal Text_IO procs of same name.
 462       --  The text is put in Buffer, then it will be writen into a temporary
 463       --  file with procedure Write_Temp_File below.
 464
 465       procedure Write_Temp_File;
 466       --  Create a temporary file and put the content of the buffer in it
 467
 468       -----------
 469       -- Check --
 470       -----------
 471
 472       procedure Check (Project : Project_Id; State : in out Integer) is
 473          pragma Unreferenced (State);
 474          Lang   : constant Language_Ptr :=
 475                     Get_Language_From_Name (Project, "ada");
 476          Naming : Lang_Naming_Data;
 477
 478       begin
 479          if Current_Verbosity = High then
 480             Write_Str ("Checking project file """);
 481             Write_Str (Namet.Get_Name_String (Project.Name));
 482             Write_Str (""".");
 483             Write_Eol;
 484          end if;
 485
 486          if Lang = null then
 487             if Current_Verbosity = High then
 488                Write_Line ("   Languages does not contain Ada, nothing to do");
 489             end if;
 490
 491             return;
 492          end if;
 493
 494          Naming := Lang.Config.Naming_Data;
 495
 496          --  Is the naming scheme of this project one that we know?
 497
 498          Current_Naming := Default_Naming;
 499          while Current_Naming <= Naming_Table.Last (Namings)
 500            and then Namings.Table (Current_Naming).Dot_Replacement =
 501                                                     Naming.Dot_Replacement
 502            and then Namings.Table (Current_Naming).Casing =
 503                                                     Naming.Casing
 504            and then Namings.Table (Current_Naming).Separate_Suffix =
 505                                                     Naming.Separate_Suffix
 506          loop
 507             Current_Naming := Current_Naming + 1;
 508          end loop;
 509
 510          --  If we don't know it, add it
 511
 512          if Current_Naming > Naming_Table.Last (Namings) then
 513             Naming_Table.Increment_Last (Namings);
 514             Namings.Table (Naming_Table.Last (Namings)) := Naming;
 515
 516             --  Put the SFN pragmas for the naming scheme
 517
 518             --  Spec
 519
 520             Put_Line
 521               ("pragma Source_File_Name_Project");
 522             Put_Line
 523               ("  (Spec_File_Name  => ""*" &
 524                Get_Name_String (Naming.Spec_Suffix) & """,");
 525             Put_Line
 526               ("   Casing          => " &
 527                Image (Naming.Casing) & ",");
 528             Put_Line
 529               ("   Dot_Replacement => """ &
 530                Get_Name_String (Naming.Dot_Replacement) & """);");
 531
 532             --  and body
 533
 534             Put_Line
 535               ("pragma Source_File_Name_Project");
 536             Put_Line
 537               ("  (Body_File_Name  => ""*" &
 538                Get_Name_String (Naming.Body_Suffix) & """,");
 539             Put_Line
 540               ("   Casing          => " &
 541                Image (Naming.Casing) & ",");
 542             Put_Line
 543               ("   Dot_Replacement => """ &
 544                Get_Name_String (Naming.Dot_Replacement) &
 545                """);");
 546
 547             --  and maybe separate
 548
 549             if Naming.Body_Suffix /= Naming.Separate_Suffix then
 550                Put_Line ("pragma Source_File_Name_Project");
 551                Put_Line
 552                  ("  (Subunit_File_Name  => ""*" &
 553                   Get_Name_String (Naming.Separate_Suffix) & """,");
 554                Put_Line
 555                  ("   Casing          => " &
 556                   Image (Naming.Casing) & ",");
 557                Put_Line
 558                  ("   Dot_Replacement => """ &
 559                   Get_Name_String (Naming.Dot_Replacement) &
 560                   """);");
 561             end if;
 562          end if;
 563       end Check;
 564
 565       ---------
 566       -- Put --
 567       ---------
 568
 569       procedure Put (Source : Source_Id) is
 570       begin
 571          --  Put the pragma SFN for the unit kind (spec or body)
 572
 573          Put ("pragma Source_File_Name_Project (");
 574          Put (Namet.Get_Name_String (Source.Unit.Name));
 575
 576          if Source.Kind = Spec then
 577             Put (", Spec_File_Name => """);
 578          else
 579             Put (", Body_File_Name => """);
 580          end if;
 581
 582          Put (Namet.Get_Name_String (Source.File));
 583          Put ("""");
 584
 585          if Source.Index /= 0 then
 586             Put (", Index =>");
 587             Put (Source.Index'Img);
 588          end if;
 589
 590          Put_Line (");");
 591       end Put;
 592
 593       procedure Put (S : String) is
 594       begin
 595          Add_To_Buffer (S, Buffer, Buffer_Last);
 596
 597          if Current_Verbosity = High then
 598             Write_Str (S);
 599          end if;
 600       end Put;
 601
 602       --------------
 603       -- Put_Line --
 604       --------------
 605
 606       procedure Put_Line (S : String) is
 607       begin
 608          --  Add an ASCII.LF to the string. As this config file is supposed to
 609          --  be used only by the compiler, we don't care about the characters
 610          --  for the end of line. In fact we could have put a space, but
 611          --  it is more convenient to be able to read gnat.adc during
 612          --  development, for which the ASCII.LF is fine.
 613
 614          Put (S);
 615          Put (S => (1 => ASCII.LF));
 616       end Put_Line;
 617
 618       ---------------------
 619       -- Write_Temp_File --
 620       ---------------------
 621
 622       procedure Write_Temp_File is
 623          Status : Boolean := False;
 624          Last   : Natural;
 625
 626       begin
 627          Tempdir.Create_Temp_File (File, File_Name);
 628
 629          if File /= Invalid_FD then
 630             Last := Write (File, Buffer (1)'Address, Buffer_Last);
 631
 632             if Last = Buffer_Last then
 633                Close (File, Status);
 634             end if;
 635          end if;
 636
 637          if not Status then
 638             Prj.Com.Fail ("unable to create temporary file");
 639          end if;
 640       end Write_Temp_File;
 641
 642       procedure Check_Imported_Projects is
 643         new For_Every_Project_Imported (Integer, Check);
 644
 645       Dummy : Integer := 0;
 646
 647    --  Start of processing for Create_Config_Pragmas_File
 648
 649    begin
 650       if not For_Project.Config_Checked then
 651          Naming_Table.Init (Namings);
 652
 653          --  Check the naming schemes
 654
 655          Check_Imported_Projects (For_Project, Dummy, Imported_First => False);
 656
 657          --  Visit all the files and process those that need an SFN pragma
 658
 659          Iter := For_Each_Source (In_Tree, For_Project);
 660          while Element (Iter) /= No_Source loop
 661             Source := Element (Iter);
 662
 663             if Source.Index >= 1
 664               and then not Source.Locally_Removed
 665               and then Source.Unit /= null
 666             then
 667                Put (Source);
 668             end if;
 669
 670             Next (Iter);
 671          end loop;
 672
 673          --  If there are no non standard naming scheme, issue the GNAT
 674          --  standard naming scheme. This will tell the compiler that
 675          --  a project file is used and will forbid any pragma SFN.
 676
 677          if Buffer_Last = 0 then
 678
 679             Put_Line ("pragma Source_File_Name_Project");
 680             Put_Line ("   (Spec_File_Name  => ""*.ads"",");
 681             Put_Line ("    Dot_Replacement => ""-"",");
 682             Put_Line ("    Casing          => lowercase);");
 683
 684             Put_Line ("pragma Source_File_Name_Project");
 685             Put_Line ("   (Body_File_Name  => ""*.adb"",");
 686             Put_Line ("    Dot_Replacement => ""-"",");
 687             Put_Line ("    Casing          => lowercase);");
 688          end if;
 689
 690          --  Close the temporary file
 691
 692          Write_Temp_File;
 693
 694          if Opt.Verbose_Mode then
 695             Write_Str ("Created configuration file """);
 696             Write_Str (Get_Name_String (File_Name));
 697             Write_Line ("""");
 698          end if;
 699
 700          For_Project.Config_File_Name := File_Name;
 701          For_Project.Config_File_Temp := True;
 702          For_Project.Config_Checked   := True;
 703       end if;
 704
 705       Free (Buffer);
 706    end Create_Config_Pragmas_File;
 707
 708    --------------------
 709    -- Create_Mapping --
 710    --------------------
 711
 712    procedure Create_Mapping (In_Tree : Project_Tree_Ref) is
 713       Data : Source_Id;
 714       Iter : Source_Iterator;
 715
 716    begin
 717       Fmap.Reset_Tables;
 718
 719       Iter := For_Each_Source (In_Tree);
 720       loop
 721          Data := Element (Iter);
 722          exit when Data = No_Source;
 723
 724          if Data.Unit /= No_Unit_Index then
 725             if Data.Locally_Removed then
 726                Fmap.Add_Forbidden_File_Name (Data.File);
 727             else
 728                Fmap.Add_To_File_Map
 729                  (Unit_Name => Unit_Name_Type (Data.Unit.Name),
 730                   File_Name => Data.File,
 731                   Path_Name => File_Name_Type (Data.Path.Name));
 732             end if;
 733          end if;
 734
 735          Next (Iter);
 736       end loop;
 737    end Create_Mapping;
 738
 739    -------------------------
 740    -- Create_Mapping_File --
 741    -------------------------
 742
 743    procedure Create_Mapping_File
 744      (Project  : Project_Id;
 745       Language : Name_Id;
 746       In_Tree  : Project_Tree_Ref;
 747       Name     : out Path_Name_Type)
 748    is
 749       File   : File_Descriptor := Invalid_FD;
 750
 751       Buffer : String_Access := new String (1 .. Buffer_Initial);
 752       Buffer_Last : Natural := 0;
 753
 754       procedure Put_Name_Buffer;
 755       --  Put the line contained in the Name_Buffer in the global buffer
 756
 757       procedure Process (Project : Project_Id; State : in out Integer);
 758       --  Generate the mapping file for Project (not recursively)
 759
 760       ---------------------
 761       -- Put_Name_Buffer --
 762       ---------------------
 763
 764       procedure Put_Name_Buffer is
 765       begin
 766          Name_Len := Name_Len + 1;
 767          Name_Buffer (Name_Len) := ASCII.LF;
 768
 769          if Current_Verbosity = High then
 770             Write_Str ("Mapping file: " & Name_Buffer (1 .. Name_Len));
 771          end if;
 772
 773          Add_To_Buffer (Name_Buffer (1 .. Name_Len), Buffer, Buffer_Last);
 774       end Put_Name_Buffer;
 775
 776       -------------
 777       -- Process --
 778       -------------
 779
 780       procedure Process (Project : Project_Id; State : in out Integer) is
 781          pragma Unreferenced (State);
 782          Source : Source_Id;
 783          Suffix : File_Name_Type;
 784          Iter   : Source_Iterator;
 785
 786       begin
 787          Iter := For_Each_Source (In_Tree, Project, Language => Language);
 788
 789          loop
 790             Source := Prj.Element (Iter);
 791             exit when Source = No_Source;
 792
 793             if Source.Replaced_By = No_Source
 794               and then Source.Path.Name /= No_Path
 795               and then
 796                 (Source.Language.Config.Kind = File_Based
 797                   or else Source.Unit /= No_Unit_Index)
 798             then
 799                if Source.Unit /= No_Unit_Index then
 800                   Get_Name_String (Source.Unit.Name);
 801
 802                   if Source.Language.Config.Kind = Unit_Based then
 803
 804                      --  ??? Mapping_Spec_Suffix could be set in the case of
 805                      --  gnatmake as well
 806
 807                      Add_Char_To_Name_Buffer ('%');
 808
 809                      if Source.Kind = Spec then
 810                         Add_Char_To_Name_Buffer ('s');
 811                      else
 812                         Add_Char_To_Name_Buffer ('b');
 813                      end if;
 814
 815                   else
 816                      case Source.Kind is
 817                         when Spec =>
 818                            Suffix :=
 819                              Source.Language.Config.Mapping_Spec_Suffix;
 820                         when Impl | Sep =>
 821                            Suffix :=
 822                              Source.Language.Config.Mapping_Body_Suffix;
 823                      end case;
 824
 825                      if Suffix /= No_File then
 826                         Add_Str_To_Name_Buffer
 827                           (Get_Name_String (Suffix));
 828                      end if;
 829                   end if;
 830
 831                   Put_Name_Buffer;
 832                end if;
 833
 834                Get_Name_String (Source.File);
 835                Put_Name_Buffer;
 836
 837                if Source.Locally_Removed then
 838                   Name_Len := 1;
 839                   Name_Buffer (1) := '/';
 840                else
 841                   Get_Name_String (Source.Path.Name);
 842                end if;
 843
 844                Put_Name_Buffer;
 845             end if;
 846
 847             Next (Iter);
 848          end loop;
 849       end Process;
 850
 851       procedure For_Every_Imported_Project is new
 852         For_Every_Project_Imported (State => Integer, Action => Process);
 853
 854       Dummy : Integer := 0;
 855
 856    --  Start of processing for Create_Mapping_File
 857
 858    begin
 859       For_Every_Imported_Project (Project, Dummy);
 860
 861       declare
 862          Last   : Natural;
 863          Status : Boolean := False;
 864
 865       begin
 866          Create_Temp_File (In_Tree, File, Name, "mapping");
 867
 868          if File /= Invalid_FD then
 869             Last := Write (File, Buffer (1)'Address, Buffer_Last);
 870
 871             if Last = Buffer_Last then
 872                GNAT.OS_Lib.Close (File, Status);
 873             end if;
 874          end if;
 875
 876          if not Status then
 877             Prj.Com.Fail ("could not write mapping file");
 878          end if;
 879       end;
 880
 881       Free (Buffer);
 882    end Create_Mapping_File;
 883
 884    ----------------------
 885    -- Create_Temp_File --
 886    ----------------------
 887
 888    procedure Create_Temp_File
 889      (In_Tree   : Project_Tree_Ref;
 890       Path_FD   : out File_Descriptor;
 891       Path_Name : out Path_Name_Type;
 892       File_Use  : String)
 893    is
 894    begin
 895       Tempdir.Create_Temp_File (Path_FD, Path_Name);
 896
 897       if Path_Name /= No_Path then
 898          if Current_Verbosity = High then
 899             Write_Line ("Create temp file (" & File_Use & ") "
 900                         & Get_Name_String (Path_Name));
 901          end if;
 902
 903          Record_Temp_File (In_Tree, Path_Name);
 904
 905       else
 906          Prj.Com.Fail
 907            ("unable to create temporary " & File_Use & " file");
 908       end if;
 909    end Create_Temp_File;
 910
 911    --------------------------
 912    -- Create_New_Path_File --
 913    --------------------------
 914
 915    procedure Create_New_Path_File
 916      (In_Tree   : Project_Tree_Ref;
 917       Path_FD   : out File_Descriptor;
 918       Path_Name : out Path_Name_Type)
 919    is
 920    begin
 921       Create_Temp_File (In_Tree, Path_FD, Path_Name, "path file");
 922    end Create_New_Path_File;
 923
 924    ------------------------------------
 925    -- File_Name_Of_Library_Unit_Body --
 926    ------------------------------------
 927
 928    function File_Name_Of_Library_Unit_Body
 929      (Name              : String;
 930       Project           : Project_Id;
 931       In_Tree           : Project_Tree_Ref;
 932       Main_Project_Only : Boolean := True;
 933       Full_Path         : Boolean := False) return String
 934    is
 935       The_Project   : Project_Id := Project;
 936       Original_Name : String := Name;
 937
 938       Lang   : constant Language_Ptr :=
 939         Get_Language_From_Name (Project, "ada");
 940
 941       Unit              : Unit_Index;
 942       The_Original_Name : Name_Id;
 943       The_Spec_Name     : Name_Id;
 944       The_Body_Name     : Name_Id;
 945
 946    begin
 947       --  ??? Same block in Project_Of
 948       Canonical_Case_File_Name (Original_Name);
 949       Name_Len := Original_Name'Length;
 950       Name_Buffer (1 .. Name_Len) := Original_Name;
 951       The_Original_Name := Name_Find;
 952
 953       if Lang /= null then
 954          declare
 955             Naming : constant Lang_Naming_Data := Lang.Config.Naming_Data;
 956             Extended_Spec_Name : String :=
 957                                    Name & Namet.Get_Name_String
 958                                             (Naming.Spec_Suffix);
 959             Extended_Body_Name : String :=
 960                                    Name & Namet.Get_Name_String
 961                                             (Naming.Body_Suffix);
 962
 963          begin
 964             Canonical_Case_File_Name (Extended_Spec_Name);
 965             Name_Len := Extended_Spec_Name'Length;
 966             Name_Buffer (1 .. Name_Len) := Extended_Spec_Name;
 967             The_Spec_Name := Name_Find;
 968
 969             Canonical_Case_File_Name (Extended_Body_Name);
 970             Name_Len := Extended_Body_Name'Length;
 971             Name_Buffer (1 .. Name_Len) := Extended_Body_Name;
 972             The_Body_Name := Name_Find;
 973          end;
 974
 975       else
 976          Name_Len := Name'Length;
 977          Name_Buffer (1 .. Name_Len) := Name;
 978          Canonical_Case_File_Name (Name_Buffer);
 979          The_Spec_Name := Name_Find;
 980          The_Body_Name := The_Spec_Name;
 981       end if;
 982
 983       if Current_Verbosity = High then
 984          Write_Str  ("Looking for file name of """);
 985          Write_Str  (Name);
 986          Write_Char ('"');
 987          Write_Eol;
 988          Write_Str  ("   Extended Spec Name = """);
 989          Write_Str  (Get_Name_String (The_Spec_Name));
 990          Write_Char ('"');
 991          Write_Eol;
 992          Write_Str  ("   Extended Body Name = """);
 993          Write_Str  (Get_Name_String (The_Body_Name));
 994          Write_Char ('"');
 995          Write_Eol;
 996       end if;
 997
 998       --  For extending project, search in the extended project if the source
 999       --  is not found. For non extending projects, this loop will be run only
1000       --  once.
1001
1002       loop
1003          --  Loop through units
1004
1005          Unit := Units_Htable.Get_First (In_Tree.Units_HT);
1006          while Unit /= null loop
1007             --  Check for body
1008
1009             if not Main_Project_Only
1010               or else
1011                 (Unit.File_Names (Impl) /= null
1012                  and then Unit.File_Names (Impl).Project = The_Project)
1013             then
1014                declare
1015                   Current_Name : File_Name_Type;
1016                begin
1017                   --  Case of a body present
1018
1019                   if Unit.File_Names (Impl) /= null then
1020                      Current_Name := Unit.File_Names (Impl).File;
1021
1022                      if Current_Verbosity = High then
1023                         Write_Str  ("   Comparing with """);
1024                         Write_Str  (Get_Name_String (Current_Name));
1025                         Write_Char ('"');
1026                         Write_Eol;
1027                      end if;
1028
1029                      --  If it has the name of the original name, return the
1030                      --  original name.
1031
1032                      if Unit.Name = The_Original_Name
1033                        or else
1034                          Current_Name = File_Name_Type (The_Original_Name)
1035                      then
1036                         if Current_Verbosity = High then
1037                            Write_Line ("   OK");
1038                         end if;
1039
1040                         if Full_Path then
1041                            return Get_Name_String
1042                              (Unit.File_Names (Impl).Path.Name);
1043
1044                         else
1045                            return Get_Name_String (Current_Name);
1046                         end if;
1047
1048                         --  If it has the name of the extended body name,
1049                         --  return the extended body name
1050
1051                      elsif Current_Name = File_Name_Type (The_Body_Name) then
1052                         if Current_Verbosity = High then
1053                            Write_Line ("   OK");
1054                         end if;
1055
1056                         if Full_Path then
1057                            return Get_Name_String
1058                              (Unit.File_Names (Impl).Path.Name);
1059
1060                         else
1061                            return Get_Name_String (The_Body_Name);
1062                         end if;
1063
1064                      else
1065                         if Current_Verbosity = High then
1066                            Write_Line ("   not good");
1067                         end if;
1068                      end if;
1069                   end if;
1070                end;
1071             end if;
1072
1073             --  Check for spec
1074
1075             if not Main_Project_Only
1076               or else
1077                 (Unit.File_Names (Spec) /= null
1078                  and then Unit.File_Names (Spec).Project =
1079                    The_Project)
1080             then
1081                declare
1082                   Current_Name : File_Name_Type;
1083
1084                begin
1085                   --  Case of spec present
1086
1087                   if Unit.File_Names (Spec) /= null then
1088                      Current_Name := Unit.File_Names (Spec).File;
1089                      if Current_Verbosity = High then
1090                         Write_Str  ("   Comparing with """);
1091                         Write_Str  (Get_Name_String (Current_Name));
1092                         Write_Char ('"');
1093                         Write_Eol;
1094                      end if;
1095
1096                      --  If name same as original name, return original name
1097
1098                      if Unit.Name = The_Original_Name
1099                        or else
1100                          Current_Name = File_Name_Type (The_Original_Name)
1101                      then
1102                         if Current_Verbosity = High then
1103                            Write_Line ("   OK");
1104                         end if;
1105
1106                         if Full_Path then
1107                            return Get_Name_String
1108                              (Unit.File_Names (Spec).Path.Name);
1109                         else
1110                            return Get_Name_String (Current_Name);
1111                         end if;
1112
1113                         --  If it has the same name as the extended spec name,
1114                         --  return the extended spec name.
1115
1116                      elsif Current_Name = File_Name_Type (The_Spec_Name) then
1117                         if Current_Verbosity = High then
1118                            Write_Line ("   OK");
1119                         end if;
1120
1121                         if Full_Path then
1122                            return Get_Name_String
1123                              (Unit.File_Names (Spec).Path.Name);
1124                         else
1125                            return Get_Name_String (The_Spec_Name);
1126                         end if;
1127
1128                      else
1129                         if Current_Verbosity = High then
1130                            Write_Line ("   not good");
1131                         end if;
1132                      end if;
1133                   end if;
1134                end;
1135             end if;
1136
1137             Unit := Units_Htable.Get_Next (In_Tree.Units_HT);
1138          end loop;
1139
1140          --  If we are not in an extending project, give up
1141
1142          exit when not Main_Project_Only
1143            or else The_Project.Extends = No_Project;
1144
1145          --  Otherwise, look in the project we are extending
1146
1147          The_Project := The_Project.Extends;
1148       end loop;
1149
1150       --  We don't know this file name, return an empty string
1151
1152       return "";
1153    end File_Name_Of_Library_Unit_Body;
1154
1155    -------------------------
1156    -- For_All_Object_Dirs --
1157    -------------------------
1158
1159    procedure For_All_Object_Dirs (Project : Project_Id) is
1160       procedure For_Project (Prj : Project_Id; Dummy : in out Integer);
1161       --  Get all object directories of Prj
1162
1163       -----------------
1164       -- For_Project --
1165       -----------------
1166
1167       procedure For_Project (Prj : Project_Id; Dummy : in out Integer) is
1168          pragma Unreferenced (Dummy);
1169       begin
1170          --  ??? Set_Ada_Paths has a different behavior for library project
1171          --  files, should we have the same ?
1172
1173          if Prj.Object_Directory /= No_Path_Information then
1174             Get_Name_String (Prj.Object_Directory.Display_Name);
1175             Action (Name_Buffer (1 .. Name_Len));
1176          end if;
1177       end For_Project;
1178
1179       procedure Get_Object_Dirs is
1180         new For_Every_Project_Imported (Integer, For_Project);
1181       Dummy : Integer := 1;
1182
1183    --  Start of processing for For_All_Object_Dirs
1184
1185    begin
1186       Get_Object_Dirs (Project, Dummy);
1187    end For_All_Object_Dirs;
1188
1189    -------------------------
1190    -- For_All_Source_Dirs --
1191    -------------------------
1192
1193    procedure For_All_Source_Dirs
1194      (Project : Project_Id;
1195       In_Tree : Project_Tree_Ref)
1196    is
1197       procedure For_Project (Prj : Project_Id; Dummy : in out Integer);
1198       --  Get all object directories of Prj
1199
1200       -----------------
1201       -- For_Project --
1202       -----------------
1203
1204       procedure For_Project (Prj : Project_Id; Dummy : in out Integer) is
1205          pragma Unreferenced (Dummy);
1206          Current    : String_List_Id := Prj.Source_Dirs;
1207          The_String : String_Element;
1208
1209       begin
1210          --  If there are Ada sources, call action with the name of every
1211          --  source directory.
1212
1213          if Has_Ada_Sources (Project) then
1214             while Current /= Nil_String loop
1215                The_String := In_Tree.String_Elements.Table (Current);
1216                Action (Get_Name_String (The_String.Display_Value));
1217                Current := The_String.Next;
1218             end loop;
1219          end if;
1220       end For_Project;
1221
1222       procedure Get_Source_Dirs is
1223         new For_Every_Project_Imported (Integer, For_Project);
1224       Dummy : Integer := 1;
1225
1226    --  Start of processing for For_All_Source_Dirs
1227
1228    begin
1229       Get_Source_Dirs (Project, Dummy);
1230    end For_All_Source_Dirs;
1231
1232    -------------------
1233    -- Get_Reference --
1234    -------------------
1235
1236    procedure Get_Reference
1237      (Source_File_Name : String;
1238       In_Tree          : Project_Tree_Ref;
1239       Project          : out Project_Id;
1240       Path             : out Path_Name_Type)
1241    is
1242    begin
1243       --  Body below could use some comments ???
1244
1245       if Current_Verbosity > Default then
1246          Write_Str ("Getting Reference_Of (""");
1247          Write_Str (Source_File_Name);
1248          Write_Str (""") ... ");
1249       end if;
1250
1251       declare
1252          Original_Name : String := Source_File_Name;
1253          Unit          : Unit_Index;
1254
1255       begin
1256          Canonical_Case_File_Name (Original_Name);
1257          Unit := Units_Htable.Get_First (In_Tree.Units_HT);
1258
1259          while Unit /= null loop
1260             if Unit.File_Names (Spec) /= null
1261               and then Unit.File_Names (Spec).File /= No_File
1262               and then
1263                 (Namet.Get_Name_String
1264                      (Unit.File_Names (Spec).File) = Original_Name
1265                  or else (Unit.File_Names (Spec).Path /=
1266                             No_Path_Information
1267                           and then
1268                             Namet.Get_Name_String
1269                               (Unit.File_Names (Spec).Path.Name) =
1270                             Original_Name))
1271             then
1272                Project := Ultimate_Extension_Of
1273                           (Project => Unit.File_Names (Spec).Project);
1274                Path := Unit.File_Names (Spec).Path.Display_Name;
1275
1276                if Current_Verbosity > Default then
1277                   Write_Str ("Done: Spec.");
1278                   Write_Eol;
1279                end if;
1280
1281                return;
1282
1283             elsif Unit.File_Names (Impl) /= null
1284               and then Unit.File_Names (Impl).File /= No_File
1285               and then
1286                 (Namet.Get_Name_String
1287                    (Unit.File_Names (Impl).File) = Original_Name
1288                  or else (Unit.File_Names (Impl).Path /=
1289                             No_Path_Information
1290                           and then Namet.Get_Name_String
1291                             (Unit.File_Names (Impl).Path.Name) =
1292                             Original_Name))
1293             then
1294                Project := Ultimate_Extension_Of
1295                             (Project => Unit.File_Names (Impl).Project);
1296                Path := Unit.File_Names (Impl).Path.Display_Name;
1297
1298                if Current_Verbosity > Default then
1299                   Write_Str ("Done: Body.");
1300                   Write_Eol;
1301                end if;
1302
1303                return;
1304             end if;
1305
1306             Unit := Units_Htable.Get_Next (In_Tree.Units_HT);
1307          end loop;
1308       end;
1309
1310       Project := No_Project;
1311       Path    := No_Path;
1312
1313       if Current_Verbosity > Default then
1314          Write_Str ("Cannot be found.");
1315          Write_Eol;
1316       end if;
1317    end Get_Reference;
1318
1319    ----------------
1320    -- Initialize --
1321    ----------------
1322
1323    procedure Initialize (In_Tree : Project_Tree_Ref) is
1324    begin
1325       In_Tree.Private_Part.Current_Source_Path_File := No_Path;
1326       In_Tree.Private_Part.Current_Object_Path_File := No_Path;
1327    end Initialize;
1328
1329    -------------------
1330    -- Print_Sources --
1331    -------------------
1332
1333    --  Could use some comments in this body ???
1334
1335    procedure Print_Sources (In_Tree : Project_Tree_Ref) is
1336       Unit : Unit_Index;
1337
1338    begin
1339       Write_Line ("List of Sources:");
1340
1341       Unit := Units_Htable.Get_First (In_Tree.Units_HT);
1342
1343       while Unit /= No_Unit_Index loop
1344          Write_Str  ("   ");
1345          Write_Line (Namet.Get_Name_String (Unit.Name));
1346
1347          if Unit.File_Names (Spec).File /= No_File then
1348             if Unit.File_Names (Spec).Project = No_Project then
1349                Write_Line ("   No project");
1350
1351             else
1352                Write_Str  ("   Project: ");
1353                Get_Name_String
1354                  (Unit.File_Names (Spec).Project.Path.Name);
1355                Write_Line (Name_Buffer (1 .. Name_Len));
1356             end if;
1357
1358             Write_Str  ("      spec: ");
1359             Write_Line
1360               (Namet.Get_Name_String
1361                (Unit.File_Names (Spec).File));
1362          end if;
1363
1364          if Unit.File_Names (Impl).File /= No_File then
1365             if Unit.File_Names (Impl).Project = No_Project then
1366                Write_Line ("   No project");
1367
1368             else
1369                Write_Str  ("   Project: ");
1370                Get_Name_String
1371                  (Unit.File_Names (Impl).Project.Path.Name);
1372                Write_Line (Name_Buffer (1 .. Name_Len));
1373             end if;
1374
1375             Write_Str  ("      body: ");
1376             Write_Line
1377               (Namet.Get_Name_String (Unit.File_Names (Impl).File));
1378          end if;
1379
1380          Unit := Units_Htable.Get_Next (In_Tree.Units_HT);
1381       end loop;
1382
1383       Write_Line ("end of List of Sources.");
1384    end Print_Sources;
1385
1386    ----------------
1387    -- Project_Of --
1388    ----------------
1389
1390    function Project_Of
1391      (Name         : String;
1392       Main_Project : Project_Id;
1393       In_Tree      : Project_Tree_Ref) return Project_Id
1394    is
1395       Result : Project_Id := No_Project;
1396
1397       Original_Name : String := Name;
1398
1399       Lang : constant Language_Ptr :=
1400                Get_Language_From_Name (Main_Project, "ada");
1401
1402       Unit : Unit_Index;
1403
1404       Current_Name      : File_Name_Type;
1405       The_Original_Name : File_Name_Type;
1406       The_Spec_Name     : File_Name_Type;
1407       The_Body_Name     : File_Name_Type;
1408
1409    begin
1410       --  ??? Same block in File_Name_Of_Library_Unit_Body
1411       Canonical_Case_File_Name (Original_Name);
1412       Name_Len := Original_Name'Length;
1413       Name_Buffer (1 .. Name_Len) := Original_Name;
1414       The_Original_Name := Name_Find;
1415
1416       if Lang /= null then
1417          declare
1418             Naming : Lang_Naming_Data renames Lang.Config.Naming_Data;
1419             Extended_Spec_Name : String :=
1420                                    Name & Namet.Get_Name_String
1421                                             (Naming.Spec_Suffix);
1422             Extended_Body_Name : String :=
1423                                    Name & Namet.Get_Name_String
1424                                             (Naming.Body_Suffix);
1425
1426          begin
1427             Canonical_Case_File_Name (Extended_Spec_Name);
1428             Name_Len := Extended_Spec_Name'Length;
1429             Name_Buffer (1 .. Name_Len) := Extended_Spec_Name;
1430             The_Spec_Name := Name_Find;
1431
1432             Canonical_Case_File_Name (Extended_Body_Name);
1433             Name_Len := Extended_Body_Name'Length;
1434             Name_Buffer (1 .. Name_Len) := Extended_Body_Name;
1435             The_Body_Name := Name_Find;
1436          end;
1437
1438       else
1439          The_Spec_Name := The_Original_Name;
1440          The_Body_Name := The_Original_Name;
1441       end if;
1442
1443       Unit := Units_Htable.Get_First (In_Tree.Units_HT);
1444       while Unit /= null loop
1445
1446          --  Case of a body present
1447
1448          if Unit.File_Names (Impl) /= null then
1449             Current_Name := Unit.File_Names (Impl).File;
1450
1451             --  If it has the name of the original name or the body name,
1452             --  we have found the project.
1453
1454             if Unit.Name = Name_Id (The_Original_Name)
1455               or else Current_Name = The_Original_Name
1456               or else Current_Name = The_Body_Name
1457             then
1458                Result := Unit.File_Names (Impl).Project;
1459                exit;
1460             end if;
1461          end if;
1462
1463          --  Check for spec
1464
1465          if Unit.File_Names (Spec) /= null then
1466             Current_Name := Unit.File_Names (Spec).File;
1467
1468             --  If name same as the original name, or the spec name, we have
1469             --  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_Spec_Name
1474             then
1475                Result := Unit.File_Names (Spec).Project;
1476                exit;
1477             end if;
1478          end if;
1479
1480          Unit := Units_Htable.Get_Next (In_Tree.Units_HT);
1481       end loop;
1482
1483       --  Get the ultimate extending project
1484
1485       if Result /= No_Project then
1486          while Result.Extended_By /= No_Project loop
1487             Result := Result.Extended_By;
1488          end loop;
1489       end if;
1490
1491       return Result;
1492    end Project_Of;
1493
1494    -------------------
1495    -- Set_Ada_Paths --
1496    -------------------
1497
1498    procedure Set_Ada_Paths
1499      (Project             : Project_Id;
1500       In_Tree             : Project_Tree_Ref;
1501       Including_Libraries : Boolean;
1502       Include_Path        : Boolean := True;
1503       Objects_Path        : Boolean := True)
1504
1505    is
1506       Source_Paths : Source_Path_Table.Instance;
1507       Object_Paths : Object_Path_Table.Instance;
1508       --  List of source or object dirs. Only computed the first time this
1509       --  procedure is called (since Source_FD is then reused)
1510
1511       Source_FD : File_Descriptor := Invalid_FD;
1512       Object_FD : File_Descriptor := Invalid_FD;
1513       --  The temporary files to store the paths. These are only created the
1514       --  first time this procedure is called, and reused from then on.
1515
1516       Process_Source_Dirs : Boolean := False;
1517       Process_Object_Dirs : Boolean := False;
1518
1519       Status : Boolean;
1520       --  For calls to Close
1521
1522       Last        : Natural;
1523       Buffer      : String_Access := new String (1 .. Buffer_Initial);
1524       Buffer_Last : Natural := 0;
1525
1526       procedure Recursive_Add (Project : Project_Id; Dummy : in out Boolean);
1527       --  Recursive procedure to add the source/object paths of extended/
1528       --  imported projects.
1529
1530       -------------------
1531       -- Recursive_Add --
1532       -------------------
1533
1534       procedure Recursive_Add (Project : Project_Id; Dummy : in out Boolean) is
1535          pragma Unreferenced (Dummy);
1536
1537          Path : Path_Name_Type;
1538
1539       begin
1540          --  ??? This is almost the equivalent of For_All_Source_Dirs
1541
1542          if Process_Source_Dirs then
1543
1544             --  Add to path all source directories of this project if there are
1545             --  Ada sources.
1546
1547             if Has_Ada_Sources (Project) then
1548                Add_To_Source_Path (Project.Source_Dirs, In_Tree, Source_Paths);
1549             end if;
1550          end if;
1551
1552          if Process_Object_Dirs then
1553             Path := Get_Object_Directory
1554               (Project,
1555                Including_Libraries => Including_Libraries,
1556                Only_If_Ada         => True);
1557
1558             if Path /= No_Path then
1559                Add_To_Object_Path (Path, Object_Paths);
1560             end if;
1561          end if;
1562       end Recursive_Add;
1563
1564       procedure For_All_Projects is
1565         new For_Every_Project_Imported (Boolean, Recursive_Add);
1566
1567       Dummy : Boolean := False;
1568
1569    --  Start of processing for Set_Ada_Paths
1570
1571    begin
1572       --  If it is the first time we call this procedure for this project,
1573       --  compute the source path and/or the object path.
1574
1575       if Include_Path and then Project.Include_Path_File = No_Path then
1576          Source_Path_Table.Init (Source_Paths);
1577          Process_Source_Dirs := True;
1578          Create_New_Path_File
1579            (In_Tree, Source_FD, Project.Include_Path_File);
1580       end if;
1581
1582       --  For the object path, we make a distinction depending on
1583       --  Including_Libraries.
1584
1585       if Objects_Path and Including_Libraries then
1586          if Project.Objects_Path_File_With_Libs = No_Path then
1587             Object_Path_Table.Init (Object_Paths);
1588             Process_Object_Dirs := True;
1589             Create_New_Path_File
1590               (In_Tree, Object_FD, Project.Objects_Path_File_With_Libs);
1591          end if;
1592
1593       elsif Objects_Path then
1594          if Project.Objects_Path_File_Without_Libs = No_Path then
1595             Object_Path_Table.Init (Object_Paths);
1596             Process_Object_Dirs := True;
1597             Create_New_Path_File
1598               (In_Tree, Object_FD, Project.Objects_Path_File_Without_Libs);
1599          end if;
1600       end if;
1601
1602       --  If there is something to do, set Seen to False for all projects,
1603       --  then call the recursive procedure Add for Project.
1604
1605       if Process_Source_Dirs or Process_Object_Dirs then
1606          For_All_Projects (Project, Dummy);
1607       end if;
1608
1609       --  Write and close any file that has been created. Source_FD is not set
1610       --  when this subprogram is called a second time or more, since we reuse
1611       --  the previous version of the file.
1612
1613       if Source_FD /= Invalid_FD then
1614          Buffer_Last := 0;
1615
1616          for Index in Source_Path_Table.First ..
1617                       Source_Path_Table.Last (Source_Paths)
1618          loop
1619             Get_Name_String (Source_Paths.Table (Index));
1620             Name_Len := Name_Len + 1;
1621             Name_Buffer (Name_Len) := ASCII.LF;
1622             Add_To_Buffer (Name_Buffer (1 .. Name_Len), Buffer, Buffer_Last);
1623          end loop;
1624
1625          Last := Write (Source_FD, Buffer (1)'Address, Buffer_Last);
1626
1627          if Last = Buffer_Last then
1628             Close (Source_FD, Status);
1629
1630          else
1631             Status := False;
1632          end if;
1633
1634          if not Status then
1635             Prj.Com.Fail ("could not write temporary file");
1636          end if;
1637       end if;
1638
1639       if Object_FD /= Invalid_FD then
1640          Buffer_Last := 0;
1641
1642          for Index in Object_Path_Table.First ..
1643                       Object_Path_Table.Last (Object_Paths)
1644          loop
1645             Get_Name_String (Object_Paths.Table (Index));
1646             Name_Len := Name_Len + 1;
1647             Name_Buffer (Name_Len) := ASCII.LF;
1648             Add_To_Buffer (Name_Buffer (1 .. Name_Len), Buffer, Buffer_Last);
1649          end loop;
1650
1651          Last := Write (Object_FD, Buffer (1)'Address, Buffer_Last);
1652
1653          if Last = Buffer_Last then
1654             Close (Object_FD, Status);
1655          else
1656             Status := False;
1657          end if;
1658
1659          if not Status then
1660             Prj.Com.Fail ("could not write temporary file");
1661          end if;
1662       end if;
1663
1664       --  Set the env vars, if they need to be changed, and set the
1665       --  corresponding flags.
1666
1667       if Include_Path and then
1668          In_Tree.Private_Part.Current_Source_Path_File /=
1669            Project.Include_Path_File
1670       then
1671          In_Tree.Private_Part.Current_Source_Path_File :=
1672            Project.Include_Path_File;
1673          Set_Path_File_Var
1674            (Project_Include_Path_File,
1675             Get_Name_String (In_Tree.Private_Part.Current_Source_Path_File));
1676       end if;
1677
1678       if Objects_Path then
1679          if Including_Libraries then
1680             if In_Tree.Private_Part.Current_Object_Path_File /=
1681               Project.Objects_Path_File_With_Libs
1682             then
1683                In_Tree.Private_Part.Current_Object_Path_File :=
1684                  Project.Objects_Path_File_With_Libs;
1685                Set_Path_File_Var
1686                  (Project_Objects_Path_File,
1687                   Get_Name_String
1688                     (In_Tree.Private_Part.Current_Object_Path_File));
1689             end if;
1690
1691          else
1692             if In_Tree.Private_Part.Current_Object_Path_File /=
1693               Project.Objects_Path_File_Without_Libs
1694             then
1695                In_Tree.Private_Part.Current_Object_Path_File :=
1696                  Project.Objects_Path_File_Without_Libs;
1697                Set_Path_File_Var
1698                  (Project_Objects_Path_File,
1699                   Get_Name_String
1700                     (In_Tree.Private_Part.Current_Object_Path_File));
1701             end if;
1702          end if;
1703       end if;
1704
1705       Free (Buffer);
1706    end Set_Ada_Paths;
1707
1708    -----------------------
1709    -- Set_Path_File_Var --
1710    -----------------------
1711
1712    procedure Set_Path_File_Var (Name : String; Value : String) is
1713       Host_Spec : String_Access := To_Host_File_Spec (Value);
1714    begin
1715       if Host_Spec = null then
1716          Prj.Com.Fail
1717            ("could not convert file name """ & Value & """ to host spec");
1718       else
1719          Setenv (Name, Host_Spec.all);
1720          Free (Host_Spec);
1721       end if;
1722    end Set_Path_File_Var;
1723
1724    ---------------------------
1725    -- Ultimate_Extension_Of --
1726    ---------------------------
1727
1728    function Ultimate_Extension_Of
1729      (Project : Project_Id) return Project_Id
1730    is
1731       Result : Project_Id;
1732
1733    begin
1734       Result := Project;
1735       while Result.Extended_By /= No_Project loop
1736          Result := Result.Extended_By;
1737       end loop;
1738
1739       return Result;
1740    end Ultimate_Extension_Of;
1741
1742 end Prj.Env;