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