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-2005 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 2,  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 COPYING.  If not, write --
  19 -- to  the  Free Software Foundation,  51  Franklin  Street,  Fifth  Floor, --
  20 -- Boston, MA 02110-1301, USA.                                              --
  21 --                                                                          --
  22 -- GNAT was originally developed  by the GNAT team at  New York University. --
  23 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  24 --                                                                          --
  25 ------------------------------------------------------------------------------
  26
  27 with Namet;    use Namet;
  28 with Opt;
  29 with Osint;    use Osint;
  30 with Output;   use Output;
  31 with Prj.Com;  use Prj.Com;
  32 with Tempdir;
  33
  34 with GNAT.Directory_Operations; use GNAT.Directory_Operations;
  35
  36 package body Prj.Env is
  37
  38    Current_Source_Path_File : Name_Id := No_Name;
  39    --  Current value of project source path file env var.
  40    --  Used to avoid setting the env var to the same value.
  41
  42    Current_Object_Path_File : Name_Id := No_Name;
  43    --  Current value of project object path file env var.
  44    --  Used to avoid setting the env var to the same value.
  45
  46    Ada_Path_Buffer : String_Access := new String (1 .. 1024);
  47    --  A buffer where values for ADA_INCLUDE_PATH
  48    --  and ADA_OBJECTS_PATH are stored.
  49
  50    Ada_Path_Length : Natural := 0;
  51    --  Index of the last valid character in Ada_Path_Buffer.
  52
  53    Ada_Prj_Include_File_Set : Boolean := False;
  54    Ada_Prj_Objects_File_Set : Boolean := False;
  55    --  These flags are set to True when the corresponding environment variables
  56    --  are set and are used to give these environment variables an empty string
  57    --  value at the end of the program. This has no practical effect on most
  58    --  platforms, except on VMS where the logical names are deassigned, thus
  59    --  avoiding the pollution of the environment of the caller.
  60
  61    Default_Naming : constant Naming_Id := Naming_Table.First;
  62
  63    Fill_Mapping_File : Boolean := True;
  64
  65    type Project_Flags is array (Project_Id range <>) of Boolean;
  66    --  A Boolean array type used in Create_Mapping_File to select the projects
  67    --  in the closure of a specific project.
  68
  69    -----------------------
  70    -- Local Subprograms --
  71    -----------------------
  72
  73    function Body_Path_Name_Of
  74      (Unit    : Unit_Id;
  75       In_Tree : Project_Tree_Ref) return String;
  76    --  Returns the path name of the body of a unit.
  77    --  Compute it first, if necessary.
  78
  79    function Spec_Path_Name_Of
  80      (Unit    : Unit_Id;
  81       In_Tree : Project_Tree_Ref) return String;
  82    --  Returns the path name of the spec of a unit.
  83    --  Compute it first, if necessary.
  84
  85    procedure Add_To_Path
  86      (Source_Dirs : String_List_Id;
  87       In_Tree     : Project_Tree_Ref);
  88    --  Add to Ada_Path_Buffer all the source directories in string list
  89    --  Source_Dirs, if any. Increment Ada_Path_Length.
  90
  91    procedure Add_To_Path (Dir : String);
  92    --  If Dir is not already in the global variable Ada_Path_Buffer, add it.
  93    --  Increment Ada_Path_Length.
  94    --  If Ada_Path_Length /= 0, prepend a Path_Separator character to
  95    --  Path.
  96
  97    procedure Add_To_Source_Path
  98      (Source_Dirs : String_List_Id; In_Tree : Project_Tree_Ref);
  99    --  Add to Ada_Path_B all the source directories in string list
 100    --  Source_Dirs, if any. Increment Ada_Path_Length.
 101
 102    procedure Add_To_Object_Path
 103      (Object_Dir : Name_Id;
 104       In_Tree    : Project_Tree_Ref);
 105    --  Add Object_Dir to object path table. Make sure it is not duplicate
 106    --  and it is the last one in the current table.
 107
 108    function Contains_ALI_Files (Dir : Name_Id) return Boolean;
 109    --  Return True if there is at least one ALI file in the directory Dir
 110
 111    procedure Create_New_Path_File
 112      (In_Tree   : Project_Tree_Ref;
 113       Path_FD   : out File_Descriptor;
 114       Path_Name : out Name_Id);
 115    --  Create a new temporary path file. Get the file name in Path_Name.
 116    --  The name is normally obtained by increasing the number in
 117    --  Temp_Path_File_Name by 1.
 118
 119    procedure Set_Path_File_Var (Name : String; Value : String);
 120    --  Call Setenv, after calling To_Host_File_Spec
 121
 122    function Ultimate_Extension_Of
 123      (Project : in Project_Id; In_Tree : Project_Tree_Ref) return Project_Id;
 124    --  Return a project that is either Project or an extended ancestor of
 125    --  Project that itself is not extended.
 126
 127    ----------------------
 128    -- Ada_Include_Path --
 129    ----------------------
 130
 131    function Ada_Include_Path
 132      (Project : Project_Id;
 133       In_Tree : Project_Tree_Ref) return String_Access is
 134
 135       procedure Add (Project : Project_Id);
 136       --  Add all the source directories of a project to the path only if
 137       --  this project has not been visited. Calls itself recursively for
 138       --  projects being extended, and imported projects. Adds the project
 139       --  to the list Seen if this is the call to Add for this project.
 140
 141       ---------
 142       -- Add --
 143       ---------
 144
 145       procedure Add (Project : Project_Id) is
 146       begin
 147          --  If Seen is empty, then the project cannot have been visited
 148
 149          if not In_Tree.Projects.Table (Project).Seen then
 150             In_Tree.Projects.Table (Project).Seen := True;
 151
 152             declare
 153                Data : constant Project_Data :=
 154                         In_Tree.Projects.Table (Project);
 155                List : Project_List := Data.Imported_Projects;
 156
 157             begin
 158                --  Add to path all source directories of this project
 159
 160                Add_To_Path (Data.Source_Dirs, In_Tree);
 161
 162                --  Call Add to the project being extended, if any
 163
 164                if Data.Extends /= No_Project then
 165                   Add (Data.Extends);
 166                end if;
 167
 168                --  Call Add for each imported project, if any
 169
 170                while List /= Empty_Project_List loop
 171                   Add
 172                     (In_Tree.Project_Lists.Table (List).Project);
 173                   List := In_Tree.Project_Lists.Table (List).Next;
 174                end loop;
 175             end;
 176          end if;
 177       end Add;
 178
 179    --  Start of processing for Ada_Include_Path
 180
 181    begin
 182       --  If it is the first time we call this function for
 183       --  this project, compute the source path
 184
 185       if
 186         In_Tree.Projects.Table (Project).Ada_Include_Path = null
 187       then
 188          Ada_Path_Length := 0;
 189
 190          for Index in Project_Table.First ..
 191                       Project_Table.Last (In_Tree.Projects)
 192          loop
 193             In_Tree.Projects.Table (Index).Seen := False;
 194          end loop;
 195
 196          Add (Project);
 197          In_Tree.Projects.Table (Project).Ada_Include_Path :=
 198            new String'(Ada_Path_Buffer (1 .. Ada_Path_Length));
 199       end if;
 200
 201       return In_Tree.Projects.Table (Project).Ada_Include_Path;
 202    end Ada_Include_Path;
 203
 204    ----------------------
 205    -- Ada_Include_Path --
 206    ----------------------
 207
 208    function Ada_Include_Path
 209      (Project   : Project_Id;
 210       In_Tree   : Project_Tree_Ref;
 211       Recursive : Boolean) return String
 212    is
 213    begin
 214       if Recursive then
 215          return Ada_Include_Path (Project, In_Tree).all;
 216       else
 217          Ada_Path_Length := 0;
 218          Add_To_Path
 219            (In_Tree.Projects.Table (Project).Source_Dirs, In_Tree);
 220          return Ada_Path_Buffer (1 .. Ada_Path_Length);
 221       end if;
 222    end Ada_Include_Path;
 223
 224    ----------------------
 225    -- Ada_Objects_Path --
 226    ----------------------
 227
 228    function Ada_Objects_Path
 229      (Project             : Project_Id;
 230       In_Tree             : Project_Tree_Ref;
 231       Including_Libraries : Boolean := True) return String_Access
 232    is
 233       procedure Add (Project : Project_Id);
 234       --  Add all the object directories of a project to the path only if
 235       --  this project has not been visited. Calls itself recursively for
 236       --  projects being extended, and imported projects. Adds the project
 237       --  to the list Seen if this is the first call to Add for this project.
 238
 239       ---------
 240       -- Add --
 241       ---------
 242
 243       procedure Add (Project : Project_Id) is
 244       begin
 245          --  If this project has not been seen yet
 246
 247          if not In_Tree.Projects.Table (Project).Seen then
 248             In_Tree.Projects.Table (Project).Seen := True;
 249
 250             declare
 251                Data : constant Project_Data :=
 252                  In_Tree.Projects.Table (Project);
 253                List : Project_List := Data.Imported_Projects;
 254
 255             begin
 256                --  Add to path the object directory of this project
 257                --  except if we don't include library project and
 258                --  this is a library project.
 259
 260                if (Data.Library and then Including_Libraries)
 261                  or else
 262                  (Data.Object_Directory /= No_Name
 263                    and then
 264                    (not Including_Libraries or else not Data.Library))
 265                then
 266                   --  For a library project, add the library directory,
 267                   --  if there is no object directory or if it contains ALI
 268                   --  files; otherwise add the object directory.
 269
 270                   if Data.Library then
 271                      if Data.Object_Directory = No_Name
 272                        or else
 273                          Contains_ALI_Files (Data.Library_Dir)
 274                      then
 275                         Add_To_Path (Get_Name_String (Data.Library_Dir));
 276                      else
 277                         Add_To_Path (Get_Name_String (Data.Object_Directory));
 278                      end if;
 279
 280                   else
 281                      --  For a non library project, add the object directory
 282
 283                      Add_To_Path (Get_Name_String (Data.Object_Directory));
 284                   end if;
 285                end if;
 286
 287                --  Call Add to the project being extended, if any
 288
 289                if Data.Extends /= No_Project then
 290                   Add (Data.Extends);
 291                end if;
 292
 293                --  Call Add for each imported project, if any
 294
 295                while List /= Empty_Project_List loop
 296                   Add
 297                     (In_Tree.Project_Lists.Table (List).Project);
 298                   List := In_Tree.Project_Lists.Table (List).Next;
 299                end loop;
 300             end;
 301
 302          end if;
 303       end Add;
 304
 305    --  Start of processing for Ada_Objects_Path
 306
 307    begin
 308       --  If it is the first time we call this function for
 309       --  this project, compute the objects path
 310
 311       if
 312         In_Tree.Projects.Table (Project).Ada_Objects_Path = null
 313       then
 314          Ada_Path_Length := 0;
 315
 316          for Index in Project_Table.First ..
 317                       Project_Table.Last (In_Tree.Projects)
 318          loop
 319             In_Tree.Projects.Table (Index).Seen := False;
 320          end loop;
 321
 322          Add (Project);
 323          In_Tree.Projects.Table (Project).Ada_Objects_Path :=
 324            new String'(Ada_Path_Buffer (1 .. Ada_Path_Length));
 325       end if;
 326
 327       return In_Tree.Projects.Table (Project).Ada_Objects_Path;
 328    end Ada_Objects_Path;
 329
 330    ------------------------
 331    -- Add_To_Object_Path --
 332    ------------------------
 333
 334    procedure Add_To_Object_Path
 335      (Object_Dir : Name_Id; In_Tree : Project_Tree_Ref)
 336    is
 337    begin
 338       --  Check if the directory is already in the table
 339
 340       for Index in Object_Path_Table.First ..
 341                    Object_Path_Table.Last (In_Tree.Private_Part.Object_Paths)
 342       loop
 343
 344          --  If it is, remove it, and add it as the last one
 345
 346          if In_Tree.Private_Part.Object_Paths.Table (Index) = Object_Dir then
 347             for Index2 in Index + 1 ..
 348                           Object_Path_Table.Last
 349                             (In_Tree.Private_Part.Object_Paths)
 350             loop
 351                In_Tree.Private_Part.Object_Paths.Table (Index2 - 1) :=
 352                  In_Tree.Private_Part.Object_Paths.Table (Index2);
 353             end loop;
 354
 355             In_Tree.Private_Part.Object_Paths.Table
 356               (Object_Path_Table.Last (In_Tree.Private_Part.Object_Paths)) :=
 357                  Object_Dir;
 358             return;
 359          end if;
 360       end loop;
 361
 362       --  The directory is not already in the table, add it
 363
 364       Object_Path_Table.Increment_Last (In_Tree.Private_Part.Object_Paths);
 365       In_Tree.Private_Part.Object_Paths.Table
 366         (Object_Path_Table.Last (In_Tree.Private_Part.Object_Paths)) :=
 367            Object_Dir;
 368    end Add_To_Object_Path;
 369
 370    -----------------
 371    -- Add_To_Path --
 372    -----------------
 373
 374    procedure Add_To_Path
 375      (Source_Dirs : String_List_Id;
 376       In_Tree     : Project_Tree_Ref)
 377    is
 378       Current    : String_List_Id := Source_Dirs;
 379       Source_Dir : String_Element;
 380    begin
 381       while Current /= Nil_String loop
 382          Source_Dir := In_Tree.String_Elements.Table (Current);
 383          Add_To_Path (Get_Name_String (Source_Dir.Display_Value));
 384          Current := Source_Dir.Next;
 385       end loop;
 386    end Add_To_Path;
 387
 388    procedure Add_To_Path (Dir : String) is
 389       Len        : Natural;
 390       New_Buffer : String_Access;
 391       Min_Len    : Natural;
 392
 393       function Is_Present (Path : String; Dir : String) return Boolean;
 394       --  Return True if Dir is part of Path
 395
 396       ----------------
 397       -- Is_Present --
 398       ----------------
 399
 400       function Is_Present (Path : String; Dir : String) return Boolean is
 401          Last : constant Integer := Path'Last - Dir'Length + 1;
 402
 403       begin
 404          for J in Path'First .. Last loop
 405
 406             --  Note: the order of the conditions below is important, since
 407             --  it ensures a minimal number of string comparisons.
 408
 409             if (J = Path'First
 410                 or else Path (J - 1) = Path_Separator)
 411               and then
 412                 (J + Dir'Length > Path'Last
 413                  or else Path (J + Dir'Length) = Path_Separator)
 414               and then Dir = Path (J .. J + Dir'Length - 1)
 415             then
 416                return True;
 417             end if;
 418          end loop;
 419
 420          return False;
 421       end Is_Present;
 422
 423    --  Start of processing for Add_To_Path
 424
 425    begin
 426       if Is_Present (Ada_Path_Buffer (1 .. Ada_Path_Length), Dir) then
 427
 428          --  Dir is already in the path, nothing to do
 429
 430          return;
 431       end if;
 432
 433       Min_Len := Ada_Path_Length + Dir'Length;
 434
 435       if Ada_Path_Length > 0 then
 436
 437          --  Add 1 for the Path_Separator character
 438
 439          Min_Len := Min_Len + 1;
 440       end if;
 441
 442       --  If Ada_Path_Buffer is too small, increase it
 443
 444       Len := Ada_Path_Buffer'Last;
 445
 446       if Len < Min_Len then
 447          loop
 448             Len := Len * 2;
 449             exit when Len >= Min_Len;
 450          end loop;
 451
 452          New_Buffer := new String (1 .. Len);
 453          New_Buffer (1 .. Ada_Path_Length) :=
 454            Ada_Path_Buffer (1 .. Ada_Path_Length);
 455          Free (Ada_Path_Buffer);
 456          Ada_Path_Buffer := New_Buffer;
 457       end if;
 458
 459       if Ada_Path_Length > 0 then
 460          Ada_Path_Length := Ada_Path_Length + 1;
 461          Ada_Path_Buffer (Ada_Path_Length) := Path_Separator;
 462       end if;
 463
 464       Ada_Path_Buffer
 465         (Ada_Path_Length + 1 .. Ada_Path_Length + Dir'Length) := Dir;
 466       Ada_Path_Length := Ada_Path_Length + Dir'Length;
 467    end Add_To_Path;
 468
 469    ------------------------
 470    -- Add_To_Source_Path --
 471    ------------------------
 472
 473    procedure Add_To_Source_Path
 474      (Source_Dirs : String_List_Id; In_Tree : Project_Tree_Ref)
 475    is
 476       Current    : String_List_Id := Source_Dirs;
 477       Source_Dir : String_Element;
 478       Add_It     : Boolean;
 479
 480    begin
 481       --  Add each source directory
 482
 483       while Current /= Nil_String loop
 484          Source_Dir := In_Tree.String_Elements.Table (Current);
 485          Add_It := True;
 486
 487          --  Check if the source directory is already in the table
 488
 489          for Index in Source_Path_Table.First ..
 490                       Source_Path_Table.Last
 491                                           (In_Tree.Private_Part.Source_Paths)
 492          loop
 493             --  If it is already, no need to add it
 494
 495             if In_Tree.Private_Part.Source_Paths.Table (Index) =
 496                         Source_Dir.Value
 497             then
 498                Add_It := False;
 499                exit;
 500             end if;
 501          end loop;
 502
 503          if Add_It then
 504             Source_Path_Table.Increment_Last
 505               (In_Tree.Private_Part.Source_Paths);
 506             In_Tree.Private_Part.Source_Paths.Table
 507               (Source_Path_Table.Last (In_Tree.Private_Part.Source_Paths)) :=
 508               Source_Dir.Value;
 509          end if;
 510
 511          --  Next source directory
 512
 513          Current := Source_Dir.Next;
 514       end loop;
 515    end Add_To_Source_Path;
 516
 517    -----------------------
 518    -- Body_Path_Name_Of --
 519    -----------------------
 520
 521    function Body_Path_Name_Of
 522      (Unit : Unit_Id; In_Tree : Project_Tree_Ref) return String
 523    is
 524       Data : Unit_Data := In_Tree.Units.Table (Unit);
 525
 526    begin
 527       --  If we don't know the path name of the body of this unit,
 528       --  we compute it, and we store it.
 529
 530       if Data.File_Names (Body_Part).Path = No_Name then
 531          declare
 532             Current_Source : String_List_Id :=
 533               In_Tree.Projects.Table
 534                 (Data.File_Names (Body_Part).Project).Sources;
 535             Path : GNAT.OS_Lib.String_Access;
 536
 537          begin
 538             --  By default, put the file name
 539
 540             Data.File_Names (Body_Part).Path :=
 541               Data.File_Names (Body_Part).Name;
 542
 543             --  For each source directory
 544
 545             while Current_Source /= Nil_String loop
 546                Path :=
 547                  Locate_Regular_File
 548                    (Namet.Get_Name_String
 549                       (Data.File_Names (Body_Part).Name),
 550                     Namet.Get_Name_String
 551                       (In_Tree.String_Elements.Table
 552                          (Current_Source).Value));
 553
 554                --  If the file is in this directory, then we store the path,
 555                --  and we are done.
 556
 557                if Path /= null then
 558                   Name_Len := Path'Length;
 559                   Name_Buffer (1 .. Name_Len) := Path.all;
 560                   Data.File_Names (Body_Part).Path := Name_Enter;
 561                   exit;
 562
 563                else
 564                   Current_Source :=
 565                     In_Tree.String_Elements.Table
 566                       (Current_Source).Next;
 567                end if;
 568             end loop;
 569
 570             In_Tree.Units.Table (Unit) := Data;
 571          end;
 572       end if;
 573
 574       --  Returned the stored value
 575
 576       return Namet.Get_Name_String (Data.File_Names (Body_Part).Path);
 577    end Body_Path_Name_Of;
 578
 579    ------------------------
 580    -- Contains_ALI_Files --
 581    ------------------------
 582
 583    function Contains_ALI_Files (Dir : Name_Id) return Boolean is
 584       Dir_Name : constant String := Get_Name_String (Dir);
 585       Direct : Dir_Type;
 586       Name   : String (1 .. 1_000);
 587       Last   : Natural;
 588       Result : Boolean := False;
 589
 590    begin
 591       Open (Direct, Dir_Name);
 592
 593       --  For each file in the directory, check if it is an ALI file
 594
 595       loop
 596          Read (Direct, Name, Last);
 597          exit when Last = 0;
 598          Canonical_Case_File_Name (Name (1 .. Last));
 599          Result := Last >= 5 and then Name (Last - 3 .. Last) = ".ali";
 600          exit when Result;
 601       end loop;
 602
 603       Close (Direct);
 604       return Result;
 605
 606    exception
 607       --  If there is any problem, close the directory if open and return
 608       --  True; the library directory will be added to the path.
 609
 610       when others =>
 611          if Is_Open (Direct) then
 612             Close (Direct);
 613          end if;
 614
 615          return True;
 616    end Contains_ALI_Files;
 617
 618    --------------------------------
 619    -- Create_Config_Pragmas_File --
 620    --------------------------------
 621
 622    procedure Create_Config_Pragmas_File
 623      (For_Project          : Project_Id;
 624       Main_Project         : Project_Id;
 625       In_Tree              : Project_Tree_Ref;
 626       Include_Config_Files : Boolean := True)
 627    is
 628       pragma Unreferenced (Main_Project);
 629       pragma Unreferenced (Include_Config_Files);
 630
 631       File_Name : Name_Id         := No_Name;
 632       File      : File_Descriptor := Invalid_FD;
 633
 634       Current_Unit : Unit_Id := Unit_Table.First;
 635
 636       First_Project : Project_List := Empty_Project_List;
 637
 638       Current_Project : Project_List;
 639       Current_Naming  : Naming_Id;
 640
 641       Status : Boolean;
 642       --  For call to Close
 643
 644       procedure Check (Project : Project_Id);
 645       --  Recursive procedure that put in the config pragmas file any non
 646       --  standard naming schemes, if it is not already in the file, then call
 647       --  itself for any imported project.
 648
 649       procedure Check_Temp_File;
 650       --  Check that a temporary file has been opened.
 651       --  If not, create one, and put its name in the project data,
 652       --  with the indication that it is a temporary file.
 653
 654       procedure Put
 655         (Unit_Name : Name_Id;
 656          File_Name : Name_Id;
 657          Unit_Kind : Spec_Or_Body;
 658          Index     : Int);
 659       --  Put an SFN pragma in the temporary file
 660
 661       procedure Put (File : File_Descriptor; S : String);
 662       procedure Put_Line (File : File_Descriptor; S : String);
 663       --  Output procedures, analogous to normal Text_IO procs of same name
 664
 665       -----------
 666       -- Check --
 667       -----------
 668
 669       procedure Check (Project : Project_Id) is
 670          Data : constant Project_Data :=
 671            In_Tree.Projects.Table (Project);
 672
 673       begin
 674          if Current_Verbosity = High then
 675             Write_Str ("Checking project file """);
 676             Write_Str (Namet.Get_Name_String (Data.Name));
 677             Write_Str (""".");
 678             Write_Eol;
 679          end if;
 680
 681          --  Is this project in the list of the visited project?
 682
 683          Current_Project := First_Project;
 684          while Current_Project /= Empty_Project_List
 685            and then In_Tree.Project_Lists.Table
 686                       (Current_Project).Project /= Project
 687          loop
 688             Current_Project :=
 689               In_Tree.Project_Lists.Table (Current_Project).Next;
 690          end loop;
 691
 692          --  If it is not, put it in the list, and visit it
 693
 694          if Current_Project = Empty_Project_List then
 695             Project_List_Table.Increment_Last
 696               (In_Tree.Project_Lists);
 697             In_Tree.Project_Lists.Table
 698               (Project_List_Table.Last (In_Tree.Project_Lists)) :=
 699                  (Project => Project, Next => First_Project);
 700                First_Project :=
 701                  Project_List_Table.Last (In_Tree.Project_Lists);
 702
 703             --  Is the naming scheme of this project one that we know?
 704
 705             Current_Naming := Default_Naming;
 706             while Current_Naming <=
 707                     Naming_Table.Last (In_Tree.Private_Part.Namings)
 708               and then not Same_Naming_Scheme
 709               (Left => In_Tree.Private_Part.Namings.Table (Current_Naming),
 710                Right => Data.Naming) loop
 711                Current_Naming := Current_Naming + 1;
 712             end loop;
 713
 714             --  If we don't know it, add it
 715
 716             if Current_Naming >
 717                  Naming_Table.Last (In_Tree.Private_Part.Namings)
 718             then
 719                Naming_Table.Increment_Last (In_Tree.Private_Part.Namings);
 720                In_Tree.Private_Part.Namings.Table
 721                  (Naming_Table.Last (In_Tree.Private_Part.Namings)) :=
 722                     Data.Naming;
 723
 724                --  We need a temporary file to be created
 725
 726                Check_Temp_File;
 727
 728                --  Put the SFN pragmas for the naming scheme
 729
 730                --  Spec
 731
 732                Put_Line
 733                  (File, "pragma Source_File_Name_Project");
 734                Put_Line
 735                  (File, "  (Spec_File_Name  => ""*" &
 736                   Namet.Get_Name_String (Data.Naming.Ada_Spec_Suffix) &
 737                   """,");
 738                Put_Line
 739                  (File, "   Casing          => " &
 740                   Image (Data.Naming.Casing) & ",");
 741                Put_Line
 742                  (File, "   Dot_Replacement => """ &
 743                  Namet.Get_Name_String (Data.Naming.Dot_Replacement) &
 744                   """);");
 745
 746                --  and body
 747
 748                Put_Line
 749                  (File, "pragma Source_File_Name_Project");
 750                Put_Line
 751                  (File, "  (Body_File_Name  => ""*" &
 752                   Namet.Get_Name_String (Data.Naming.Ada_Body_Suffix) &
 753                   """,");
 754                Put_Line
 755                  (File, "   Casing          => " &
 756                   Image (Data.Naming.Casing) & ",");
 757                Put_Line
 758                  (File, "   Dot_Replacement => """ &
 759                   Namet.Get_Name_String (Data.Naming.Dot_Replacement) &
 760                   """);");
 761
 762                --  and maybe separate
 763
 764                if
 765                  Data.Naming.Ada_Body_Suffix /= Data.Naming.Separate_Suffix
 766                then
 767                   Put_Line
 768                     (File, "pragma Source_File_Name_Project");
 769                   Put_Line
 770                     (File, "  (Subunit_File_Name  => ""*" &
 771                      Namet.Get_Name_String (Data.Naming.Separate_Suffix) &
 772                      """,");
 773                   Put_Line
 774                     (File, "   Casing          => " &
 775                      Image (Data.Naming.Casing) &
 776                      ",");
 777                   Put_Line
 778                     (File, "   Dot_Replacement => """ &
 779                      Namet.Get_Name_String (Data.Naming.Dot_Replacement) &
 780                      """);");
 781                end if;
 782             end if;
 783
 784             if Data.Extends /= No_Project then
 785                Check (Data.Extends);
 786             end if;
 787
 788             declare
 789                Current : Project_List := Data.Imported_Projects;
 790
 791             begin
 792                while Current /= Empty_Project_List loop
 793                   Check
 794                     (In_Tree.Project_Lists.Table
 795                        (Current).Project);
 796                   Current := In_Tree.Project_Lists.Table
 797                                (Current).Next;
 798                end loop;
 799             end;
 800          end if;
 801       end Check;
 802
 803       ---------------------
 804       -- Check_Temp_File --
 805       ---------------------
 806
 807       procedure Check_Temp_File is
 808       begin
 809          if File = Invalid_FD then
 810             Tempdir.Create_Temp_File (File, Name => File_Name);
 811
 812             if File = Invalid_FD then
 813                Prj.Com.Fail
 814                  ("unable to create temporary configuration pragmas file");
 815             elsif Opt.Verbose_Mode then
 816                Write_Str ("Creating temp file """);
 817                Write_Str (Get_Name_String (File_Name));
 818                Write_Line ("""");
 819             end if;
 820          end if;
 821       end Check_Temp_File;
 822
 823       ---------
 824       -- Put --
 825       ---------
 826
 827       procedure Put
 828         (Unit_Name : Name_Id;
 829          File_Name : Name_Id;
 830          Unit_Kind : Spec_Or_Body;
 831          Index     : Int)
 832       is
 833       begin
 834          --  A temporary file needs to be open
 835
 836          Check_Temp_File;
 837
 838          --  Put the pragma SFN for the unit kind (spec or body)
 839
 840          Put (File, "pragma Source_File_Name_Project (");
 841          Put (File, Namet.Get_Name_String (Unit_Name));
 842
 843          if Unit_Kind = Specification then
 844             Put (File, ", Spec_File_Name => """);
 845          else
 846             Put (File, ", Body_File_Name => """);
 847          end if;
 848
 849          Put (File, Namet.Get_Name_String (File_Name));
 850          Put (File, """");
 851
 852          if Index /= 0 then
 853             Put (File, ", Index =>");
 854             Put (File, Index'Img);
 855          end if;
 856
 857          Put_Line (File, ");");
 858       end Put;
 859
 860       procedure Put (File : File_Descriptor; S : String) is
 861          Last : Natural;
 862
 863       begin
 864          Last := Write (File, S (S'First)'Address, S'Length);
 865
 866          if Last /= S'Length then
 867             Prj.Com.Fail ("Disk full");
 868          end if;
 869
 870          if Current_Verbosity = High then
 871             Write_Str (S);
 872          end if;
 873       end Put;
 874
 875       --------------
 876       -- Put_Line --
 877       --------------
 878
 879       procedure Put_Line (File : File_Descriptor; S : String) is
 880          S0   : String (1 .. S'Length + 1);
 881          Last : Natural;
 882
 883       begin
 884          --  Add an ASCII.LF to the string. As this config file is supposed to
 885          --  be used only by the compiler, we don't care about the characters
 886          --  for the end of line. In fact we could have put a space, but
 887          --  it is more convenient to be able to read gnat.adc during
 888          --  development, for which the ASCII.LF is fine.
 889
 890          S0 (1 .. S'Length) := S;
 891          S0 (S0'Last) := ASCII.LF;
 892          Last := Write (File, S0'Address, S0'Length);
 893
 894          if Last /= S'Length + 1 then
 895             Prj.Com.Fail ("Disk full");
 896          end if;
 897
 898          if Current_Verbosity = High then
 899             Write_Line (S);
 900          end if;
 901       end Put_Line;
 902
 903    --  Start of processing for Create_Config_Pragmas_File
 904
 905    begin
 906       if not
 907         In_Tree.Projects.Table (For_Project).Config_Checked
 908       then
 909
 910          --  Remove any memory of processed naming schemes, if any
 911
 912          Naming_Table.Set_Last (In_Tree.Private_Part.Namings, Default_Naming);
 913
 914          --  Check the naming schemes
 915
 916          Check (For_Project);
 917
 918          --  Visit all the units and process those that need an SFN pragma
 919
 920          while
 921            Current_Unit <= Unit_Table.Last (In_Tree.Units)
 922          loop
 923             declare
 924                Unit : constant Unit_Data :=
 925                  In_Tree.Units.Table (Current_Unit);
 926
 927             begin
 928                if Unit.File_Names (Specification).Needs_Pragma then
 929                   Put (Unit.Name,
 930                        Unit.File_Names (Specification).Name,
 931                        Specification,
 932                        Unit.File_Names (Specification).Index);
 933                end if;
 934
 935                if Unit.File_Names (Body_Part).Needs_Pragma then
 936                   Put (Unit.Name,
 937                        Unit.File_Names (Body_Part).Name,
 938                        Body_Part,
 939                        Unit.File_Names (Body_Part).Index);
 940                end if;
 941
 942                Current_Unit := Current_Unit + 1;
 943             end;
 944          end loop;
 945
 946          --  If there are no non standard naming scheme, issue the GNAT
 947          --  standard naming scheme. This will tell the compiler that
 948          --  a project file is used and will forbid any pragma SFN.
 949
 950          if File = Invalid_FD then
 951             Check_Temp_File;
 952
 953             Put_Line (File, "pragma Source_File_Name_Project");
 954             Put_Line (File, "   (Spec_File_Name  => ""*.ads"",");
 955             Put_Line (File, "    Dot_Replacement => ""-"",");
 956             Put_Line (File, "    Casing          => lowercase);");
 957
 958             Put_Line (File, "pragma Source_File_Name_Project");
 959             Put_Line (File, "   (Body_File_Name  => ""*.adb"",");
 960             Put_Line (File, "    Dot_Replacement => ""-"",");
 961             Put_Line (File, "    Casing          => lowercase);");
 962          end if;
 963
 964          --  Close the temporary file
 965
 966          GNAT.OS_Lib.Close (File, Status);
 967
 968          if not Status then
 969             Prj.Com.Fail ("disk full");
 970          end if;
 971
 972          if Opt.Verbose_Mode then
 973             Write_Str ("Closing configuration file """);
 974             Write_Str (Get_Name_String (File_Name));
 975             Write_Line ("""");
 976          end if;
 977
 978          In_Tree.Projects.Table (For_Project).Config_File_Name :=
 979            File_Name;
 980          In_Tree.Projects.Table (For_Project).Config_File_Temp :=
 981            True;
 982
 983          In_Tree.Projects.Table (For_Project).Config_Checked :=
 984            True;
 985       end if;
 986    end Create_Config_Pragmas_File;
 987
 988    -------------------------
 989    -- Create_Mapping_File --
 990    -------------------------
 991
 992    procedure Create_Mapping_File
 993      (Project : Project_Id;
 994       In_Tree : Project_Tree_Ref;
 995       Name    : out Name_Id)
 996    is
 997       File          : File_Descriptor := Invalid_FD;
 998       The_Unit_Data : Unit_Data;
 999       Data          : File_Name_Data;
1000
1001       Status : Boolean;
1002       --  For call to Close
1003
1004       Present       : Project_Flags
1005         (No_Project .. Project_Table.Last (In_Tree.Projects)) :=
1006         (others => False);
1007       --  For each project in the closure of Project, the corresponding flag
1008       --  will be set to True;
1009
1010       procedure Put_Name_Buffer;
1011       --  Put the line contained in the Name_Buffer in the mapping file
1012
1013       procedure Put_Data (Spec : Boolean);
1014       --  Put the mapping of the spec or body contained in Data in the file
1015       --  (3 lines).
1016
1017       procedure Recursive_Flag (Prj : Project_Id);
1018       --  Set the flags corresponding to Prj, the projects it imports
1019       --  (directly or indirectly) or extends to True. Call itself recursively.
1020
1021       ---------
1022       -- Put --
1023       ---------
1024
1025       procedure Put_Name_Buffer is
1026          Last : Natural;
1027
1028       begin
1029          Name_Len := Name_Len + 1;
1030          Name_Buffer (Name_Len) := ASCII.LF;
1031          Last := Write (File, Name_Buffer (1)'Address, Name_Len);
1032
1033          if Last /= Name_Len then
1034             Prj.Com.Fail ("Disk full");
1035          end if;
1036       end Put_Name_Buffer;
1037
1038       --------------
1039       -- Put_Data --
1040       --------------
1041
1042       procedure Put_Data (Spec : Boolean) is
1043       begin
1044          --  Line with the unit name
1045
1046          Get_Name_String (The_Unit_Data.Name);
1047          Name_Len := Name_Len + 1;
1048          Name_Buffer (Name_Len) := '%';
1049          Name_Len := Name_Len + 1;
1050
1051          if Spec then
1052             Name_Buffer (Name_Len) := 's';
1053          else
1054             Name_Buffer (Name_Len) := 'b';
1055          end if;
1056
1057          Put_Name_Buffer;
1058
1059          --  Line with the file name
1060
1061          Get_Name_String (Data.Name);
1062          Put_Name_Buffer;
1063
1064          --  Line with the path name
1065
1066          Get_Name_String (Data.Path);
1067          Put_Name_Buffer;
1068
1069       end Put_Data;
1070
1071       --------------------
1072       -- Recursive_Flag --
1073       --------------------
1074
1075       procedure Recursive_Flag (Prj : Project_Id) is
1076          Imported : Project_List;
1077          Proj     : Project_Id;
1078
1079       begin
1080          --  Nothing to do for non existent project or project that has
1081          --  already been flagged.
1082
1083          if Prj = No_Project or else Present (Prj) then
1084             return;
1085          end if;
1086
1087          --  Flag the current project
1088
1089          Present (Prj) := True;
1090          Imported :=
1091            In_Tree.Projects.Table (Prj).Imported_Projects;
1092
1093          --  Call itself for each project directly imported
1094
1095          while Imported /= Empty_Project_List loop
1096             Proj :=
1097               In_Tree.Project_Lists.Table (Imported).Project;
1098             Imported :=
1099               In_Tree.Project_Lists.Table (Imported).Next;
1100             Recursive_Flag (Proj);
1101          end loop;
1102
1103          --  Call itself for an eventual project being extended
1104
1105          Recursive_Flag (In_Tree.Projects.Table (Prj).Extends);
1106       end Recursive_Flag;
1107
1108    --  Start of processing for Create_Mapping_File
1109
1110    begin
1111       --  Flag the necessary projects
1112
1113       Recursive_Flag (Project);
1114
1115       --  Create the temporary file
1116
1117       Tempdir.Create_Temp_File (File, Name => Name);
1118
1119       if File = Invalid_FD then
1120          Prj.Com.Fail ("unable to create temporary mapping file");
1121
1122       elsif Opt.Verbose_Mode then
1123          Write_Str ("Creating temp mapping file """);
1124          Write_Str (Get_Name_String (Name));
1125          Write_Line ("""");
1126       end if;
1127
1128       if Fill_Mapping_File then
1129
1130          --  For all units in table Units
1131
1132          for Unit in 1 .. Unit_Table.Last (In_Tree.Units) loop
1133             The_Unit_Data := In_Tree.Units.Table (Unit);
1134
1135             --  If the unit has a valid name
1136
1137             if The_Unit_Data.Name /= No_Name then
1138                Data := The_Unit_Data.File_Names (Specification);
1139
1140                --  If there is a spec, put it mapping in the file if it is
1141                --  from a project in the closure of Project.
1142
1143                if Data.Name /= No_Name and then Present (Data.Project) then
1144                   Put_Data (Spec => True);
1145                end if;
1146
1147                Data := The_Unit_Data.File_Names (Body_Part);
1148
1149                --  If there is a body (or subunit) put its mapping in the file
1150                --  if it is from a project in the closure of Project.
1151
1152                if Data.Name /= No_Name and then Present (Data.Project) then
1153                   Put_Data (Spec => False);
1154                end if;
1155
1156             end if;
1157          end loop;
1158       end if;
1159
1160       GNAT.OS_Lib.Close (File, Status);
1161
1162       if not Status then
1163          Prj.Com.Fail ("disk full");
1164       end if;
1165    end Create_Mapping_File;
1166
1167    --------------------------
1168    -- Create_New_Path_File --
1169    --------------------------
1170
1171    procedure Create_New_Path_File
1172      (In_Tree   : Project_Tree_Ref;
1173       Path_FD   : out File_Descriptor;
1174       Path_Name : out Name_Id)
1175    is
1176    begin
1177       Tempdir.Create_Temp_File (Path_FD, Path_Name);
1178
1179       if Path_Name /= No_Name then
1180
1181          --  Record the name, so that the temp path file will be deleted
1182          --  at the end of the program.
1183
1184          Path_File_Table.Increment_Last (In_Tree.Private_Part.Path_Files);
1185          In_Tree.Private_Part.Path_Files.Table
1186            (Path_File_Table.Last (In_Tree.Private_Part.Path_Files)) :=
1187               Path_Name;
1188       end if;
1189    end Create_New_Path_File;
1190
1191    ---------------------------
1192    -- Delete_All_Path_Files --
1193    ---------------------------
1194
1195    procedure Delete_All_Path_Files (In_Tree : Project_Tree_Ref) is
1196       Disregard : Boolean := True;
1197
1198    begin
1199       for Index in Path_File_Table.First ..
1200                    Path_File_Table.Last (In_Tree.Private_Part.Path_Files)
1201       loop
1202          if In_Tree.Private_Part.Path_Files.Table (Index) /= No_Name then
1203             Delete_File
1204               (Get_Name_String
1205                  (In_Tree.Private_Part.Path_Files.Table (Index)),
1206                Disregard);
1207          end if;
1208       end loop;
1209
1210       --  If any of the environment variables ADA_PRJ_INCLUDE_FILE or
1211       --  ADA_PRJ_OBJECTS_FILE has been set, then reset their value to
1212       --  the empty string. On VMS, this has the effect of deassigning
1213       --  the logical names.
1214
1215       if Ada_Prj_Include_File_Set then
1216          Setenv (Project_Include_Path_File, "");
1217          Ada_Prj_Include_File_Set := False;
1218       end if;
1219
1220       if Ada_Prj_Objects_File_Set then
1221          Setenv (Project_Objects_Path_File, "");
1222          Ada_Prj_Objects_File_Set := False;
1223       end if;
1224    end Delete_All_Path_Files;
1225
1226    ------------------------------------
1227    -- File_Name_Of_Library_Unit_Body --
1228    ------------------------------------
1229
1230    function File_Name_Of_Library_Unit_Body
1231      (Name              : String;
1232       Project           : Project_Id;
1233       In_Tree           : Project_Tree_Ref;
1234       Main_Project_Only : Boolean := True;
1235       Full_Path         : Boolean := False) return String
1236    is
1237       The_Project   : Project_Id := Project;
1238       Data          : Project_Data :=
1239                         In_Tree.Projects.Table (Project);
1240       Original_Name : String := Name;
1241
1242       Extended_Spec_Name : String :=
1243                              Name & Namet.Get_Name_String
1244                                       (Data.Naming.Ada_Spec_Suffix);
1245       Extended_Body_Name : String :=
1246                              Name & Namet.Get_Name_String
1247                                       (Data.Naming.Ada_Body_Suffix);
1248
1249       Unit : Unit_Data;
1250
1251       The_Original_Name : Name_Id;
1252       The_Spec_Name     : Name_Id;
1253       The_Body_Name     : Name_Id;
1254
1255    begin
1256       Canonical_Case_File_Name (Original_Name);
1257       Name_Len := Original_Name'Length;
1258       Name_Buffer (1 .. Name_Len) := Original_Name;
1259       The_Original_Name := Name_Find;
1260
1261       Canonical_Case_File_Name (Extended_Spec_Name);
1262       Name_Len := Extended_Spec_Name'Length;
1263       Name_Buffer (1 .. Name_Len) := Extended_Spec_Name;
1264       The_Spec_Name := Name_Find;
1265
1266       Canonical_Case_File_Name (Extended_Body_Name);
1267       Name_Len := Extended_Body_Name'Length;
1268       Name_Buffer (1 .. Name_Len) := Extended_Body_Name;
1269       The_Body_Name := Name_Find;
1270
1271       if Current_Verbosity = High then
1272          Write_Str  ("Looking for file name of """);
1273          Write_Str  (Name);
1274          Write_Char ('"');
1275          Write_Eol;
1276          Write_Str  ("   Extended Spec Name = """);
1277          Write_Str  (Extended_Spec_Name);
1278          Write_Char ('"');
1279          Write_Eol;
1280          Write_Str  ("   Extended Body Name = """);
1281          Write_Str  (Extended_Body_Name);
1282          Write_Char ('"');
1283          Write_Eol;
1284       end if;
1285
1286       --  For extending project, search in the extended project
1287       --  if the source is not found. For non extending projects,
1288       --  this loop will be run only once.
1289
1290       loop
1291          --  Loop through units
1292          --  Should have comment explaining reverse ???
1293
1294          for Current in reverse Unit_Table.First ..
1295                                 Unit_Table.Last (In_Tree.Units)
1296          loop
1297             Unit := In_Tree.Units.Table (Current);
1298
1299             --  Check for body
1300
1301             if not Main_Project_Only
1302               or else Unit.File_Names (Body_Part).Project = The_Project
1303             then
1304                declare
1305                   Current_Name : constant Name_Id :=
1306                                    Unit.File_Names (Body_Part).Name;
1307
1308                begin
1309                   --  Case of a body present
1310
1311                   if Current_Name /= No_Name then
1312                      if Current_Verbosity = High then
1313                         Write_Str  ("   Comparing with """);
1314                         Write_Str  (Get_Name_String (Current_Name));
1315                         Write_Char ('"');
1316                         Write_Eol;
1317                      end if;
1318
1319                      --  If it has the name of the original name,
1320                      --  return the original name
1321
1322                      if Unit.Name = The_Original_Name
1323                        or else Current_Name = The_Original_Name
1324                      then
1325                         if Current_Verbosity = High then
1326                            Write_Line ("   OK");
1327                         end if;
1328
1329                         if Full_Path then
1330                            return Get_Name_String
1331                              (Unit.File_Names (Body_Part).Path);
1332
1333                         else
1334                            return Get_Name_String (Current_Name);
1335                         end if;
1336
1337                         --  If it has the name of the extended body name,
1338                         --  return the extended body name
1339
1340                      elsif Current_Name = The_Body_Name then
1341                         if Current_Verbosity = High then
1342                            Write_Line ("   OK");
1343                         end if;
1344
1345                         if Full_Path then
1346                            return Get_Name_String
1347                              (Unit.File_Names (Body_Part).Path);
1348
1349                         else
1350                            return Extended_Body_Name;
1351                         end if;
1352
1353                      else
1354                         if Current_Verbosity = High then
1355                            Write_Line ("   not good");
1356                         end if;
1357                      end if;
1358                   end if;
1359                end;
1360             end if;
1361
1362             --  Check for spec
1363
1364             if not Main_Project_Only
1365               or else Unit.File_Names (Specification).Project = The_Project
1366             then
1367                declare
1368                   Current_Name : constant Name_Id :=
1369                                    Unit.File_Names (Specification).Name;
1370
1371                begin
1372                   --  Case of spec present
1373
1374                   if Current_Name /= No_Name then
1375                      if Current_Verbosity = High then
1376                         Write_Str  ("   Comparing with """);
1377                         Write_Str  (Get_Name_String (Current_Name));
1378                         Write_Char ('"');
1379                         Write_Eol;
1380                      end if;
1381
1382                      --  If name same as original name, return original name
1383
1384                      if Unit.Name = The_Original_Name
1385                        or else Current_Name = The_Original_Name
1386                      then
1387                         if Current_Verbosity = High then
1388                            Write_Line ("   OK");
1389                         end if;
1390
1391                         if Full_Path then
1392                            return Get_Name_String
1393                              (Unit.File_Names (Specification).Path);
1394                         else
1395                            return Get_Name_String (Current_Name);
1396                         end if;
1397
1398                         --  If it has the same name as the extended spec name,
1399                         --  return the extended spec name.
1400
1401                      elsif Current_Name = The_Spec_Name then
1402                         if Current_Verbosity = High then
1403                            Write_Line ("   OK");
1404                         end if;
1405
1406                         if Full_Path then
1407                            return Get_Name_String
1408                              (Unit.File_Names (Specification).Path);
1409                         else
1410                            return Extended_Spec_Name;
1411                         end if;
1412
1413                      else
1414                         if Current_Verbosity = High then
1415                            Write_Line ("   not good");
1416                         end if;
1417                      end if;
1418                   end if;
1419                end;
1420             end if;
1421          end loop;
1422
1423          --  If we are not in an extending project, give up
1424
1425          exit when (not Main_Project_Only) or else Data.Extends = No_Project;
1426
1427          --  Otherwise, look in the project we are extending
1428
1429          The_Project := Data.Extends;
1430          Data := In_Tree.Projects.Table (The_Project);
1431       end loop;
1432
1433       --  We don't know this file name, return an empty string
1434
1435       return "";
1436    end File_Name_Of_Library_Unit_Body;
1437
1438    -------------------------
1439    -- For_All_Object_Dirs --
1440    -------------------------
1441
1442    procedure For_All_Object_Dirs
1443      (Project : Project_Id;
1444       In_Tree : Project_Tree_Ref)
1445    is
1446       Seen : Project_List := Empty_Project_List;
1447
1448       procedure Add (Project : Project_Id);
1449       --  Process a project. Remember the processes visited to avoid
1450       --  processing a project twice. Recursively process an eventual
1451       --  extended project, and all imported projects.
1452
1453       ---------
1454       -- Add --
1455       ---------
1456
1457       procedure Add (Project : Project_Id) is
1458          Data : constant Project_Data :=
1459                   In_Tree.Projects.Table (Project);
1460          List : Project_List := Data.Imported_Projects;
1461
1462       begin
1463          --  If the list of visited project is empty, then
1464          --  for sure we never visited this project.
1465
1466          if Seen = Empty_Project_List then
1467             Project_List_Table.Increment_Last
1468               (In_Tree.Project_Lists);
1469             Seen :=
1470               Project_List_Table.Last (In_Tree.Project_Lists);
1471             In_Tree.Project_Lists.Table (Seen) :=
1472               (Project => Project, Next => Empty_Project_List);
1473
1474          else
1475             --  Check if the project is in the list
1476
1477             declare
1478                Current : Project_List := Seen;
1479
1480             begin
1481                loop
1482                   --  If it is, then there is nothing else to do
1483
1484                   if In_Tree.Project_Lists.Table
1485                                            (Current).Project = Project
1486                   then
1487                      return;
1488                   end if;
1489
1490                   exit when
1491                     In_Tree.Project_Lists.Table (Current).Next =
1492                       Empty_Project_List;
1493                   Current :=
1494                     In_Tree.Project_Lists.Table (Current).Next;
1495                end loop;
1496
1497                --  This project has never been visited, add it
1498                --  to the list.
1499
1500                Project_List_Table.Increment_Last
1501                  (In_Tree.Project_Lists);
1502                In_Tree.Project_Lists.Table (Current).Next :=
1503                  Project_List_Table.Last (In_Tree.Project_Lists);
1504                In_Tree.Project_Lists.Table
1505                  (Project_List_Table.Last
1506                     (In_Tree.Project_Lists)) :=
1507                  (Project => Project, Next => Empty_Project_List);
1508             end;
1509          end if;
1510
1511          --  If there is an object directory, call Action
1512          --  with its name
1513
1514          if Data.Object_Directory /= No_Name then
1515             Get_Name_String (Data.Object_Directory);
1516             Action (Name_Buffer (1 .. Name_Len));
1517          end if;
1518
1519          --  If we are extending a project, visit it
1520
1521          if Data.Extends /= No_Project then
1522             Add (Data.Extends);
1523          end if;
1524
1525          --  And visit all imported projects
1526
1527          while List /= Empty_Project_List loop
1528             Add (In_Tree.Project_Lists.Table (List).Project);
1529             List := In_Tree.Project_Lists.Table (List).Next;
1530          end loop;
1531       end Add;
1532
1533    --  Start of processing for For_All_Object_Dirs
1534
1535    begin
1536       --  Visit this project, and its imported projects,
1537       --  recursively
1538
1539       Add (Project);
1540    end For_All_Object_Dirs;
1541
1542    -------------------------
1543    -- For_All_Source_Dirs --
1544    -------------------------
1545
1546    procedure For_All_Source_Dirs
1547      (Project : Project_Id;
1548       In_Tree : Project_Tree_Ref)
1549    is
1550       Seen : Project_List := Empty_Project_List;
1551
1552       procedure Add (Project : Project_Id);
1553       --  Process a project. Remember the processes visited to avoid
1554       --  processing a project twice. Recursively process an eventual
1555       --  extended project, and all imported projects.
1556
1557       ---------
1558       -- Add --
1559       ---------
1560
1561       procedure Add (Project : Project_Id) is
1562          Data : constant Project_Data :=
1563                   In_Tree.Projects.Table (Project);
1564          List : Project_List := Data.Imported_Projects;
1565
1566       begin
1567          --  If the list of visited project is empty, then
1568          --  for sure we never visited this project.
1569
1570          if Seen = Empty_Project_List then
1571             Project_List_Table.Increment_Last
1572               (In_Tree.Project_Lists);
1573             Seen := Project_List_Table.Last
1574                                          (In_Tree.Project_Lists);
1575             In_Tree.Project_Lists.Table (Seen) :=
1576               (Project => Project, Next => Empty_Project_List);
1577
1578          else
1579             --  Check if the project is in the list
1580
1581             declare
1582                Current : Project_List := Seen;
1583
1584             begin
1585                loop
1586                   --  If it is, then there is nothing else to do
1587
1588                   if In_Tree.Project_Lists.Table
1589                                            (Current).Project = Project
1590                   then
1591                      return;
1592                   end if;
1593
1594                   exit when
1595                     In_Tree.Project_Lists.Table (Current).Next =
1596                       Empty_Project_List;
1597                   Current :=
1598                     In_Tree.Project_Lists.Table (Current).Next;
1599                end loop;
1600
1601                --  This project has never been visited, add it
1602                --  to the list.
1603
1604                Project_List_Table.Increment_Last
1605                  (In_Tree.Project_Lists);
1606                In_Tree.Project_Lists.Table (Current).Next :=
1607                  Project_List_Table.Last (In_Tree.Project_Lists);
1608                In_Tree.Project_Lists.Table
1609                  (Project_List_Table.Last
1610                     (In_Tree.Project_Lists)) :=
1611                  (Project => Project, Next => Empty_Project_List);
1612             end;
1613          end if;
1614
1615          declare
1616             Current    : String_List_Id := Data.Source_Dirs;
1617             The_String : String_Element;
1618
1619          begin
1620             --  If there are Ada sources, call action with the name of every
1621             --  source directory.
1622
1623             if
1624               In_Tree.Projects.Table (Project).Ada_Sources_Present
1625             then
1626                while Current /= Nil_String loop
1627                   The_String :=
1628                     In_Tree.String_Elements.Table (Current);
1629                   Action (Get_Name_String (The_String.Value));
1630                   Current := The_String.Next;
1631                end loop;
1632             end if;
1633          end;
1634
1635          --  If we are extending a project, visit it
1636
1637          if Data.Extends /= No_Project then
1638             Add (Data.Extends);
1639          end if;
1640
1641          --  And visit all imported projects
1642
1643          while List /= Empty_Project_List loop
1644             Add (In_Tree.Project_Lists.Table (List).Project);
1645             List := In_Tree.Project_Lists.Table (List).Next;
1646          end loop;
1647       end Add;
1648
1649    --  Start of processing for For_All_Source_Dirs
1650
1651    begin
1652       --  Visit this project, and its imported projects recursively
1653
1654       Add (Project);
1655    end For_All_Source_Dirs;
1656
1657    -------------------
1658    -- Get_Reference --
1659    -------------------
1660
1661    procedure Get_Reference
1662      (Source_File_Name : String;
1663       In_Tree          : Project_Tree_Ref;
1664       Project          : out Project_Id;
1665       Path             : out Name_Id)
1666    is
1667    begin
1668       --  Body below could use some comments ???
1669
1670       if Current_Verbosity > Default then
1671          Write_Str ("Getting Reference_Of (""");
1672          Write_Str (Source_File_Name);
1673          Write_Str (""") ... ");
1674       end if;
1675
1676       declare
1677          Original_Name : String := Source_File_Name;
1678          Unit          : Unit_Data;
1679
1680       begin
1681          Canonical_Case_File_Name (Original_Name);
1682
1683          for Id in Unit_Table.First ..
1684                    Unit_Table.Last (In_Tree.Units)
1685          loop
1686             Unit := In_Tree.Units.Table (Id);
1687
1688             if (Unit.File_Names (Specification).Name /= No_Name
1689                  and then
1690                    Namet.Get_Name_String
1691                      (Unit.File_Names (Specification).Name) = Original_Name)
1692               or else (Unit.File_Names (Specification).Path /= No_Name
1693                          and then
1694                            Namet.Get_Name_String
1695                            (Unit.File_Names (Specification).Path) =
1696                                                               Original_Name)
1697             then
1698                Project := Ultimate_Extension_Of
1699                            (Project => Unit.File_Names (Specification).Project,
1700                             In_Tree => In_Tree);
1701                Path := Unit.File_Names (Specification).Display_Path;
1702
1703                if Current_Verbosity > Default then
1704                   Write_Str ("Done: Specification.");
1705                   Write_Eol;
1706                end if;
1707
1708                return;
1709
1710             elsif (Unit.File_Names (Body_Part).Name /= No_Name
1711                     and then
1712                       Namet.Get_Name_String
1713                         (Unit.File_Names (Body_Part).Name) = Original_Name)
1714               or else (Unit.File_Names (Body_Part).Path /= No_Name
1715                          and then Namet.Get_Name_String
1716                                     (Unit.File_Names (Body_Part).Path) =
1717                                                              Original_Name)
1718             then
1719                Project := Ultimate_Extension_Of
1720                             (Project => Unit.File_Names (Body_Part).Project,
1721                              In_Tree => In_Tree);
1722                Path := Unit.File_Names (Body_Part).Display_Path;
1723
1724                if Current_Verbosity > Default then
1725                   Write_Str ("Done: Body.");
1726                   Write_Eol;
1727                end if;
1728
1729                return;
1730             end if;
1731          end loop;
1732       end;
1733
1734       Project := No_Project;
1735       Path    := No_Name;
1736
1737       if Current_Verbosity > Default then
1738          Write_Str ("Cannot be found.");
1739          Write_Eol;
1740       end if;
1741    end Get_Reference;
1742
1743    ----------------
1744    -- Initialize --
1745    ----------------
1746
1747    procedure Initialize is
1748    begin
1749       Fill_Mapping_File := True;
1750    end Initialize;
1751
1752    ------------------------------------
1753    -- Path_Name_Of_Library_Unit_Body --
1754    ------------------------------------
1755
1756    --  Could use some comments in the body here ???
1757
1758    function Path_Name_Of_Library_Unit_Body
1759      (Name    : String;
1760       Project : Project_Id;
1761       In_Tree : Project_Tree_Ref) return String
1762    is
1763       Data          : constant Project_Data :=
1764                         In_Tree.Projects.Table (Project);
1765       Original_Name : String := Name;
1766
1767       Extended_Spec_Name : String :=
1768                              Name & Namet.Get_Name_String
1769                                      (Data.Naming.Ada_Spec_Suffix);
1770       Extended_Body_Name : String :=
1771                              Name & Namet.Get_Name_String
1772                                      (Data.Naming.Ada_Body_Suffix);
1773
1774       First   : Unit_Id := Unit_Table.First;
1775       Current : Unit_Id;
1776       Unit    : Unit_Data;
1777
1778    begin
1779       Canonical_Case_File_Name (Original_Name);
1780       Canonical_Case_File_Name (Extended_Spec_Name);
1781       Canonical_Case_File_Name (Extended_Body_Name);
1782
1783       if Current_Verbosity = High then
1784          Write_Str  ("Looking for path name of """);
1785          Write_Str  (Name);
1786          Write_Char ('"');
1787          Write_Eol;
1788          Write_Str  ("   Extended Spec Name = """);
1789          Write_Str  (Extended_Spec_Name);
1790          Write_Char ('"');
1791          Write_Eol;
1792          Write_Str  ("   Extended Body Name = """);
1793          Write_Str  (Extended_Body_Name);
1794          Write_Char ('"');
1795          Write_Eol;
1796       end if;
1797
1798       while First <= Unit_Table.Last (In_Tree.Units)
1799         and then In_Tree.Units.Table
1800                    (First).File_Names (Body_Part).Project /= Project
1801       loop
1802          First := First + 1;
1803       end loop;
1804
1805       Current := First;
1806       while Current <= Unit_Table.Last (In_Tree.Units) loop
1807          Unit := In_Tree.Units.Table (Current);
1808
1809          if Unit.File_Names (Body_Part).Project = Project
1810            and then Unit.File_Names (Body_Part).Name /= No_Name
1811          then
1812             declare
1813                Current_Name : constant String :=
1814                  Namet.Get_Name_String (Unit.File_Names (Body_Part).Name);
1815             begin
1816                if Current_Verbosity = High then
1817                   Write_Str  ("   Comparing with """);
1818                   Write_Str  (Current_Name);
1819                   Write_Char ('"');
1820                   Write_Eol;
1821                end if;
1822
1823                if Current_Name = Original_Name then
1824                   if Current_Verbosity = High then
1825                      Write_Line ("   OK");
1826                   end if;
1827
1828                   return Body_Path_Name_Of (Current, In_Tree);
1829
1830                elsif Current_Name = Extended_Body_Name then
1831                   if Current_Verbosity = High then
1832                      Write_Line ("   OK");
1833                   end if;
1834
1835                   return Body_Path_Name_Of (Current, In_Tree);
1836
1837                else
1838                   if Current_Verbosity = High then
1839                      Write_Line ("   not good");
1840                   end if;
1841                end if;
1842             end;
1843
1844          elsif Unit.File_Names (Specification).Name /= No_Name then
1845             declare
1846                Current_Name : constant String :=
1847                                 Namet.Get_Name_String
1848                                   (Unit.File_Names (Specification).Name);
1849
1850             begin
1851                if Current_Verbosity = High then
1852                   Write_Str  ("   Comparing with """);
1853                   Write_Str  (Current_Name);
1854                   Write_Char ('"');
1855                   Write_Eol;
1856                end if;
1857
1858                if Current_Name = Original_Name then
1859                   if Current_Verbosity = High then
1860                      Write_Line ("   OK");
1861                   end if;
1862
1863                   return Spec_Path_Name_Of (Current, In_Tree);
1864
1865                elsif Current_Name = Extended_Spec_Name then
1866                   if Current_Verbosity = High then
1867                      Write_Line ("   OK");
1868                   end if;
1869
1870                   return Spec_Path_Name_Of (Current, In_Tree);
1871
1872                else
1873                   if Current_Verbosity = High then
1874                      Write_Line ("   not good");
1875                   end if;
1876                end if;
1877             end;
1878          end if;
1879          Current := Current + 1;
1880       end loop;
1881
1882       return "";
1883    end Path_Name_Of_Library_Unit_Body;
1884
1885    -------------------
1886    -- Print_Sources --
1887    -------------------
1888
1889    --  Could use some comments in this body ???
1890
1891    procedure Print_Sources (In_Tree : Project_Tree_Ref) is
1892       Unit : Unit_Data;
1893
1894    begin
1895       Write_Line ("List of Sources:");
1896
1897       for Id in Unit_Table.First ..
1898                 Unit_Table.Last (In_Tree.Units)
1899       loop
1900          Unit := In_Tree.Units.Table (Id);
1901          Write_Str  ("   ");
1902          Write_Line (Namet.Get_Name_String (Unit.Name));
1903
1904          if Unit.File_Names (Specification).Name /= No_Name then
1905             if Unit.File_Names (Specification).Project = No_Project then
1906                Write_Line ("   No project");
1907
1908             else
1909                Write_Str  ("   Project: ");
1910                Get_Name_String
1911                  (In_Tree.Projects.Table
1912                    (Unit.File_Names (Specification).Project).Path_Name);
1913                Write_Line (Name_Buffer (1 .. Name_Len));
1914             end if;
1915
1916             Write_Str  ("      spec: ");
1917             Write_Line
1918               (Namet.Get_Name_String
1919                (Unit.File_Names (Specification).Name));
1920          end if;
1921
1922          if Unit.File_Names (Body_Part).Name /= No_Name then
1923             if Unit.File_Names (Body_Part).Project = No_Project then
1924                Write_Line ("   No project");
1925
1926             else
1927                Write_Str  ("   Project: ");
1928                Get_Name_String
1929                  (In_Tree.Projects.Table
1930                    (Unit.File_Names (Body_Part).Project).Path_Name);
1931                Write_Line (Name_Buffer (1 .. Name_Len));
1932             end if;
1933
1934             Write_Str  ("      body: ");
1935             Write_Line
1936               (Namet.Get_Name_String
1937                (Unit.File_Names (Body_Part).Name));
1938          end if;
1939       end loop;
1940
1941       Write_Line ("end of List of Sources.");
1942    end Print_Sources;
1943
1944    ----------------
1945    -- Project_Of --
1946    ----------------
1947
1948    function Project_Of
1949      (Name         : String;
1950       Main_Project : Project_Id;
1951       In_Tree      : Project_Tree_Ref) return Project_Id
1952    is
1953       Result : Project_Id := No_Project;
1954
1955       Original_Name : String := Name;
1956
1957       Data   : constant Project_Data :=
1958         In_Tree.Projects.Table (Main_Project);
1959
1960       Extended_Spec_Name : String :=
1961                              Name & Namet.Get_Name_String
1962                                       (Data.Naming.Ada_Spec_Suffix);
1963       Extended_Body_Name : String :=
1964                              Name & Namet.Get_Name_String
1965                                       (Data.Naming.Ada_Body_Suffix);
1966
1967       Unit : Unit_Data;
1968
1969       Current_Name : Name_Id;
1970
1971       The_Original_Name : Name_Id;
1972       The_Spec_Name     : Name_Id;
1973       The_Body_Name     : Name_Id;
1974
1975    begin
1976       Canonical_Case_File_Name (Original_Name);
1977       Name_Len := Original_Name'Length;
1978       Name_Buffer (1 .. Name_Len) := Original_Name;
1979       The_Original_Name := Name_Find;
1980
1981       Canonical_Case_File_Name (Extended_Spec_Name);
1982       Name_Len := Extended_Spec_Name'Length;
1983       Name_Buffer (1 .. Name_Len) := Extended_Spec_Name;
1984       The_Spec_Name := Name_Find;
1985
1986       Canonical_Case_File_Name (Extended_Body_Name);
1987       Name_Len := Extended_Body_Name'Length;
1988       Name_Buffer (1 .. Name_Len) := Extended_Body_Name;
1989       The_Body_Name := Name_Find;
1990
1991       for Current in reverse Unit_Table.First ..
1992                              Unit_Table.Last (In_Tree.Units)
1993       loop
1994          Unit := In_Tree.Units.Table (Current);
1995
1996          --  Check for body
1997
1998          Current_Name := Unit.File_Names (Body_Part).Name;
1999
2000          --  Case of a body present
2001
2002          if Current_Name /= No_Name then
2003
2004             --  If it has the name of the original name or the body name,
2005             --  we have found the project.
2006
2007             if Unit.Name = The_Original_Name
2008               or else Current_Name = The_Original_Name
2009               or else Current_Name = The_Body_Name
2010             then
2011                Result := Unit.File_Names (Body_Part).Project;
2012                exit;
2013             end if;
2014          end if;
2015
2016          --  Check for spec
2017
2018          Current_Name := Unit.File_Names (Specification).Name;
2019
2020          if Current_Name /= No_Name then
2021
2022             --  If name same as the original name, or the spec name, we have
2023             --  found the project.
2024
2025             if Unit.Name = The_Original_Name
2026               or else Current_Name = The_Original_Name
2027               or else Current_Name = The_Spec_Name
2028             then
2029                Result := Unit.File_Names (Specification).Project;
2030                exit;
2031             end if;
2032          end if;
2033       end loop;
2034
2035       --  Get the ultimate extending project
2036
2037       if Result /= No_Project then
2038          while In_Tree.Projects.Table (Result).Extended_By /=
2039            No_Project
2040          loop
2041             Result := In_Tree.Projects.Table (Result).Extended_By;
2042          end loop;
2043       end if;
2044
2045       return Result;
2046    end Project_Of;
2047
2048    -------------------
2049    -- Set_Ada_Paths --
2050    -------------------
2051
2052    procedure Set_Ada_Paths
2053      (Project             : Project_Id;
2054       In_Tree             : Project_Tree_Ref;
2055       Including_Libraries : Boolean)
2056    is
2057       Source_FD : File_Descriptor := Invalid_FD;
2058       Object_FD : File_Descriptor := Invalid_FD;
2059
2060       Process_Source_Dirs : Boolean := False;
2061       Process_Object_Dirs : Boolean := False;
2062
2063       Status : Boolean;
2064       --  For calls to Close
2065
2066       Len : Natural;
2067
2068       procedure Add (Proj : Project_Id);
2069       --  Add all the source/object directories of a project to the path only
2070       --  if this project has not been visited. Calls an internal procedure
2071       --  recursively for projects being extended, and imported projects.
2072
2073       ---------
2074       -- Add --
2075       ---------
2076
2077       procedure Add (Proj : Project_Id) is
2078
2079          procedure Recursive_Add (Project : Project_Id);
2080          --  Recursive procedure to add the source/object paths of extended/
2081          --  imported projects.
2082
2083          -------------------
2084          -- Recursive_Add --
2085          -------------------
2086
2087          procedure Recursive_Add (Project : Project_Id) is
2088          begin
2089             --  If Seen is False, then the project has not yet been visited
2090
2091             if not In_Tree.Projects.Table (Project).Seen then
2092                In_Tree.Projects.Table (Project).Seen := True;
2093
2094                declare
2095                   Data : constant Project_Data :=
2096                     In_Tree.Projects.Table (Project);
2097                   List : Project_List := Data.Imported_Projects;
2098
2099                begin
2100                   if Process_Source_Dirs then
2101
2102                      --  Add to path all source directories of this project
2103                      --  if there are Ada sources.
2104
2105                      if In_Tree.Projects.Table
2106                           (Project).Ada_Sources_Present
2107                      then
2108                         Add_To_Source_Path (Data.Source_Dirs, In_Tree);
2109                      end if;
2110                   end if;
2111
2112                   if Process_Object_Dirs then
2113
2114                      --  Add to path the object directory of this project
2115                      --  except if we don't include library project and
2116                      --  this is a library project.
2117
2118                      if (Data.Library and then Including_Libraries)
2119                        or else
2120                          (Data.Object_Directory /= No_Name
2121                           and then
2122                             (not Including_Libraries or else not Data.Library))
2123                      then
2124                         --  For a library project, add the library directory
2125                         --  if there is no object directory or if the library
2126                         --  directory contains ALI files; otherwise add the
2127                         --  object directory.
2128
2129                         if Data.Library then
2130                            if Data.Object_Directory = No_Name
2131                              or else Contains_ALI_Files (Data.Library_Dir)
2132                            then
2133                               Add_To_Object_Path (Data.Library_Dir, In_Tree);
2134                            else
2135                               Add_To_Object_Path
2136                                 (Data.Object_Directory, In_Tree);
2137                            end if;
2138
2139                         --  For a non-library project, add the object
2140                         --  directory, if it is not a virtual project, and
2141                         --  if there are Ada sources. If there are no Ada
2142                         --  sources, adding the object directory could
2143                         --  disrupt the order of the object dirs in the path.
2144
2145                         elsif not Data.Virtual
2146                           and then In_Tree.Projects.Table
2147                                      (Project).Ada_Sources_Present
2148                         then
2149                            Add_To_Object_Path
2150                              (Data.Object_Directory, In_Tree);
2151                         end if;
2152                      end if;
2153                   end if;
2154
2155                   --  Call Add to the project being extended, if any
2156
2157                   if Data.Extends /= No_Project then
2158                      Recursive_Add (Data.Extends);
2159                   end if;
2160
2161                   --  Call Add for each imported project, if any
2162
2163                   while List /= Empty_Project_List loop
2164                      Recursive_Add
2165                        (In_Tree.Project_Lists.Table
2166                           (List).Project);
2167                      List :=
2168                        In_Tree.Project_Lists.Table (List).Next;
2169                   end loop;
2170                end;
2171             end if;
2172          end Recursive_Add;
2173
2174       begin
2175          Source_Path_Table.Set_Last (In_Tree.Private_Part.Source_Paths, 0);
2176          Object_Path_Table.Set_Last (In_Tree.Private_Part.Object_Paths, 0);
2177
2178          for Index in Project_Table.First ..
2179                       Project_Table.Last (In_Tree.Projects)
2180          loop
2181             In_Tree.Projects.Table (Index).Seen := False;
2182          end loop;
2183
2184          Recursive_Add (Proj);
2185       end Add;
2186
2187    --  Start of processing for Set_Ada_Paths
2188
2189    begin
2190       --  If it is the first time we call this procedure for
2191       --  this project, compute the source path and/or the object path.
2192
2193       if In_Tree.Projects.Table (Project).Include_Path_File =
2194         No_Name
2195       then
2196          Process_Source_Dirs := True;
2197          Create_New_Path_File
2198            (In_Tree, Source_FD,
2199             In_Tree.Projects.Table (Project).Include_Path_File);
2200       end if;
2201
2202       --  For the object path, we make a distinction depending on
2203       --  Including_Libraries.
2204
2205       if Including_Libraries then
2206          if In_Tree.Projects.Table
2207            (Project).Objects_Path_File_With_Libs = No_Name
2208          then
2209             Process_Object_Dirs := True;
2210             Create_New_Path_File
2211               (In_Tree, Object_FD, In_Tree.Projects.Table (Project).
2212                                            Objects_Path_File_With_Libs);
2213          end if;
2214
2215       else
2216          if In_Tree.Projects.Table
2217               (Project).Objects_Path_File_Without_Libs = No_Name
2218          then
2219             Process_Object_Dirs := True;
2220             Create_New_Path_File
2221               (In_Tree, Object_FD, In_Tree.Projects.Table (Project).
2222                                            Objects_Path_File_Without_Libs);
2223          end if;
2224       end if;
2225
2226       --  If there is something to do, set Seen to False for all projects,
2227       --  then call the recursive procedure Add for Project.
2228
2229       if Process_Source_Dirs or Process_Object_Dirs then
2230          Add (Project);
2231       end if;
2232
2233       --  Write and close any file that has been created.
2234
2235       if Source_FD /= Invalid_FD then
2236          for Index in Source_Path_Table.First ..
2237                       Source_Path_Table.Last
2238                         (In_Tree.Private_Part.Source_Paths)
2239          loop
2240             Get_Name_String (In_Tree.Private_Part.Source_Paths.Table (Index));
2241             Name_Len := Name_Len + 1;
2242             Name_Buffer (Name_Len) := ASCII.LF;
2243             Len := Write (Source_FD, Name_Buffer (1)'Address, Name_Len);
2244
2245             if Len /= Name_Len then
2246                Prj.Com.Fail ("disk full");
2247             end if;
2248          end loop;
2249
2250          Close (Source_FD, Status);
2251
2252          if not Status then
2253             Prj.Com.Fail ("disk full");
2254          end if;
2255       end if;
2256
2257       if Object_FD /= Invalid_FD then
2258          for Index in Object_Path_Table.First ..
2259                       Object_Path_Table.Last
2260                         (In_Tree.Private_Part.Object_Paths)
2261          loop
2262             Get_Name_String (In_Tree.Private_Part.Object_Paths.Table (Index));
2263             Name_Len := Name_Len + 1;
2264             Name_Buffer (Name_Len) := ASCII.LF;
2265             Len := Write (Object_FD, Name_Buffer (1)'Address, Name_Len);
2266
2267             if Len /= Name_Len then
2268                Prj.Com.Fail ("disk full");
2269             end if;
2270          end loop;
2271
2272          Close (Object_FD, Status);
2273
2274          if not Status then
2275             Prj.Com.Fail ("disk full");
2276          end if;
2277       end if;
2278
2279       --  Set the env vars, if they need to be changed, and set the
2280       --  corresponding flags.
2281
2282       if Current_Source_Path_File /=
2283            In_Tree.Projects.Table (Project).Include_Path_File
2284       then
2285          Current_Source_Path_File :=
2286            In_Tree.Projects.Table (Project).Include_Path_File;
2287          Set_Path_File_Var
2288            (Project_Include_Path_File,
2289             Get_Name_String (Current_Source_Path_File));
2290          Ada_Prj_Include_File_Set := True;
2291       end if;
2292
2293       if Including_Libraries then
2294          if Current_Object_Path_File
2295            /= In_Tree.Projects.Table
2296                 (Project).Objects_Path_File_With_Libs
2297          then
2298             Current_Object_Path_File :=
2299               In_Tree.Projects.Table
2300                 (Project).Objects_Path_File_With_Libs;
2301             Set_Path_File_Var
2302               (Project_Objects_Path_File,
2303                Get_Name_String (Current_Object_Path_File));
2304             Ada_Prj_Objects_File_Set := True;
2305          end if;
2306
2307       else
2308          if Current_Object_Path_File /=
2309            In_Tree.Projects.Table
2310              (Project).Objects_Path_File_Without_Libs
2311          then
2312             Current_Object_Path_File :=
2313               In_Tree.Projects.Table
2314                 (Project).Objects_Path_File_Without_Libs;
2315             Set_Path_File_Var
2316               (Project_Objects_Path_File,
2317                Get_Name_String (Current_Object_Path_File));
2318             Ada_Prj_Objects_File_Set := True;
2319          end if;
2320       end if;
2321    end Set_Ada_Paths;
2322
2323    ---------------------------------------------
2324    -- Set_Mapping_File_Initial_State_To_Empty --
2325    ---------------------------------------------
2326
2327    procedure Set_Mapping_File_Initial_State_To_Empty is
2328    begin
2329       Fill_Mapping_File := False;
2330    end Set_Mapping_File_Initial_State_To_Empty;
2331
2332    -----------------------
2333    -- Set_Path_File_Var --
2334    -----------------------
2335
2336    procedure Set_Path_File_Var (Name : String; Value : String) is
2337       Host_Spec : String_Access := To_Host_File_Spec (Value);
2338
2339    begin
2340       if Host_Spec = null then
2341          Prj.Com.Fail
2342            ("could not convert file name """, Value, """ to host spec");
2343       else
2344          Setenv (Name, Host_Spec.all);
2345          Free (Host_Spec);
2346       end if;
2347    end Set_Path_File_Var;
2348
2349    -----------------------
2350    -- Spec_Path_Name_Of --
2351    -----------------------
2352
2353    function Spec_Path_Name_Of
2354      (Unit : Unit_Id; In_Tree : Project_Tree_Ref) return String
2355    is
2356       Data : Unit_Data := In_Tree.Units.Table (Unit);
2357
2358    begin
2359       if Data.File_Names (Specification).Path = No_Name then
2360          declare
2361             Current_Source : String_List_Id :=
2362               In_Tree.Projects.Table
2363                 (Data.File_Names (Specification).Project).Sources;
2364             Path : GNAT.OS_Lib.String_Access;
2365
2366          begin
2367             Data.File_Names (Specification).Path :=
2368               Data.File_Names (Specification).Name;
2369
2370             while Current_Source /= Nil_String loop
2371                Path := Locate_Regular_File
2372                  (Namet.Get_Name_String
2373                   (Data.File_Names (Specification).Name),
2374                   Namet.Get_Name_String
2375                     (In_Tree.String_Elements.Table
2376                        (Current_Source).Value));
2377
2378                if Path /= null then
2379                   Name_Len := Path'Length;
2380                   Name_Buffer (1 .. Name_Len) := Path.all;
2381                   Data.File_Names (Specification).Path := Name_Enter;
2382                   exit;
2383                else
2384                   Current_Source :=
2385                     In_Tree.String_Elements.Table
2386                       (Current_Source).Next;
2387                end if;
2388             end loop;
2389
2390             In_Tree.Units.Table (Unit) := Data;
2391          end;
2392       end if;
2393
2394       return Namet.Get_Name_String (Data.File_Names (Specification).Path);
2395    end Spec_Path_Name_Of;
2396
2397    ---------------------------
2398    -- Ultimate_Extension_Of --
2399    ---------------------------
2400
2401    function Ultimate_Extension_Of
2402      (Project : Project_Id; In_Tree : Project_Tree_Ref) return Project_Id
2403    is
2404       Result : Project_Id := Project;
2405
2406    begin
2407       while In_Tree.Projects.Table (Result).Extended_By /=
2408         No_Project
2409       loop
2410          Result := In_Tree.Projects.Table (Result).Extended_By;
2411       end loop;
2412
2413       return Result;
2414    end Ultimate_Extension_Of;
2415
2416 end Prj.Env;