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