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-2009, 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 Ada.Characters.Handling; use Ada.Characters.Handling;
  27 with Ada.Unchecked_Deallocation;
  28
  29 with Debug;
  30 with Osint;    use Osint;
  31 with Prj.Attr;
  32 with Prj.Err;  use Prj.Err;
  33 with Snames;   use Snames;
  34 with Table;
  35 with Uintp;    use Uintp;
  36
  37 with GNAT.Directory_Operations; use GNAT.Directory_Operations;
  38
  39 with System.Case_Util; use System.Case_Util;
  40 with System.HTable;
  41
  42 package body Prj is
  43
  44    Object_Suffix : constant String := Get_Target_Object_Suffix.all;
  45    --  File suffix for object files
  46
  47    Initial_Buffer_Size : constant := 100;
  48    --  Initial size for extensible buffer used in Add_To_Buffer
  49
  50    Current_Mode : Mode := Ada_Only;
  51
  52    Configuration_Mode : Boolean := False;
  53
  54    The_Empty_String : Name_Id;
  55
  56    Default_Ada_Spec_Suffix_Id : File_Name_Type;
  57    Default_Ada_Body_Suffix_Id : File_Name_Type;
  58    Slash_Id                   : Path_Name_Type;
  59    --  Initialized in Prj.Initialize, then never modified
  60
  61    subtype Known_Casing is Casing_Type range All_Upper_Case .. Mixed_Case;
  62
  63    The_Casing_Images : constant array (Known_Casing) of String_Access :=
  64      (All_Lower_Case => new String'("lowercase"),
  65       All_Upper_Case => new String'("UPPERCASE"),
  66       Mixed_Case     => new String'("MixedCase"));
  67
  68    Initialized : Boolean := False;
  69
  70    Standard_Dot_Replacement : constant File_Name_Type :=
  71                                 File_Name_Type
  72                                   (First_Name_Id + Character'Pos ('-'));
  73
  74    Std_Naming_Data : constant Naming_Data :=
  75                        (Dot_Replacement           => Standard_Dot_Replacement,
  76                         Casing                    => All_Lower_Case,
  77                         Spec_Suffix               => No_Array_Element,
  78                         Body_Suffix               => No_Array_Element,
  79                         Separate_Suffix           => No_File,
  80                         Specs                     => No_Array_Element,
  81                         Bodies                    => No_Array_Element,
  82                         Specification_Exceptions  => No_Array_Element,
  83                         Implementation_Exceptions => No_Array_Element);
  84
  85    Project_Empty : constant Project_Data :=
  86                      (Qualifier                      => Unspecified,
  87                       Externally_Built               => False,
  88                       Config                         => Default_Project_Config,
  89                       Name                           => No_Name,
  90                       Display_Name                   => No_Name,
  91                       Path                           => No_Path_Information,
  92                       Virtual                        => False,
  93                       Location                       => No_Location,
  94                       Mains                          => Nil_String,
  95                       Directory                      => No_Path_Information,
  96                       Library                        => False,
  97                       Library_Dir                    => No_Path_Information,
  98                       Library_Src_Dir                => No_Path_Information,
  99                       Library_ALI_Dir                => No_Path_Information,
 100                       Library_Name                   => No_Name,
 101                       Library_Kind                   => Static,
 102                       Lib_Internal_Name              => No_Name,
 103                       Standalone_Library             => False,
 104                       Lib_Interface_ALIs             => Nil_String,
 105                       Lib_Auto_Init                  => False,
 106                       Libgnarl_Needed                => Unknown,
 107                       Symbol_Data                    => No_Symbols,
 108                       Interfaces_Defined             => False,
 109                       Include_Path                   => null,
 110                       Include_Data_Set               => False,
 111                       Source_Dirs                    => Nil_String,
 112                       Known_Order_Of_Source_Dirs     => True,
 113                       Object_Directory               => No_Path_Information,
 114                       Library_TS                     => Empty_Time_Stamp,
 115                       Exec_Directory                 => No_Path_Information,
 116                       Extends                        => No_Project,
 117                       Extended_By                    => No_Project,
 118                       Naming                         => Std_Naming_Data,
 119                       Languages      => No_Language_Index,
 120                       Decl                           => No_Declarations,
 121                       Imported_Projects              => null,
 122                       All_Imported_Projects          => null,
 123                       Ada_Include_Path               => null,
 124                       Ada_Objects_Path               => null,
 125                       Objects_Path                   => null,
 126                       Include_Path_File              => No_Path,
 127                       Objects_Path_File_With_Libs    => No_Path,
 128                       Objects_Path_File_Without_Libs => No_Path,
 129                       Config_File_Name               => No_Path,
 130                       Config_File_Temp               => False,
 131                       Config_Checked                 => False,
 132                       Need_To_Build_Lib              => False,
 133                       Depth                          => 0,
 134                       Unkept_Comments                => False);
 135
 136    package Temp_Files is new Table.Table
 137      (Table_Component_Type => Path_Name_Type,
 138       Table_Index_Type     => Integer,
 139       Table_Low_Bound      => 1,
 140       Table_Initial        => 20,
 141       Table_Increment      => 100,
 142       Table_Name           => "Makegpr.Temp_Files");
 143    --  Table to store the path name of all the created temporary files, so that
 144    --  they can be deleted at the end, or when the program is interrupted.
 145
 146    procedure Free (Project : in out Project_Id; Reset_Only : Boolean);
 147    --  Free memory allocated for Project
 148
 149    procedure Free_List (Languages : in out Language_Ptr);
 150    procedure Free_List (Source : in out Source_Id);
 151    procedure Free_List (Languages : in out Language_List);
 152    --  Free memory allocated for the list of languages or sources
 153
 154    procedure Language_Changed (Iter : in out Source_Iterator);
 155    procedure Project_Changed (Iter : in out Source_Iterator);
 156    --  Called when a new project or language was selected for this iterator.
 157
 158    function Contains_ALI_Files (Dir : Path_Name_Type) return Boolean;
 159    --  Return True if there is at least one ALI file in the directory Dir
 160
 161    -------------------
 162    -- Add_To_Buffer --
 163    -------------------
 164
 165    procedure Add_To_Buffer
 166      (S    : String;
 167       To   : in out String_Access;
 168       Last : in out Natural)
 169    is
 170    begin
 171       if To = null then
 172          To := new String (1 .. Initial_Buffer_Size);
 173          Last := 0;
 174       end if;
 175
 176       --  If Buffer is too small, double its size
 177
 178       while Last + S'Length > To'Last loop
 179          declare
 180             New_Buffer : constant  String_Access :=
 181                            new String (1 .. 2 * Last);
 182
 183          begin
 184             New_Buffer (1 .. Last) := To (1 .. Last);
 185             Free (To);
 186             To := New_Buffer;
 187          end;
 188       end loop;
 189
 190       To (Last + 1 .. Last + S'Length) := S;
 191       Last := Last + S'Length;
 192    end Add_To_Buffer;
 193
 194    -----------------------
 195    -- Body_Suffix_Id_Of --
 196    -----------------------
 197
 198    function Body_Suffix_Id_Of
 199      (In_Tree     : Project_Tree_Ref;
 200       Language_Id : Name_Id;
 201       Naming      : Naming_Data) return File_Name_Type
 202    is
 203       Element_Id : Array_Element_Id;
 204       Element    : Array_Element;
 205
 206    begin
 207       --  ??? This seems to be only for Ada_Only mode...
 208       Element_Id := Naming.Body_Suffix;
 209       while Element_Id /= No_Array_Element loop
 210          Element := In_Tree.Array_Elements.Table (Element_Id);
 211
 212          if Element.Index = Language_Id then
 213             return File_Name_Type (Element.Value.Value);
 214          end if;
 215
 216          Element_Id := Element.Next;
 217       end loop;
 218
 219       return No_File;
 220    end Body_Suffix_Id_Of;
 221
 222    --------------------
 223    -- Body_Suffix_Of --
 224    --------------------
 225
 226    function Body_Suffix_Of
 227      (In_Tree  : Project_Tree_Ref;
 228       Language : String;
 229       Naming   : Naming_Data) return String
 230    is
 231       Language_Id : Name_Id;
 232       Element_Id  : Array_Element_Id;
 233       Element     : Array_Element;
 234
 235    begin
 236       Name_Len := 0;
 237       Add_Str_To_Name_Buffer (Language);
 238       To_Lower (Name_Buffer (1 .. Name_Len));
 239       Language_Id := Name_Find;
 240
 241       Element_Id := Naming.Body_Suffix;
 242       while Element_Id /= No_Array_Element loop
 243          Element := In_Tree.Array_Elements.Table (Element_Id);
 244
 245          if Element.Index = Language_Id then
 246             return Get_Name_String (Element.Value.Value);
 247          end if;
 248
 249          Element_Id := Element.Next;
 250       end loop;
 251
 252       return "";
 253    end Body_Suffix_Of;
 254
 255    -----------------------------
 256    -- Default_Ada_Body_Suffix --
 257    -----------------------------
 258
 259    function Default_Ada_Body_Suffix return File_Name_Type is
 260    begin
 261       return Default_Ada_Body_Suffix_Id;
 262    end Default_Ada_Body_Suffix;
 263
 264    -----------------------------
 265    -- Default_Ada_Spec_Suffix --
 266    -----------------------------
 267
 268    function Default_Ada_Spec_Suffix return File_Name_Type is
 269    begin
 270       return Default_Ada_Spec_Suffix_Id;
 271    end Default_Ada_Spec_Suffix;
 272
 273    ---------------------------
 274    -- Delete_All_Temp_Files --
 275    ---------------------------
 276
 277    procedure Delete_All_Temp_Files is
 278       Dont_Care : Boolean;
 279       pragma Warnings (Off, Dont_Care);
 280    begin
 281       if not Debug.Debug_Flag_N then
 282          for Index in 1 .. Temp_Files.Last loop
 283             Delete_File
 284               (Get_Name_String (Temp_Files.Table (Index)), Dont_Care);
 285          end loop;
 286       end if;
 287    end Delete_All_Temp_Files;
 288
 289    ---------------------
 290    -- Dependency_Name --
 291    ---------------------
 292
 293    function Dependency_Name
 294      (Source_File_Name : File_Name_Type;
 295       Dependency       : Dependency_File_Kind) return File_Name_Type
 296    is
 297    begin
 298       case Dependency is
 299          when None =>
 300             return No_File;
 301
 302          when Makefile =>
 303             return
 304               File_Name_Type
 305                 (Extend_Name
 306                    (Source_File_Name, Makefile_Dependency_Suffix));
 307
 308          when ALI_File =>
 309             return
 310               File_Name_Type
 311                 (Extend_Name
 312                    (Source_File_Name, ALI_Dependency_Suffix));
 313       end case;
 314    end Dependency_Name;
 315
 316    ----------------
 317    -- Empty_File --
 318    ----------------
 319
 320    function Empty_File return File_Name_Type is
 321    begin
 322       return File_Name_Type (The_Empty_String);
 323    end Empty_File;
 324
 325    -------------------
 326    -- Empty_Project --
 327    -------------------
 328
 329    function Empty_Project (Tree : Project_Tree_Ref) return Project_Data is
 330       Value : Project_Data;
 331
 332    begin
 333       Prj.Initialize (Tree => No_Project_Tree);
 334       Value := Project_Empty;
 335       Value.Naming := Tree.Private_Part.Default_Naming;
 336
 337       return Value;
 338    end Empty_Project;
 339
 340    ------------------
 341    -- Empty_String --
 342    ------------------
 343
 344    function Empty_String return Name_Id is
 345    begin
 346       return The_Empty_String;
 347    end Empty_String;
 348
 349    ------------
 350    -- Expect --
 351    ------------
 352
 353    procedure Expect (The_Token : Token_Type; Token_Image : String) is
 354    begin
 355       if Token /= The_Token then
 356          Error_Msg (Token_Image & " expected", Token_Ptr);
 357       end if;
 358    end Expect;
 359
 360    -----------------
 361    -- Extend_Name --
 362    -----------------
 363
 364    function Extend_Name
 365      (File        : File_Name_Type;
 366       With_Suffix : String) return File_Name_Type
 367    is
 368       Last : Positive;
 369
 370    begin
 371       Get_Name_String (File);
 372       Last := Name_Len + 1;
 373
 374       while Name_Len /= 0 and then Name_Buffer (Name_Len) /= '.' loop
 375          Name_Len := Name_Len - 1;
 376       end loop;
 377
 378       if Name_Len <= 1 then
 379          Name_Len := Last;
 380       end if;
 381
 382       for J in With_Suffix'Range loop
 383          Name_Buffer (Name_Len) := With_Suffix (J);
 384          Name_Len := Name_Len + 1;
 385       end loop;
 386
 387       Name_Len := Name_Len - 1;
 388       return Name_Find;
 389
 390    end Extend_Name;
 391
 392    ---------------------
 393    -- Project_Changed --
 394    ---------------------
 395
 396    procedure Project_Changed (Iter : in out Source_Iterator) is
 397    begin
 398       Iter.Language := Iter.Project.Project.Languages;
 399       Language_Changed (Iter);
 400    end Project_Changed;
 401
 402    ----------------------
 403    -- Language_Changed --
 404    ----------------------
 405
 406    procedure Language_Changed (Iter : in out Source_Iterator) is
 407    begin
 408       Iter.Current  := No_Source;
 409
 410       if Iter.Language_Name /= No_Name then
 411          while Iter.Language /= null
 412            and then Iter.Language.Name /= Iter.Language_Name
 413          loop
 414             Iter.Language := Iter.Language.Next;
 415          end loop;
 416       end if;
 417
 418       --  If there is no matching language in this project, move to next
 419
 420       if Iter.Language = No_Language_Index then
 421          if Iter.All_Projects then
 422             Iter.Project := Iter.Project.Next;
 423
 424             if Iter.Project /= null then
 425                Project_Changed (Iter);
 426             end if;
 427
 428          else
 429             Iter.Project := null;
 430          end if;
 431
 432       else
 433          Iter.Current := Iter.Language.First_Source;
 434
 435          if Iter.Current = No_Source then
 436             Iter.Language := Iter.Language.Next;
 437             Language_Changed (Iter);
 438          end if;
 439       end if;
 440    end Language_Changed;
 441
 442    ---------------------
 443    -- For_Each_Source --
 444    ---------------------
 445
 446    function For_Each_Source
 447      (In_Tree  : Project_Tree_Ref;
 448       Project  : Project_Id := No_Project;
 449       Language : Name_Id := No_Name) return Source_Iterator
 450    is
 451       Iter : Source_Iterator;
 452    begin
 453       Iter := Source_Iterator'
 454         (In_Tree       => In_Tree,
 455          Project       => In_Tree.Projects,
 456          All_Projects  => Project = No_Project,
 457          Language_Name => Language,
 458          Language      => No_Language_Index,
 459          Current       => No_Source);
 460
 461       if Project /= null then
 462          while Iter.Project /= null
 463            and then Iter.Project.Project /= Project
 464          loop
 465             Iter.Project := Iter.Project.Next;
 466          end loop;
 467       end if;
 468
 469       Project_Changed (Iter);
 470
 471       return Iter;
 472    end For_Each_Source;
 473
 474    -------------
 475    -- Element --
 476    -------------
 477
 478    function Element (Iter : Source_Iterator) return Source_Id is
 479    begin
 480       return Iter.Current;
 481    end Element;
 482
 483    ----------
 484    -- Next --
 485    ----------
 486
 487    procedure Next (Iter : in out Source_Iterator) is
 488    begin
 489       Iter.Current := Iter.Current.Next_In_Lang;
 490       if Iter.Current = No_Source then
 491          Iter.Language := Iter.Language.Next;
 492          Language_Changed (Iter);
 493       end if;
 494    end Next;
 495
 496    --------------------------------
 497    -- For_Every_Project_Imported --
 498    --------------------------------
 499
 500    procedure For_Every_Project_Imported
 501      (By             : Project_Id;
 502       With_State     : in out State;
 503       Imported_First : Boolean := False)
 504    is
 505       use Project_Boolean_Htable;
 506       Seen : Project_Boolean_Htable.Instance := Project_Boolean_Htable.Nil;
 507
 508       procedure Recursive_Check (Project : Project_Id);
 509       --  Check if a project has already been seen. If not seen, mark it as
 510       --  Seen, Call Action, and check all its imported projects.
 511
 512       ---------------------
 513       -- Recursive_Check --
 514       ---------------------
 515
 516       procedure Recursive_Check (Project : Project_Id) is
 517          List : Project_List;
 518
 519       begin
 520          if not Get (Seen, Project) then
 521             Set (Seen, Project, True);
 522
 523             if not Imported_First then
 524                Action (Project, With_State);
 525             end if;
 526
 527             --  Visited all extended projects
 528
 529             if Project.Extends /= No_Project then
 530                Recursive_Check (Project.Extends);
 531             end if;
 532
 533             --  Visited all imported projects
 534
 535             List := Project.Imported_Projects;
 536             while List /= null loop
 537                Recursive_Check (List.Project);
 538                List := List.Next;
 539             end loop;
 540
 541             if Imported_First then
 542                Action (Project, With_State);
 543             end if;
 544          end if;
 545       end Recursive_Check;
 546
 547    --  Start of processing for For_Every_Project_Imported
 548
 549    begin
 550       Recursive_Check (Project => By);
 551       Reset (Seen);
 552    end For_Every_Project_Imported;
 553
 554    --------------
 555    -- Get_Mode --
 556    --------------
 557
 558    function Get_Mode return Mode is
 559    begin
 560       return Current_Mode;
 561    end Get_Mode;
 562
 563    ----------
 564    -- Hash --
 565    ----------
 566
 567    function Hash is new System.HTable.Hash (Header_Num => Header_Num);
 568    --  Used in implementation of other functions Hash below
 569
 570    function Hash (Name : File_Name_Type) return Header_Num is
 571    begin
 572       return Hash (Get_Name_String (Name));
 573    end Hash;
 574
 575    function Hash (Name : Name_Id) return Header_Num is
 576    begin
 577       return Hash (Get_Name_String (Name));
 578    end Hash;
 579
 580    function Hash (Name : Path_Name_Type) return Header_Num is
 581    begin
 582       return Hash (Get_Name_String (Name));
 583    end Hash;
 584
 585    function Hash (Project : Project_Id) return Header_Num is
 586    begin
 587       if Project = No_Project then
 588          return Header_Num'First;
 589       else
 590          return Hash (Get_Name_String (Project.Name));
 591       end if;
 592    end Hash;
 593
 594    -----------
 595    -- Image --
 596    -----------
 597
 598    function Image (Casing : Casing_Type) return String is
 599    begin
 600       return The_Casing_Images (Casing).all;
 601    end Image;
 602
 603    ----------------------
 604    -- In_Configuration --
 605    ----------------------
 606
 607    function In_Configuration return Boolean is
 608    begin
 609       return Configuration_Mode;
 610    end In_Configuration;
 611
 612    ----------------
 613    -- Initialize --
 614    ----------------
 615
 616    procedure Initialize (Tree : Project_Tree_Ref) is
 617    begin
 618       if not Initialized then
 619          Initialized := True;
 620          Uintp.Initialize;
 621          Name_Len := 0;
 622          The_Empty_String := Name_Find;
 623          Empty_Name := The_Empty_String;
 624          Empty_File_Name := File_Name_Type (The_Empty_String);
 625          Name_Len := 4;
 626          Name_Buffer (1 .. 4) := ".ads";
 627          Default_Ada_Spec_Suffix_Id := Name_Find;
 628          Name_Len := 4;
 629          Name_Buffer (1 .. 4) := ".adb";
 630          Default_Ada_Body_Suffix_Id := Name_Find;
 631          Name_Len := 1;
 632          Name_Buffer (1) := '/';
 633          Slash_Id := Name_Find;
 634
 635          Prj.Attr.Initialize;
 636          Set_Name_Table_Byte (Name_Project,  Token_Type'Pos (Tok_Project));
 637          Set_Name_Table_Byte (Name_Extends,  Token_Type'Pos (Tok_Extends));
 638          Set_Name_Table_Byte (Name_External, Token_Type'Pos (Tok_External));
 639       end if;
 640
 641       if Tree /= No_Project_Tree then
 642          Reset (Tree);
 643       end if;
 644    end Initialize;
 645
 646    -------------------
 647    -- Is_A_Language --
 648    -------------------
 649
 650    function Is_A_Language
 651      (Project       : Project_Id;
 652       Language_Name : Name_Id) return Boolean
 653    is
 654       Lang_Ind : Language_Ptr;
 655
 656    begin
 657       Lang_Ind := Project.Languages;
 658       while Lang_Ind /= No_Language_Index loop
 659          if Lang_Ind.Name = Language_Name then
 660             return True;
 661          end if;
 662
 663          Lang_Ind := Lang_Ind.Next;
 664       end loop;
 665
 666       return False;
 667    end Is_A_Language;
 668
 669    ------------------
 670    -- Is_Extending --
 671    ------------------
 672
 673    function Is_Extending
 674      (Extending : Project_Id;
 675       Extended  : Project_Id) return Boolean
 676    is
 677       Proj : Project_Id;
 678
 679    begin
 680       Proj := Extending;
 681       while Proj /= No_Project loop
 682          if Proj = Extended then
 683             return True;
 684          end if;
 685
 686          Proj := Proj.Extends;
 687       end loop;
 688
 689       return False;
 690    end Is_Extending;
 691
 692    -----------------
 693    -- Object_Name --
 694    -----------------
 695
 696    function Object_Name
 697      (Source_File_Name   : File_Name_Type;
 698       Object_File_Suffix : Name_Id := No_Name) return File_Name_Type
 699    is
 700    begin
 701       if Object_File_Suffix = No_Name then
 702          return Extend_Name
 703            (Source_File_Name, Object_Suffix);
 704       else
 705          return Extend_Name
 706            (Source_File_Name, Get_Name_String (Object_File_Suffix));
 707       end if;
 708    end Object_Name;
 709
 710    ----------------------
 711    -- Record_Temp_File --
 712    ----------------------
 713
 714    procedure Record_Temp_File (Path : Path_Name_Type) is
 715    begin
 716       Temp_Files.Increment_Last;
 717       Temp_Files.Table (Temp_Files.Last) := Path;
 718    end Record_Temp_File;
 719
 720    ------------------------------------
 721    -- Register_Default_Naming_Scheme --
 722    ------------------------------------
 723
 724    procedure Register_Default_Naming_Scheme
 725      (Language            : Name_Id;
 726       Default_Spec_Suffix : File_Name_Type;
 727       Default_Body_Suffix : File_Name_Type;
 728       In_Tree             : Project_Tree_Ref)
 729    is
 730       Lang    : Name_Id;
 731       Suffix  : Array_Element_Id;
 732       Found   : Boolean := False;
 733       Element : Array_Element;
 734
 735    begin
 736       --  Get the language name in small letters
 737
 738       Get_Name_String (Language);
 739       Name_Buffer (1 .. Name_Len) := To_Lower (Name_Buffer (1 .. Name_Len));
 740       Lang := Name_Find;
 741
 742       --  Look for an element of the spec suffix array indexed by the language
 743       --  name. If one is found, put the default value.
 744
 745       Suffix := In_Tree.Private_Part.Default_Naming.Spec_Suffix;
 746       Found := False;
 747       while Suffix /= No_Array_Element and then not Found loop
 748          Element := In_Tree.Array_Elements.Table (Suffix);
 749
 750          if Element.Index = Lang then
 751             Found := True;
 752             Element.Value.Value := Name_Id (Default_Spec_Suffix);
 753             In_Tree.Array_Elements.Table (Suffix) := Element;
 754
 755          else
 756             Suffix := Element.Next;
 757          end if;
 758       end loop;
 759
 760       --  If none can be found, create a new one
 761
 762       if not Found then
 763          Element :=
 764            (Index     => Lang,
 765             Src_Index => 0,
 766             Index_Case_Sensitive => False,
 767             Value => (Project  => No_Project,
 768                       Kind     => Single,
 769                       Location => No_Location,
 770                       Default  => False,
 771                       Value    => Name_Id (Default_Spec_Suffix),
 772                       Index    => 0),
 773             Next  => In_Tree.Private_Part.Default_Naming.Spec_Suffix);
 774          Array_Element_Table.Increment_Last (In_Tree.Array_Elements);
 775          In_Tree.Array_Elements.Table
 776            (Array_Element_Table.Last (In_Tree.Array_Elements)) :=
 777             Element;
 778          In_Tree.Private_Part.Default_Naming.Spec_Suffix :=
 779            Array_Element_Table.Last (In_Tree.Array_Elements);
 780       end if;
 781
 782       --  Look for an element of the body suffix array indexed by the language
 783       --  name. If one is found, put the default value.
 784
 785       Suffix := In_Tree.Private_Part.Default_Naming.Body_Suffix;
 786       Found := False;
 787       while Suffix /= No_Array_Element and then not Found loop
 788          Element := In_Tree.Array_Elements.Table (Suffix);
 789
 790          if Element.Index = Lang then
 791             Found := True;
 792             Element.Value.Value := Name_Id (Default_Body_Suffix);
 793             In_Tree.Array_Elements.Table (Suffix) := Element;
 794
 795          else
 796             Suffix := Element.Next;
 797          end if;
 798       end loop;
 799
 800       --  If none can be found, create a new one
 801
 802       if not Found then
 803          Element :=
 804            (Index     => Lang,
 805             Src_Index => 0,
 806             Index_Case_Sensitive => False,
 807             Value => (Project  => No_Project,
 808                       Kind     => Single,
 809                       Location => No_Location,
 810                       Default  => False,
 811                       Value    => Name_Id (Default_Body_Suffix),
 812                       Index    => 0),
 813             Next  => In_Tree.Private_Part.Default_Naming.Body_Suffix);
 814          Array_Element_Table.Increment_Last
 815            (In_Tree.Array_Elements);
 816          In_Tree.Array_Elements.Table
 817            (Array_Element_Table.Last (In_Tree.Array_Elements))
 818              := Element;
 819          In_Tree.Private_Part.Default_Naming.Body_Suffix :=
 820            Array_Element_Table.Last (In_Tree.Array_Elements);
 821       end if;
 822    end Register_Default_Naming_Scheme;
 823
 824    ----------
 825    -- Free --
 826    ----------
 827
 828    procedure Free (Project : in out Project_Id; Reset_Only : Boolean) is
 829       procedure Unchecked_Free is new Ada.Unchecked_Deallocation
 830         (Project_Data, Project_Id);
 831
 832    begin
 833       if Project /= null then
 834          Free (Project.Include_Path);
 835          Free (Project.Ada_Include_Path);
 836          Free (Project.Objects_Path);
 837          Free (Project.Ada_Objects_Path);
 838
 839          Free_List (Project.Imported_Projects, Free_Project => False);
 840          Free_List (Project.All_Imported_Projects, Free_Project => False);
 841
 842          if not Reset_Only then
 843             Free_List (Project.Languages);
 844          end if;
 845
 846          Unchecked_Free (Project);
 847       end if;
 848    end Free;
 849
 850    ---------------
 851    -- Free_List --
 852    ---------------
 853
 854    procedure Free_List (Languages : in out Language_List) is
 855       procedure Unchecked_Free is new Ada.Unchecked_Deallocation
 856         (Language_List_Element, Language_List);
 857       Tmp : Language_List;
 858    begin
 859       while Languages /= null loop
 860          Tmp := Languages.Next;
 861          Unchecked_Free (Languages);
 862          Languages := Tmp;
 863       end loop;
 864    end Free_List;
 865
 866    ---------------
 867    -- Free_List --
 868    ---------------
 869
 870    procedure Free_List (Source : in out Source_Id) is
 871       procedure Unchecked_Free is new Ada.Unchecked_Deallocation
 872         (Source_Data, Source_Id);
 873       Tmp : Source_Id;
 874    begin
 875       while Source /= No_Source loop
 876          Tmp := Source.Next_In_Lang;
 877          Free_List (Source.Alternate_Languages);
 878          Unchecked_Free (Source);
 879          Source := Tmp;
 880       end loop;
 881    end Free_List;
 882
 883    ---------------
 884    -- Free_List --
 885    ---------------
 886
 887    procedure Free_List
 888      (List         : in out Project_List;
 889       Free_Project : Boolean;
 890       Reset_Only   : Boolean := True)
 891    is
 892       procedure Unchecked_Free is new Ada.Unchecked_Deallocation
 893         (Project_List_Element, Project_List);
 894       Tmp : Project_List;
 895
 896    begin
 897       while List /= null loop
 898          Tmp := List.Next;
 899
 900          if Free_Project then
 901             Free (List.Project, Reset_Only => Reset_Only);
 902          end if;
 903
 904          Unchecked_Free (List);
 905          List := Tmp;
 906       end loop;
 907    end Free_List;
 908
 909    ---------------
 910    -- Free_List --
 911    ---------------
 912
 913    procedure Free_List (Languages : in out Language_Ptr) is
 914       procedure Unchecked_Free is new Ada.Unchecked_Deallocation
 915         (Language_Data, Language_Ptr);
 916       Tmp : Language_Ptr;
 917    begin
 918       while Languages /= null loop
 919          Tmp := Languages.Next;
 920          Free_List (Languages.First_Source);
 921          Unchecked_Free (Languages);
 922          Languages := Tmp;
 923       end loop;
 924    end Free_List;
 925
 926    ----------
 927    -- Free --
 928    ----------
 929
 930    procedure Free (Tree : in out Project_Tree_Ref) is
 931       procedure Unchecked_Free is new Ada.Unchecked_Deallocation
 932         (Project_Tree_Data, Project_Tree_Ref);
 933
 934    begin
 935       if Tree /= null then
 936          Name_List_Table.Free (Tree.Name_Lists);
 937          String_Element_Table.Free (Tree.String_Elements);
 938          Variable_Element_Table.Free (Tree.Variable_Elements);
 939          Array_Element_Table.Free (Tree.Array_Elements);
 940          Array_Table.Free (Tree.Arrays);
 941          Package_Table.Free (Tree.Packages);
 942          Unit_Table.Free (Tree.Units);
 943          Units_Htable.Reset (Tree.Units_HT);
 944          Source_Paths_Htable.Reset (Tree.Source_Paths_HT);
 945          Unit_Sources_Htable.Reset (Tree.Unit_Sources_HT);
 946
 947          Free_List (Tree.Projects, Free_Project => True, Reset_Only => False);
 948
 949          --  Private part
 950
 951          Naming_Table.Free (Tree.Private_Part.Namings);
 952          Path_File_Table.Free (Tree.Private_Part.Path_Files);
 953          Source_Path_Table.Free (Tree.Private_Part.Source_Paths);
 954          Object_Path_Table.Free (Tree.Private_Part.Object_Paths);
 955
 956          Free (Tree.Private_Part.Ada_Path_Buffer);
 957
 958          --  Naming data (nothing to free ?)
 959          null;
 960
 961          Unchecked_Free (Tree);
 962       end if;
 963    end Free;
 964
 965    -----------
 966    -- Reset --
 967    -----------
 968
 969    procedure Reset (Tree : Project_Tree_Ref) is
 970    begin
 971       --  Visible tables
 972
 973       Name_List_Table.Init          (Tree.Name_Lists);
 974       String_Element_Table.Init     (Tree.String_Elements);
 975       Variable_Element_Table.Init   (Tree.Variable_Elements);
 976       Array_Element_Table.Init      (Tree.Array_Elements);
 977       Array_Table.Init              (Tree.Arrays);
 978       Package_Table.Init            (Tree.Packages);
 979       Unit_Table.Init               (Tree.Units);
 980       Units_Htable.Reset            (Tree.Units_HT);
 981       Source_Paths_Htable.Reset     (Tree.Source_Paths_HT);
 982       Unit_Sources_Htable.Reset     (Tree.Unit_Sources_HT);
 983
 984       Free_List (Tree.Projects, Free_Project => True, Reset_Only => True);
 985
 986       --  Private part table
 987
 988       Naming_Table.Init             (Tree.Private_Part.Namings);
 989       Naming_Table.Increment_Last   (Tree.Private_Part.Namings);
 990       Tree.Private_Part.Namings.Table
 991         (Naming_Table.Last (Tree.Private_Part.Namings)) := Std_Naming_Data;
 992       Path_File_Table.Init        (Tree.Private_Part.Path_Files);
 993       Source_Path_Table.Init      (Tree.Private_Part.Source_Paths);
 994       Object_Path_Table.Init      (Tree.Private_Part.Object_Paths);
 995       Tree.Private_Part.Default_Naming := Std_Naming_Data;
 996
 997       if Current_Mode = Ada_Only then
 998          Register_Default_Naming_Scheme
 999            (Language            => Name_Ada,
1000             Default_Spec_Suffix => Default_Ada_Spec_Suffix,
1001             Default_Body_Suffix => Default_Ada_Body_Suffix,
1002             In_Tree             => Tree);
1003          Tree.Private_Part.Default_Naming.Separate_Suffix :=
1004            Default_Ada_Body_Suffix;
1005
1006          Tree.Private_Part.Current_Source_Path_File := No_Path;
1007          Tree.Private_Part.Current_Object_Path_File := No_Path;
1008          Tree.Private_Part.Ada_Path_Length := 0;
1009          Tree.Private_Part.Ada_Prj_Include_File_Set := False;
1010          Tree.Private_Part.Ada_Prj_Objects_File_Set := False;
1011          Tree.Private_Part.Fill_Mapping_File := True;
1012       end if;
1013    end Reset;
1014
1015    ------------------------
1016    -- Same_Naming_Scheme --
1017    ------------------------
1018
1019    function Same_Naming_Scheme
1020      (Left, Right : Naming_Data) return Boolean
1021    is
1022    begin
1023       return Left.Dot_Replacement = Right.Dot_Replacement
1024         and then Left.Casing = Right.Casing
1025         and then Left.Separate_Suffix = Right.Separate_Suffix;
1026    end Same_Naming_Scheme;
1027
1028    ---------------------
1029    -- Set_Body_Suffix --
1030    ---------------------
1031
1032    procedure Set_Body_Suffix
1033      (In_Tree  : Project_Tree_Ref;
1034       Language : String;
1035       Naming   : in out Naming_Data;
1036       Suffix   : File_Name_Type)
1037    is
1038       Language_Id : Name_Id;
1039       Element     : Array_Element;
1040
1041    begin
1042       Name_Len := 0;
1043       Add_Str_To_Name_Buffer (Language);
1044       To_Lower (Name_Buffer (1 .. Name_Len));
1045       Language_Id := Name_Find;
1046
1047       Element :=
1048         (Index                => Language_Id,
1049          Src_Index            => 0,
1050          Index_Case_Sensitive => False,
1051          Value                =>
1052            (Kind     => Single,
1053             Project  => No_Project,
1054             Location => No_Location,
1055             Default  => False,
1056             Value    => Name_Id (Suffix),
1057             Index    => 0),
1058          Next                 => Naming.Body_Suffix);
1059
1060       Array_Element_Table.Increment_Last (In_Tree.Array_Elements);
1061       Naming.Body_Suffix :=
1062          Array_Element_Table.Last (In_Tree.Array_Elements);
1063       In_Tree.Array_Elements.Table (Naming.Body_Suffix) := Element;
1064    end Set_Body_Suffix;
1065
1066    --------------------------
1067    -- Set_In_Configuration --
1068    --------------------------
1069
1070    procedure Set_In_Configuration (Value : Boolean) is
1071    begin
1072       Configuration_Mode := Value;
1073    end Set_In_Configuration;
1074
1075    --------------
1076    -- Set_Mode --
1077    --------------
1078
1079    procedure Set_Mode (New_Mode : Mode) is
1080    begin
1081       Current_Mode := New_Mode;
1082       case New_Mode is
1083          when Ada_Only =>
1084             Default_Language_Is_Ada := True;
1085             Must_Check_Configuration := False;
1086          when Multi_Language =>
1087             Default_Language_Is_Ada := False;
1088             Must_Check_Configuration := True;
1089       end case;
1090    end Set_Mode;
1091
1092    ---------------------
1093    -- Set_Spec_Suffix --
1094    ---------------------
1095
1096    procedure Set_Spec_Suffix
1097      (In_Tree  : Project_Tree_Ref;
1098       Language : String;
1099       Naming   : in out Naming_Data;
1100       Suffix   : File_Name_Type)
1101    is
1102       Language_Id : Name_Id;
1103       Element     : Array_Element;
1104
1105    begin
1106       Name_Len := 0;
1107       Add_Str_To_Name_Buffer (Language);
1108       To_Lower (Name_Buffer (1 .. Name_Len));
1109       Language_Id := Name_Find;
1110
1111       Element :=
1112         (Index                => Language_Id,
1113          Src_Index            => 0,
1114          Index_Case_Sensitive => False,
1115          Value                =>
1116            (Kind     => Single,
1117             Project  => No_Project,
1118             Location => No_Location,
1119             Default  => False,
1120             Value    => Name_Id (Suffix),
1121             Index    => 0),
1122          Next                 => Naming.Spec_Suffix);
1123
1124       Array_Element_Table.Increment_Last (In_Tree.Array_Elements);
1125       Naming.Spec_Suffix :=
1126         Array_Element_Table.Last (In_Tree.Array_Elements);
1127       In_Tree.Array_Elements.Table (Naming.Spec_Suffix) := Element;
1128    end Set_Spec_Suffix;
1129
1130    -----------
1131    -- Slash --
1132    -----------
1133
1134    function Slash return Path_Name_Type is
1135    begin
1136       return Slash_Id;
1137    end Slash;
1138
1139    -----------------------
1140    -- Spec_Suffix_Id_Of --
1141    -----------------------
1142
1143    function Spec_Suffix_Id_Of
1144      (In_Tree     : Project_Tree_Ref;
1145       Language_Id : Name_Id;
1146       Naming      : Naming_Data) return File_Name_Type
1147    is
1148       Element_Id : Array_Element_Id;
1149       Element    : Array_Element;
1150
1151    begin
1152       Element_Id := Naming.Spec_Suffix;
1153       while Element_Id /= No_Array_Element loop
1154          Element := In_Tree.Array_Elements.Table (Element_Id);
1155
1156          if Element.Index = Language_Id then
1157             return File_Name_Type (Element.Value.Value);
1158          end if;
1159
1160          Element_Id := Element.Next;
1161       end loop;
1162
1163       return No_File;
1164    end Spec_Suffix_Id_Of;
1165
1166    --------------------
1167    -- Spec_Suffix_Of --
1168    --------------------
1169
1170    function Spec_Suffix_Of
1171      (In_Tree  : Project_Tree_Ref;
1172       Language : String;
1173       Naming   : Naming_Data) return String
1174    is
1175       Language_Id : Name_Id;
1176       Element_Id  : Array_Element_Id;
1177       Element     : Array_Element;
1178
1179    begin
1180       Name_Len := 0;
1181       Add_Str_To_Name_Buffer (Language);
1182       To_Lower (Name_Buffer (1 .. Name_Len));
1183       Language_Id := Name_Find;
1184
1185       Element_Id := Naming.Spec_Suffix;
1186       while Element_Id /= No_Array_Element loop
1187          Element := In_Tree.Array_Elements.Table (Element_Id);
1188
1189          if Element.Index = Language_Id then
1190             return Get_Name_String (Element.Value.Value);
1191          end if;
1192
1193          Element_Id := Element.Next;
1194       end loop;
1195
1196       return "";
1197    end Spec_Suffix_Of;
1198
1199    --------------------------
1200    -- Standard_Naming_Data --
1201    --------------------------
1202
1203    function Standard_Naming_Data
1204      (Tree : Project_Tree_Ref := No_Project_Tree) return Naming_Data
1205    is
1206    begin
1207       if Tree = No_Project_Tree then
1208          Prj.Initialize (Tree => No_Project_Tree);
1209          return Std_Naming_Data;
1210       else
1211          return Tree.Private_Part.Default_Naming;
1212       end if;
1213    end Standard_Naming_Data;
1214
1215    -------------------
1216    -- Switches_Name --
1217    -------------------
1218
1219    function Switches_Name
1220      (Source_File_Name : File_Name_Type) return File_Name_Type
1221    is
1222    begin
1223       return Extend_Name (Source_File_Name, Switches_Dependency_Suffix);
1224    end Switches_Name;
1225
1226    -----------
1227    -- Value --
1228    -----------
1229
1230    function Value (Image : String) return Casing_Type is
1231    begin
1232       for Casing in The_Casing_Images'Range loop
1233          if To_Lower (Image) = To_Lower (The_Casing_Images (Casing).all) then
1234             return Casing;
1235          end if;
1236       end loop;
1237
1238       raise Constraint_Error;
1239    end Value;
1240
1241    ---------------------
1242    -- Has_Ada_Sources --
1243    ---------------------
1244
1245    function Has_Ada_Sources (Data : Project_Id) return Boolean is
1246       Lang : Language_Ptr;
1247
1248    begin
1249       Lang := Data.Languages;
1250       while Lang /= No_Language_Index loop
1251          if Lang.Name = Name_Ada then
1252             return Lang.First_Source /= No_Source;
1253          end if;
1254          Lang := Lang.Next;
1255       end loop;
1256
1257       return False;
1258    end Has_Ada_Sources;
1259
1260    -------------------------
1261    -- Has_Foreign_Sources --
1262    -------------------------
1263
1264    function Has_Foreign_Sources (Data : Project_Id) return Boolean is
1265       Lang : Language_Ptr;
1266
1267    begin
1268       Lang := Data.Languages;
1269       while Lang /= No_Language_Index loop
1270          if Lang.Name /= Name_Ada
1271            and then
1272              (Current_Mode = Ada_Only or else Lang.First_Source /= No_Source)
1273          then
1274             return True;
1275          end if;
1276
1277          Lang := Lang.Next;
1278       end loop;
1279
1280       return False;
1281    end Has_Foreign_Sources;
1282
1283    ------------------------
1284    -- Contains_ALI_Files --
1285    ------------------------
1286
1287    function Contains_ALI_Files (Dir : Path_Name_Type) return Boolean is
1288       Dir_Name : constant String := Get_Name_String (Dir);
1289       Direct   : Dir_Type;
1290       Name     : String (1 .. 1_000);
1291       Last     : Natural;
1292       Result   : Boolean := False;
1293
1294    begin
1295       Open (Direct, Dir_Name);
1296
1297       --  For each file in the directory, check if it is an ALI file
1298
1299       loop
1300          Read (Direct, Name, Last);
1301          exit when Last = 0;
1302          Canonical_Case_File_Name (Name (1 .. Last));
1303          Result := Last >= 5 and then Name (Last - 3 .. Last) = ".ali";
1304          exit when Result;
1305       end loop;
1306
1307       Close (Direct);
1308       return Result;
1309
1310    exception
1311       --  If there is any problem, close the directory if open and return True.
1312       --  The library directory will be added to the path.
1313
1314       when others =>
1315          if Is_Open (Direct) then
1316             Close (Direct);
1317          end if;
1318
1319          return True;
1320    end Contains_ALI_Files;
1321
1322    --------------------------
1323    -- Get_Object_Directory --
1324    --------------------------
1325
1326    function Get_Object_Directory
1327      (Project             : Project_Id;
1328       Including_Libraries : Boolean;
1329       Only_If_Ada         : Boolean := False) return Path_Name_Type
1330    is
1331    begin
1332       if (Project.Library and Including_Libraries)
1333         or else
1334           (Project.Object_Directory /= No_Path_Information
1335             and then (not Including_Libraries or else not Project.Library))
1336       then
1337          --  For a library project, add the library ALI directory if there is
1338          --  no object directory or if the library ALI directory contains ALI
1339          --  files; otherwise add the object directory.
1340
1341          if Project.Library then
1342             if Project.Object_Directory = No_Path_Information
1343               or else Contains_ALI_Files (Project.Library_ALI_Dir.Name)
1344             then
1345                return Project.Library_ALI_Dir.Name;
1346             else
1347                return Project.Object_Directory.Name;
1348             end if;
1349
1350             --  For a non-library project, add object directory if it is not a
1351             --  virtual project, and if there are Ada sources in the project or
1352             --  one of the projects it extends. If there are no Ada sources,
1353             --  adding the object directory could disrupt the order of the
1354             --  object dirs in the path.
1355
1356          elsif not Project.Virtual then
1357             declare
1358                Add_Object_Dir : Boolean;
1359                Prj            : Project_Id;
1360
1361             begin
1362                Add_Object_Dir := not Only_If_Ada;
1363                Prj := Project;
1364                while not Add_Object_Dir and then Prj /= No_Project loop
1365                   if Has_Ada_Sources (Prj) then
1366                      Add_Object_Dir := True;
1367                   else
1368                      Prj := Prj.Extends;
1369                   end if;
1370                end loop;
1371
1372                if Add_Object_Dir then
1373                   return Project.Object_Directory.Name;
1374                end if;
1375             end;
1376          end if;
1377       end if;
1378
1379       return No_Path;
1380    end Get_Object_Directory;
1381
1382    -----------------------------------
1383    -- Ultimate_Extending_Project_Of --
1384    -----------------------------------
1385
1386    function Ultimate_Extending_Project_Of
1387      (Proj : Project_Id) return Project_Id
1388    is
1389       Prj : Project_Id;
1390
1391    begin
1392       Prj := Proj;
1393       while Prj /= null and then Prj.Extended_By /= No_Project loop
1394          Prj := Prj.Extended_By;
1395       end loop;
1396
1397       return Prj;
1398    end Ultimate_Extending_Project_Of;
1399
1400    -----------------------------------
1401    -- Compute_All_Imported_Projects --
1402    -----------------------------------
1403
1404    procedure Compute_All_Imported_Projects (Project : Project_Id) is
1405       procedure Recursive_Add (Prj : Project_Id; Dummy : in out Boolean);
1406       --  Recursively add the projects imported by project Project, but not
1407       --  those that are extended.
1408
1409       -------------------
1410       -- Recursive_Add --
1411       -------------------
1412
1413       procedure Recursive_Add (Prj : Project_Id; Dummy : in out Boolean) is
1414          pragma Unreferenced (Dummy);
1415          List    : Project_List;
1416          Prj2    : Project_Id;
1417
1418       begin
1419          --  A project is not importing itself
1420
1421          if Project /= Prj then
1422             Prj2 := Ultimate_Extending_Project_Of (Prj);
1423
1424             --  Check that the project is not already in the list. We know the
1425             --  one passed to Recursive_Add have never been visited before, but
1426             --  the one passed it are the extended projects.
1427
1428             List := Project.All_Imported_Projects;
1429             while List /= null loop
1430                if List.Project = Prj2 then
1431                   return;
1432                end if;
1433                List := List.Next;
1434             end loop;
1435
1436             --  Add it to the list
1437
1438             Project.All_Imported_Projects :=
1439               new Project_List_Element'
1440                 (Project => Prj2,
1441                  Next    => Project.All_Imported_Projects);
1442          end if;
1443       end Recursive_Add;
1444
1445       procedure For_All_Projects is
1446         new For_Every_Project_Imported (Boolean, Recursive_Add);
1447       Dummy : Boolean := False;
1448
1449    begin
1450       Free_List (Project.All_Imported_Projects, Free_Project => False);
1451       For_All_Projects (Project, Dummy);
1452    end Compute_All_Imported_Projects;
1453
1454 begin
1455    --  Make sure that the standard config and user project file extensions are
1456    --  compatible with canonical case file naming.
1457
1458    Canonical_Case_File_Name (Config_Project_File_Extension);
1459    Canonical_Case_File_Name (Project_File_Extension);
1460 end Prj;