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