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