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