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