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       else
 958          --  For all source of the Language of all projects in the closure
 959
 960          declare
 961             P : Project_List;
 962          begin
 963             P := In_Tree.Projects;
 964             while P /= null loop
 965                if Project_Boolean_Htable.Get (Present, P.Project) then
 966
 967                   Iter := For_Each_Source (In_Tree, P.Project);
 968                   loop
 969                      Source := Prj.Element (Iter);
 970                      exit when Source = No_Source;
 971
 972                      if Source.Language.Name = Language
 973                        and then not Source.Locally_Removed
 974                        and then Source.Replaced_By = No_Source
 975                        and then Source.Path.Name /= No_Path
 976                      then
 977                         if Source.Unit /= No_Name then
 978                            Get_Name_String (Source.Unit);
 979
 980                            if Source.Kind = Spec then
 981                               Suffix :=
 982                                 Source.Language.Config.Mapping_Spec_Suffix;
 983                            else
 984                               Suffix :=
 985                                 Source.Language.Config.Mapping_Body_Suffix;
 986                            end if;
 987
 988                            if Suffix /= No_File then
 989                               Add_Str_To_Name_Buffer
 990                                 (Get_Name_String (Suffix));
 991                            end if;
 992
 993                            Put_Name_Buffer;
 994                         end if;
 995
 996                         Get_Name_String (Source.File);
 997                         Put_Name_Buffer;
 998
 999                         Get_Name_String (Source.Path.Name);
1000                         Put_Name_Buffer;
1001                      end if;
1002
1003                      Next (Iter);
1004                   end loop;
1005                end if;
1006
1007                P := P.Next;
1008             end loop;
1009          end;
1010       end if;
1011
1012       GNAT.OS_Lib.Close (File, Status);
1013
1014       if not Status then
1015
1016          --  We were able to create the temporary file, so there is no problem
1017          --  of protection. However, we are not able to close it, so there must
1018          --  be a capacity problem that we express using "disk full".
1019
1020          Prj.Com.Fail ("disk full, could not write mapping file");
1021       end if;
1022
1023       Project_Boolean_Htable.Reset (Present);
1024    end Create_Mapping_File;
1025
1026    --------------------------
1027    -- Create_New_Path_File --
1028    --------------------------
1029
1030    procedure Create_New_Path_File
1031      (In_Tree   : Project_Tree_Ref;
1032       Path_FD   : out File_Descriptor;
1033       Path_Name : out Path_Name_Type)
1034    is
1035    begin
1036       Tempdir.Create_Temp_File (Path_FD, Path_Name);
1037
1038       if Path_Name /= No_Path then
1039          Record_Temp_File (Path_Name);
1040
1041          --  Record the name, so that the temp path file will be deleted at the
1042          --  end of the program.
1043
1044          Path_File_Table.Increment_Last (In_Tree.Private_Part.Path_Files);
1045          In_Tree.Private_Part.Path_Files.Table
1046            (Path_File_Table.Last (In_Tree.Private_Part.Path_Files)) :=
1047               Path_Name;
1048       end if;
1049    end Create_New_Path_File;
1050
1051    ---------------------------
1052    -- Delete_All_Path_Files --
1053    ---------------------------
1054
1055    procedure Delete_All_Path_Files (In_Tree : Project_Tree_Ref) is
1056       Disregard : Boolean := True;
1057       pragma Warnings (Off, Disregard);
1058
1059    begin
1060       for Index in Path_File_Table.First ..
1061                    Path_File_Table.Last (In_Tree.Private_Part.Path_Files)
1062       loop
1063          if In_Tree.Private_Part.Path_Files.Table (Index) /= No_Path then
1064             Delete_File
1065               (Get_Name_String
1066                  (In_Tree.Private_Part.Path_Files.Table (Index)),
1067                Disregard);
1068          end if;
1069       end loop;
1070
1071       --  If any of the environment variables ADA_PRJ_INCLUDE_FILE or
1072       --  ADA_PRJ_OBJECTS_FILE has been set, then reset their value to
1073       --  the empty string. On VMS, this has the effect of deassigning
1074       --  the logical names.
1075
1076       if In_Tree.Private_Part.Ada_Prj_Include_File_Set then
1077          Setenv (Project_Include_Path_File, "");
1078          In_Tree.Private_Part.Ada_Prj_Include_File_Set := False;
1079       end if;
1080
1081       if In_Tree.Private_Part.Ada_Prj_Objects_File_Set then
1082          Setenv (Project_Objects_Path_File, "");
1083          In_Tree.Private_Part.Ada_Prj_Objects_File_Set := False;
1084       end if;
1085    end Delete_All_Path_Files;
1086
1087    ------------------------------------
1088    -- File_Name_Of_Library_Unit_Body --
1089    ------------------------------------
1090
1091    function File_Name_Of_Library_Unit_Body
1092      (Name              : String;
1093       Project           : Project_Id;
1094       In_Tree           : Project_Tree_Ref;
1095       Main_Project_Only : Boolean := True;
1096       Full_Path         : Boolean := False) return String
1097    is
1098       The_Project   : Project_Id := Project;
1099       Original_Name : String := Name;
1100
1101       Extended_Spec_Name : String :=
1102                              Name &
1103                              Spec_Suffix_Of (In_Tree, "ada", Project.Naming);
1104       Extended_Body_Name : String :=
1105                              Name &
1106                              Body_Suffix_Of (In_Tree, "ada", Project.Naming);
1107
1108       Unit : Unit_Data;
1109
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          --  Should have comment explaining reverse ???
1152
1153          for Current in reverse Unit_Table.First ..
1154                                 Unit_Table.Last (In_Tree.Units)
1155          loop
1156             Unit := In_Tree.Units.Table (Current);
1157
1158             --  Check for body
1159
1160             if not Main_Project_Only
1161               or else Unit.File_Names (Body_Part).Project = The_Project
1162             then
1163                declare
1164                   Current_Name : constant File_Name_Type :=
1165                                    Unit.File_Names (Body_Part).Name;
1166
1167                begin
1168                   --  Case of a body present
1169
1170                   if Current_Name /= No_File then
1171                      if Current_Verbosity = High then
1172                         Write_Str  ("   Comparing with """);
1173                         Write_Str  (Get_Name_String (Current_Name));
1174                         Write_Char ('"');
1175                         Write_Eol;
1176                      end if;
1177
1178                      --  If it has the name of the original name, return the
1179                      --  original name.
1180
1181                      if Unit.Name = The_Original_Name
1182                        or else
1183                          Current_Name = File_Name_Type (The_Original_Name)
1184                      then
1185                         if Current_Verbosity = High then
1186                            Write_Line ("   OK");
1187                         end if;
1188
1189                         if Full_Path then
1190                            return Get_Name_String
1191                              (Unit.File_Names (Body_Part).Path.Name);
1192
1193                         else
1194                            return Get_Name_String (Current_Name);
1195                         end if;
1196
1197                         --  If it has the name of the extended body name,
1198                         --  return the extended body name
1199
1200                      elsif Current_Name = File_Name_Type (The_Body_Name) then
1201                         if Current_Verbosity = High then
1202                            Write_Line ("   OK");
1203                         end if;
1204
1205                         if Full_Path then
1206                            return Get_Name_String
1207                              (Unit.File_Names (Body_Part).Path.Name);
1208
1209                         else
1210                            return Extended_Body_Name;
1211                         end if;
1212
1213                      else
1214                         if Current_Verbosity = High then
1215                            Write_Line ("   not good");
1216                         end if;
1217                      end if;
1218                   end if;
1219                end;
1220             end if;
1221
1222             --  Check for spec
1223
1224             if not Main_Project_Only
1225               or else Unit.File_Names (Specification).Project = The_Project
1226             then
1227                declare
1228                   Current_Name : constant File_Name_Type :=
1229                                    Unit.File_Names (Specification).Name;
1230
1231                begin
1232                   --  Case of spec present
1233
1234                   if Current_Name /= No_File then
1235                      if Current_Verbosity = High then
1236                         Write_Str  ("   Comparing with """);
1237                         Write_Str  (Get_Name_String (Current_Name));
1238                         Write_Char ('"');
1239                         Write_Eol;
1240                      end if;
1241
1242                      --  If name same as original name, return original name
1243
1244                      if Unit.Name = The_Original_Name
1245                        or else
1246                          Current_Name = File_Name_Type (The_Original_Name)
1247                      then
1248                         if Current_Verbosity = High then
1249                            Write_Line ("   OK");
1250                         end if;
1251
1252                         if Full_Path then
1253                            return Get_Name_String
1254                              (Unit.File_Names (Specification).Path.Name);
1255                         else
1256                            return Get_Name_String (Current_Name);
1257                         end if;
1258
1259                         --  If it has the same name as the extended spec name,
1260                         --  return the extended spec name.
1261
1262                      elsif Current_Name = File_Name_Type (The_Spec_Name) then
1263                         if Current_Verbosity = High then
1264                            Write_Line ("   OK");
1265                         end if;
1266
1267                         if Full_Path then
1268                            return Get_Name_String
1269                              (Unit.File_Names (Specification).Path.Name);
1270                         else
1271                            return Extended_Spec_Name;
1272                         end if;
1273
1274                      else
1275                         if Current_Verbosity = High then
1276                            Write_Line ("   not good");
1277                         end if;
1278                      end if;
1279                   end if;
1280                end;
1281             end if;
1282          end loop;
1283
1284          --  If we are not in an extending project, give up
1285
1286          exit when not Main_Project_Only
1287            or else The_Project.Extends = No_Project;
1288
1289          --  Otherwise, look in the project we are extending
1290
1291          The_Project := The_Project.Extends;
1292       end loop;
1293
1294       --  We don't know this file name, return an empty string
1295
1296       return "";
1297    end File_Name_Of_Library_Unit_Body;
1298
1299    -------------------------
1300    -- For_All_Object_Dirs --
1301    -------------------------
1302
1303    procedure For_All_Object_Dirs (Project : Project_Id) is
1304       procedure For_Project (Prj : Project_Id; Dummy : in out Integer);
1305       --  Get all object directories of Prj
1306
1307       -----------------
1308       -- For_Project --
1309       -----------------
1310
1311       procedure For_Project (Prj : Project_Id; Dummy : in out Integer) is
1312          pragma Unreferenced (Dummy);
1313       begin
1314          --  ??? Set_Ada_Paths has a different behavior for library project
1315          --  files, should we have the same ?
1316
1317          if Prj.Object_Directory /= No_Path_Information then
1318             Get_Name_String (Prj.Object_Directory.Display_Name);
1319             Action (Name_Buffer (1 .. Name_Len));
1320          end if;
1321       end For_Project;
1322
1323       procedure Get_Object_Dirs is
1324         new For_Every_Project_Imported (Integer, For_Project);
1325       Dummy : Integer := 1;
1326
1327    --  Start of processing for For_All_Object_Dirs
1328
1329    begin
1330       Get_Object_Dirs (Project, Dummy);
1331    end For_All_Object_Dirs;
1332
1333    -------------------------
1334    -- For_All_Source_Dirs --
1335    -------------------------
1336
1337    procedure For_All_Source_Dirs
1338      (Project : Project_Id;
1339       In_Tree : Project_Tree_Ref)
1340    is
1341       procedure For_Project (Prj : Project_Id; Dummy : in out Integer);
1342       --  Get all object directories of Prj
1343
1344       -----------------
1345       -- For_Project --
1346       -----------------
1347
1348       procedure For_Project (Prj : Project_Id; Dummy : in out Integer) is
1349          pragma Unreferenced (Dummy);
1350          Current    : String_List_Id := Prj.Source_Dirs;
1351          The_String : String_Element;
1352
1353       begin
1354          --  If there are Ada sources, call action with the name of every
1355          --  source directory.
1356
1357          if Has_Ada_Sources (Project) then
1358             while Current /= Nil_String loop
1359                The_String := In_Tree.String_Elements.Table (Current);
1360                Action (Get_Name_String (The_String.Display_Value));
1361                Current := The_String.Next;
1362             end loop;
1363          end if;
1364       end For_Project;
1365
1366       procedure Get_Source_Dirs is
1367         new For_Every_Project_Imported (Integer, For_Project);
1368       Dummy : Integer := 1;
1369
1370    --  Start of processing for For_All_Source_Dirs
1371
1372    begin
1373       Get_Source_Dirs (Project, Dummy);
1374    end For_All_Source_Dirs;
1375
1376    -------------------
1377    -- Get_Reference --
1378    -------------------
1379
1380    procedure Get_Reference
1381      (Source_File_Name : String;
1382       In_Tree          : Project_Tree_Ref;
1383       Project          : out Project_Id;
1384       Path             : out Path_Name_Type)
1385    is
1386    begin
1387       --  Body below could use some comments ???
1388
1389       if Current_Verbosity > Default then
1390          Write_Str ("Getting Reference_Of (""");
1391          Write_Str (Source_File_Name);
1392          Write_Str (""") ... ");
1393       end if;
1394
1395       declare
1396          Original_Name : String := Source_File_Name;
1397          Unit          : Unit_Data;
1398
1399       begin
1400          Canonical_Case_File_Name (Original_Name);
1401
1402          for Id in Unit_Table.First ..
1403                    Unit_Table.Last (In_Tree.Units)
1404          loop
1405             Unit := In_Tree.Units.Table (Id);
1406
1407             if (Unit.File_Names (Specification).Name /= No_File
1408                  and then
1409                    Namet.Get_Name_String
1410                      (Unit.File_Names (Specification).Name) = Original_Name)
1411               or else (Unit.File_Names (Specification).Path /=
1412                                                          No_Path_Information
1413                          and then
1414                            Namet.Get_Name_String
1415                            (Unit.File_Names (Specification).Path.Name) =
1416                                                               Original_Name)
1417             then
1418                Project := Ultimate_Extension_Of
1419                           (Project => Unit.File_Names (Specification).Project);
1420                Path := Unit.File_Names (Specification).Path.Display_Name;
1421
1422                if Current_Verbosity > Default then
1423                   Write_Str ("Done: Specification.");
1424                   Write_Eol;
1425                end if;
1426
1427                return;
1428
1429             elsif (Unit.File_Names (Body_Part).Name /= No_File
1430                     and then
1431                       Namet.Get_Name_String
1432                         (Unit.File_Names (Body_Part).Name) = Original_Name)
1433               or else (Unit.File_Names (Body_Part).Path /= No_Path_Information
1434                          and then Namet.Get_Name_String
1435                                     (Unit.File_Names (Body_Part).Path.Name) =
1436                                                              Original_Name)
1437             then
1438                Project := Ultimate_Extension_Of
1439                             (Project => Unit.File_Names (Body_Part).Project);
1440                Path := Unit.File_Names (Body_Part).Path.Display_Name;
1441
1442                if Current_Verbosity > Default then
1443                   Write_Str ("Done: Body.");
1444                   Write_Eol;
1445                end if;
1446
1447                return;
1448             end if;
1449          end loop;
1450       end;
1451
1452       Project := No_Project;
1453       Path    := No_Path;
1454
1455       if Current_Verbosity > Default then
1456          Write_Str ("Cannot be found.");
1457          Write_Eol;
1458       end if;
1459    end Get_Reference;
1460
1461    ----------------
1462    -- Initialize --
1463    ----------------
1464
1465    procedure Initialize (In_Tree : Project_Tree_Ref) is
1466    begin
1467       In_Tree.Private_Part.Fill_Mapping_File := True;
1468       In_Tree.Private_Part.Current_Source_Path_File := No_Path;
1469       In_Tree.Private_Part.Current_Object_Path_File := No_Path;
1470    end Initialize;
1471
1472    -------------------
1473    -- Print_Sources --
1474    -------------------
1475
1476    --  Could use some comments in this body ???
1477
1478    procedure Print_Sources (In_Tree : Project_Tree_Ref) is
1479       Unit : Unit_Data;
1480
1481    begin
1482       Write_Line ("List of Sources:");
1483
1484       for Id in Unit_Table.First ..
1485                 Unit_Table.Last (In_Tree.Units)
1486       loop
1487          Unit := In_Tree.Units.Table (Id);
1488          Write_Str  ("   ");
1489          Write_Line (Namet.Get_Name_String (Unit.Name));
1490
1491          if Unit.File_Names (Specification).Name /= No_File then
1492             if Unit.File_Names (Specification).Project = No_Project then
1493                Write_Line ("   No project");
1494
1495             else
1496                Write_Str  ("   Project: ");
1497                Get_Name_String
1498                  (Unit.File_Names (Specification).Project.Path.Name);
1499                Write_Line (Name_Buffer (1 .. Name_Len));
1500             end if;
1501
1502             Write_Str  ("      spec: ");
1503             Write_Line
1504               (Namet.Get_Name_String
1505                (Unit.File_Names (Specification).Name));
1506          end if;
1507
1508          if Unit.File_Names (Body_Part).Name /= No_File then
1509             if Unit.File_Names (Body_Part).Project = No_Project then
1510                Write_Line ("   No project");
1511
1512             else
1513                Write_Str  ("   Project: ");
1514                Get_Name_String
1515                  (Unit.File_Names (Body_Part).Project.Path.Name);
1516                Write_Line (Name_Buffer (1 .. Name_Len));
1517             end if;
1518
1519             Write_Str  ("      body: ");
1520             Write_Line
1521               (Namet.Get_Name_String
1522                (Unit.File_Names (Body_Part).Name));
1523          end if;
1524       end loop;
1525
1526       Write_Line ("end of List of Sources.");
1527    end Print_Sources;
1528
1529    ----------------
1530    -- Project_Of --
1531    ----------------
1532
1533    function Project_Of
1534      (Name         : String;
1535       Main_Project : Project_Id;
1536       In_Tree      : Project_Tree_Ref) return Project_Id
1537    is
1538       Result : Project_Id := No_Project;
1539
1540       Original_Name : String := Name;
1541
1542       Extended_Spec_Name : String :=
1543         Name & Spec_Suffix_Of (In_Tree, "ada", Main_Project.Naming);
1544       Extended_Body_Name : String :=
1545         Name & Body_Suffix_Of (In_Tree, "ada", Main_Project.Naming);
1546
1547       Unit : Unit_Data;
1548
1549       Current_Name      : File_Name_Type;
1550       The_Original_Name : File_Name_Type;
1551       The_Spec_Name     : File_Name_Type;
1552       The_Body_Name     : File_Name_Type;
1553
1554    begin
1555       Canonical_Case_File_Name (Original_Name);
1556       Name_Len := Original_Name'Length;
1557       Name_Buffer (1 .. Name_Len) := Original_Name;
1558       The_Original_Name := Name_Find;
1559
1560       Canonical_Case_File_Name (Extended_Spec_Name);
1561       Name_Len := Extended_Spec_Name'Length;
1562       Name_Buffer (1 .. Name_Len) := Extended_Spec_Name;
1563       The_Spec_Name := Name_Find;
1564
1565       Canonical_Case_File_Name (Extended_Body_Name);
1566       Name_Len := Extended_Body_Name'Length;
1567       Name_Buffer (1 .. Name_Len) := Extended_Body_Name;
1568       The_Body_Name := Name_Find;
1569
1570       for Current in reverse Unit_Table.First ..
1571                              Unit_Table.Last (In_Tree.Units)
1572       loop
1573          Unit := In_Tree.Units.Table (Current);
1574
1575          --  Check for body
1576
1577          Current_Name := Unit.File_Names (Body_Part).Name;
1578
1579          --  Case of a body present
1580
1581          if Current_Name /= No_File then
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 (Body_Part).Project;
1591                exit;
1592             end if;
1593          end if;
1594
1595          --  Check for spec
1596
1597          Current_Name := Unit.File_Names (Specification).Name;
1598
1599          if Current_Name /= No_File then
1600
1601             --  If name same as the original name, or the spec name, we have
1602             --  found the project.
1603
1604             if Unit.Name = Name_Id (The_Original_Name)
1605               or else Current_Name = The_Original_Name
1606               or else Current_Name = The_Spec_Name
1607             then
1608                Result := Unit.File_Names (Specification).Project;
1609                exit;
1610             end if;
1611          end if;
1612       end loop;
1613
1614       --  Get the ultimate extending project
1615
1616       if Result /= No_Project then
1617          while Result.Extended_By /= No_Project loop
1618             Result := Result.Extended_By;
1619          end loop;
1620       end if;
1621
1622       return Result;
1623    end Project_Of;
1624
1625    -------------------
1626    -- Set_Ada_Paths --
1627    -------------------
1628
1629    procedure Set_Ada_Paths
1630      (Project             : Project_Id;
1631       In_Tree             : Project_Tree_Ref;
1632       Including_Libraries : Boolean)
1633
1634    is
1635       Source_FD : File_Descriptor := Invalid_FD;
1636       Object_FD : File_Descriptor := Invalid_FD;
1637
1638       Process_Source_Dirs : Boolean := False;
1639       Process_Object_Dirs : Boolean := False;
1640
1641       Status : Boolean;
1642       --  For calls to Close
1643
1644       Len : Natural;
1645
1646       procedure Recursive_Add (Project : Project_Id; Dummy : in out Boolean);
1647       --  Recursive procedure to add the source/object paths of extended/
1648       --  imported projects.
1649
1650       -------------------
1651       -- Recursive_Add --
1652       -------------------
1653
1654       procedure Recursive_Add (Project : Project_Id; Dummy : in out Boolean) is
1655          pragma Unreferenced (Dummy);
1656
1657          Path : Path_Name_Type;
1658
1659       begin
1660          --  ??? This is almost the equivalent of For_All_Source_Dirs
1661
1662          if Process_Source_Dirs then
1663
1664             --  Add to path all source directories of this project if there are
1665             --  Ada sources.
1666
1667             if Has_Ada_Sources (Project) then
1668                Add_To_Source_Path (Project.Source_Dirs, In_Tree);
1669             end if;
1670          end if;
1671
1672          if Process_Object_Dirs then
1673             Path := Get_Object_Directory
1674               (Project,
1675                Including_Libraries => Including_Libraries,
1676                Only_If_Ada         => True);
1677
1678             if Path /= No_Path then
1679                Add_To_Object_Path (Path, In_Tree);
1680             end if;
1681          end if;
1682       end Recursive_Add;
1683
1684       procedure For_All_Projects is
1685         new For_Every_Project_Imported (Boolean, Recursive_Add);
1686       Dummy : Boolean := False;
1687
1688    --  Start of processing for Set_Ada_Paths
1689
1690    begin
1691       --  If it is the first time we call this procedure for this project,
1692       --  compute the source path and/or the object path.
1693
1694       if Project.Include_Path_File = No_Path then
1695          Process_Source_Dirs := True;
1696          Create_New_Path_File
1697            (In_Tree, Source_FD, Project.Include_Path_File);
1698       end if;
1699
1700       --  For the object path, we make a distinction depending on
1701       --  Including_Libraries.
1702
1703       if Including_Libraries then
1704          if Project.Objects_Path_File_With_Libs = No_Path then
1705             Process_Object_Dirs := True;
1706             Create_New_Path_File
1707               (In_Tree, Object_FD, Project.Objects_Path_File_With_Libs);
1708          end if;
1709
1710       else
1711          if Project.Objects_Path_File_Without_Libs = No_Path then
1712             Process_Object_Dirs := True;
1713             Create_New_Path_File
1714               (In_Tree, Object_FD, Project.Objects_Path_File_Without_Libs);
1715          end if;
1716       end if;
1717
1718       --  If there is something to do, set Seen to False for all projects,
1719       --  then call the recursive procedure Add for Project.
1720
1721       if Process_Source_Dirs or Process_Object_Dirs then
1722          Source_Path_Table.Set_Last (In_Tree.Private_Part.Source_Paths, 0);
1723          Object_Path_Table.Set_Last (In_Tree.Private_Part.Object_Paths, 0);
1724          For_All_Projects (Project, Dummy);
1725       end if;
1726
1727       --  Write and close any file that has been created
1728
1729       if Source_FD /= Invalid_FD then
1730          for Index in Source_Path_Table.First ..
1731                       Source_Path_Table.Last
1732                         (In_Tree.Private_Part.Source_Paths)
1733          loop
1734             Get_Name_String (In_Tree.Private_Part.Source_Paths.Table (Index));
1735             Name_Len := Name_Len + 1;
1736             Name_Buffer (Name_Len) := ASCII.LF;
1737             Len := Write (Source_FD, Name_Buffer (1)'Address, Name_Len);
1738
1739             if Len /= Name_Len then
1740                Prj.Com.Fail ("disk full");
1741             end if;
1742          end loop;
1743
1744          Close (Source_FD, Status);
1745
1746          if not Status then
1747             Prj.Com.Fail ("disk full");
1748          end if;
1749       end if;
1750
1751       if Object_FD /= Invalid_FD then
1752          for Index in Object_Path_Table.First ..
1753                       Object_Path_Table.Last
1754                         (In_Tree.Private_Part.Object_Paths)
1755          loop
1756             Get_Name_String (In_Tree.Private_Part.Object_Paths.Table (Index));
1757             Name_Len := Name_Len + 1;
1758             Name_Buffer (Name_Len) := ASCII.LF;
1759             Len := Write (Object_FD, Name_Buffer (1)'Address, Name_Len);
1760
1761             if Len /= Name_Len then
1762                Prj.Com.Fail ("disk full");
1763             end if;
1764          end loop;
1765
1766          Close (Object_FD, Status);
1767
1768          if not Status then
1769             Prj.Com.Fail ("disk full");
1770          end if;
1771       end if;
1772
1773       --  Set the env vars, if they need to be changed, and set the
1774       --  corresponding flags.
1775
1776       if In_Tree.Private_Part.Current_Source_Path_File /=
1777            Project.Include_Path_File
1778       then
1779          In_Tree.Private_Part.Current_Source_Path_File :=
1780            Project.Include_Path_File;
1781          Set_Path_File_Var
1782            (Project_Include_Path_File,
1783             Get_Name_String (In_Tree.Private_Part.Current_Source_Path_File));
1784          In_Tree.Private_Part.Ada_Prj_Include_File_Set := True;
1785       end if;
1786
1787       if Including_Libraries then
1788          if In_Tree.Private_Part.Current_Object_Path_File /=
1789             Project.Objects_Path_File_With_Libs
1790          then
1791             In_Tree.Private_Part.Current_Object_Path_File :=
1792               Project.Objects_Path_File_With_Libs;
1793             Set_Path_File_Var
1794               (Project_Objects_Path_File,
1795                Get_Name_String
1796                  (In_Tree.Private_Part.Current_Object_Path_File));
1797             In_Tree.Private_Part.Ada_Prj_Objects_File_Set := True;
1798          end if;
1799
1800       else
1801          if In_Tree.Private_Part.Current_Object_Path_File /=
1802             Project.Objects_Path_File_Without_Libs
1803          then
1804             In_Tree.Private_Part.Current_Object_Path_File :=
1805               Project.Objects_Path_File_Without_Libs;
1806             Set_Path_File_Var
1807               (Project_Objects_Path_File,
1808                Get_Name_String
1809                  (In_Tree.Private_Part.Current_Object_Path_File));
1810             In_Tree.Private_Part.Ada_Prj_Objects_File_Set := True;
1811          end if;
1812       end if;
1813    end Set_Ada_Paths;
1814
1815    ---------------------------------------------
1816    -- Set_Mapping_File_Initial_State_To_Empty --
1817    ---------------------------------------------
1818
1819    procedure Set_Mapping_File_Initial_State_To_Empty
1820      (In_Tree : Project_Tree_Ref)
1821    is
1822    begin
1823       In_Tree.Private_Part.Fill_Mapping_File := False;
1824    end Set_Mapping_File_Initial_State_To_Empty;
1825
1826    -----------------------
1827    -- Set_Path_File_Var --
1828    -----------------------
1829
1830    procedure Set_Path_File_Var (Name : String; Value : String) is
1831       Host_Spec : String_Access := To_Host_File_Spec (Value);
1832    begin
1833       if Host_Spec = null then
1834          Prj.Com.Fail
1835            ("could not convert file name """ & Value & """ to host spec");
1836       else
1837          Setenv (Name, Host_Spec.all);
1838          Free (Host_Spec);
1839       end if;
1840    end Set_Path_File_Var;
1841
1842    ---------------------------
1843    -- Ultimate_Extension_Of --
1844    ---------------------------
1845
1846    function Ultimate_Extension_Of
1847      (Project : Project_Id) return Project_Id
1848    is
1849       Result : Project_Id := Project;
1850
1851    begin
1852       while Result.Extended_By /= No_Project loop
1853          Result := Result.Extended_By;
1854       end loop;
1855
1856       return Result;
1857    end Ultimate_Extension_Of;
1858
1859 end Prj.Env;