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