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