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