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