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