gcc/ada/prj.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                                  P R J                                   --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 2001-2009, Free Software Foundation, Inc.         --
  10 --                                                                          --
  11 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  12 -- terms of the  GNU General Public License as published  by the Free Soft- --
  13 -- ware  Foundation;  either version 3,  or (at your option) any later ver- --
  14 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  15 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  16 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  17 -- for  more details.  You should have  received  a copy of the GNU General --
  18 -- Public License  distributed with GNAT; see file COPYING3.  If not, go to --
  19 -- http://www.gnu.org/licenses for a complete copy of the license.          --
  20 --                                                                          --
  21 -- GNAT was originally developed  by the GNAT team at  New York University. --
  22 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  23 --                                                                          --
  24 ------------------------------------------------------------------------------
  25
  26 with Ada.Characters.Handling; use Ada.Characters.Handling;
  27 with Ada.Unchecked_Deallocation;
  28
  29 with Debug;
  30 with Osint;    use Osint;
  31 with Prj.Attr;
  32 with Prj.Err;  use Prj.Err;
  33 with Snames;   use Snames;
  34 with Table;
  35 with Uintp;    use Uintp;
  36
  37 with GNAT.Directory_Operations; use GNAT.Directory_Operations;
  38
  39 with System.Case_Util; use System.Case_Util;
  40 with System.HTable;
  41
  42 package body Prj is
  43
  44    Object_Suffix : constant String := Get_Target_Object_Suffix.all;
  45    --  File suffix for object files
  46
  47    Initial_Buffer_Size : constant := 100;
  48    --  Initial size for extensible buffer used in Add_To_Buffer
  49
  50    Current_Mode : Mode := Ada_Only;
  51
  52    The_Empty_String : Name_Id;
  53
  54    Default_Ada_Spec_Suffix_Id : File_Name_Type;
  55    Default_Ada_Body_Suffix_Id : File_Name_Type;
  56    --  Initialized in Prj.Initialize, then never modified
  57
  58    subtype Known_Casing is Casing_Type range All_Upper_Case .. Mixed_Case;
  59
  60    The_Casing_Images : constant array (Known_Casing) of String_Access :=
  61      (All_Lower_Case => new String'("lowercase"),
  62       All_Upper_Case => new String'("UPPERCASE"),
  63       Mixed_Case     => new String'("MixedCase"));
  64
  65    Initialized : Boolean := False;
  66
  67    Project_Empty : constant Project_Data :=
  68                      (Qualifier                      => Unspecified,
  69                       Externally_Built               => False,
  70                       Config                         => Default_Project_Config,
  71                       Name                           => No_Name,
  72                       Display_Name                   => No_Name,
  73                       Path                           => No_Path_Information,
  74                       Virtual                        => False,
  75                       Location                       => No_Location,
  76                       Mains                          => Nil_String,
  77                       Directory                      => No_Path_Information,
  78                       Library                        => False,
  79                       Library_Dir                    => No_Path_Information,
  80                       Library_Src_Dir                => No_Path_Information,
  81                       Library_ALI_Dir                => No_Path_Information,
  82                       Library_Name                   => No_Name,
  83                       Library_Kind                   => Static,
  84                       Lib_Internal_Name              => No_Name,
  85                       Standalone_Library             => False,
  86                       Lib_Interface_ALIs             => Nil_String,
  87                       Lib_Auto_Init                  => False,
  88                       Libgnarl_Needed                => Unknown,
  89                       Symbol_Data                    => No_Symbols,
  90                       Interfaces_Defined             => False,
  91                       Include_Path                   => null,
  92                       Include_Data_Set               => False,
  93                       Source_Dirs                    => Nil_String,
  94                       Known_Order_Of_Source_Dirs     => True,
  95                       Object_Directory               => No_Path_Information,
  96                       Library_TS                     => Empty_Time_Stamp,
  97                       Exec_Directory                 => No_Path_Information,
  98                       Extends                        => No_Project,
  99                       Extended_By                    => No_Project,
 100                       Languages                      => No_Language_Index,
 101                       Decl                           => No_Declarations,
 102                       Imported_Projects              => null,
 103                       All_Imported_Projects          => null,
 104                       Ada_Include_Path               => null,
 105                       Ada_Objects_Path               => null,
 106                       Objects_Path                   => null,
 107                       Include_Path_File              => No_Path,
 108                       Objects_Path_File_With_Libs    => No_Path,
 109                       Objects_Path_File_Without_Libs => No_Path,
 110                       Config_File_Name               => No_Path,
 111                       Config_File_Temp               => False,
 112                       Config_Checked                 => False,
 113                       Need_To_Build_Lib              => False,
 114                       Depth                          => 0,
 115                       Unkept_Comments                => False);
 116
 117    package Temp_Files is new Table.Table
 118      (Table_Component_Type => Path_Name_Type,
 119       Table_Index_Type     => Integer,
 120       Table_Low_Bound      => 1,
 121       Table_Initial        => 20,
 122       Table_Increment      => 100,
 123       Table_Name           => "Makegpr.Temp_Files");
 124    --  Table to store the path name of all the created temporary files, so that
 125    --  they can be deleted at the end, or when the program is interrupted.
 126
 127    procedure Free (Project : in out Project_Id);
 128    --  Free memory allocated for Project
 129
 130    procedure Free_List (Languages : in out Language_Ptr);
 131    procedure Free_List (Source : in out Source_Id);
 132    procedure Free_List (Languages : in out Language_List);
 133    --  Free memory allocated for the list of languages or sources
 134
 135    procedure Free_Units (Table : in out Units_Htable.Instance);
 136    --  Free memory allocated for unit information in the project
 137
 138    procedure Language_Changed (Iter : in out Source_Iterator);
 139    procedure Project_Changed (Iter : in out Source_Iterator);
 140    --  Called when a new project or language was selected for this iterator
 141
 142    function Contains_ALI_Files (Dir : Path_Name_Type) return Boolean;
 143    --  Return True if there is at least one ALI file in the directory Dir
 144
 145    -------------------
 146    -- Add_To_Buffer --
 147    -------------------
 148
 149    procedure Add_To_Buffer
 150      (S    : String;
 151       To   : in out String_Access;
 152       Last : in out Natural)
 153    is
 154    begin
 155       if To = null then
 156          To := new String (1 .. Initial_Buffer_Size);
 157          Last := 0;
 158       end if;
 159
 160       --  If Buffer is too small, double its size
 161
 162       while Last + S'Length > To'Last loop
 163          declare
 164             New_Buffer : constant  String_Access :=
 165                            new String (1 .. 2 * Last);
 166
 167          begin
 168             New_Buffer (1 .. Last) := To (1 .. Last);
 169             Free (To);
 170             To := New_Buffer;
 171          end;
 172       end loop;
 173
 174       To (Last + 1 .. Last + S'Length) := S;
 175       Last := Last + S'Length;
 176    end Add_To_Buffer;
 177
 178    -----------------------------
 179    -- Default_Ada_Body_Suffix --
 180    -----------------------------
 181
 182    function Default_Ada_Body_Suffix return File_Name_Type is
 183    begin
 184       return Default_Ada_Body_Suffix_Id;
 185    end Default_Ada_Body_Suffix;
 186
 187    -----------------------------
 188    -- Default_Ada_Spec_Suffix --
 189    -----------------------------
 190
 191    function Default_Ada_Spec_Suffix return File_Name_Type is
 192    begin
 193       return Default_Ada_Spec_Suffix_Id;
 194    end Default_Ada_Spec_Suffix;
 195
 196    ---------------------------
 197    -- Delete_All_Temp_Files --
 198    ---------------------------
 199
 200    procedure Delete_All_Temp_Files is
 201       Dont_Care : Boolean;
 202       pragma Warnings (Off, Dont_Care);
 203    begin
 204       if not Debug.Debug_Flag_N then
 205          for Index in 1 .. Temp_Files.Last loop
 206             Delete_File
 207               (Get_Name_String (Temp_Files.Table (Index)), Dont_Care);
 208          end loop;
 209       end if;
 210    end Delete_All_Temp_Files;
 211
 212    ---------------------
 213    -- Dependency_Name --
 214    ---------------------
 215
 216    function Dependency_Name
 217      (Source_File_Name : File_Name_Type;
 218       Dependency       : Dependency_File_Kind) return File_Name_Type
 219    is
 220    begin
 221       case Dependency is
 222          when None =>
 223             return No_File;
 224
 225          when Makefile =>
 226             return
 227               File_Name_Type
 228                 (Extend_Name
 229                    (Source_File_Name, Makefile_Dependency_Suffix));
 230
 231          when ALI_File =>
 232             return
 233               File_Name_Type
 234                 (Extend_Name
 235                    (Source_File_Name, ALI_Dependency_Suffix));
 236       end case;
 237    end Dependency_Name;
 238
 239    ----------------
 240    -- Empty_File --
 241    ----------------
 242
 243    function Empty_File return File_Name_Type is
 244    begin
 245       return File_Name_Type (The_Empty_String);
 246    end Empty_File;
 247
 248    -------------------
 249    -- Empty_Project --
 250    -------------------
 251
 252    function Empty_Project return Project_Data is
 253    begin
 254       Prj.Initialize (Tree => No_Project_Tree);
 255       return Project_Empty;
 256    end Empty_Project;
 257
 258    ------------------
 259    -- Empty_String --
 260    ------------------
 261
 262    function Empty_String return Name_Id is
 263    begin
 264       return The_Empty_String;
 265    end Empty_String;
 266
 267    ------------
 268    -- Expect --
 269    ------------
 270
 271    procedure Expect (The_Token : Token_Type; Token_Image : String) is
 272    begin
 273       if Token /= The_Token then
 274          Error_Msg (Token_Image & " expected", Token_Ptr);
 275       end if;
 276    end Expect;
 277
 278    -----------------
 279    -- Extend_Name --
 280    -----------------
 281
 282    function Extend_Name
 283      (File        : File_Name_Type;
 284       With_Suffix : String) return File_Name_Type
 285    is
 286       Last : Positive;
 287
 288    begin
 289       Get_Name_String (File);
 290       Last := Name_Len + 1;
 291
 292       while Name_Len /= 0 and then Name_Buffer (Name_Len) /= '.' loop
 293          Name_Len := Name_Len - 1;
 294       end loop;
 295
 296       if Name_Len <= 1 then
 297          Name_Len := Last;
 298       end if;
 299
 300       for J in With_Suffix'Range loop
 301          Name_Buffer (Name_Len) := With_Suffix (J);
 302          Name_Len := Name_Len + 1;
 303       end loop;
 304
 305       Name_Len := Name_Len - 1;
 306       return Name_Find;
 307
 308    end Extend_Name;
 309
 310    ---------------------
 311    -- Project_Changed --
 312    ---------------------
 313
 314    procedure Project_Changed (Iter : in out Source_Iterator) is
 315    begin
 316       Iter.Language := Iter.Project.Project.Languages;
 317       Language_Changed (Iter);
 318    end Project_Changed;
 319
 320    ----------------------
 321    -- Language_Changed --
 322    ----------------------
 323
 324    procedure Language_Changed (Iter : in out Source_Iterator) is
 325    begin
 326       Iter.Current  := No_Source;
 327
 328       if Iter.Language_Name /= No_Name then
 329          while Iter.Language /= null
 330            and then Iter.Language.Name /= Iter.Language_Name
 331          loop
 332             Iter.Language := Iter.Language.Next;
 333          end loop;
 334       end if;
 335
 336       --  If there is no matching language in this project, move to next
 337
 338       if Iter.Language = No_Language_Index then
 339          if Iter.All_Projects then
 340             Iter.Project := Iter.Project.Next;
 341
 342             if Iter.Project /= null then
 343                Project_Changed (Iter);
 344             end if;
 345
 346          else
 347             Iter.Project := null;
 348          end if;
 349
 350       else
 351          Iter.Current := Iter.Language.First_Source;
 352
 353          if Iter.Current = No_Source then
 354             Iter.Language := Iter.Language.Next;
 355             Language_Changed (Iter);
 356          end if;
 357       end if;
 358    end Language_Changed;
 359
 360    ---------------------
 361    -- For_Each_Source --
 362    ---------------------
 363
 364    function For_Each_Source
 365      (In_Tree  : Project_Tree_Ref;
 366       Project  : Project_Id := No_Project;
 367       Language : Name_Id := No_Name) return Source_Iterator
 368    is
 369       Iter : Source_Iterator;
 370    begin
 371       Iter := Source_Iterator'
 372         (In_Tree       => In_Tree,
 373          Project       => In_Tree.Projects,
 374          All_Projects  => Project = No_Project,
 375          Language_Name => Language,
 376          Language      => No_Language_Index,
 377          Current       => No_Source);
 378
 379       if Project /= null then
 380          while Iter.Project /= null
 381            and then Iter.Project.Project /= Project
 382          loop
 383             Iter.Project := Iter.Project.Next;
 384          end loop;
 385       end if;
 386
 387       Project_Changed (Iter);
 388
 389       return Iter;
 390    end For_Each_Source;
 391
 392    -------------
 393    -- Element --
 394    -------------
 395
 396    function Element (Iter : Source_Iterator) return Source_Id is
 397    begin
 398       return Iter.Current;
 399    end Element;
 400
 401    ----------
 402    -- Next --
 403    ----------
 404
 405    procedure Next (Iter : in out Source_Iterator) is
 406    begin
 407       Iter.Current := Iter.Current.Next_In_Lang;
 408       if Iter.Current = No_Source then
 409          Iter.Language := Iter.Language.Next;
 410          Language_Changed (Iter);
 411       end if;
 412    end Next;
 413
 414    --------------------------------
 415    -- For_Every_Project_Imported --
 416    --------------------------------
 417
 418    procedure For_Every_Project_Imported
 419      (By             : Project_Id;
 420       With_State     : in out State;
 421       Imported_First : Boolean := False)
 422    is
 423       use Project_Boolean_Htable;
 424       Seen : Project_Boolean_Htable.Instance := Project_Boolean_Htable.Nil;
 425
 426       procedure Recursive_Check (Project : Project_Id);
 427       --  Check if a project has already been seen. If not seen, mark it as
 428       --  Seen, Call Action, and check all its imported projects.
 429
 430       ---------------------
 431       -- Recursive_Check --
 432       ---------------------
 433
 434       procedure Recursive_Check (Project : Project_Id) is
 435          List : Project_List;
 436
 437       begin
 438          if not Get (Seen, Project) then
 439             Set (Seen, Project, True);
 440
 441             if not Imported_First then
 442                Action (Project, With_State);
 443             end if;
 444
 445             --  Visited all extended projects
 446
 447             if Project.Extends /= No_Project then
 448                Recursive_Check (Project.Extends);
 449             end if;
 450
 451             --  Visited all imported projects
 452
 453             List := Project.Imported_Projects;
 454             while List /= null loop
 455                Recursive_Check (List.Project);
 456                List := List.Next;
 457             end loop;
 458
 459             if Imported_First then
 460                Action (Project, With_State);
 461             end if;
 462          end if;
 463       end Recursive_Check;
 464
 465    --  Start of processing for For_Every_Project_Imported
 466
 467    begin
 468       Recursive_Check (Project => By);
 469       Reset (Seen);
 470    end For_Every_Project_Imported;
 471
 472    -----------------
 473    -- Find_Source --
 474    -----------------
 475
 476    function Find_Source
 477      (In_Tree          : Project_Tree_Ref;
 478       Project          : Project_Id;
 479       In_Imported_Only : Boolean;
 480       Base_Name        : File_Name_Type) return Source_Id
 481    is
 482       Result : Source_Id  := No_Source;
 483
 484       procedure Look_For_Sources (Proj : Project_Id; Src : in out Source_Id);
 485       --  Look for Base_Name in the sources of Proj
 486
 487       ----------------------
 488       -- Look_For_Sources --
 489       ----------------------
 490
 491       procedure Look_For_Sources (Proj : Project_Id; Src : in out Source_Id) is
 492          Iterator : Source_Iterator;
 493
 494       begin
 495          Iterator := For_Each_Source (In_Tree => In_Tree, Project => Proj);
 496          while Element (Iterator) /= No_Source loop
 497             if Element (Iterator).File = Base_Name then
 498                Src := Element (Iterator);
 499                return;
 500             end if;
 501
 502             Next (Iterator);
 503          end loop;
 504       end Look_For_Sources;
 505
 506       procedure For_Imported_Projects is new For_Every_Project_Imported
 507         (State => Source_Id, Action => Look_For_Sources);
 508
 509    --  Start of processing for Find_Source
 510
 511    begin
 512       if In_Imported_Only then
 513          Look_For_Sources (Project, Result);
 514
 515          if Result = No_Source then
 516             For_Imported_Projects
 517               (By         => Project,
 518                With_State => Result);
 519          end if;
 520       else
 521          Look_For_Sources (No_Project, Result);
 522       end if;
 523
 524       return Result;
 525    end Find_Source;
 526
 527    --------------
 528    -- Get_Mode --
 529    --------------
 530
 531    function Get_Mode return Mode is
 532    begin
 533       return Current_Mode;
 534    end Get_Mode;
 535
 536    ----------
 537    -- Hash --
 538    ----------
 539
 540    function Hash is new System.HTable.Hash (Header_Num => Header_Num);
 541    --  Used in implementation of other functions Hash below
 542
 543    function Hash (Name : File_Name_Type) return Header_Num is
 544    begin
 545       return Hash (Get_Name_String (Name));
 546    end Hash;
 547
 548    function Hash (Name : Name_Id) return Header_Num is
 549    begin
 550       return Hash (Get_Name_String (Name));
 551    end Hash;
 552
 553    function Hash (Name : Path_Name_Type) return Header_Num is
 554    begin
 555       return Hash (Get_Name_String (Name));
 556    end Hash;
 557
 558    function Hash (Project : Project_Id) return Header_Num is
 559    begin
 560       if Project = No_Project then
 561          return Header_Num'First;
 562       else
 563          return Hash (Get_Name_String (Project.Name));
 564       end if;
 565    end Hash;
 566
 567    -----------
 568    -- Image --
 569    -----------
 570
 571    function Image (Casing : Casing_Type) return String is
 572    begin
 573       return The_Casing_Images (Casing).all;
 574    end Image;
 575
 576    ----------------
 577    -- Initialize --
 578    ----------------
 579
 580    procedure Initialize (Tree : Project_Tree_Ref) is
 581    begin
 582       if not Initialized then
 583          Initialized := True;
 584          Uintp.Initialize;
 585          Name_Len := 0;
 586          The_Empty_String := Name_Find;
 587          Empty_Name := The_Empty_String;
 588          Empty_File_Name := File_Name_Type (The_Empty_String);
 589          Name_Len := 4;
 590          Name_Buffer (1 .. 4) := ".ads";
 591          Default_Ada_Spec_Suffix_Id := Name_Find;
 592          Name_Len := 4;
 593          Name_Buffer (1 .. 4) := ".adb";
 594          Default_Ada_Body_Suffix_Id := Name_Find;
 595
 596          Prj.Attr.Initialize;
 597          Set_Name_Table_Byte (Name_Project,  Token_Type'Pos (Tok_Project));
 598          Set_Name_Table_Byte (Name_Extends,  Token_Type'Pos (Tok_Extends));
 599          Set_Name_Table_Byte (Name_External, Token_Type'Pos (Tok_External));
 600       end if;
 601
 602       if Tree /= No_Project_Tree then
 603          Reset (Tree);
 604       end if;
 605    end Initialize;
 606
 607    -------------------
 608    -- Is_A_Language --
 609    -------------------
 610
 611    function Is_A_Language
 612      (Project       : Project_Id;
 613       Language_Name : Name_Id) return Boolean is
 614    begin
 615       return Get_Language_From_Name
 616         (Project, Get_Name_String (Language_Name)) /= null;
 617    end Is_A_Language;
 618
 619    ------------------
 620    -- Is_Extending --
 621    ------------------
 622
 623    function Is_Extending
 624      (Extending : Project_Id;
 625       Extended  : Project_Id) return Boolean
 626    is
 627       Proj : Project_Id;
 628
 629    begin
 630       Proj := Extending;
 631       while Proj /= No_Project loop
 632          if Proj = Extended then
 633             return True;
 634          end if;
 635
 636          Proj := Proj.Extends;
 637       end loop;
 638
 639       return False;
 640    end Is_Extending;
 641
 642    -----------------
 643    -- Object_Name --
 644    -----------------
 645
 646    function Object_Name
 647      (Source_File_Name   : File_Name_Type;
 648       Object_File_Suffix : Name_Id := No_Name) return File_Name_Type
 649    is
 650    begin
 651       if Object_File_Suffix = No_Name then
 652          return Extend_Name
 653            (Source_File_Name, Object_Suffix);
 654       else
 655          return Extend_Name
 656            (Source_File_Name, Get_Name_String (Object_File_Suffix));
 657       end if;
 658    end Object_Name;
 659
 660    ----------------------
 661    -- Record_Temp_File --
 662    ----------------------
 663
 664    procedure Record_Temp_File (Path : Path_Name_Type) is
 665    begin
 666       Temp_Files.Increment_Last;
 667       Temp_Files.Table (Temp_Files.Last) := Path;
 668    end Record_Temp_File;
 669
 670    ----------
 671    -- Free --
 672    ----------
 673
 674    procedure Free (Project : in out Project_Id) is
 675       procedure Unchecked_Free is new Ada.Unchecked_Deallocation
 676         (Project_Data, Project_Id);
 677
 678    begin
 679       if Project /= null then
 680          Free (Project.Include_Path);
 681          Free (Project.Ada_Include_Path);
 682          Free (Project.Objects_Path);
 683          Free (Project.Ada_Objects_Path);
 684          Free_List (Project.Imported_Projects, Free_Project => False);
 685          Free_List (Project.All_Imported_Projects, Free_Project => False);
 686          Free_List (Project.Languages);
 687
 688          Unchecked_Free (Project);
 689       end if;
 690    end Free;
 691
 692    ---------------
 693    -- Free_List --
 694    ---------------
 695
 696    procedure Free_List (Languages : in out Language_List) is
 697       procedure Unchecked_Free is new Ada.Unchecked_Deallocation
 698         (Language_List_Element, Language_List);
 699       Tmp : Language_List;
 700    begin
 701       while Languages /= null loop
 702          Tmp := Languages.Next;
 703          Unchecked_Free (Languages);
 704          Languages := Tmp;
 705       end loop;
 706    end Free_List;
 707
 708    ---------------
 709    -- Free_List --
 710    ---------------
 711
 712    procedure Free_List (Source : in out Source_Id) is
 713       procedure Unchecked_Free is new
 714         Ada.Unchecked_Deallocation (Source_Data, Source_Id);
 715
 716       Tmp : Source_Id;
 717
 718    begin
 719       while Source /= No_Source loop
 720          Tmp := Source.Next_In_Lang;
 721          Free_List (Source.Alternate_Languages);
 722
 723          if Source.Unit /= null
 724            and then Source.Kind in Spec_Or_Body
 725          then
 726             Source.Unit.File_Names (Source.Kind) := null;
 727          end if;
 728
 729          Unchecked_Free (Source);
 730          Source := Tmp;
 731       end loop;
 732    end Free_List;
 733
 734    ---------------
 735    -- Free_List --
 736    ---------------
 737
 738    procedure Free_List
 739      (List         : in out Project_List;
 740       Free_Project : Boolean)
 741    is
 742       procedure Unchecked_Free is new
 743         Ada.Unchecked_Deallocation (Project_List_Element, Project_List);
 744
 745       Tmp : Project_List;
 746
 747    begin
 748       while List /= null loop
 749          Tmp := List.Next;
 750
 751          if Free_Project then
 752             Free (List.Project);
 753          end if;
 754
 755          Unchecked_Free (List);
 756          List := Tmp;
 757       end loop;
 758    end Free_List;
 759
 760    ---------------
 761    -- Free_List --
 762    ---------------
 763
 764    procedure Free_List (Languages : in out Language_Ptr) is
 765       procedure Unchecked_Free is new
 766         Ada.Unchecked_Deallocation (Language_Data, Language_Ptr);
 767
 768       Tmp : Language_Ptr;
 769
 770    begin
 771       while Languages /= null loop
 772          Tmp := Languages.Next;
 773          Free_List (Languages.First_Source);
 774          Unchecked_Free (Languages);
 775          Languages := Tmp;
 776       end loop;
 777    end Free_List;
 778
 779    ----------------
 780    -- Free_Units --
 781    ----------------
 782
 783    procedure Free_Units (Table : in out Units_Htable.Instance) is
 784       procedure Unchecked_Free is new
 785         Ada.Unchecked_Deallocation (Unit_Data, Unit_Index);
 786
 787       Unit : Unit_Index;
 788
 789    begin
 790       Unit := Units_Htable.Get_First (Table);
 791       while Unit /= No_Unit_Index loop
 792          if Unit.File_Names (Spec) /= null then
 793             Unit.File_Names (Spec).Unit := No_Unit_Index;
 794          end if;
 795
 796          if Unit.File_Names (Impl) /= null then
 797             Unit.File_Names (Impl).Unit := No_Unit_Index;
 798          end if;
 799
 800          Unchecked_Free (Unit);
 801          Unit := Units_Htable.Get_Next (Table);
 802       end loop;
 803
 804       Units_Htable.Reset (Table);
 805    end Free_Units;
 806
 807    ----------
 808    -- Free --
 809    ----------
 810
 811    procedure Free (Tree : in out Project_Tree_Ref) is
 812       procedure Unchecked_Free is new
 813         Ada.Unchecked_Deallocation (Project_Tree_Data, Project_Tree_Ref);
 814
 815    begin
 816       if Tree /= null then
 817          Name_List_Table.Free (Tree.Name_Lists);
 818          String_Element_Table.Free (Tree.String_Elements);
 819          Variable_Element_Table.Free (Tree.Variable_Elements);
 820          Array_Element_Table.Free (Tree.Array_Elements);
 821          Array_Table.Free (Tree.Arrays);
 822          Package_Table.Free (Tree.Packages);
 823          Source_Paths_Htable.Reset (Tree.Source_Paths_HT);
 824          Unit_Sources_Htable.Reset (Tree.Unit_Sources_HT);
 825
 826          Free_List (Tree.Projects, Free_Project => True);
 827          Free_Units (Tree.Units_HT);
 828
 829          --  Private part
 830
 831          Path_File_Table.Free   (Tree.Private_Part.Path_Files);
 832          Source_Path_Table.Free (Tree.Private_Part.Source_Paths);
 833          Object_Path_Table.Free (Tree.Private_Part.Object_Paths);
 834
 835          Free (Tree.Private_Part.Ada_Path_Buffer);
 836
 837          --  Naming data (nothing to free ???)
 838
 839          null;
 840
 841          Unchecked_Free (Tree);
 842       end if;
 843    end Free;
 844
 845    -----------
 846    -- Reset --
 847    -----------
 848
 849    procedure Reset (Tree : Project_Tree_Ref) is
 850    begin
 851       --  Visible tables
 852
 853       Name_List_Table.Init          (Tree.Name_Lists);
 854       String_Element_Table.Init     (Tree.String_Elements);
 855       Variable_Element_Table.Init   (Tree.Variable_Elements);
 856       Array_Element_Table.Init      (Tree.Array_Elements);
 857       Array_Table.Init              (Tree.Arrays);
 858       Package_Table.Init            (Tree.Packages);
 859       Source_Paths_Htable.Reset     (Tree.Source_Paths_HT);
 860       Unit_Sources_Htable.Reset     (Tree.Unit_Sources_HT);
 861
 862       Free_List (Tree.Projects, Free_Project => True);
 863       Free_Units (Tree.Units_HT);
 864
 865       --  Private part table
 866
 867       Path_File_Table.Init        (Tree.Private_Part.Path_Files);
 868       Source_Path_Table.Init      (Tree.Private_Part.Source_Paths);
 869       Object_Path_Table.Init      (Tree.Private_Part.Object_Paths);
 870
 871       if Current_Mode = Ada_Only then
 872          Tree.Private_Part.Current_Source_Path_File := No_Path;
 873          Tree.Private_Part.Current_Object_Path_File := No_Path;
 874          Tree.Private_Part.Ada_Path_Length := 0;
 875          Tree.Private_Part.Ada_Prj_Include_File_Set := False;
 876          Tree.Private_Part.Ada_Prj_Objects_File_Set := False;
 877          Tree.Private_Part.Fill_Mapping_File := True;
 878       end if;
 879    end Reset;
 880
 881    --------------
 882    -- Set_Mode --
 883    --------------
 884
 885    procedure Set_Mode (New_Mode : Mode) is
 886    begin
 887       Current_Mode := New_Mode;
 888
 889       case New_Mode is
 890          when Ada_Only =>
 891             Default_Language_Is_Ada := True;
 892             Must_Check_Configuration := False;
 893          when Multi_Language =>
 894             Default_Language_Is_Ada := False;
 895             Must_Check_Configuration := True;
 896       end case;
 897    end Set_Mode;
 898
 899    -------------------
 900    -- Switches_Name --
 901    -------------------
 902
 903    function Switches_Name
 904      (Source_File_Name : File_Name_Type) return File_Name_Type
 905    is
 906    begin
 907       return Extend_Name (Source_File_Name, Switches_Dependency_Suffix);
 908    end Switches_Name;
 909
 910    -----------
 911    -- Value --
 912    -----------
 913
 914    function Value (Image : String) return Casing_Type is
 915    begin
 916       for Casing in The_Casing_Images'Range loop
 917          if To_Lower (Image) = To_Lower (The_Casing_Images (Casing).all) then
 918             return Casing;
 919          end if;
 920       end loop;
 921
 922       raise Constraint_Error;
 923    end Value;
 924
 925    ---------------------
 926    -- Has_Ada_Sources --
 927    ---------------------
 928
 929    function Has_Ada_Sources (Data : Project_Id) return Boolean is
 930       Lang : Language_Ptr;
 931
 932    begin
 933       Lang := Data.Languages;
 934       while Lang /= No_Language_Index loop
 935          if Lang.Name = Name_Ada then
 936             return Lang.First_Source /= No_Source;
 937          end if;
 938          Lang := Lang.Next;
 939       end loop;
 940
 941       return False;
 942    end Has_Ada_Sources;
 943
 944    -------------------------
 945    -- Has_Foreign_Sources --
 946    -------------------------
 947
 948    function Has_Foreign_Sources (Data : Project_Id) return Boolean is
 949       Lang : Language_Ptr;
 950
 951    begin
 952       Lang := Data.Languages;
 953       while Lang /= No_Language_Index loop
 954          if Lang.Name /= Name_Ada
 955            and then
 956              (Current_Mode = Ada_Only or else Lang.First_Source /= No_Source)
 957          then
 958             return True;
 959          end if;
 960
 961          Lang := Lang.Next;
 962       end loop;
 963
 964       return False;
 965    end Has_Foreign_Sources;
 966
 967    ------------------------
 968    -- Contains_ALI_Files --
 969    ------------------------
 970
 971    function Contains_ALI_Files (Dir : Path_Name_Type) return Boolean is
 972       Dir_Name : constant String := Get_Name_String (Dir);
 973       Direct   : Dir_Type;
 974       Name     : String (1 .. 1_000);
 975       Last     : Natural;
 976       Result   : Boolean := False;
 977
 978    begin
 979       Open (Direct, Dir_Name);
 980
 981       --  For each file in the directory, check if it is an ALI file
 982
 983       loop
 984          Read (Direct, Name, Last);
 985          exit when Last = 0;
 986          Canonical_Case_File_Name (Name (1 .. Last));
 987          Result := Last >= 5 and then Name (Last - 3 .. Last) = ".ali";
 988          exit when Result;
 989       end loop;
 990
 991       Close (Direct);
 992       return Result;
 993
 994    exception
 995       --  If there is any problem, close the directory if open and return True.
 996       --  The library directory will be added to the path.
 997
 998       when others =>
 999          if Is_Open (Direct) then
1000             Close (Direct);
1001          end if;
1002
1003          return True;
1004    end Contains_ALI_Files;
1005
1006    --------------------------
1007    -- Get_Object_Directory --
1008    --------------------------
1009
1010    function Get_Object_Directory
1011      (Project             : Project_Id;
1012       Including_Libraries : Boolean;
1013       Only_If_Ada         : Boolean := False) return Path_Name_Type
1014    is
1015    begin
1016       if (Project.Library and Including_Libraries)
1017         or else
1018           (Project.Object_Directory /= No_Path_Information
1019             and then (not Including_Libraries or else not Project.Library))
1020       then
1021          --  For a library project, add the library ALI directory if there is
1022          --  no object directory or if the library ALI directory contains ALI
1023          --  files; otherwise add the object directory.
1024
1025          if Project.Library then
1026             if Project.Object_Directory = No_Path_Information
1027               or else Contains_ALI_Files (Project.Library_ALI_Dir.Name)
1028             then
1029                return Project.Library_ALI_Dir.Name;
1030             else
1031                return Project.Object_Directory.Name;
1032             end if;
1033
1034             --  For a non-library project, add object directory if it is not a
1035             --  virtual project, and if there are Ada sources in the project or
1036             --  one of the projects it extends. If there are no Ada sources,
1037             --  adding the object directory could disrupt the order of the
1038             --  object dirs in the path.
1039
1040          elsif not Project.Virtual then
1041             declare
1042                Add_Object_Dir : Boolean;
1043                Prj            : Project_Id;
1044
1045             begin
1046                Add_Object_Dir := not Only_If_Ada;
1047                Prj := Project;
1048                while not Add_Object_Dir and then Prj /= No_Project loop
1049                   if Has_Ada_Sources (Prj) then
1050                      Add_Object_Dir := True;
1051                   else
1052                      Prj := Prj.Extends;
1053                   end if;
1054                end loop;
1055
1056                if Add_Object_Dir then
1057                   return Project.Object_Directory.Name;
1058                end if;
1059             end;
1060          end if;
1061       end if;
1062
1063       return No_Path;
1064    end Get_Object_Directory;
1065
1066    -----------------------------------
1067    -- Ultimate_Extending_Project_Of --
1068    -----------------------------------
1069
1070    function Ultimate_Extending_Project_Of
1071      (Proj : Project_Id) return Project_Id
1072    is
1073       Prj : Project_Id;
1074
1075    begin
1076       Prj := Proj;
1077       while Prj /= null and then Prj.Extended_By /= No_Project loop
1078          Prj := Prj.Extended_By;
1079       end loop;
1080
1081       return Prj;
1082    end Ultimate_Extending_Project_Of;
1083
1084    -----------------------------------
1085    -- Compute_All_Imported_Projects --
1086    -----------------------------------
1087
1088    procedure Compute_All_Imported_Projects (Project : Project_Id) is
1089       procedure Recursive_Add (Prj : Project_Id; Dummy : in out Boolean);
1090       --  Recursively add the projects imported by project Project, but not
1091       --  those that are extended.
1092
1093       -------------------
1094       -- Recursive_Add --
1095       -------------------
1096
1097       procedure Recursive_Add (Prj : Project_Id; Dummy : in out Boolean) is
1098          pragma Unreferenced (Dummy);
1099          List    : Project_List;
1100          Prj2    : Project_Id;
1101
1102       begin
1103          --  A project is not importing itself
1104
1105          if Project /= Prj then
1106             Prj2 := Ultimate_Extending_Project_Of (Prj);
1107
1108             --  Check that the project is not already in the list. We know the
1109             --  one passed to Recursive_Add have never been visited before, but
1110             --  the one passed it are the extended projects.
1111
1112             List := Project.All_Imported_Projects;
1113             while List /= null loop
1114                if List.Project = Prj2 then
1115                   return;
1116                end if;
1117                List := List.Next;
1118             end loop;
1119
1120             --  Add it to the list
1121
1122             Project.All_Imported_Projects :=
1123               new Project_List_Element'
1124                 (Project => Prj2,
1125                  Next    => Project.All_Imported_Projects);
1126          end if;
1127       end Recursive_Add;
1128
1129       procedure For_All_Projects is
1130         new For_Every_Project_Imported (Boolean, Recursive_Add);
1131       Dummy : Boolean := False;
1132
1133    begin
1134       Free_List (Project.All_Imported_Projects, Free_Project => False);
1135       For_All_Projects (Project, Dummy);
1136    end Compute_All_Imported_Projects;
1137
1138    -------------------
1139    -- Is_Compilable --
1140    -------------------
1141
1142    function Is_Compilable (Source : Source_Id) return Boolean is
1143    begin
1144       return Source.Language.Config.Compiler_Driver /= Empty_File_Name
1145         and then not Source.Locally_Removed;
1146    end Is_Compilable;
1147
1148    ------------------------------
1149    -- Object_To_Global_Archive --
1150    ------------------------------
1151
1152    function Object_To_Global_Archive (Source : Source_Id) return Boolean is
1153    begin
1154       return Source.Language.Config.Kind = File_Based
1155         and then Source.Kind = Impl
1156         and then Source.Language.Config.Objects_Linked
1157         and then Is_Compilable (Source)
1158         and then Source.Language.Config.Object_Generated;
1159    end Object_To_Global_Archive;
1160
1161    ----------------------------
1162    -- Get_Language_From_Name --
1163    ----------------------------
1164
1165    function Get_Language_From_Name
1166      (Project : Project_Id;
1167       Name    : String) return Language_Ptr
1168    is
1169       N      : Name_Id;
1170       Result : Language_Ptr;
1171
1172    begin
1173       Name_Len := Name'Length;
1174       Name_Buffer (1 .. Name_Len) := Name;
1175       To_Lower (Name_Buffer (1 .. Name_Len));
1176       N := Name_Find;
1177
1178       Result := Project.Languages;
1179       while Result /= No_Language_Index loop
1180          if Result.Name = N then
1181             return Result;
1182          end if;
1183
1184          Result := Result.Next;
1185       end loop;
1186
1187       return No_Language_Index;
1188    end Get_Language_From_Name;
1189
1190    ----------------
1191    -- Other_Part --
1192    ----------------
1193
1194    function Other_Part (Source : Source_Id) return Source_Id is
1195    begin
1196       if Source.Unit /= No_Unit_Index then
1197          case Source.Kind is
1198             when Impl =>
1199                return Source.Unit.File_Names (Spec);
1200             when Spec =>
1201                return Source.Unit.File_Names (Impl);
1202             when Sep =>
1203                return No_Source;
1204          end case;
1205       else
1206          return No_Source;
1207       end if;
1208    end Other_Part;
1209
1210 begin
1211    --  Make sure that the standard config and user project file extensions are
1212    --  compatible with canonical case file naming.
1213
1214    Canonical_Case_File_Name (Config_Project_File_Extension);
1215    Canonical_Case_File_Name (Project_File_Extension);
1216 end Prj;