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