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