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