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