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