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 := Unit_Table.First;
 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 = Specification 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
 677            Current_Unit <= Unit_Table.Last (In_Tree.Units)
 678          loop
 679             declare
 680                Unit : constant Unit_Data :=
 681                  In_Tree.Units.Table (Current_Unit);
 682
 683             begin
 684                if Unit.File_Names (Specification).Needs_Pragma then
 685                   Put (Unit.Name,
 686                        Unit.File_Names (Specification).Name,
 687                        Specification,
 688                        Unit.File_Names (Specification).Index);
 689                end if;
 690
 691                if Unit.File_Names (Body_Part).Needs_Pragma then
 692                   Put (Unit.Name,
 693                        Unit.File_Names (Body_Part).Name,
 694                        Body_Part,
 695                        Unit.File_Names (Body_Part).Index);
 696                end if;
 697
 698                Current_Unit := Current_Unit + 1;
 699             end;
 700          end loop;
 701
 702          --  If there are no non standard naming scheme, issue the GNAT
 703          --  standard naming scheme. This will tell the compiler that
 704          --  a project file is used and will forbid any pragma SFN.
 705
 706          if File = Invalid_FD then
 707             Check_Temp_File;
 708
 709             Put_Line (File, "pragma Source_File_Name_Project");
 710             Put_Line (File, "   (Spec_File_Name  => ""*.ads"",");
 711             Put_Line (File, "    Dot_Replacement => ""-"",");
 712             Put_Line (File, "    Casing          => lowercase);");
 713
 714             Put_Line (File, "pragma Source_File_Name_Project");
 715             Put_Line (File, "   (Body_File_Name  => ""*.adb"",");
 716             Put_Line (File, "    Dot_Replacement => ""-"",");
 717             Put_Line (File, "    Casing          => lowercase);");
 718          end if;
 719
 720          --  Close the temporary file
 721
 722          GNAT.OS_Lib.Close (File, Status);
 723
 724          if not Status then
 725             Prj.Com.Fail ("disk full");
 726          end if;
 727
 728          if Opt.Verbose_Mode then
 729             Write_Str ("Closing configuration file """);
 730             Write_Str (Get_Name_String (File_Name));
 731             Write_Line ("""");
 732          end if;
 733
 734          For_Project.Config_File_Name := File_Name;
 735          For_Project.Config_File_Temp := True;
 736          For_Project.Config_Checked   := True;
 737       end if;
 738    end Create_Config_Pragmas_File;
 739
 740    --------------------
 741    -- Create_Mapping --
 742    --------------------
 743
 744    procedure Create_Mapping (In_Tree : Project_Tree_Ref) is
 745       The_Unit_Data : Unit_Data;
 746       Data          : File_Name_Data;
 747
 748    begin
 749       Fmap.Reset_Tables;
 750
 751       for Unit in 1 .. Unit_Table.Last (In_Tree.Units) loop
 752          The_Unit_Data := In_Tree.Units.Table (Unit);
 753
 754          --  Process only if the unit has a valid name
 755
 756          if The_Unit_Data.Name /= No_Name then
 757             Data := The_Unit_Data.File_Names (Specification);
 758
 759             --  If there is a spec, put it in the mapping
 760
 761             if Data.Name /= No_File then
 762                if Data.Path.Name = Slash then
 763                   Fmap.Add_Forbidden_File_Name (Data.Name);
 764                else
 765                   Fmap.Add_To_File_Map
 766                     (Unit_Name => Unit_Name_Type (The_Unit_Data.Name),
 767                      File_Name => Data.Name,
 768                      Path_Name => File_Name_Type (Data.Path.Name));
 769                end if;
 770             end if;
 771
 772             Data := The_Unit_Data.File_Names (Body_Part);
 773
 774             --  If there is a body (or subunit) put it in the mapping
 775
 776             if Data.Name /= No_File then
 777                if Data.Path.Name = Slash then
 778                   Fmap.Add_Forbidden_File_Name (Data.Name);
 779                else
 780                   Fmap.Add_To_File_Map
 781                     (Unit_Name => Unit_Name_Type (The_Unit_Data.Name),
 782                      File_Name => Data.Name,
 783                      Path_Name => File_Name_Type (Data.Path.Name));
 784                end if;
 785             end if;
 786          end if;
 787       end loop;
 788    end Create_Mapping;
 789
 790    -------------------------
 791    -- Create_Mapping_File --
 792    -------------------------
 793
 794    procedure Create_Mapping_File
 795      (Project  : Project_Id;
 796       Language : Name_Id := No_Name;
 797       In_Tree  : Project_Tree_Ref;
 798       Name     : out Path_Name_Type)
 799    is
 800       File   : File_Descriptor := Invalid_FD;
 801       Status : Boolean;
 802
 803       Present : Project_Boolean_Htable.Instance;
 804       --  For each project in the closure of Project, the corresponding flag
 805       --  will be set to True.
 806
 807       Source        : Source_Id;
 808       Suffix        : File_Name_Type;
 809       The_Unit_Data : Unit_Data;
 810       Data          : File_Name_Data;
 811       Iter          : Source_Iterator;
 812
 813       procedure Put_Name_Buffer;
 814       --  Put the line contained in the Name_Buffer in the mapping file
 815
 816       procedure Put_Data (Spec : Boolean);
 817       --  Put the mapping of the spec or body contained in Data in the file
 818       --  (3 lines).
 819
 820       procedure Recursive_Flag (Prj : Project_Id);
 821       --  Set the flags corresponding to Prj, the projects it imports
 822       --  (directly or indirectly) or extends to True. Call itself recursively.
 823
 824       ---------
 825       -- Put --
 826       ---------
 827
 828       procedure Put_Name_Buffer is
 829          Last : Natural;
 830
 831       begin
 832          Name_Len := Name_Len + 1;
 833          Name_Buffer (Name_Len) := ASCII.LF;
 834          Last := Write (File, Name_Buffer (1)'Address, Name_Len);
 835
 836          if Last /= Name_Len then
 837             Prj.Com.Fail ("Disk full, cannot write mapping file");
 838          end if;
 839       end Put_Name_Buffer;
 840
 841       --------------
 842       -- Put_Data --
 843       --------------
 844
 845       procedure Put_Data (Spec : Boolean) is
 846       begin
 847          --  Line with the unit name
 848
 849          Get_Name_String (The_Unit_Data.Name);
 850          Name_Len := Name_Len + 1;
 851          Name_Buffer (Name_Len) := '%';
 852          Name_Len := Name_Len + 1;
 853
 854          if Spec then
 855             Name_Buffer (Name_Len) := 's';
 856          else
 857             Name_Buffer (Name_Len) := 'b';
 858          end if;
 859
 860          Put_Name_Buffer;
 861
 862          --  Line with the file name
 863
 864          Get_Name_String (Data.Name);
 865          Put_Name_Buffer;
 866
 867          --  Line with the path name
 868
 869          Get_Name_String (Data.Path.Name);
 870          Put_Name_Buffer;
 871       end Put_Data;
 872
 873       --------------------
 874       -- Recursive_Flag --
 875       --------------------
 876
 877       procedure Recursive_Flag (Prj : Project_Id) is
 878          Imported : Project_List;
 879
 880       begin
 881          --  Nothing to do for non existent project or project that has already
 882          --  been flagged.
 883
 884          if Prj /= No_Project
 885            and then not Project_Boolean_Htable.Get (Present, Prj)
 886          then
 887             Project_Boolean_Htable.Set (Present, Prj, True);
 888
 889             Imported := Prj.Imported_Projects;
 890             while Imported /= null loop
 891                Recursive_Flag (Imported.Project);
 892                Imported := Imported.Next;
 893             end loop;
 894
 895             Recursive_Flag (Prj.Extends);
 896          end if;
 897       end Recursive_Flag;
 898
 899    --  Start of processing for Create_Mapping_File
 900
 901    begin
 902       --  Flag the necessary projects
 903
 904       Recursive_Flag (Project);
 905
 906       --  Create the temporary file
 907
 908       Tempdir.Create_Temp_File (File, Name => Name);
 909
 910       if File = Invalid_FD then
 911          Prj.Com.Fail ("unable to create temporary mapping file");
 912
 913       else
 914          Record_Temp_File (Name);
 915
 916          if Opt.Verbose_Mode then
 917             Write_Str ("Creating temp mapping file """);
 918             Write_Str (Get_Name_String (Name));
 919             Write_Line ("""");
 920          end if;
 921       end if;
 922
 923       if Language = No_Name then
 924          if In_Tree.Private_Part.Fill_Mapping_File then
 925             for Unit in 1 .. Unit_Table.Last (In_Tree.Units) loop
 926                The_Unit_Data := In_Tree.Units.Table (Unit);
 927
 928                --  Case of unit has a valid name
 929
 930                if The_Unit_Data.Name /= No_Name then
 931                   Data := The_Unit_Data.File_Names (Specification);
 932
 933                   --  If there is a spec, put it mapping in the file if it is
 934                   --  from a project in the closure of Project.
 935
 936                   if Data.Name /= No_File
 937                     and then Project_Boolean_Htable.Get (Present, Data.Project)
 938                   then
 939                      Put_Data (Spec => True);
 940                   end if;
 941
 942                   Data := The_Unit_Data.File_Names (Body_Part);
 943
 944                   --  If there is a body (or subunit) put its mapping in the
 945                   --  file if it is from a project in the closure of Project.
 946
 947                   if Data.Name /= No_File
 948                     and then Project_Boolean_Htable.Get (Present, Data.Project)
 949                   then
 950                      Put_Data (Spec => False);
 951                   end if;
 952                end if;
 953             end loop;
 954          end if;
 955
 956       --  If language is defined
 957
 958       else
 959          --  For all source of the Language of all projects in the closure
 960
 961          declare
 962             P : Project_List;
 963
 964          begin
 965             P := In_Tree.Projects;
 966             while P /= null loop
 967                if Project_Boolean_Htable.Get (Present, P.Project) then
 968
 969                   Iter := For_Each_Source (In_Tree, P.Project);
 970                   loop
 971                      Source := Prj.Element (Iter);
 972                      exit when Source = No_Source;
 973
 974                      if Source.Language.Name = Language
 975                        and then not Source.Locally_Removed
 976                        and then Source.Replaced_By = No_Source
 977                        and then Source.Path.Name /= No_Path
 978                      then
 979                         if Source.Unit /= No_Name then
 980                            Get_Name_String (Source.Unit);
 981
 982                            if Source.Kind = Spec then
 983                               Suffix :=
 984                                 Source.Language.Config.Mapping_Spec_Suffix;
 985                            else
 986                               Suffix :=
 987                                 Source.Language.Config.Mapping_Body_Suffix;
 988                            end if;
 989
 990                            if Suffix /= No_File then
 991                               Add_Str_To_Name_Buffer
 992                                 (Get_Name_String (Suffix));
 993                            end if;
 994
 995                            Put_Name_Buffer;
 996                         end if;
 997
 998                         Get_Name_String (Source.File);
 999                         Put_Name_Buffer;
1000
1001                         Get_Name_String (Source.Path.Name);
1002                         Put_Name_Buffer;
1003                      end if;
1004
1005                      Next (Iter);
1006                   end loop;
1007                end if;
1008
1009                P := P.Next;
1010             end loop;
1011          end;
1012       end if;
1013
1014       GNAT.OS_Lib.Close (File, Status);
1015
1016       if not Status then
1017
1018          --  We were able to create the temporary file, so there is no problem
1019          --  of protection. However, we are not able to close it, so there must
1020          --  be a capacity problem that we express using "disk full".
1021
1022          Prj.Com.Fail ("disk full, could not write mapping file");
1023       end if;
1024
1025       Project_Boolean_Htable.Reset (Present);
1026    end Create_Mapping_File;
1027
1028    --------------------------
1029    -- Create_New_Path_File --
1030    --------------------------
1031
1032    procedure Create_New_Path_File
1033      (In_Tree   : Project_Tree_Ref;
1034       Path_FD   : out File_Descriptor;
1035       Path_Name : out Path_Name_Type)
1036    is
1037    begin
1038       Tempdir.Create_Temp_File (Path_FD, Path_Name);
1039
1040       if Path_Name /= No_Path then
1041          Record_Temp_File (Path_Name);
1042
1043          --  Record the name, so that the temp path file will be deleted at the
1044          --  end of the program.
1045
1046          Path_File_Table.Increment_Last (In_Tree.Private_Part.Path_Files);
1047          In_Tree.Private_Part.Path_Files.Table
1048            (Path_File_Table.Last (In_Tree.Private_Part.Path_Files)) :=
1049               Path_Name;
1050       end if;
1051    end Create_New_Path_File;
1052
1053    ---------------------------
1054    -- Delete_All_Path_Files --
1055    ---------------------------
1056
1057    procedure Delete_All_Path_Files (In_Tree : Project_Tree_Ref) is
1058       Disregard : Boolean := True;
1059       pragma Unreferenced (Disregard);
1060
1061    begin
1062       for Index in Path_File_Table.First ..
1063                    Path_File_Table.Last (In_Tree.Private_Part.Path_Files)
1064       loop
1065          if In_Tree.Private_Part.Path_Files.Table (Index) /= No_Path then
1066             Delete_File
1067               (Get_Name_String
1068                  (In_Tree.Private_Part.Path_Files.Table (Index)),
1069                Disregard);
1070          end if;
1071       end loop;
1072
1073       --  If any of the environment variables ADA_PRJ_INCLUDE_FILE or
1074       --  ADA_PRJ_OBJECTS_FILE has been set, then reset their value to
1075       --  the empty string. On VMS, this has the effect of deassigning
1076       --  the logical names.
1077
1078       if In_Tree.Private_Part.Ada_Prj_Include_File_Set then
1079          Setenv (Project_Include_Path_File, "");
1080          In_Tree.Private_Part.Ada_Prj_Include_File_Set := False;
1081       end if;
1082
1083       if In_Tree.Private_Part.Ada_Prj_Objects_File_Set then
1084          Setenv (Project_Objects_Path_File, "");
1085          In_Tree.Private_Part.Ada_Prj_Objects_File_Set := False;
1086       end if;
1087    end Delete_All_Path_Files;
1088
1089    ------------------------------------
1090    -- File_Name_Of_Library_Unit_Body --
1091    ------------------------------------
1092
1093    function File_Name_Of_Library_Unit_Body
1094      (Name              : String;
1095       Project           : Project_Id;
1096       In_Tree           : Project_Tree_Ref;
1097       Main_Project_Only : Boolean := True;
1098       Full_Path         : Boolean := False) return String
1099    is
1100       The_Project   : Project_Id := Project;
1101       Original_Name : String := Name;
1102
1103       Extended_Spec_Name : String :=
1104                              Name &
1105                              Spec_Suffix_Of (In_Tree, "ada", Project.Naming);
1106       Extended_Body_Name : String :=
1107                              Name &
1108                              Body_Suffix_Of (In_Tree, "ada", Project.Naming);
1109
1110       Unit : Unit_Data;
1111
1112       The_Original_Name : Name_Id;
1113       The_Spec_Name     : Name_Id;
1114       The_Body_Name     : Name_Id;
1115
1116    begin
1117       Canonical_Case_File_Name (Original_Name);
1118       Name_Len := Original_Name'Length;
1119       Name_Buffer (1 .. Name_Len) := Original_Name;
1120       The_Original_Name := Name_Find;
1121
1122       Canonical_Case_File_Name (Extended_Spec_Name);
1123       Name_Len := Extended_Spec_Name'Length;
1124       Name_Buffer (1 .. Name_Len) := Extended_Spec_Name;
1125       The_Spec_Name := Name_Find;
1126
1127       Canonical_Case_File_Name (Extended_Body_Name);
1128       Name_Len := Extended_Body_Name'Length;
1129       Name_Buffer (1 .. Name_Len) := Extended_Body_Name;
1130       The_Body_Name := Name_Find;
1131
1132       if Current_Verbosity = High then
1133          Write_Str  ("Looking for file name of """);
1134          Write_Str  (Name);
1135          Write_Char ('"');
1136          Write_Eol;
1137          Write_Str  ("   Extended Spec Name = """);
1138          Write_Str  (Extended_Spec_Name);
1139          Write_Char ('"');
1140          Write_Eol;
1141          Write_Str  ("   Extended Body Name = """);
1142          Write_Str  (Extended_Body_Name);
1143          Write_Char ('"');
1144          Write_Eol;
1145       end if;
1146
1147       --  For extending project, search in the extended project if the source
1148       --  is not found. For non extending projects, this loop will be run only
1149       --  once.
1150
1151       loop
1152          --  Loop through units
1153          --  Should have comment explaining reverse ???
1154
1155          for Current in reverse Unit_Table.First ..
1156                                 Unit_Table.Last (In_Tree.Units)
1157          loop
1158             Unit := In_Tree.Units.Table (Current);
1159
1160             --  Check for body
1161
1162             if not Main_Project_Only
1163               or else Unit.File_Names (Body_Part).Project = The_Project
1164             then
1165                declare
1166                   Current_Name : constant File_Name_Type :=
1167                                    Unit.File_Names (Body_Part).Name;
1168
1169                begin
1170                   --  Case of a body present
1171
1172                   if Current_Name /= No_File then
1173                      if Current_Verbosity = High then
1174                         Write_Str  ("   Comparing with """);
1175                         Write_Str  (Get_Name_String (Current_Name));
1176                         Write_Char ('"');
1177                         Write_Eol;
1178                      end if;
1179
1180                      --  If it has the name of the original name, return the
1181                      --  original name.
1182
1183                      if Unit.Name = The_Original_Name
1184                        or else
1185                          Current_Name = File_Name_Type (The_Original_Name)
1186                      then
1187                         if Current_Verbosity = High then
1188                            Write_Line ("   OK");
1189                         end if;
1190
1191                         if Full_Path then
1192                            return Get_Name_String
1193                              (Unit.File_Names (Body_Part).Path.Name);
1194
1195                         else
1196                            return Get_Name_String (Current_Name);
1197                         end if;
1198
1199                         --  If it has the name of the extended body name,
1200                         --  return the extended body name
1201
1202                      elsif Current_Name = File_Name_Type (The_Body_Name) then
1203                         if Current_Verbosity = High then
1204                            Write_Line ("   OK");
1205                         end if;
1206
1207                         if Full_Path then
1208                            return Get_Name_String
1209                              (Unit.File_Names (Body_Part).Path.Name);
1210
1211                         else
1212                            return Extended_Body_Name;
1213                         end if;
1214
1215                      else
1216                         if Current_Verbosity = High then
1217                            Write_Line ("   not good");
1218                         end if;
1219                      end if;
1220                   end if;
1221                end;
1222             end if;
1223
1224             --  Check for spec
1225
1226             if not Main_Project_Only
1227               or else Unit.File_Names (Specification).Project = The_Project
1228             then
1229                declare
1230                   Current_Name : constant File_Name_Type :=
1231                                    Unit.File_Names (Specification).Name;
1232
1233                begin
1234                   --  Case of spec present
1235
1236                   if Current_Name /= No_File then
1237                      if Current_Verbosity = High then
1238                         Write_Str  ("   Comparing with """);
1239                         Write_Str  (Get_Name_String (Current_Name));
1240                         Write_Char ('"');
1241                         Write_Eol;
1242                      end if;
1243
1244                      --  If name same as original name, return original name
1245
1246                      if Unit.Name = The_Original_Name
1247                        or else
1248                          Current_Name = File_Name_Type (The_Original_Name)
1249                      then
1250                         if Current_Verbosity = High then
1251                            Write_Line ("   OK");
1252                         end if;
1253
1254                         if Full_Path then
1255                            return Get_Name_String
1256                              (Unit.File_Names (Specification).Path.Name);
1257                         else
1258                            return Get_Name_String (Current_Name);
1259                         end if;
1260
1261                         --  If it has the same name as the extended spec name,
1262                         --  return the extended spec name.
1263
1264                      elsif Current_Name = File_Name_Type (The_Spec_Name) then
1265                         if Current_Verbosity = High then
1266                            Write_Line ("   OK");
1267                         end if;
1268
1269                         if Full_Path then
1270                            return Get_Name_String
1271                              (Unit.File_Names (Specification).Path.Name);
1272                         else
1273                            return Extended_Spec_Name;
1274                         end if;
1275
1276                      else
1277                         if Current_Verbosity = High then
1278                            Write_Line ("   not good");
1279                         end if;
1280                      end if;
1281                   end if;
1282                end;
1283             end if;
1284          end loop;
1285
1286          --  If we are not in an extending project, give up
1287
1288          exit when not Main_Project_Only
1289            or else The_Project.Extends = No_Project;
1290
1291          --  Otherwise, look in the project we are extending
1292
1293          The_Project := The_Project.Extends;
1294       end loop;
1295
1296       --  We don't know this file name, return an empty string
1297
1298       return "";
1299    end File_Name_Of_Library_Unit_Body;
1300
1301    -------------------------
1302    -- For_All_Object_Dirs --
1303    -------------------------
1304
1305    procedure For_All_Object_Dirs (Project : Project_Id) is
1306       procedure For_Project (Prj : Project_Id; Dummy : in out Integer);
1307       --  Get all object directories of Prj
1308
1309       -----------------
1310       -- For_Project --
1311       -----------------
1312
1313       procedure For_Project (Prj : Project_Id; Dummy : in out Integer) is
1314          pragma Unreferenced (Dummy);
1315       begin
1316          --  ??? Set_Ada_Paths has a different behavior for library project
1317          --  files, should we have the same ?
1318
1319          if Prj.Object_Directory /= No_Path_Information then
1320             Get_Name_String (Prj.Object_Directory.Display_Name);
1321             Action (Name_Buffer (1 .. Name_Len));
1322          end if;
1323       end For_Project;
1324
1325       procedure Get_Object_Dirs is
1326         new For_Every_Project_Imported (Integer, For_Project);
1327       Dummy : Integer := 1;
1328
1329    --  Start of processing for For_All_Object_Dirs
1330
1331    begin
1332       Get_Object_Dirs (Project, Dummy);
1333    end For_All_Object_Dirs;
1334
1335    -------------------------
1336    -- For_All_Source_Dirs --
1337    -------------------------
1338
1339    procedure For_All_Source_Dirs
1340      (Project : Project_Id;
1341       In_Tree : Project_Tree_Ref)
1342    is
1343       procedure For_Project (Prj : Project_Id; Dummy : in out Integer);
1344       --  Get all object directories of Prj
1345
1346       -----------------
1347       -- For_Project --
1348       -----------------
1349
1350       procedure For_Project (Prj : Project_Id; Dummy : in out Integer) is
1351          pragma Unreferenced (Dummy);
1352          Current    : String_List_Id := Prj.Source_Dirs;
1353          The_String : String_Element;
1354
1355       begin
1356          --  If there are Ada sources, call action with the name of every
1357          --  source directory.
1358
1359          if Has_Ada_Sources (Project) then
1360             while Current /= Nil_String loop
1361                The_String := In_Tree.String_Elements.Table (Current);
1362                Action (Get_Name_String (The_String.Display_Value));
1363                Current := The_String.Next;
1364             end loop;
1365          end if;
1366       end For_Project;
1367
1368       procedure Get_Source_Dirs is
1369         new For_Every_Project_Imported (Integer, For_Project);
1370       Dummy : Integer := 1;
1371
1372    --  Start of processing for For_All_Source_Dirs
1373
1374    begin
1375       Get_Source_Dirs (Project, Dummy);
1376    end For_All_Source_Dirs;
1377
1378    -------------------
1379    -- Get_Reference --
1380    -------------------
1381
1382    procedure Get_Reference
1383      (Source_File_Name : String;
1384       In_Tree          : Project_Tree_Ref;
1385       Project          : out Project_Id;
1386       Path             : out Path_Name_Type)
1387    is
1388    begin
1389       --  Body below could use some comments ???
1390
1391       if Current_Verbosity > Default then
1392          Write_Str ("Getting Reference_Of (""");
1393          Write_Str (Source_File_Name);
1394          Write_Str (""") ... ");
1395       end if;
1396
1397       declare
1398          Original_Name : String := Source_File_Name;
1399          Unit          : Unit_Data;
1400
1401       begin
1402          Canonical_Case_File_Name (Original_Name);
1403
1404          for Id in Unit_Table.First ..
1405                    Unit_Table.Last (In_Tree.Units)
1406          loop
1407             Unit := In_Tree.Units.Table (Id);
1408
1409             if (Unit.File_Names (Specification).Name /= No_File
1410                  and then
1411                    Namet.Get_Name_String
1412                      (Unit.File_Names (Specification).Name) = Original_Name)
1413               or else (Unit.File_Names (Specification).Path /=
1414                                                          No_Path_Information
1415                          and then
1416                            Namet.Get_Name_String
1417                            (Unit.File_Names (Specification).Path.Name) =
1418                                                               Original_Name)
1419             then
1420                Project := Ultimate_Extension_Of
1421                           (Project => Unit.File_Names (Specification).Project);
1422                Path := Unit.File_Names (Specification).Path.Display_Name;
1423
1424                if Current_Verbosity > Default then
1425                   Write_Str ("Done: Specification.");
1426                   Write_Eol;
1427                end if;
1428
1429                return;
1430
1431             elsif (Unit.File_Names (Body_Part).Name /= No_File
1432                     and then
1433                       Namet.Get_Name_String
1434                         (Unit.File_Names (Body_Part).Name) = Original_Name)
1435               or else (Unit.File_Names (Body_Part).Path /= No_Path_Information
1436                          and then Namet.Get_Name_String
1437                                     (Unit.File_Names (Body_Part).Path.Name) =
1438                                                              Original_Name)
1439             then
1440                Project := Ultimate_Extension_Of
1441                             (Project => Unit.File_Names (Body_Part).Project);
1442                Path := Unit.File_Names (Body_Part).Path.Display_Name;
1443
1444                if Current_Verbosity > Default then
1445                   Write_Str ("Done: Body.");
1446                   Write_Eol;
1447                end if;
1448
1449                return;
1450             end if;
1451          end loop;
1452       end;
1453
1454       Project := No_Project;
1455       Path    := No_Path;
1456
1457       if Current_Verbosity > Default then
1458          Write_Str ("Cannot be found.");
1459          Write_Eol;
1460       end if;
1461    end Get_Reference;
1462
1463    ----------------
1464    -- Initialize --
1465    ----------------
1466
1467    procedure Initialize (In_Tree : Project_Tree_Ref) is
1468    begin
1469       In_Tree.Private_Part.Fill_Mapping_File := True;
1470       In_Tree.Private_Part.Current_Source_Path_File := No_Path;
1471       In_Tree.Private_Part.Current_Object_Path_File := No_Path;
1472    end Initialize;
1473
1474    -------------------
1475    -- Print_Sources --
1476    -------------------
1477
1478    --  Could use some comments in this body ???
1479
1480    procedure Print_Sources (In_Tree : Project_Tree_Ref) is
1481       Unit : Unit_Data;
1482
1483    begin
1484       Write_Line ("List of Sources:");
1485
1486       for Id in Unit_Table.First ..
1487                 Unit_Table.Last (In_Tree.Units)
1488       loop
1489          Unit := In_Tree.Units.Table (Id);
1490          Write_Str  ("   ");
1491          Write_Line (Namet.Get_Name_String (Unit.Name));
1492
1493          if Unit.File_Names (Specification).Name /= No_File then
1494             if Unit.File_Names (Specification).Project = No_Project then
1495                Write_Line ("   No project");
1496
1497             else
1498                Write_Str  ("   Project: ");
1499                Get_Name_String
1500                  (Unit.File_Names (Specification).Project.Path.Name);
1501                Write_Line (Name_Buffer (1 .. Name_Len));
1502             end if;
1503
1504             Write_Str  ("      spec: ");
1505             Write_Line
1506               (Namet.Get_Name_String
1507                (Unit.File_Names (Specification).Name));
1508          end if;
1509
1510          if Unit.File_Names (Body_Part).Name /= No_File then
1511             if Unit.File_Names (Body_Part).Project = No_Project then
1512                Write_Line ("   No project");
1513
1514             else
1515                Write_Str  ("   Project: ");
1516                Get_Name_String
1517                  (Unit.File_Names (Body_Part).Project.Path.Name);
1518                Write_Line (Name_Buffer (1 .. Name_Len));
1519             end if;
1520
1521             Write_Str  ("      body: ");
1522             Write_Line
1523               (Namet.Get_Name_String
1524                (Unit.File_Names (Body_Part).Name));
1525          end if;
1526       end loop;
1527
1528       Write_Line ("end of List of Sources.");
1529    end Print_Sources;
1530
1531    ----------------
1532    -- Project_Of --
1533    ----------------
1534
1535    function Project_Of
1536      (Name         : String;
1537       Main_Project : Project_Id;
1538       In_Tree      : Project_Tree_Ref) return Project_Id
1539    is
1540       Result : Project_Id := No_Project;
1541
1542       Original_Name : String := Name;
1543
1544       Extended_Spec_Name : String :=
1545         Name & Spec_Suffix_Of (In_Tree, "ada", Main_Project.Naming);
1546       Extended_Body_Name : String :=
1547         Name & Body_Suffix_Of (In_Tree, "ada", Main_Project.Naming);
1548
1549       Unit : Unit_Data;
1550
1551       Current_Name      : File_Name_Type;
1552       The_Original_Name : File_Name_Type;
1553       The_Spec_Name     : File_Name_Type;
1554       The_Body_Name     : File_Name_Type;
1555
1556    begin
1557       Canonical_Case_File_Name (Original_Name);
1558       Name_Len := Original_Name'Length;
1559       Name_Buffer (1 .. Name_Len) := Original_Name;
1560       The_Original_Name := Name_Find;
1561
1562       Canonical_Case_File_Name (Extended_Spec_Name);
1563       Name_Len := Extended_Spec_Name'Length;
1564       Name_Buffer (1 .. Name_Len) := Extended_Spec_Name;
1565       The_Spec_Name := Name_Find;
1566
1567       Canonical_Case_File_Name (Extended_Body_Name);
1568       Name_Len := Extended_Body_Name'Length;
1569       Name_Buffer (1 .. Name_Len) := Extended_Body_Name;
1570       The_Body_Name := Name_Find;
1571
1572       for Current in reverse Unit_Table.First ..
1573                              Unit_Table.Last (In_Tree.Units)
1574       loop
1575          Unit := In_Tree.Units.Table (Current);
1576
1577          --  Check for body
1578
1579          Current_Name := Unit.File_Names (Body_Part).Name;
1580
1581          --  Case of a body present
1582
1583          if Current_Name /= No_File then
1584
1585             --  If it has the name of the original name or the body name,
1586             --  we have found the project.
1587
1588             if Unit.Name = Name_Id (The_Original_Name)
1589               or else Current_Name = The_Original_Name
1590               or else Current_Name = The_Body_Name
1591             then
1592                Result := Unit.File_Names (Body_Part).Project;
1593                exit;
1594             end if;
1595          end if;
1596
1597          --  Check for spec
1598
1599          Current_Name := Unit.File_Names (Specification).Name;
1600
1601          if Current_Name /= No_File then
1602
1603             --  If name same as the original name, or the spec name, we have
1604             --  found the project.
1605
1606             if Unit.Name = Name_Id (The_Original_Name)
1607               or else Current_Name = The_Original_Name
1608               or else Current_Name = The_Spec_Name
1609             then
1610                Result := Unit.File_Names (Specification).Project;
1611                exit;
1612             end if;
1613          end if;
1614       end loop;
1615
1616       --  Get the ultimate extending project
1617
1618       if Result /= No_Project then
1619          while Result.Extended_By /= No_Project loop
1620             Result := Result.Extended_By;
1621          end loop;
1622       end if;
1623
1624       return Result;
1625    end Project_Of;
1626
1627    -------------------
1628    -- Set_Ada_Paths --
1629    -------------------
1630
1631    procedure Set_Ada_Paths
1632      (Project             : Project_Id;
1633       In_Tree             : Project_Tree_Ref;
1634       Including_Libraries : Boolean)
1635
1636    is
1637       Source_FD : File_Descriptor := Invalid_FD;
1638       Object_FD : File_Descriptor := Invalid_FD;
1639
1640       Process_Source_Dirs : Boolean := False;
1641       Process_Object_Dirs : Boolean := False;
1642
1643       Status : Boolean;
1644       --  For calls to Close
1645
1646       Len : Natural;
1647
1648       procedure Recursive_Add (Project : Project_Id; Dummy : in out Boolean);
1649       --  Recursive procedure to add the source/object paths of extended/
1650       --  imported projects.
1651
1652       -------------------
1653       -- Recursive_Add --
1654       -------------------
1655
1656       procedure Recursive_Add (Project : Project_Id; Dummy : in out Boolean) is
1657          pragma Unreferenced (Dummy);
1658
1659          Path : Path_Name_Type;
1660
1661       begin
1662          --  ??? This is almost the equivalent of For_All_Source_Dirs
1663
1664          if Process_Source_Dirs then
1665
1666             --  Add to path all source directories of this project if there are
1667             --  Ada sources.
1668
1669             if Has_Ada_Sources (Project) then
1670                Add_To_Source_Path (Project.Source_Dirs, In_Tree);
1671             end if;
1672          end if;
1673
1674          if Process_Object_Dirs then
1675             Path := Get_Object_Directory
1676               (Project,
1677                Including_Libraries => Including_Libraries,
1678                Only_If_Ada         => True);
1679
1680             if Path /= No_Path then
1681                Add_To_Object_Path (Path, In_Tree);
1682             end if;
1683          end if;
1684       end Recursive_Add;
1685
1686       procedure For_All_Projects is
1687         new For_Every_Project_Imported (Boolean, Recursive_Add);
1688       Dummy : Boolean := False;
1689
1690    --  Start of processing for Set_Ada_Paths
1691
1692    begin
1693       --  If it is the first time we call this procedure for this project,
1694       --  compute the source path and/or the object path.
1695
1696       if Project.Include_Path_File = No_Path then
1697          Process_Source_Dirs := True;
1698          Create_New_Path_File
1699            (In_Tree, Source_FD, Project.Include_Path_File);
1700       end if;
1701
1702       --  For the object path, we make a distinction depending on
1703       --  Including_Libraries.
1704
1705       if Including_Libraries then
1706          if Project.Objects_Path_File_With_Libs = No_Path then
1707             Process_Object_Dirs := True;
1708             Create_New_Path_File
1709               (In_Tree, Object_FD, Project.Objects_Path_File_With_Libs);
1710          end if;
1711
1712       else
1713          if Project.Objects_Path_File_Without_Libs = No_Path then
1714             Process_Object_Dirs := True;
1715             Create_New_Path_File
1716               (In_Tree, Object_FD, Project.Objects_Path_File_Without_Libs);
1717          end if;
1718       end if;
1719
1720       --  If there is something to do, set Seen to False for all projects,
1721       --  then call the recursive procedure Add for Project.
1722
1723       if Process_Source_Dirs or Process_Object_Dirs then
1724          Source_Path_Table.Set_Last (In_Tree.Private_Part.Source_Paths, 0);
1725          Object_Path_Table.Set_Last (In_Tree.Private_Part.Object_Paths, 0);
1726          For_All_Projects (Project, Dummy);
1727       end if;
1728
1729       --  Write and close any file that has been created
1730
1731       if Source_FD /= Invalid_FD then
1732          for Index in Source_Path_Table.First ..
1733                       Source_Path_Table.Last
1734                         (In_Tree.Private_Part.Source_Paths)
1735          loop
1736             Get_Name_String (In_Tree.Private_Part.Source_Paths.Table (Index));
1737             Name_Len := Name_Len + 1;
1738             Name_Buffer (Name_Len) := ASCII.LF;
1739             Len := Write (Source_FD, Name_Buffer (1)'Address, Name_Len);
1740
1741             if Len /= Name_Len then
1742                Prj.Com.Fail ("disk full");
1743             end if;
1744          end loop;
1745
1746          Close (Source_FD, Status);
1747
1748          if not Status then
1749             Prj.Com.Fail ("disk full");
1750          end if;
1751       end if;
1752
1753       if Object_FD /= Invalid_FD then
1754          for Index in Object_Path_Table.First ..
1755                       Object_Path_Table.Last
1756                         (In_Tree.Private_Part.Object_Paths)
1757          loop
1758             Get_Name_String (In_Tree.Private_Part.Object_Paths.Table (Index));
1759             Name_Len := Name_Len + 1;
1760             Name_Buffer (Name_Len) := ASCII.LF;
1761             Len := Write (Object_FD, Name_Buffer (1)'Address, Name_Len);
1762
1763             if Len /= Name_Len then
1764                Prj.Com.Fail ("disk full");
1765             end if;
1766          end loop;
1767
1768          Close (Object_FD, Status);
1769
1770          if not Status then
1771             Prj.Com.Fail ("disk full");
1772          end if;
1773       end if;
1774
1775       --  Set the env vars, if they need to be changed, and set the
1776       --  corresponding flags.
1777
1778       if In_Tree.Private_Part.Current_Source_Path_File /=
1779            Project.Include_Path_File
1780       then
1781          In_Tree.Private_Part.Current_Source_Path_File :=
1782            Project.Include_Path_File;
1783          Set_Path_File_Var
1784            (Project_Include_Path_File,
1785             Get_Name_String (In_Tree.Private_Part.Current_Source_Path_File));
1786          In_Tree.Private_Part.Ada_Prj_Include_File_Set := True;
1787       end if;
1788
1789       if Including_Libraries then
1790          if In_Tree.Private_Part.Current_Object_Path_File /=
1791             Project.Objects_Path_File_With_Libs
1792          then
1793             In_Tree.Private_Part.Current_Object_Path_File :=
1794               Project.Objects_Path_File_With_Libs;
1795             Set_Path_File_Var
1796               (Project_Objects_Path_File,
1797                Get_Name_String
1798                  (In_Tree.Private_Part.Current_Object_Path_File));
1799             In_Tree.Private_Part.Ada_Prj_Objects_File_Set := True;
1800          end if;
1801
1802       else
1803          if In_Tree.Private_Part.Current_Object_Path_File /=
1804             Project.Objects_Path_File_Without_Libs
1805          then
1806             In_Tree.Private_Part.Current_Object_Path_File :=
1807               Project.Objects_Path_File_Without_Libs;
1808             Set_Path_File_Var
1809               (Project_Objects_Path_File,
1810                Get_Name_String
1811                  (In_Tree.Private_Part.Current_Object_Path_File));
1812             In_Tree.Private_Part.Ada_Prj_Objects_File_Set := True;
1813          end if;
1814       end if;
1815    end Set_Ada_Paths;
1816
1817    ---------------------------------------------
1818    -- Set_Mapping_File_Initial_State_To_Empty --
1819    ---------------------------------------------
1820
1821    procedure Set_Mapping_File_Initial_State_To_Empty
1822      (In_Tree : Project_Tree_Ref)
1823    is
1824    begin
1825       In_Tree.Private_Part.Fill_Mapping_File := False;
1826    end Set_Mapping_File_Initial_State_To_Empty;
1827
1828    -----------------------
1829    -- Set_Path_File_Var --
1830    -----------------------
1831
1832    procedure Set_Path_File_Var (Name : String; Value : String) is
1833       Host_Spec : String_Access := To_Host_File_Spec (Value);
1834    begin
1835       if Host_Spec = null then
1836          Prj.Com.Fail
1837            ("could not convert file name """ & Value & """ to host spec");
1838       else
1839          Setenv (Name, Host_Spec.all);
1840          Free (Host_Spec);
1841       end if;
1842    end Set_Path_File_Var;
1843
1844    ---------------------------
1845    -- Ultimate_Extension_Of --
1846    ---------------------------
1847
1848    function Ultimate_Extension_Of
1849      (Project : Project_Id) return Project_Id
1850    is
1851       Result : Project_Id;
1852
1853    begin
1854       Result := Project;
1855       while Result.Extended_By /= No_Project loop
1856          Result := Result.Extended_By;
1857       end loop;
1858
1859       return Result;
1860    end Ultimate_Extension_Of;
1861
1862 end Prj.Env;