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