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