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