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