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