gcc/ada/prj-util.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                              P R J . U T I L                             --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 2001-2015, 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.Containers.Indefinite_Ordered_Sets;
  27 with Ada.Directories;
  28 with Ada.Strings.Fixed;          use Ada.Strings.Fixed;
  29 with Ada.Strings.Maps;           use Ada.Strings.Maps;
  30 with Ada.Unchecked_Deallocation;
  31
  32 with GNAT.Case_Util; use GNAT.Case_Util;
  33 with GNAT.Regexp;    use GNAT.Regexp;
  34
  35 with ALI;      use ALI;
  36 with Osint;    use Osint;
  37 with Output;   use Output;
  38 with Opt;
  39 with Prj.Com;
  40 with Snames;   use Snames;
  41 with Table;
  42 with Targparm; use Targparm;
  43
  44 with GNAT.HTable;
  45
  46 package body Prj.Util is
  47
  48    package Source_Info_Table is new Table.Table
  49      (Table_Component_Type => Source_Info_Iterator,
  50       Table_Index_Type     => Natural,
  51       Table_Low_Bound      => 1,
  52       Table_Initial        => 10,
  53       Table_Increment      => 100,
  54       Table_Name           => "Makeutl.Source_Info_Table");
  55
  56    package Source_Info_Project_HTable is new GNAT.HTable.Simple_HTable
  57      (Header_Num => Prj.Header_Num,
  58       Element    => Natural,
  59       No_Element => 0,
  60       Key        => Name_Id,
  61       Hash       => Prj.Hash,
  62       Equal      => "=");
  63
  64    procedure Free is new Ada.Unchecked_Deallocation
  65      (Text_File_Data, Text_File);
  66
  67    -----------
  68    -- Close --
  69    -----------
  70
  71    procedure Close (File : in out Text_File) is
  72       Len : Integer;
  73       Status : Boolean;
  74
  75    begin
  76       if File = null then
  77          Prj.Com.Fail ("Close attempted on an invalid Text_File");
  78       end if;
  79
  80       if File.Out_File then
  81          if File.Buffer_Len > 0 then
  82             Len := Write (File.FD, File.Buffer'Address, File.Buffer_Len);
  83
  84             if Len /= File.Buffer_Len then
  85                Prj.Com.Fail ("Unable to write to an out Text_File");
  86             end if;
  87          end if;
  88
  89          Close (File.FD, Status);
  90
  91          if not Status then
  92             Prj.Com.Fail ("Unable to close an out Text_File");
  93          end if;
  94
  95       else
  96
  97          --  Close in file, no need to test status, since this is a file that
  98          --  we read, and the file was read successfully before we closed it.
  99
 100          Close (File.FD);
 101       end if;
 102
 103       Free (File);
 104    end Close;
 105
 106    ------------
 107    -- Create --
 108    ------------
 109
 110    procedure Create (File : out Text_File; Name : String) is
 111       FD        : File_Descriptor;
 112       File_Name : String (1 .. Name'Length + 1);
 113
 114    begin
 115       File_Name (1 .. Name'Length) := Name;
 116       File_Name (File_Name'Last) := ASCII.NUL;
 117       FD := Create_File (Name => File_Name'Address,
 118                          Fmode => GNAT.OS_Lib.Text);
 119
 120       if FD = Invalid_FD then
 121          File := null;
 122
 123       else
 124          File := new Text_File_Data;
 125          File.FD := FD;
 126          File.Out_File := True;
 127          File.End_Of_File_Reached := True;
 128       end if;
 129    end Create;
 130
 131    ---------------
 132    -- Duplicate --
 133    ---------------
 134
 135    procedure Duplicate
 136      (This   : in out Name_List_Index;
 137       Shared : Shared_Project_Tree_Data_Access)
 138    is
 139       Old_Current : Name_List_Index;
 140       New_Current : Name_List_Index;
 141
 142    begin
 143       if This /= No_Name_List then
 144          Old_Current := This;
 145          Name_List_Table.Increment_Last (Shared.Name_Lists);
 146          New_Current := Name_List_Table.Last (Shared.Name_Lists);
 147          This := New_Current;
 148          Shared.Name_Lists.Table (New_Current) :=
 149            (Shared.Name_Lists.Table (Old_Current).Name, No_Name_List);
 150
 151          loop
 152             Old_Current := Shared.Name_Lists.Table (Old_Current).Next;
 153             exit when Old_Current = No_Name_List;
 154             Shared.Name_Lists.Table (New_Current).Next := New_Current + 1;
 155             Name_List_Table.Increment_Last (Shared.Name_Lists);
 156             New_Current := New_Current + 1;
 157             Shared.Name_Lists.Table (New_Current) :=
 158               (Shared.Name_Lists.Table (Old_Current).Name, No_Name_List);
 159          end loop;
 160       end if;
 161    end Duplicate;
 162
 163    -----------------
 164    -- End_Of_File --
 165    -----------------
 166
 167    function End_Of_File (File : Text_File) return Boolean is
 168    begin
 169       if File = null then
 170          Prj.Com.Fail ("End_Of_File attempted on an invalid Text_File");
 171       end if;
 172
 173       return File.End_Of_File_Reached;
 174    end End_Of_File;
 175
 176    -------------------
 177    -- Executable_Of --
 178    -------------------
 179
 180    function Executable_Of
 181      (Project  : Project_Id;
 182       Shared   : Shared_Project_Tree_Data_Access;
 183       Main     : File_Name_Type;
 184       Index    : Int;
 185       Ada_Main : Boolean := True;
 186       Language : String := "";
 187       Include_Suffix : Boolean := True) return File_Name_Type
 188    is
 189       pragma Assert (Project /= No_Project);
 190
 191       The_Packages : constant Package_Id := Project.Decl.Packages;
 192
 193       Builder_Package : constant Prj.Package_Id :=
 194                           Prj.Util.Value_Of
 195                             (Name        => Name_Builder,
 196                              In_Packages => The_Packages,
 197                              Shared      => Shared);
 198
 199       Executable : Variable_Value :=
 200                      Prj.Util.Value_Of
 201                        (Name                    => Name_Id (Main),
 202                         Index                   => Index,
 203                         Attribute_Or_Array_Name => Name_Executable,
 204                         In_Package              => Builder_Package,
 205                         Shared                  => Shared);
 206
 207       Lang   : Language_Ptr;
 208
 209       Spec_Suffix : Name_Id := No_Name;
 210       Body_Suffix : Name_Id := No_Name;
 211
 212       Spec_Suffix_Length : Natural := 0;
 213       Body_Suffix_Length : Natural := 0;
 214
 215       procedure Get_Suffixes
 216         (B_Suffix : File_Name_Type;
 217          S_Suffix : File_Name_Type);
 218       --  Get the non empty suffixes in variables Spec_Suffix and Body_Suffix
 219
 220       function Add_Suffix (File : File_Name_Type) return File_Name_Type;
 221       --  Return the name of the executable, based on File, and adding the
 222       --  executable suffix if needed
 223
 224       ------------------
 225       -- Get_Suffixes --
 226       ------------------
 227
 228       procedure Get_Suffixes
 229         (B_Suffix : File_Name_Type;
 230          S_Suffix : File_Name_Type)
 231       is
 232       begin
 233          if B_Suffix /= No_File then
 234             Body_Suffix := Name_Id (B_Suffix);
 235             Body_Suffix_Length := Natural (Length_Of_Name (Body_Suffix));
 236          end if;
 237
 238          if S_Suffix /= No_File then
 239             Spec_Suffix := Name_Id (S_Suffix);
 240             Spec_Suffix_Length := Natural (Length_Of_Name (Spec_Suffix));
 241          end if;
 242       end Get_Suffixes;
 243
 244       ----------------
 245       -- Add_Suffix --
 246       ----------------
 247
 248       function Add_Suffix (File : File_Name_Type) return File_Name_Type is
 249          Saved_EEOT : constant Name_Id := Executable_Extension_On_Target;
 250          Result     : File_Name_Type;
 251          Suffix_From_Project : Variable_Value;
 252       begin
 253          if Include_Suffix then
 254             if Project.Config.Executable_Suffix /= No_Name then
 255                Executable_Extension_On_Target :=
 256                  Project.Config.Executable_Suffix;
 257             end if;
 258
 259             Result :=  Executable_Name (File);
 260             Executable_Extension_On_Target := Saved_EEOT;
 261             return Result;
 262
 263          elsif Builder_Package /= No_Package then
 264
 265             --  If the suffix is specified in the project itself, as opposed to
 266             --  the config file, it needs to be taken into account. However,
 267             --  when the project was processed, in both cases the suffix was
 268             --  stored in Project.Config, so get it from the project again.
 269
 270             Suffix_From_Project :=
 271               Prj.Util.Value_Of
 272                 (Variable_Name => Name_Executable_Suffix,
 273                  In_Variables  =>
 274                    Shared.Packages.Table (Builder_Package).Decl.Attributes,
 275                  Shared        => Shared);
 276
 277             if Suffix_From_Project /= Nil_Variable_Value
 278               and then Suffix_From_Project.Value /= No_Name
 279             then
 280                Executable_Extension_On_Target := Suffix_From_Project.Value;
 281                Result :=  Executable_Name (File);
 282                Executable_Extension_On_Target := Saved_EEOT;
 283                return Result;
 284             end if;
 285          end if;
 286
 287          return File;
 288       end Add_Suffix;
 289
 290    --  Start of processing for Executable_Of
 291
 292    begin
 293       if Ada_Main then
 294          Lang := Get_Language_From_Name (Project, "ada");
 295       elsif Language /= "" then
 296          Lang := Get_Language_From_Name (Project, Language);
 297       end if;
 298
 299       if Lang /= null then
 300          Get_Suffixes
 301            (B_Suffix => Lang.Config.Naming_Data.Body_Suffix,
 302             S_Suffix => Lang.Config.Naming_Data.Spec_Suffix);
 303       end if;
 304
 305       if Builder_Package /= No_Package then
 306          if Executable = Nil_Variable_Value and then Ada_Main then
 307             Get_Name_String (Main);
 308
 309             --  Try as index the name minus the implementation suffix or minus
 310             --  the specification suffix.
 311
 312             declare
 313                Name : constant String (1 .. Name_Len) :=
 314                         Name_Buffer (1 .. Name_Len);
 315                Last : Positive := Name_Len;
 316
 317                Truncated : Boolean := False;
 318
 319             begin
 320                if Body_Suffix /= No_Name
 321                  and then Last > Natural (Length_Of_Name (Body_Suffix))
 322                  and then Name (Last - Body_Suffix_Length + 1 .. Last) =
 323                             Get_Name_String (Body_Suffix)
 324                then
 325                   Truncated := True;
 326                   Last := Last - Body_Suffix_Length;
 327                end if;
 328
 329                if Spec_Suffix /= No_Name
 330                  and then not Truncated
 331                  and then Last > Spec_Suffix_Length
 332                  and then Name (Last - Spec_Suffix_Length + 1 .. Last) =
 333                             Get_Name_String (Spec_Suffix)
 334                then
 335                   Truncated := True;
 336                   Last := Last - Spec_Suffix_Length;
 337                end if;
 338
 339                if Truncated then
 340                   Name_Len := Last;
 341                   Name_Buffer (1 .. Name_Len) := Name (1 .. Last);
 342                   Executable :=
 343                     Prj.Util.Value_Of
 344                       (Name                    => Name_Find,
 345                        Index                   => 0,
 346                        Attribute_Or_Array_Name => Name_Executable,
 347                        In_Package              => Builder_Package,
 348                        Shared                  => Shared);
 349                end if;
 350             end;
 351          end if;
 352
 353          --  If we have found an Executable attribute, return its value,
 354          --  possibly suffixed by the executable suffix.
 355
 356          if Executable /= Nil_Variable_Value
 357            and then Executable.Value /= No_Name
 358            and then Length_Of_Name (Executable.Value) /= 0
 359          then
 360             return Add_Suffix (File_Name_Type (Executable.Value));
 361          end if;
 362       end if;
 363
 364       Get_Name_String (Main);
 365
 366       --  If there is a body suffix or a spec suffix, remove this suffix,
 367       --  otherwise remove any suffix ('.' followed by other characters), if
 368       --  there is one.
 369
 370       if Body_Suffix /= No_Name
 371          and then Name_Len > Body_Suffix_Length
 372          and then Name_Buffer (Name_Len - Body_Suffix_Length + 1 .. Name_Len) =
 373                     Get_Name_String (Body_Suffix)
 374       then
 375          --  Found the body termination, remove it
 376
 377          Name_Len := Name_Len - Body_Suffix_Length;
 378
 379       elsif Spec_Suffix /= No_Name
 380             and then Name_Len > Spec_Suffix_Length
 381             and then
 382               Name_Buffer (Name_Len - Spec_Suffix_Length + 1 .. Name_Len) =
 383                 Get_Name_String (Spec_Suffix)
 384       then
 385          --  Found the spec termination, remove it
 386
 387          Name_Len := Name_Len - Spec_Suffix_Length;
 388
 389       else
 390          --  Remove any suffix, if there is one
 391
 392          Get_Name_String (Strip_Suffix (Main));
 393       end if;
 394
 395       return Add_Suffix (Name_Find);
 396    end Executable_Of;
 397
 398    ---------------------------
 399    -- For_Interface_Sources --
 400    ---------------------------
 401
 402    procedure For_Interface_Sources
 403      (Tree    : Project_Tree_Ref;
 404       Project : Project_Id)
 405    is
 406       use Ada;
 407       use type Ada.Containers.Count_Type;
 408
 409       package Dep_Names is new Containers.Indefinite_Ordered_Sets (String);
 410
 411       function Load_ALI (Filename : String) return ALI_Id;
 412       --  Load an ALI file and return its id
 413
 414       --------------
 415       -- Load_ALI --
 416       --------------
 417
 418       function Load_ALI (Filename : String) return ALI_Id is
 419          Result   : ALI_Id := No_ALI_Id;
 420          Text     : Text_Buffer_Ptr;
 421          Lib_File : File_Name_Type;
 422
 423       begin
 424          if Directories.Exists (Filename) then
 425             Name_Len := 0;
 426             Add_Str_To_Name_Buffer (Filename);
 427             Lib_File := Name_Find;
 428             Text := Osint.Read_Library_Info (Lib_File);
 429             Result :=
 430               ALI.Scan_ALI
 431                 (Lib_File,
 432                  Text,
 433                  Ignore_ED  => False,
 434                  Err        => True,
 435                  Read_Lines => "UD");
 436             Free (Text);
 437          end if;
 438
 439          return Result;
 440       end Load_ALI;
 441
 442       --  Local declarations
 443
 444       Iter : Source_Iterator;
 445       Sid  : Source_Id;
 446       ALI  : ALI_Id;
 447
 448       First_Unit  : Unit_Id;
 449       Second_Unit : Unit_Id;
 450       Body_Needed : Boolean;
 451       Deps        : Dep_Names.Set;
 452
 453    --  Start of processing for For_Interface_Sources
 454
 455    begin
 456       if Project.Qualifier = Aggregate_Library then
 457          Iter := For_Each_Source (Tree);
 458       else
 459          Iter := For_Each_Source (Tree, Project);
 460       end if;
 461
 462       --  First look at each spec, check if the body is needed
 463
 464       loop
 465          Sid := Element (Iter);
 466          exit when Sid = No_Source;
 467
 468          --  Skip sources that are removed/excluded and sources not part of
 469          --  the interface for standalone libraries.
 470
 471          if Sid.Kind = Spec
 472            and then (not Sid.Project.Externally_Built
 473                       or else Sid.Project = Project)
 474            and then not Sid.Locally_Removed
 475            and then (Project.Standalone_Library = No
 476                       or else Sid.Declared_In_Interfaces)
 477
 478            --  Handle case of non-compilable languages
 479
 480            and then Sid.Dep_Name /= No_File
 481          then
 482             Action (Sid);
 483
 484             --  Check ALI for dependencies on body and sep
 485
 486             ALI :=
 487               Load_ALI
 488                 (Get_Name_String (Get_Object_Directory (Sid.Project, True))
 489                  & Get_Name_String (Sid.Dep_Name));
 490
 491             if ALI /= No_ALI_Id then
 492                First_Unit := ALIs.Table (ALI).First_Unit;
 493                Second_Unit := No_Unit_Id;
 494                Body_Needed := True;
 495
 496                --  If there is both a spec and a body, check if both needed
 497
 498                if Units.Table (First_Unit).Utype = Is_Body then
 499                   Second_Unit := ALIs.Table (ALI).Last_Unit;
 500
 501                   --  If the body is not needed, then reset First_Unit
 502
 503                   if not Units.Table (Second_Unit).Body_Needed_For_SAL then
 504                      Body_Needed := False;
 505                   end if;
 506
 507                elsif Units.Table (First_Unit).Utype = Is_Spec_Only then
 508                   Body_Needed := False;
 509                end if;
 510
 511                --  Handle all the separates, if any
 512
 513                if Body_Needed then
 514                   if Other_Part (Sid) /= null then
 515                      Deps.Include (Get_Name_String (Other_Part (Sid).File));
 516                   end if;
 517
 518                   for Dep in ALIs.Table (ALI).First_Sdep ..
 519                     ALIs.Table (ALI).Last_Sdep
 520                   loop
 521                      if Sdep.Table (Dep).Subunit_Name /= No_Name then
 522                         Deps.Include
 523                           (Get_Name_String (Sdep.Table (Dep).Sfile));
 524                      end if;
 525                   end loop;
 526                end if;
 527             end if;
 528          end if;
 529
 530          Next (Iter);
 531       end loop;
 532
 533       --  Now handle the bodies and separates if needed
 534
 535       if Deps.Length /= 0 then
 536          if Project.Qualifier = Aggregate_Library then
 537             Iter := For_Each_Source (Tree);
 538          else
 539             Iter := For_Each_Source (Tree, Project);
 540          end if;
 541
 542          loop
 543             Sid := Element (Iter);
 544             exit when Sid = No_Source;
 545
 546             if Sid.Kind /= Spec
 547               and then Deps.Contains (Get_Name_String (Sid.File))
 548             then
 549                Action (Sid);
 550             end if;
 551
 552             Next (Iter);
 553          end loop;
 554       end if;
 555    end For_Interface_Sources;
 556
 557    --------------
 558    -- Get_Line --
 559    --------------
 560
 561    procedure Get_Line
 562      (File : Text_File;
 563       Line : out String;
 564       Last : out Natural)
 565    is
 566       C : Character;
 567
 568       procedure Advance;
 569
 570       -------------
 571       -- Advance --
 572       -------------
 573
 574       procedure Advance is
 575       begin
 576          if File.Cursor = File.Buffer_Len then
 577             File.Buffer_Len :=
 578               Read
 579                (FD => File.FD,
 580                 A  => File.Buffer'Address,
 581                 N  => File.Buffer'Length);
 582
 583             if File.Buffer_Len = 0 then
 584                File.End_Of_File_Reached := True;
 585                return;
 586             else
 587                File.Cursor := 1;
 588             end if;
 589
 590          else
 591             File.Cursor := File.Cursor + 1;
 592          end if;
 593       end Advance;
 594
 595    --  Start of processing for Get_Line
 596
 597    begin
 598       if File = null then
 599          Prj.Com.Fail ("Get_Line attempted on an invalid Text_File");
 600
 601       elsif File.Out_File then
 602          Prj.Com.Fail ("Get_Line attempted on an out file");
 603       end if;
 604
 605       Last := Line'First - 1;
 606
 607       if not File.End_Of_File_Reached then
 608          loop
 609             C := File.Buffer (File.Cursor);
 610             exit when C = ASCII.CR or else C = ASCII.LF;
 611             Last := Last + 1;
 612             Line (Last) := C;
 613             Advance;
 614
 615             if File.End_Of_File_Reached then
 616                return;
 617             end if;
 618
 619             exit when Last = Line'Last;
 620          end loop;
 621
 622          if C = ASCII.CR or else C = ASCII.LF then
 623             Advance;
 624
 625             if File.End_Of_File_Reached then
 626                return;
 627             end if;
 628          end if;
 629
 630          if C = ASCII.CR
 631            and then File.Buffer (File.Cursor) = ASCII.LF
 632          then
 633             Advance;
 634          end if;
 635       end if;
 636    end Get_Line;
 637
 638    ----------------
 639    -- Initialize --
 640    ----------------
 641
 642    procedure Initialize
 643      (Iter        : out Source_Info_Iterator;
 644       For_Project : Name_Id)
 645    is
 646       Ind : constant Natural := Source_Info_Project_HTable.Get (For_Project);
 647    begin
 648       if Ind = 0 then
 649          Iter := (No_Source_Info, 0);
 650       else
 651          Iter := Source_Info_Table.Table (Ind);
 652       end if;
 653    end Initialize;
 654
 655    --------------
 656    -- Is_Valid --
 657    --------------
 658
 659    function Is_Valid (File : Text_File) return Boolean is
 660    begin
 661       return File /= null;
 662    end Is_Valid;
 663
 664    ----------
 665    -- Next --
 666    ----------
 667
 668    procedure Next (Iter : in out Source_Info_Iterator) is
 669    begin
 670       if Iter.Next = 0 then
 671          Iter.Info := No_Source_Info;
 672
 673       else
 674          Iter := Source_Info_Table.Table (Iter.Next);
 675       end if;
 676    end Next;
 677
 678    ----------
 679    -- Open --
 680    ----------
 681
 682    procedure Open (File : out Text_File; Name : String) is
 683       FD        : File_Descriptor;
 684       File_Name : String (1 .. Name'Length + 1);
 685
 686    begin
 687       File_Name (1 .. Name'Length) := Name;
 688       File_Name (File_Name'Last) := ASCII.NUL;
 689       FD := Open_Read (Name => File_Name'Address,
 690                        Fmode => GNAT.OS_Lib.Text);
 691
 692       if FD = Invalid_FD then
 693          File := null;
 694
 695       else
 696          File := new Text_File_Data;
 697          File.FD := FD;
 698          File.Buffer_Len :=
 699            Read (FD => FD,
 700                  A  => File.Buffer'Address,
 701                  N  => File.Buffer'Length);
 702
 703          if File.Buffer_Len = 0 then
 704             File.End_Of_File_Reached := True;
 705          else
 706             File.Cursor := 1;
 707          end if;
 708       end if;
 709    end Open;
 710
 711    ---------
 712    -- Put --
 713    ---------
 714
 715    procedure Put
 716      (Into_List  : in out Name_List_Index;
 717       From_List  : String_List_Id;
 718       In_Tree    : Project_Tree_Ref;
 719       Lower_Case : Boolean := False)
 720    is
 721       Shared  : constant Shared_Project_Tree_Data_Access := In_Tree.Shared;
 722
 723       Current_Name : Name_List_Index;
 724       List         : String_List_Id;
 725       Element      : String_Element;
 726       Last         : Name_List_Index :=
 727                        Name_List_Table.Last (Shared.Name_Lists);
 728       Value        : Name_Id;
 729
 730    begin
 731       Current_Name := Into_List;
 732       while Current_Name /= No_Name_List
 733         and then Shared.Name_Lists.Table (Current_Name).Next /= No_Name_List
 734       loop
 735          Current_Name := Shared.Name_Lists.Table (Current_Name).Next;
 736       end loop;
 737
 738       List := From_List;
 739       while List /= Nil_String loop
 740          Element := Shared.String_Elements.Table (List);
 741          Value := Element.Value;
 742
 743          if Lower_Case then
 744             Get_Name_String (Value);
 745             To_Lower (Name_Buffer (1 .. Name_Len));
 746             Value := Name_Find;
 747          end if;
 748
 749          Name_List_Table.Append
 750            (Shared.Name_Lists, (Name => Value, Next => No_Name_List));
 751
 752          Last := Last + 1;
 753
 754          if Current_Name = No_Name_List then
 755             Into_List := Last;
 756          else
 757             Shared.Name_Lists.Table (Current_Name).Next := Last;
 758          end if;
 759
 760          Current_Name := Last;
 761
 762          List := Element.Next;
 763       end loop;
 764    end Put;
 765
 766    procedure Put (File : Text_File; S : String) is
 767       Len : Integer;
 768    begin
 769       if File = null then
 770          Prj.Com.Fail ("Attempted to write on an invalid Text_File");
 771
 772       elsif not File.Out_File then
 773          Prj.Com.Fail ("Attempted to write an in Text_File");
 774       end if;
 775
 776       if File.Buffer_Len + S'Length > File.Buffer'Last then
 777          --  Write buffer
 778          Len := Write (File.FD, File.Buffer'Address, File.Buffer_Len);
 779
 780          if Len /= File.Buffer_Len then
 781             Prj.Com.Fail ("Failed to write to an out Text_File");
 782          end if;
 783
 784          File.Buffer_Len := 0;
 785       end if;
 786
 787       File.Buffer (File.Buffer_Len + 1 .. File.Buffer_Len + S'Length) := S;
 788       File.Buffer_Len := File.Buffer_Len + S'Length;
 789    end Put;
 790
 791    --------------
 792    -- Put_Line --
 793    --------------
 794
 795    procedure Put_Line (File : Text_File; Line : String) is
 796       L : String (1 .. Line'Length + 1);
 797    begin
 798       L (1 .. Line'Length) := Line;
 799       L (L'Last) := ASCII.LF;
 800       Put (File, L);
 801    end Put_Line;
 802
 803    -------------------
 804    -- Relative_Path --
 805    -------------------
 806
 807    function Relative_Path (Pathname : String; To : String) return String is
 808       function Ensure_Directory (Path : String) return String;
 809       --  Returns Path with an added directory separator if needed
 810
 811       ----------------------
 812       -- Ensure_Directory --
 813       ----------------------
 814
 815       function Ensure_Directory (Path : String) return String is
 816       begin
 817          if Path'Length = 0
 818            or else Path (Path'Last) = Directory_Separator
 819            or else Path (Path'Last) = '/' -- on Windows check also for /
 820          then
 821             return Path;
 822          else
 823             return Path & Directory_Separator;
 824          end if;
 825       end Ensure_Directory;
 826
 827       --  Local variables
 828
 829       Dir_Sep_Map : constant Character_Mapping := To_Mapping ("\", "/");
 830
 831       P  : String (1 .. Pathname'Length) := Pathname;
 832       T  : String (1 .. To'Length) := To;
 833
 834       Pi : Natural; -- common prefix ending
 835       N  : Natural := 0;
 836
 837    --  Start of processing for Relative_Path
 838
 839    begin
 840       pragma Assert (Is_Absolute_Path (Pathname));
 841       pragma Assert (Is_Absolute_Path (To));
 842
 843       --  Use canonical directory separator
 844
 845       Translate (Source => P, Mapping => Dir_Sep_Map);
 846       Translate (Source => T, Mapping => Dir_Sep_Map);
 847
 848       --  First check for common prefix
 849
 850       Pi := 1;
 851       while Pi < P'Last and then Pi < T'Last and then P (Pi) = T (Pi) loop
 852          Pi := Pi + 1;
 853       end loop;
 854
 855       --  Cut common prefix at a directory separator
 856
 857       while Pi > P'First and then P (Pi) /= '/' loop
 858          Pi := Pi - 1;
 859       end loop;
 860
 861       --  Count directory under prefix in P, these will be replaced by the
 862       --  corresponding number of "..".
 863
 864       N := Count (T (Pi + 1 .. T'Last), "/");
 865
 866       if T (T'Last) /= '/' then
 867          N := N + 1;
 868       end if;
 869
 870       return N * "../" & Ensure_Directory (P (Pi + 1 .. P'Last));
 871    end Relative_Path;
 872
 873    ---------------------------
 874    -- Read_Source_Info_File --
 875    ---------------------------
 876
 877    procedure Read_Source_Info_File (Tree : Project_Tree_Ref) is
 878       File : Text_File;
 879       Info : Source_Info_Iterator;
 880       Proj : Name_Id;
 881
 882       procedure Report_Error;
 883
 884       ------------------
 885       -- Report_Error --
 886       ------------------
 887
 888       procedure Report_Error is
 889       begin
 890          Write_Line ("errors in source info file """ &
 891                      Tree.Source_Info_File_Name.all & '"');
 892          Tree.Source_Info_File_Exists := False;
 893       end Report_Error;
 894
 895    begin
 896       Source_Info_Project_HTable.Reset;
 897       Source_Info_Table.Init;
 898
 899       if Tree.Source_Info_File_Name = null then
 900          Tree.Source_Info_File_Exists := False;
 901          return;
 902       end if;
 903
 904       Open (File, Tree.Source_Info_File_Name.all);
 905
 906       if not Is_Valid (File) then
 907          if Opt.Verbose_Mode then
 908             Write_Line ("source info file " & Tree.Source_Info_File_Name.all &
 909                         " does not exist");
 910          end if;
 911
 912          Tree.Source_Info_File_Exists := False;
 913          return;
 914       end if;
 915
 916       Tree.Source_Info_File_Exists := True;
 917
 918       if Opt.Verbose_Mode then
 919          Write_Line ("Reading source info file " &
 920                      Tree.Source_Info_File_Name.all);
 921       end if;
 922
 923       Source_Loop :
 924       while not End_Of_File (File) loop
 925          Info := (new Source_Info_Data, 0);
 926          Source_Info_Table.Increment_Last;
 927
 928          --  project name
 929          Get_Line (File, Name_Buffer, Name_Len);
 930          Proj := Name_Find;
 931          Info.Info.Project := Proj;
 932          Info.Next := Source_Info_Project_HTable.Get (Proj);
 933          Source_Info_Project_HTable.Set (Proj, Source_Info_Table.Last);
 934
 935          if End_Of_File (File) then
 936             Report_Error;
 937             exit Source_Loop;
 938          end if;
 939
 940          --  language name
 941          Get_Line (File, Name_Buffer, Name_Len);
 942          Info.Info.Language := Name_Find;
 943
 944          if End_Of_File (File) then
 945             Report_Error;
 946             exit Source_Loop;
 947          end if;
 948
 949          --  kind
 950          Get_Line (File, Name_Buffer, Name_Len);
 951          Info.Info.Kind := Source_Kind'Value (Name_Buffer (1 .. Name_Len));
 952
 953          if End_Of_File (File) then
 954             Report_Error;
 955             exit Source_Loop;
 956          end if;
 957
 958          --  display path name
 959          Get_Line (File, Name_Buffer, Name_Len);
 960          Info.Info.Display_Path_Name := Name_Find;
 961          Info.Info.Path_Name := Info.Info.Display_Path_Name;
 962
 963          if End_Of_File (File) then
 964             Report_Error;
 965             exit Source_Loop;
 966          end if;
 967
 968          --  optional fields
 969          Option_Loop :
 970          loop
 971             Get_Line (File, Name_Buffer, Name_Len);
 972             exit Option_Loop when Name_Len = 0;
 973
 974             if Name_Len <= 2 then
 975                Report_Error;
 976                exit Source_Loop;
 977
 978             else
 979                if Name_Buffer (1 .. 2) = "P=" then
 980                   Name_Buffer (1 .. Name_Len - 2) :=
 981                     Name_Buffer (3 .. Name_Len);
 982                   Name_Len := Name_Len - 2;
 983                   Info.Info.Path_Name := Name_Find;
 984
 985                elsif Name_Buffer (1 .. 2) = "U=" then
 986                   Name_Buffer (1 .. Name_Len - 2) :=
 987                     Name_Buffer (3 .. Name_Len);
 988                   Name_Len := Name_Len - 2;
 989                   Info.Info.Unit_Name := Name_Find;
 990
 991                elsif Name_Buffer (1 .. 2) = "I=" then
 992                   Info.Info.Index := Int'Value (Name_Buffer (3 .. Name_Len));
 993
 994                elsif Name_Buffer (1 .. Name_Len) = "N=Y" then
 995                   Info.Info.Naming_Exception := Yes;
 996
 997                elsif Name_Buffer (1 .. Name_Len) = "N=I" then
 998                   Info.Info.Naming_Exception := Inherited;
 999
1000                else
1001                   Report_Error;
1002                   exit Source_Loop;
1003                end if;
1004             end if;
1005          end loop Option_Loop;
1006
1007          Source_Info_Table.Table (Source_Info_Table.Last) := Info;
1008       end loop Source_Loop;
1009
1010       Close (File);
1011
1012    exception
1013       when others =>
1014          Close (File);
1015          Report_Error;
1016    end Read_Source_Info_File;
1017
1018    --------------------
1019    -- Source_Info_Of --
1020    --------------------
1021
1022    function Source_Info_Of (Iter : Source_Info_Iterator) return Source_Info is
1023    begin
1024       return Iter.Info;
1025    end Source_Info_Of;
1026
1027    --------------
1028    -- Value_Of --
1029    --------------
1030
1031    function Value_Of
1032      (Variable : Variable_Value;
1033       Default  : String) return String
1034    is
1035    begin
1036       if Variable.Kind /= Single
1037         or else Variable.Default
1038         or else Variable.Value = No_Name
1039       then
1040          return Default;
1041       else
1042          return Get_Name_String (Variable.Value);
1043       end if;
1044    end Value_Of;
1045
1046    function Value_Of
1047      (Index    : Name_Id;
1048       In_Array : Array_Element_Id;
1049       Shared   : Shared_Project_Tree_Data_Access) return Name_Id
1050    is
1051
1052       Current    : Array_Element_Id;
1053       Element    : Array_Element;
1054       Real_Index : Name_Id := Index;
1055
1056    begin
1057       Current := In_Array;
1058
1059       if Current = No_Array_Element then
1060          return No_Name;
1061       end if;
1062
1063       Element := Shared.Array_Elements.Table (Current);
1064
1065       if not Element.Index_Case_Sensitive then
1066          Get_Name_String (Index);
1067          To_Lower (Name_Buffer (1 .. Name_Len));
1068          Real_Index := Name_Find;
1069       end if;
1070
1071       while Current /= No_Array_Element loop
1072          Element := Shared.Array_Elements.Table (Current);
1073
1074          if Real_Index = Element.Index then
1075             exit when Element.Value.Kind /= Single;
1076             exit when Element.Value.Value = Empty_String;
1077             return Element.Value.Value;
1078          else
1079             Current := Element.Next;
1080          end if;
1081       end loop;
1082
1083       return No_Name;
1084    end Value_Of;
1085
1086    function Value_Of
1087      (Index                  : Name_Id;
1088       Src_Index              : Int := 0;
1089       In_Array               : Array_Element_Id;
1090       Shared                 : Shared_Project_Tree_Data_Access;
1091       Force_Lower_Case_Index : Boolean := False;
1092       Allow_Wildcards        : Boolean := False) return Variable_Value
1093    is
1094       Current      : Array_Element_Id;
1095       Element      : Array_Element;
1096       Real_Index_1 : Name_Id;
1097       Real_Index_2 : Name_Id;
1098
1099    begin
1100       Current := In_Array;
1101
1102       if Current = No_Array_Element then
1103          return Nil_Variable_Value;
1104       end if;
1105
1106       Element := Shared.Array_Elements.Table (Current);
1107
1108       Real_Index_1 := Index;
1109
1110       if not Element.Index_Case_Sensitive or else Force_Lower_Case_Index then
1111          if Index /= All_Other_Names then
1112             Get_Name_String (Index);
1113             To_Lower (Name_Buffer (1 .. Name_Len));
1114             Real_Index_1 := Name_Find;
1115          end if;
1116       end if;
1117
1118       while Current /= No_Array_Element loop
1119          Element := Shared.Array_Elements.Table (Current);
1120          Real_Index_2 := Element.Index;
1121
1122          if not Element.Index_Case_Sensitive
1123            or else Force_Lower_Case_Index
1124          then
1125             if Element.Index /= All_Other_Names then
1126                Get_Name_String (Element.Index);
1127                To_Lower (Name_Buffer (1 .. Name_Len));
1128                Real_Index_2 := Name_Find;
1129             end if;
1130          end if;
1131
1132          if Src_Index = Element.Src_Index and then
1133            (Real_Index_1 = Real_Index_2 or else
1134               (Real_Index_2 /= All_Other_Names and then
1135                Allow_Wildcards and then
1136                  Match (Get_Name_String (Real_Index_1),
1137                         Compile (Get_Name_String (Real_Index_2),
1138                                  Glob => True))))
1139          then
1140             return Element.Value;
1141          else
1142             Current := Element.Next;
1143          end if;
1144       end loop;
1145
1146       return Nil_Variable_Value;
1147    end Value_Of;
1148
1149    function Value_Of
1150      (Name                    : Name_Id;
1151       Index                   : Int := 0;
1152       Attribute_Or_Array_Name : Name_Id;
1153       In_Package              : Package_Id;
1154       Shared                  : Shared_Project_Tree_Data_Access;
1155       Force_Lower_Case_Index  : Boolean := False;
1156       Allow_Wildcards         : Boolean := False) return Variable_Value
1157    is
1158       The_Array     : Array_Element_Id;
1159       The_Attribute : Variable_Value := Nil_Variable_Value;
1160
1161    begin
1162       if In_Package /= No_Package then
1163
1164          --  First, look if there is an array element that fits
1165
1166          The_Array :=
1167            Value_Of
1168              (Name      => Attribute_Or_Array_Name,
1169               In_Arrays => Shared.Packages.Table (In_Package).Decl.Arrays,
1170               Shared    => Shared);
1171          The_Attribute :=
1172            Value_Of
1173              (Index                  => Name,
1174               Src_Index              => Index,
1175               In_Array               => The_Array,
1176               Shared                 => Shared,
1177               Force_Lower_Case_Index => Force_Lower_Case_Index,
1178               Allow_Wildcards        => Allow_Wildcards);
1179
1180          --  If there is no array element, look for a variable
1181
1182          if The_Attribute = Nil_Variable_Value then
1183             The_Attribute :=
1184               Value_Of
1185                 (Variable_Name => Attribute_Or_Array_Name,
1186                  In_Variables  => Shared.Packages.Table
1187                    (In_Package).Decl.Attributes,
1188                  Shared        => Shared);
1189          end if;
1190       end if;
1191
1192       return The_Attribute;
1193    end Value_Of;
1194
1195    function Value_Of
1196      (Index     : Name_Id;
1197       In_Array  : Name_Id;
1198       In_Arrays : Array_Id;
1199       Shared    : Shared_Project_Tree_Data_Access) return Name_Id
1200    is
1201       Current   : Array_Id;
1202       The_Array : Array_Data;
1203
1204    begin
1205       Current := In_Arrays;
1206       while Current /= No_Array loop
1207          The_Array := Shared.Arrays.Table (Current);
1208          if The_Array.Name = In_Array then
1209             return Value_Of
1210               (Index, In_Array => The_Array.Value, Shared => Shared);
1211          else
1212             Current := The_Array.Next;
1213          end if;
1214       end loop;
1215
1216       return No_Name;
1217    end Value_Of;
1218
1219    function Value_Of
1220      (Name      : Name_Id;
1221       In_Arrays : Array_Id;
1222       Shared    : Shared_Project_Tree_Data_Access) return Array_Element_Id
1223    is
1224       Current   : Array_Id;
1225       The_Array : Array_Data;
1226
1227    begin
1228       Current := In_Arrays;
1229       while Current /= No_Array loop
1230          The_Array := Shared.Arrays.Table (Current);
1231
1232          if The_Array.Name = Name then
1233             return The_Array.Value;
1234          else
1235             Current := The_Array.Next;
1236          end if;
1237       end loop;
1238
1239       return No_Array_Element;
1240    end Value_Of;
1241
1242    function Value_Of
1243      (Name        : Name_Id;
1244       In_Packages : Package_Id;
1245       Shared      : Shared_Project_Tree_Data_Access) return Package_Id
1246    is
1247       Current     : Package_Id;
1248       The_Package : Package_Element;
1249
1250    begin
1251       Current := In_Packages;
1252       while Current /= No_Package loop
1253          The_Package := Shared.Packages.Table (Current);
1254          exit when The_Package.Name /= No_Name
1255            and then The_Package.Name = Name;
1256          Current := The_Package.Next;
1257       end loop;
1258
1259       return Current;
1260    end Value_Of;
1261
1262    function Value_Of
1263      (Variable_Name : Name_Id;
1264       In_Variables  : Variable_Id;
1265       Shared        : Shared_Project_Tree_Data_Access) return Variable_Value
1266    is
1267       Current      : Variable_Id;
1268       The_Variable : Variable;
1269
1270    begin
1271       Current := In_Variables;
1272       while Current /= No_Variable loop
1273          The_Variable := Shared.Variable_Elements.Table (Current);
1274
1275          if Variable_Name = The_Variable.Name then
1276             return The_Variable.Value;
1277          else
1278             Current := The_Variable.Next;
1279          end if;
1280       end loop;
1281
1282       return Nil_Variable_Value;
1283    end Value_Of;
1284
1285    ----------------------------
1286    -- Write_Source_Info_File --
1287    ----------------------------
1288
1289    procedure Write_Source_Info_File (Tree : Project_Tree_Ref) is
1290       Iter   : Source_Iterator := For_Each_Source (Tree);
1291       Source : Prj.Source_Id;
1292       File   : Text_File;
1293
1294    begin
1295       if Opt.Verbose_Mode then
1296          Write_Line ("Writing new source info file " &
1297                      Tree.Source_Info_File_Name.all);
1298       end if;
1299
1300       Create (File, Tree.Source_Info_File_Name.all);
1301
1302       if not Is_Valid (File) then
1303          Write_Line ("warning: unable to create source info file """ &
1304                      Tree.Source_Info_File_Name.all & '"');
1305          return;
1306       end if;
1307
1308       loop
1309          Source := Element (Iter);
1310          exit when Source = No_Source;
1311
1312          if not Source.Locally_Removed and then
1313            Source.Replaced_By = No_Source
1314          then
1315             --  Project name
1316
1317             Put_Line (File, Get_Name_String (Source.Project.Name));
1318
1319             --  Language name
1320
1321             Put_Line (File, Get_Name_String (Source.Language.Name));
1322
1323             --  Kind
1324
1325             Put_Line (File, Source.Kind'Img);
1326
1327             --  Display path name
1328
1329             Put_Line (File, Get_Name_String (Source.Path.Display_Name));
1330
1331             --  Optional lines:
1332
1333             --  Path name (P=)
1334
1335             if Source.Path.Name /= Source.Path.Display_Name then
1336                Put (File, "P=");
1337                Put_Line (File, Get_Name_String (Source.Path.Name));
1338             end if;
1339
1340             --  Unit name (U=)
1341
1342             if Source.Unit /= No_Unit_Index then
1343                Put (File, "U=");
1344                Put_Line (File, Get_Name_String (Source.Unit.Name));
1345             end if;
1346
1347             --  Multi-source index (I=)
1348
1349             if Source.Index /= 0 then
1350                Put (File, "I=");
1351                Put_Line (File, Source.Index'Img);
1352             end if;
1353
1354             --  Naming exception ("N=T");
1355
1356             if Source.Naming_Exception = Yes then
1357                Put_Line (File, "N=Y");
1358
1359             elsif Source.Naming_Exception = Inherited then
1360                Put_Line (File, "N=I");
1361             end if;
1362
1363             --  Empty line to indicate end of info on this source
1364
1365             Put_Line (File, "");
1366          end if;
1367
1368          Next (Iter);
1369       end loop;
1370
1371       Close (File);
1372    end Write_Source_Info_File;
1373
1374    ---------------
1375    -- Write_Str --
1376    ---------------
1377
1378    procedure Write_Str
1379      (S          : String;
1380       Max_Length : Positive;
1381       Separator  : Character)
1382    is
1383       First : Positive := S'First;
1384       Last  : Natural  := S'Last;
1385
1386    begin
1387       --  Nothing to do for empty strings
1388
1389       if S'Length > 0 then
1390
1391          --  Start on a new line if current line is already longer than
1392          --  Max_Length.
1393
1394          if Positive (Column) >= Max_Length then
1395             Write_Eol;
1396          end if;
1397
1398          --  If length of remainder is longer than Max_Length, we need to
1399          --  cut the remainder in several lines.
1400
1401          while Positive (Column) + S'Last - First > Max_Length loop
1402
1403             --  Try the maximum length possible
1404
1405             Last := First + Max_Length - Positive (Column);
1406
1407             --  Look for last Separator in the line
1408
1409             while Last >= First and then S (Last) /= Separator loop
1410                Last := Last - 1;
1411             end loop;
1412
1413             --  If we do not find a separator, output maximum length possible
1414
1415             if Last < First then
1416                Last := First + Max_Length - Positive (Column);
1417             end if;
1418
1419             Write_Line (S (First .. Last));
1420
1421             --  Set the beginning of the new remainder
1422
1423             First := Last + 1;
1424          end loop;
1425
1426          --  What is left goes to the buffer, without EOL
1427
1428          Write_Str (S (First .. S'Last));
1429       end if;
1430    end Write_Str;
1431
1432 end Prj.Util;