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