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.Env;
  33 with Prj.Err;  use Prj.Err;
  34 with Snames;   use Snames;
  35 with Table;
  36 with Uintp;    use Uintp;
  37
  38 with System.Case_Util; use System.Case_Util;
  39 with System.HTable;
  40
  41 package body Prj is
  42
  43    Object_Suffix : constant String := Get_Target_Object_Suffix.all;
  44    --  File suffix for object files
  45
  46    Initial_Buffer_Size : constant := 100;
  47    --  Initial size for extensible buffer used in Add_To_Buffer
  48
  49    Current_Mode : Mode := Ada_Only;
  50
  51    Configuration_Mode : Boolean := False;
  52
  53    The_Empty_String : Name_Id;
  54
  55    Default_Ada_Spec_Suffix_Id : File_Name_Type;
  56    Default_Ada_Body_Suffix_Id : File_Name_Type;
  57    Slash_Id                   : Path_Name_Type;
  58    --  Initialized in Prj.Initialize, then never modified
  59
  60    subtype Known_Casing is Casing_Type range All_Upper_Case .. Mixed_Case;
  61
  62    The_Casing_Images : constant array (Known_Casing) of String_Access :=
  63      (All_Lower_Case => new String'("lowercase"),
  64       All_Upper_Case => new String'("UPPERCASE"),
  65       Mixed_Case     => new String'("MixedCase"));
  66
  67    Initialized : Boolean := False;
  68
  69    Standard_Dot_Replacement : constant File_Name_Type :=
  70                                 File_Name_Type
  71                                   (First_Name_Id + Character'Pos ('-'));
  72
  73    Std_Naming_Data : constant Naming_Data :=
  74                        (Dot_Replacement           => Standard_Dot_Replacement,
  75                         Casing                    => All_Lower_Case,
  76                         Spec_Suffix               => No_Array_Element,
  77                         Body_Suffix               => No_Array_Element,
  78                         Separate_Suffix           => No_File,
  79                         Specs                     => No_Array_Element,
  80                         Bodies                    => No_Array_Element,
  81                         Specification_Exceptions  => No_Array_Element,
  82                         Implementation_Exceptions => No_Array_Element);
  83
  84    Project_Empty : constant Project_Data :=
  85                      (Qualifier                      => Unspecified,
  86                       Externally_Built               => False,
  87                       Config                         => Default_Project_Config,
  88                       Name                           => No_Name,
  89                       Display_Name                   => No_Name,
  90                       Path                           => No_Path_Information,
  91                       Virtual                        => False,
  92                       Location                       => No_Location,
  93                       Mains                          => Nil_String,
  94                       Directory                      => No_Path_Information,
  95                       Dir_Path                       => null,
  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                       Ada_Sources_Present            => True,
 109                       Other_Sources_Present          => True,
 110                       Ada_Sources                    => Nil_String,
 111                       First_Source                   => No_Source,
 112                       Last_Source                    => No_Source,
 113                       Interfaces_Defined             => False,
 114                       Imported_Directories_Switches  => null,
 115                       Include_Path                   => null,
 116                       Include_Data_Set               => False,
 117                       Source_Dirs                    => Nil_String,
 118                       Known_Order_Of_Source_Dirs     => True,
 119                       Object_Directory               => No_Path_Information,
 120                       Library_TS                     => Empty_Time_Stamp,
 121                       Exec_Directory                 => No_Path_Information,
 122                       Extends                        => No_Project,
 123                       Extended_By                    => No_Project,
 124                       Naming                         => Std_Naming_Data,
 125                       Languages      => No_Language_Index,
 126                       Decl                           => No_Declarations,
 127                       Imported_Projects              => Empty_Project_List,
 128                       All_Imported_Projects          => Empty_Project_List,
 129                       Ada_Include_Path               => null,
 130                       Ada_Objects_Path               => null,
 131                       Objects_Path                   => null,
 132                       Include_Path_File              => No_Path,
 133                       Objects_Path_File_With_Libs    => No_Path,
 134                       Objects_Path_File_Without_Libs => No_Path,
 135                       Config_File_Name               => No_Path,
 136                       Config_File_Temp               => False,
 137                       Config_Checked                 => False,
 138                       Checked                        => False,
 139                       Seen                           => False,
 140                       Need_To_Build_Lib              => False,
 141                       Depth                          => 0,
 142                       Unkept_Comments                => False);
 143
 144    package Temp_Files is new Table.Table
 145      (Table_Component_Type => Path_Name_Type,
 146       Table_Index_Type     => Integer,
 147       Table_Low_Bound      => 1,
 148       Table_Initial        => 20,
 149       Table_Increment      => 100,
 150       Table_Name           => "Makegpr.Temp_Files");
 151    --  Table to store the path name of all the created temporary files, so that
 152    --  they can be deleted at the end, or when the program is interrupted.
 153
 154    procedure Free (Project : in out Project_Data);
 155    --  Free memory allocated for Project
 156
 157    procedure Free_List (Languages : in out Language_Ptr);
 158    --  Free memory allocated for the list of languages
 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_Id : Name_Id;
 200       Naming      : Naming_Data) return File_Name_Type
 201    is
 202       Element_Id : Array_Element_Id;
 203       Element    : Array_Element;
 204
 205    begin
 206       --  ??? This seems to be only for Ada_Only mode...
 207       Element_Id := Naming.Body_Suffix;
 208       while Element_Id /= No_Array_Element loop
 209          Element := In_Tree.Array_Elements.Table (Element_Id);
 210
 211          if Element.Index = Language_Id then
 212             return File_Name_Type (Element.Value.Value);
 213          end if;
 214
 215          Element_Id := Element.Next;
 216       end loop;
 217
 218       return No_File;
 219    end Body_Suffix_Id_Of;
 220
 221    --------------------
 222    -- Body_Suffix_Of --
 223    --------------------
 224
 225    function Body_Suffix_Of
 226      (In_Tree  : Project_Tree_Ref;
 227       Language : String;
 228       Naming   : Naming_Data) return String
 229    is
 230       Language_Id : Name_Id;
 231       Element_Id  : Array_Element_Id;
 232       Element     : Array_Element;
 233
 234    begin
 235       Name_Len := 0;
 236       Add_Str_To_Name_Buffer (Language);
 237       To_Lower (Name_Buffer (1 .. Name_Len));
 238       Language_Id := Name_Find;
 239
 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 Get_Name_String (Element.Value.Value);
 246          end if;
 247
 248          Element_Id := Element.Next;
 249       end loop;
 250
 251       return "";
 252    end Body_Suffix_Of;
 253
 254    -----------------------------
 255    -- Default_Ada_Body_Suffix --
 256    -----------------------------
 257
 258    function Default_Ada_Body_Suffix return File_Name_Type is
 259    begin
 260       return Default_Ada_Body_Suffix_Id;
 261    end Default_Ada_Body_Suffix;
 262
 263    -----------------------------
 264    -- Default_Ada_Spec_Suffix --
 265    -----------------------------
 266
 267    function Default_Ada_Spec_Suffix return File_Name_Type is
 268    begin
 269       return Default_Ada_Spec_Suffix_Id;
 270    end Default_Ada_Spec_Suffix;
 271
 272    ---------------------------
 273    -- Delete_All_Temp_Files --
 274    ---------------------------
 275
 276    procedure Delete_All_Temp_Files is
 277       Dont_Care : Boolean;
 278       pragma Warnings (Off, Dont_Care);
 279    begin
 280       if not Debug.Debug_Flag_N then
 281          for Index in 1 .. Temp_Files.Last loop
 282             Delete_File
 283               (Get_Name_String (Temp_Files.Table (Index)), Dont_Care);
 284          end loop;
 285       end if;
 286    end Delete_All_Temp_Files;
 287
 288    ---------------------
 289    -- Dependency_Name --
 290    ---------------------
 291
 292    function Dependency_Name
 293      (Source_File_Name : File_Name_Type;
 294       Dependency       : Dependency_File_Kind) return File_Name_Type
 295    is
 296    begin
 297       case Dependency is
 298          when None =>
 299             return No_File;
 300
 301          when Makefile =>
 302             return
 303               File_Name_Type
 304                 (Extend_Name
 305                    (Source_File_Name, Makefile_Dependency_Suffix));
 306
 307          when ALI_File =>
 308             return
 309               File_Name_Type
 310                 (Extend_Name
 311                    (Source_File_Name, ALI_Dependency_Suffix));
 312       end case;
 313    end Dependency_Name;
 314
 315    ----------------
 316    -- Empty_File --
 317    ----------------
 318
 319    function Empty_File return File_Name_Type is
 320    begin
 321       return File_Name_Type (The_Empty_String);
 322    end Empty_File;
 323
 324    -------------------
 325    -- Empty_Project --
 326    -------------------
 327
 328    function Empty_Project (Tree : Project_Tree_Ref) return Project_Data is
 329       Value : Project_Data;
 330
 331    begin
 332       Prj.Initialize (Tree => No_Project_Tree);
 333       Value := Project_Empty;
 334       Value.Naming := Tree.Private_Part.Default_Naming;
 335
 336       return Value;
 337    end Empty_Project;
 338
 339    ------------------
 340    -- Empty_String --
 341    ------------------
 342
 343    function Empty_String return Name_Id is
 344    begin
 345       return The_Empty_String;
 346    end Empty_String;
 347
 348    ------------
 349    -- Expect --
 350    ------------
 351
 352    procedure Expect (The_Token : Token_Type; Token_Image : String) is
 353    begin
 354       if Token /= The_Token then
 355          Error_Msg (Token_Image & " expected", Token_Ptr);
 356       end if;
 357    end Expect;
 358
 359    -----------------
 360    -- Extend_Name --
 361    -----------------
 362
 363    function Extend_Name
 364      (File        : File_Name_Type;
 365       With_Suffix : String) return File_Name_Type
 366    is
 367       Last : Positive;
 368
 369    begin
 370       Get_Name_String (File);
 371       Last := Name_Len + 1;
 372
 373       while Name_Len /= 0 and then Name_Buffer (Name_Len) /= '.' loop
 374          Name_Len := Name_Len - 1;
 375       end loop;
 376
 377       if Name_Len <= 1 then
 378          Name_Len := Last;
 379       end if;
 380
 381       for J in With_Suffix'Range loop
 382          Name_Buffer (Name_Len) := With_Suffix (J);
 383          Name_Len := Name_Len + 1;
 384       end loop;
 385
 386       Name_Len := Name_Len - 1;
 387       return Name_Find;
 388
 389    end Extend_Name;
 390
 391    --------------------------------
 392    -- For_Every_Project_Imported --
 393    --------------------------------
 394
 395    procedure For_Every_Project_Imported
 396      (By         : Project_Id;
 397       In_Tree    : Project_Tree_Ref;
 398       With_State : in out State)
 399    is
 400
 401       procedure Recursive_Check (Project : Project_Id);
 402       --  Check if a project has already been seen. If not seen, mark it as
 403       --  Seen, Call Action, and check all its imported projects.
 404
 405       ---------------------
 406       -- Recursive_Check --
 407       ---------------------
 408
 409       procedure Recursive_Check (Project : Project_Id) is
 410          List : Project_List;
 411       begin
 412          if not In_Tree.Projects.Table (Project).Seen then
 413             In_Tree.Projects.Table (Project).Seen := True;
 414             Action (Project, With_State);
 415
 416             List := In_Tree.Projects.Table (Project).Imported_Projects;
 417             while List /= Empty_Project_List loop
 418                Recursive_Check (In_Tree.Project_Lists.Table (List).Project);
 419                List := In_Tree.Project_Lists.Table (List).Next;
 420             end loop;
 421          end if;
 422       end Recursive_Check;
 423
 424    --  Start of processing for For_Every_Project_Imported
 425
 426    begin
 427       for Project in Project_Table.First ..
 428                      Project_Table.Last (In_Tree.Projects)
 429       loop
 430          In_Tree.Projects.Table (Project).Seen := False;
 431       end loop;
 432
 433       Recursive_Check (Project => By);
 434    end For_Every_Project_Imported;
 435
 436    --------------
 437    -- Get_Mode --
 438    --------------
 439
 440    function Get_Mode return Mode is
 441    begin
 442       return Current_Mode;
 443    end Get_Mode;
 444
 445    ----------
 446    -- Hash --
 447    ----------
 448
 449    function Hash is new System.HTable.Hash (Header_Num => Header_Num);
 450    --  Used in implementation of other functions Hash below
 451
 452    function Hash (Name : File_Name_Type) return Header_Num is
 453    begin
 454       return Hash (Get_Name_String (Name));
 455    end Hash;
 456
 457    function Hash (Name : Name_Id) return Header_Num is
 458    begin
 459       return Hash (Get_Name_String (Name));
 460    end Hash;
 461
 462    function Hash (Name : Path_Name_Type) return Header_Num is
 463    begin
 464       return Hash (Get_Name_String (Name));
 465    end Hash;
 466
 467    function Hash (Project : Project_Id) return Header_Num is
 468    begin
 469       return Header_Num (Project mod Max_Header_Num);
 470    end Hash;
 471
 472    -----------
 473    -- Image --
 474    -----------
 475
 476    function Image (Casing : Casing_Type) return String is
 477    begin
 478       return The_Casing_Images (Casing).all;
 479    end Image;
 480
 481    ----------------------
 482    -- In_Configuration --
 483    ----------------------
 484
 485    function In_Configuration return Boolean is
 486    begin
 487       return Configuration_Mode;
 488    end In_Configuration;
 489
 490    ----------------
 491    -- Initialize --
 492    ----------------
 493
 494    procedure Initialize (Tree : Project_Tree_Ref) is
 495    begin
 496       if not Initialized then
 497          Initialized := True;
 498          Uintp.Initialize;
 499          Name_Len := 0;
 500          The_Empty_String := Name_Find;
 501          Empty_Name := The_Empty_String;
 502          Empty_File_Name := File_Name_Type (The_Empty_String);
 503          Name_Len := 4;
 504          Name_Buffer (1 .. 4) := ".ads";
 505          Default_Ada_Spec_Suffix_Id := Name_Find;
 506          Name_Len := 4;
 507          Name_Buffer (1 .. 4) := ".adb";
 508          Default_Ada_Body_Suffix_Id := Name_Find;
 509          Name_Len := 1;
 510          Name_Buffer (1) := '/';
 511          Slash_Id := Name_Find;
 512
 513          Prj.Env.Initialize;
 514          Prj.Attr.Initialize;
 515          Set_Name_Table_Byte (Name_Project,  Token_Type'Pos (Tok_Project));
 516          Set_Name_Table_Byte (Name_Extends,  Token_Type'Pos (Tok_Extends));
 517          Set_Name_Table_Byte (Name_External, Token_Type'Pos (Tok_External));
 518       end if;
 519
 520       if Tree /= No_Project_Tree then
 521          Reset (Tree);
 522       end if;
 523    end Initialize;
 524
 525    -------------------
 526    -- Is_A_Language --
 527    -------------------
 528
 529    function Is_A_Language
 530      (Data          : Project_Data;
 531       Language_Name : Name_Id) return Boolean
 532    is
 533       Lang_Ind  : Language_Ptr := Data.Languages;
 534    begin
 535       while Lang_Ind /= No_Language_Index loop
 536          if Lang_Ind.Name = Language_Name then
 537             return True;
 538          end if;
 539
 540          Lang_Ind := Lang_Ind.Next;
 541       end loop;
 542
 543       return False;
 544    end Is_A_Language;
 545
 546    ------------------
 547    -- Is_Extending --
 548    ------------------
 549
 550    function Is_Extending
 551      (Extending : Project_Id;
 552       Extended  : Project_Id;
 553       In_Tree   : Project_Tree_Ref) return Boolean
 554    is
 555       Proj : Project_Id;
 556
 557    begin
 558       Proj := Extending;
 559       while Proj /= No_Project loop
 560          if Proj = Extended then
 561             return True;
 562          end if;
 563
 564          Proj := In_Tree.Projects.Table (Proj).Extends;
 565       end loop;
 566
 567       return False;
 568    end Is_Extending;
 569
 570    -----------------
 571    -- Object_Name --
 572    -----------------
 573
 574    function Object_Name
 575      (Source_File_Name   : File_Name_Type;
 576       Object_File_Suffix : Name_Id := No_Name)
 577       return File_Name_Type
 578    is
 579    begin
 580       if Object_File_Suffix = No_Name then
 581          return Extend_Name
 582            (Source_File_Name, Object_Suffix);
 583       else
 584          return Extend_Name
 585            (Source_File_Name, Get_Name_String (Object_File_Suffix));
 586       end if;
 587    end Object_Name;
 588
 589    ----------------------
 590    -- Record_Temp_File --
 591    ----------------------
 592
 593    procedure Record_Temp_File (Path : Path_Name_Type) is
 594    begin
 595       Temp_Files.Increment_Last;
 596       Temp_Files.Table (Temp_Files.Last) := Path;
 597    end Record_Temp_File;
 598
 599    ------------------------------------
 600    -- Register_Default_Naming_Scheme --
 601    ------------------------------------
 602
 603    procedure Register_Default_Naming_Scheme
 604      (Language            : Name_Id;
 605       Default_Spec_Suffix : File_Name_Type;
 606       Default_Body_Suffix : File_Name_Type;
 607       In_Tree             : Project_Tree_Ref)
 608    is
 609       Lang : Name_Id;
 610       Suffix : Array_Element_Id;
 611       Found : Boolean := False;
 612       Element : Array_Element;
 613
 614    begin
 615       --  Get the language name in small letters
 616
 617       Get_Name_String (Language);
 618       Name_Buffer (1 .. Name_Len) := To_Lower (Name_Buffer (1 .. Name_Len));
 619       Lang := Name_Find;
 620
 621       --  Look for an element of the spec suffix array indexed by the language
 622       --  name. If one is found, put the default value.
 623
 624       Suffix := In_Tree.Private_Part.Default_Naming.Spec_Suffix;
 625       Found := False;
 626       while Suffix /= No_Array_Element and then not Found loop
 627          Element := In_Tree.Array_Elements.Table (Suffix);
 628
 629          if Element.Index = Lang then
 630             Found := True;
 631             Element.Value.Value := Name_Id (Default_Spec_Suffix);
 632             In_Tree.Array_Elements.Table (Suffix) := Element;
 633
 634          else
 635             Suffix := Element.Next;
 636          end if;
 637       end loop;
 638
 639       --  If none can be found, create a new one
 640
 641       if not Found then
 642          Element :=
 643            (Index     => Lang,
 644             Src_Index => 0,
 645             Index_Case_Sensitive => False,
 646             Value => (Project  => No_Project,
 647                       Kind     => Single,
 648                       Location => No_Location,
 649                       Default  => False,
 650                       Value    => Name_Id (Default_Spec_Suffix),
 651                       Index    => 0),
 652             Next  => In_Tree.Private_Part.Default_Naming.Spec_Suffix);
 653          Array_Element_Table.Increment_Last (In_Tree.Array_Elements);
 654          In_Tree.Array_Elements.Table
 655            (Array_Element_Table.Last (In_Tree.Array_Elements)) :=
 656             Element;
 657          In_Tree.Private_Part.Default_Naming.Spec_Suffix :=
 658            Array_Element_Table.Last (In_Tree.Array_Elements);
 659       end if;
 660
 661       --  Look for an element of the body suffix array indexed by the language
 662       --  name. If one is found, put the default value.
 663
 664       Suffix := In_Tree.Private_Part.Default_Naming.Body_Suffix;
 665       Found := False;
 666       while Suffix /= No_Array_Element and then not Found loop
 667          Element := In_Tree.Array_Elements.Table (Suffix);
 668
 669          if Element.Index = Lang then
 670             Found := True;
 671             Element.Value.Value := Name_Id (Default_Body_Suffix);
 672             In_Tree.Array_Elements.Table (Suffix) := Element;
 673
 674          else
 675             Suffix := Element.Next;
 676          end if;
 677       end loop;
 678
 679       --  If none can be found, create a new one
 680
 681       if not Found then
 682          Element :=
 683            (Index     => Lang,
 684             Src_Index => 0,
 685             Index_Case_Sensitive => False,
 686             Value => (Project  => No_Project,
 687                       Kind     => Single,
 688                       Location => No_Location,
 689                       Default  => False,
 690                       Value    => Name_Id (Default_Body_Suffix),
 691                       Index    => 0),
 692             Next  => In_Tree.Private_Part.Default_Naming.Body_Suffix);
 693          Array_Element_Table.Increment_Last
 694            (In_Tree.Array_Elements);
 695          In_Tree.Array_Elements.Table
 696            (Array_Element_Table.Last (In_Tree.Array_Elements))
 697              := Element;
 698          In_Tree.Private_Part.Default_Naming.Body_Suffix :=
 699            Array_Element_Table.Last (In_Tree.Array_Elements);
 700       end if;
 701    end Register_Default_Naming_Scheme;
 702
 703    ----------
 704    -- Free --
 705    ----------
 706
 707    procedure Free (Project : in out Project_Data) is
 708    begin
 709       Free (Project.Dir_Path);
 710       Free (Project.Include_Path);
 711       Free (Project.Ada_Include_Path);
 712       Free (Project.Objects_Path);
 713       Free (Project.Ada_Objects_Path);
 714    end Free;
 715
 716    ---------------
 717    -- Free_List --
 718    ---------------
 719
 720    procedure Free_List (Languages : in out Language_Ptr) is
 721       procedure Unchecked_Free is new Ada.Unchecked_Deallocation
 722         (Language_Data, Language_Ptr);
 723       Tmp : Language_Ptr;
 724    begin
 725       while Languages /= null loop
 726          Tmp := Languages.Next;
 727          Unchecked_Free (Languages);
 728          Languages := Tmp;
 729       end loop;
 730    end Free_List;
 731
 732    ----------
 733    -- Free --
 734    ----------
 735
 736    procedure Free (Tree : in out Project_Tree_Ref) is
 737       procedure Unchecked_Free is new Ada.Unchecked_Deallocation
 738         (Project_Tree_Data, Project_Tree_Ref);
 739    begin
 740       if Tree /= null then
 741          Name_List_Table.Free (Tree.Name_Lists);
 742          String_Element_Table.Free (Tree.String_Elements);
 743          Variable_Element_Table.Free (Tree.Variable_Elements);
 744          Array_Element_Table.Free (Tree.Array_Elements);
 745          Array_Table.Free (Tree.Arrays);
 746          Package_Table.Free (Tree.Packages);
 747          Project_List_Table.Free (Tree.Project_Lists);
 748          Source_Data_Table.Free (Tree.Sources);
 749          Alternate_Language_Table.Free (Tree.Alt_Langs);
 750          Unit_Table.Free (Tree.Units);
 751          Units_Htable.Reset (Tree.Units_HT);
 752          Files_Htable.Reset (Tree.Files_HT);
 753          Source_Paths_Htable.Reset (Tree.Source_Paths_HT);
 754          Unit_Sources_Htable.Reset (Tree.Unit_Sources_HT);
 755
 756          for P in Project_Table.First ..
 757            Project_Table.Last (Tree.Projects)
 758          loop
 759             Free_List (Tree.Projects.Table (P).Languages);
 760             Free (Tree.Projects.Table (P));
 761          end loop;
 762
 763          Project_Table.Free (Tree.Projects);
 764
 765          --  Private part
 766
 767          Naming_Table.Free (Tree.Private_Part.Namings);
 768          Path_File_Table.Free (Tree.Private_Part.Path_Files);
 769          Source_Path_Table.Free (Tree.Private_Part.Source_Paths);
 770          Object_Path_Table.Free (Tree.Private_Part.Object_Paths);
 771
 772          --  Naming data (nothing to free ?)
 773          null;
 774
 775          Unchecked_Free (Tree);
 776       end if;
 777    end Free;
 778
 779    -----------
 780    -- Reset --
 781    -----------
 782
 783    procedure Reset (Tree : Project_Tree_Ref) is
 784    begin
 785       Prj.Env.Initialize;
 786
 787       --  Visible tables
 788
 789       Name_List_Table.Init          (Tree.Name_Lists);
 790       String_Element_Table.Init     (Tree.String_Elements);
 791       Variable_Element_Table.Init   (Tree.Variable_Elements);
 792       Array_Element_Table.Init      (Tree.Array_Elements);
 793       Array_Table.Init              (Tree.Arrays);
 794       Package_Table.Init            (Tree.Packages);
 795       Project_List_Table.Init       (Tree.Project_Lists);
 796       Source_Data_Table.Init        (Tree.Sources);
 797       Alternate_Language_Table.Init (Tree.Alt_Langs);
 798       Unit_Table.Init               (Tree.Units);
 799       Units_Htable.Reset            (Tree.Units_HT);
 800       Files_Htable.Reset            (Tree.Files_HT);
 801       Source_Paths_Htable.Reset     (Tree.Source_Paths_HT);
 802       Unit_Sources_Htable.Reset     (Tree.Unit_Sources_HT);
 803
 804       if not Project_Table."=" (Tree.Projects.Table, null) then
 805          for P in Project_Table.First ..
 806            Project_Table.Last (Tree.Projects)
 807          loop
 808             Free (Tree.Projects.Table (P));
 809          end loop;
 810       end if;
 811
 812       Project_Table.Init            (Tree.Projects);
 813
 814       --  Private part table
 815
 816       Naming_Table.Init             (Tree.Private_Part.Namings);
 817       Naming_Table.Increment_Last   (Tree.Private_Part.Namings);
 818       Tree.Private_Part.Namings.Table
 819         (Naming_Table.Last (Tree.Private_Part.Namings)) := Std_Naming_Data;
 820       Path_File_Table.Init        (Tree.Private_Part.Path_Files);
 821       Source_Path_Table.Init      (Tree.Private_Part.Source_Paths);
 822       Object_Path_Table.Init      (Tree.Private_Part.Object_Paths);
 823       Tree.Private_Part.Default_Naming := Std_Naming_Data;
 824
 825       if Current_Mode = Ada_Only then
 826          Register_Default_Naming_Scheme
 827            (Language            => Name_Ada,
 828             Default_Spec_Suffix => Default_Ada_Spec_Suffix,
 829             Default_Body_Suffix => Default_Ada_Body_Suffix,
 830             In_Tree             => Tree);
 831          Tree.Private_Part.Default_Naming.Separate_Suffix :=
 832            Default_Ada_Body_Suffix;
 833       end if;
 834    end Reset;
 835
 836    ------------------------
 837    -- Same_Naming_Scheme --
 838    ------------------------
 839
 840    function Same_Naming_Scheme
 841      (Left, Right : Naming_Data) return Boolean
 842    is
 843    begin
 844       return Left.Dot_Replacement = Right.Dot_Replacement
 845         and then Left.Casing = Right.Casing
 846         and then Left.Separate_Suffix = Right.Separate_Suffix;
 847    end Same_Naming_Scheme;
 848
 849    ---------------------
 850    -- Set_Body_Suffix --
 851    ---------------------
 852
 853    procedure Set_Body_Suffix
 854      (In_Tree  : Project_Tree_Ref;
 855       Language : String;
 856       Naming   : in out Naming_Data;
 857       Suffix   : File_Name_Type)
 858    is
 859       Language_Id : Name_Id;
 860       Element     : Array_Element;
 861
 862    begin
 863       Name_Len := 0;
 864       Add_Str_To_Name_Buffer (Language);
 865       To_Lower (Name_Buffer (1 .. Name_Len));
 866       Language_Id := Name_Find;
 867
 868       Element :=
 869         (Index                => Language_Id,
 870          Src_Index            => 0,
 871          Index_Case_Sensitive => False,
 872          Value                =>
 873            (Kind     => Single,
 874             Project  => No_Project,
 875             Location => No_Location,
 876             Default  => False,
 877             Value    => Name_Id (Suffix),
 878             Index    => 0),
 879          Next                 => Naming.Body_Suffix);
 880
 881       Array_Element_Table.Increment_Last (In_Tree.Array_Elements);
 882       Naming.Body_Suffix :=
 883          Array_Element_Table.Last (In_Tree.Array_Elements);
 884       In_Tree.Array_Elements.Table (Naming.Body_Suffix) := Element;
 885    end Set_Body_Suffix;
 886
 887    --------------------------
 888    -- Set_In_Configuration --
 889    --------------------------
 890
 891    procedure Set_In_Configuration (Value : Boolean) is
 892    begin
 893       Configuration_Mode := Value;
 894    end Set_In_Configuration;
 895
 896    --------------
 897    -- Set_Mode --
 898    --------------
 899
 900    procedure Set_Mode (New_Mode : Mode) is
 901    begin
 902       Current_Mode := New_Mode;
 903       case New_Mode is
 904          when Ada_Only =>
 905             Default_Language_Is_Ada := True;
 906             Must_Check_Configuration := False;
 907          when Multi_Language =>
 908             Default_Language_Is_Ada := False;
 909             Must_Check_Configuration := True;
 910       end case;
 911    end Set_Mode;
 912
 913    ---------------------
 914    -- Set_Spec_Suffix --
 915    ---------------------
 916
 917    procedure Set_Spec_Suffix
 918      (In_Tree  : Project_Tree_Ref;
 919       Language : String;
 920       Naming   : in out Naming_Data;
 921       Suffix   : File_Name_Type)
 922    is
 923       Language_Id : Name_Id;
 924       Element     : Array_Element;
 925
 926    begin
 927       Name_Len := 0;
 928       Add_Str_To_Name_Buffer (Language);
 929       To_Lower (Name_Buffer (1 .. Name_Len));
 930       Language_Id := Name_Find;
 931
 932       Element :=
 933         (Index                => Language_Id,
 934          Src_Index            => 0,
 935          Index_Case_Sensitive => False,
 936          Value                =>
 937            (Kind     => Single,
 938             Project  => No_Project,
 939             Location => No_Location,
 940             Default  => False,
 941             Value    => Name_Id (Suffix),
 942             Index    => 0),
 943          Next                 => Naming.Spec_Suffix);
 944
 945       Array_Element_Table.Increment_Last (In_Tree.Array_Elements);
 946       Naming.Spec_Suffix :=
 947         Array_Element_Table.Last (In_Tree.Array_Elements);
 948       In_Tree.Array_Elements.Table (Naming.Spec_Suffix) := Element;
 949    end Set_Spec_Suffix;
 950
 951    -----------
 952    -- Slash --
 953    -----------
 954
 955    function Slash return Path_Name_Type is
 956    begin
 957       return Slash_Id;
 958    end Slash;
 959
 960    -----------------------
 961    -- Spec_Suffix_Id_Of --
 962    -----------------------
 963
 964    function Spec_Suffix_Id_Of
 965      (In_Tree     : Project_Tree_Ref;
 966       Language_Id : Name_Id;
 967       Naming      : Naming_Data) return File_Name_Type
 968    is
 969       Element_Id : Array_Element_Id;
 970       Element    : Array_Element;
 971
 972    begin
 973       Element_Id := Naming.Spec_Suffix;
 974       while Element_Id /= No_Array_Element loop
 975          Element := In_Tree.Array_Elements.Table (Element_Id);
 976
 977          if Element.Index = Language_Id then
 978             return File_Name_Type (Element.Value.Value);
 979          end if;
 980
 981          Element_Id := Element.Next;
 982       end loop;
 983
 984       return No_File;
 985    end Spec_Suffix_Id_Of;
 986
 987    --------------------
 988    -- Spec_Suffix_Of --
 989    --------------------
 990
 991    function Spec_Suffix_Of
 992      (In_Tree  : Project_Tree_Ref;
 993       Language : String;
 994       Naming   : Naming_Data) return String
 995    is
 996       Language_Id : Name_Id;
 997       Element_Id  : Array_Element_Id;
 998       Element     : Array_Element;
 999
1000    begin
1001       Name_Len := 0;
1002       Add_Str_To_Name_Buffer (Language);
1003       To_Lower (Name_Buffer (1 .. Name_Len));
1004       Language_Id := Name_Find;
1005
1006       Element_Id := Naming.Spec_Suffix;
1007       while Element_Id /= No_Array_Element loop
1008          Element := In_Tree.Array_Elements.Table (Element_Id);
1009
1010          if Element.Index = Language_Id then
1011             return Get_Name_String (Element.Value.Value);
1012          end if;
1013
1014          Element_Id := Element.Next;
1015       end loop;
1016
1017       return "";
1018    end Spec_Suffix_Of;
1019
1020    --------------------------
1021    -- Standard_Naming_Data --
1022    --------------------------
1023
1024    function Standard_Naming_Data
1025      (Tree : Project_Tree_Ref := No_Project_Tree) return Naming_Data
1026    is
1027    begin
1028       if Tree = No_Project_Tree then
1029          Prj.Initialize (Tree => No_Project_Tree);
1030          return Std_Naming_Data;
1031       else
1032          return Tree.Private_Part.Default_Naming;
1033       end if;
1034    end Standard_Naming_Data;
1035
1036    -------------------
1037    -- Switches_Name --
1038    -------------------
1039
1040    function Switches_Name
1041      (Source_File_Name : File_Name_Type) return File_Name_Type
1042    is
1043    begin
1044       return Extend_Name (Source_File_Name, Switches_Dependency_Suffix);
1045    end Switches_Name;
1046
1047    -----------
1048    -- Value --
1049    -----------
1050
1051    function Value (Image : String) return Casing_Type is
1052    begin
1053       for Casing in The_Casing_Images'Range loop
1054          if To_Lower (Image) = To_Lower (The_Casing_Images (Casing).all) then
1055             return Casing;
1056          end if;
1057       end loop;
1058
1059       raise Constraint_Error;
1060    end Value;
1061
1062 begin
1063    --  Make sure that the standard config and user project file extensions are
1064    --  compatible with canonical case file naming.
1065
1066    Canonical_Case_File_Name (Config_Project_File_Extension);
1067    Canonical_Case_File_Name (Project_File_Extension);
1068 end Prj;