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