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