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-2012, 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.Locally_Removed
 471            and then (Project.Standalone_Library = No
 472                       or else Sid.Declared_In_Interfaces)
 473          then
 474             Action (Sid);
 475
 476             --  Check ALI for dependencies on body and sep
 477
 478             ALI :=
 479               Load_ALI
 480                 (Get_Name_String (Get_Object_Directory (Sid.Project, True))
 481                  & Get_Name_String (Sid.Dep_Name));
 482
 483             if ALI /= No_ALI_Id then
 484                First_Unit := ALIs.Table (ALI).First_Unit;
 485                Second_Unit := No_Unit_Id;
 486                Body_Needed := True;
 487
 488                --  If there is both a spec and a body, check if both needed
 489
 490                if Units.Table (First_Unit).Utype = Is_Body then
 491                   Second_Unit := ALIs.Table (ALI).Last_Unit;
 492
 493                   --  If the body is not needed, then reset First_Unit
 494
 495                   if not Units.Table (Second_Unit).Body_Needed_For_SAL then
 496                      Body_Needed := False;
 497                   end if;
 498
 499                elsif Units.Table (First_Unit).Utype = Is_Spec_Only then
 500                   Body_Needed := False;
 501                end if;
 502
 503                --  Handle all the separates, if any
 504
 505                if Body_Needed then
 506                   if Other_Part (Sid) /= null then
 507                      Deps.Include (Get_Name_String (Other_Part (Sid).File));
 508                   end if;
 509
 510                   for Dep in ALIs.Table (ALI).First_Sdep ..
 511                     ALIs.Table (ALI).Last_Sdep
 512                   loop
 513                      if Sdep.Table (Dep).Subunit_Name /= No_Name then
 514                         Deps.Include
 515                           (Get_Name_String (Sdep.Table (Dep).Sfile));
 516                      end if;
 517                   end loop;
 518                end if;
 519             end if;
 520          end if;
 521
 522          Next (Iter);
 523       end loop;
 524
 525       --  Now handle the bodies and separates if needed
 526
 527       if Deps.Length /= 0 then
 528          Iter := For_Each_Source (Tree, Project);
 529
 530          loop
 531             Sid := Element (Iter);
 532             exit when Sid = No_Source;
 533
 534             if Sid.Kind /= Spec
 535               and then Deps.Contains (Get_Name_String (Sid.File))
 536             then
 537                Action (Sid);
 538             end if;
 539
 540             Next (Iter);
 541          end loop;
 542       end if;
 543    end For_Interface_Sources;
 544
 545    --------------
 546    -- Get_Line --
 547    --------------
 548
 549    procedure Get_Line
 550      (File : Text_File;
 551       Line : out String;
 552       Last : out Natural)
 553    is
 554       C : Character;
 555
 556       procedure Advance;
 557
 558       -------------
 559       -- Advance --
 560       -------------
 561
 562       procedure Advance is
 563       begin
 564          if File.Cursor = File.Buffer_Len then
 565             File.Buffer_Len :=
 566               Read
 567                (FD => File.FD,
 568                 A  => File.Buffer'Address,
 569                 N  => File.Buffer'Length);
 570
 571             if File.Buffer_Len = 0 then
 572                File.End_Of_File_Reached := True;
 573                return;
 574             else
 575                File.Cursor := 1;
 576             end if;
 577
 578          else
 579             File.Cursor := File.Cursor + 1;
 580          end if;
 581       end Advance;
 582
 583    --  Start of processing for Get_Line
 584
 585    begin
 586       if File = null then
 587          Prj.Com.Fail ("Get_Line attempted on an invalid Text_File");
 588
 589       elsif File.Out_File then
 590          Prj.Com.Fail ("Get_Line attempted on an out file");
 591       end if;
 592
 593       Last := Line'First - 1;
 594
 595       if not File.End_Of_File_Reached then
 596          loop
 597             C := File.Buffer (File.Cursor);
 598             exit when C = ASCII.CR or else C = ASCII.LF;
 599             Last := Last + 1;
 600             Line (Last) := C;
 601             Advance;
 602
 603             if File.End_Of_File_Reached then
 604                return;
 605             end if;
 606
 607             exit when Last = Line'Last;
 608          end loop;
 609
 610          if C = ASCII.CR or else C = ASCII.LF then
 611             Advance;
 612
 613             if File.End_Of_File_Reached then
 614                return;
 615             end if;
 616          end if;
 617
 618          if C = ASCII.CR
 619            and then File.Buffer (File.Cursor) = ASCII.LF
 620          then
 621             Advance;
 622          end if;
 623       end if;
 624    end Get_Line;
 625
 626    ----------------
 627    -- Initialize --
 628    ----------------
 629
 630    procedure Initialize
 631      (Iter        : out Source_Info_Iterator;
 632       For_Project : Name_Id)
 633    is
 634       Ind : constant Natural := Source_Info_Project_HTable.Get (For_Project);
 635    begin
 636       if Ind = 0 then
 637          Iter := (No_Source_Info, 0);
 638       else
 639          Iter := Source_Info_Table.Table (Ind);
 640       end if;
 641    end Initialize;
 642
 643    --------------
 644    -- Is_Valid --
 645    --------------
 646
 647    function Is_Valid (File : Text_File) return Boolean is
 648    begin
 649       return File /= null;
 650    end Is_Valid;
 651
 652    ----------
 653    -- Next --
 654    ----------
 655
 656    procedure Next (Iter : in out Source_Info_Iterator) is
 657    begin
 658       if Iter.Next = 0 then
 659          Iter.Info := No_Source_Info;
 660
 661       else
 662          Iter := Source_Info_Table.Table (Iter.Next);
 663       end if;
 664    end Next;
 665
 666    ----------
 667    -- Open --
 668    ----------
 669
 670    procedure Open (File : out Text_File; Name : String) is
 671       FD        : File_Descriptor;
 672       File_Name : String (1 .. Name'Length + 1);
 673
 674    begin
 675       File_Name (1 .. Name'Length) := Name;
 676       File_Name (File_Name'Last) := ASCII.NUL;
 677       FD := Open_Read (Name => File_Name'Address,
 678                        Fmode => GNAT.OS_Lib.Text);
 679
 680       if FD = Invalid_FD then
 681          File := null;
 682
 683       else
 684          File := new Text_File_Data;
 685          File.FD := FD;
 686          File.Buffer_Len :=
 687            Read (FD => FD,
 688                  A  => File.Buffer'Address,
 689                  N  => File.Buffer'Length);
 690
 691          if File.Buffer_Len = 0 then
 692             File.End_Of_File_Reached := True;
 693          else
 694             File.Cursor := 1;
 695          end if;
 696       end if;
 697    end Open;
 698
 699    ---------
 700    -- Put --
 701    ---------
 702
 703    procedure Put
 704      (Into_List  : in out Name_List_Index;
 705       From_List  : String_List_Id;
 706       In_Tree    : Project_Tree_Ref;
 707       Lower_Case : Boolean := False)
 708    is
 709       Shared  : constant Shared_Project_Tree_Data_Access := In_Tree.Shared;
 710
 711       Current_Name : Name_List_Index;
 712       List         : String_List_Id;
 713       Element      : String_Element;
 714       Last         : Name_List_Index :=
 715                        Name_List_Table.Last (Shared.Name_Lists);
 716       Value        : Name_Id;
 717
 718    begin
 719       Current_Name := Into_List;
 720       while Current_Name /= No_Name_List
 721         and then Shared.Name_Lists.Table (Current_Name).Next /= No_Name_List
 722       loop
 723          Current_Name := Shared.Name_Lists.Table (Current_Name).Next;
 724       end loop;
 725
 726       List := From_List;
 727       while List /= Nil_String loop
 728          Element := Shared.String_Elements.Table (List);
 729          Value := Element.Value;
 730
 731          if Lower_Case then
 732             Get_Name_String (Value);
 733             To_Lower (Name_Buffer (1 .. Name_Len));
 734             Value := Name_Find;
 735          end if;
 736
 737          Name_List_Table.Append
 738            (Shared.Name_Lists, (Name => Value, Next => No_Name_List));
 739
 740          Last := Last + 1;
 741
 742          if Current_Name = No_Name_List then
 743             Into_List := Last;
 744          else
 745             Shared.Name_Lists.Table (Current_Name).Next := Last;
 746          end if;
 747
 748          Current_Name := Last;
 749
 750          List := Element.Next;
 751       end loop;
 752    end Put;
 753
 754    procedure Put (File : Text_File; S : String) is
 755       Len : Integer;
 756    begin
 757       if File = null then
 758          Prj.Com.Fail ("Attempted to write on an invalid Text_File");
 759
 760       elsif not File.Out_File then
 761          Prj.Com.Fail ("Attempted to write an in Text_File");
 762       end if;
 763
 764       if File.Buffer_Len + S'Length > File.Buffer'Last then
 765          --  Write buffer
 766          Len := Write (File.FD, File.Buffer'Address, File.Buffer_Len);
 767
 768          if Len /= File.Buffer_Len then
 769             Prj.Com.Fail ("Failed to write to an out Text_File");
 770          end if;
 771
 772          File.Buffer_Len := 0;
 773       end if;
 774
 775       File.Buffer (File.Buffer_Len + 1 .. File.Buffer_Len + S'Length) := S;
 776       File.Buffer_Len := File.Buffer_Len + S'Length;
 777    end Put;
 778
 779    --------------
 780    -- Put_Line --
 781    --------------
 782
 783    procedure Put_Line (File : Text_File; Line : String) is
 784       L : String (1 .. Line'Length + 1);
 785    begin
 786       L (1 .. Line'Length) := Line;
 787       L (L'Last) := ASCII.LF;
 788       Put (File, L);
 789    end Put_Line;
 790
 791    ---------------------------
 792    -- Read_Source_Info_File --
 793    ---------------------------
 794
 795    procedure Read_Source_Info_File (Tree : Project_Tree_Ref) is
 796       File : Text_File;
 797       Info : Source_Info_Iterator;
 798       Proj : Name_Id;
 799
 800       procedure Report_Error;
 801
 802       ------------------
 803       -- Report_Error --
 804       ------------------
 805
 806       procedure Report_Error is
 807       begin
 808          Write_Line ("errors in source info file """ &
 809                      Tree.Source_Info_File_Name.all & '"');
 810          Tree.Source_Info_File_Exists := False;
 811       end Report_Error;
 812
 813    begin
 814       Source_Info_Project_HTable.Reset;
 815       Source_Info_Table.Init;
 816
 817       if Tree.Source_Info_File_Name = null then
 818          Tree.Source_Info_File_Exists := False;
 819          return;
 820       end if;
 821
 822       Open (File, Tree.Source_Info_File_Name.all);
 823
 824       if not Is_Valid (File) then
 825          if Opt.Verbose_Mode then
 826             Write_Line ("source info file " & Tree.Source_Info_File_Name.all &
 827                         " does not exist");
 828          end if;
 829
 830          Tree.Source_Info_File_Exists := False;
 831          return;
 832       end if;
 833
 834       Tree.Source_Info_File_Exists := True;
 835
 836       if Opt.Verbose_Mode then
 837          Write_Line ("Reading source info file " &
 838                      Tree.Source_Info_File_Name.all);
 839       end if;
 840
 841       Source_Loop :
 842       while not End_Of_File (File) loop
 843          Info := (new Source_Info_Data, 0);
 844          Source_Info_Table.Increment_Last;
 845
 846          --  project name
 847          Get_Line (File, Name_Buffer, Name_Len);
 848          Proj := Name_Find;
 849          Info.Info.Project := Proj;
 850          Info.Next := Source_Info_Project_HTable.Get (Proj);
 851          Source_Info_Project_HTable.Set (Proj, Source_Info_Table.Last);
 852
 853          if End_Of_File (File) then
 854             Report_Error;
 855             exit Source_Loop;
 856          end if;
 857
 858          --  language name
 859          Get_Line (File, Name_Buffer, Name_Len);
 860          Info.Info.Language := Name_Find;
 861
 862          if End_Of_File (File) then
 863             Report_Error;
 864             exit Source_Loop;
 865          end if;
 866
 867          --  kind
 868          Get_Line (File, Name_Buffer, Name_Len);
 869          Info.Info.Kind := Source_Kind'Value (Name_Buffer (1 .. Name_Len));
 870
 871          if End_Of_File (File) then
 872             Report_Error;
 873             exit Source_Loop;
 874          end if;
 875
 876          --  display path name
 877          Get_Line (File, Name_Buffer, Name_Len);
 878          Info.Info.Display_Path_Name := Name_Find;
 879          Info.Info.Path_Name := Info.Info.Display_Path_Name;
 880
 881          if End_Of_File (File) then
 882             Report_Error;
 883             exit Source_Loop;
 884          end if;
 885
 886          --  optional fields
 887          Option_Loop :
 888          loop
 889             Get_Line (File, Name_Buffer, Name_Len);
 890             exit Option_Loop when Name_Len = 0;
 891
 892             if Name_Len <= 2 then
 893                Report_Error;
 894                exit Source_Loop;
 895
 896             else
 897                if Name_Buffer (1 .. 2) = "P=" then
 898                   Name_Buffer (1 .. Name_Len - 2) :=
 899                     Name_Buffer (3 .. Name_Len);
 900                   Name_Len := Name_Len - 2;
 901                   Info.Info.Path_Name := Name_Find;
 902
 903                elsif Name_Buffer (1 .. 2) = "U=" then
 904                   Name_Buffer (1 .. Name_Len - 2) :=
 905                     Name_Buffer (3 .. Name_Len);
 906                   Name_Len := Name_Len - 2;
 907                   Info.Info.Unit_Name := Name_Find;
 908
 909                elsif Name_Buffer (1 .. 2) = "I=" then
 910                   Info.Info.Index := Int'Value (Name_Buffer (3 .. Name_Len));
 911
 912                elsif Name_Buffer (1 .. Name_Len) = "N=Y" then
 913                   Info.Info.Naming_Exception := Yes;
 914
 915                elsif Name_Buffer (1 .. Name_Len) = "N=I" then
 916                   Info.Info.Naming_Exception := Inherited;
 917
 918                else
 919                   Report_Error;
 920                   exit Source_Loop;
 921                end if;
 922             end if;
 923          end loop Option_Loop;
 924
 925          Source_Info_Table.Table (Source_Info_Table.Last) := Info;
 926       end loop Source_Loop;
 927
 928       Close (File);
 929
 930    exception
 931       when others =>
 932          Close (File);
 933          Report_Error;
 934    end Read_Source_Info_File;
 935
 936    --------------------
 937    -- Source_Info_Of --
 938    --------------------
 939
 940    function Source_Info_Of (Iter : Source_Info_Iterator) return Source_Info is
 941    begin
 942       return Iter.Info;
 943    end Source_Info_Of;
 944
 945    --------------
 946    -- Value_Of --
 947    --------------
 948
 949    function Value_Of
 950      (Variable : Variable_Value;
 951       Default  : String) return String
 952    is
 953    begin
 954       if Variable.Kind /= Single
 955         or else Variable.Default
 956         or else Variable.Value = No_Name
 957       then
 958          return Default;
 959       else
 960          return Get_Name_String (Variable.Value);
 961       end if;
 962    end Value_Of;
 963
 964    function Value_Of
 965      (Index    : Name_Id;
 966       In_Array : Array_Element_Id;
 967       Shared   : Shared_Project_Tree_Data_Access) return Name_Id
 968    is
 969
 970       Current    : Array_Element_Id;
 971       Element    : Array_Element;
 972       Real_Index : Name_Id := Index;
 973
 974    begin
 975       Current := In_Array;
 976
 977       if Current = No_Array_Element then
 978          return No_Name;
 979       end if;
 980
 981       Element := Shared.Array_Elements.Table (Current);
 982
 983       if not Element.Index_Case_Sensitive then
 984          Get_Name_String (Index);
 985          To_Lower (Name_Buffer (1 .. Name_Len));
 986          Real_Index := Name_Find;
 987       end if;
 988
 989       while Current /= No_Array_Element loop
 990          Element := Shared.Array_Elements.Table (Current);
 991
 992          if Real_Index = Element.Index then
 993             exit when Element.Value.Kind /= Single;
 994             exit when Element.Value.Value = Empty_String;
 995             return Element.Value.Value;
 996          else
 997             Current := Element.Next;
 998          end if;
 999       end loop;
1000
1001       return No_Name;
1002    end Value_Of;
1003
1004    function Value_Of
1005      (Index                  : Name_Id;
1006       Src_Index              : Int := 0;
1007       In_Array               : Array_Element_Id;
1008       Shared                 : Shared_Project_Tree_Data_Access;
1009       Force_Lower_Case_Index : Boolean := False;
1010       Allow_Wildcards        : Boolean := False) return Variable_Value
1011    is
1012       Current      : Array_Element_Id;
1013       Element      : Array_Element;
1014       Real_Index_1 : Name_Id;
1015       Real_Index_2 : Name_Id;
1016
1017    begin
1018       Current := In_Array;
1019
1020       if Current = No_Array_Element then
1021          return Nil_Variable_Value;
1022       end if;
1023
1024       Element := Shared.Array_Elements.Table (Current);
1025
1026       Real_Index_1 := Index;
1027
1028       if not Element.Index_Case_Sensitive or else Force_Lower_Case_Index then
1029          if Index /= All_Other_Names then
1030             Get_Name_String (Index);
1031             To_Lower (Name_Buffer (1 .. Name_Len));
1032             Real_Index_1 := Name_Find;
1033          end if;
1034       end if;
1035
1036       while Current /= No_Array_Element loop
1037          Element := Shared.Array_Elements.Table (Current);
1038          Real_Index_2 := Element.Index;
1039
1040          if not Element.Index_Case_Sensitive
1041            or else Force_Lower_Case_Index
1042          then
1043             if Element.Index /= All_Other_Names then
1044                Get_Name_String (Element.Index);
1045                To_Lower (Name_Buffer (1 .. Name_Len));
1046                Real_Index_2 := Name_Find;
1047             end if;
1048          end if;
1049
1050          if Src_Index = Element.Src_Index and then
1051            (Real_Index_1 = Real_Index_2 or else
1052               (Real_Index_2 /= All_Other_Names and then
1053                Allow_Wildcards and then
1054                  Match (Get_Name_String (Real_Index_1),
1055                         Compile (Get_Name_String (Real_Index_2),
1056                                  Glob => True))))
1057          then
1058             return Element.Value;
1059          else
1060             Current := Element.Next;
1061          end if;
1062       end loop;
1063
1064       return Nil_Variable_Value;
1065    end Value_Of;
1066
1067    function Value_Of
1068      (Name                    : Name_Id;
1069       Index                   : Int := 0;
1070       Attribute_Or_Array_Name : Name_Id;
1071       In_Package              : Package_Id;
1072       Shared                  : Shared_Project_Tree_Data_Access;
1073       Force_Lower_Case_Index  : Boolean := False;
1074       Allow_Wildcards         : Boolean := False) return Variable_Value
1075    is
1076       The_Array     : Array_Element_Id;
1077       The_Attribute : Variable_Value := Nil_Variable_Value;
1078
1079    begin
1080       if In_Package /= No_Package then
1081
1082          --  First, look if there is an array element that fits
1083
1084          The_Array :=
1085            Value_Of
1086              (Name      => Attribute_Or_Array_Name,
1087               In_Arrays => Shared.Packages.Table (In_Package).Decl.Arrays,
1088               Shared    => Shared);
1089          The_Attribute :=
1090            Value_Of
1091              (Index                  => Name,
1092               Src_Index              => Index,
1093               In_Array               => The_Array,
1094               Shared                 => Shared,
1095               Force_Lower_Case_Index => Force_Lower_Case_Index,
1096               Allow_Wildcards        => Allow_Wildcards);
1097
1098          --  If there is no array element, look for a variable
1099
1100          if The_Attribute = Nil_Variable_Value then
1101             The_Attribute :=
1102               Value_Of
1103                 (Variable_Name => Attribute_Or_Array_Name,
1104                  In_Variables  => Shared.Packages.Table
1105                    (In_Package).Decl.Attributes,
1106                  Shared        => Shared);
1107          end if;
1108       end if;
1109
1110       return The_Attribute;
1111    end Value_Of;
1112
1113    function Value_Of
1114      (Index     : Name_Id;
1115       In_Array  : Name_Id;
1116       In_Arrays : Array_Id;
1117       Shared    : Shared_Project_Tree_Data_Access) return Name_Id
1118    is
1119       Current   : Array_Id;
1120       The_Array : Array_Data;
1121
1122    begin
1123       Current := In_Arrays;
1124       while Current /= No_Array loop
1125          The_Array := Shared.Arrays.Table (Current);
1126          if The_Array.Name = In_Array then
1127             return Value_Of
1128               (Index, In_Array => The_Array.Value, Shared => Shared);
1129          else
1130             Current := The_Array.Next;
1131          end if;
1132       end loop;
1133
1134       return No_Name;
1135    end Value_Of;
1136
1137    function Value_Of
1138      (Name      : Name_Id;
1139       In_Arrays : Array_Id;
1140       Shared    : Shared_Project_Tree_Data_Access) return Array_Element_Id
1141    is
1142       Current   : Array_Id;
1143       The_Array : Array_Data;
1144
1145    begin
1146       Current := In_Arrays;
1147       while Current /= No_Array loop
1148          The_Array := Shared.Arrays.Table (Current);
1149
1150          if The_Array.Name = Name then
1151             return The_Array.Value;
1152          else
1153             Current := The_Array.Next;
1154          end if;
1155       end loop;
1156
1157       return No_Array_Element;
1158    end Value_Of;
1159
1160    function Value_Of
1161      (Name        : Name_Id;
1162       In_Packages : Package_Id;
1163       Shared      : Shared_Project_Tree_Data_Access) return Package_Id
1164    is
1165       Current     : Package_Id;
1166       The_Package : Package_Element;
1167
1168    begin
1169       Current := In_Packages;
1170       while Current /= No_Package loop
1171          The_Package := Shared.Packages.Table (Current);
1172          exit when The_Package.Name /= No_Name
1173            and then The_Package.Name = Name;
1174          Current := The_Package.Next;
1175       end loop;
1176
1177       return Current;
1178    end Value_Of;
1179
1180    function Value_Of
1181      (Variable_Name : Name_Id;
1182       In_Variables  : Variable_Id;
1183       Shared        : Shared_Project_Tree_Data_Access) return Variable_Value
1184    is
1185       Current      : Variable_Id;
1186       The_Variable : Variable;
1187
1188    begin
1189       Current := In_Variables;
1190       while Current /= No_Variable loop
1191          The_Variable := Shared.Variable_Elements.Table (Current);
1192
1193          if Variable_Name = The_Variable.Name then
1194             return The_Variable.Value;
1195          else
1196             Current := The_Variable.Next;
1197          end if;
1198       end loop;
1199
1200       return Nil_Variable_Value;
1201    end Value_Of;
1202
1203    ----------------------------
1204    -- Write_Source_Info_File --
1205    ----------------------------
1206
1207    procedure Write_Source_Info_File (Tree : Project_Tree_Ref) is
1208       Iter   : Source_Iterator := For_Each_Source (Tree);
1209       Source : Prj.Source_Id;
1210       File   : Text_File;
1211
1212    begin
1213       if Opt.Verbose_Mode then
1214          Write_Line ("Writing new source info file " &
1215                      Tree.Source_Info_File_Name.all);
1216       end if;
1217
1218       Create (File, Tree.Source_Info_File_Name.all);
1219
1220       if not Is_Valid (File) then
1221          Write_Line ("warning: unable to create source info file """ &
1222                      Tree.Source_Info_File_Name.all & '"');
1223          return;
1224       end if;
1225
1226       loop
1227          Source := Element (Iter);
1228          exit when Source = No_Source;
1229
1230          if not Source.Locally_Removed and then
1231            Source.Replaced_By = No_Source
1232          then
1233             --  Project name
1234
1235             Put_Line (File, Get_Name_String (Source.Project.Name));
1236
1237             --  Language name
1238
1239             Put_Line (File, Get_Name_String (Source.Language.Name));
1240
1241             --  Kind
1242
1243             Put_Line (File, Source.Kind'Img);
1244
1245             --  Display path name
1246
1247             Put_Line (File, Get_Name_String (Source.Path.Display_Name));
1248
1249             --  Optional lines:
1250
1251             --  Path name (P=)
1252
1253             if Source.Path.Name /= Source.Path.Display_Name then
1254                Put (File, "P=");
1255                Put_Line (File, Get_Name_String (Source.Path.Name));
1256             end if;
1257
1258             --  Unit name (U=)
1259
1260             if Source.Unit /= No_Unit_Index then
1261                Put (File, "U=");
1262                Put_Line (File, Get_Name_String (Source.Unit.Name));
1263             end if;
1264
1265             --  Multi-source index (I=)
1266
1267             if Source.Index /= 0 then
1268                Put (File, "I=");
1269                Put_Line (File, Source.Index'Img);
1270             end if;
1271
1272             --  Naming exception ("N=T");
1273
1274             if Source.Naming_Exception = Yes then
1275                Put_Line (File, "N=Y");
1276
1277             elsif Source.Naming_Exception = Inherited then
1278                Put_Line (File, "N=I");
1279             end if;
1280
1281             --  Empty line to indicate end of info on this source
1282
1283             Put_Line (File, "");
1284          end if;
1285
1286          Next (Iter);
1287       end loop;
1288
1289       Close (File);
1290    end Write_Source_Info_File;
1291
1292    ---------------
1293    -- Write_Str --
1294    ---------------
1295
1296    procedure Write_Str
1297      (S          : String;
1298       Max_Length : Positive;
1299       Separator  : Character)
1300    is
1301       First : Positive := S'First;
1302       Last  : Natural  := S'Last;
1303
1304    begin
1305       --  Nothing to do for empty strings
1306
1307       if S'Length > 0 then
1308
1309          --  Start on a new line if current line is already longer than
1310          --  Max_Length.
1311
1312          if Positive (Column) >= Max_Length then
1313             Write_Eol;
1314          end if;
1315
1316          --  If length of remainder is longer than Max_Length, we need to
1317          --  cut the remainder in several lines.
1318
1319          while Positive (Column) + S'Last - First > Max_Length loop
1320
1321             --  Try the maximum length possible
1322
1323             Last := First + Max_Length - Positive (Column);
1324
1325             --  Look for last Separator in the line
1326
1327             while Last >= First and then S (Last) /= Separator loop
1328                Last := Last - 1;
1329             end loop;
1330
1331             --  If we do not find a separator, we output the maximum length
1332             --  possible.
1333
1334             if Last < First then
1335                Last := First + Max_Length - Positive (Column);
1336             end if;
1337
1338             Write_Line (S (First .. Last));
1339
1340             --  Set the beginning of the new remainder
1341
1342             First := Last + 1;
1343          end loop;
1344
1345          --  What is left goes to the buffer, without EOL
1346
1347          Write_Str (S (First .. S'Last));
1348       end if;
1349    end Write_Str;
1350 end Prj.Util;