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