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