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