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-2009, 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 3,  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 COPYING3.  If not, go to --
  19 -- http://www.gnu.org/licenses for a complete copy of the license.          --
  20 --                                                                          --
  21 -- GNAT was originally developed  by the GNAT team at  New York University. --
  22 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  23 --                                                                          --
  24 ------------------------------------------------------------------------------
  25
  26 with Fmap;
  27 with Opt;
  28 with Osint;    use Osint;
  29 with Output;   use Output;
  30 with Prj.Com;  use Prj.Com;
  31 with Tempdir;
  32
  33 package body Prj.Env is
  34
  35    -----------------------
  36    -- Local Subprograms --
  37    -----------------------
  38
  39    package Source_Path_Table is new GNAT.Dynamic_Tables
  40      (Table_Component_Type => Name_Id,
  41       Table_Index_Type     => Natural,
  42       Table_Low_Bound      => 1,
  43       Table_Initial        => 50,
  44       Table_Increment      => 100);
  45    --  A table to store the source dirs before creating the source path file
  46
  47    package Object_Path_Table is new GNAT.Dynamic_Tables
  48      (Table_Component_Type => Path_Name_Type,
  49       Table_Index_Type     => Natural,
  50       Table_Low_Bound      => 1,
  51       Table_Initial        => 50,
  52       Table_Increment      => 100);
  53    --  A table to store the object dirs, before creating the object path file
  54
  55    procedure Add_To_Path
  56      (Source_Dirs : String_List_Id;
  57       In_Tree     : Project_Tree_Ref;
  58       Buffer      : in out String_Access;
  59       Buffer_Last : in out Natural);
  60    --  Add to Ada_Path_Buffer all the source directories in string list
  61    --  Source_Dirs, if any.
  62
  63    procedure Add_To_Path
  64      (Dir         : String;
  65       Buffer      : in out String_Access;
  66       Buffer_Last : in out Natural);
  67    --  If Dir is not already in the global variable Ada_Path_Buffer, add it.
  68    --  If Buffer_Last /= 0, prepend a Path_Separator character to Path.
  69
  70    procedure Add_To_Source_Path
  71      (Source_Dirs  : String_List_Id;
  72       In_Tree      : Project_Tree_Ref;
  73       Source_Paths : in out Source_Path_Table.Instance);
  74    --  Add to Ada_Path_B all the source directories in string list
  75    --  Source_Dirs, if any. Increment Ada_Path_Length.
  76
  77    procedure Add_To_Object_Path
  78      (Object_Dir   : Path_Name_Type;
  79       Object_Paths : in out Object_Path_Table.Instance);
  80    --  Add Object_Dir to object path table. Make sure it is not duplicate
  81    --  and it is the last one in the current table.
  82
  83    procedure Set_Path_File_Var (Name : String; Value : String);
  84    --  Call Setenv, after calling To_Host_File_Spec
  85
  86    function Ultimate_Extension_Of
  87      (Project : Project_Id) return Project_Id;
  88    --  Return a project that is either Project or an extended ancestor of
  89    --  Project that itself is not extended.
  90
  91    procedure Create_Temp_File
  92      (In_Tree   : Project_Tree_Ref;
  93       Path_FD   : out File_Descriptor;
  94       Path_Name : out Path_Name_Type;
  95       File_Use  : String);
  96    --  Create a temporary file, and fail with an error if it could not be
  97    --  created.
  98
  99    ----------------------
 100    -- Ada_Include_Path --
 101    ----------------------
 102
 103    function Ada_Include_Path
 104      (Project   : Project_Id;
 105       In_Tree   : Project_Tree_Ref;
 106       Recursive : Boolean := False) return String
 107    is
 108       Buffer      : String_Access;
 109       Buffer_Last : Natural := 0;
 110
 111       procedure Add (Project : Project_Id; Dummy : in out Boolean);
 112       --  Add source dirs of Project to the path
 113
 114       ---------
 115       -- Add --
 116       ---------
 117
 118       procedure Add (Project : Project_Id; Dummy : in out Boolean) is
 119          pragma Unreferenced (Dummy);
 120       begin
 121          Add_To_Path (Project.Source_Dirs, In_Tree, Buffer, Buffer_Last);
 122       end Add;
 123
 124       procedure For_All_Projects is
 125         new For_Every_Project_Imported (Boolean, Add);
 126
 127       Dummy : Boolean := False;
 128
 129    --  Start of processing for Ada_Include_Path
 130
 131    begin
 132       if Recursive then
 133
 134          --  If it is the first time we call this function for
 135          --  this project, compute the source path
 136
 137          if Project.Ada_Include_Path = null then
 138             Buffer := new String (1 .. 4096);
 139             For_All_Projects (Project, Dummy);
 140             Project.Ada_Include_Path := new String'(Buffer (1 .. Buffer_Last));
 141             Free (Buffer);
 142          end if;
 143
 144          return Project.Ada_Include_Path.all;
 145
 146       else
 147          Buffer := new String (1 .. 4096);
 148          Add_To_Path (Project.Source_Dirs, In_Tree, Buffer, Buffer_Last);
 149
 150          declare
 151             Result : constant String := Buffer (1 .. Buffer_Last);
 152          begin
 153             Free (Buffer);
 154             return Result;
 155          end;
 156       end if;
 157    end Ada_Include_Path;
 158
 159    ----------------------
 160    -- Ada_Objects_Path --
 161    ----------------------
 162
 163    function Ada_Objects_Path
 164      (Project             : Project_Id;
 165       Including_Libraries : Boolean := True) return String_Access
 166    is
 167       Buffer      : String_Access;
 168       Buffer_Last : Natural := 0;
 169
 170       procedure Add (Project : Project_Id; Dummy : in out Boolean);
 171       --  Add all the object directories of a project to the path
 172
 173       ---------
 174       -- Add --
 175       ---------
 176
 177       procedure Add (Project : Project_Id; Dummy : in out Boolean) is
 178          pragma Unreferenced (Dummy);
 179          Path : constant Path_Name_Type :=
 180                   Get_Object_Directory
 181                     (Project,
 182                      Including_Libraries => Including_Libraries,
 183                      Only_If_Ada         => False);
 184       begin
 185          if Path /= No_Path then
 186             Add_To_Path (Get_Name_String (Path), Buffer, Buffer_Last);
 187          end if;
 188       end Add;
 189
 190       procedure For_All_Projects is
 191         new For_Every_Project_Imported (Boolean, Add);
 192
 193       Dummy : Boolean := False;
 194
 195    --  Start of processing for Ada_Objects_Path
 196
 197    begin
 198       --  If it is the first time we call this function for
 199       --  this project, compute the objects path
 200
 201       if Project.Ada_Objects_Path = null then
 202          Buffer := new String (1 .. 4096);
 203          For_All_Projects (Project, Dummy);
 204
 205          Project.Ada_Objects_Path := new String'(Buffer (1 .. Buffer_Last));
 206          Free (Buffer);
 207       end if;
 208
 209       return Project.Ada_Objects_Path;
 210    end Ada_Objects_Path;
 211
 212    ------------------------
 213    -- Add_To_Object_Path --
 214    ------------------------
 215
 216    procedure Add_To_Object_Path
 217      (Object_Dir   : Path_Name_Type;
 218       Object_Paths : in out Object_Path_Table.Instance)
 219    is
 220    begin
 221       --  Check if the directory is already in the table
 222
 223       for Index in Object_Path_Table.First ..
 224                    Object_Path_Table.Last (Object_Paths)
 225       loop
 226
 227          --  If it is, remove it, and add it as the last one
 228
 229          if Object_Paths.Table (Index) = Object_Dir then
 230             for Index2 in Index + 1 ..
 231                           Object_Path_Table.Last (Object_Paths)
 232             loop
 233                Object_Paths.Table (Index2 - 1) := Object_Paths.Table (Index2);
 234             end loop;
 235
 236             Object_Paths.Table
 237               (Object_Path_Table.Last (Object_Paths)) := Object_Dir;
 238             return;
 239          end if;
 240       end loop;
 241
 242       --  The directory is not already in the table, add it
 243
 244       Object_Path_Table.Append (Object_Paths, Object_Dir);
 245    end Add_To_Object_Path;
 246
 247    -----------------
 248    -- Add_To_Path --
 249    -----------------
 250
 251    procedure Add_To_Path
 252      (Source_Dirs : String_List_Id;
 253       In_Tree     : Project_Tree_Ref;
 254       Buffer      : in out String_Access;
 255       Buffer_Last : in out Natural)
 256    is
 257       Current    : String_List_Id := Source_Dirs;
 258       Source_Dir : String_Element;
 259    begin
 260       while Current /= Nil_String loop
 261          Source_Dir := In_Tree.String_Elements.Table (Current);
 262          Add_To_Path (Get_Name_String (Source_Dir.Display_Value),
 263                       Buffer, Buffer_Last);
 264          Current := Source_Dir.Next;
 265       end loop;
 266    end Add_To_Path;
 267
 268    procedure Add_To_Path
 269      (Dir         : String;
 270       Buffer      : in out String_Access;
 271       Buffer_Last : in out Natural)
 272    is
 273       Len        : Natural;
 274       New_Buffer : String_Access;
 275       Min_Len    : Natural;
 276
 277       function Is_Present (Path : String; Dir : String) return Boolean;
 278       --  Return True if Dir is part of Path
 279
 280       ----------------
 281       -- Is_Present --
 282       ----------------
 283
 284       function Is_Present (Path : String; Dir : String) return Boolean is
 285          Last : constant Integer := Path'Last - Dir'Length + 1;
 286
 287       begin
 288          for J in Path'First .. Last loop
 289
 290             --  Note: the order of the conditions below is important, since
 291             --  it ensures a minimal number of string comparisons.
 292
 293             if (J = Path'First
 294                 or else Path (J - 1) = Path_Separator)
 295               and then
 296                 (J + Dir'Length > Path'Last
 297                  or else Path (J + Dir'Length) = Path_Separator)
 298               and then Dir = Path (J .. J + Dir'Length - 1)
 299             then
 300                return True;
 301             end if;
 302          end loop;
 303
 304          return False;
 305       end Is_Present;
 306
 307    --  Start of processing for Add_To_Path
 308
 309    begin
 310       if Is_Present (Buffer (1 .. Buffer_Last), Dir) then
 311
 312          --  Dir is already in the path, nothing to do
 313
 314          return;
 315       end if;
 316
 317       Min_Len := Buffer_Last + Dir'Length;
 318
 319       if Buffer_Last > 0 then
 320
 321          --  Add 1 for the Path_Separator character
 322
 323          Min_Len := Min_Len + 1;
 324       end if;
 325
 326       --  If Ada_Path_Buffer is too small, increase it
 327
 328       Len := Buffer'Last;
 329
 330       if Len < Min_Len then
 331          loop
 332             Len := Len * 2;
 333             exit when Len >= Min_Len;
 334          end loop;
 335
 336          New_Buffer := new String (1 .. Len);
 337          New_Buffer (1 .. Buffer_Last) := Buffer (1 .. Buffer_Last);
 338          Free (Buffer);
 339          Buffer := New_Buffer;
 340       end if;
 341
 342       if Buffer_Last > 0 then
 343          Buffer_Last := Buffer_Last + 1;
 344          Buffer (Buffer_Last) := Path_Separator;
 345       end if;
 346
 347       Buffer (Buffer_Last + 1 .. Buffer_Last + Dir'Length) := Dir;
 348       Buffer_Last := Buffer_Last + Dir'Length;
 349    end Add_To_Path;
 350
 351    ------------------------
 352    -- Add_To_Source_Path --
 353    ------------------------
 354
 355    procedure Add_To_Source_Path
 356      (Source_Dirs  : String_List_Id;
 357       In_Tree      : Project_Tree_Ref;
 358       Source_Paths : in out Source_Path_Table.Instance)
 359    is
 360       Current    : String_List_Id := Source_Dirs;
 361       Source_Dir : String_Element;
 362       Add_It     : Boolean;
 363
 364    begin
 365       --  Add each source directory
 366
 367       while Current /= Nil_String loop
 368          Source_Dir := In_Tree.String_Elements.Table (Current);
 369          Add_It := True;
 370
 371          --  Check if the source directory is already in the table
 372
 373          for Index in Source_Path_Table.First ..
 374                       Source_Path_Table.Last (Source_Paths)
 375          loop
 376             --  If it is already, no need to add it
 377
 378             if Source_Paths.Table (Index) = Source_Dir.Value then
 379                Add_It := False;
 380                exit;
 381             end if;
 382          end loop;
 383
 384          if Add_It then
 385             Source_Path_Table.Append (Source_Paths, Source_Dir.Value);
 386          end if;
 387
 388          --  Next source directory
 389
 390          Current := Source_Dir.Next;
 391       end loop;
 392    end Add_To_Source_Path;
 393
 394    --------------------------------
 395    -- Create_Config_Pragmas_File --
 396    --------------------------------
 397
 398    procedure Create_Config_Pragmas_File
 399      (For_Project : Project_Id;
 400       In_Tree     : Project_Tree_Ref)
 401    is
 402       type Naming_Id is new Nat;
 403       package Naming_Table is new GNAT.Dynamic_Tables
 404         (Table_Component_Type => Lang_Naming_Data,
 405          Table_Index_Type     => Naming_Id,
 406          Table_Low_Bound      => 1,
 407          Table_Initial        => 5,
 408          Table_Increment      => 100);
 409       Default_Naming : constant Naming_Id := Naming_Table.First;
 410       Namings        : Naming_Table.Instance;
 411       --  Table storing the naming data for gnatmake/gprmake
 412
 413       File_Name : Path_Name_Type  := No_Path;
 414       File      : File_Descriptor := Invalid_FD;
 415
 416       Current_Naming  : Naming_Id;
 417       Iter            : Source_Iterator;
 418       Source          : Source_Id;
 419
 420       Status : Boolean;
 421       --  For call to Close
 422
 423       procedure Check (Project : Project_Id; State : in out Integer);
 424       --  Recursive procedure that put in the config pragmas file any non
 425       --  standard naming schemes, if it is not already in the file, then call
 426       --  itself for any imported project.
 427
 428       procedure Check_Temp_File;
 429       --  Check that a temporary file has been opened.
 430       --  If not, create one, and put its name in the project data,
 431       --  with the indication that it is a temporary file.
 432
 433       procedure Put (Source : Source_Id);
 434       --  Put an SFN pragma in the temporary file
 435
 436       procedure Put (File : File_Descriptor; S : String);
 437       procedure Put_Line (File : File_Descriptor; S : String);
 438       --  Output procedures, analogous to normal Text_IO procs of same name
 439
 440       -----------
 441       -- Check --
 442       -----------
 443
 444       procedure Check (Project : Project_Id; State : in out Integer) is
 445          pragma Unreferenced (State);
 446          Lang   : constant Language_Ptr :=
 447                     Get_Language_From_Name (Project, "ada");
 448          Naming : Lang_Naming_Data;
 449
 450       begin
 451          if Current_Verbosity = High then
 452             Write_Str ("Checking project file """);
 453             Write_Str (Namet.Get_Name_String (Project.Name));
 454             Write_Str (""".");
 455             Write_Eol;
 456          end if;
 457
 458          if Lang = null then
 459             if Current_Verbosity = High then
 460                Write_Line ("   Languages does not contain Ada, nothing to do");
 461             end if;
 462
 463             return;
 464          end if;
 465
 466          Naming := Lang.Config.Naming_Data;
 467
 468          --  Is the naming scheme of this project one that we know?
 469
 470          Current_Naming := Default_Naming;
 471          while Current_Naming <= Naming_Table.Last (Namings)
 472            and then Namings.Table (Current_Naming).Dot_Replacement =
 473                                                     Naming.Dot_Replacement
 474            and then Namings.Table (Current_Naming).Casing =
 475                                                     Naming.Casing
 476            and then Namings.Table (Current_Naming).Separate_Suffix =
 477                                                     Naming.Separate_Suffix
 478          loop
 479             Current_Naming := Current_Naming + 1;
 480          end loop;
 481
 482          --  If we don't know it, add it
 483
 484          if Current_Naming > Naming_Table.Last (Namings) then
 485             Naming_Table.Increment_Last (Namings);
 486             Namings.Table (Naming_Table.Last (Namings)) := Naming;
 487
 488             --  We need a temporary file to be created
 489
 490             Check_Temp_File;
 491
 492             --  Put the SFN pragmas for the naming scheme
 493
 494             --  Spec
 495
 496             Put_Line
 497               (File, "pragma Source_File_Name_Project");
 498             Put_Line
 499               (File, "  (Spec_File_Name  => ""*" &
 500                Get_Name_String (Naming.Spec_Suffix) & """,");
 501             Put_Line
 502               (File, "   Casing          => " &
 503                Image (Naming.Casing) & ",");
 504             Put_Line
 505               (File, "   Dot_Replacement => """ &
 506                Get_Name_String (Naming.Dot_Replacement) & """);");
 507
 508             --  and body
 509
 510             Put_Line
 511               (File, "pragma Source_File_Name_Project");
 512             Put_Line
 513               (File, "  (Body_File_Name  => ""*" &
 514                Get_Name_String (Naming.Body_Suffix) & """,");
 515             Put_Line
 516               (File, "   Casing          => " &
 517                Image (Naming.Casing) & ",");
 518             Put_Line
 519               (File, "   Dot_Replacement => """ &
 520                Get_Name_String (Naming.Dot_Replacement) &
 521                """);");
 522
 523             --  and maybe separate
 524
 525             if Naming.Body_Suffix /= Naming.Separate_Suffix then
 526                Put_Line (File, "pragma Source_File_Name_Project");
 527                Put_Line
 528                  (File, "  (Subunit_File_Name  => ""*" &
 529                   Get_Name_String (Naming.Separate_Suffix) & """,");
 530                Put_Line
 531                  (File, "   Casing          => " &
 532                   Image (Naming.Casing) & ",");
 533                Put_Line
 534                  (File, "   Dot_Replacement => """ &
 535                   Get_Name_String (Naming.Dot_Replacement) &
 536                   """);");
 537             end if;
 538          end if;
 539       end Check;
 540
 541       ---------------------
 542       -- Check_Temp_File --
 543       ---------------------
 544
 545       procedure Check_Temp_File is
 546       begin
 547          if File = Invalid_FD then
 548             Create_Temp_File
 549               (In_Tree, File, File_Name, "configuration pragmas");
 550          end if;
 551       end Check_Temp_File;
 552
 553       ---------
 554       -- Put --
 555       ---------
 556
 557       procedure Put (Source : Source_Id) is
 558       begin
 559          --  A temporary file needs to be open
 560
 561          Check_Temp_File;
 562
 563          --  Put the pragma SFN for the unit kind (spec or body)
 564
 565          Put (File, "pragma Source_File_Name_Project (");
 566          Put (File, Namet.Get_Name_String (Source.Unit.Name));
 567
 568          if Source.Kind = Spec then
 569             Put (File, ", Spec_File_Name => """);
 570          else
 571             Put (File, ", Body_File_Name => """);
 572          end if;
 573
 574          Put (File, Namet.Get_Name_String (Source.File));
 575          Put (File, """");
 576
 577          if Source.Index /= 0 then
 578             Put (File, ", Index =>");
 579             Put (File, Source.Index'Img);
 580          end if;
 581
 582          Put_Line (File, ");");
 583       end Put;
 584
 585       procedure Put (File : File_Descriptor; S : String) is
 586          Last : Natural;
 587
 588       begin
 589          Last := Write (File, S (S'First)'Address, S'Length);
 590
 591          if Last /= S'Length then
 592             Prj.Com.Fail
 593               ("Disk full when creating " & Get_Name_String (File_Name));
 594          end if;
 595
 596          if Current_Verbosity = High then
 597             Write_Str (S);
 598          end if;
 599       end Put;
 600
 601       --------------
 602       -- Put_Line --
 603       --------------
 604
 605       procedure Put_Line (File : File_Descriptor; S : String) is
 606          S0   : String (1 .. S'Length + 1);
 607          Last : Natural;
 608
 609       begin
 610          --  Add an ASCII.LF to the string. As this config file is supposed to
 611          --  be used only by the compiler, we don't care about the characters
 612          --  for the end of line. In fact we could have put a space, but
 613          --  it is more convenient to be able to read gnat.adc during
 614          --  development, for which the ASCII.LF is fine.
 615
 616          S0 (1 .. S'Length) := S;
 617          S0 (S0'Last) := ASCII.LF;
 618          Last := Write (File, S0'Address, S0'Length);
 619
 620          if Last /= S'Length + 1 then
 621             Prj.Com.Fail
 622               ("Disk full when creating " & Get_Name_String (File_Name));
 623          end if;
 624
 625          if Current_Verbosity = High then
 626             Write_Line (S);
 627          end if;
 628       end Put_Line;
 629
 630       procedure Check_Imported_Projects is new For_Every_Project_Imported
 631         (Integer, Check);
 632       Dummy : Integer := 0;
 633
 634    --  Start of processing for Create_Config_Pragmas_File
 635
 636    begin
 637       if not For_Project.Config_Checked then
 638
 639          Naming_Table.Init (Namings);
 640
 641          --  Check the naming schemes
 642
 643          Check_Imported_Projects (For_Project, Dummy, Imported_First => False);
 644
 645          --  Visit all the files and process those that need an SFN pragma
 646
 647          Iter := For_Each_Source (In_Tree, For_Project);
 648          while Element (Iter) /= No_Source loop
 649             Source := Element (Iter);
 650
 651             if Source.Index >= 1
 652               and then not Source.Locally_Removed
 653               and then Source.Unit /= null
 654             then
 655                Put (Source);
 656             end if;
 657
 658             Next (Iter);
 659          end loop;
 660
 661          --  If there are no non standard naming scheme, issue the GNAT
 662          --  standard naming scheme. This will tell the compiler that
 663          --  a project file is used and will forbid any pragma SFN.
 664
 665          if File = Invalid_FD then
 666             Check_Temp_File;
 667
 668             Put_Line (File, "pragma Source_File_Name_Project");
 669             Put_Line (File, "   (Spec_File_Name  => ""*.ads"",");
 670             Put_Line (File, "    Dot_Replacement => ""-"",");
 671             Put_Line (File, "    Casing          => lowercase);");
 672
 673             Put_Line (File, "pragma Source_File_Name_Project");
 674             Put_Line (File, "   (Body_File_Name  => ""*.adb"",");
 675             Put_Line (File, "    Dot_Replacement => ""-"",");
 676             Put_Line (File, "    Casing          => lowercase);");
 677          end if;
 678
 679          --  Close the temporary file
 680
 681          GNAT.OS_Lib.Close (File, Status);
 682
 683          if not Status then
 684             Prj.Com.Fail
 685               ("Disk full when creating " & Get_Name_String (File_Name));
 686          end if;
 687
 688          if Opt.Verbose_Mode then
 689             Write_Str ("Closing configuration file """);
 690             Write_Str (Get_Name_String (File_Name));
 691             Write_Line ("""");
 692          end if;
 693
 694          For_Project.Config_File_Name := File_Name;
 695          For_Project.Config_File_Temp := True;
 696          For_Project.Config_Checked   := True;
 697       end if;
 698    end Create_Config_Pragmas_File;
 699
 700    --------------------
 701    -- Create_Mapping --
 702    --------------------
 703
 704    procedure Create_Mapping (In_Tree : Project_Tree_Ref) is
 705       Data : Source_Id;
 706       Iter : Source_Iterator;
 707
 708    begin
 709       Fmap.Reset_Tables;
 710
 711       Iter := For_Each_Source (In_Tree);
 712       loop
 713          Data := Element (Iter);
 714          exit when Data = No_Source;
 715
 716          if Data.Unit /= No_Unit_Index then
 717             if Data.Locally_Removed then
 718                Fmap.Add_Forbidden_File_Name (Data.File);
 719             else
 720                Fmap.Add_To_File_Map
 721                  (Unit_Name => Unit_Name_Type (Data.Unit.Name),
 722                   File_Name => Data.File,
 723                   Path_Name => File_Name_Type (Data.Path.Name));
 724             end if;
 725          end if;
 726
 727          Next (Iter);
 728       end loop;
 729    end Create_Mapping;
 730
 731    -------------------------
 732    -- Create_Mapping_File --
 733    -------------------------
 734
 735    procedure Create_Mapping_File
 736      (Project  : Project_Id;
 737       Language : Name_Id;
 738       In_Tree  : Project_Tree_Ref;
 739       Name     : out Path_Name_Type)
 740    is
 741       File   : File_Descriptor := Invalid_FD;
 742       Status : Boolean;
 743
 744       procedure Put_Name_Buffer;
 745       --  Put the line contained in the Name_Buffer in the mapping file
 746
 747       procedure Process (Project : Project_Id; State : in out Integer);
 748       --  Generate the mapping file for Project (not recursively)
 749
 750       ---------
 751       -- Put --
 752       ---------
 753
 754       procedure Put_Name_Buffer is
 755          Last : Natural;
 756
 757       begin
 758          Name_Len := Name_Len + 1;
 759          Name_Buffer (Name_Len) := ASCII.LF;
 760          Last := Write (File, Name_Buffer (1)'Address, Name_Len);
 761
 762          if Current_Verbosity = High then
 763             Write_Str ("Mapping file: " & Name_Buffer (1 .. Name_Len));
 764          end if;
 765
 766          if Last /= Name_Len then
 767             Prj.Com.Fail ("Disk full, cannot write mapping file");
 768          end if;
 769       end Put_Name_Buffer;
 770
 771       -------------
 772       -- Process --
 773       -------------
 774
 775       procedure Process (Project : Project_Id; State : in out Integer) is
 776          pragma Unreferenced (State);
 777          Source : Source_Id;
 778          Suffix : File_Name_Type;
 779          Iter   : Source_Iterator;
 780
 781       begin
 782          Iter := For_Each_Source (In_Tree, Project, Language => Language);
 783
 784          loop
 785             Source := Prj.Element (Iter);
 786             exit when Source = No_Source;
 787
 788             if Source.Replaced_By = No_Source
 789               and then Source.Path.Name /= No_Path
 790               and then
 791                 (Source.Language.Config.Kind = File_Based
 792                   or else Source.Unit /= No_Unit_Index)
 793             then
 794                if Source.Unit /= No_Unit_Index then
 795                   Get_Name_String (Source.Unit.Name);
 796
 797                   if Source.Language.Config.Kind = Unit_Based then
 798
 799                      --  ??? Mapping_Spec_Suffix could be set in the case of
 800                      --  gnatmake as well
 801
 802                      Add_Char_To_Name_Buffer ('%');
 803
 804                      if Source.Kind = Spec then
 805                         Add_Char_To_Name_Buffer ('s');
 806                      else
 807                         Add_Char_To_Name_Buffer ('b');
 808                      end if;
 809
 810                   else
 811                      case Source.Kind is
 812                         when Spec =>
 813                            Suffix :=
 814                              Source.Language.Config.Mapping_Spec_Suffix;
 815                         when Impl | Sep =>
 816                            Suffix :=
 817                              Source.Language.Config.Mapping_Body_Suffix;
 818                      end case;
 819
 820                      if Suffix /= No_File then
 821                         Add_Str_To_Name_Buffer
 822                           (Get_Name_String (Suffix));
 823                      end if;
 824                   end if;
 825
 826                   Put_Name_Buffer;
 827                end if;
 828
 829                Get_Name_String (Source.File);
 830                Put_Name_Buffer;
 831
 832                if Source.Locally_Removed then
 833                   Name_Len := 1;
 834                   Name_Buffer (1) := '/';
 835                else
 836                   Get_Name_String (Source.Path.Name);
 837                end if;
 838
 839                Put_Name_Buffer;
 840             end if;
 841
 842             Next (Iter);
 843          end loop;
 844       end Process;
 845
 846       procedure For_Every_Imported_Project is new
 847         For_Every_Project_Imported (State => Integer, Action => Process);
 848
 849       Dummy : Integer := 0;
 850
 851    --  Start of processing for Create_Mapping_File
 852
 853    begin
 854
 855       --  Create the temporary file
 856
 857       Create_Temp_File (In_Tree, File, Name, "mapping");
 858
 859       For_Every_Imported_Project (Project, Dummy);
 860       GNAT.OS_Lib.Close (File, Status);
 861
 862       if not Status then
 863
 864          --  We were able to create the temporary file, so there is no problem
 865          --  of protection. However, we are not able to close it, so there must
 866          --  be a capacity problem that we express using "disk full".
 867
 868          Prj.Com.Fail ("disk full, could not write mapping file");
 869       end if;
 870    end Create_Mapping_File;
 871
 872    ----------------------
 873    -- Create_Temp_File --
 874    ----------------------
 875
 876    procedure Create_Temp_File
 877      (In_Tree   : Project_Tree_Ref;
 878       Path_FD   : out File_Descriptor;
 879       Path_Name : out Path_Name_Type;
 880       File_Use  : String)
 881    is
 882    begin
 883       Tempdir.Create_Temp_File (Path_FD, Path_Name);
 884
 885       if Path_Name /= No_Path then
 886          if Current_Verbosity = High then
 887             Write_Line ("Create temp file (" & File_Use & ") "
 888                         & Get_Name_String (Path_Name));
 889          end if;
 890
 891          Record_Temp_File (In_Tree, Path_Name);
 892
 893       else
 894          Prj.Com.Fail
 895            ("unable to create temporary " & File_Use & " file");
 896       end if;
 897    end Create_Temp_File;
 898
 899    --------------------------
 900    -- Create_New_Path_File --
 901    --------------------------
 902
 903    procedure Create_New_Path_File
 904      (In_Tree   : Project_Tree_Ref;
 905       Path_FD   : out File_Descriptor;
 906       Path_Name : out Path_Name_Type)
 907    is
 908    begin
 909       Create_Temp_File (In_Tree, Path_FD, Path_Name, "path file");
 910    end Create_New_Path_File;
 911
 912    ------------------------------------
 913    -- File_Name_Of_Library_Unit_Body --
 914    ------------------------------------
 915
 916    function File_Name_Of_Library_Unit_Body
 917      (Name              : String;
 918       Project           : Project_Id;
 919       In_Tree           : Project_Tree_Ref;
 920       Main_Project_Only : Boolean := True;
 921       Full_Path         : Boolean := False) return String
 922    is
 923       The_Project   : Project_Id := Project;
 924       Original_Name : String := Name;
 925
 926       Lang   : constant Language_Ptr :=
 927         Get_Language_From_Name (Project, "ada");
 928
 929       Unit              : Unit_Index;
 930       The_Original_Name : Name_Id;
 931       The_Spec_Name     : Name_Id;
 932       The_Body_Name     : Name_Id;
 933
 934    begin
 935       --  ??? Same block in Project_Of
 936       Canonical_Case_File_Name (Original_Name);
 937       Name_Len := Original_Name'Length;
 938       Name_Buffer (1 .. Name_Len) := Original_Name;
 939       The_Original_Name := Name_Find;
 940
 941       if Lang /= null then
 942          declare
 943             Naming : constant Lang_Naming_Data := Lang.Config.Naming_Data;
 944             Extended_Spec_Name : String :=
 945                                    Name & Namet.Get_Name_String
 946                                             (Naming.Spec_Suffix);
 947             Extended_Body_Name : String :=
 948                                    Name & Namet.Get_Name_String
 949                                             (Naming.Body_Suffix);
 950
 951          begin
 952             Canonical_Case_File_Name (Extended_Spec_Name);
 953             Name_Len := Extended_Spec_Name'Length;
 954             Name_Buffer (1 .. Name_Len) := Extended_Spec_Name;
 955             The_Spec_Name := Name_Find;
 956
 957             Canonical_Case_File_Name (Extended_Body_Name);
 958             Name_Len := Extended_Body_Name'Length;
 959             Name_Buffer (1 .. Name_Len) := Extended_Body_Name;
 960             The_Body_Name := Name_Find;
 961          end;
 962
 963       else
 964          Name_Len := Name'Length;
 965          Name_Buffer (1 .. Name_Len) := Name;
 966          Canonical_Case_File_Name (Name_Buffer);
 967          The_Spec_Name := Name_Find;
 968          The_Body_Name := The_Spec_Name;
 969       end if;
 970
 971       if Current_Verbosity = High then
 972          Write_Str  ("Looking for file name of """);
 973          Write_Str  (Name);
 974          Write_Char ('"');
 975          Write_Eol;
 976          Write_Str  ("   Extended Spec Name = """);
 977          Write_Str  (Get_Name_String (The_Spec_Name));
 978          Write_Char ('"');
 979          Write_Eol;
 980          Write_Str  ("   Extended Body Name = """);
 981          Write_Str  (Get_Name_String (The_Body_Name));
 982          Write_Char ('"');
 983          Write_Eol;
 984       end if;
 985
 986       --  For extending project, search in the extended project if the source
 987       --  is not found. For non extending projects, this loop will be run only
 988       --  once.
 989
 990       loop
 991          --  Loop through units
 992
 993          Unit := Units_Htable.Get_First (In_Tree.Units_HT);
 994          while Unit /= null loop
 995             --  Check for body
 996
 997             if not Main_Project_Only
 998               or else
 999                 (Unit.File_Names (Impl) /= null
1000                  and then Unit.File_Names (Impl).Project = The_Project)
1001             then
1002                declare
1003                   Current_Name : File_Name_Type;
1004                begin
1005                   --  Case of a body present
1006
1007                   if Unit.File_Names (Impl) /= null then
1008                      Current_Name := Unit.File_Names (Impl).File;
1009
1010                      if Current_Verbosity = High then
1011                         Write_Str  ("   Comparing with """);
1012                         Write_Str  (Get_Name_String (Current_Name));
1013                         Write_Char ('"');
1014                         Write_Eol;
1015                      end if;
1016
1017                      --  If it has the name of the original name, return the
1018                      --  original name.
1019
1020                      if Unit.Name = The_Original_Name
1021                        or else
1022                          Current_Name = File_Name_Type (The_Original_Name)
1023                      then
1024                         if Current_Verbosity = High then
1025                            Write_Line ("   OK");
1026                         end if;
1027
1028                         if Full_Path then
1029                            return Get_Name_String
1030                              (Unit.File_Names (Impl).Path.Name);
1031
1032                         else
1033                            return Get_Name_String (Current_Name);
1034                         end if;
1035
1036                         --  If it has the name of the extended body name,
1037                         --  return the extended body name
1038
1039                      elsif Current_Name = File_Name_Type (The_Body_Name) then
1040                         if Current_Verbosity = High then
1041                            Write_Line ("   OK");
1042                         end if;
1043
1044                         if Full_Path then
1045                            return Get_Name_String
1046                              (Unit.File_Names (Impl).Path.Name);
1047
1048                         else
1049                            return Get_Name_String (The_Body_Name);
1050                         end if;
1051
1052                      else
1053                         if Current_Verbosity = High then
1054                            Write_Line ("   not good");
1055                         end if;
1056                      end if;
1057                   end if;
1058                end;
1059             end if;
1060
1061             --  Check for spec
1062
1063             if not Main_Project_Only
1064               or else
1065                 (Unit.File_Names (Spec) /= null
1066                  and then Unit.File_Names (Spec).Project =
1067                    The_Project)
1068             then
1069                declare
1070                   Current_Name : File_Name_Type;
1071
1072                begin
1073                   --  Case of spec present
1074
1075                   if Unit.File_Names (Spec) /= null then
1076                      Current_Name := Unit.File_Names (Spec).File;
1077                      if Current_Verbosity = High then
1078                         Write_Str  ("   Comparing with """);
1079                         Write_Str  (Get_Name_String (Current_Name));
1080                         Write_Char ('"');
1081                         Write_Eol;
1082                      end if;
1083
1084                      --  If name same as original name, return original name
1085
1086                      if Unit.Name = The_Original_Name
1087                        or else
1088                          Current_Name = File_Name_Type (The_Original_Name)
1089                      then
1090                         if Current_Verbosity = High then
1091                            Write_Line ("   OK");
1092                         end if;
1093
1094                         if Full_Path then
1095                            return Get_Name_String
1096                              (Unit.File_Names (Spec).Path.Name);
1097                         else
1098                            return Get_Name_String (Current_Name);
1099                         end if;
1100
1101                         --  If it has the same name as the extended spec name,
1102                         --  return the extended spec name.
1103
1104                      elsif Current_Name = File_Name_Type (The_Spec_Name) then
1105                         if Current_Verbosity = High then
1106                            Write_Line ("   OK");
1107                         end if;
1108
1109                         if Full_Path then
1110                            return Get_Name_String
1111                              (Unit.File_Names (Spec).Path.Name);
1112                         else
1113                            return Get_Name_String (The_Spec_Name);
1114                         end if;
1115
1116                      else
1117                         if Current_Verbosity = High then
1118                            Write_Line ("   not good");
1119                         end if;
1120                      end if;
1121                   end if;
1122                end;
1123             end if;
1124
1125             Unit := Units_Htable.Get_Next (In_Tree.Units_HT);
1126          end loop;
1127
1128          --  If we are not in an extending project, give up
1129
1130          exit when not Main_Project_Only
1131            or else The_Project.Extends = No_Project;
1132
1133          --  Otherwise, look in the project we are extending
1134
1135          The_Project := The_Project.Extends;
1136       end loop;
1137
1138       --  We don't know this file name, return an empty string
1139
1140       return "";
1141    end File_Name_Of_Library_Unit_Body;
1142
1143    -------------------------
1144    -- For_All_Object_Dirs --
1145    -------------------------
1146
1147    procedure For_All_Object_Dirs (Project : Project_Id) is
1148       procedure For_Project (Prj : Project_Id; Dummy : in out Integer);
1149       --  Get all object directories of Prj
1150
1151       -----------------
1152       -- For_Project --
1153       -----------------
1154
1155       procedure For_Project (Prj : Project_Id; Dummy : in out Integer) is
1156          pragma Unreferenced (Dummy);
1157       begin
1158          --  ??? Set_Ada_Paths has a different behavior for library project
1159          --  files, should we have the same ?
1160
1161          if Prj.Object_Directory /= No_Path_Information then
1162             Get_Name_String (Prj.Object_Directory.Display_Name);
1163             Action (Name_Buffer (1 .. Name_Len));
1164          end if;
1165       end For_Project;
1166
1167       procedure Get_Object_Dirs is
1168         new For_Every_Project_Imported (Integer, For_Project);
1169       Dummy : Integer := 1;
1170
1171    --  Start of processing for For_All_Object_Dirs
1172
1173    begin
1174       Get_Object_Dirs (Project, Dummy);
1175    end For_All_Object_Dirs;
1176
1177    -------------------------
1178    -- For_All_Source_Dirs --
1179    -------------------------
1180
1181    procedure For_All_Source_Dirs
1182      (Project : Project_Id;
1183       In_Tree : Project_Tree_Ref)
1184    is
1185       procedure For_Project (Prj : Project_Id; Dummy : in out Integer);
1186       --  Get all object directories of Prj
1187
1188       -----------------
1189       -- For_Project --
1190       -----------------
1191
1192       procedure For_Project (Prj : Project_Id; Dummy : in out Integer) is
1193          pragma Unreferenced (Dummy);
1194          Current    : String_List_Id := Prj.Source_Dirs;
1195          The_String : String_Element;
1196
1197       begin
1198          --  If there are Ada sources, call action with the name of every
1199          --  source directory.
1200
1201          if Has_Ada_Sources (Project) then
1202             while Current /= Nil_String loop
1203                The_String := In_Tree.String_Elements.Table (Current);
1204                Action (Get_Name_String (The_String.Display_Value));
1205                Current := The_String.Next;
1206             end loop;
1207          end if;
1208       end For_Project;
1209
1210       procedure Get_Source_Dirs is
1211         new For_Every_Project_Imported (Integer, For_Project);
1212       Dummy : Integer := 1;
1213
1214    --  Start of processing for For_All_Source_Dirs
1215
1216    begin
1217       Get_Source_Dirs (Project, Dummy);
1218    end For_All_Source_Dirs;
1219
1220    -------------------
1221    -- Get_Reference --
1222    -------------------
1223
1224    procedure Get_Reference
1225      (Source_File_Name : String;
1226       In_Tree          : Project_Tree_Ref;
1227       Project          : out Project_Id;
1228       Path             : out Path_Name_Type)
1229    is
1230    begin
1231       --  Body below could use some comments ???
1232
1233       if Current_Verbosity > Default then
1234          Write_Str ("Getting Reference_Of (""");
1235          Write_Str (Source_File_Name);
1236          Write_Str (""") ... ");
1237       end if;
1238
1239       declare
1240          Original_Name : String := Source_File_Name;
1241          Unit          : Unit_Index;
1242
1243       begin
1244          Canonical_Case_File_Name (Original_Name);
1245          Unit := Units_Htable.Get_First (In_Tree.Units_HT);
1246
1247          while Unit /= null loop
1248             if Unit.File_Names (Spec) /= null
1249               and then Unit.File_Names (Spec).File /= No_File
1250               and then
1251                 (Namet.Get_Name_String
1252                      (Unit.File_Names (Spec).File) = Original_Name
1253                  or else (Unit.File_Names (Spec).Path /=
1254                             No_Path_Information
1255                           and then
1256                             Namet.Get_Name_String
1257                               (Unit.File_Names (Spec).Path.Name) =
1258                             Original_Name))
1259             then
1260                Project := Ultimate_Extension_Of
1261                           (Project => Unit.File_Names (Spec).Project);
1262                Path := Unit.File_Names (Spec).Path.Display_Name;
1263
1264                if Current_Verbosity > Default then
1265                   Write_Str ("Done: Spec.");
1266                   Write_Eol;
1267                end if;
1268
1269                return;
1270
1271             elsif Unit.File_Names (Impl) /= null
1272               and then Unit.File_Names (Impl).File /= No_File
1273               and then
1274                 (Namet.Get_Name_String
1275                    (Unit.File_Names (Impl).File) = Original_Name
1276                  or else (Unit.File_Names (Impl).Path /=
1277                             No_Path_Information
1278                           and then Namet.Get_Name_String
1279                             (Unit.File_Names (Impl).Path.Name) =
1280                             Original_Name))
1281             then
1282                Project := Ultimate_Extension_Of
1283                             (Project => Unit.File_Names (Impl).Project);
1284                Path := Unit.File_Names (Impl).Path.Display_Name;
1285
1286                if Current_Verbosity > Default then
1287                   Write_Str ("Done: Body.");
1288                   Write_Eol;
1289                end if;
1290
1291                return;
1292             end if;
1293
1294             Unit := Units_Htable.Get_Next (In_Tree.Units_HT);
1295          end loop;
1296       end;
1297
1298       Project := No_Project;
1299       Path    := No_Path;
1300
1301       if Current_Verbosity > Default then
1302          Write_Str ("Cannot be found.");
1303          Write_Eol;
1304       end if;
1305    end Get_Reference;
1306
1307    ----------------
1308    -- Initialize --
1309    ----------------
1310
1311    procedure Initialize (In_Tree : Project_Tree_Ref) is
1312    begin
1313       In_Tree.Private_Part.Current_Source_Path_File := No_Path;
1314       In_Tree.Private_Part.Current_Object_Path_File := No_Path;
1315    end Initialize;
1316
1317    -------------------
1318    -- Print_Sources --
1319    -------------------
1320
1321    --  Could use some comments in this body ???
1322
1323    procedure Print_Sources (In_Tree : Project_Tree_Ref) is
1324       Unit : Unit_Index;
1325
1326    begin
1327       Write_Line ("List of Sources:");
1328
1329       Unit := Units_Htable.Get_First (In_Tree.Units_HT);
1330
1331       while Unit /= No_Unit_Index loop
1332          Write_Str  ("   ");
1333          Write_Line (Namet.Get_Name_String (Unit.Name));
1334
1335          if Unit.File_Names (Spec).File /= No_File then
1336             if Unit.File_Names (Spec).Project = No_Project then
1337                Write_Line ("   No project");
1338
1339             else
1340                Write_Str  ("   Project: ");
1341                Get_Name_String
1342                  (Unit.File_Names (Spec).Project.Path.Name);
1343                Write_Line (Name_Buffer (1 .. Name_Len));
1344             end if;
1345
1346             Write_Str  ("      spec: ");
1347             Write_Line
1348               (Namet.Get_Name_String
1349                (Unit.File_Names (Spec).File));
1350          end if;
1351
1352          if Unit.File_Names (Impl).File /= No_File then
1353             if Unit.File_Names (Impl).Project = No_Project then
1354                Write_Line ("   No project");
1355
1356             else
1357                Write_Str  ("   Project: ");
1358                Get_Name_String
1359                  (Unit.File_Names (Impl).Project.Path.Name);
1360                Write_Line (Name_Buffer (1 .. Name_Len));
1361             end if;
1362
1363             Write_Str  ("      body: ");
1364             Write_Line
1365               (Namet.Get_Name_String (Unit.File_Names (Impl).File));
1366          end if;
1367
1368          Unit := Units_Htable.Get_Next (In_Tree.Units_HT);
1369       end loop;
1370
1371       Write_Line ("end of List of Sources.");
1372    end Print_Sources;
1373
1374    ----------------
1375    -- Project_Of --
1376    ----------------
1377
1378    function Project_Of
1379      (Name         : String;
1380       Main_Project : Project_Id;
1381       In_Tree      : Project_Tree_Ref) return Project_Id
1382    is
1383       Result : Project_Id := No_Project;
1384
1385       Original_Name : String := Name;
1386
1387       Lang : constant Language_Ptr :=
1388                Get_Language_From_Name (Main_Project, "ada");
1389
1390       Unit : Unit_Index;
1391
1392       Current_Name      : File_Name_Type;
1393       The_Original_Name : File_Name_Type;
1394       The_Spec_Name     : File_Name_Type;
1395       The_Body_Name     : File_Name_Type;
1396
1397    begin
1398       --  ??? Same block in File_Name_Of_Library_Unit_Body
1399       Canonical_Case_File_Name (Original_Name);
1400       Name_Len := Original_Name'Length;
1401       Name_Buffer (1 .. Name_Len) := Original_Name;
1402       The_Original_Name := Name_Find;
1403
1404       if Lang /= null then
1405          declare
1406             Naming : Lang_Naming_Data renames Lang.Config.Naming_Data;
1407             Extended_Spec_Name : String :=
1408                                    Name & Namet.Get_Name_String
1409                                             (Naming.Spec_Suffix);
1410             Extended_Body_Name : String :=
1411                                    Name & Namet.Get_Name_String
1412                                             (Naming.Body_Suffix);
1413
1414          begin
1415             Canonical_Case_File_Name (Extended_Spec_Name);
1416             Name_Len := Extended_Spec_Name'Length;
1417             Name_Buffer (1 .. Name_Len) := Extended_Spec_Name;
1418             The_Spec_Name := Name_Find;
1419
1420             Canonical_Case_File_Name (Extended_Body_Name);
1421             Name_Len := Extended_Body_Name'Length;
1422             Name_Buffer (1 .. Name_Len) := Extended_Body_Name;
1423             The_Body_Name := Name_Find;
1424          end;
1425
1426       else
1427          The_Spec_Name := The_Original_Name;
1428          The_Body_Name := The_Original_Name;
1429       end if;
1430
1431       Unit := Units_Htable.Get_First (In_Tree.Units_HT);
1432       while Unit /= null loop
1433
1434          --  Case of a body present
1435
1436          if Unit.File_Names (Impl) /= null then
1437             Current_Name := Unit.File_Names (Impl).File;
1438
1439             --  If it has the name of the original name or the body name,
1440             --  we have found the project.
1441
1442             if Unit.Name = Name_Id (The_Original_Name)
1443               or else Current_Name = The_Original_Name
1444               or else Current_Name = The_Body_Name
1445             then
1446                Result := Unit.File_Names (Impl).Project;
1447                exit;
1448             end if;
1449          end if;
1450
1451          --  Check for spec
1452
1453          if Unit.File_Names (Spec) /= null then
1454             Current_Name := Unit.File_Names (Spec).File;
1455
1456             --  If name same as the original name, or the spec name, we have
1457             --  found the project.
1458
1459             if Unit.Name = Name_Id (The_Original_Name)
1460               or else Current_Name = The_Original_Name
1461               or else Current_Name = The_Spec_Name
1462             then
1463                Result := Unit.File_Names (Spec).Project;
1464                exit;
1465             end if;
1466          end if;
1467
1468          Unit := Units_Htable.Get_Next (In_Tree.Units_HT);
1469       end loop;
1470
1471       --  Get the ultimate extending project
1472
1473       if Result /= No_Project then
1474          while Result.Extended_By /= No_Project loop
1475             Result := Result.Extended_By;
1476          end loop;
1477       end if;
1478
1479       return Result;
1480    end Project_Of;
1481
1482    -------------------
1483    -- Set_Ada_Paths --
1484    -------------------
1485
1486    procedure Set_Ada_Paths
1487      (Project             : Project_Id;
1488       In_Tree             : Project_Tree_Ref;
1489       Including_Libraries : Boolean)
1490
1491    is
1492       Source_Paths : Source_Path_Table.Instance;
1493       Object_Paths : Object_Path_Table.Instance;
1494       --  List of source or object dirs. Only computed the first time this
1495       --  procedure is called (since Source_FD is then reused)
1496
1497       Source_FD : File_Descriptor := Invalid_FD;
1498       Object_FD : File_Descriptor := Invalid_FD;
1499       --  The temporary files to store the paths. These are only created the
1500       --  first time this procedure is called, and reused from then on.
1501
1502       Process_Source_Dirs : Boolean := False;
1503       Process_Object_Dirs : Boolean := False;
1504
1505       Status : Boolean;
1506       --  For calls to Close
1507
1508       Len : Natural;
1509
1510       procedure Recursive_Add (Project : Project_Id; Dummy : in out Boolean);
1511       --  Recursive procedure to add the source/object paths of extended/
1512       --  imported projects.
1513
1514       -------------------
1515       -- Recursive_Add --
1516       -------------------
1517
1518       procedure Recursive_Add (Project : Project_Id; Dummy : in out Boolean) is
1519          pragma Unreferenced (Dummy);
1520
1521          Path : Path_Name_Type;
1522
1523       begin
1524          --  ??? This is almost the equivalent of For_All_Source_Dirs
1525
1526          if Process_Source_Dirs then
1527
1528             --  Add to path all source directories of this project if there are
1529             --  Ada sources.
1530
1531             if Has_Ada_Sources (Project) then
1532                Add_To_Source_Path (Project.Source_Dirs, In_Tree, Source_Paths);
1533             end if;
1534          end if;
1535
1536          if Process_Object_Dirs then
1537             Path := Get_Object_Directory
1538               (Project,
1539                Including_Libraries => Including_Libraries,
1540                Only_If_Ada         => True);
1541
1542             if Path /= No_Path then
1543                Add_To_Object_Path (Path, Object_Paths);
1544             end if;
1545          end if;
1546       end Recursive_Add;
1547
1548       procedure For_All_Projects is
1549         new For_Every_Project_Imported (Boolean, Recursive_Add);
1550       Dummy : Boolean := False;
1551
1552    --  Start of processing for Set_Ada_Paths
1553
1554    begin
1555       --  If it is the first time we call this procedure for this project,
1556       --  compute the source path and/or the object path.
1557
1558       if Project.Include_Path_File = No_Path then
1559          Source_Path_Table.Init (Source_Paths);
1560          Process_Source_Dirs := True;
1561          Create_New_Path_File
1562            (In_Tree, Source_FD, Project.Include_Path_File);
1563       end if;
1564
1565       --  For the object path, we make a distinction depending on
1566       --  Including_Libraries.
1567
1568       if Including_Libraries then
1569          if Project.Objects_Path_File_With_Libs = No_Path then
1570             Object_Path_Table.Init (Object_Paths);
1571             Process_Object_Dirs := True;
1572             Create_New_Path_File
1573               (In_Tree, Object_FD, Project.Objects_Path_File_With_Libs);
1574          end if;
1575
1576       else
1577          if Project.Objects_Path_File_Without_Libs = No_Path then
1578             Object_Path_Table.Init (Object_Paths);
1579             Process_Object_Dirs := True;
1580             Create_New_Path_File
1581               (In_Tree, Object_FD, Project.Objects_Path_File_Without_Libs);
1582          end if;
1583       end if;
1584
1585       --  If there is something to do, set Seen to False for all projects,
1586       --  then call the recursive procedure Add for Project.
1587
1588       if Process_Source_Dirs or Process_Object_Dirs then
1589          For_All_Projects (Project, Dummy);
1590       end if;
1591
1592       --  Write and close any file that has been created. Source_FD is not set
1593       --  when this subprogram is called a second time or more, since we reuse
1594       --  the previous version of the file.
1595
1596       if Source_FD /= Invalid_FD then
1597          for Index in Source_Path_Table.First ..
1598                       Source_Path_Table.Last (Source_Paths)
1599          loop
1600             Get_Name_String (Source_Paths.Table (Index));
1601             Name_Len := Name_Len + 1;
1602             Name_Buffer (Name_Len) := ASCII.LF;
1603             Len := Write (Source_FD, Name_Buffer (1)'Address, Name_Len);
1604
1605             if Len /= Name_Len then
1606                Prj.Com.Fail ("disk full");
1607             end if;
1608          end loop;
1609
1610          Close (Source_FD, Status);
1611
1612          if not Status then
1613             Prj.Com.Fail ("disk full");
1614          end if;
1615       end if;
1616
1617       if Object_FD /= Invalid_FD then
1618          for Index in Object_Path_Table.First ..
1619                       Object_Path_Table.Last (Object_Paths)
1620          loop
1621             Get_Name_String (Object_Paths.Table (Index));
1622             Name_Len := Name_Len + 1;
1623             Name_Buffer (Name_Len) := ASCII.LF;
1624             Len := Write (Object_FD, Name_Buffer (1)'Address, Name_Len);
1625
1626             if Len /= Name_Len then
1627                Prj.Com.Fail ("disk full");
1628             end if;
1629          end loop;
1630
1631          Close (Object_FD, Status);
1632
1633          if not Status then
1634             Prj.Com.Fail ("disk full");
1635          end if;
1636       end if;
1637
1638       --  Set the env vars, if they need to be changed, and set the
1639       --  corresponding flags.
1640
1641       if In_Tree.Private_Part.Current_Source_Path_File /=
1642            Project.Include_Path_File
1643       then
1644          In_Tree.Private_Part.Current_Source_Path_File :=
1645            Project.Include_Path_File;
1646          Set_Path_File_Var
1647            (Project_Include_Path_File,
1648             Get_Name_String (In_Tree.Private_Part.Current_Source_Path_File));
1649       end if;
1650
1651       if Including_Libraries then
1652          if In_Tree.Private_Part.Current_Object_Path_File /=
1653             Project.Objects_Path_File_With_Libs
1654          then
1655             In_Tree.Private_Part.Current_Object_Path_File :=
1656               Project.Objects_Path_File_With_Libs;
1657             Set_Path_File_Var
1658               (Project_Objects_Path_File,
1659                Get_Name_String
1660                  (In_Tree.Private_Part.Current_Object_Path_File));
1661          end if;
1662
1663       else
1664          if In_Tree.Private_Part.Current_Object_Path_File /=
1665             Project.Objects_Path_File_Without_Libs
1666          then
1667             In_Tree.Private_Part.Current_Object_Path_File :=
1668               Project.Objects_Path_File_Without_Libs;
1669             Set_Path_File_Var
1670               (Project_Objects_Path_File,
1671                Get_Name_String
1672                  (In_Tree.Private_Part.Current_Object_Path_File));
1673          end if;
1674       end if;
1675    end Set_Ada_Paths;
1676
1677    -----------------------
1678    -- Set_Path_File_Var --
1679    -----------------------
1680
1681    procedure Set_Path_File_Var (Name : String; Value : String) is
1682       Host_Spec : String_Access := To_Host_File_Spec (Value);
1683    begin
1684       if Host_Spec = null then
1685          Prj.Com.Fail
1686            ("could not convert file name """ & Value & """ to host spec");
1687       else
1688          Setenv (Name, Host_Spec.all);
1689          Free (Host_Spec);
1690       end if;
1691    end Set_Path_File_Var;
1692
1693    ---------------------------
1694    -- Ultimate_Extension_Of --
1695    ---------------------------
1696
1697    function Ultimate_Extension_Of
1698      (Project : Project_Id) return Project_Id
1699    is
1700       Result : Project_Id;
1701
1702    begin
1703       Result := Project;
1704       while Result.Extended_By /= No_Project loop
1705          Result := Result.Extended_By;
1706       end loop;
1707
1708       return Result;
1709    end Ultimate_Extension_Of;
1710
1711 end Prj.Env;