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       --  ??? requires a comment
 576
 577       procedure Check_Temp_File;
 578       --  Check that a temporary file has been opened.
 579       --  If not, create one, and put its name in the project data,
 580       --  with the indication that it is a temporary file.
 581
 582       procedure Put
 583         (Unit_Name : Name_Id;
 584          File_Name : Name_Id;
 585          Unit_Kind : Spec_Or_Body);
 586       --  Put an SFN pragma in the temporary file
 587
 588       procedure Put (File : File_Descriptor; S : String);
 589       procedure Put_Line (File : File_Descriptor; S : String);
 590       --  Output procedures, analogous to normal Text_IO procs of same name
 591
 592       -----------
 593       -- Check --
 594       -----------
 595
 596       procedure Check (Project : Project_Id) is
 597          Data : constant Project_Data := Projects.Table (Project);
 598
 599       begin
 600          if Current_Verbosity = High then
 601             Write_Str ("Checking project file """);
 602             Write_Str (Namet.Get_Name_String (Data.Name));
 603             Write_Str (""".");
 604             Write_Eol;
 605          end if;
 606
 607          --  Is this project in the list of the visited project?
 608
 609          Current_Project := First_Project;
 610          while Current_Project /= Empty_Project_List
 611            and then Project_Lists.Table (Current_Project).Project /= Project
 612          loop
 613             Current_Project := Project_Lists.Table (Current_Project).Next;
 614          end loop;
 615
 616          --  If it is not, put it in the list, and visit it
 617
 618          if Current_Project = Empty_Project_List then
 619             Project_Lists.Increment_Last;
 620             Project_Lists.Table (Project_Lists.Last) :=
 621               (Project => Project, Next => First_Project);
 622             First_Project := Project_Lists.Last;
 623
 624             --  Is the naming scheme of this project one that we know?
 625
 626             Current_Naming := Default_Naming;
 627             while Current_Naming <= Namings.Last and then
 628               not Same_Naming_Scheme
 629               (Left => Namings.Table (Current_Naming),
 630                Right => Data.Naming) loop
 631                Current_Naming := Current_Naming + 1;
 632             end loop;
 633
 634             --  If we don't know it, add it
 635
 636             if Current_Naming > Namings.Last then
 637                Namings.Increment_Last;
 638                Namings.Table (Namings.Last) := Data.Naming;
 639
 640                --  We need a temporary file to be created
 641
 642                Check_Temp_File;
 643
 644                --  Put the SFN pragmas for the naming scheme
 645
 646                --  Spec
 647
 648                Put_Line
 649                  (File, "pragma Source_File_Name_Project");
 650                Put_Line
 651                  (File, "  (Spec_File_Name  => ""*" &
 652                   Namet.Get_Name_String (Data.Naming.Current_Spec_Suffix) &
 653                   """,");
 654                Put_Line
 655                  (File, "   Casing          => " &
 656                   Image (Data.Naming.Casing) & ",");
 657                Put_Line
 658                  (File, "   Dot_Replacement => """ &
 659                  Namet.Get_Name_String (Data.Naming.Dot_Replacement) &
 660                   """);");
 661
 662                --  and body
 663
 664                Put_Line
 665                  (File, "pragma Source_File_Name_Project");
 666                Put_Line
 667                  (File, "  (Body_File_Name  => ""*" &
 668                   Namet.Get_Name_String (Data.Naming.Current_Body_Suffix) &
 669                   """,");
 670                Put_Line
 671                  (File, "   Casing          => " &
 672                   Image (Data.Naming.Casing) & ",");
 673                Put_Line
 674                  (File, "   Dot_Replacement => """ &
 675                   Namet.Get_Name_String (Data.Naming.Dot_Replacement) &
 676                   """);");
 677
 678                --  and maybe separate
 679
 680                if
 681                  Data.Naming.Current_Body_Suffix /= Data.Naming.Separate_Suffix
 682                then
 683                   Put_Line
 684                     (File, "pragma Source_File_Name_Project");
 685                   Put_Line
 686                     (File, "  (Subunit_File_Name  => ""*" &
 687                      Namet.Get_Name_String (Data.Naming.Separate_Suffix) &
 688                      """,");
 689                   Put_Line
 690                     (File, "   Casing          => " &
 691                      Image (Data.Naming.Casing) &
 692                      ",");
 693                   Put_Line
 694                     (File, "   Dot_Replacement => """ &
 695                      Namet.Get_Name_String (Data.Naming.Dot_Replacement) &
 696                      """);");
 697                end if;
 698             end if;
 699
 700             if Data.Extends /= No_Project then
 701                Check (Data.Extends);
 702             end if;
 703
 704             declare
 705                Current : Project_List := Data.Imported_Projects;
 706
 707             begin
 708                while Current /= Empty_Project_List loop
 709                   Check (Project_Lists.Table (Current).Project);
 710                   Current := Project_Lists.Table (Current).Next;
 711                end loop;
 712             end;
 713          end if;
 714       end Check;
 715
 716       ---------------------
 717       -- Check_Temp_File --
 718       ---------------------
 719
 720       procedure Check_Temp_File is
 721       begin
 722          if File = Invalid_FD then
 723             Tempdir.Create_Temp_File (File, Name => File_Name);
 724
 725             if File = Invalid_FD then
 726                Prj.Com.Fail
 727                  ("unable to create temporary configuration pragmas file");
 728             elsif Opt.Verbose_Mode then
 729                Write_Str ("Creating temp file """);
 730                Write_Str (Get_Name_String (File_Name));
 731                Write_Line ("""");
 732             end if;
 733          end if;
 734       end Check_Temp_File;
 735
 736       ---------
 737       -- Put --
 738       ---------
 739
 740       procedure Put
 741         (Unit_Name : Name_Id;
 742          File_Name : Name_Id;
 743          Unit_Kind : Spec_Or_Body)
 744       is
 745       begin
 746          --  A temporary file needs to be open
 747
 748          Check_Temp_File;
 749
 750          --  Put the pragma SFN for the unit kind (spec or body)
 751
 752          Put (File, "pragma Source_File_Name_Project (");
 753          Put (File, Namet.Get_Name_String (Unit_Name));
 754
 755          if Unit_Kind = Specification then
 756             Put (File, ", Spec_File_Name => """);
 757          else
 758             Put (File, ", Body_File_Name => """);
 759          end if;
 760
 761          Put (File, Namet.Get_Name_String (File_Name));
 762          Put_Line (File, """);");
 763       end Put;
 764
 765       procedure Put (File : File_Descriptor; S : String) is
 766          Last : Natural;
 767
 768       begin
 769          Last := Write (File, S (S'First)'Address, S'Length);
 770
 771          if Last /= S'Length then
 772             Prj.Com.Fail ("Disk full");
 773          end if;
 774
 775          if Current_Verbosity = High then
 776             Write_Str (S);
 777          end if;
 778       end Put;
 779
 780       --------------
 781       -- Put_Line --
 782       --------------
 783
 784       procedure Put_Line (File : File_Descriptor; S : String) is
 785          S0   : String (1 .. S'Length + 1);
 786          Last : Natural;
 787
 788       begin
 789          --  Add an ASCII.LF to the string. As this gnat.adc is supposed to
 790          --  be used only by the compiler, we don't care about the characters
 791          --  for the end of line. In fact we could have put a space, but
 792          --  it is more convenient to be able to read gnat.adc during
 793          --  development, for which the ASCII.LF is fine.
 794
 795          S0 (1 .. S'Length) := S;
 796          S0 (S0'Last) := ASCII.LF;
 797          Last := Write (File, S0'Address, S0'Length);
 798
 799          if Last /= S'Length + 1 then
 800             Prj.Com.Fail ("Disk full");
 801          end if;
 802
 803          if Current_Verbosity = High then
 804             Write_Line (S);
 805          end if;
 806       end Put_Line;
 807
 808    --  Start of processing for Create_Config_Pragmas_File
 809
 810    begin
 811       if not Projects.Table (For_Project).Config_Checked then
 812
 813          --  Remove any memory of processed naming schemes, if any
 814
 815          Namings.Set_Last (Default_Naming);
 816
 817          --  Check the naming schemes
 818
 819          Check (For_Project);
 820
 821          --  Visit all the units and process those that need an SFN pragma
 822
 823          while Current_Unit <= Units.Last loop
 824             declare
 825                Unit : constant Unit_Data :=
 826                  Units.Table (Current_Unit);
 827
 828             begin
 829                if Unit.File_Names (Specification).Needs_Pragma then
 830                   Put (Unit.Name,
 831                        Unit.File_Names (Specification).Name,
 832                        Specification);
 833                end if;
 834
 835                if Unit.File_Names (Body_Part).Needs_Pragma then
 836                   Put (Unit.Name,
 837                        Unit.File_Names (Body_Part).Name,
 838                        Body_Part);
 839                end if;
 840
 841                Current_Unit := Current_Unit + 1;
 842             end;
 843          end loop;
 844
 845          --  If there are no non standard naming scheme, issue the GNAT
 846          --  standard naming scheme. This will tell the compiler that
 847          --  a project file is used and will forbid any pragma SFN.
 848
 849          if File = Invalid_FD then
 850             Check_Temp_File;
 851
 852             Put_Line (File, "pragma Source_File_Name_Project");
 853             Put_Line (File, "   (Spec_File_Name  => ""*.ads"",");
 854             Put_Line (File, "    Dot_Replacement => ""-"",");
 855             Put_Line (File, "    Casing          => lowercase);");
 856
 857             Put_Line (File, "pragma Source_File_Name_Project");
 858             Put_Line (File, "   (Body_File_Name  => ""*.adb"",");
 859             Put_Line (File, "    Dot_Replacement => ""-"",");
 860             Put_Line (File, "    Casing          => lowercase);");
 861          end if;
 862
 863          --  Close the temporary file
 864
 865          GNAT.OS_Lib.Close (File, Status);
 866
 867          if not Status then
 868             Prj.Com.Fail ("disk full");
 869          end if;
 870
 871          if Opt.Verbose_Mode then
 872             Write_Str ("Closing configuration file """);
 873             Write_Str (Get_Name_String (File_Name));
 874             Write_Line ("""");
 875          end if;
 876
 877          Projects.Table (For_Project).Config_File_Name := File_Name;
 878          Projects.Table (For_Project).Config_File_Temp := True;
 879
 880          Projects.Table (For_Project).Config_Checked := True;
 881       end if;
 882    end Create_Config_Pragmas_File;
 883
 884    -------------------------
 885    -- Create_Mapping_File --
 886    -------------------------
 887
 888    procedure Create_Mapping_File
 889      (Project : Project_Id;
 890       Name    : out Name_Id)
 891    is
 892       File          : File_Descriptor := Invalid_FD;
 893       The_Unit_Data : Unit_Data;
 894       Data          : File_Name_Data;
 895
 896       Status : Boolean;
 897       --  For call to Close
 898
 899       Present : Project_Flags (No_Project .. Projects.Last) :=
 900         (others => False);
 901       --  For each project in the closure of Project, the corresponding flag
 902       --  will be set to True;
 903
 904       procedure Put_Name_Buffer;
 905       --  Put the line contained in the Name_Buffer in the mapping file
 906
 907       procedure Put_Data (Spec : Boolean);
 908       --  Put the mapping of the spec or body contained in Data in the file
 909       --  (3 lines).
 910
 911       procedure Recursive_Flag (Prj : Project_Id);
 912       --  Set the flags corresponding to Prj, the projects it imports
 913       --  (directly or indirectly) or extends to True. Call itself recursively.
 914
 915       ---------
 916       -- Put --
 917       ---------
 918
 919       procedure Put_Name_Buffer is
 920          Last : Natural;
 921
 922       begin
 923          Name_Len := Name_Len + 1;
 924          Name_Buffer (Name_Len) := ASCII.LF;
 925          Last := Write (File, Name_Buffer (1)'Address, Name_Len);
 926
 927          if Last /= Name_Len then
 928             Prj.Com.Fail ("Disk full");
 929          end if;
 930       end Put_Name_Buffer;
 931
 932       --------------
 933       -- Put_Data --
 934       --------------
 935
 936       procedure Put_Data (Spec : Boolean) is
 937       begin
 938          --  Line with the unit name
 939
 940          Get_Name_String (The_Unit_Data.Name);
 941          Name_Len := Name_Len + 1;
 942          Name_Buffer (Name_Len) := '%';
 943          Name_Len := Name_Len + 1;
 944
 945          if Spec then
 946             Name_Buffer (Name_Len) := 's';
 947          else
 948             Name_Buffer (Name_Len) := 'b';
 949          end if;
 950
 951          Put_Name_Buffer;
 952
 953          --  Line with the file name
 954
 955          Get_Name_String (Data.Name);
 956          Put_Name_Buffer;
 957
 958          --  Line with the path name
 959
 960          Get_Name_String (Data.Path);
 961          Put_Name_Buffer;
 962
 963       end Put_Data;
 964
 965       --------------------
 966       -- Recursive_Flag --
 967       --------------------
 968
 969       procedure Recursive_Flag (Prj : Project_Id) is
 970          Imported : Project_List;
 971          Proj     : Project_Id;
 972
 973       begin
 974          --  Nothing to do for non existent project or project that has
 975          --  already been flagged.
 976
 977          if Prj = No_Project or else Present (Prj) then
 978             return;
 979          end if;
 980
 981          --  Flag the current project
 982
 983          Present (Prj) := True;
 984          Imported := Projects.Table (Prj).Imported_Projects;
 985
 986          --  Call itself for each project directly imported
 987
 988          while Imported /= Empty_Project_List loop
 989             Proj := Project_Lists.Table (Imported).Project;
 990             Imported := Project_Lists.Table (Imported).Next;
 991             Recursive_Flag (Proj);
 992          end loop;
 993
 994          --  Call itself for an eventual project being extended
 995
 996          Recursive_Flag (Projects.Table (Prj).Extends);
 997       end Recursive_Flag;
 998
 999    --  Start of processing for Create_Mapping_File
1000
1001    begin
1002       --  Flag the necessary projects
1003
1004       Recursive_Flag (Project);
1005
1006       --  Create the temporary file
1007
1008       Tempdir.Create_Temp_File (File, Name => Name);
1009
1010       if File = Invalid_FD then
1011          Prj.Com.Fail ("unable to create temporary mapping file");
1012
1013       elsif Opt.Verbose_Mode then
1014          Write_Str ("Creating temp mapping file """);
1015          Write_Str (Get_Name_String (Name));
1016          Write_Line ("""");
1017       end if;
1018
1019       if Fill_Mapping_File then
1020          --  For all units in table Units
1021
1022          for Unit in 1 .. Units.Last loop
1023             The_Unit_Data := Units.Table (Unit);
1024
1025             --  If the unit has a valid name
1026
1027             if The_Unit_Data.Name /= No_Name then
1028                Data := The_Unit_Data.File_Names (Specification);
1029
1030                --  If there is a spec, put it mapping in the file if it is
1031                --  from a project in the closure of Project.
1032
1033                if Data.Name /= No_Name and then Present (Data.Project) then
1034                   Put_Data (Spec => True);
1035                end if;
1036
1037                Data := The_Unit_Data.File_Names (Body_Part);
1038
1039                --  If there is a body (or subunit) put its mapping in the file
1040                --  if it is from a project in the closure of Project.
1041
1042                if Data.Name /= No_Name and then Present (Data.Project) then
1043                   Put_Data (Spec => False);
1044                end if;
1045
1046             end if;
1047          end loop;
1048       end if;
1049
1050       GNAT.OS_Lib.Close (File, Status);
1051
1052       if not Status then
1053          Prj.Com.Fail ("disk full");
1054       end if;
1055    end Create_Mapping_File;
1056
1057    --------------------------
1058    -- Create_New_Path_File --
1059    --------------------------
1060
1061    procedure Create_New_Path_File
1062      (Path_FD   : out File_Descriptor;
1063       Path_Name : out Name_Id)
1064    is
1065    begin
1066       Tempdir.Create_Temp_File (Path_FD, Path_Name);
1067
1068       if Path_Name /= No_Name then
1069
1070          --  Record the name, so that the temp path file will be deleted
1071          --  at the end of the program.
1072
1073          Path_Files.Increment_Last;
1074          Path_Files.Table (Path_Files.Last) := Path_Name;
1075       end if;
1076    end Create_New_Path_File;
1077
1078    ---------------------------
1079    -- Delete_All_Path_Files --
1080    ---------------------------
1081
1082    procedure Delete_All_Path_Files is
1083       Disregard : Boolean := True;
1084
1085    begin
1086       for Index in 1 .. Path_Files.Last loop
1087          if Path_Files.Table (Index) /= No_Name then
1088             Delete_File
1089               (Get_Name_String (Path_Files.Table (Index)), Disregard);
1090          end if;
1091       end loop;
1092
1093       --  If any of the environment variables ADA_PRJ_INCLUDE_FILE or
1094       --  ADA_PRJ_OBJECTS_FILE has been set, then reset their value to
1095       --  the empty string. On VMS, this has the effect of deassigning
1096       --  the logical names.
1097
1098       if Ada_Prj_Include_File_Set then
1099          Setenv (Project_Include_Path_File, "");
1100          Ada_Prj_Include_File_Set := False;
1101       end if;
1102
1103       if Ada_Prj_Objects_File_Set then
1104          Setenv (Project_Objects_Path_File, "");
1105          Ada_Prj_Objects_File_Set := False;
1106       end if;
1107    end Delete_All_Path_Files;
1108
1109    ------------------------------------
1110    -- File_Name_Of_Library_Unit_Body --
1111    ------------------------------------
1112
1113    function File_Name_Of_Library_Unit_Body
1114      (Name              : String;
1115       Project           : Project_Id;
1116       Main_Project_Only : Boolean := True;
1117       Full_Path         : Boolean := False) return String
1118    is
1119       The_Project   : Project_Id := Project;
1120       Data          : Project_Data := Projects.Table (Project);
1121       Original_Name : String := Name;
1122
1123       Extended_Spec_Name : String :=
1124                              Name & Namet.Get_Name_String
1125                                       (Data.Naming.Current_Spec_Suffix);
1126       Extended_Body_Name : String :=
1127                              Name & Namet.Get_Name_String
1128                                       (Data.Naming.Current_Body_Suffix);
1129
1130       Unit : Unit_Data;
1131
1132       The_Original_Name : Name_Id;
1133       The_Spec_Name     : Name_Id;
1134       The_Body_Name     : Name_Id;
1135
1136    begin
1137       Canonical_Case_File_Name (Original_Name);
1138       Name_Len := Original_Name'Length;
1139       Name_Buffer (1 .. Name_Len) := Original_Name;
1140       The_Original_Name := Name_Find;
1141
1142       Canonical_Case_File_Name (Extended_Spec_Name);
1143       Name_Len := Extended_Spec_Name'Length;
1144       Name_Buffer (1 .. Name_Len) := Extended_Spec_Name;
1145       The_Spec_Name := Name_Find;
1146
1147       Canonical_Case_File_Name (Extended_Body_Name);
1148       Name_Len := Extended_Body_Name'Length;
1149       Name_Buffer (1 .. Name_Len) := Extended_Body_Name;
1150       The_Body_Name := Name_Find;
1151
1152       if Current_Verbosity = High then
1153          Write_Str  ("Looking for file name of """);
1154          Write_Str  (Name);
1155          Write_Char ('"');
1156          Write_Eol;
1157          Write_Str  ("   Extended Spec Name = """);
1158          Write_Str  (Extended_Spec_Name);
1159          Write_Char ('"');
1160          Write_Eol;
1161          Write_Str  ("   Extended Body Name = """);
1162          Write_Str  (Extended_Body_Name);
1163          Write_Char ('"');
1164          Write_Eol;
1165       end if;
1166
1167       --  For extending project, search in the extended project
1168       --  if the source is not found. For non extending projects,
1169       --  this loop will be run only once.
1170
1171       loop
1172          --  Loop through units
1173          --  Should have comment explaining reverse ???
1174
1175          for Current in reverse Units.First .. Units.Last loop
1176             Unit := Units.Table (Current);
1177
1178             --  Check for body
1179
1180             if not Main_Project_Only
1181               or else Unit.File_Names (Body_Part).Project = The_Project
1182             then
1183                declare
1184                   Current_Name : constant Name_Id :=
1185                                    Unit.File_Names (Body_Part).Name;
1186
1187                begin
1188                   --  Case of a body present
1189
1190                   if Current_Name /= No_Name then
1191                      if Current_Verbosity = High then
1192                         Write_Str  ("   Comparing with """);
1193                         Write_Str  (Get_Name_String (Current_Name));
1194                         Write_Char ('"');
1195                         Write_Eol;
1196                      end if;
1197
1198                      --  If it has the name of the original name,
1199                      --  return the original name
1200
1201                      if Unit.Name = The_Original_Name
1202                        or else Current_Name = The_Original_Name
1203                      then
1204                         if Current_Verbosity = High then
1205                            Write_Line ("   OK");
1206                         end if;
1207
1208                         if Full_Path then
1209                            return Get_Name_String
1210                              (Unit.File_Names (Body_Part).Path);
1211
1212                         else
1213                            return Get_Name_String (Current_Name);
1214                         end if;
1215
1216                         --  If it has the name of the extended body name,
1217                         --  return the extended body name
1218
1219                      elsif Current_Name = The_Body_Name then
1220                         if Current_Verbosity = High then
1221                            Write_Line ("   OK");
1222                         end if;
1223
1224                         if Full_Path then
1225                            return Get_Name_String
1226                              (Unit.File_Names (Body_Part).Path);
1227
1228                         else
1229                            return Extended_Body_Name;
1230                         end if;
1231
1232                      else
1233                         if Current_Verbosity = High then
1234                            Write_Line ("   not good");
1235                         end if;
1236                      end if;
1237                   end if;
1238                end;
1239             end if;
1240
1241             --  Check for spec
1242
1243             if not Main_Project_Only
1244               or else Unit.File_Names (Specification).Project = The_Project
1245             then
1246                declare
1247                   Current_Name : constant Name_Id :=
1248                                    Unit.File_Names (Specification).Name;
1249
1250                begin
1251                   --  Case of spec present
1252
1253                   if Current_Name /= No_Name then
1254                      if Current_Verbosity = High then
1255                         Write_Str  ("   Comparing with """);
1256                         Write_Str  (Get_Name_String (Current_Name));
1257                         Write_Char ('"');
1258                         Write_Eol;
1259                      end if;
1260
1261                      --  If name same as original name, return original name
1262
1263                      if Unit.Name = The_Original_Name
1264                        or else Current_Name = The_Original_Name
1265                      then
1266                         if Current_Verbosity = High then
1267                            Write_Line ("   OK");
1268                         end if;
1269
1270
1271                         if Full_Path then
1272                            return Get_Name_String
1273                              (Unit.File_Names (Specification).Path);
1274                         else
1275                            return Get_Name_String (Current_Name);
1276                         end if;
1277
1278                         --  If it has the same name as the extended spec name,
1279                         --  return the extended spec name.
1280
1281                      elsif Current_Name = The_Spec_Name then
1282                         if Current_Verbosity = High then
1283                            Write_Line ("   OK");
1284                         end if;
1285
1286                         if Full_Path then
1287                            return Get_Name_String
1288                              (Unit.File_Names (Specification).Path);
1289                         else
1290                            return Extended_Spec_Name;
1291                         end if;
1292
1293                      else
1294                         if Current_Verbosity = High then
1295                            Write_Line ("   not good");
1296                         end if;
1297                      end if;
1298                   end if;
1299                end;
1300             end if;
1301          end loop;
1302
1303          --  If we are not in an extending project, give up
1304
1305          exit when (not Main_Project_Only) or else Data.Extends = No_Project;
1306
1307          --  Otherwise, look in the project we are extending
1308
1309          The_Project := Data.Extends;
1310          Data := Projects.Table (The_Project);
1311       end loop;
1312
1313       --  We don't know this file name, return an empty string
1314
1315       return "";
1316    end File_Name_Of_Library_Unit_Body;
1317
1318    -------------------------
1319    -- For_All_Object_Dirs --
1320    -------------------------
1321
1322    procedure For_All_Object_Dirs (Project : Project_Id) is
1323       Seen : Project_List := Empty_Project_List;
1324
1325       procedure Add (Project : Project_Id);
1326       --  Process a project. Remember the processes visited to avoid
1327       --  processing a project twice. Recursively process an eventual
1328       --  extended project, and all imported projects.
1329
1330       ---------
1331       -- Add --
1332       ---------
1333
1334       procedure Add (Project : Project_Id) is
1335          Data : constant Project_Data := Projects.Table (Project);
1336          List : Project_List := Data.Imported_Projects;
1337
1338       begin
1339          --  If the list of visited project is empty, then
1340          --  for sure we never visited this project.
1341
1342          if Seen = Empty_Project_List then
1343             Project_Lists.Increment_Last;
1344             Seen := Project_Lists.Last;
1345             Project_Lists.Table (Seen) :=
1346               (Project => Project, Next => Empty_Project_List);
1347
1348          else
1349             --  Check if the project is in the list
1350
1351             declare
1352                Current : Project_List := Seen;
1353
1354             begin
1355                loop
1356                   --  If it is, then there is nothing else to do
1357
1358                   if Project_Lists.Table (Current).Project = Project then
1359                      return;
1360                   end if;
1361
1362                   exit when Project_Lists.Table (Current).Next =
1363                     Empty_Project_List;
1364                   Current := Project_Lists.Table (Current).Next;
1365                end loop;
1366
1367                --  This project has never been visited, add it
1368                --  to the list.
1369
1370                Project_Lists.Increment_Last;
1371                Project_Lists.Table (Current).Next := Project_Lists.Last;
1372                Project_Lists.Table (Project_Lists.Last) :=
1373                  (Project => Project, Next => Empty_Project_List);
1374             end;
1375          end if;
1376
1377          --  If there is an object directory, call Action
1378          --  with its name
1379
1380          if Data.Object_Directory /= No_Name then
1381             Get_Name_String (Data.Object_Directory);
1382             Action (Name_Buffer (1 .. Name_Len));
1383          end if;
1384
1385          --  If we are extending a project, visit it
1386
1387          if Data.Extends /= No_Project then
1388             Add (Data.Extends);
1389          end if;
1390
1391          --  And visit all imported projects
1392
1393          while List /= Empty_Project_List loop
1394             Add (Project_Lists.Table (List).Project);
1395             List := Project_Lists.Table (List).Next;
1396          end loop;
1397       end Add;
1398
1399    --  Start of processing for For_All_Object_Dirs
1400
1401    begin
1402       --  Visit this project, and its imported projects,
1403       --  recursively
1404
1405       Add (Project);
1406    end For_All_Object_Dirs;
1407
1408    -------------------------
1409    -- For_All_Source_Dirs --
1410    -------------------------
1411
1412    procedure For_All_Source_Dirs (Project : Project_Id) is
1413       Seen : Project_List := Empty_Project_List;
1414
1415       procedure Add (Project : Project_Id);
1416       --  Process a project. Remember the processes visited to avoid
1417       --  processing a project twice. Recursively process an eventual
1418       --  extended project, and all imported projects.
1419
1420       ---------
1421       -- Add --
1422       ---------
1423
1424       procedure Add (Project : Project_Id) is
1425          Data : constant Project_Data := Projects.Table (Project);
1426          List : Project_List := Data.Imported_Projects;
1427
1428       begin
1429          --  If the list of visited project is empty, then
1430          --  for sure we never visited this project.
1431
1432          if Seen = Empty_Project_List then
1433             Project_Lists.Increment_Last;
1434             Seen := Project_Lists.Last;
1435             Project_Lists.Table (Seen) :=
1436               (Project => Project, Next => Empty_Project_List);
1437
1438          else
1439             --  Check if the project is in the list
1440
1441             declare
1442                Current : Project_List := Seen;
1443
1444             begin
1445                loop
1446                   --  If it is, then there is nothing else to do
1447
1448                   if Project_Lists.Table (Current).Project = Project then
1449                      return;
1450                   end if;
1451
1452                   exit when Project_Lists.Table (Current).Next =
1453                     Empty_Project_List;
1454                   Current := Project_Lists.Table (Current).Next;
1455                end loop;
1456
1457                --  This project has never been visited, add it
1458                --  to the list.
1459
1460                Project_Lists.Increment_Last;
1461                Project_Lists.Table (Current).Next := Project_Lists.Last;
1462                Project_Lists.Table (Project_Lists.Last) :=
1463                  (Project => Project, Next => Empty_Project_List);
1464             end;
1465          end if;
1466
1467          declare
1468             Current    : String_List_Id := Data.Source_Dirs;
1469             The_String : String_Element;
1470
1471          begin
1472             --  If there are Ada sources, call action with the name of every
1473             --  source directory.
1474
1475             if Projects.Table (Project).Sources_Present then
1476                while Current /= Nil_String loop
1477                   The_String := String_Elements.Table (Current);
1478                   Action (Get_Name_String (The_String.Value));
1479                   Current := The_String.Next;
1480                end loop;
1481             end if;
1482          end;
1483
1484          --  If we are extending a project, visit it
1485
1486          if Data.Extends /= No_Project then
1487             Add (Data.Extends);
1488          end if;
1489
1490          --  And visit all imported projects
1491
1492          while List /= Empty_Project_List loop
1493             Add (Project_Lists.Table (List).Project);
1494             List := Project_Lists.Table (List).Next;
1495          end loop;
1496       end Add;
1497
1498    --  Start of processing for For_All_Source_Dirs
1499
1500    begin
1501       --  Visit this project, and its imported projects recursively
1502
1503       Add (Project);
1504    end For_All_Source_Dirs;
1505
1506    -------------------
1507    -- Get_Reference --
1508    -------------------
1509
1510    procedure Get_Reference
1511      (Source_File_Name : String;
1512       Project          : out Project_Id;
1513       Path             : out Name_Id)
1514    is
1515    begin
1516       --  Body below could use some comments ???
1517
1518       if Current_Verbosity > Default then
1519          Write_Str ("Getting Reference_Of (""");
1520          Write_Str (Source_File_Name);
1521          Write_Str (""") ... ");
1522       end if;
1523
1524       declare
1525          Original_Name : String := Source_File_Name;
1526          Unit          : Unit_Data;
1527
1528       begin
1529          Canonical_Case_File_Name (Original_Name);
1530
1531          for Id in Units.First .. Units.Last loop
1532             Unit := Units.Table (Id);
1533
1534             if (Unit.File_Names (Specification).Name /= No_Name
1535                  and then
1536                    Namet.Get_Name_String
1537                      (Unit.File_Names (Specification).Name) = Original_Name)
1538               or else (Unit.File_Names (Specification).Path /= No_Name
1539                          and then
1540                            Namet.Get_Name_String
1541                            (Unit.File_Names (Specification).Path) =
1542                                                               Original_Name)
1543             then
1544                Project := Ultimate_Extension_Of
1545                             (Unit.File_Names (Specification).Project);
1546                Path := Unit.File_Names (Specification).Display_Path;
1547
1548                if Current_Verbosity > Default then
1549                   Write_Str ("Done: Specification.");
1550                   Write_Eol;
1551                end if;
1552
1553                return;
1554
1555             elsif (Unit.File_Names (Body_Part).Name /= No_Name
1556                     and then
1557                       Namet.Get_Name_String
1558                         (Unit.File_Names (Body_Part).Name) = Original_Name)
1559               or else (Unit.File_Names (Body_Part).Path /= No_Name
1560                          and then Namet.Get_Name_String
1561                                     (Unit.File_Names (Body_Part).Path) =
1562                                                              Original_Name)
1563             then
1564                Project := Ultimate_Extension_Of
1565                             (Unit.File_Names (Body_Part).Project);
1566                Path := Unit.File_Names (Body_Part).Display_Path;
1567
1568                if Current_Verbosity > Default then
1569                   Write_Str ("Done: Body.");
1570                   Write_Eol;
1571                end if;
1572
1573                return;
1574             end if;
1575          end loop;
1576       end;
1577
1578       Project := No_Project;
1579       Path    := No_Name;
1580
1581       if Current_Verbosity > Default then
1582          Write_Str ("Cannot be found.");
1583          Write_Eol;
1584       end if;
1585    end Get_Reference;
1586
1587    ----------------
1588    -- Initialize --
1589    ----------------
1590
1591    --  This is a place holder for possible required initialization in
1592    --  the future. In the current version no initialization is required.
1593
1594    procedure Initialize is
1595    begin
1596       null;
1597    end Initialize;
1598
1599    ------------------------------------
1600    -- Path_Name_Of_Library_Unit_Body --
1601    ------------------------------------
1602
1603    --  Could use some comments in the body here ???
1604
1605    function Path_Name_Of_Library_Unit_Body
1606      (Name    : String;
1607       Project : Project_Id) return String
1608    is
1609       Data          : constant Project_Data := Projects.Table (Project);
1610       Original_Name : String := Name;
1611
1612       Extended_Spec_Name : String :=
1613                              Name & Namet.Get_Name_String
1614                                      (Data.Naming.Current_Spec_Suffix);
1615       Extended_Body_Name : String :=
1616                              Name & Namet.Get_Name_String
1617                                      (Data.Naming.Current_Body_Suffix);
1618
1619       First   : Unit_Id := Units.First;
1620       Current : Unit_Id;
1621       Unit    : Unit_Data;
1622
1623    begin
1624       Canonical_Case_File_Name (Original_Name);
1625       Canonical_Case_File_Name (Extended_Spec_Name);
1626       Canonical_Case_File_Name (Extended_Body_Name);
1627
1628       if Current_Verbosity = High then
1629          Write_Str  ("Looking for path name of """);
1630          Write_Str  (Name);
1631          Write_Char ('"');
1632          Write_Eol;
1633          Write_Str  ("   Extended Spec Name = """);
1634          Write_Str  (Extended_Spec_Name);
1635          Write_Char ('"');
1636          Write_Eol;
1637          Write_Str  ("   Extended Body Name = """);
1638          Write_Str  (Extended_Body_Name);
1639          Write_Char ('"');
1640          Write_Eol;
1641       end if;
1642
1643       while First <= Units.Last
1644         and then Units.Table (First).File_Names (Body_Part).Project /= Project
1645       loop
1646          First := First + 1;
1647       end loop;
1648
1649       Current := First;
1650       while Current <= Units.Last loop
1651          Unit := Units.Table (Current);
1652
1653          if Unit.File_Names (Body_Part).Project = Project
1654            and then Unit.File_Names (Body_Part).Name /= No_Name
1655          then
1656             declare
1657                Current_Name : constant String :=
1658                  Namet.Get_Name_String (Unit.File_Names (Body_Part).Name);
1659             begin
1660                if Current_Verbosity = High then
1661                   Write_Str  ("   Comparing with """);
1662                   Write_Str  (Current_Name);
1663                   Write_Char ('"');
1664                   Write_Eol;
1665                end if;
1666
1667                if Current_Name = Original_Name then
1668                   if Current_Verbosity = High then
1669                      Write_Line ("   OK");
1670                   end if;
1671
1672                   return Body_Path_Name_Of (Current);
1673
1674                elsif Current_Name = Extended_Body_Name then
1675                   if Current_Verbosity = High then
1676                      Write_Line ("   OK");
1677                   end if;
1678
1679                   return Body_Path_Name_Of (Current);
1680
1681                else
1682                   if Current_Verbosity = High then
1683                      Write_Line ("   not good");
1684                   end if;
1685                end if;
1686             end;
1687
1688          elsif Unit.File_Names (Specification).Name /= No_Name then
1689             declare
1690                Current_Name : constant String :=
1691                                 Namet.Get_Name_String
1692                                   (Unit.File_Names (Specification).Name);
1693
1694             begin
1695                if Current_Verbosity = High then
1696                   Write_Str  ("   Comparing with """);
1697                   Write_Str  (Current_Name);
1698                   Write_Char ('"');
1699                   Write_Eol;
1700                end if;
1701
1702                if Current_Name = Original_Name then
1703                   if Current_Verbosity = High then
1704                      Write_Line ("   OK");
1705                   end if;
1706
1707                   return Spec_Path_Name_Of (Current);
1708
1709                elsif Current_Name = Extended_Spec_Name then
1710                   if Current_Verbosity = High then
1711                      Write_Line ("   OK");
1712                   end if;
1713
1714                   return Spec_Path_Name_Of (Current);
1715
1716                else
1717                   if Current_Verbosity = High then
1718                      Write_Line ("   not good");
1719                   end if;
1720                end if;
1721             end;
1722          end if;
1723          Current := Current + 1;
1724       end loop;
1725
1726       return "";
1727    end Path_Name_Of_Library_Unit_Body;
1728
1729    -------------------
1730    -- Print_Sources --
1731    -------------------
1732
1733    --  Could use some comments in this body ???
1734
1735    procedure Print_Sources is
1736       Unit : Unit_Data;
1737
1738    begin
1739       Write_Line ("List of Sources:");
1740
1741       for Id in Units.First .. Units.Last loop
1742          Unit := Units.Table (Id);
1743          Write_Str  ("   ");
1744          Write_Line (Namet.Get_Name_String (Unit.Name));
1745
1746          if Unit.File_Names (Specification).Name /= No_Name then
1747             if Unit.File_Names (Specification).Project = No_Project then
1748                Write_Line ("   No project");
1749
1750             else
1751                Write_Str  ("   Project: ");
1752                Get_Name_String
1753                  (Projects.Table
1754                    (Unit.File_Names (Specification).Project).Path_Name);
1755                Write_Line (Name_Buffer (1 .. Name_Len));
1756             end if;
1757
1758             Write_Str  ("      spec: ");
1759             Write_Line
1760               (Namet.Get_Name_String
1761                (Unit.File_Names (Specification).Name));
1762          end if;
1763
1764          if Unit.File_Names (Body_Part).Name /= No_Name then
1765             if Unit.File_Names (Body_Part).Project = No_Project then
1766                Write_Line ("   No project");
1767
1768             else
1769                Write_Str  ("   Project: ");
1770                Get_Name_String
1771                  (Projects.Table
1772                    (Unit.File_Names (Body_Part).Project).Path_Name);
1773                Write_Line (Name_Buffer (1 .. Name_Len));
1774             end if;
1775
1776             Write_Str  ("      body: ");
1777             Write_Line
1778               (Namet.Get_Name_String
1779                (Unit.File_Names (Body_Part).Name));
1780          end if;
1781       end loop;
1782
1783       Write_Line ("end of List of Sources.");
1784    end Print_Sources;
1785
1786    ----------------
1787    -- Project_Of --
1788    ----------------
1789
1790    function Project_Of
1791      (Name         : String;
1792       Main_Project : Project_Id) return Project_Id
1793    is
1794       Result : Project_Id := No_Project;
1795
1796       Original_Name : String := Name;
1797
1798       Data : constant Project_Data := Projects.Table (Main_Project);
1799
1800       Extended_Spec_Name : String :=
1801                              Name & Namet.Get_Name_String
1802                                       (Data.Naming.Current_Spec_Suffix);
1803       Extended_Body_Name : String :=
1804                              Name & Namet.Get_Name_String
1805                                       (Data.Naming.Current_Body_Suffix);
1806
1807       Unit : Unit_Data;
1808
1809       Current_Name : Name_Id;
1810
1811       The_Original_Name : Name_Id;
1812       The_Spec_Name     : Name_Id;
1813       The_Body_Name     : Name_Id;
1814
1815    begin
1816       Canonical_Case_File_Name (Original_Name);
1817       Name_Len := Original_Name'Length;
1818       Name_Buffer (1 .. Name_Len) := Original_Name;
1819       The_Original_Name := Name_Find;
1820
1821       Canonical_Case_File_Name (Extended_Spec_Name);
1822       Name_Len := Extended_Spec_Name'Length;
1823       Name_Buffer (1 .. Name_Len) := Extended_Spec_Name;
1824       The_Spec_Name := Name_Find;
1825
1826       Canonical_Case_File_Name (Extended_Body_Name);
1827       Name_Len := Extended_Body_Name'Length;
1828       Name_Buffer (1 .. Name_Len) := Extended_Body_Name;
1829       The_Body_Name := Name_Find;
1830
1831       for Current in reverse Units.First .. Units.Last loop
1832          Unit := Units.Table (Current);
1833
1834          --  Check for body
1835
1836          Current_Name := Unit.File_Names (Body_Part).Name;
1837
1838          --  Case of a body present
1839
1840          if Current_Name /= No_Name then
1841
1842             --  If it has the name of the original name or the body name,
1843             --  we have found the project.
1844
1845             if Unit.Name = The_Original_Name
1846               or else Current_Name = The_Original_Name
1847               or else Current_Name = The_Body_Name
1848             then
1849                Result := Unit.File_Names (Body_Part).Project;
1850                exit;
1851             end if;
1852          end if;
1853
1854          --  Check for spec
1855
1856          Current_Name := Unit.File_Names (Specification).Name;
1857
1858          if Current_Name /= No_Name then
1859
1860             --  If name same as the original name, or the spec name, we have
1861             --  found the project.
1862
1863             if Unit.Name = The_Original_Name
1864               or else Current_Name = The_Original_Name
1865               or else Current_Name = The_Spec_Name
1866             then
1867                Result := Unit.File_Names (Specification).Project;
1868                exit;
1869             end if;
1870          end if;
1871       end loop;
1872
1873       --  Get the ultimate extending project
1874
1875       if Result /= No_Project then
1876          while Projects.Table (Result).Extended_By /= No_Project loop
1877             Result := Projects.Table (Result).Extended_By;
1878          end loop;
1879       end if;
1880
1881       return Result;
1882    end Project_Of;
1883
1884    -------------------
1885    -- Set_Ada_Paths --
1886    -------------------
1887
1888    procedure Set_Ada_Paths
1889      (Project             : Project_Id;
1890       Including_Libraries : Boolean)
1891    is
1892       Source_FD : File_Descriptor := Invalid_FD;
1893       Object_FD : File_Descriptor := Invalid_FD;
1894
1895       Process_Source_Dirs : Boolean := False;
1896       Process_Object_Dirs : Boolean := False;
1897
1898       Status : Boolean;
1899       --  For calls to Close
1900
1901       Len : Natural;
1902
1903       procedure Add (Proj : Project_Id);
1904       --  Add all the source/object directories of a project to the path only
1905       --  if this project has not been visited. Calls an internal procedure
1906       --  recursively for projects being extended, and imported projects.
1907
1908       ---------
1909       -- Add --
1910       ---------
1911
1912       procedure Add (Proj : Project_Id) is
1913
1914          procedure Recursive_Add (Project : Project_Id);
1915          --  Recursive procedure to add the source/object paths of extended/
1916          --  imported projects.
1917
1918          -------------------
1919          -- Recursive_Add --
1920          -------------------
1921
1922          procedure Recursive_Add (Project : Project_Id) is
1923          begin
1924             --  If Seen is False, then the project has not yet been visited
1925
1926             if not Projects.Table (Project).Seen then
1927                Projects.Table (Project).Seen := True;
1928
1929                declare
1930                   Data : constant Project_Data := Projects.Table (Project);
1931                   List : Project_List := Data.Imported_Projects;
1932
1933                begin
1934                   if Process_Source_Dirs then
1935
1936                      --  Add to path all source directories of this project
1937                      --  if there are Ada sources.
1938
1939                      if Projects.Table (Project).Sources_Present then
1940                         Add_To_Source_Path (Data.Source_Dirs);
1941                      end if;
1942                   end if;
1943
1944                   if Process_Object_Dirs then
1945
1946                      --  Add to path the object directory of this project
1947                      --  except if we don't include library project and
1948                      --  this is a library project.
1949
1950                      if (Data.Library and then Including_Libraries)
1951                        or else
1952                          (Data.Object_Directory /= No_Name
1953                           and then
1954                             (not Including_Libraries or else not Data.Library))
1955                      then
1956                         --  For a library project, add the library directory
1957
1958                         if Data.Library then
1959                            Add_To_Object_Path (Data.Library_Dir);
1960
1961                         else
1962                            --  For a non library project, add the object
1963                            --  directory.
1964
1965                            Add_To_Object_Path (Data.Object_Directory);
1966                         end if;
1967                      end if;
1968                   end if;
1969
1970                   --  Call Add to the project being extended, if any
1971
1972                   if Data.Extends /= No_Project then
1973                      Recursive_Add (Data.Extends);
1974                   end if;
1975
1976                   --  Call Add for each imported project, if any
1977
1978                   while List /= Empty_Project_List loop
1979                      Recursive_Add (Project_Lists.Table (List).Project);
1980                      List := Project_Lists.Table (List).Next;
1981                   end loop;
1982                end;
1983             end if;
1984          end Recursive_Add;
1985
1986       begin
1987          Source_Paths.Set_Last (0);
1988          Object_Paths.Set_Last (0);
1989
1990          for Index in 1 .. Projects.Last loop
1991             Projects.Table (Index).Seen := False;
1992          end loop;
1993
1994          Recursive_Add (Proj);
1995       end Add;
1996
1997    --  Start of processing for Set_Ada_Paths
1998
1999    begin
2000       --  If it is the first time we call this procedure for
2001       --  this project, compute the source path and/or the object path.
2002
2003       if Projects.Table (Project).Include_Path_File = No_Name then
2004          Process_Source_Dirs := True;
2005          Create_New_Path_File
2006            (Source_FD, Projects.Table (Project).Include_Path_File);
2007       end if;
2008
2009       --  For the object path, we make a distinction depending on
2010       --  Including_Libraries.
2011
2012       if Including_Libraries then
2013          if Projects.Table (Project).Objects_Path_File_With_Libs = No_Name then
2014             Process_Object_Dirs := True;
2015             Create_New_Path_File
2016               (Object_FD, Projects.Table (Project).
2017                                            Objects_Path_File_With_Libs);
2018          end if;
2019
2020       else
2021          if
2022            Projects.Table (Project).Objects_Path_File_Without_Libs = No_Name
2023          then
2024             Process_Object_Dirs := True;
2025             Create_New_Path_File
2026               (Object_FD, Projects.Table (Project).
2027                                            Objects_Path_File_Without_Libs);
2028          end if;
2029       end if;
2030
2031       --  If there is something to do, set Seen to False for all projects,
2032       --  then call the recursive procedure Add for Project.
2033
2034       if Process_Source_Dirs or Process_Object_Dirs then
2035          Add (Project);
2036       end if;
2037
2038       --  Write and close any file that has been created.
2039
2040       if Source_FD /= Invalid_FD then
2041          for Index in 1 .. Source_Paths.Last loop
2042             Get_Name_String (Source_Paths.Table (Index));
2043             Name_Len := Name_Len + 1;
2044             Name_Buffer (Name_Len) := ASCII.LF;
2045             Len := Write (Source_FD, Name_Buffer (1)'Address, Name_Len);
2046
2047             if Len /= Name_Len then
2048                Prj.Com.Fail ("disk full");
2049             end if;
2050          end loop;
2051
2052          Close (Source_FD, Status);
2053
2054          if not Status then
2055             Prj.Com.Fail ("disk full");
2056          end if;
2057       end if;
2058
2059       if Object_FD /= Invalid_FD then
2060          for Index in 1 .. Object_Paths.Last loop
2061             Get_Name_String (Object_Paths.Table (Index));
2062             Name_Len := Name_Len + 1;
2063             Name_Buffer (Name_Len) := ASCII.LF;
2064             Len := Write (Object_FD, Name_Buffer (1)'Address, Name_Len);
2065
2066             if Len /= Name_Len then
2067                Prj.Com.Fail ("disk full");
2068             end if;
2069          end loop;
2070
2071          Close (Object_FD, Status);
2072
2073          if not Status then
2074             Prj.Com.Fail ("disk full");
2075          end if;
2076       end if;
2077
2078       --  Set the env vars, if they need to be changed, and set the
2079       --  corresponding flags.
2080
2081       if Current_Source_Path_File /=
2082            Projects.Table (Project).Include_Path_File
2083       then
2084          Current_Source_Path_File :=
2085            Projects.Table (Project).Include_Path_File;
2086          Set_Path_File_Var
2087            (Project_Include_Path_File,
2088             Get_Name_String (Current_Source_Path_File));
2089          Ada_Prj_Include_File_Set := True;
2090       end if;
2091
2092       if Including_Libraries then
2093          if Current_Object_Path_File
2094               /= Projects.Table (Project).Objects_Path_File_With_Libs
2095          then
2096             Current_Object_Path_File :=
2097               Projects.Table (Project).Objects_Path_File_With_Libs;
2098             Set_Path_File_Var
2099               (Project_Objects_Path_File,
2100                Get_Name_String (Current_Object_Path_File));
2101             Ada_Prj_Objects_File_Set := True;
2102          end if;
2103
2104       else
2105          if Current_Object_Path_File
2106               /= Projects.Table (Project).Objects_Path_File_Without_Libs
2107          then
2108             Current_Object_Path_File :=
2109               Projects.Table (Project).Objects_Path_File_Without_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       end if;
2116    end Set_Ada_Paths;
2117
2118    ---------------------------------------------
2119    -- Set_Mapping_File_Initial_State_To_Empty --
2120    ---------------------------------------------
2121
2122    procedure Set_Mapping_File_Initial_State_To_Empty is
2123    begin
2124       Fill_Mapping_File := False;
2125    end Set_Mapping_File_Initial_State_To_Empty;
2126
2127    -----------------------
2128    -- Set_Path_File_Var --
2129    -----------------------
2130
2131    procedure Set_Path_File_Var (Name : String; Value : String) is
2132       Host_Spec : String_Access := To_Host_File_Spec (Value);
2133
2134    begin
2135       if Host_Spec = null then
2136          Prj.Com.Fail
2137            ("could not convert file name """, Value, """ to host spec");
2138       else
2139          Setenv (Name, Host_Spec.all);
2140          Free (Host_Spec);
2141       end if;
2142    end Set_Path_File_Var;
2143
2144    -----------------------
2145    -- Spec_Path_Name_Of --
2146    -----------------------
2147
2148    function Spec_Path_Name_Of (Unit : Unit_Id) return String is
2149       Data : Unit_Data := Units.Table (Unit);
2150
2151    begin
2152       if Data.File_Names (Specification).Path = No_Name then
2153          declare
2154             Current_Source : String_List_Id :=
2155               Projects.Table (Data.File_Names (Specification).Project).Sources;
2156             Path : GNAT.OS_Lib.String_Access;
2157
2158          begin
2159             Data.File_Names (Specification).Path :=
2160               Data.File_Names (Specification).Name;
2161
2162             while Current_Source /= Nil_String loop
2163                Path := Locate_Regular_File
2164                  (Namet.Get_Name_String
2165                   (Data.File_Names (Specification).Name),
2166                   Namet.Get_Name_String
2167                    (String_Elements.Table (Current_Source).Value));
2168
2169                if Path /= null then
2170                   Name_Len := Path'Length;
2171                   Name_Buffer (1 .. Name_Len) := Path.all;
2172                   Data.File_Names (Specification).Path := Name_Enter;
2173                   exit;
2174                else
2175                   Current_Source :=
2176                     String_Elements.Table (Current_Source).Next;
2177                end if;
2178             end loop;
2179
2180             Units.Table (Unit) := Data;
2181          end;
2182       end if;
2183
2184       return Namet.Get_Name_String (Data.File_Names (Specification).Path);
2185    end Spec_Path_Name_Of;
2186
2187    ---------------------------
2188    -- Ultimate_Extension_Of --
2189    ---------------------------
2190
2191    function Ultimate_Extension_Of (Project : in Project_Id) return Project_Id
2192    is
2193       Result : Project_Id := Project;
2194
2195    begin
2196       while Projects.Table (Result).Extended_By /= No_Project loop
2197          Result := Projects.Table (Result).Extended_By;
2198       end loop;
2199
2200       return Result;
2201    end Ultimate_Extension_Of;
2202
2203 --  Package initialization
2204 --  What is relationshiop to procedure Initialize
2205
2206 begin
2207    Path_Files.Set_Last (0);
2208 end Prj.Env;