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