gcc/ada/prj.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                                  P R J                                   --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 2001-2014, 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 Opt;
  27 with Osint;    use Osint;
  28 with Output;   use Output;
  29 with Prj.Attr;
  30 with Prj.Com;
  31 with Prj.Err;  use Prj.Err;
  32 with Snames;   use Snames;
  33 with Uintp;    use Uintp;
  34
  35 with Ada.Characters.Handling;    use Ada.Characters.Handling;
  36 with Ada.Containers.Ordered_Sets;
  37 with Ada.Unchecked_Deallocation;
  38
  39 with GNAT.Case_Util;            use GNAT.Case_Util;
  40 with GNAT.Directory_Operations; use GNAT.Directory_Operations;
  41 with GNAT.HTable;
  42
  43 package body Prj is
  44
  45    type Restricted_Lang;
  46    type Restricted_Lang_Access is access Restricted_Lang;
  47    type Restricted_Lang is record
  48       Name : Name_Id;
  49       Next : Restricted_Lang_Access;
  50    end record;
  51
  52    Restricted_Languages : Restricted_Lang_Access := null;
  53    --  When null, all languages are allowed, otherwise only the languages in
  54    --  the list are allowed.
  55
  56    Object_Suffix : constant String := Get_Target_Object_Suffix.all;
  57    --  File suffix for object files
  58
  59    Initial_Buffer_Size : constant := 100;
  60    --  Initial size for extensible buffer used in Add_To_Buffer
  61
  62    The_Empty_String : Name_Id := No_Name;
  63    The_Dot_String   : Name_Id := No_Name;
  64
  65    Debug_Level : Integer := 0;
  66    --  Current indentation level for debug traces
  67
  68    type Cst_String_Access is access constant String;
  69
  70    All_Lower_Case_Image : aliased constant String := "lowercase";
  71    All_Upper_Case_Image : aliased constant String := "UPPERCASE";
  72    Mixed_Case_Image     : aliased constant String := "MixedCase";
  73
  74    The_Casing_Images : constant array (Known_Casing) of Cst_String_Access :=
  75                          (All_Lower_Case => All_Lower_Case_Image'Access,
  76                           All_Upper_Case => All_Upper_Case_Image'Access,
  77                           Mixed_Case     => Mixed_Case_Image'Access);
  78
  79    procedure Free (Project : in out Project_Id);
  80    --  Free memory allocated for Project
  81
  82    procedure Free_List (Languages : in out Language_Ptr);
  83    procedure Free_List (Source : in out Source_Id);
  84    procedure Free_List (Languages : in out Language_List);
  85    --  Free memory allocated for the list of languages or sources
  86
  87    procedure Reset_Units_In_Table (Table : in out Units_Htable.Instance);
  88    --  Resets all Units to No_Unit_Index Unit.File_Names (Spec).Unit &
  89    --  Unit.File_Names (Impl).Unit in the given table.
  90
  91    procedure Free_Units (Table : in out Units_Htable.Instance);
  92    --  Free memory allocated for unit information in the project
  93
  94    procedure Language_Changed (Iter : in out Source_Iterator);
  95    procedure Project_Changed (Iter : in out Source_Iterator);
  96    --  Called when a new project or language was selected for this iterator
  97
  98    function Contains_ALI_Files (Dir : Path_Name_Type) return Boolean;
  99    --  Return True if there is at least one ALI file in the directory Dir
 100
 101    -----------------------------
 102    -- Add_Restricted_Language --
 103    -----------------------------
 104
 105    procedure Add_Restricted_Language (Name : String) is
 106       N : String (1 .. Name'Length) := Name;
 107    begin
 108       To_Lower (N);
 109       Name_Len := 0;
 110       Add_Str_To_Name_Buffer (N);
 111       Restricted_Languages :=
 112         new Restricted_Lang'(Name => Name_Find, Next => Restricted_Languages);
 113    end Add_Restricted_Language;
 114
 115    -------------------------------------
 116    -- Remove_All_Restricted_Languages --
 117    -------------------------------------
 118
 119    procedure Remove_All_Restricted_Languages is
 120    begin
 121       Restricted_Languages := null;
 122    end Remove_All_Restricted_Languages;
 123
 124    -------------------
 125    -- Add_To_Buffer --
 126    -------------------
 127
 128    procedure Add_To_Buffer
 129      (S    : String;
 130       To   : in out String_Access;
 131       Last : in out Natural)
 132    is
 133    begin
 134       if To = null then
 135          To := new String (1 .. Initial_Buffer_Size);
 136          Last := 0;
 137       end if;
 138
 139       --  If Buffer is too small, double its size
 140
 141       while Last + S'Length > To'Last loop
 142          declare
 143             New_Buffer : constant  String_Access :=
 144                            new String (1 .. 2 * To'Length);
 145          begin
 146             New_Buffer (1 .. Last) := To (1 .. Last);
 147             Free (To);
 148             To := New_Buffer;
 149          end;
 150       end loop;
 151
 152       To (Last + 1 .. Last + S'Length) := S;
 153       Last := Last + S'Length;
 154    end Add_To_Buffer;
 155
 156    ---------------------------------
 157    -- Current_Object_Path_File_Of --
 158    ---------------------------------
 159
 160    function Current_Object_Path_File_Of
 161      (Shared : Shared_Project_Tree_Data_Access) return Path_Name_Type
 162    is
 163    begin
 164       return Shared.Private_Part.Current_Object_Path_File;
 165    end Current_Object_Path_File_Of;
 166
 167    ---------------------------------
 168    -- Current_Source_Path_File_Of --
 169    ---------------------------------
 170
 171    function Current_Source_Path_File_Of
 172      (Shared : Shared_Project_Tree_Data_Access)
 173       return Path_Name_Type is
 174    begin
 175       return Shared.Private_Part.Current_Source_Path_File;
 176    end Current_Source_Path_File_Of;
 177
 178    ---------------------------
 179    -- Delete_Temporary_File --
 180    ---------------------------
 181
 182    procedure Delete_Temporary_File
 183      (Shared : Shared_Project_Tree_Data_Access := null;
 184       Path   : Path_Name_Type)
 185    is
 186       Dont_Care : Boolean;
 187       pragma Warnings (Off, Dont_Care);
 188
 189    begin
 190       if not Opt.Keep_Temporary_Files  then
 191          if Current_Verbosity = High then
 192             Write_Line ("Removing temp file: " & Get_Name_String (Path));
 193          end if;
 194
 195          Delete_File (Get_Name_String (Path), Dont_Care);
 196
 197          if Shared /= null then
 198             for Index in
 199               1 .. Temp_Files_Table.Last (Shared.Private_Part.Temp_Files)
 200             loop
 201                if Shared.Private_Part.Temp_Files.Table (Index) = Path then
 202                   Shared.Private_Part.Temp_Files.Table (Index) := No_Path;
 203                end if;
 204             end loop;
 205          end if;
 206       end if;
 207    end Delete_Temporary_File;
 208
 209    ------------------------------
 210    -- Delete_Temp_Config_Files --
 211    ------------------------------
 212
 213    procedure Delete_Temp_Config_Files (Project_Tree : Project_Tree_Ref) is
 214       Success : Boolean;
 215       pragma Warnings (Off, Success);
 216
 217       Proj : Project_List;
 218
 219    begin
 220       if not Opt.Keep_Temporary_Files then
 221          if Project_Tree /= null then
 222             Proj := Project_Tree.Projects;
 223             while Proj /= null loop
 224                if Proj.Project.Config_File_Temp then
 225                   Delete_Temporary_File
 226                     (Project_Tree.Shared, Proj.Project.Config_File_Name);
 227
 228                   --  Make sure that we don't have a config file for this
 229                   --  project, in case there are several mains. In this case,
 230                   --  we will recreate another config file: we cannot reuse the
 231                   --  one that we just deleted.
 232
 233                   Proj.Project.Config_Checked   := False;
 234                   Proj.Project.Config_File_Name := No_Path;
 235                   Proj.Project.Config_File_Temp := False;
 236                end if;
 237
 238                Proj := Proj.Next;
 239             end loop;
 240          end if;
 241       end if;
 242    end Delete_Temp_Config_Files;
 243
 244    ---------------------------
 245    -- Delete_All_Temp_Files --
 246    ---------------------------
 247
 248    procedure Delete_All_Temp_Files
 249      (Shared : Shared_Project_Tree_Data_Access)
 250    is
 251       Dont_Care : Boolean;
 252       pragma Warnings (Off, Dont_Care);
 253
 254       Path : Path_Name_Type;
 255
 256    begin
 257       if not Opt.Keep_Temporary_Files then
 258          for Index in
 259            1 .. Temp_Files_Table.Last (Shared.Private_Part.Temp_Files)
 260          loop
 261             Path := Shared.Private_Part.Temp_Files.Table (Index);
 262
 263             if Path /= No_Path then
 264                if Current_Verbosity = High then
 265                   Write_Line ("Removing temp file: "
 266                               & Get_Name_String (Path));
 267                end if;
 268
 269                Delete_File (Get_Name_String (Path), Dont_Care);
 270             end if;
 271          end loop;
 272
 273          Temp_Files_Table.Free (Shared.Private_Part.Temp_Files);
 274          Temp_Files_Table.Init (Shared.Private_Part.Temp_Files);
 275       end if;
 276
 277       --  If any of the environment variables ADA_PRJ_INCLUDE_FILE or
 278       --  ADA_PRJ_OBJECTS_FILE has been set, then reset their value to
 279       --  the empty string.
 280
 281       if Shared.Private_Part.Current_Source_Path_File /= No_Path then
 282          Setenv (Project_Include_Path_File, "");
 283       end if;
 284
 285       if Shared.Private_Part.Current_Object_Path_File /= No_Path then
 286          Setenv (Project_Objects_Path_File, "");
 287       end if;
 288    end Delete_All_Temp_Files;
 289
 290    ---------------------
 291    -- Dependency_Name --
 292    ---------------------
 293
 294    function Dependency_Name
 295      (Source_File_Name : File_Name_Type;
 296       Dependency       : Dependency_File_Kind) return File_Name_Type
 297    is
 298    begin
 299       case Dependency is
 300          when None =>
 301             return No_File;
 302
 303          when Makefile =>
 304             return Extend_Name (Source_File_Name, Makefile_Dependency_Suffix);
 305
 306          when ALI_File | ALI_Closure =>
 307             return Extend_Name (Source_File_Name, ALI_Dependency_Suffix);
 308       end case;
 309    end Dependency_Name;
 310
 311    ----------------
 312    -- Dot_String --
 313    ----------------
 314
 315    function Dot_String return Name_Id is
 316    begin
 317       return The_Dot_String;
 318    end Dot_String;
 319
 320    ----------------
 321    -- Empty_File --
 322    ----------------
 323
 324    function Empty_File return File_Name_Type is
 325    begin
 326       return File_Name_Type (The_Empty_String);
 327    end Empty_File;
 328
 329    -------------------
 330    -- Empty_Project --
 331    -------------------
 332
 333    function Empty_Project
 334      (Qualifier : Project_Qualifier) return Project_Data
 335    is
 336    begin
 337       Prj.Initialize (Tree => No_Project_Tree);
 338
 339       declare
 340          Data : Project_Data (Qualifier => Qualifier);
 341
 342       begin
 343          --  Only the fields for which no default value could be provided in
 344          --  prj.ads are initialized below.
 345
 346          Data.Config := Default_Project_Config;
 347          return Data;
 348       end;
 349    end Empty_Project;
 350
 351    ------------------
 352    -- Empty_String --
 353    ------------------
 354
 355    function Empty_String return Name_Id is
 356    begin
 357       return The_Empty_String;
 358    end Empty_String;
 359
 360    ------------
 361    -- Expect --
 362    ------------
 363
 364    procedure Expect (The_Token : Token_Type; Token_Image : String) is
 365    begin
 366       if Token /= The_Token then
 367
 368          --  ??? Should pass user flags here instead
 369
 370          Error_Msg (Gnatmake_Flags, Token_Image & " expected", Token_Ptr);
 371       end if;
 372    end Expect;
 373
 374    -----------------
 375    -- Extend_Name --
 376    -----------------
 377
 378    function Extend_Name
 379      (File        : File_Name_Type;
 380       With_Suffix : String) return File_Name_Type
 381    is
 382       Last : Positive;
 383
 384    begin
 385       Get_Name_String (File);
 386       Last := Name_Len + 1;
 387
 388       while Name_Len /= 0 and then Name_Buffer (Name_Len) /= '.' loop
 389          Name_Len := Name_Len - 1;
 390       end loop;
 391
 392       if Name_Len <= 1 then
 393          Name_Len := Last;
 394       end if;
 395
 396       for J in With_Suffix'Range loop
 397          Name_Buffer (Name_Len) := With_Suffix (J);
 398          Name_Len := Name_Len + 1;
 399       end loop;
 400
 401       Name_Len := Name_Len - 1;
 402       return Name_Find;
 403    end Extend_Name;
 404
 405    -------------------------
 406    -- Is_Allowed_Language --
 407    -------------------------
 408
 409    function Is_Allowed_Language (Name : Name_Id) return Boolean is
 410       R    : Restricted_Lang_Access := Restricted_Languages;
 411       Lang : constant String := Get_Name_String (Name);
 412
 413    begin
 414       if R = null then
 415          return True;
 416
 417       else
 418          while R /= null loop
 419             if Get_Name_String (R.Name) = Lang then
 420                return True;
 421             end if;
 422
 423             R := R.Next;
 424          end loop;
 425
 426          return False;
 427       end if;
 428    end Is_Allowed_Language;
 429
 430    ---------------------
 431    -- Project_Changed --
 432    ---------------------
 433
 434    procedure Project_Changed (Iter : in out Source_Iterator) is
 435    begin
 436       if Iter.Project /= null then
 437          Iter.Language := Iter.Project.Project.Languages;
 438          Language_Changed (Iter);
 439       end if;
 440    end Project_Changed;
 441
 442    ----------------------
 443    -- Language_Changed --
 444    ----------------------
 445
 446    procedure Language_Changed (Iter : in out Source_Iterator) is
 447    begin
 448       Iter.Current := No_Source;
 449
 450       if Iter.Language_Name /= No_Name then
 451          while Iter.Language /= null
 452            and then Iter.Language.Name /= Iter.Language_Name
 453          loop
 454             Iter.Language := Iter.Language.Next;
 455          end loop;
 456       end if;
 457
 458       --  If there is no matching language in this project, move to next
 459
 460       if Iter.Language = No_Language_Index then
 461          if Iter.All_Projects then
 462             loop
 463                Iter.Project := Iter.Project.Next;
 464                exit when Iter.Project = null
 465                  or else Iter.Encapsulated_Libs
 466                  or else not Iter.Project.From_Encapsulated_Lib;
 467             end loop;
 468
 469             Project_Changed (Iter);
 470          else
 471             Iter.Project := null;
 472          end if;
 473
 474       else
 475          Iter.Current := Iter.Language.First_Source;
 476
 477          if Iter.Current = No_Source then
 478             Iter.Language := Iter.Language.Next;
 479             Language_Changed (Iter);
 480
 481          elsif not Iter.Locally_Removed
 482            and then Iter.Current.Locally_Removed
 483          then
 484             Next (Iter);
 485          end if;
 486       end if;
 487    end Language_Changed;
 488
 489    ---------------------
 490    -- For_Each_Source --
 491    ---------------------
 492
 493    function For_Each_Source
 494      (In_Tree           : Project_Tree_Ref;
 495       Project           : Project_Id := No_Project;
 496       Language          : Name_Id := No_Name;
 497       Encapsulated_Libs : Boolean := True;
 498       Locally_Removed   : Boolean := True) return Source_Iterator
 499    is
 500       Iter : Source_Iterator;
 501    begin
 502       Iter := Source_Iterator'
 503         (In_Tree           => In_Tree,
 504          Project           => In_Tree.Projects,
 505          All_Projects      => Project = No_Project,
 506          Language_Name     => Language,
 507          Language          => No_Language_Index,
 508          Current           => No_Source,
 509          Encapsulated_Libs => Encapsulated_Libs,
 510          Locally_Removed   => Locally_Removed);
 511
 512       if Project /= null then
 513          while Iter.Project /= null
 514            and then Iter.Project.Project /= Project
 515          loop
 516             Iter.Project := Iter.Project.Next;
 517          end loop;
 518
 519       else
 520          while not Iter.Encapsulated_Libs
 521            and then Iter.Project.From_Encapsulated_Lib
 522          loop
 523             Iter.Project := Iter.Project.Next;
 524          end loop;
 525       end if;
 526
 527       Project_Changed (Iter);
 528
 529       return Iter;
 530    end For_Each_Source;
 531
 532    -------------
 533    -- Element --
 534    -------------
 535
 536    function Element (Iter : Source_Iterator) return Source_Id is
 537    begin
 538       return Iter.Current;
 539    end Element;
 540
 541    ----------
 542    -- Next --
 543    ----------
 544
 545    procedure Next (Iter : in out Source_Iterator) is
 546    begin
 547       loop
 548          Iter.Current := Iter.Current.Next_In_Lang;
 549
 550          exit when Iter.Locally_Removed
 551            or else Iter.Current = No_Source
 552            or else not Iter.Current.Locally_Removed;
 553       end loop;
 554
 555       if Iter.Current = No_Source then
 556          Iter.Language := Iter.Language.Next;
 557          Language_Changed (Iter);
 558       end if;
 559    end Next;
 560
 561    --------------------------------
 562    -- For_Every_Project_Imported --
 563    --------------------------------
 564
 565    procedure For_Every_Project_Imported_Context
 566      (By                 : Project_Id;
 567       Tree               : Project_Tree_Ref;
 568       With_State         : in out State;
 569       Include_Aggregated : Boolean := True;
 570       Imported_First     : Boolean := False)
 571    is
 572       use Project_Boolean_Htable;
 573
 574       procedure Recursive_Check_Context
 575         (Project               : Project_Id;
 576          Tree                  : Project_Tree_Ref;
 577          In_Aggregate_Lib      : Boolean;
 578          From_Encapsulated_Lib : Boolean);
 579       --  Recursively handle the project tree creating a new context for
 580       --  keeping track about already handled projects.
 581
 582       -----------------------------
 583       -- Recursive_Check_Context --
 584       -----------------------------
 585
 586       procedure Recursive_Check_Context
 587         (Project               : Project_Id;
 588          Tree                  : Project_Tree_Ref;
 589          In_Aggregate_Lib      : Boolean;
 590          From_Encapsulated_Lib : Boolean)
 591       is
 592          package Name_Id_Set is
 593            new Ada.Containers.Ordered_Sets (Element_Type => Name_Id);
 594
 595          Seen_Name : Name_Id_Set.Set;
 596          --  This set is needed to ensure that we do not handle the same
 597          --  project twice in the context of aggregate libraries.
 598
 599          procedure Recursive_Check
 600            (Project               : Project_Id;
 601             Tree                  : Project_Tree_Ref;
 602             In_Aggregate_Lib      : Boolean;
 603             From_Encapsulated_Lib : Boolean);
 604          --  Check if project has already been seen. If not, mark it as Seen,
 605          --  Call Action, and check all its imported and aggregated projects.
 606
 607          ---------------------
 608          -- Recursive_Check --
 609          ---------------------
 610
 611          procedure Recursive_Check
 612            (Project               : Project_Id;
 613             Tree                  : Project_Tree_Ref;
 614             In_Aggregate_Lib      : Boolean;
 615             From_Encapsulated_Lib : Boolean)
 616          is
 617
 618             function Has_Sources (P : Project_Id) return Boolean;
 619             --  Returns True if P has sources
 620
 621             function Get_From_Tree (P : Project_Id) return Project_Id;
 622             --  Get project P from Tree. If P has no sources get another
 623             --  instance of this project with sources. If P has sources,
 624             --  returns it.
 625
 626             -----------------
 627             -- Has_Sources --
 628             -----------------
 629
 630             function Has_Sources (P : Project_Id) return Boolean is
 631                Lang : Language_Ptr;
 632
 633             begin
 634                Lang := P.Languages;
 635                while Lang /= No_Language_Index loop
 636                   if Lang.First_Source /= No_Source then
 637                      return True;
 638                   end if;
 639
 640                   Lang := Lang.Next;
 641                end loop;
 642
 643                return False;
 644             end Has_Sources;
 645
 646             -------------------
 647             -- Get_From_Tree --
 648             -------------------
 649
 650             function Get_From_Tree (P : Project_Id) return Project_Id is
 651                List : Project_List := Tree.Projects;
 652
 653             begin
 654                if not Has_Sources (P) then
 655                   while List /= null loop
 656                      if List.Project.Name = P.Name
 657                        and then Has_Sources (List.Project)
 658                      then
 659                         return List.Project;
 660                      end if;
 661
 662                      List := List.Next;
 663                   end loop;
 664                end if;
 665
 666                return P;
 667             end Get_From_Tree;
 668
 669             --  Local variables
 670
 671             List : Project_List;
 672
 673          --  Start of processing for Recursive_Check
 674
 675          begin
 676             if not Seen_Name.Contains (Project.Name) then
 677
 678                --  Even if a project is aggregated multiple times in an
 679                --  aggregated library, we will only return it once.
 680
 681                Seen_Name.Include (Project.Name);
 682
 683                if not Imported_First then
 684                   Action
 685                     (Get_From_Tree (Project),
 686                      Tree,
 687                      Project_Context'(In_Aggregate_Lib, From_Encapsulated_Lib),
 688                      With_State);
 689                end if;
 690
 691                --  Visit all extended projects
 692
 693                if Project.Extends /= No_Project then
 694                   Recursive_Check
 695                     (Project.Extends, Tree,
 696                      In_Aggregate_Lib, From_Encapsulated_Lib);
 697                end if;
 698
 699                --  Visit all imported projects
 700
 701                List := Project.Imported_Projects;
 702                while List /= null loop
 703                   Recursive_Check
 704                     (List.Project, Tree,
 705                      In_Aggregate_Lib,
 706                      From_Encapsulated_Lib
 707                        or else Project.Standalone_Library = Encapsulated);
 708                   List := List.Next;
 709                end loop;
 710
 711                --  Visit all aggregated projects
 712
 713                if Include_Aggregated
 714                  and then Project.Qualifier in Aggregate_Project
 715                then
 716                   declare
 717                      Agg : Aggregated_Project_List;
 718
 719                   begin
 720                      Agg := Project.Aggregated_Projects;
 721                      while Agg /= null loop
 722                         pragma Assert (Agg.Project /= No_Project);
 723
 724                         --  For aggregated libraries, the tree must be the one
 725                         --  of the aggregate library.
 726
 727                         if Project.Qualifier = Aggregate_Library then
 728                            Recursive_Check
 729                              (Agg.Project, Tree,
 730                               True,
 731                               From_Encapsulated_Lib
 732                                 or else
 733                                   Project.Standalone_Library = Encapsulated);
 734
 735                         else
 736                            --  Use a new context as we want to returns the same
 737                            --  project in different project tree for aggregated
 738                            --  projects.
 739
 740                            Recursive_Check_Context
 741                              (Agg.Project, Agg.Tree, False, False);
 742                         end if;
 743
 744                         Agg := Agg.Next;
 745                      end loop;
 746                   end;
 747                end if;
 748
 749                if Imported_First then
 750                   Action
 751                     (Get_From_Tree (Project),
 752                      Tree,
 753                      Project_Context'(In_Aggregate_Lib, From_Encapsulated_Lib),
 754                      With_State);
 755                end if;
 756             end if;
 757          end Recursive_Check;
 758
 759       --  Start of processing for Recursive_Check_Context
 760
 761       begin
 762          Recursive_Check
 763            (Project, Tree, In_Aggregate_Lib, From_Encapsulated_Lib);
 764       end Recursive_Check_Context;
 765
 766    --  Start of processing for For_Every_Project_Imported
 767
 768    begin
 769       Recursive_Check_Context
 770         (Project               => By,
 771          Tree                  => Tree,
 772          In_Aggregate_Lib      => False,
 773          From_Encapsulated_Lib => False);
 774    end For_Every_Project_Imported_Context;
 775
 776    procedure For_Every_Project_Imported
 777      (By                 : Project_Id;
 778       Tree               : Project_Tree_Ref;
 779       With_State         : in out State;
 780       Include_Aggregated : Boolean := True;
 781       Imported_First     : Boolean := False)
 782    is
 783       procedure Internal
 784         (Project    : Project_Id;
 785          Tree       : Project_Tree_Ref;
 786          Context    : Project_Context;
 787          With_State : in out State);
 788       --  Action wrapper for handling the context
 789
 790       --------------
 791       -- Internal --
 792       --------------
 793
 794       procedure Internal
 795         (Project    : Project_Id;
 796          Tree       : Project_Tree_Ref;
 797          Context    : Project_Context;
 798          With_State : in out State)
 799       is
 800          pragma Unreferenced (Context);
 801       begin
 802          Action (Project, Tree, With_State);
 803       end Internal;
 804
 805       procedure For_Projects is
 806         new For_Every_Project_Imported_Context (State, Internal);
 807
 808    begin
 809       For_Projects (By, Tree, With_State, Include_Aggregated, Imported_First);
 810    end For_Every_Project_Imported;
 811
 812    -----------------
 813    -- Find_Source --
 814    -----------------
 815
 816    function Find_Source
 817      (In_Tree          : Project_Tree_Ref;
 818       Project          : Project_Id;
 819       In_Imported_Only : Boolean := False;
 820       In_Extended_Only : Boolean := False;
 821       Base_Name        : File_Name_Type;
 822       Index            : Int := 0) return Source_Id
 823    is
 824       Result : Source_Id  := No_Source;
 825
 826       procedure Look_For_Sources
 827         (Proj : Project_Id;
 828          Tree : Project_Tree_Ref;
 829          Src  : in out Source_Id);
 830       --  Look for Base_Name in the sources of Proj
 831
 832       ----------------------
 833       -- Look_For_Sources --
 834       ----------------------
 835
 836       procedure Look_For_Sources
 837         (Proj : Project_Id;
 838          Tree : Project_Tree_Ref;
 839          Src  : in out Source_Id)
 840       is
 841          Iterator : Source_Iterator;
 842
 843       begin
 844          Iterator := For_Each_Source (In_Tree => Tree, Project => Proj);
 845          while Element (Iterator) /= No_Source loop
 846             if Element (Iterator).File = Base_Name
 847               and then (Index = 0 or else Element (Iterator).Index = Index)
 848             then
 849                Src := Element (Iterator);
 850
 851                --  If the source has been excluded, continue looking. We will
 852                --  get the excluded source only if there is no other source
 853                --  with the same base name that is not locally removed.
 854
 855                if not Element (Iterator).Locally_Removed then
 856                   return;
 857                end if;
 858             end if;
 859
 860             Next (Iterator);
 861          end loop;
 862       end Look_For_Sources;
 863
 864       procedure For_Imported_Projects is new For_Every_Project_Imported
 865         (State => Source_Id, Action => Look_For_Sources);
 866
 867       Proj : Project_Id;
 868
 869    --  Start of processing for Find_Source
 870
 871    begin
 872       if In_Extended_Only then
 873          Proj := Project;
 874          while Proj /= No_Project loop
 875             Look_For_Sources (Proj, In_Tree, Result);
 876             exit when Result /= No_Source;
 877
 878             Proj := Proj.Extends;
 879          end loop;
 880
 881       elsif In_Imported_Only then
 882          Look_For_Sources (Project, In_Tree, Result);
 883
 884          if Result = No_Source then
 885             For_Imported_Projects
 886               (By                 => Project,
 887                Tree               => In_Tree,
 888                Include_Aggregated => False,
 889                With_State         => Result);
 890          end if;
 891
 892       else
 893          Look_For_Sources (No_Project, In_Tree, Result);
 894       end if;
 895
 896       return Result;
 897    end Find_Source;
 898
 899    ----------------------
 900    -- Find_All_Sources --
 901    ----------------------
 902
 903    function Find_All_Sources
 904      (In_Tree          : Project_Tree_Ref;
 905       Project          : Project_Id;
 906       In_Imported_Only : Boolean := False;
 907       In_Extended_Only : Boolean := False;
 908       Base_Name        : File_Name_Type;
 909       Index            : Int := 0) return Source_Ids
 910    is
 911       Result : Source_Ids (1 .. 1_000);
 912       Last   : Natural := 0;
 913
 914       type Empty_State is null record;
 915       No_State : Empty_State;
 916       --  This is needed for the State parameter of procedure Look_For_Sources
 917       --  below, because of the instantiation For_Imported_Projects of generic
 918       --  procedure For_Every_Project_Imported. As procedure Look_For_Sources
 919       --  does not modify parameter State, there is no need to give its type
 920       --  more than one value.
 921
 922       procedure Look_For_Sources
 923         (Proj  : Project_Id;
 924          Tree  : Project_Tree_Ref;
 925          State : in out Empty_State);
 926       --  Look for Base_Name in the sources of Proj
 927
 928       ----------------------
 929       -- Look_For_Sources --
 930       ----------------------
 931
 932       procedure Look_For_Sources
 933         (Proj  : Project_Id;
 934          Tree  : Project_Tree_Ref;
 935          State : in out Empty_State)
 936       is
 937          Iterator : Source_Iterator;
 938          Src : Source_Id;
 939
 940       begin
 941          State := No_State;
 942
 943          Iterator := For_Each_Source (In_Tree => Tree, Project => Proj);
 944          while Element (Iterator) /= No_Source loop
 945             if Element (Iterator).File = Base_Name
 946               and then (Index = 0
 947                         or else
 948                           (Element (Iterator).Unit /= No_Unit_Index
 949                            and then
 950                            Element (Iterator).Index = Index))
 951             then
 952                Src := Element (Iterator);
 953
 954                --  If the source has been excluded, continue looking. We will
 955                --  get the excluded source only if there is no other source
 956                --  with the same base name that is not locally removed.
 957
 958                if not Element (Iterator).Locally_Removed then
 959                   Last := Last + 1;
 960                   Result (Last) := Src;
 961                end if;
 962             end if;
 963
 964             Next (Iterator);
 965          end loop;
 966       end Look_For_Sources;
 967
 968       procedure For_Imported_Projects is new For_Every_Project_Imported
 969         (State => Empty_State, Action => Look_For_Sources);
 970
 971       Proj : Project_Id;
 972
 973    --  Start of processing for Find_All_Sources
 974
 975    begin
 976       if In_Extended_Only then
 977          Proj := Project;
 978          while Proj /= No_Project loop
 979             Look_For_Sources (Proj, In_Tree, No_State);
 980             exit when Last > 0;
 981             Proj := Proj.Extends;
 982          end loop;
 983
 984       elsif In_Imported_Only then
 985          Look_For_Sources (Project, In_Tree, No_State);
 986
 987          if Last = 0 then
 988             For_Imported_Projects
 989               (By                 => Project,
 990                Tree               => In_Tree,
 991                Include_Aggregated => False,
 992                With_State         => No_State);
 993          end if;
 994
 995       else
 996          Look_For_Sources (No_Project, In_Tree, No_State);
 997       end if;
 998
 999       return Result (1 .. Last);
1000    end Find_All_Sources;
1001
1002    ----------
1003    -- Hash --
1004    ----------
1005
1006    function Hash is new GNAT.HTable.Hash (Header_Num => Header_Num);
1007    --  Used in implementation of other functions Hash below
1008
1009    ----------
1010    -- Hash --
1011    ----------
1012
1013    function Hash (Name : File_Name_Type) return Header_Num is
1014    begin
1015       return Hash (Get_Name_String (Name));
1016    end Hash;
1017
1018    function Hash (Name : Name_Id) return Header_Num is
1019    begin
1020       return Hash (Get_Name_String (Name));
1021    end Hash;
1022
1023    function Hash (Name : Path_Name_Type) return Header_Num is
1024    begin
1025       return Hash (Get_Name_String (Name));
1026    end Hash;
1027
1028    function Hash (Project : Project_Id) return Header_Num is
1029    begin
1030       if Project = No_Project then
1031          return Header_Num'First;
1032       else
1033          return Hash (Get_Name_String (Project.Name));
1034       end if;
1035    end Hash;
1036
1037    -----------
1038    -- Image --
1039    -----------
1040
1041    function Image (The_Casing : Casing_Type) return String is
1042    begin
1043       return The_Casing_Images (The_Casing).all;
1044    end Image;
1045
1046    -----------------------------
1047    -- Is_Standard_GNAT_Naming --
1048    -----------------------------
1049
1050    function Is_Standard_GNAT_Naming
1051      (Naming : Lang_Naming_Data) return Boolean
1052    is
1053    begin
1054       return Get_Name_String (Naming.Spec_Suffix) = ".ads"
1055         and then Get_Name_String (Naming.Body_Suffix) = ".adb"
1056         and then Get_Name_String (Naming.Dot_Replacement) = "-";
1057    end Is_Standard_GNAT_Naming;
1058
1059    ----------------
1060    -- Initialize --
1061    ----------------
1062
1063    procedure Initialize (Tree : Project_Tree_Ref) is
1064    begin
1065       if The_Empty_String = No_Name then
1066          Uintp.Initialize;
1067          Name_Len := 0;
1068          The_Empty_String := Name_Find;
1069
1070          Name_Len := 1;
1071          Name_Buffer (1) := '.';
1072          The_Dot_String := Name_Find;
1073
1074          Prj.Attr.Initialize;
1075
1076          --  Make sure that new reserved words after Ada 95 may be used as
1077          --  identifiers.
1078
1079          Opt.Ada_Version := Opt.Ada_95;
1080          Opt.Ada_Version_Pragma := Empty;
1081
1082          Set_Name_Table_Byte (Name_Project,  Token_Type'Pos (Tok_Project));
1083          Set_Name_Table_Byte (Name_Extends,  Token_Type'Pos (Tok_Extends));
1084          Set_Name_Table_Byte (Name_External, Token_Type'Pos (Tok_External));
1085          Set_Name_Table_Byte
1086            (Name_External_As_List, Token_Type'Pos (Tok_External_As_List));
1087       end if;
1088
1089       if Tree /= No_Project_Tree then
1090          Reset (Tree);
1091       end if;
1092    end Initialize;
1093
1094    ------------------
1095    -- Is_Extending --
1096    ------------------
1097
1098    function Is_Extending
1099      (Extending : Project_Id;
1100       Extended  : Project_Id) return Boolean
1101    is
1102       Proj : Project_Id;
1103
1104    begin
1105       Proj := Extending;
1106       while Proj /= No_Project loop
1107          if Proj = Extended then
1108             return True;
1109          end if;
1110
1111          Proj := Proj.Extends;
1112       end loop;
1113
1114       return False;
1115    end Is_Extending;
1116
1117    -----------------
1118    -- Object_Name --
1119    -----------------
1120
1121    function Object_Name
1122      (Source_File_Name   : File_Name_Type;
1123       Object_File_Suffix : Name_Id := No_Name) return File_Name_Type
1124    is
1125    begin
1126       if Object_File_Suffix = No_Name then
1127          return Extend_Name
1128            (Source_File_Name, Object_Suffix);
1129       else
1130          return Extend_Name
1131            (Source_File_Name, Get_Name_String (Object_File_Suffix));
1132       end if;
1133    end Object_Name;
1134
1135    function Object_Name
1136      (Source_File_Name   : File_Name_Type;
1137       Source_Index       : Int;
1138       Index_Separator    : Character;
1139       Object_File_Suffix : Name_Id := No_Name) return File_Name_Type
1140    is
1141       Index_Img : constant String := Source_Index'Img;
1142       Last      : Natural;
1143
1144    begin
1145       Get_Name_String (Source_File_Name);
1146
1147       Last := Name_Len;
1148       while Last > 1 and then Name_Buffer (Last) /= '.' loop
1149          Last := Last - 1;
1150       end loop;
1151
1152       if Last > 1 then
1153          Name_Len := Last - 1;
1154       end if;
1155
1156       Add_Char_To_Name_Buffer (Index_Separator);
1157       Add_Str_To_Name_Buffer (Index_Img (2 .. Index_Img'Last));
1158
1159       if Object_File_Suffix = No_Name then
1160          Add_Str_To_Name_Buffer (Object_Suffix);
1161       else
1162          Add_Str_To_Name_Buffer (Get_Name_String (Object_File_Suffix));
1163       end if;
1164
1165       return Name_Find;
1166    end Object_Name;
1167
1168    ----------------------
1169    -- Record_Temp_File --
1170    ----------------------
1171
1172    procedure Record_Temp_File
1173      (Shared : Shared_Project_Tree_Data_Access;
1174       Path   : Path_Name_Type)
1175    is
1176    begin
1177       Temp_Files_Table.Append (Shared.Private_Part.Temp_Files, Path);
1178    end Record_Temp_File;
1179
1180    ----------
1181    -- Free --
1182    ----------
1183
1184    procedure Free (List : in out Aggregated_Project_List) is
1185       procedure Unchecked_Free is new Ada.Unchecked_Deallocation
1186         (Aggregated_Project, Aggregated_Project_List);
1187       Tmp : Aggregated_Project_List;
1188    begin
1189       while List /= null loop
1190          Tmp := List.Next;
1191
1192          Free (List.Tree);
1193
1194          Unchecked_Free (List);
1195          List := Tmp;
1196       end loop;
1197    end Free;
1198
1199    ----------------------------
1200    -- Add_Aggregated_Project --
1201    ----------------------------
1202
1203    procedure Add_Aggregated_Project
1204      (Project : Project_Id;
1205       Path    : Path_Name_Type)
1206    is
1207       Aggregated : Aggregated_Project_List;
1208
1209    begin
1210       --  Check if the project is already in the aggregated project list. If it
1211       --  is, do not add it again.
1212
1213       Aggregated := Project.Aggregated_Projects;
1214       while Aggregated /= null loop
1215          if Path = Aggregated.Path then
1216             return;
1217          else
1218             Aggregated := Aggregated.Next;
1219          end if;
1220       end loop;
1221
1222       Project.Aggregated_Projects := new Aggregated_Project'
1223         (Path    => Path,
1224          Project => No_Project,
1225          Tree    => null,
1226          Next    => Project.Aggregated_Projects);
1227    end Add_Aggregated_Project;
1228
1229    ----------
1230    -- Free --
1231    ----------
1232
1233    procedure Free (Project : in out Project_Id) is
1234       procedure Unchecked_Free is new Ada.Unchecked_Deallocation
1235         (Project_Data, Project_Id);
1236
1237    begin
1238       if Project /= null then
1239          Free (Project.Ada_Include_Path);
1240          Free (Project.Objects_Path);
1241          Free (Project.Ada_Objects_Path);
1242          Free (Project.Ada_Objects_Path_No_Libs);
1243          Free_List (Project.Imported_Projects, Free_Project => False);
1244          Free_List (Project.All_Imported_Projects, Free_Project => False);
1245          Free_List (Project.Languages);
1246
1247          case Project.Qualifier is
1248             when Aggregate | Aggregate_Library =>
1249                Free (Project.Aggregated_Projects);
1250
1251             when others =>
1252                null;
1253          end case;
1254
1255          Unchecked_Free (Project);
1256       end if;
1257    end Free;
1258
1259    ---------------
1260    -- Free_List --
1261    ---------------
1262
1263    procedure Free_List (Languages : in out Language_List) is
1264       procedure Unchecked_Free is new Ada.Unchecked_Deallocation
1265         (Language_List_Element, Language_List);
1266       Tmp : Language_List;
1267    begin
1268       while Languages /= null loop
1269          Tmp := Languages.Next;
1270          Unchecked_Free (Languages);
1271          Languages := Tmp;
1272       end loop;
1273    end Free_List;
1274
1275    ---------------
1276    -- Free_List --
1277    ---------------
1278
1279    procedure Free_List (Source : in out Source_Id) is
1280       procedure Unchecked_Free is new
1281         Ada.Unchecked_Deallocation (Source_Data, Source_Id);
1282
1283       Tmp : Source_Id;
1284
1285    begin
1286       while Source /= No_Source loop
1287          Tmp := Source.Next_In_Lang;
1288          Free_List (Source.Alternate_Languages);
1289
1290          if Source.Unit /= null
1291            and then Source.Kind in Spec_Or_Body
1292          then
1293             Source.Unit.File_Names (Source.Kind) := null;
1294          end if;
1295
1296          Unchecked_Free (Source);
1297          Source := Tmp;
1298       end loop;
1299    end Free_List;
1300
1301    ---------------
1302    -- Free_List --
1303    ---------------
1304
1305    procedure Free_List
1306      (List         : in out Project_List;
1307       Free_Project : Boolean)
1308    is
1309       procedure Unchecked_Free is new
1310         Ada.Unchecked_Deallocation (Project_List_Element, Project_List);
1311
1312       Tmp : Project_List;
1313
1314    begin
1315       while List /= null loop
1316          Tmp := List.Next;
1317
1318          if Free_Project then
1319             Free (List.Project);
1320          end if;
1321
1322          Unchecked_Free (List);
1323          List := Tmp;
1324       end loop;
1325    end Free_List;
1326
1327    ---------------
1328    -- Free_List --
1329    ---------------
1330
1331    procedure Free_List (Languages : in out Language_Ptr) is
1332       procedure Unchecked_Free is new
1333         Ada.Unchecked_Deallocation (Language_Data, Language_Ptr);
1334
1335       Tmp : Language_Ptr;
1336
1337    begin
1338       while Languages /= null loop
1339          Tmp := Languages.Next;
1340          Free_List (Languages.First_Source);
1341          Unchecked_Free (Languages);
1342          Languages := Tmp;
1343       end loop;
1344    end Free_List;
1345
1346    --------------------------
1347    -- Reset_Units_In_Table --
1348    --------------------------
1349
1350    procedure Reset_Units_In_Table (Table : in out Units_Htable.Instance) is
1351       Unit : Unit_Index;
1352
1353    begin
1354       Unit := Units_Htable.Get_First (Table);
1355       while Unit /= No_Unit_Index loop
1356          if Unit.File_Names (Spec) /= null then
1357             Unit.File_Names (Spec).Unit := No_Unit_Index;
1358          end if;
1359
1360          if Unit.File_Names (Impl) /= null then
1361             Unit.File_Names (Impl).Unit := No_Unit_Index;
1362          end if;
1363
1364          Unit := Units_Htable.Get_Next (Table);
1365       end loop;
1366    end Reset_Units_In_Table;
1367
1368    ----------------
1369    -- Free_Units --
1370    ----------------
1371
1372    procedure Free_Units (Table : in out Units_Htable.Instance) is
1373       procedure Unchecked_Free is new
1374         Ada.Unchecked_Deallocation (Unit_Data, Unit_Index);
1375
1376       Unit : Unit_Index;
1377
1378    begin
1379       Unit := Units_Htable.Get_First (Table);
1380       while Unit /= No_Unit_Index loop
1381
1382          --  We cannot reset Unit.File_Names (Impl or Spec).Unit here as
1383          --  Source_Data buffer is freed by the following instruction
1384          --  Free_List (Tree.Projects, Free_Project => True);
1385
1386          Unchecked_Free (Unit);
1387          Unit := Units_Htable.Get_Next (Table);
1388       end loop;
1389
1390       Units_Htable.Reset (Table);
1391    end Free_Units;
1392
1393    ----------
1394    -- Free --
1395    ----------
1396
1397    procedure Free (Tree : in out Project_Tree_Ref) is
1398       procedure Unchecked_Free is new
1399         Ada.Unchecked_Deallocation
1400           (Project_Tree_Data, Project_Tree_Ref);
1401
1402       procedure Unchecked_Free is new
1403         Ada.Unchecked_Deallocation
1404           (Project_Tree_Appdata'Class, Project_Tree_Appdata_Access);
1405
1406    begin
1407       if Tree /= null then
1408          if Tree.Is_Root_Tree then
1409             Name_List_Table.Free        (Tree.Shared.Name_Lists);
1410             Number_List_Table.Free      (Tree.Shared.Number_Lists);
1411             String_Element_Table.Free   (Tree.Shared.String_Elements);
1412             Variable_Element_Table.Free (Tree.Shared.Variable_Elements);
1413             Array_Element_Table.Free    (Tree.Shared.Array_Elements);
1414             Array_Table.Free            (Tree.Shared.Arrays);
1415             Package_Table.Free          (Tree.Shared.Packages);
1416             Temp_Files_Table.Free       (Tree.Shared.Private_Part.Temp_Files);
1417          end if;
1418
1419          if Tree.Appdata /= null then
1420             Free (Tree.Appdata.all);
1421             Unchecked_Free (Tree.Appdata);
1422          end if;
1423
1424          Source_Paths_Htable.Reset (Tree.Source_Paths_HT);
1425          Source_Files_Htable.Reset (Tree.Source_Files_HT);
1426
1427          Reset_Units_In_Table (Tree.Units_HT);
1428          Free_List (Tree.Projects, Free_Project => True);
1429          Free_Units (Tree.Units_HT);
1430
1431          Unchecked_Free (Tree);
1432       end if;
1433    end Free;
1434
1435    -----------
1436    -- Reset --
1437    -----------
1438
1439    procedure Reset (Tree : Project_Tree_Ref) is
1440    begin
1441       --  Visible tables
1442
1443       if Tree.Is_Root_Tree then
1444
1445          --  We cannot use 'Access here:
1446          --    "illegal attribute for discriminant-dependent component"
1447          --  However, we know this is valid since Shared and Shared_Data have
1448          --  the same lifetime and will always exist concurrently.
1449
1450          Tree.Shared := Tree.Shared_Data'Unrestricted_Access;
1451          Name_List_Table.Init        (Tree.Shared.Name_Lists);
1452          Number_List_Table.Init      (Tree.Shared.Number_Lists);
1453          String_Element_Table.Init   (Tree.Shared.String_Elements);
1454          Variable_Element_Table.Init (Tree.Shared.Variable_Elements);
1455          Array_Element_Table.Init    (Tree.Shared.Array_Elements);
1456          Array_Table.Init            (Tree.Shared.Arrays);
1457          Package_Table.Init          (Tree.Shared.Packages);
1458
1459          --  Create Dot_String_List
1460
1461          String_Element_Table.Append
1462            (Tree.Shared.String_Elements,
1463             String_Element'
1464               (Value         => The_Dot_String,
1465                Index         => 0,
1466                Display_Value => The_Dot_String,
1467                Location      => No_Location,
1468                Flag          => False,
1469                Next          => Nil_String));
1470          Tree.Shared.Dot_String_List :=
1471            String_Element_Table.Last (Tree.Shared.String_Elements);
1472
1473          --  Private part table
1474
1475          Temp_Files_Table.Init (Tree.Shared.Private_Part.Temp_Files);
1476
1477          Tree.Shared.Private_Part.Current_Source_Path_File := No_Path;
1478          Tree.Shared.Private_Part.Current_Object_Path_File := No_Path;
1479       end if;
1480
1481       Source_Paths_Htable.Reset    (Tree.Source_Paths_HT);
1482       Source_Files_Htable.Reset    (Tree.Source_Files_HT);
1483       Replaced_Source_HTable.Reset (Tree.Replaced_Sources);
1484
1485       Tree.Replaced_Source_Number := 0;
1486
1487       Reset_Units_In_Table (Tree.Units_HT);
1488       Free_List (Tree.Projects, Free_Project => True);
1489       Free_Units (Tree.Units_HT);
1490    end Reset;
1491
1492    -------------------------------------
1493    -- Set_Current_Object_Path_File_Of --
1494    -------------------------------------
1495
1496    procedure Set_Current_Object_Path_File_Of
1497      (Shared : Shared_Project_Tree_Data_Access;
1498       To     : Path_Name_Type)
1499    is
1500    begin
1501       Shared.Private_Part.Current_Object_Path_File := To;
1502    end Set_Current_Object_Path_File_Of;
1503
1504    -------------------------------------
1505    -- Set_Current_Source_Path_File_Of --
1506    -------------------------------------
1507
1508    procedure Set_Current_Source_Path_File_Of
1509      (Shared : Shared_Project_Tree_Data_Access;
1510       To     : Path_Name_Type)
1511    is
1512    begin
1513       Shared.Private_Part.Current_Source_Path_File := To;
1514    end Set_Current_Source_Path_File_Of;
1515
1516    -----------------------
1517    -- Set_Path_File_Var --
1518    -----------------------
1519
1520    procedure Set_Path_File_Var (Name : String; Value : String) is
1521       Host_Spec : String_Access := To_Host_File_Spec (Value);
1522    begin
1523       if Host_Spec = null then
1524          Prj.Com.Fail
1525            ("could not convert file name """ & Value & """ to host spec");
1526       else
1527          Setenv (Name, Host_Spec.all);
1528          Free (Host_Spec);
1529       end if;
1530    end Set_Path_File_Var;
1531
1532    -------------------
1533    -- Switches_Name --
1534    -------------------
1535
1536    function Switches_Name
1537      (Source_File_Name : File_Name_Type) return File_Name_Type
1538    is
1539    begin
1540       return Extend_Name (Source_File_Name, Switches_Dependency_Suffix);
1541    end Switches_Name;
1542
1543    -----------
1544    -- Value --
1545    -----------
1546
1547    function Value (Image : String) return Casing_Type is
1548    begin
1549       for Casing in The_Casing_Images'Range loop
1550          if To_Lower (Image) = To_Lower (The_Casing_Images (Casing).all) then
1551             return Casing;
1552          end if;
1553       end loop;
1554
1555       raise Constraint_Error;
1556    end Value;
1557
1558    ---------------------
1559    -- Has_Ada_Sources --
1560    ---------------------
1561
1562    function Has_Ada_Sources (Data : Project_Id) return Boolean is
1563       Lang : Language_Ptr;
1564
1565    begin
1566       Lang := Data.Languages;
1567       while Lang /= No_Language_Index loop
1568          if Lang.Name = Name_Ada then
1569             return Lang.First_Source /= No_Source;
1570          end if;
1571          Lang := Lang.Next;
1572       end loop;
1573
1574       return False;
1575    end Has_Ada_Sources;
1576
1577    ------------------------
1578    -- Contains_ALI_Files --
1579    ------------------------
1580
1581    function Contains_ALI_Files (Dir : Path_Name_Type) return Boolean is
1582       Dir_Name : constant String := Get_Name_String (Dir);
1583       Direct   : Dir_Type;
1584       Name     : String (1 .. 1_000);
1585       Last     : Natural;
1586       Result   : Boolean := False;
1587
1588    begin
1589       Open (Direct, Dir_Name);
1590
1591       --  For each file in the directory, check if it is an ALI file
1592
1593       loop
1594          Read (Direct, Name, Last);
1595          exit when Last = 0;
1596          Canonical_Case_File_Name (Name (1 .. Last));
1597          Result := Last >= 5 and then Name (Last - 3 .. Last) = ".ali";
1598          exit when Result;
1599       end loop;
1600
1601       Close (Direct);
1602       return Result;
1603
1604    exception
1605       --  If there is any problem, close the directory if open and return True.
1606       --  The library directory will be added to the path.
1607
1608       when others =>
1609          if Is_Open (Direct) then
1610             Close (Direct);
1611          end if;
1612
1613          return True;
1614    end Contains_ALI_Files;
1615
1616    --------------------------
1617    -- Get_Object_Directory --
1618    --------------------------
1619
1620    function Get_Object_Directory
1621      (Project             : Project_Id;
1622       Including_Libraries : Boolean;
1623       Only_If_Ada         : Boolean := False) return Path_Name_Type
1624    is
1625    begin
1626       if (Project.Library and then Including_Libraries)
1627         or else
1628           (Project.Object_Directory /= No_Path_Information
1629             and then (not Including_Libraries or else not Project.Library))
1630       then
1631          --  For a library project, add the library ALI directory if there is
1632          --  no object directory or if the library ALI directory contains ALI
1633          --  files; otherwise add the object directory.
1634
1635          if Project.Library then
1636             if Project.Object_Directory = No_Path_Information
1637               or else
1638                 (Including_Libraries
1639                   and then
1640                     Contains_ALI_Files (Project.Library_ALI_Dir.Display_Name))
1641             then
1642                return Project.Library_ALI_Dir.Display_Name;
1643             else
1644                return Project.Object_Directory.Display_Name;
1645             end if;
1646
1647             --  For a non-library project, add object directory if it is not a
1648             --  virtual project, and if there are Ada sources in the project or
1649             --  one of the projects it extends. If there are no Ada sources,
1650             --  adding the object directory could disrupt the order of the
1651             --  object dirs in the path.
1652
1653          elsif not Project.Virtual then
1654             declare
1655                Add_Object_Dir : Boolean;
1656                Prj            : Project_Id;
1657
1658             begin
1659                Add_Object_Dir := not Only_If_Ada;
1660                Prj := Project;
1661                while not Add_Object_Dir and then Prj /= No_Project loop
1662                   if Has_Ada_Sources (Prj) then
1663                      Add_Object_Dir := True;
1664                   else
1665                      Prj := Prj.Extends;
1666                   end if;
1667                end loop;
1668
1669                if Add_Object_Dir then
1670                   return Project.Object_Directory.Display_Name;
1671                end if;
1672             end;
1673          end if;
1674       end if;
1675
1676       return No_Path;
1677    end Get_Object_Directory;
1678
1679    -----------------------------------
1680    -- Ultimate_Extending_Project_Of --
1681    -----------------------------------
1682
1683    function Ultimate_Extending_Project_Of
1684      (Proj : Project_Id) return Project_Id
1685    is
1686       Prj : Project_Id;
1687
1688    begin
1689       Prj := Proj;
1690       while Prj /= null and then Prj.Extended_By /= No_Project loop
1691          Prj := Prj.Extended_By;
1692       end loop;
1693
1694       return Prj;
1695    end Ultimate_Extending_Project_Of;
1696
1697    -----------------------------------
1698    -- Compute_All_Imported_Projects --
1699    -----------------------------------
1700
1701    procedure Compute_All_Imported_Projects
1702      (Root_Project : Project_Id;
1703       Tree         : Project_Tree_Ref)
1704    is
1705       procedure Analyze_Tree
1706         (Local_Root : Project_Id;
1707          Local_Tree : Project_Tree_Ref;
1708          Context    : Project_Context);
1709       --  Process Project and all its aggregated project to analyze their own
1710       --  imported projects.
1711
1712       ------------------
1713       -- Analyze_Tree --
1714       ------------------
1715
1716       procedure Analyze_Tree
1717         (Local_Root : Project_Id;
1718          Local_Tree : Project_Tree_Ref;
1719          Context    : Project_Context)
1720       is
1721          pragma Unreferenced (Local_Root);
1722
1723          Project : Project_Id;
1724
1725          procedure Recursive_Add
1726            (Prj     : Project_Id;
1727             Tree    : Project_Tree_Ref;
1728             Context : Project_Context;
1729             Dummy   : in out Boolean);
1730          --  Recursively add the projects imported by project Project, but not
1731          --  those that are extended.
1732
1733          -------------------
1734          -- Recursive_Add --
1735          -------------------
1736
1737          procedure Recursive_Add
1738            (Prj     : Project_Id;
1739             Tree    : Project_Tree_Ref;
1740             Context : Project_Context;
1741             Dummy   : in out Boolean)
1742          is
1743             pragma Unreferenced (Tree);
1744
1745             List : Project_List;
1746             Prj2 : Project_Id;
1747
1748          begin
1749             --  A project is not importing itself
1750
1751             Prj2 := Ultimate_Extending_Project_Of (Prj);
1752
1753             if Project /= Prj2 then
1754
1755                --  Check that the project is not already in the list. We know
1756                --  the one passed to Recursive_Add have never been visited
1757                --  before, but the one passed it are the extended projects.
1758
1759                List := Project.All_Imported_Projects;
1760                while List /= null loop
1761                   if List.Project = Prj2 then
1762                      return;
1763                   end if;
1764
1765                   List := List.Next;
1766                end loop;
1767
1768                --  Add it to the list
1769
1770                Project.All_Imported_Projects :=
1771                  new Project_List_Element'
1772                    (Project               => Prj2,
1773                     From_Encapsulated_Lib =>
1774                       Context.From_Encapsulated_Lib
1775                         or else Analyze_Tree.Context.From_Encapsulated_Lib,
1776                     Next                  => Project.All_Imported_Projects);
1777             end if;
1778          end Recursive_Add;
1779
1780          procedure For_All_Projects is
1781            new For_Every_Project_Imported_Context (Boolean, Recursive_Add);
1782
1783          Dummy : Boolean := False;
1784          List  : Project_List;
1785
1786       begin
1787          List := Local_Tree.Projects;
1788          while List /= null loop
1789             Project := List.Project;
1790             Free_List
1791               (Project.All_Imported_Projects, Free_Project => False);
1792             For_All_Projects
1793               (Project, Local_Tree, Dummy, Include_Aggregated => False);
1794             List := List.Next;
1795          end loop;
1796       end Analyze_Tree;
1797
1798       procedure For_Aggregates is
1799         new For_Project_And_Aggregated_Context (Analyze_Tree);
1800
1801    --  Start of processing for Compute_All_Imported_Projects
1802
1803    begin
1804       For_Aggregates (Root_Project, Tree);
1805    end Compute_All_Imported_Projects;
1806
1807    -------------------
1808    -- Is_Compilable --
1809    -------------------
1810
1811    function Is_Compilable (Source : Source_Id) return Boolean is
1812    begin
1813       case Source.Compilable is
1814          when Unknown =>
1815             if Source.Language.Config.Compiler_Driver /= No_File
1816               and then
1817                 Length_Of_Name (Source.Language.Config.Compiler_Driver) /= 0
1818               and then not Source.Locally_Removed
1819               and then (Source.Language.Config.Kind /= File_Based
1820                          or else Source.Kind /= Spec)
1821             then
1822                --  Do not modify Source.Compilable before the source record
1823                --  has been initialized.
1824
1825                if Source.Source_TS /= Empty_Time_Stamp then
1826                   Source.Compilable := Yes;
1827                end if;
1828
1829                return True;
1830
1831             else
1832                if Source.Source_TS /= Empty_Time_Stamp then
1833                   Source.Compilable := No;
1834                end if;
1835
1836                return False;
1837             end if;
1838
1839          when Yes =>
1840             return True;
1841
1842          when No =>
1843             return False;
1844       end case;
1845    end Is_Compilable;
1846
1847    ------------------------------
1848    -- Object_To_Global_Archive --
1849    ------------------------------
1850
1851    function Object_To_Global_Archive (Source : Source_Id) return Boolean is
1852    begin
1853       return Source.Language.Config.Kind = File_Based
1854         and then Source.Kind = Impl
1855         and then Source.Language.Config.Objects_Linked
1856         and then Is_Compilable (Source)
1857         and then Source.Language.Config.Object_Generated;
1858    end Object_To_Global_Archive;
1859
1860    ----------------------------
1861    -- Get_Language_From_Name --
1862    ----------------------------
1863
1864    function Get_Language_From_Name
1865      (Project : Project_Id;
1866       Name    : String) return Language_Ptr
1867    is
1868       N      : Name_Id;
1869       Result : Language_Ptr;
1870
1871    begin
1872       Name_Len := Name'Length;
1873       Name_Buffer (1 .. Name_Len) := Name;
1874       To_Lower (Name_Buffer (1 .. Name_Len));
1875       N := Name_Find;
1876
1877       Result := Project.Languages;
1878       while Result /= No_Language_Index loop
1879          if Result.Name = N then
1880             return Result;
1881          end if;
1882
1883          Result := Result.Next;
1884       end loop;
1885
1886       return No_Language_Index;
1887    end Get_Language_From_Name;
1888
1889    ----------------
1890    -- Other_Part --
1891    ----------------
1892
1893    function Other_Part (Source : Source_Id) return Source_Id is
1894    begin
1895       if Source.Unit /= No_Unit_Index then
1896          case Source.Kind is
1897             when Impl =>
1898                return Source.Unit.File_Names (Spec);
1899             when Spec =>
1900                return Source.Unit.File_Names (Impl);
1901             when Sep =>
1902                return No_Source;
1903          end case;
1904       else
1905          return No_Source;
1906       end if;
1907    end Other_Part;
1908
1909    ------------------
1910    -- Create_Flags --
1911    ------------------
1912
1913    function Create_Flags
1914      (Report_Error               : Error_Handler;
1915       When_No_Sources            : Error_Warning;
1916       Require_Sources_Other_Lang : Boolean       := True;
1917       Allow_Duplicate_Basenames  : Boolean       := True;
1918       Compiler_Driver_Mandatory  : Boolean       := False;
1919       Error_On_Unknown_Language  : Boolean       := True;
1920       Require_Obj_Dirs           : Error_Warning := Error;
1921       Allow_Invalid_External     : Error_Warning := Error;
1922       Missing_Source_Files       : Error_Warning := Error;
1923       Ignore_Missing_With        : Boolean       := False)
1924       return Processing_Flags
1925    is
1926    begin
1927       return Processing_Flags'
1928         (Report_Error               => Report_Error,
1929          When_No_Sources            => When_No_Sources,
1930          Require_Sources_Other_Lang => Require_Sources_Other_Lang,
1931          Allow_Duplicate_Basenames  => Allow_Duplicate_Basenames,
1932          Error_On_Unknown_Language  => Error_On_Unknown_Language,
1933          Compiler_Driver_Mandatory  => Compiler_Driver_Mandatory,
1934          Require_Obj_Dirs           => Require_Obj_Dirs,
1935          Allow_Invalid_External     => Allow_Invalid_External,
1936          Missing_Source_Files       => Missing_Source_Files,
1937          Ignore_Missing_With        => Ignore_Missing_With);
1938    end Create_Flags;
1939
1940    ------------
1941    -- Length --
1942    ------------
1943
1944    function Length
1945      (Table : Name_List_Table.Instance;
1946       List  : Name_List_Index) return Natural
1947    is
1948       Count : Natural := 0;
1949       Tmp   : Name_List_Index;
1950
1951    begin
1952       Tmp := List;
1953       while Tmp /= No_Name_List loop
1954          Count := Count + 1;
1955          Tmp := Table.Table (Tmp).Next;
1956       end loop;
1957
1958       return Count;
1959    end Length;
1960
1961    ------------------
1962    -- Debug_Output --
1963    ------------------
1964
1965    procedure Debug_Output (Str : String) is
1966    begin
1967       if Current_Verbosity > Default then
1968          Set_Standard_Error;
1969          Write_Line ((1 .. Debug_Level * 2 => ' ') & Str);
1970          Set_Standard_Output;
1971       end if;
1972    end Debug_Output;
1973
1974    ------------------
1975    -- Debug_Indent --
1976    ------------------
1977
1978    procedure Debug_Indent is
1979    begin
1980       if Current_Verbosity = High then
1981          Set_Standard_Error;
1982          Write_Str ((1 .. Debug_Level * 2 => ' '));
1983          Set_Standard_Output;
1984       end if;
1985    end Debug_Indent;
1986
1987    ------------------
1988    -- Debug_Output --
1989    ------------------
1990
1991    procedure Debug_Output (Str : String; Str2 : Name_Id) is
1992    begin
1993       if Current_Verbosity > Default then
1994          Debug_Indent;
1995          Set_Standard_Error;
1996          Write_Str (Str);
1997
1998          if Str2 = No_Name then
1999             Write_Line (" <no_name>");
2000          else
2001             Write_Line (" """ & Get_Name_String (Str2) & '"');
2002          end if;
2003
2004          Set_Standard_Output;
2005       end if;
2006    end Debug_Output;
2007
2008    ---------------------------
2009    -- Debug_Increase_Indent --
2010    ---------------------------
2011
2012    procedure Debug_Increase_Indent
2013      (Str : String := ""; Str2 : Name_Id := No_Name)
2014    is
2015    begin
2016       if Str2 /= No_Name then
2017          Debug_Output (Str, Str2);
2018       else
2019          Debug_Output (Str);
2020       end if;
2021       Debug_Level := Debug_Level + 1;
2022    end Debug_Increase_Indent;
2023
2024    ---------------------------
2025    -- Debug_Decrease_Indent --
2026    ---------------------------
2027
2028    procedure Debug_Decrease_Indent (Str : String := "") is
2029    begin
2030       if Debug_Level > 0 then
2031          Debug_Level := Debug_Level - 1;
2032       end if;
2033
2034       if Str /= "" then
2035          Debug_Output (Str);
2036       end if;
2037    end Debug_Decrease_Indent;
2038
2039    ----------------
2040    -- Debug_Name --
2041    ----------------
2042
2043    function Debug_Name (Tree : Project_Tree_Ref) return Name_Id is
2044       P : Project_List;
2045
2046    begin
2047       Name_Len := 0;
2048       Add_Str_To_Name_Buffer ("Tree [");
2049
2050       P := Tree.Projects;
2051       while P /= null loop
2052          if P /= Tree.Projects then
2053             Add_Char_To_Name_Buffer (',');
2054          end if;
2055
2056          Add_Str_To_Name_Buffer (Get_Name_String (P.Project.Name));
2057
2058          P := P.Next;
2059       end loop;
2060
2061       Add_Char_To_Name_Buffer (']');
2062
2063       return Name_Find;
2064    end Debug_Name;
2065
2066    ----------
2067    -- Free --
2068    ----------
2069
2070    procedure Free (Tree : in out Project_Tree_Appdata) is
2071       pragma Unreferenced (Tree);
2072    begin
2073       null;
2074    end Free;
2075
2076    --------------------------------
2077    -- For_Project_And_Aggregated --
2078    --------------------------------
2079
2080    procedure For_Project_And_Aggregated
2081      (Root_Project : Project_Id;
2082       Root_Tree    : Project_Tree_Ref)
2083    is
2084       Agg : Aggregated_Project_List;
2085
2086    begin
2087       Action (Root_Project, Root_Tree);
2088
2089       if Root_Project.Qualifier in Aggregate_Project then
2090          Agg := Root_Project.Aggregated_Projects;
2091          while Agg /= null loop
2092             For_Project_And_Aggregated (Agg.Project, Agg.Tree);
2093             Agg := Agg.Next;
2094          end loop;
2095       end if;
2096    end For_Project_And_Aggregated;
2097
2098    ----------------------------------------
2099    -- For_Project_And_Aggregated_Context --
2100    ----------------------------------------
2101
2102    procedure For_Project_And_Aggregated_Context
2103      (Root_Project : Project_Id;
2104       Root_Tree    : Project_Tree_Ref)
2105    is
2106
2107       procedure Recursive_Process
2108         (Project : Project_Id;
2109          Tree    : Project_Tree_Ref;
2110          Context : Project_Context);
2111       --  Process Project and all aggregated projects recursively
2112
2113       -----------------------
2114       -- Recursive_Process --
2115       -----------------------
2116
2117       procedure Recursive_Process
2118         (Project : Project_Id;
2119          Tree    : Project_Tree_Ref;
2120          Context : Project_Context)
2121       is
2122          Agg : Aggregated_Project_List;
2123          Ctx : Project_Context;
2124
2125       begin
2126          Action (Project, Tree, Context);
2127
2128          if Project.Qualifier in Aggregate_Project then
2129             Ctx :=
2130               (In_Aggregate_Lib      => Project.Qualifier = Aggregate_Library,
2131                From_Encapsulated_Lib =>
2132                  Context.From_Encapsulated_Lib
2133                    or else Project.Standalone_Library = Encapsulated);
2134
2135             Agg := Project.Aggregated_Projects;
2136             while Agg /= null loop
2137                Recursive_Process (Agg.Project, Agg.Tree, Ctx);
2138                Agg := Agg.Next;
2139             end loop;
2140          end if;
2141       end Recursive_Process;
2142
2143    --  Start of processing for For_Project_And_Aggregated_Context
2144
2145    begin
2146       Recursive_Process
2147         (Root_Project, Root_Tree, Project_Context'(False, False));
2148    end For_Project_And_Aggregated_Context;
2149
2150    --------------------------------
2151    -- Update_Ignore_Missing_With --
2152    --------------------------------
2153
2154    procedure Update_Ignore_Missing_With
2155      (Flags : in out Processing_Flags; Value : Boolean)
2156    is
2157    begin
2158       Flags.Ignore_Missing_With := Value;
2159    end Update_Ignore_Missing_With;
2160
2161 --  Package initialization for Prj
2162
2163 begin
2164    --  Make sure that the standard config and user project file extensions are
2165    --  compatible with canonical case file naming.
2166
2167    Canonical_Case_File_Name (Config_Project_File_Extension);
2168    Canonical_Case_File_Name (Project_File_Extension);
2169 end Prj;