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