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