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
 362    end Extend_Name;
 363
 364    ---------------------
 365    -- Project_Changed --
 366    ---------------------
 367
 368    procedure Project_Changed (Iter : in out Source_Iterator) is
 369    begin
 370       Iter.Language := Iter.Project.Project.Languages;
 371       Language_Changed (Iter);
 372    end Project_Changed;
 373
 374    ----------------------
 375    -- Language_Changed --
 376    ----------------------
 377
 378    procedure Language_Changed (Iter : in out Source_Iterator) is
 379    begin
 380       Iter.Current  := No_Source;
 381
 382       if Iter.Language_Name /= No_Name then
 383          while Iter.Language /= null
 384            and then Iter.Language.Name /= Iter.Language_Name
 385          loop
 386             Iter.Language := Iter.Language.Next;
 387          end loop;
 388       end if;
 389
 390       --  If there is no matching language in this project, move to next
 391
 392       if Iter.Language = No_Language_Index then
 393          if Iter.All_Projects then
 394             Iter.Project := Iter.Project.Next;
 395
 396             if Iter.Project /= null then
 397                Project_Changed (Iter);
 398             end if;
 399
 400          else
 401             Iter.Project := null;
 402          end if;
 403
 404       else
 405          Iter.Current := Iter.Language.First_Source;
 406
 407          if Iter.Current = No_Source then
 408             Iter.Language := Iter.Language.Next;
 409             Language_Changed (Iter);
 410          end if;
 411       end if;
 412    end Language_Changed;
 413
 414    ---------------------
 415    -- For_Each_Source --
 416    ---------------------
 417
 418    function For_Each_Source
 419      (In_Tree  : Project_Tree_Ref;
 420       Project  : Project_Id := No_Project;
 421       Language : Name_Id := No_Name) return Source_Iterator
 422    is
 423       Iter : Source_Iterator;
 424    begin
 425       Iter := Source_Iterator'
 426         (In_Tree       => In_Tree,
 427          Project       => In_Tree.Projects,
 428          All_Projects  => Project = No_Project,
 429          Language_Name => Language,
 430          Language      => No_Language_Index,
 431          Current       => No_Source);
 432
 433       if Project /= null then
 434          while Iter.Project /= null
 435            and then Iter.Project.Project /= Project
 436          loop
 437             Iter.Project := Iter.Project.Next;
 438          end loop;
 439       end if;
 440
 441       Project_Changed (Iter);
 442
 443       return Iter;
 444    end For_Each_Source;
 445
 446    -------------
 447    -- Element --
 448    -------------
 449
 450    function Element (Iter : Source_Iterator) return Source_Id is
 451    begin
 452       return Iter.Current;
 453    end Element;
 454
 455    ----------
 456    -- Next --
 457    ----------
 458
 459    procedure Next (Iter : in out Source_Iterator) is
 460    begin
 461       Iter.Current := Iter.Current.Next_In_Lang;
 462       if Iter.Current = No_Source then
 463          Iter.Language := Iter.Language.Next;
 464          Language_Changed (Iter);
 465       end if;
 466    end Next;
 467
 468    --------------------------------
 469    -- For_Every_Project_Imported --
 470    --------------------------------
 471
 472    procedure For_Every_Project_Imported
 473      (By                 : Project_Id;
 474       Tree               : Project_Tree_Ref;
 475       With_State         : in out State;
 476       Include_Aggregated : Boolean := True;
 477       Imported_First     : Boolean := False)
 478    is
 479       use Project_Boolean_Htable;
 480       Seen : Project_Boolean_Htable.Instance := Project_Boolean_Htable.Nil;
 481
 482       procedure Recursive_Check
 483         (Project : Project_Id;
 484          Tree    : Project_Tree_Ref);
 485       --  Check if a project has already been seen. If not seen, mark it as
 486       --  Seen, Call Action, and check all its imported projects.
 487
 488       ---------------------
 489       -- Recursive_Check --
 490       ---------------------
 491
 492       procedure Recursive_Check
 493         (Project : Project_Id;
 494          Tree    : Project_Tree_Ref)
 495       is
 496          List : Project_List;
 497          Agg  : Aggregated_Project_List;
 498
 499       begin
 500          if not Get (Seen, Project) then
 501             --  Even if a project is aggregated multiple times, we will only
 502             --  return it once.
 503
 504             Set (Seen, Project, True);
 505
 506             if not Imported_First then
 507                Action (Project, Tree, With_State);
 508             end if;
 509
 510             --  Visit all extended projects
 511
 512             if Project.Extends /= No_Project then
 513                Recursive_Check (Project.Extends, Tree);
 514             end if;
 515
 516             --  Visit all imported projects
 517
 518             List := Project.Imported_Projects;
 519             while List /= null loop
 520                Recursive_Check (List.Project, Tree);
 521                List := List.Next;
 522             end loop;
 523
 524             --  Visit all aggregated projects
 525
 526             if Include_Aggregated
 527               and then Project.Qualifier = Aggregate
 528             then
 529                Agg := Project.Aggregated_Projects;
 530                while Agg /= null loop
 531                   pragma Assert (Agg.Project /= No_Project);
 532                   Recursive_Check (Agg.Project, Agg.Tree);
 533                   Agg := Agg.Next;
 534                end loop;
 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       else
 630          Look_For_Sources (No_Project, In_Tree, Result);
 631       end if;
 632
 633       return Result;
 634    end Find_Source;
 635
 636    ----------
 637    -- Hash --
 638    ----------
 639
 640    function Hash is new GNAT.HTable.Hash (Header_Num => Header_Num);
 641    --  Used in implementation of other functions Hash below
 642
 643    function Hash (Name : File_Name_Type) return Header_Num is
 644    begin
 645       return Hash (Get_Name_String (Name));
 646    end Hash;
 647
 648    function Hash (Name : Name_Id) return Header_Num is
 649    begin
 650       return Hash (Get_Name_String (Name));
 651    end Hash;
 652
 653    function Hash (Name : Path_Name_Type) return Header_Num is
 654    begin
 655       return Hash (Get_Name_String (Name));
 656    end Hash;
 657
 658    function Hash (Project : Project_Id) return Header_Num is
 659    begin
 660       if Project = No_Project then
 661          return Header_Num'First;
 662       else
 663          return Hash (Get_Name_String (Project.Name));
 664       end if;
 665    end Hash;
 666
 667    -----------
 668    -- Image --
 669    -----------
 670
 671    function Image (The_Casing : Casing_Type) return String is
 672    begin
 673       return The_Casing_Images (The_Casing).all;
 674    end Image;
 675
 676    -----------------------------
 677    -- Is_Standard_GNAT_Naming --
 678    -----------------------------
 679
 680    function Is_Standard_GNAT_Naming
 681      (Naming : Lang_Naming_Data) return Boolean
 682    is
 683    begin
 684       return Get_Name_String (Naming.Spec_Suffix) = ".ads"
 685         and then Get_Name_String (Naming.Body_Suffix) = ".adb"
 686         and then Get_Name_String (Naming.Dot_Replacement) = "-";
 687    end Is_Standard_GNAT_Naming;
 688
 689    ----------------
 690    -- Initialize --
 691    ----------------
 692
 693    procedure Initialize (Tree : Project_Tree_Ref) is
 694    begin
 695       if The_Empty_String = No_Name then
 696          Uintp.Initialize;
 697          Name_Len := 0;
 698          The_Empty_String := Name_Find;
 699
 700          Prj.Attr.Initialize;
 701
 702          --  Make sure that new reserved words after Ada 95 may be used as
 703          --  identifiers.
 704
 705          Opt.Ada_Version := Opt.Ada_95;
 706
 707          Set_Name_Table_Byte (Name_Project,  Token_Type'Pos (Tok_Project));
 708          Set_Name_Table_Byte (Name_Extends,  Token_Type'Pos (Tok_Extends));
 709          Set_Name_Table_Byte (Name_External, Token_Type'Pos (Tok_External));
 710          Set_Name_Table_Byte
 711            (Name_External_As_List, Token_Type'Pos (Tok_External_As_List));
 712       end if;
 713
 714       if Tree /= No_Project_Tree then
 715          Reset (Tree);
 716       end if;
 717    end Initialize;
 718
 719    ------------------
 720    -- Is_Extending --
 721    ------------------
 722
 723    function Is_Extending
 724      (Extending : Project_Id;
 725       Extended  : Project_Id) return Boolean
 726    is
 727       Proj : Project_Id;
 728
 729    begin
 730       Proj := Extending;
 731       while Proj /= No_Project loop
 732          if Proj = Extended then
 733             return True;
 734          end if;
 735
 736          Proj := Proj.Extends;
 737       end loop;
 738
 739       return False;
 740    end Is_Extending;
 741
 742    -----------------
 743    -- Object_Name --
 744    -----------------
 745
 746    function Object_Name
 747      (Source_File_Name   : File_Name_Type;
 748       Object_File_Suffix : Name_Id := No_Name) return File_Name_Type
 749    is
 750    begin
 751       if Object_File_Suffix = No_Name then
 752          return Extend_Name
 753            (Source_File_Name, Object_Suffix);
 754       else
 755          return Extend_Name
 756            (Source_File_Name, Get_Name_String (Object_File_Suffix));
 757       end if;
 758    end Object_Name;
 759
 760    function Object_Name
 761      (Source_File_Name   : File_Name_Type;
 762       Source_Index       : Int;
 763       Index_Separator    : Character;
 764       Object_File_Suffix : Name_Id := No_Name) return File_Name_Type
 765    is
 766       Index_Img : constant String := Source_Index'Img;
 767       Last      : Natural;
 768
 769    begin
 770       Get_Name_String (Source_File_Name);
 771
 772       Last := Name_Len;
 773       while Last > 1 and then Name_Buffer (Last) /= '.' loop
 774          Last := Last - 1;
 775       end loop;
 776
 777       if Last > 1 then
 778          Name_Len := Last - 1;
 779       end if;
 780
 781       Add_Char_To_Name_Buffer (Index_Separator);
 782       Add_Str_To_Name_Buffer (Index_Img (2 .. Index_Img'Last));
 783
 784       if Object_File_Suffix = No_Name then
 785          Add_Str_To_Name_Buffer (Object_Suffix);
 786       else
 787          Add_Str_To_Name_Buffer (Get_Name_String (Object_File_Suffix));
 788       end if;
 789
 790       return Name_Find;
 791    end Object_Name;
 792
 793    ----------------------
 794    -- Record_Temp_File --
 795    ----------------------
 796
 797    procedure Record_Temp_File
 798      (Shared : Shared_Project_Tree_Data_Access;
 799       Path   : Path_Name_Type)
 800    is
 801    begin
 802       Temp_Files_Table.Append (Shared.Private_Part.Temp_Files, Path);
 803    end Record_Temp_File;
 804
 805    ----------
 806    -- Free --
 807    ----------
 808
 809    procedure Free (List : in out Aggregated_Project_List) is
 810       procedure Unchecked_Free is new Ada.Unchecked_Deallocation
 811         (Aggregated_Project, Aggregated_Project_List);
 812       Tmp : Aggregated_Project_List;
 813    begin
 814       while List /= null loop
 815          Tmp := List.Next;
 816
 817          Free (List.Tree);
 818
 819          Unchecked_Free (List);
 820          List := Tmp;
 821       end loop;
 822    end Free;
 823
 824    ----------------------------
 825    -- Add_Aggregated_Project --
 826    ----------------------------
 827
 828    procedure Add_Aggregated_Project
 829      (Project : Project_Id; Path : Path_Name_Type) is
 830    begin
 831       Project.Aggregated_Projects := new Aggregated_Project'
 832         (Path    => Path,
 833          Project => No_Project,
 834          Tree    => null,
 835          Next    => Project.Aggregated_Projects);
 836    end Add_Aggregated_Project;
 837
 838    ----------
 839    -- Free --
 840    ----------
 841
 842    procedure Free (Project : in out Project_Id) is
 843       procedure Unchecked_Free is new Ada.Unchecked_Deallocation
 844         (Project_Data, Project_Id);
 845
 846    begin
 847       if Project /= null then
 848          Free (Project.Ada_Include_Path);
 849          Free (Project.Objects_Path);
 850          Free (Project.Ada_Objects_Path);
 851          Free_List (Project.Imported_Projects, Free_Project => False);
 852          Free_List (Project.All_Imported_Projects, Free_Project => False);
 853          Free_List (Project.Languages);
 854
 855          case Project.Qualifier is
 856             when Aggregate =>
 857                Free (Project.Aggregated_Projects);
 858
 859             when others =>
 860                null;
 861          end case;
 862
 863          Unchecked_Free (Project);
 864       end if;
 865    end Free;
 866
 867    ---------------
 868    -- Free_List --
 869    ---------------
 870
 871    procedure Free_List (Languages : in out Language_List) is
 872       procedure Unchecked_Free is new Ada.Unchecked_Deallocation
 873         (Language_List_Element, Language_List);
 874       Tmp : Language_List;
 875    begin
 876       while Languages /= null loop
 877          Tmp := Languages.Next;
 878          Unchecked_Free (Languages);
 879          Languages := Tmp;
 880       end loop;
 881    end Free_List;
 882
 883    ---------------
 884    -- Free_List --
 885    ---------------
 886
 887    procedure Free_List (Source : in out Source_Id) is
 888       procedure Unchecked_Free is new
 889         Ada.Unchecked_Deallocation (Source_Data, Source_Id);
 890
 891       Tmp : Source_Id;
 892
 893    begin
 894       while Source /= No_Source loop
 895          Tmp := Source.Next_In_Lang;
 896          Free_List (Source.Alternate_Languages);
 897
 898          if Source.Unit /= null
 899            and then Source.Kind in Spec_Or_Body
 900          then
 901             Source.Unit.File_Names (Source.Kind) := null;
 902          end if;
 903
 904          Unchecked_Free (Source);
 905          Source := Tmp;
 906       end loop;
 907    end Free_List;
 908
 909    ---------------
 910    -- Free_List --
 911    ---------------
 912
 913    procedure Free_List
 914      (List         : in out Project_List;
 915       Free_Project : Boolean)
 916    is
 917       procedure Unchecked_Free is new
 918         Ada.Unchecked_Deallocation (Project_List_Element, Project_List);
 919
 920       Tmp : Project_List;
 921
 922    begin
 923       while List /= null loop
 924          Tmp := List.Next;
 925
 926          if Free_Project then
 927             Free (List.Project);
 928          end if;
 929
 930          Unchecked_Free (List);
 931          List := Tmp;
 932       end loop;
 933    end Free_List;
 934
 935    ---------------
 936    -- Free_List --
 937    ---------------
 938
 939    procedure Free_List (Languages : in out Language_Ptr) is
 940       procedure Unchecked_Free is new
 941         Ada.Unchecked_Deallocation (Language_Data, Language_Ptr);
 942
 943       Tmp : Language_Ptr;
 944
 945    begin
 946       while Languages /= null loop
 947          Tmp := Languages.Next;
 948          Free_List (Languages.First_Source);
 949          Unchecked_Free (Languages);
 950          Languages := Tmp;
 951       end loop;
 952    end Free_List;
 953
 954    --------------------------
 955    -- Reset_Units_In_Table --
 956    --------------------------
 957
 958    procedure Reset_Units_In_Table (Table : in out Units_Htable.Instance) is
 959       Unit : Unit_Index;
 960
 961    begin
 962       Unit := Units_Htable.Get_First (Table);
 963       while Unit /= No_Unit_Index loop
 964          if Unit.File_Names (Spec) /= null then
 965             Unit.File_Names (Spec).Unit := No_Unit_Index;
 966          end if;
 967
 968          if Unit.File_Names (Impl) /= null then
 969             Unit.File_Names (Impl).Unit := No_Unit_Index;
 970          end if;
 971
 972          Unit := Units_Htable.Get_Next (Table);
 973       end loop;
 974    end Reset_Units_In_Table;
 975
 976    ----------------
 977    -- Free_Units --
 978    ----------------
 979
 980    procedure Free_Units (Table : in out Units_Htable.Instance) is
 981       procedure Unchecked_Free is new
 982         Ada.Unchecked_Deallocation (Unit_Data, Unit_Index);
 983
 984       Unit : Unit_Index;
 985
 986    begin
 987       Unit := Units_Htable.Get_First (Table);
 988       while Unit /= No_Unit_Index loop
 989
 990          --  We cannot reset Unit.File_Names (Impl or Spec).Unit here as
 991          --  Source_Data buffer is freed by the following instruction
 992          --  Free_List (Tree.Projects, Free_Project => True);
 993
 994          Unchecked_Free (Unit);
 995          Unit := Units_Htable.Get_Next (Table);
 996       end loop;
 997
 998       Units_Htable.Reset (Table);
 999    end Free_Units;
1000
1001    ----------
1002    -- Free --
1003    ----------
1004
1005    procedure Free (Tree : in out Project_Tree_Ref) is
1006       procedure Unchecked_Free is new
1007         Ada.Unchecked_Deallocation
1008           (Project_Tree_Data, Project_Tree_Ref);
1009
1010       procedure Unchecked_Free is new
1011         Ada.Unchecked_Deallocation
1012           (Project_Tree_Appdata'Class, Project_Tree_Appdata_Access);
1013
1014    begin
1015       if Tree /= null then
1016          if Tree.Is_Root_Tree then
1017             Name_List_Table.Free        (Tree.Shared.Name_Lists);
1018             Number_List_Table.Free      (Tree.Shared.Number_Lists);
1019             String_Element_Table.Free   (Tree.Shared.String_Elements);
1020             Variable_Element_Table.Free (Tree.Shared.Variable_Elements);
1021             Array_Element_Table.Free    (Tree.Shared.Array_Elements);
1022             Array_Table.Free            (Tree.Shared.Arrays);
1023             Package_Table.Free          (Tree.Shared.Packages);
1024             Temp_Files_Table.Free       (Tree.Shared.Private_Part.Temp_Files);
1025          end if;
1026
1027          if Tree.Appdata /= null then
1028             Free (Tree.Appdata.all);
1029             Unchecked_Free (Tree.Appdata);
1030          end if;
1031
1032          Source_Paths_Htable.Reset (Tree.Source_Paths_HT);
1033          Source_Files_Htable.Reset (Tree.Source_Files_HT);
1034
1035          Reset_Units_In_Table (Tree.Units_HT);
1036          Free_List (Tree.Projects, Free_Project => True);
1037          Free_Units (Tree.Units_HT);
1038
1039          Unchecked_Free (Tree);
1040       end if;
1041    end Free;
1042
1043    -----------
1044    -- Reset --
1045    -----------
1046
1047    procedure Reset (Tree : Project_Tree_Ref) is
1048    begin
1049       --  Visible tables
1050
1051       if Tree.Is_Root_Tree then
1052
1053          --  We cannot use 'Access here:
1054          --    "illegal attribute for discriminant-dependent component"
1055          --  However, we know this is valid since Shared and Shared_Data have
1056          --  the same lifetime and will always exist concurrently.
1057
1058          Tree.Shared := Tree.Shared_Data'Unrestricted_Access;
1059          Name_List_Table.Init        (Tree.Shared.Name_Lists);
1060          Number_List_Table.Init      (Tree.Shared.Number_Lists);
1061          String_Element_Table.Init   (Tree.Shared.String_Elements);
1062          Variable_Element_Table.Init (Tree.Shared.Variable_Elements);
1063          Array_Element_Table.Init    (Tree.Shared.Array_Elements);
1064          Array_Table.Init            (Tree.Shared.Arrays);
1065          Package_Table.Init          (Tree.Shared.Packages);
1066
1067          --  Private part table
1068
1069          Temp_Files_Table.Init (Tree.Shared.Private_Part.Temp_Files);
1070
1071          Tree.Shared.Private_Part.Current_Source_Path_File := No_Path;
1072          Tree.Shared.Private_Part.Current_Object_Path_File := No_Path;
1073       end if;
1074
1075       Source_Paths_Htable.Reset    (Tree.Source_Paths_HT);
1076       Source_Files_Htable.Reset    (Tree.Source_Files_HT);
1077       Replaced_Source_HTable.Reset (Tree.Replaced_Sources);
1078
1079       Tree.Replaced_Source_Number := 0;
1080
1081       Reset_Units_In_Table (Tree.Units_HT);
1082       Free_List (Tree.Projects, Free_Project => True);
1083       Free_Units (Tree.Units_HT);
1084    end Reset;
1085
1086    -------------------------------------
1087    -- Set_Current_Object_Path_File_Of --
1088    -------------------------------------
1089
1090    procedure Set_Current_Object_Path_File_Of
1091      (Shared : Shared_Project_Tree_Data_Access;
1092       To     : Path_Name_Type)
1093    is
1094    begin
1095       Shared.Private_Part.Current_Object_Path_File := To;
1096    end Set_Current_Object_Path_File_Of;
1097
1098    -------------------------------------
1099    -- Set_Current_Source_Path_File_Of --
1100    -------------------------------------
1101
1102    procedure Set_Current_Source_Path_File_Of
1103      (Shared : Shared_Project_Tree_Data_Access;
1104       To     : Path_Name_Type)
1105    is
1106    begin
1107       Shared.Private_Part.Current_Source_Path_File := To;
1108    end Set_Current_Source_Path_File_Of;
1109
1110    -----------------------
1111    -- Set_Path_File_Var --
1112    -----------------------
1113
1114    procedure Set_Path_File_Var (Name : String; Value : String) is
1115       Host_Spec : String_Access := To_Host_File_Spec (Value);
1116    begin
1117       if Host_Spec = null then
1118          Prj.Com.Fail
1119            ("could not convert file name """ & Value & """ to host spec");
1120       else
1121          Setenv (Name, Host_Spec.all);
1122          Free (Host_Spec);
1123       end if;
1124    end Set_Path_File_Var;
1125
1126    -------------------
1127    -- Switches_Name --
1128    -------------------
1129
1130    function Switches_Name
1131      (Source_File_Name : File_Name_Type) return File_Name_Type
1132    is
1133    begin
1134       return Extend_Name (Source_File_Name, Switches_Dependency_Suffix);
1135    end Switches_Name;
1136
1137    -----------
1138    -- Value --
1139    -----------
1140
1141    function Value (Image : String) return Casing_Type is
1142    begin
1143       for Casing in The_Casing_Images'Range loop
1144          if To_Lower (Image) = To_Lower (The_Casing_Images (Casing).all) then
1145             return Casing;
1146          end if;
1147       end loop;
1148
1149       raise Constraint_Error;
1150    end Value;
1151
1152    ---------------------
1153    -- Has_Ada_Sources --
1154    ---------------------
1155
1156    function Has_Ada_Sources (Data : Project_Id) return Boolean is
1157       Lang : Language_Ptr;
1158
1159    begin
1160       Lang := Data.Languages;
1161       while Lang /= No_Language_Index loop
1162          if Lang.Name = Name_Ada then
1163             return Lang.First_Source /= No_Source;
1164          end if;
1165          Lang := Lang.Next;
1166       end loop;
1167
1168       return False;
1169    end Has_Ada_Sources;
1170
1171    ------------------------
1172    -- Contains_ALI_Files --
1173    ------------------------
1174
1175    function Contains_ALI_Files (Dir : Path_Name_Type) return Boolean is
1176       Dir_Name : constant String := Get_Name_String (Dir);
1177       Direct   : Dir_Type;
1178       Name     : String (1 .. 1_000);
1179       Last     : Natural;
1180       Result   : Boolean := False;
1181
1182    begin
1183       Open (Direct, Dir_Name);
1184
1185       --  For each file in the directory, check if it is an ALI file
1186
1187       loop
1188          Read (Direct, Name, Last);
1189          exit when Last = 0;
1190          Canonical_Case_File_Name (Name (1 .. Last));
1191          Result := Last >= 5 and then Name (Last - 3 .. Last) = ".ali";
1192          exit when Result;
1193       end loop;
1194
1195       Close (Direct);
1196       return Result;
1197
1198    exception
1199       --  If there is any problem, close the directory if open and return True.
1200       --  The library directory will be added to the path.
1201
1202       when others =>
1203          if Is_Open (Direct) then
1204             Close (Direct);
1205          end if;
1206
1207          return True;
1208    end Contains_ALI_Files;
1209
1210    --------------------------
1211    -- Get_Object_Directory --
1212    --------------------------
1213
1214    function Get_Object_Directory
1215      (Project             : Project_Id;
1216       Including_Libraries : Boolean;
1217       Only_If_Ada         : Boolean := False) return Path_Name_Type
1218    is
1219    begin
1220       if (Project.Library and then Including_Libraries)
1221         or else
1222           (Project.Object_Directory /= No_Path_Information
1223             and then (not Including_Libraries or else not Project.Library))
1224       then
1225          --  For a library project, add the library ALI directory if there is
1226          --  no object directory or if the library ALI directory contains ALI
1227          --  files; otherwise add the object directory.
1228
1229          if Project.Library then
1230             if Project.Object_Directory = No_Path_Information
1231               or else Contains_ALI_Files (Project.Library_ALI_Dir.Display_Name)
1232             then
1233                return Project.Library_ALI_Dir.Display_Name;
1234             else
1235                return Project.Object_Directory.Display_Name;
1236             end if;
1237
1238             --  For a non-library project, add object directory if it is not a
1239             --  virtual project, and if there are Ada sources in the project or
1240             --  one of the projects it extends. If there are no Ada sources,
1241             --  adding the object directory could disrupt the order of the
1242             --  object dirs in the path.
1243
1244          elsif not Project.Virtual then
1245             declare
1246                Add_Object_Dir : Boolean;
1247                Prj            : Project_Id;
1248
1249             begin
1250                Add_Object_Dir := not Only_If_Ada;
1251                Prj := Project;
1252                while not Add_Object_Dir and then Prj /= No_Project loop
1253                   if Has_Ada_Sources (Prj) then
1254                      Add_Object_Dir := True;
1255                   else
1256                      Prj := Prj.Extends;
1257                   end if;
1258                end loop;
1259
1260                if Add_Object_Dir then
1261                   return Project.Object_Directory.Display_Name;
1262                end if;
1263             end;
1264          end if;
1265       end if;
1266
1267       return No_Path;
1268    end Get_Object_Directory;
1269
1270    -----------------------------------
1271    -- Ultimate_Extending_Project_Of --
1272    -----------------------------------
1273
1274    function Ultimate_Extending_Project_Of
1275      (Proj : Project_Id) return Project_Id
1276    is
1277       Prj : Project_Id;
1278
1279    begin
1280       Prj := Proj;
1281       while Prj /= null and then Prj.Extended_By /= No_Project loop
1282          Prj := Prj.Extended_By;
1283       end loop;
1284
1285       return Prj;
1286    end Ultimate_Extending_Project_Of;
1287
1288    -----------------------------------
1289    -- Compute_All_Imported_Projects --
1290    -----------------------------------
1291
1292    procedure Compute_All_Imported_Projects
1293      (Root_Project : Project_Id;
1294       Tree         : Project_Tree_Ref)
1295    is
1296       procedure Analyze_Tree
1297         (Local_Root : Project_Id;
1298          Local_Tree : Project_Tree_Ref);
1299       --  Process Project and all its aggregated project to analyze their own
1300       --  imported projects.
1301
1302       ------------------
1303       -- Analyze_Tree --
1304       ------------------
1305
1306       procedure Analyze_Tree
1307         (Local_Root : Project_Id;
1308          Local_Tree : Project_Tree_Ref)
1309       is
1310          pragma Unreferenced (Local_Root);
1311
1312          Project : Project_Id;
1313
1314          procedure Recursive_Add
1315            (Prj   : Project_Id;
1316             Tree  : Project_Tree_Ref;
1317             Dummy : in out Boolean);
1318          --  Recursively add the projects imported by project Project, but not
1319          --  those that are extended.
1320
1321          -------------------
1322          -- Recursive_Add --
1323          -------------------
1324
1325          procedure Recursive_Add
1326            (Prj   : Project_Id;
1327             Tree  : Project_Tree_Ref;
1328             Dummy : in out Boolean)
1329          is
1330             pragma Unreferenced (Dummy, Tree);
1331             List : Project_List;
1332             Prj2 : Project_Id;
1333
1334          begin
1335             --  A project is not importing itself
1336
1337             Prj2 := Ultimate_Extending_Project_Of (Prj);
1338
1339             if Project /= Prj2 then
1340
1341                --  Check that the project is not already in the list. We know
1342                --  the one passed to Recursive_Add have never been visited
1343                --  before, but the one passed it are the extended projects.
1344
1345                List := Project.All_Imported_Projects;
1346                while List /= null loop
1347                   if List.Project = Prj2 then
1348                      return;
1349                   end if;
1350
1351                   List := List.Next;
1352                end loop;
1353
1354                --  Add it to the list
1355
1356                Project.All_Imported_Projects :=
1357                  new Project_List_Element'
1358                    (Project => Prj2,
1359                     Next    => Project.All_Imported_Projects);
1360             end if;
1361          end Recursive_Add;
1362
1363          procedure For_All_Projects is
1364            new For_Every_Project_Imported (Boolean, Recursive_Add);
1365
1366          Dummy   : Boolean := False;
1367          List    : Project_List;
1368
1369       begin
1370          List := Local_Tree.Projects;
1371          while List /= null loop
1372             Project := List.Project;
1373             Free_List
1374               (Project.All_Imported_Projects, Free_Project => False);
1375             For_All_Projects
1376               (Project, Local_Tree, Dummy, Include_Aggregated => False);
1377             List := List.Next;
1378          end loop;
1379       end Analyze_Tree;
1380
1381       procedure For_Aggregates is
1382         new For_Project_And_Aggregated (Analyze_Tree);
1383
1384    --  Start of processing for Compute_All_Imported_Projects
1385
1386    begin
1387       For_Aggregates (Root_Project, Tree);
1388    end Compute_All_Imported_Projects;
1389
1390    -------------------
1391    -- Is_Compilable --
1392    -------------------
1393
1394    function Is_Compilable (Source : Source_Id) return Boolean is
1395    begin
1396       case Source.Compilable is
1397          when Unknown =>
1398             if Source.Language.Config.Compiler_Driver /= No_File
1399               and then
1400                 Length_Of_Name (Source.Language.Config.Compiler_Driver) /= 0
1401               and then not Source.Locally_Removed
1402               and then (Source.Language.Config.Kind /= File_Based
1403                          or else Source.Kind /= Spec)
1404             then
1405                --  Do not modify Source.Compilable before the source record
1406                --  has been initialized.
1407
1408                if Source.Source_TS /= Empty_Time_Stamp then
1409                   Source.Compilable := Yes;
1410                end if;
1411
1412                return True;
1413
1414             else
1415                if Source.Source_TS /= Empty_Time_Stamp then
1416                   Source.Compilable := No;
1417                end if;
1418
1419                return False;
1420             end if;
1421
1422          when Yes =>
1423             return True;
1424
1425          when No =>
1426             return False;
1427       end case;
1428    end Is_Compilable;
1429
1430    ------------------------------
1431    -- Object_To_Global_Archive --
1432    ------------------------------
1433
1434    function Object_To_Global_Archive (Source : Source_Id) return Boolean is
1435    begin
1436       return Source.Language.Config.Kind = File_Based
1437         and then Source.Kind = Impl
1438         and then Source.Language.Config.Objects_Linked
1439         and then Is_Compilable (Source)
1440         and then Source.Language.Config.Object_Generated;
1441    end Object_To_Global_Archive;
1442
1443    ----------------------------
1444    -- Get_Language_From_Name --
1445    ----------------------------
1446
1447    function Get_Language_From_Name
1448      (Project : Project_Id;
1449       Name    : String) return Language_Ptr
1450    is
1451       N      : Name_Id;
1452       Result : Language_Ptr;
1453
1454    begin
1455       Name_Len := Name'Length;
1456       Name_Buffer (1 .. Name_Len) := Name;
1457       To_Lower (Name_Buffer (1 .. Name_Len));
1458       N := Name_Find;
1459
1460       Result := Project.Languages;
1461       while Result /= No_Language_Index loop
1462          if Result.Name = N then
1463             return Result;
1464          end if;
1465
1466          Result := Result.Next;
1467       end loop;
1468
1469       return No_Language_Index;
1470    end Get_Language_From_Name;
1471
1472    ----------------
1473    -- Other_Part --
1474    ----------------
1475
1476    function Other_Part (Source : Source_Id) return Source_Id is
1477    begin
1478       if Source.Unit /= No_Unit_Index then
1479          case Source.Kind is
1480             when Impl =>
1481                return Source.Unit.File_Names (Spec);
1482             when Spec =>
1483                return Source.Unit.File_Names (Impl);
1484             when Sep =>
1485                return No_Source;
1486          end case;
1487       else
1488          return No_Source;
1489       end if;
1490    end Other_Part;
1491
1492    ------------------
1493    -- Create_Flags --
1494    ------------------
1495
1496    function Create_Flags
1497      (Report_Error               : Error_Handler;
1498       When_No_Sources            : Error_Warning;
1499       Require_Sources_Other_Lang : Boolean       := True;
1500       Allow_Duplicate_Basenames  : Boolean       := True;
1501       Compiler_Driver_Mandatory  : Boolean       := False;
1502       Error_On_Unknown_Language  : Boolean       := True;
1503       Require_Obj_Dirs           : Error_Warning := Error;
1504       Allow_Invalid_External     : Error_Warning := Error;
1505       Missing_Source_Files       : Error_Warning := Error;
1506       Ignore_Missing_With        : Boolean       := False)
1507       return Processing_Flags
1508    is
1509    begin
1510       return Processing_Flags'
1511         (Report_Error               => Report_Error,
1512          When_No_Sources            => When_No_Sources,
1513          Require_Sources_Other_Lang => Require_Sources_Other_Lang,
1514          Allow_Duplicate_Basenames  => Allow_Duplicate_Basenames,
1515          Error_On_Unknown_Language  => Error_On_Unknown_Language,
1516          Compiler_Driver_Mandatory  => Compiler_Driver_Mandatory,
1517          Require_Obj_Dirs           => Require_Obj_Dirs,
1518          Allow_Invalid_External     => Allow_Invalid_External,
1519          Missing_Source_Files       => Missing_Source_Files,
1520          Ignore_Missing_With        => Ignore_Missing_With);
1521    end Create_Flags;
1522
1523    ------------
1524    -- Length --
1525    ------------
1526
1527    function Length
1528      (Table : Name_List_Table.Instance;
1529       List  : Name_List_Index) return Natural
1530    is
1531       Count : Natural := 0;
1532       Tmp   : Name_List_Index;
1533
1534    begin
1535       Tmp := List;
1536       while Tmp /= No_Name_List loop
1537          Count := Count + 1;
1538          Tmp := Table.Table (Tmp).Next;
1539       end loop;
1540
1541       return Count;
1542    end Length;
1543
1544    ------------------
1545    -- Debug_Output --
1546    ------------------
1547
1548    procedure Debug_Output (Str : String) is
1549    begin
1550       if Current_Verbosity > Default then
1551          Write_Line ((1 .. Debug_Level * 2 => ' ') & Str);
1552       end if;
1553    end Debug_Output;
1554
1555    ------------------
1556    -- Debug_Indent --
1557    ------------------
1558
1559    procedure Debug_Indent is
1560    begin
1561       if Current_Verbosity = High then
1562          Write_Str ((1 .. Debug_Level * 2 => ' '));
1563       end if;
1564    end Debug_Indent;
1565
1566    ------------------
1567    -- Debug_Output --
1568    ------------------
1569
1570    procedure Debug_Output (Str : String; Str2 : Name_Id) is
1571    begin
1572       if Current_Verbosity = High then
1573          Debug_Indent;
1574          Write_Str (Str);
1575
1576          if Str2 = No_Name then
1577             Write_Line (" <no_name>");
1578          else
1579             Write_Line (" """ & Get_Name_String (Str2) & '"');
1580          end if;
1581       end if;
1582    end Debug_Output;
1583
1584    ---------------------------
1585    -- Debug_Increase_Indent --
1586    ---------------------------
1587
1588    procedure Debug_Increase_Indent
1589      (Str : String := ""; Str2 : Name_Id := No_Name)
1590    is
1591    begin
1592       if Str2 /= No_Name then
1593          Debug_Output (Str, Str2);
1594       else
1595          Debug_Output (Str);
1596       end if;
1597       Debug_Level := Debug_Level + 1;
1598    end Debug_Increase_Indent;
1599
1600    ---------------------------
1601    -- Debug_Decrease_Indent --
1602    ---------------------------
1603
1604    procedure Debug_Decrease_Indent (Str : String := "") is
1605    begin
1606       if Debug_Level > 0 then
1607          Debug_Level := Debug_Level - 1;
1608       end if;
1609
1610       if Str /= "" then
1611          Debug_Output (Str);
1612       end if;
1613    end Debug_Decrease_Indent;
1614
1615    ----------------
1616    -- Debug_Name --
1617    ----------------
1618
1619    function Debug_Name (Tree : Project_Tree_Ref) return Name_Id is
1620       P : Project_List;
1621
1622    begin
1623       Name_Len := 0;
1624       Add_Str_To_Name_Buffer ("Tree [");
1625
1626       P := Tree.Projects;
1627       while P /= null loop
1628          if P /= Tree.Projects then
1629             Add_Char_To_Name_Buffer (',');
1630          end if;
1631
1632          Add_Str_To_Name_Buffer (Get_Name_String (P.Project.Name));
1633
1634          P := P.Next;
1635       end loop;
1636
1637       Add_Char_To_Name_Buffer (']');
1638
1639       return Name_Find;
1640    end Debug_Name;
1641
1642    ----------
1643    -- Free --
1644    ----------
1645
1646    procedure Free (Tree : in out Project_Tree_Appdata) is
1647       pragma Unreferenced (Tree);
1648    begin
1649       null;
1650    end Free;
1651
1652    --------------------------------
1653    -- For_Project_And_Aggregated --
1654    --------------------------------
1655
1656    procedure For_Project_And_Aggregated
1657      (Root_Project : Project_Id;
1658       Root_Tree    : Project_Tree_Ref)
1659    is
1660       Agg : Aggregated_Project_List;
1661    begin
1662       Action (Root_Project, Root_Tree);
1663
1664       if Root_Project.Qualifier = Aggregate then
1665          Agg := Root_Project.Aggregated_Projects;
1666          while Agg /= null loop
1667             For_Project_And_Aggregated (Agg.Project, Agg.Tree);
1668             Agg := Agg.Next;
1669          end loop;
1670       end if;
1671    end For_Project_And_Aggregated;
1672
1673 begin
1674    --  Make sure that the standard config and user project file extensions are
1675    --  compatible with canonical case file naming.
1676
1677    Canonical_Case_File_Name (Config_Project_File_Extension);
1678    Canonical_Case_File_Name (Project_File_Extension);
1679 end Prj;