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