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-2014, 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    -- Find_All_Sources --
 894    ----------------------
 895
 896    function Find_All_Sources
 897      (In_Tree          : Project_Tree_Ref;
 898       Project          : Project_Id;
 899       In_Imported_Only : Boolean := False;
 900       In_Extended_Only : Boolean := False;
 901       Base_Name        : File_Name_Type;
 902       Index            : Int := 0) return Source_Ids
 903    is
 904       Result : Source_Ids (1 .. 1_000);
 905       Last   : Natural := 0;
 906
 907       type Empty_State is null record;
 908       No_State : Empty_State;
 909       --  This is needed for the State parameter of procedure Look_For_Sources
 910       --  below, because of the instantiation For_Imported_Projects of generic
 911       --  procedure For_Every_Project_Imported. As procedure Look_For_Sources
 912       --  does not modify parameter State, there is no need to give its type
 913       --  more than one value.
 914
 915       procedure Look_For_Sources
 916         (Proj  : Project_Id;
 917          Tree  : Project_Tree_Ref;
 918          State : in out Empty_State);
 919       --  Look for Base_Name in the sources of Proj
 920
 921       ----------------------
 922       -- Look_For_Sources --
 923       ----------------------
 924
 925       procedure Look_For_Sources
 926         (Proj  : Project_Id;
 927          Tree  : Project_Tree_Ref;
 928          State : in out Empty_State)
 929       is
 930          Iterator : Source_Iterator;
 931          Src : Source_Id;
 932
 933       begin
 934          State := No_State;
 935
 936          Iterator := For_Each_Source (In_Tree => Tree, Project => Proj);
 937          while Element (Iterator) /= No_Source loop
 938             if Element (Iterator).File = Base_Name
 939               and then (Index = 0
 940                         or else
 941                           (Element (Iterator).Unit /= No_Unit_Index
 942                            and then
 943                            Element (Iterator).Index = Index))
 944             then
 945                Src := Element (Iterator);
 946
 947                --  If the source has been excluded, continue looking. We will
 948                --  get the excluded source only if there is no other source
 949                --  with the same base name that is not locally removed.
 950
 951                if not Element (Iterator).Locally_Removed then
 952                   Last := Last + 1;
 953                   Result (Last) := Src;
 954                end if;
 955             end if;
 956
 957             Next (Iterator);
 958          end loop;
 959       end Look_For_Sources;
 960
 961       procedure For_Imported_Projects is new For_Every_Project_Imported
 962         (State => Empty_State, Action => Look_For_Sources);
 963
 964       Proj : Project_Id;
 965
 966    --  Start of processing for Find_All_Sources
 967
 968    begin
 969       if In_Extended_Only then
 970          Proj := Project;
 971          while Proj /= No_Project loop
 972             Look_For_Sources (Proj, In_Tree, No_State);
 973             exit when Last > 0;
 974             Proj := Proj.Extends;
 975          end loop;
 976
 977       elsif In_Imported_Only then
 978          Look_For_Sources (Project, In_Tree, No_State);
 979
 980          if Last = 0 then
 981             For_Imported_Projects
 982               (By                 => Project,
 983                Tree               => In_Tree,
 984                Include_Aggregated => False,
 985                With_State         => No_State);
 986          end if;
 987
 988       else
 989          Look_For_Sources (No_Project, In_Tree, No_State);
 990       end if;
 991
 992       return Result (1 .. Last);
 993    end Find_All_Sources;
 994
 995    ----------
 996    -- Hash --
 997    ----------
 998
 999    function Hash is new GNAT.HTable.Hash (Header_Num => Header_Num);
1000    --  Used in implementation of other functions Hash below
1001
1002    ----------
1003    -- Hash --
1004    ----------
1005
1006    function Hash (Name : File_Name_Type) return Header_Num is
1007    begin
1008       return Hash (Get_Name_String (Name));
1009    end Hash;
1010
1011    function Hash (Name : Name_Id) return Header_Num is
1012    begin
1013       return Hash (Get_Name_String (Name));
1014    end Hash;
1015
1016    function Hash (Name : Path_Name_Type) return Header_Num is
1017    begin
1018       return Hash (Get_Name_String (Name));
1019    end Hash;
1020
1021    function Hash (Project : Project_Id) return Header_Num is
1022    begin
1023       if Project = No_Project then
1024          return Header_Num'First;
1025       else
1026          return Hash (Get_Name_String (Project.Name));
1027       end if;
1028    end Hash;
1029
1030    -----------
1031    -- Image --
1032    -----------
1033
1034    function Image (The_Casing : Casing_Type) return String is
1035    begin
1036       return The_Casing_Images (The_Casing).all;
1037    end Image;
1038
1039    -----------------------------
1040    -- Is_Standard_GNAT_Naming --
1041    -----------------------------
1042
1043    function Is_Standard_GNAT_Naming
1044      (Naming : Lang_Naming_Data) return Boolean
1045    is
1046    begin
1047       return Get_Name_String (Naming.Spec_Suffix) = ".ads"
1048         and then Get_Name_String (Naming.Body_Suffix) = ".adb"
1049         and then Get_Name_String (Naming.Dot_Replacement) = "-";
1050    end Is_Standard_GNAT_Naming;
1051
1052    ----------------
1053    -- Initialize --
1054    ----------------
1055
1056    procedure Initialize (Tree : Project_Tree_Ref) is
1057    begin
1058       if The_Empty_String = No_Name then
1059          Uintp.Initialize;
1060          Name_Len := 0;
1061          The_Empty_String := Name_Find;
1062
1063          Prj.Attr.Initialize;
1064
1065          --  Make sure that new reserved words after Ada 95 may be used as
1066          --  identifiers.
1067
1068          Opt.Ada_Version := Opt.Ada_95;
1069          Opt.Ada_Version_Pragma := Empty;
1070
1071          Set_Name_Table_Byte (Name_Project,  Token_Type'Pos (Tok_Project));
1072          Set_Name_Table_Byte (Name_Extends,  Token_Type'Pos (Tok_Extends));
1073          Set_Name_Table_Byte (Name_External, Token_Type'Pos (Tok_External));
1074          Set_Name_Table_Byte
1075            (Name_External_As_List, Token_Type'Pos (Tok_External_As_List));
1076       end if;
1077
1078       if Tree /= No_Project_Tree then
1079          Reset (Tree);
1080       end if;
1081    end Initialize;
1082
1083    ------------------
1084    -- Is_Extending --
1085    ------------------
1086
1087    function Is_Extending
1088      (Extending : Project_Id;
1089       Extended  : Project_Id) return Boolean
1090    is
1091       Proj : Project_Id;
1092
1093    begin
1094       Proj := Extending;
1095       while Proj /= No_Project loop
1096          if Proj = Extended then
1097             return True;
1098          end if;
1099
1100          Proj := Proj.Extends;
1101       end loop;
1102
1103       return False;
1104    end Is_Extending;
1105
1106    -----------------
1107    -- Object_Name --
1108    -----------------
1109
1110    function Object_Name
1111      (Source_File_Name   : File_Name_Type;
1112       Object_File_Suffix : Name_Id := No_Name) return File_Name_Type
1113    is
1114    begin
1115       if Object_File_Suffix = No_Name then
1116          return Extend_Name
1117            (Source_File_Name, Object_Suffix);
1118       else
1119          return Extend_Name
1120            (Source_File_Name, Get_Name_String (Object_File_Suffix));
1121       end if;
1122    end Object_Name;
1123
1124    function Object_Name
1125      (Source_File_Name   : File_Name_Type;
1126       Source_Index       : Int;
1127       Index_Separator    : Character;
1128       Object_File_Suffix : Name_Id := No_Name) return File_Name_Type
1129    is
1130       Index_Img : constant String := Source_Index'Img;
1131       Last      : Natural;
1132
1133    begin
1134       Get_Name_String (Source_File_Name);
1135
1136       Last := Name_Len;
1137       while Last > 1 and then Name_Buffer (Last) /= '.' loop
1138          Last := Last - 1;
1139       end loop;
1140
1141       if Last > 1 then
1142          Name_Len := Last - 1;
1143       end if;
1144
1145       Add_Char_To_Name_Buffer (Index_Separator);
1146       Add_Str_To_Name_Buffer (Index_Img (2 .. Index_Img'Last));
1147
1148       if Object_File_Suffix = No_Name then
1149          Add_Str_To_Name_Buffer (Object_Suffix);
1150       else
1151          Add_Str_To_Name_Buffer (Get_Name_String (Object_File_Suffix));
1152       end if;
1153
1154       return Name_Find;
1155    end Object_Name;
1156
1157    ----------------------
1158    -- Record_Temp_File --
1159    ----------------------
1160
1161    procedure Record_Temp_File
1162      (Shared : Shared_Project_Tree_Data_Access;
1163       Path   : Path_Name_Type)
1164    is
1165    begin
1166       Temp_Files_Table.Append (Shared.Private_Part.Temp_Files, Path);
1167    end Record_Temp_File;
1168
1169    ----------
1170    -- Free --
1171    ----------
1172
1173    procedure Free (List : in out Aggregated_Project_List) is
1174       procedure Unchecked_Free is new Ada.Unchecked_Deallocation
1175         (Aggregated_Project, Aggregated_Project_List);
1176       Tmp : Aggregated_Project_List;
1177    begin
1178       while List /= null loop
1179          Tmp := List.Next;
1180
1181          Free (List.Tree);
1182
1183          Unchecked_Free (List);
1184          List := Tmp;
1185       end loop;
1186    end Free;
1187
1188    ----------------------------
1189    -- Add_Aggregated_Project --
1190    ----------------------------
1191
1192    procedure Add_Aggregated_Project
1193      (Project : Project_Id;
1194       Path    : Path_Name_Type)
1195    is
1196       Aggregated : Aggregated_Project_List;
1197
1198    begin
1199       --  Check if the project is already in the aggregated project list. If it
1200       --  is, do not add it again.
1201
1202       Aggregated := Project.Aggregated_Projects;
1203       while Aggregated /= null loop
1204          if Path = Aggregated.Path then
1205             return;
1206          else
1207             Aggregated := Aggregated.Next;
1208          end if;
1209       end loop;
1210
1211       Project.Aggregated_Projects := new Aggregated_Project'
1212         (Path    => Path,
1213          Project => No_Project,
1214          Tree    => null,
1215          Next    => Project.Aggregated_Projects);
1216    end Add_Aggregated_Project;
1217
1218    ----------
1219    -- Free --
1220    ----------
1221
1222    procedure Free (Project : in out Project_Id) is
1223       procedure Unchecked_Free is new Ada.Unchecked_Deallocation
1224         (Project_Data, Project_Id);
1225
1226    begin
1227       if Project /= null then
1228          Free (Project.Ada_Include_Path);
1229          Free (Project.Objects_Path);
1230          Free (Project.Ada_Objects_Path);
1231          Free (Project.Ada_Objects_Path_No_Libs);
1232          Free_List (Project.Imported_Projects, Free_Project => False);
1233          Free_List (Project.All_Imported_Projects, Free_Project => False);
1234          Free_List (Project.Languages);
1235
1236          case Project.Qualifier is
1237             when Aggregate | Aggregate_Library =>
1238                Free (Project.Aggregated_Projects);
1239
1240             when others =>
1241                null;
1242          end case;
1243
1244          Unchecked_Free (Project);
1245       end if;
1246    end Free;
1247
1248    ---------------
1249    -- Free_List --
1250    ---------------
1251
1252    procedure Free_List (Languages : in out Language_List) is
1253       procedure Unchecked_Free is new Ada.Unchecked_Deallocation
1254         (Language_List_Element, Language_List);
1255       Tmp : Language_List;
1256    begin
1257       while Languages /= null loop
1258          Tmp := Languages.Next;
1259          Unchecked_Free (Languages);
1260          Languages := Tmp;
1261       end loop;
1262    end Free_List;
1263
1264    ---------------
1265    -- Free_List --
1266    ---------------
1267
1268    procedure Free_List (Source : in out Source_Id) is
1269       procedure Unchecked_Free is new
1270         Ada.Unchecked_Deallocation (Source_Data, Source_Id);
1271
1272       Tmp : Source_Id;
1273
1274    begin
1275       while Source /= No_Source loop
1276          Tmp := Source.Next_In_Lang;
1277          Free_List (Source.Alternate_Languages);
1278
1279          if Source.Unit /= null
1280            and then Source.Kind in Spec_Or_Body
1281          then
1282             Source.Unit.File_Names (Source.Kind) := null;
1283          end if;
1284
1285          Unchecked_Free (Source);
1286          Source := Tmp;
1287       end loop;
1288    end Free_List;
1289
1290    ---------------
1291    -- Free_List --
1292    ---------------
1293
1294    procedure Free_List
1295      (List         : in out Project_List;
1296       Free_Project : Boolean)
1297    is
1298       procedure Unchecked_Free is new
1299         Ada.Unchecked_Deallocation (Project_List_Element, Project_List);
1300
1301       Tmp : Project_List;
1302
1303    begin
1304       while List /= null loop
1305          Tmp := List.Next;
1306
1307          if Free_Project then
1308             Free (List.Project);
1309          end if;
1310
1311          Unchecked_Free (List);
1312          List := Tmp;
1313       end loop;
1314    end Free_List;
1315
1316    ---------------
1317    -- Free_List --
1318    ---------------
1319
1320    procedure Free_List (Languages : in out Language_Ptr) is
1321       procedure Unchecked_Free is new
1322         Ada.Unchecked_Deallocation (Language_Data, Language_Ptr);
1323
1324       Tmp : Language_Ptr;
1325
1326    begin
1327       while Languages /= null loop
1328          Tmp := Languages.Next;
1329          Free_List (Languages.First_Source);
1330          Unchecked_Free (Languages);
1331          Languages := Tmp;
1332       end loop;
1333    end Free_List;
1334
1335    --------------------------
1336    -- Reset_Units_In_Table --
1337    --------------------------
1338
1339    procedure Reset_Units_In_Table (Table : in out Units_Htable.Instance) is
1340       Unit : Unit_Index;
1341
1342    begin
1343       Unit := Units_Htable.Get_First (Table);
1344       while Unit /= No_Unit_Index loop
1345          if Unit.File_Names (Spec) /= null then
1346             Unit.File_Names (Spec).Unit := No_Unit_Index;
1347          end if;
1348
1349          if Unit.File_Names (Impl) /= null then
1350             Unit.File_Names (Impl).Unit := No_Unit_Index;
1351          end if;
1352
1353          Unit := Units_Htable.Get_Next (Table);
1354       end loop;
1355    end Reset_Units_In_Table;
1356
1357    ----------------
1358    -- Free_Units --
1359    ----------------
1360
1361    procedure Free_Units (Table : in out Units_Htable.Instance) is
1362       procedure Unchecked_Free is new
1363         Ada.Unchecked_Deallocation (Unit_Data, Unit_Index);
1364
1365       Unit : Unit_Index;
1366
1367    begin
1368       Unit := Units_Htable.Get_First (Table);
1369       while Unit /= No_Unit_Index loop
1370
1371          --  We cannot reset Unit.File_Names (Impl or Spec).Unit here as
1372          --  Source_Data buffer is freed by the following instruction
1373          --  Free_List (Tree.Projects, Free_Project => True);
1374
1375          Unchecked_Free (Unit);
1376          Unit := Units_Htable.Get_Next (Table);
1377       end loop;
1378
1379       Units_Htable.Reset (Table);
1380    end Free_Units;
1381
1382    ----------
1383    -- Free --
1384    ----------
1385
1386    procedure Free (Tree : in out Project_Tree_Ref) is
1387       procedure Unchecked_Free is new
1388         Ada.Unchecked_Deallocation
1389           (Project_Tree_Data, Project_Tree_Ref);
1390
1391       procedure Unchecked_Free is new
1392         Ada.Unchecked_Deallocation
1393           (Project_Tree_Appdata'Class, Project_Tree_Appdata_Access);
1394
1395    begin
1396       if Tree /= null then
1397          if Tree.Is_Root_Tree then
1398             Name_List_Table.Free        (Tree.Shared.Name_Lists);
1399             Number_List_Table.Free      (Tree.Shared.Number_Lists);
1400             String_Element_Table.Free   (Tree.Shared.String_Elements);
1401             Variable_Element_Table.Free (Tree.Shared.Variable_Elements);
1402             Array_Element_Table.Free    (Tree.Shared.Array_Elements);
1403             Array_Table.Free            (Tree.Shared.Arrays);
1404             Package_Table.Free          (Tree.Shared.Packages);
1405             Temp_Files_Table.Free       (Tree.Shared.Private_Part.Temp_Files);
1406          end if;
1407
1408          if Tree.Appdata /= null then
1409             Free (Tree.Appdata.all);
1410             Unchecked_Free (Tree.Appdata);
1411          end if;
1412
1413          Source_Paths_Htable.Reset (Tree.Source_Paths_HT);
1414          Source_Files_Htable.Reset (Tree.Source_Files_HT);
1415
1416          Reset_Units_In_Table (Tree.Units_HT);
1417          Free_List (Tree.Projects, Free_Project => True);
1418          Free_Units (Tree.Units_HT);
1419
1420          Unchecked_Free (Tree);
1421       end if;
1422    end Free;
1423
1424    -----------
1425    -- Reset --
1426    -----------
1427
1428    procedure Reset (Tree : Project_Tree_Ref) is
1429    begin
1430       --  Visible tables
1431
1432       if Tree.Is_Root_Tree then
1433
1434          --  We cannot use 'Access here:
1435          --    "illegal attribute for discriminant-dependent component"
1436          --  However, we know this is valid since Shared and Shared_Data have
1437          --  the same lifetime and will always exist concurrently.
1438
1439          Tree.Shared := Tree.Shared_Data'Unrestricted_Access;
1440          Name_List_Table.Init        (Tree.Shared.Name_Lists);
1441          Number_List_Table.Init      (Tree.Shared.Number_Lists);
1442          String_Element_Table.Init   (Tree.Shared.String_Elements);
1443          Variable_Element_Table.Init (Tree.Shared.Variable_Elements);
1444          Array_Element_Table.Init    (Tree.Shared.Array_Elements);
1445          Array_Table.Init            (Tree.Shared.Arrays);
1446          Package_Table.Init          (Tree.Shared.Packages);
1447
1448          --  Private part table
1449
1450          Temp_Files_Table.Init (Tree.Shared.Private_Part.Temp_Files);
1451
1452          Tree.Shared.Private_Part.Current_Source_Path_File := No_Path;
1453          Tree.Shared.Private_Part.Current_Object_Path_File := No_Path;
1454       end if;
1455
1456       Source_Paths_Htable.Reset    (Tree.Source_Paths_HT);
1457       Source_Files_Htable.Reset    (Tree.Source_Files_HT);
1458       Replaced_Source_HTable.Reset (Tree.Replaced_Sources);
1459
1460       Tree.Replaced_Source_Number := 0;
1461
1462       Reset_Units_In_Table (Tree.Units_HT);
1463       Free_List (Tree.Projects, Free_Project => True);
1464       Free_Units (Tree.Units_HT);
1465    end Reset;
1466
1467    -------------------------------------
1468    -- Set_Current_Object_Path_File_Of --
1469    -------------------------------------
1470
1471    procedure Set_Current_Object_Path_File_Of
1472      (Shared : Shared_Project_Tree_Data_Access;
1473       To     : Path_Name_Type)
1474    is
1475    begin
1476       Shared.Private_Part.Current_Object_Path_File := To;
1477    end Set_Current_Object_Path_File_Of;
1478
1479    -------------------------------------
1480    -- Set_Current_Source_Path_File_Of --
1481    -------------------------------------
1482
1483    procedure Set_Current_Source_Path_File_Of
1484      (Shared : Shared_Project_Tree_Data_Access;
1485       To     : Path_Name_Type)
1486    is
1487    begin
1488       Shared.Private_Part.Current_Source_Path_File := To;
1489    end Set_Current_Source_Path_File_Of;
1490
1491    -----------------------
1492    -- Set_Path_File_Var --
1493    -----------------------
1494
1495    procedure Set_Path_File_Var (Name : String; Value : String) is
1496       Host_Spec : String_Access := To_Host_File_Spec (Value);
1497    begin
1498       if Host_Spec = null then
1499          Prj.Com.Fail
1500            ("could not convert file name """ & Value & """ to host spec");
1501       else
1502          Setenv (Name, Host_Spec.all);
1503          Free (Host_Spec);
1504       end if;
1505    end Set_Path_File_Var;
1506
1507    -------------------
1508    -- Switches_Name --
1509    -------------------
1510
1511    function Switches_Name
1512      (Source_File_Name : File_Name_Type) return File_Name_Type
1513    is
1514    begin
1515       return Extend_Name (Source_File_Name, Switches_Dependency_Suffix);
1516    end Switches_Name;
1517
1518    -----------
1519    -- Value --
1520    -----------
1521
1522    function Value (Image : String) return Casing_Type is
1523    begin
1524       for Casing in The_Casing_Images'Range loop
1525          if To_Lower (Image) = To_Lower (The_Casing_Images (Casing).all) then
1526             return Casing;
1527          end if;
1528       end loop;
1529
1530       raise Constraint_Error;
1531    end Value;
1532
1533    ---------------------
1534    -- Has_Ada_Sources --
1535    ---------------------
1536
1537    function Has_Ada_Sources (Data : Project_Id) return Boolean is
1538       Lang : Language_Ptr;
1539
1540    begin
1541       Lang := Data.Languages;
1542       while Lang /= No_Language_Index loop
1543          if Lang.Name = Name_Ada then
1544             return Lang.First_Source /= No_Source;
1545          end if;
1546          Lang := Lang.Next;
1547       end loop;
1548
1549       return False;
1550    end Has_Ada_Sources;
1551
1552    ------------------------
1553    -- Contains_ALI_Files --
1554    ------------------------
1555
1556    function Contains_ALI_Files (Dir : Path_Name_Type) return Boolean is
1557       Dir_Name : constant String := Get_Name_String (Dir);
1558       Direct   : Dir_Type;
1559       Name     : String (1 .. 1_000);
1560       Last     : Natural;
1561       Result   : Boolean := False;
1562
1563    begin
1564       Open (Direct, Dir_Name);
1565
1566       --  For each file in the directory, check if it is an ALI file
1567
1568       loop
1569          Read (Direct, Name, Last);
1570          exit when Last = 0;
1571          Canonical_Case_File_Name (Name (1 .. Last));
1572          Result := Last >= 5 and then Name (Last - 3 .. Last) = ".ali";
1573          exit when Result;
1574       end loop;
1575
1576       Close (Direct);
1577       return Result;
1578
1579    exception
1580       --  If there is any problem, close the directory if open and return True.
1581       --  The library directory will be added to the path.
1582
1583       when others =>
1584          if Is_Open (Direct) then
1585             Close (Direct);
1586          end if;
1587
1588          return True;
1589    end Contains_ALI_Files;
1590
1591    --------------------------
1592    -- Get_Object_Directory --
1593    --------------------------
1594
1595    function Get_Object_Directory
1596      (Project             : Project_Id;
1597       Including_Libraries : Boolean;
1598       Only_If_Ada         : Boolean := False) return Path_Name_Type
1599    is
1600    begin
1601       if (Project.Library and then Including_Libraries)
1602         or else
1603           (Project.Object_Directory /= No_Path_Information
1604             and then (not Including_Libraries or else not Project.Library))
1605       then
1606          --  For a library project, add the library ALI directory if there is
1607          --  no object directory or if the library ALI directory contains ALI
1608          --  files; otherwise add the object directory.
1609
1610          if Project.Library then
1611             if Project.Object_Directory = No_Path_Information
1612               or else
1613                 (Including_Libraries
1614                   and then
1615                     Contains_ALI_Files (Project.Library_ALI_Dir.Display_Name))
1616             then
1617                return Project.Library_ALI_Dir.Display_Name;
1618             else
1619                return Project.Object_Directory.Display_Name;
1620             end if;
1621
1622             --  For a non-library project, add object directory if it is not a
1623             --  virtual project, and if there are Ada sources in the project or
1624             --  one of the projects it extends. If there are no Ada sources,
1625             --  adding the object directory could disrupt the order of the
1626             --  object dirs in the path.
1627
1628          elsif not Project.Virtual then
1629             declare
1630                Add_Object_Dir : Boolean;
1631                Prj            : Project_Id;
1632
1633             begin
1634                Add_Object_Dir := not Only_If_Ada;
1635                Prj := Project;
1636                while not Add_Object_Dir and then Prj /= No_Project loop
1637                   if Has_Ada_Sources (Prj) then
1638                      Add_Object_Dir := True;
1639                   else
1640                      Prj := Prj.Extends;
1641                   end if;
1642                end loop;
1643
1644                if Add_Object_Dir then
1645                   return Project.Object_Directory.Display_Name;
1646                end if;
1647             end;
1648          end if;
1649       end if;
1650
1651       return No_Path;
1652    end Get_Object_Directory;
1653
1654    -----------------------------------
1655    -- Ultimate_Extending_Project_Of --
1656    -----------------------------------
1657
1658    function Ultimate_Extending_Project_Of
1659      (Proj : Project_Id) return Project_Id
1660    is
1661       Prj : Project_Id;
1662
1663    begin
1664       Prj := Proj;
1665       while Prj /= null and then Prj.Extended_By /= No_Project loop
1666          Prj := Prj.Extended_By;
1667       end loop;
1668
1669       return Prj;
1670    end Ultimate_Extending_Project_Of;
1671
1672    -----------------------------------
1673    -- Compute_All_Imported_Projects --
1674    -----------------------------------
1675
1676    procedure Compute_All_Imported_Projects
1677      (Root_Project : Project_Id;
1678       Tree         : Project_Tree_Ref)
1679    is
1680       procedure Analyze_Tree
1681         (Local_Root : Project_Id;
1682          Local_Tree : Project_Tree_Ref;
1683          Context    : Project_Context);
1684       --  Process Project and all its aggregated project to analyze their own
1685       --  imported projects.
1686
1687       ------------------
1688       -- Analyze_Tree --
1689       ------------------
1690
1691       procedure Analyze_Tree
1692         (Local_Root : Project_Id;
1693          Local_Tree : Project_Tree_Ref;
1694          Context    : Project_Context)
1695       is
1696          pragma Unreferenced (Local_Root);
1697
1698          Project : Project_Id;
1699
1700          procedure Recursive_Add
1701            (Prj     : Project_Id;
1702             Tree    : Project_Tree_Ref;
1703             Context : Project_Context;
1704             Dummy   : in out Boolean);
1705          --  Recursively add the projects imported by project Project, but not
1706          --  those that are extended.
1707
1708          -------------------
1709          -- Recursive_Add --
1710          -------------------
1711
1712          procedure Recursive_Add
1713            (Prj     : Project_Id;
1714             Tree    : Project_Tree_Ref;
1715             Context : Project_Context;
1716             Dummy   : in out Boolean)
1717          is
1718             pragma Unreferenced (Dummy, Tree);
1719
1720             List : Project_List;
1721             Prj2 : Project_Id;
1722
1723          begin
1724             --  A project is not importing itself
1725
1726             Prj2 := Ultimate_Extending_Project_Of (Prj);
1727
1728             if Project /= Prj2 then
1729
1730                --  Check that the project is not already in the list. We know
1731                --  the one passed to Recursive_Add have never been visited
1732                --  before, but the one passed it are the extended projects.
1733
1734                List := Project.All_Imported_Projects;
1735                while List /= null loop
1736                   if List.Project = Prj2 then
1737                      return;
1738                   end if;
1739
1740                   List := List.Next;
1741                end loop;
1742
1743                --  Add it to the list
1744
1745                Project.All_Imported_Projects :=
1746                  new Project_List_Element'
1747                    (Project               => Prj2,
1748                     From_Encapsulated_Lib =>
1749                       Context.From_Encapsulated_Lib
1750                         or else Analyze_Tree.Context.From_Encapsulated_Lib,
1751                     Next                  => Project.All_Imported_Projects);
1752             end if;
1753          end Recursive_Add;
1754
1755          procedure For_All_Projects is
1756            new For_Every_Project_Imported_Context (Boolean, Recursive_Add);
1757
1758          Dummy : Boolean := False;
1759          List  : Project_List;
1760
1761       begin
1762          List := Local_Tree.Projects;
1763          while List /= null loop
1764             Project := List.Project;
1765             Free_List
1766               (Project.All_Imported_Projects, Free_Project => False);
1767             For_All_Projects
1768               (Project, Local_Tree, Dummy, Include_Aggregated => False);
1769             List := List.Next;
1770          end loop;
1771       end Analyze_Tree;
1772
1773       procedure For_Aggregates is
1774         new For_Project_And_Aggregated_Context (Analyze_Tree);
1775
1776    --  Start of processing for Compute_All_Imported_Projects
1777
1778    begin
1779       For_Aggregates (Root_Project, Tree);
1780    end Compute_All_Imported_Projects;
1781
1782    -------------------
1783    -- Is_Compilable --
1784    -------------------
1785
1786    function Is_Compilable (Source : Source_Id) return Boolean is
1787    begin
1788       case Source.Compilable is
1789          when Unknown =>
1790             if Source.Language.Config.Compiler_Driver /= No_File
1791               and then
1792                 Length_Of_Name (Source.Language.Config.Compiler_Driver) /= 0
1793               and then not Source.Locally_Removed
1794               and then (Source.Language.Config.Kind /= File_Based
1795                          or else Source.Kind /= Spec)
1796             then
1797                --  Do not modify Source.Compilable before the source record
1798                --  has been initialized.
1799
1800                if Source.Source_TS /= Empty_Time_Stamp then
1801                   Source.Compilable := Yes;
1802                end if;
1803
1804                return True;
1805
1806             else
1807                if Source.Source_TS /= Empty_Time_Stamp then
1808                   Source.Compilable := No;
1809                end if;
1810
1811                return False;
1812             end if;
1813
1814          when Yes =>
1815             return True;
1816
1817          when No =>
1818             return False;
1819       end case;
1820    end Is_Compilable;
1821
1822    ------------------------------
1823    -- Object_To_Global_Archive --
1824    ------------------------------
1825
1826    function Object_To_Global_Archive (Source : Source_Id) return Boolean is
1827    begin
1828       return Source.Language.Config.Kind = File_Based
1829         and then Source.Kind = Impl
1830         and then Source.Language.Config.Objects_Linked
1831         and then Is_Compilable (Source)
1832         and then Source.Language.Config.Object_Generated;
1833    end Object_To_Global_Archive;
1834
1835    ----------------------------
1836    -- Get_Language_From_Name --
1837    ----------------------------
1838
1839    function Get_Language_From_Name
1840      (Project : Project_Id;
1841       Name    : String) return Language_Ptr
1842    is
1843       N      : Name_Id;
1844       Result : Language_Ptr;
1845
1846    begin
1847       Name_Len := Name'Length;
1848       Name_Buffer (1 .. Name_Len) := Name;
1849       To_Lower (Name_Buffer (1 .. Name_Len));
1850       N := Name_Find;
1851
1852       Result := Project.Languages;
1853       while Result /= No_Language_Index loop
1854          if Result.Name = N then
1855             return Result;
1856          end if;
1857
1858          Result := Result.Next;
1859       end loop;
1860
1861       return No_Language_Index;
1862    end Get_Language_From_Name;
1863
1864    ----------------
1865    -- Other_Part --
1866    ----------------
1867
1868    function Other_Part (Source : Source_Id) return Source_Id is
1869    begin
1870       if Source.Unit /= No_Unit_Index then
1871          case Source.Kind is
1872             when Impl =>
1873                return Source.Unit.File_Names (Spec);
1874             when Spec =>
1875                return Source.Unit.File_Names (Impl);
1876             when Sep =>
1877                return No_Source;
1878          end case;
1879       else
1880          return No_Source;
1881       end if;
1882    end Other_Part;
1883
1884    ------------------
1885    -- Create_Flags --
1886    ------------------
1887
1888    function Create_Flags
1889      (Report_Error               : Error_Handler;
1890       When_No_Sources            : Error_Warning;
1891       Require_Sources_Other_Lang : Boolean       := True;
1892       Allow_Duplicate_Basenames  : Boolean       := True;
1893       Compiler_Driver_Mandatory  : Boolean       := False;
1894       Error_On_Unknown_Language  : Boolean       := True;
1895       Require_Obj_Dirs           : Error_Warning := Error;
1896       Allow_Invalid_External     : Error_Warning := Error;
1897       Missing_Source_Files       : Error_Warning := Error;
1898       Ignore_Missing_With        : Boolean       := False)
1899       return Processing_Flags
1900    is
1901    begin
1902       return Processing_Flags'
1903         (Report_Error               => Report_Error,
1904          When_No_Sources            => When_No_Sources,
1905          Require_Sources_Other_Lang => Require_Sources_Other_Lang,
1906          Allow_Duplicate_Basenames  => Allow_Duplicate_Basenames,
1907          Error_On_Unknown_Language  => Error_On_Unknown_Language,
1908          Compiler_Driver_Mandatory  => Compiler_Driver_Mandatory,
1909          Require_Obj_Dirs           => Require_Obj_Dirs,
1910          Allow_Invalid_External     => Allow_Invalid_External,
1911          Missing_Source_Files       => Missing_Source_Files,
1912          Ignore_Missing_With        => Ignore_Missing_With);
1913    end Create_Flags;
1914
1915    ------------
1916    -- Length --
1917    ------------
1918
1919    function Length
1920      (Table : Name_List_Table.Instance;
1921       List  : Name_List_Index) return Natural
1922    is
1923       Count : Natural := 0;
1924       Tmp   : Name_List_Index;
1925
1926    begin
1927       Tmp := List;
1928       while Tmp /= No_Name_List loop
1929          Count := Count + 1;
1930          Tmp := Table.Table (Tmp).Next;
1931       end loop;
1932
1933       return Count;
1934    end Length;
1935
1936    ------------------
1937    -- Debug_Output --
1938    ------------------
1939
1940    procedure Debug_Output (Str : String) is
1941    begin
1942       if Current_Verbosity > Default then
1943          Set_Standard_Error;
1944          Write_Line ((1 .. Debug_Level * 2 => ' ') & Str);
1945          Set_Standard_Output;
1946       end if;
1947    end Debug_Output;
1948
1949    ------------------
1950    -- Debug_Indent --
1951    ------------------
1952
1953    procedure Debug_Indent is
1954    begin
1955       if Current_Verbosity = High then
1956          Set_Standard_Error;
1957          Write_Str ((1 .. Debug_Level * 2 => ' '));
1958          Set_Standard_Output;
1959       end if;
1960    end Debug_Indent;
1961
1962    ------------------
1963    -- Debug_Output --
1964    ------------------
1965
1966    procedure Debug_Output (Str : String; Str2 : Name_Id) is
1967    begin
1968       if Current_Verbosity > Default then
1969          Debug_Indent;
1970          Set_Standard_Error;
1971          Write_Str (Str);
1972
1973          if Str2 = No_Name then
1974             Write_Line (" <no_name>");
1975          else
1976             Write_Line (" """ & Get_Name_String (Str2) & '"');
1977          end if;
1978
1979          Set_Standard_Output;
1980       end if;
1981    end Debug_Output;
1982
1983    ---------------------------
1984    -- Debug_Increase_Indent --
1985    ---------------------------
1986
1987    procedure Debug_Increase_Indent
1988      (Str : String := ""; Str2 : Name_Id := No_Name)
1989    is
1990    begin
1991       if Str2 /= No_Name then
1992          Debug_Output (Str, Str2);
1993       else
1994          Debug_Output (Str);
1995       end if;
1996       Debug_Level := Debug_Level + 1;
1997    end Debug_Increase_Indent;
1998
1999    ---------------------------
2000    -- Debug_Decrease_Indent --
2001    ---------------------------
2002
2003    procedure Debug_Decrease_Indent (Str : String := "") is
2004    begin
2005       if Debug_Level > 0 then
2006          Debug_Level := Debug_Level - 1;
2007       end if;
2008
2009       if Str /= "" then
2010          Debug_Output (Str);
2011       end if;
2012    end Debug_Decrease_Indent;
2013
2014    ----------------
2015    -- Debug_Name --
2016    ----------------
2017
2018    function Debug_Name (Tree : Project_Tree_Ref) return Name_Id is
2019       P : Project_List;
2020
2021    begin
2022       Name_Len := 0;
2023       Add_Str_To_Name_Buffer ("Tree [");
2024
2025       P := Tree.Projects;
2026       while P /= null loop
2027          if P /= Tree.Projects then
2028             Add_Char_To_Name_Buffer (',');
2029          end if;
2030
2031          Add_Str_To_Name_Buffer (Get_Name_String (P.Project.Name));
2032
2033          P := P.Next;
2034       end loop;
2035
2036       Add_Char_To_Name_Buffer (']');
2037
2038       return Name_Find;
2039    end Debug_Name;
2040
2041    ----------
2042    -- Free --
2043    ----------
2044
2045    procedure Free (Tree : in out Project_Tree_Appdata) is
2046       pragma Unreferenced (Tree);
2047    begin
2048       null;
2049    end Free;
2050
2051    --------------------------------
2052    -- For_Project_And_Aggregated --
2053    --------------------------------
2054
2055    procedure For_Project_And_Aggregated
2056      (Root_Project : Project_Id;
2057       Root_Tree    : Project_Tree_Ref)
2058    is
2059       Agg : Aggregated_Project_List;
2060
2061    begin
2062       Action (Root_Project, Root_Tree);
2063
2064       if Root_Project.Qualifier in Aggregate_Project then
2065          Agg := Root_Project.Aggregated_Projects;
2066          while Agg /= null loop
2067             For_Project_And_Aggregated (Agg.Project, Agg.Tree);
2068             Agg := Agg.Next;
2069          end loop;
2070       end if;
2071    end For_Project_And_Aggregated;
2072
2073    ----------------------------------------
2074    -- For_Project_And_Aggregated_Context --
2075    ----------------------------------------
2076
2077    procedure For_Project_And_Aggregated_Context
2078      (Root_Project : Project_Id;
2079       Root_Tree    : Project_Tree_Ref)
2080    is
2081
2082       procedure Recursive_Process
2083         (Project : Project_Id;
2084          Tree    : Project_Tree_Ref;
2085          Context : Project_Context);
2086       --  Process Project and all aggregated projects recursively
2087
2088       -----------------------
2089       -- Recursive_Process --
2090       -----------------------
2091
2092       procedure Recursive_Process
2093         (Project : Project_Id;
2094          Tree    : Project_Tree_Ref;
2095          Context : Project_Context)
2096       is
2097          Agg : Aggregated_Project_List;
2098          Ctx : Project_Context;
2099
2100       begin
2101          Action (Project, Tree, Context);
2102
2103          if Project.Qualifier in Aggregate_Project then
2104             Ctx :=
2105               (In_Aggregate_Lib      => True,
2106                From_Encapsulated_Lib =>
2107                  Context.From_Encapsulated_Lib
2108                    or else Project.Standalone_Library = Encapsulated);
2109
2110             Agg := Project.Aggregated_Projects;
2111             while Agg /= null loop
2112                Recursive_Process (Agg.Project, Agg.Tree, Ctx);
2113                Agg := Agg.Next;
2114             end loop;
2115          end if;
2116       end Recursive_Process;
2117
2118    --  Start of processing for For_Project_And_Aggregated_Context
2119
2120    begin
2121       Recursive_Process
2122         (Root_Project, Root_Tree, Project_Context'(False, False));
2123    end For_Project_And_Aggregated_Context;
2124
2125 --  Package initialization for Prj
2126
2127 begin
2128    --  Make sure that the standard config and user project file extensions are
2129    --  compatible with canonical case file naming.
2130
2131    Canonical_Case_File_Name (Config_Project_File_Extension);
2132    Canonical_Case_File_Name (Project_File_Extension);
2133 end Prj;