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 Output;   use Output;
  31 with Osint;    use Osint;
  32 with Prj.Attr;
  33 with Prj.Env;
  34 with Prj.Err;  use Prj.Err;
  35 with Snames;   use Snames;
  36 with Table;
  37 with Uintp;    use Uintp;
  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                       Languages                      => No_Name_List,
  90                       Name                           => No_Name,
  91                       Display_Name                   => No_Name,
  92                       Path                           => No_Path_Information,
  93                       Virtual                        => False,
  94                       Location                       => No_Location,
  95                       Mains                          => Nil_String,
  96                       Directory                      => No_Path_Information,
  97                       Dir_Path                       => null,
  98                       Library                        => False,
  99                       Library_Dir                    => No_Path_Information,
 100                       Library_Src_Dir                => No_Path_Information,
 101                       Library_ALI_Dir                => No_Path_Information,
 102                       Library_Name                   => No_Name,
 103                       Library_Kind                   => Static,
 104                       Lib_Internal_Name              => No_Name,
 105                       Standalone_Library             => False,
 106                       Lib_Interface_ALIs             => Nil_String,
 107                       Lib_Auto_Init                  => False,
 108                       Libgnarl_Needed                => Unknown,
 109                       Symbol_Data                    => No_Symbols,
 110                       Ada_Sources_Present            => True,
 111                       Other_Sources_Present          => True,
 112                       Ada_Sources                    => Nil_String,
 113                       First_Source                   => No_Source,
 114                       Last_Source                    => No_Source,
 115                       Interfaces_Defined             => False,
 116                       Imported_Directories_Switches  => null,
 117                       Include_Path                   => null,
 118                       Include_Data_Set               => False,
 119                       Include_Language               => No_Language_Index,
 120                       Source_Dirs                    => Nil_String,
 121                       Known_Order_Of_Source_Dirs     => True,
 122                       Object_Directory               => No_Path_Information,
 123                       Library_TS                     => Empty_Time_Stamp,
 124                       Exec_Directory                 => No_Path_Information,
 125                       Extends                        => No_Project,
 126                       Extended_By                    => No_Project,
 127                       Naming                         => Std_Naming_Data,
 128                       First_Language_Processing      => No_Language_Index,
 129                       Decl                           => No_Declarations,
 130                       Imported_Projects              => Empty_Project_List,
 131                       All_Imported_Projects          => Empty_Project_List,
 132                       Ada_Include_Path               => null,
 133                       Ada_Objects_Path               => null,
 134                       Objects_Path                   => null,
 135                       Include_Path_File              => No_Path,
 136                       Objects_Path_File_With_Libs    => No_Path,
 137                       Objects_Path_File_Without_Libs => No_Path,
 138                       Config_File_Name               => No_Path,
 139                       Config_File_Temp               => False,
 140                       Config_Checked                 => False,
 141                       Checked                        => False,
 142                       Seen                           => False,
 143                       Need_To_Build_Lib              => False,
 144                       Depth                          => 0,
 145                       Unkept_Comments                => False);
 146
 147    package Temp_Files is new Table.Table
 148      (Table_Component_Type => Path_Name_Type,
 149       Table_Index_Type     => Integer,
 150       Table_Low_Bound      => 1,
 151       Table_Initial        => 20,
 152       Table_Increment      => 100,
 153       Table_Name           => "Makegpr.Temp_Files");
 154    --  Table to store the path name of all the created temporary files, so that
 155    --  they can be deleted at the end, or when the program is interrupted.
 156
 157    procedure Free (Project : in out Project_Data);
 158    --  Free memory allocated for Project
 159
 160    -------------------
 161    -- Add_To_Buffer --
 162    -------------------
 163
 164    procedure Add_To_Buffer
 165      (S    : String;
 166       To   : in out String_Access;
 167       Last : in out Natural)
 168    is
 169    begin
 170       if To = null then
 171          To := new String (1 .. Initial_Buffer_Size);
 172          Last := 0;
 173       end if;
 174
 175       --  If Buffer is too small, double its size
 176
 177       while Last + S'Length > To'Last loop
 178          declare
 179             New_Buffer : constant  String_Access :=
 180                            new String (1 .. 2 * Last);
 181
 182          begin
 183             New_Buffer (1 .. Last) := To (1 .. Last);
 184             Free (To);
 185             To := New_Buffer;
 186          end;
 187       end loop;
 188
 189       To (Last + 1 .. Last + S'Length) := S;
 190       Last := Last + S'Length;
 191    end Add_To_Buffer;
 192
 193    -----------------------
 194    -- Body_Suffix_Id_Of --
 195    -----------------------
 196
 197    function Body_Suffix_Id_Of
 198      (In_Tree  : Project_Tree_Ref;
 199       Language : String;
 200       Naming   : Naming_Data) return File_Name_Type
 201    is
 202       Language_Id : Name_Id;
 203
 204    begin
 205       Name_Len := 0;
 206       Add_Str_To_Name_Buffer (Language);
 207       To_Lower (Name_Buffer (1 .. Name_Len));
 208       Language_Id := Name_Find;
 209
 210       return
 211         Body_Suffix_Id_Of
 212           (In_Tree     => In_Tree,
 213            Language_Id => Language_Id,
 214            Naming      => Naming);
 215    end Body_Suffix_Id_Of;
 216
 217    -----------------------
 218    -- Body_Suffix_Id_Of --
 219    -----------------------
 220
 221    function Body_Suffix_Id_Of
 222      (In_Tree     : Project_Tree_Ref;
 223       Language_Id : Name_Id;
 224       Naming      : Naming_Data) return File_Name_Type
 225    is
 226       Element_Id : Array_Element_Id;
 227       Element    : Array_Element;
 228       Suffix     : File_Name_Type := No_File;
 229       Lang       : Language_Index;
 230
 231    begin
 232       --  ??? This seems to be only for Ada_Only mode...
 233       Element_Id := Naming.Body_Suffix;
 234       while Element_Id /= No_Array_Element loop
 235          Element := In_Tree.Array_Elements.Table (Element_Id);
 236
 237          if Element.Index = Language_Id then
 238             return File_Name_Type (Element.Value.Value);
 239          end if;
 240
 241          Element_Id := Element.Next;
 242       end loop;
 243
 244       if Current_Mode = Multi_Language then
 245          Lang := In_Tree.First_Language;
 246          while Lang /= No_Language_Index loop
 247             if In_Tree.Languages_Data.Table (Lang).Name = Language_Id then
 248                Suffix :=
 249                  In_Tree.Languages_Data.Table
 250                    (Lang).Config.Naming_Data.Body_Suffix;
 251                exit;
 252             end if;
 253
 254             Lang := In_Tree.Languages_Data.Table (Lang).Next;
 255          end loop;
 256       end if;
 257
 258       return Suffix;
 259    end Body_Suffix_Id_Of;
 260
 261    --------------------
 262    -- Body_Suffix_Of --
 263    --------------------
 264
 265    function Body_Suffix_Of
 266      (In_Tree  : Project_Tree_Ref;
 267       Language : String;
 268       Naming   : Naming_Data) return String
 269    is
 270       Language_Id : Name_Id;
 271       Element_Id  : Array_Element_Id;
 272       Element     : Array_Element;
 273       Suffix      : File_Name_Type := No_File;
 274       Lang        : Language_Index;
 275
 276    begin
 277       Name_Len := 0;
 278       Add_Str_To_Name_Buffer (Language);
 279       To_Lower (Name_Buffer (1 .. Name_Len));
 280       Language_Id := Name_Find;
 281
 282       Element_Id := Naming.Body_Suffix;
 283       while Element_Id /= No_Array_Element loop
 284          Element := In_Tree.Array_Elements.Table (Element_Id);
 285
 286          if Element.Index = Language_Id then
 287             return Get_Name_String (Element.Value.Value);
 288          end if;
 289
 290          Element_Id := Element.Next;
 291       end loop;
 292
 293       if Current_Mode = Multi_Language then
 294          Lang := In_Tree.First_Language;
 295          while Lang /= No_Language_Index loop
 296             if In_Tree.Languages_Data.Table (Lang).Name = Language_Id then
 297                Suffix :=
 298                  File_Name_Type
 299                    (In_Tree.Languages_Data.Table
 300                         (Lang).Config.Naming_Data.Body_Suffix);
 301                exit;
 302             end if;
 303
 304             Lang := In_Tree.Languages_Data.Table (Lang).Next;
 305          end loop;
 306
 307          if Suffix /= No_File then
 308             return Get_Name_String (Suffix);
 309          end if;
 310       end if;
 311
 312       return "";
 313    end Body_Suffix_Of;
 314
 315    -----------------------------
 316    -- Default_Ada_Body_Suffix --
 317    -----------------------------
 318
 319    function Default_Ada_Body_Suffix return File_Name_Type is
 320    begin
 321       return Default_Ada_Body_Suffix_Id;
 322    end Default_Ada_Body_Suffix;
 323
 324    -----------------------------
 325    -- Default_Ada_Spec_Suffix --
 326    -----------------------------
 327
 328    function Default_Ada_Spec_Suffix return File_Name_Type is
 329    begin
 330       return Default_Ada_Spec_Suffix_Id;
 331    end Default_Ada_Spec_Suffix;
 332
 333    ---------------------------
 334    -- Delete_All_Temp_Files --
 335    ---------------------------
 336
 337    procedure Delete_All_Temp_Files is
 338       Dont_Care : Boolean;
 339       pragma Warnings (Off, Dont_Care);
 340    begin
 341       if not Debug.Debug_Flag_N then
 342          for Index in 1 .. Temp_Files.Last loop
 343             Delete_File
 344               (Get_Name_String (Temp_Files.Table (Index)), Dont_Care);
 345          end loop;
 346       end if;
 347    end Delete_All_Temp_Files;
 348
 349    ---------------------
 350    -- Dependency_Name --
 351    ---------------------
 352
 353    function Dependency_Name
 354      (Source_File_Name : File_Name_Type;
 355       Dependency       : Dependency_File_Kind) return File_Name_Type
 356    is
 357    begin
 358       case Dependency is
 359          when None =>
 360             return No_File;
 361
 362          when Makefile =>
 363             return
 364               File_Name_Type
 365                 (Extend_Name
 366                    (Source_File_Name, Makefile_Dependency_Suffix));
 367
 368          when ALI_File =>
 369             return
 370               File_Name_Type
 371                 (Extend_Name
 372                    (Source_File_Name, ALI_Dependency_Suffix));
 373       end case;
 374    end Dependency_Name;
 375
 376    ---------------------------
 377    -- Display_Language_Name --
 378    ---------------------------
 379
 380    procedure Display_Language_Name
 381      (In_Tree  : Project_Tree_Ref;
 382       Language : Language_Index)
 383    is
 384    begin
 385       Get_Name_String (In_Tree.Languages_Data.Table (Language).Display_Name);
 386       Write_Str (Name_Buffer (1 .. Name_Len));
 387    end Display_Language_Name;
 388
 389    ----------------
 390    -- Empty_File --
 391    ----------------
 392
 393    function Empty_File return File_Name_Type is
 394    begin
 395       return File_Name_Type (The_Empty_String);
 396    end Empty_File;
 397
 398    -------------------
 399    -- Empty_Project --
 400    -------------------
 401
 402    function Empty_Project (Tree : Project_Tree_Ref) return Project_Data is
 403       Value : Project_Data;
 404
 405    begin
 406       Prj.Initialize (Tree => No_Project_Tree);
 407       Value := Project_Empty;
 408       Value.Naming := Tree.Private_Part.Default_Naming;
 409
 410       return Value;
 411    end Empty_Project;
 412
 413    ------------------
 414    -- Empty_String --
 415    ------------------
 416
 417    function Empty_String return Name_Id is
 418    begin
 419       return The_Empty_String;
 420    end Empty_String;
 421
 422    ------------
 423    -- Expect --
 424    ------------
 425
 426    procedure Expect (The_Token : Token_Type; Token_Image : String) is
 427    begin
 428       if Token /= The_Token then
 429          Error_Msg (Token_Image & " expected", Token_Ptr);
 430       end if;
 431    end Expect;
 432
 433    -----------------
 434    -- Extend_Name --
 435    -----------------
 436
 437    function Extend_Name
 438      (File        : File_Name_Type;
 439       With_Suffix : String) return File_Name_Type
 440    is
 441       Last : Positive;
 442
 443    begin
 444       Get_Name_String (File);
 445       Last := Name_Len + 1;
 446
 447       while Name_Len /= 0 and then Name_Buffer (Name_Len) /= '.' loop
 448          Name_Len := Name_Len - 1;
 449       end loop;
 450
 451       if Name_Len <= 1 then
 452          Name_Len := Last;
 453       end if;
 454
 455       for J in With_Suffix'Range loop
 456          Name_Buffer (Name_Len) := With_Suffix (J);
 457          Name_Len := Name_Len + 1;
 458       end loop;
 459
 460       Name_Len := Name_Len - 1;
 461       return Name_Find;
 462
 463    end Extend_Name;
 464
 465    --------------------------------
 466    -- For_Every_Project_Imported --
 467    --------------------------------
 468
 469    procedure For_Every_Project_Imported
 470      (By         : Project_Id;
 471       In_Tree    : Project_Tree_Ref;
 472       With_State : in out State)
 473    is
 474
 475       procedure Recursive_Check (Project : Project_Id);
 476       --  Check if a project has already been seen. If not seen, mark it as
 477       --  Seen, Call Action, and check all its imported projects.
 478
 479       ---------------------
 480       -- Recursive_Check --
 481       ---------------------
 482
 483       procedure Recursive_Check (Project : Project_Id) is
 484          List : Project_List;
 485       begin
 486          if not In_Tree.Projects.Table (Project).Seen then
 487             In_Tree.Projects.Table (Project).Seen := True;
 488             Action (Project, With_State);
 489
 490             List := In_Tree.Projects.Table (Project).Imported_Projects;
 491             while List /= Empty_Project_List loop
 492                Recursive_Check (In_Tree.Project_Lists.Table (List).Project);
 493                List := In_Tree.Project_Lists.Table (List).Next;
 494             end loop;
 495          end if;
 496       end Recursive_Check;
 497
 498    --  Start of processing for For_Every_Project_Imported
 499
 500    begin
 501       for Project in Project_Table.First ..
 502                      Project_Table.Last (In_Tree.Projects)
 503       loop
 504          In_Tree.Projects.Table (Project).Seen := False;
 505       end loop;
 506
 507       Recursive_Check (Project => By);
 508    end For_Every_Project_Imported;
 509
 510    --------------
 511    -- Get_Mode --
 512    --------------
 513
 514    function Get_Mode return Mode is
 515    begin
 516       return Current_Mode;
 517    end Get_Mode;
 518
 519    ----------
 520    -- Hash --
 521    ----------
 522
 523    function Hash is new System.HTable.Hash (Header_Num => Header_Num);
 524    --  Used in implementation of other functions Hash below
 525
 526    function Hash (Name : File_Name_Type) return Header_Num is
 527    begin
 528       return Hash (Get_Name_String (Name));
 529    end Hash;
 530
 531    function Hash (Name : Name_Id) return Header_Num is
 532    begin
 533       return Hash (Get_Name_String (Name));
 534    end Hash;
 535
 536    function Hash (Name : Path_Name_Type) return Header_Num is
 537    begin
 538       return Hash (Get_Name_String (Name));
 539    end Hash;
 540
 541    function Hash (Project : Project_Id) return Header_Num is
 542    begin
 543       return Header_Num (Project mod Max_Header_Num);
 544    end Hash;
 545
 546    -----------
 547    -- Image --
 548    -----------
 549
 550    function Image (Casing : Casing_Type) return String is
 551    begin
 552       return The_Casing_Images (Casing).all;
 553    end Image;
 554
 555    ----------------------
 556    -- In_Configuration --
 557    ----------------------
 558
 559    function In_Configuration return Boolean is
 560    begin
 561       return Configuration_Mode;
 562    end In_Configuration;
 563
 564    ----------------
 565    -- Initialize --
 566    ----------------
 567
 568    procedure Initialize (Tree : Project_Tree_Ref) is
 569    begin
 570       if not Initialized then
 571          Initialized := True;
 572          Uintp.Initialize;
 573          Name_Len := 0;
 574          The_Empty_String := Name_Find;
 575          Empty_Name := The_Empty_String;
 576          Empty_File_Name := File_Name_Type (The_Empty_String);
 577          Name_Len := 4;
 578          Name_Buffer (1 .. 4) := ".ads";
 579          Default_Ada_Spec_Suffix_Id := Name_Find;
 580          Name_Len := 4;
 581          Name_Buffer (1 .. 4) := ".adb";
 582          Default_Ada_Body_Suffix_Id := Name_Find;
 583          Name_Len := 1;
 584          Name_Buffer (1) := '/';
 585          Slash_Id := Name_Find;
 586
 587          Prj.Env.Initialize;
 588          Prj.Attr.Initialize;
 589          Set_Name_Table_Byte (Name_Project,  Token_Type'Pos (Tok_Project));
 590          Set_Name_Table_Byte (Name_Extends,  Token_Type'Pos (Tok_Extends));
 591          Set_Name_Table_Byte (Name_External, Token_Type'Pos (Tok_External));
 592       end if;
 593
 594       if Tree /= No_Project_Tree then
 595          Reset (Tree);
 596       end if;
 597    end Initialize;
 598
 599    -------------------
 600    -- Is_A_Language --
 601    -------------------
 602
 603    function Is_A_Language
 604      (Tree          : Project_Tree_Ref;
 605       Data          : Project_Data;
 606       Language_Name : Name_Id) return Boolean
 607    is
 608    begin
 609       if Get_Mode = Ada_Only then
 610          declare
 611             List : Name_List_Index := Data.Languages;
 612          begin
 613             while List /= No_Name_List loop
 614                if Tree.Name_Lists.Table (List).Name = Language_Name then
 615                   return True;
 616                else
 617                   List := Tree.Name_Lists.Table (List).Next;
 618                end if;
 619             end loop;
 620          end;
 621
 622       else
 623          declare
 624             Lang_Ind  : Language_Index := Data.First_Language_Processing;
 625             Lang_Data : Language_Data;
 626
 627          begin
 628             while Lang_Ind /= No_Language_Index loop
 629                Lang_Data := Tree.Languages_Data.Table (Lang_Ind);
 630
 631                if Lang_Data.Name = Language_Name then
 632                   return True;
 633                end if;
 634
 635                Lang_Ind := Lang_Data.Next;
 636             end loop;
 637          end;
 638       end if;
 639
 640       return False;
 641    end Is_A_Language;
 642
 643    ------------------
 644    -- Is_Extending --
 645    ------------------
 646
 647    function Is_Extending
 648      (Extending : Project_Id;
 649       Extended  : Project_Id;
 650       In_Tree   : Project_Tree_Ref) return Boolean
 651    is
 652       Proj : Project_Id;
 653
 654    begin
 655       Proj := Extending;
 656       while Proj /= No_Project loop
 657          if Proj = Extended then
 658             return True;
 659          end if;
 660
 661          Proj := In_Tree.Projects.Table (Proj).Extends;
 662       end loop;
 663
 664       return False;
 665    end Is_Extending;
 666
 667    -----------------------
 668    -- Objects_Exist_For --
 669    -----------------------
 670
 671    function Objects_Exist_For
 672      (Language : String;
 673       In_Tree  : Project_Tree_Ref) return Boolean
 674    is
 675       Language_Id : Name_Id;
 676       Lang        : Language_Index;
 677
 678    begin
 679       if Current_Mode = Multi_Language then
 680          Name_Len := 0;
 681          Add_Str_To_Name_Buffer (Language);
 682          To_Lower (Name_Buffer (1 .. Name_Len));
 683          Language_Id := Name_Find;
 684
 685          Lang := In_Tree.First_Language;
 686          while Lang /= No_Language_Index loop
 687             if In_Tree.Languages_Data.Table (Lang).Name = Language_Id then
 688                return
 689                  In_Tree.Languages_Data.Table
 690                    (Lang).Config.Object_Generated;
 691             end if;
 692
 693             Lang := In_Tree.Languages_Data.Table (Lang).Next;
 694          end loop;
 695       end if;
 696
 697       return True;
 698    end Objects_Exist_For;
 699
 700    -----------------
 701    -- Object_Name --
 702    -----------------
 703
 704    function Object_Name
 705      (Source_File_Name   : File_Name_Type;
 706       Object_File_Suffix : Name_Id := No_Name)
 707       return File_Name_Type
 708    is
 709    begin
 710       if Object_File_Suffix = No_Name then
 711          return Extend_Name
 712            (Source_File_Name, Object_Suffix);
 713       else
 714          return Extend_Name
 715            (Source_File_Name, Get_Name_String (Object_File_Suffix));
 716       end if;
 717    end Object_Name;
 718
 719    ----------------------
 720    -- Record_Temp_File --
 721    ----------------------
 722
 723    procedure Record_Temp_File (Path : Path_Name_Type) is
 724    begin
 725       Temp_Files.Increment_Last;
 726       Temp_Files.Table (Temp_Files.Last) := Path;
 727    end Record_Temp_File;
 728
 729    ------------------------------------
 730    -- Register_Default_Naming_Scheme --
 731    ------------------------------------
 732
 733    procedure Register_Default_Naming_Scheme
 734      (Language            : Name_Id;
 735       Default_Spec_Suffix : File_Name_Type;
 736       Default_Body_Suffix : File_Name_Type;
 737       In_Tree             : Project_Tree_Ref)
 738    is
 739       Lang : Name_Id;
 740       Suffix : Array_Element_Id;
 741       Found : Boolean := False;
 742       Element : Array_Element;
 743
 744    begin
 745       --  Get the language name in small letters
 746
 747       Get_Name_String (Language);
 748       Name_Buffer (1 .. Name_Len) := To_Lower (Name_Buffer (1 .. Name_Len));
 749       Lang := Name_Find;
 750
 751       --  Look for an element of the spec suffix array indexed by the language
 752       --  name. If one is found, put the default value.
 753
 754       Suffix := In_Tree.Private_Part.Default_Naming.Spec_Suffix;
 755       Found := False;
 756       while Suffix /= No_Array_Element and then not Found loop
 757          Element := In_Tree.Array_Elements.Table (Suffix);
 758
 759          if Element.Index = Lang then
 760             Found := True;
 761             Element.Value.Value := Name_Id (Default_Spec_Suffix);
 762             In_Tree.Array_Elements.Table (Suffix) := Element;
 763
 764          else
 765             Suffix := Element.Next;
 766          end if;
 767       end loop;
 768
 769       --  If none can be found, create a new one
 770
 771       if not Found then
 772          Element :=
 773            (Index     => Lang,
 774             Src_Index => 0,
 775             Index_Case_Sensitive => False,
 776             Value => (Project  => No_Project,
 777                       Kind     => Single,
 778                       Location => No_Location,
 779                       Default  => False,
 780                       Value    => Name_Id (Default_Spec_Suffix),
 781                       Index    => 0),
 782             Next  => In_Tree.Private_Part.Default_Naming.Spec_Suffix);
 783          Array_Element_Table.Increment_Last (In_Tree.Array_Elements);
 784          In_Tree.Array_Elements.Table
 785            (Array_Element_Table.Last (In_Tree.Array_Elements)) :=
 786             Element;
 787          In_Tree.Private_Part.Default_Naming.Spec_Suffix :=
 788            Array_Element_Table.Last (In_Tree.Array_Elements);
 789       end if;
 790
 791       --  Look for an element of the body suffix array indexed by the language
 792       --  name. If one is found, put the default value.
 793
 794       Suffix := In_Tree.Private_Part.Default_Naming.Body_Suffix;
 795       Found := False;
 796       while Suffix /= No_Array_Element and then not Found loop
 797          Element := In_Tree.Array_Elements.Table (Suffix);
 798
 799          if Element.Index = Lang then
 800             Found := True;
 801             Element.Value.Value := Name_Id (Default_Body_Suffix);
 802             In_Tree.Array_Elements.Table (Suffix) := Element;
 803
 804          else
 805             Suffix := Element.Next;
 806          end if;
 807       end loop;
 808
 809       --  If none can be found, create a new one
 810
 811       if not Found then
 812          Element :=
 813            (Index     => Lang,
 814             Src_Index => 0,
 815             Index_Case_Sensitive => False,
 816             Value => (Project  => No_Project,
 817                       Kind     => Single,
 818                       Location => No_Location,
 819                       Default  => False,
 820                       Value    => Name_Id (Default_Body_Suffix),
 821                       Index    => 0),
 822             Next  => In_Tree.Private_Part.Default_Naming.Body_Suffix);
 823          Array_Element_Table.Increment_Last
 824            (In_Tree.Array_Elements);
 825          In_Tree.Array_Elements.Table
 826            (Array_Element_Table.Last (In_Tree.Array_Elements))
 827              := Element;
 828          In_Tree.Private_Part.Default_Naming.Body_Suffix :=
 829            Array_Element_Table.Last (In_Tree.Array_Elements);
 830       end if;
 831    end Register_Default_Naming_Scheme;
 832
 833    ----------
 834    -- Free --
 835    ----------
 836
 837    procedure Free (Project : in out Project_Data) is
 838    begin
 839       Free (Project.Dir_Path);
 840       Free (Project.Include_Path);
 841       Free (Project.Ada_Include_Path);
 842       Free (Project.Objects_Path);
 843       Free (Project.Ada_Objects_Path);
 844    end Free;
 845
 846    ----------
 847    -- Free --
 848    ----------
 849
 850    procedure Free (Tree : in out Project_Tree_Ref) is
 851       procedure Unchecked_Free is new Ada.Unchecked_Deallocation
 852         (Project_Tree_Data, Project_Tree_Ref);
 853    begin
 854       if Tree /= null then
 855          Language_Data_Table.Free (Tree.Languages_Data);
 856          Name_List_Table.Free (Tree.Name_Lists);
 857          String_Element_Table.Free (Tree.String_Elements);
 858          Variable_Element_Table.Free (Tree.Variable_Elements);
 859          Array_Element_Table.Free (Tree.Array_Elements);
 860          Array_Table.Free (Tree.Arrays);
 861          Package_Table.Free (Tree.Packages);
 862          Project_List_Table.Free (Tree.Project_Lists);
 863          Source_Data_Table.Free (Tree.Sources);
 864          Alternate_Language_Table.Free (Tree.Alt_Langs);
 865          Unit_Table.Free (Tree.Units);
 866          Units_Htable.Reset (Tree.Units_HT);
 867          Files_Htable.Reset (Tree.Files_HT);
 868          Source_Paths_Htable.Reset (Tree.Source_Paths_HT);
 869          Unit_Sources_Htable.Reset (Tree.Unit_Sources_HT);
 870
 871          for P in Project_Table.First ..
 872            Project_Table.Last (Tree.Projects)
 873          loop
 874             Free (Tree.Projects.Table (P));
 875          end loop;
 876
 877          Project_Table.Free (Tree.Projects);
 878
 879          --  Private part
 880
 881          Naming_Table.Free (Tree.Private_Part.Namings);
 882          Path_File_Table.Free (Tree.Private_Part.Path_Files);
 883          Source_Path_Table.Free (Tree.Private_Part.Source_Paths);
 884          Object_Path_Table.Free (Tree.Private_Part.Object_Paths);
 885
 886          --  Naming data (nothing to free ?)
 887          null;
 888
 889          Unchecked_Free (Tree);
 890       end if;
 891    end Free;
 892
 893    -----------
 894    -- Reset --
 895    -----------
 896
 897    procedure Reset (Tree : Project_Tree_Ref) is
 898    begin
 899       Prj.Env.Initialize;
 900
 901       --  Visible tables
 902
 903       Language_Data_Table.Init      (Tree.Languages_Data);
 904       Name_List_Table.Init          (Tree.Name_Lists);
 905       String_Element_Table.Init     (Tree.String_Elements);
 906       Variable_Element_Table.Init   (Tree.Variable_Elements);
 907       Array_Element_Table.Init      (Tree.Array_Elements);
 908       Array_Table.Init              (Tree.Arrays);
 909       Package_Table.Init            (Tree.Packages);
 910       Project_List_Table.Init       (Tree.Project_Lists);
 911       Source_Data_Table.Init        (Tree.Sources);
 912       Alternate_Language_Table.Init (Tree.Alt_Langs);
 913       Unit_Table.Init               (Tree.Units);
 914       Units_Htable.Reset            (Tree.Units_HT);
 915       Files_Htable.Reset            (Tree.Files_HT);
 916       Source_Paths_Htable.Reset     (Tree.Source_Paths_HT);
 917       Unit_Sources_Htable.Reset     (Tree.Unit_Sources_HT);
 918
 919       if not Project_Table."=" (Tree.Projects.Table, null) then
 920          for P in Project_Table.First ..
 921            Project_Table.Last (Tree.Projects)
 922          loop
 923             Free (Tree.Projects.Table (P));
 924          end loop;
 925       end if;
 926
 927       Project_Table.Init            (Tree.Projects);
 928
 929       --  Private part table
 930
 931       Naming_Table.Init             (Tree.Private_Part.Namings);
 932       Naming_Table.Increment_Last   (Tree.Private_Part.Namings);
 933       Tree.Private_Part.Namings.Table
 934         (Naming_Table.Last (Tree.Private_Part.Namings)) := Std_Naming_Data;
 935       Path_File_Table.Init        (Tree.Private_Part.Path_Files);
 936       Source_Path_Table.Init      (Tree.Private_Part.Source_Paths);
 937       Object_Path_Table.Init      (Tree.Private_Part.Object_Paths);
 938       Tree.Private_Part.Default_Naming := Std_Naming_Data;
 939
 940       if Current_Mode = Ada_Only then
 941          Register_Default_Naming_Scheme
 942            (Language            => Name_Ada,
 943             Default_Spec_Suffix => Default_Ada_Spec_Suffix,
 944             Default_Body_Suffix => Default_Ada_Body_Suffix,
 945             In_Tree             => Tree);
 946          Tree.Private_Part.Default_Naming.Separate_Suffix :=
 947            Default_Ada_Body_Suffix;
 948       end if;
 949    end Reset;
 950
 951    ------------------------
 952    -- Same_Naming_Scheme --
 953    ------------------------
 954
 955    function Same_Naming_Scheme
 956      (Left, Right : Naming_Data) return Boolean
 957    is
 958    begin
 959       return Left.Dot_Replacement = Right.Dot_Replacement
 960         and then Left.Casing = Right.Casing
 961         and then Left.Separate_Suffix = Right.Separate_Suffix;
 962    end Same_Naming_Scheme;
 963
 964    ---------------------
 965    -- Set_Body_Suffix --
 966    ---------------------
 967
 968    procedure Set_Body_Suffix
 969      (In_Tree  : Project_Tree_Ref;
 970       Language : String;
 971       Naming   : in out Naming_Data;
 972       Suffix   : File_Name_Type)
 973    is
 974       Language_Id : Name_Id;
 975       Element     : Array_Element;
 976
 977    begin
 978       Name_Len := 0;
 979       Add_Str_To_Name_Buffer (Language);
 980       To_Lower (Name_Buffer (1 .. Name_Len));
 981       Language_Id := Name_Find;
 982
 983       Element :=
 984         (Index                => Language_Id,
 985          Src_Index            => 0,
 986          Index_Case_Sensitive => False,
 987          Value                =>
 988            (Kind     => Single,
 989             Project  => No_Project,
 990             Location => No_Location,
 991             Default  => False,
 992             Value    => Name_Id (Suffix),
 993             Index    => 0),
 994          Next                 => Naming.Body_Suffix);
 995
 996       Array_Element_Table.Increment_Last (In_Tree.Array_Elements);
 997       Naming.Body_Suffix :=
 998          Array_Element_Table.Last (In_Tree.Array_Elements);
 999       In_Tree.Array_Elements.Table (Naming.Body_Suffix) := Element;
1000    end Set_Body_Suffix;
1001
1002    --------------------------
1003    -- Set_In_Configuration --
1004    --------------------------
1005
1006    procedure Set_In_Configuration (Value : Boolean) is
1007    begin
1008       Configuration_Mode := Value;
1009    end Set_In_Configuration;
1010
1011    --------------
1012    -- Set_Mode --
1013    --------------
1014
1015    procedure Set_Mode (New_Mode : Mode) is
1016    begin
1017       Current_Mode := New_Mode;
1018       case New_Mode is
1019          when Ada_Only =>
1020             Default_Language_Is_Ada := True;
1021             Must_Check_Configuration := False;
1022          when Multi_Language =>
1023             Default_Language_Is_Ada := False;
1024             Must_Check_Configuration := True;
1025       end case;
1026    end Set_Mode;
1027
1028    ---------------------
1029    -- Set_Spec_Suffix --
1030    ---------------------
1031
1032    procedure Set_Spec_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.Spec_Suffix);
1059
1060       Array_Element_Table.Increment_Last (In_Tree.Array_Elements);
1061       Naming.Spec_Suffix :=
1062         Array_Element_Table.Last (In_Tree.Array_Elements);
1063       In_Tree.Array_Elements.Table (Naming.Spec_Suffix) := Element;
1064    end Set_Spec_Suffix;
1065
1066    -----------
1067    -- Slash --
1068    -----------
1069
1070    function Slash return Path_Name_Type is
1071    begin
1072       return Slash_Id;
1073    end Slash;
1074
1075    -----------------------
1076    -- Spec_Suffix_Id_Of --
1077    -----------------------
1078
1079    function Spec_Suffix_Id_Of
1080      (In_Tree  : Project_Tree_Ref;
1081       Language : String;
1082       Naming   : Naming_Data) return File_Name_Type
1083    is
1084       Language_Id : Name_Id;
1085
1086    begin
1087       Name_Len := 0;
1088       Add_Str_To_Name_Buffer (Language);
1089       To_Lower (Name_Buffer (1 .. Name_Len));
1090       Language_Id := Name_Find;
1091
1092       return
1093         Spec_Suffix_Id_Of
1094           (In_Tree     => In_Tree,
1095            Language_Id => Language_Id,
1096            Naming      => Naming);
1097    end Spec_Suffix_Id_Of;
1098
1099    -----------------------
1100    -- Spec_Suffix_Id_Of --
1101    -----------------------
1102
1103    function Spec_Suffix_Id_Of
1104      (In_Tree     : Project_Tree_Ref;
1105       Language_Id : Name_Id;
1106       Naming      : Naming_Data) return File_Name_Type
1107    is
1108       Element_Id : Array_Element_Id;
1109       Element    : Array_Element;
1110       Suffix     : File_Name_Type := No_File;
1111       Lang       : Language_Index;
1112
1113    begin
1114       Element_Id := Naming.Spec_Suffix;
1115       while Element_Id /= No_Array_Element loop
1116          Element := In_Tree.Array_Elements.Table (Element_Id);
1117
1118          if Element.Index = Language_Id then
1119             return File_Name_Type (Element.Value.Value);
1120          end if;
1121
1122          Element_Id := Element.Next;
1123       end loop;
1124
1125       if Current_Mode = Multi_Language then
1126          Lang := In_Tree.First_Language;
1127          while Lang /= No_Language_Index loop
1128             if In_Tree.Languages_Data.Table (Lang).Name = Language_Id then
1129                Suffix :=
1130                  In_Tree.Languages_Data.Table
1131                    (Lang).Config.Naming_Data.Spec_Suffix;
1132                exit;
1133             end if;
1134
1135             Lang := In_Tree.Languages_Data.Table (Lang).Next;
1136          end loop;
1137       end if;
1138
1139       return Suffix;
1140    end Spec_Suffix_Id_Of;
1141
1142    --------------------
1143    -- Spec_Suffix_Of --
1144    --------------------
1145
1146    function Spec_Suffix_Of
1147      (In_Tree  : Project_Tree_Ref;
1148       Language : String;
1149       Naming   : Naming_Data) return String
1150    is
1151       Language_Id : Name_Id;
1152       Element_Id  : Array_Element_Id;
1153       Element     : Array_Element;
1154       Suffix      : File_Name_Type := No_File;
1155       Lang        : Language_Index;
1156
1157    begin
1158       Name_Len := 0;
1159       Add_Str_To_Name_Buffer (Language);
1160       To_Lower (Name_Buffer (1 .. Name_Len));
1161       Language_Id := Name_Find;
1162
1163       Element_Id := Naming.Spec_Suffix;
1164       while Element_Id /= No_Array_Element loop
1165          Element := In_Tree.Array_Elements.Table (Element_Id);
1166
1167          if Element.Index = Language_Id then
1168             return Get_Name_String (Element.Value.Value);
1169          end if;
1170
1171          Element_Id := Element.Next;
1172       end loop;
1173
1174       if Current_Mode = Multi_Language then
1175          Lang := In_Tree.First_Language;
1176          while Lang /= No_Language_Index loop
1177             if In_Tree.Languages_Data.Table (Lang).Name = Language_Id then
1178                Suffix :=
1179                  File_Name_Type
1180                    (In_Tree.Languages_Data.Table
1181                       (Lang).Config.Naming_Data.Spec_Suffix);
1182                exit;
1183             end if;
1184
1185             Lang := In_Tree.Languages_Data.Table (Lang).Next;
1186          end loop;
1187
1188          if Suffix /= No_File then
1189             return Get_Name_String (Suffix);
1190          end if;
1191       end if;
1192
1193       return "";
1194    end Spec_Suffix_Of;
1195
1196    --------------------------
1197    -- Standard_Naming_Data --
1198    --------------------------
1199
1200    function Standard_Naming_Data
1201      (Tree : Project_Tree_Ref := No_Project_Tree) return Naming_Data
1202    is
1203    begin
1204       if Tree = No_Project_Tree then
1205          Prj.Initialize (Tree => No_Project_Tree);
1206          return Std_Naming_Data;
1207       else
1208          return Tree.Private_Part.Default_Naming;
1209       end if;
1210    end Standard_Naming_Data;
1211
1212    -------------------
1213    -- Switches_Name --
1214    -------------------
1215
1216    function Switches_Name
1217      (Source_File_Name : File_Name_Type) return File_Name_Type
1218    is
1219    begin
1220       return Extend_Name (Source_File_Name, Switches_Dependency_Suffix);
1221    end Switches_Name;
1222
1223    -----------
1224    -- Value --
1225    -----------
1226
1227    function Value (Image : String) return Casing_Type is
1228    begin
1229       for Casing in The_Casing_Images'Range loop
1230          if To_Lower (Image) = To_Lower (The_Casing_Images (Casing).all) then
1231             return Casing;
1232          end if;
1233       end loop;
1234
1235       raise Constraint_Error;
1236    end Value;
1237
1238 begin
1239    --  Make sure that the standard config and user project file extensions are
1240    --  compatible with canonical case file naming.
1241
1242    Canonical_Case_File_Name (Config_Project_File_Extension);
1243    Canonical_Case_File_Name (Project_File_Extension);
1244 end Prj;