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