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