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=T" then
 761                   Info.Info.Naming_Exception := True;
 762
 763                else
 764                   Report_Error;
 765                   exit Source_Loop;
 766                end if;
 767             end if;
 768          end loop Option_Loop;
 769
 770          Source_Info_Table.Table (Source_Info_Table.Last) := Info;
 771       end loop Source_Loop;
 772
 773       Close (File);
 774
 775    exception
 776       when others =>
 777          Close (File);
 778          Report_Error;
 779    end Read_Source_Info_File;
 780
 781    --------------------
 782    -- Source_Info_Of --
 783    --------------------
 784
 785    function Source_Info_Of (Iter : Source_Info_Iterator) return Source_Info is
 786    begin
 787       return Iter.Info;
 788    end Source_Info_Of;
 789
 790    --------------
 791    -- Value_Of --
 792    --------------
 793
 794    function Value_Of
 795      (Variable : Variable_Value;
 796       Default  : String) return String
 797    is
 798    begin
 799       if Variable.Kind /= Single
 800         or else Variable.Default
 801         or else Variable.Value = No_Name
 802       then
 803          return Default;
 804       else
 805          return Get_Name_String (Variable.Value);
 806       end if;
 807    end Value_Of;
 808
 809    function Value_Of
 810      (Index    : Name_Id;
 811       In_Array : Array_Element_Id;
 812       Shared   : Shared_Project_Tree_Data_Access) return Name_Id
 813    is
 814
 815       Current    : Array_Element_Id;
 816       Element    : Array_Element;
 817       Real_Index : Name_Id := Index;
 818
 819    begin
 820       Current := In_Array;
 821
 822       if Current = No_Array_Element then
 823          return No_Name;
 824       end if;
 825
 826       Element := Shared.Array_Elements.Table (Current);
 827
 828       if not Element.Index_Case_Sensitive then
 829          Get_Name_String (Index);
 830          To_Lower (Name_Buffer (1 .. Name_Len));
 831          Real_Index := Name_Find;
 832       end if;
 833
 834       while Current /= No_Array_Element loop
 835          Element := Shared.Array_Elements.Table (Current);
 836
 837          if Real_Index = Element.Index then
 838             exit when Element.Value.Kind /= Single;
 839             exit when Element.Value.Value = Empty_String;
 840             return Element.Value.Value;
 841          else
 842             Current := Element.Next;
 843          end if;
 844       end loop;
 845
 846       return No_Name;
 847    end Value_Of;
 848
 849    function Value_Of
 850      (Index                  : Name_Id;
 851       Src_Index              : Int := 0;
 852       In_Array               : Array_Element_Id;
 853       Shared                 : Shared_Project_Tree_Data_Access;
 854       Force_Lower_Case_Index : Boolean := False;
 855       Allow_Wildcards        : Boolean := False) return Variable_Value
 856    is
 857       Current      : Array_Element_Id;
 858       Element      : Array_Element;
 859       Real_Index_1 : Name_Id;
 860       Real_Index_2 : Name_Id;
 861
 862    begin
 863       Current := In_Array;
 864
 865       if Current = No_Array_Element then
 866          return Nil_Variable_Value;
 867       end if;
 868
 869       Element := Shared.Array_Elements.Table (Current);
 870
 871       Real_Index_1 := Index;
 872
 873       if not Element.Index_Case_Sensitive or else Force_Lower_Case_Index then
 874          if Index /= All_Other_Names then
 875             Get_Name_String (Index);
 876             To_Lower (Name_Buffer (1 .. Name_Len));
 877             Real_Index_1 := Name_Find;
 878          end if;
 879       end if;
 880
 881       while Current /= No_Array_Element loop
 882          Element := Shared.Array_Elements.Table (Current);
 883          Real_Index_2 := Element.Index;
 884
 885          if not Element.Index_Case_Sensitive
 886            or else Force_Lower_Case_Index
 887          then
 888             if Element.Index /= All_Other_Names then
 889                Get_Name_String (Element.Index);
 890                To_Lower (Name_Buffer (1 .. Name_Len));
 891                Real_Index_2 := Name_Find;
 892             end if;
 893          end if;
 894
 895          if Src_Index = Element.Src_Index and then
 896            (Real_Index_1 = Real_Index_2 or else
 897               (Real_Index_2 /= All_Other_Names and then
 898                Allow_Wildcards and then
 899                  Match (Get_Name_String (Real_Index_1),
 900                         Compile (Get_Name_String (Real_Index_2),
 901                                  Glob => True))))
 902          then
 903             return Element.Value;
 904          else
 905             Current := Element.Next;
 906          end if;
 907       end loop;
 908
 909       return Nil_Variable_Value;
 910    end Value_Of;
 911
 912    function Value_Of
 913      (Name                    : Name_Id;
 914       Index                   : Int := 0;
 915       Attribute_Or_Array_Name : Name_Id;
 916       In_Package              : Package_Id;
 917       Shared                  : Shared_Project_Tree_Data_Access;
 918       Force_Lower_Case_Index  : Boolean := False;
 919       Allow_Wildcards         : Boolean := False) return Variable_Value
 920    is
 921       The_Array     : Array_Element_Id;
 922       The_Attribute : Variable_Value := Nil_Variable_Value;
 923
 924    begin
 925       if In_Package /= No_Package then
 926
 927          --  First, look if there is an array element that fits
 928
 929          The_Array :=
 930            Value_Of
 931              (Name      => Attribute_Or_Array_Name,
 932               In_Arrays => Shared.Packages.Table (In_Package).Decl.Arrays,
 933               Shared    => Shared);
 934          The_Attribute :=
 935            Value_Of
 936              (Index                  => Name,
 937               Src_Index              => Index,
 938               In_Array               => The_Array,
 939               Shared                 => Shared,
 940               Force_Lower_Case_Index => Force_Lower_Case_Index,
 941               Allow_Wildcards        => Allow_Wildcards);
 942
 943          --  If there is no array element, look for a variable
 944
 945          if The_Attribute = Nil_Variable_Value then
 946             The_Attribute :=
 947               Value_Of
 948                 (Variable_Name => Attribute_Or_Array_Name,
 949                  In_Variables  => Shared.Packages.Table
 950                    (In_Package).Decl.Attributes,
 951                  Shared        => Shared);
 952          end if;
 953       end if;
 954
 955       return The_Attribute;
 956    end Value_Of;
 957
 958    function Value_Of
 959      (Index     : Name_Id;
 960       In_Array  : Name_Id;
 961       In_Arrays : Array_Id;
 962       Shared    : Shared_Project_Tree_Data_Access) return Name_Id
 963    is
 964       Current   : Array_Id;
 965       The_Array : Array_Data;
 966
 967    begin
 968       Current := In_Arrays;
 969       while Current /= No_Array loop
 970          The_Array := Shared.Arrays.Table (Current);
 971          if The_Array.Name = In_Array then
 972             return Value_Of
 973               (Index, In_Array => The_Array.Value, Shared => Shared);
 974          else
 975             Current := The_Array.Next;
 976          end if;
 977       end loop;
 978
 979       return No_Name;
 980    end Value_Of;
 981
 982    function Value_Of
 983      (Name      : Name_Id;
 984       In_Arrays : Array_Id;
 985       Shared    : Shared_Project_Tree_Data_Access) return Array_Element_Id
 986    is
 987       Current   : Array_Id;
 988       The_Array : Array_Data;
 989
 990    begin
 991       Current := In_Arrays;
 992       while Current /= No_Array loop
 993          The_Array := Shared.Arrays.Table (Current);
 994
 995          if The_Array.Name = Name then
 996             return The_Array.Value;
 997          else
 998             Current := The_Array.Next;
 999          end if;
1000       end loop;
1001
1002       return No_Array_Element;
1003    end Value_Of;
1004
1005    function Value_Of
1006      (Name        : Name_Id;
1007       In_Packages : Package_Id;
1008       Shared      : Shared_Project_Tree_Data_Access) return Package_Id
1009    is
1010       Current     : Package_Id;
1011       The_Package : Package_Element;
1012
1013    begin
1014       Current := In_Packages;
1015       while Current /= No_Package loop
1016          The_Package := Shared.Packages.Table (Current);
1017          exit when The_Package.Name /= No_Name
1018            and then The_Package.Name = Name;
1019          Current := The_Package.Next;
1020       end loop;
1021
1022       return Current;
1023    end Value_Of;
1024
1025    function Value_Of
1026      (Variable_Name : Name_Id;
1027       In_Variables  : Variable_Id;
1028       Shared      : Shared_Project_Tree_Data_Access) return Variable_Value
1029    is
1030       Current      : Variable_Id;
1031       The_Variable : Variable;
1032
1033    begin
1034       Current := In_Variables;
1035       while Current /= No_Variable loop
1036          The_Variable := Shared.Variable_Elements.Table (Current);
1037
1038          if Variable_Name = The_Variable.Name then
1039             return The_Variable.Value;
1040          else
1041             Current := The_Variable.Next;
1042          end if;
1043       end loop;
1044
1045       return Nil_Variable_Value;
1046    end Value_Of;
1047
1048    ----------------------------
1049    -- Write_Source_Info_File --
1050    ----------------------------
1051
1052    procedure Write_Source_Info_File (Tree : Project_Tree_Ref) is
1053       Iter   : Source_Iterator := For_Each_Source (Tree);
1054       Source : Prj.Source_Id;
1055       File   : Text_File;
1056
1057    begin
1058       if Opt.Verbose_Mode then
1059          Write_Line ("Writing new source info file " &
1060                      Tree.Source_Info_File_Name.all);
1061       end if;
1062
1063       Create (File, Tree.Source_Info_File_Name.all);
1064
1065       if not Is_Valid (File) then
1066          Write_Line ("warning: unable to create source info file """ &
1067                      Tree.Source_Info_File_Name.all & '"');
1068          return;
1069       end if;
1070
1071       loop
1072          Source := Element (Iter);
1073          exit when Source = No_Source;
1074
1075          if not Source.Locally_Removed and then
1076            Source.Replaced_By = No_Source
1077          then
1078             --  Project name
1079
1080             Put_Line (File, Get_Name_String (Source.Project.Name));
1081
1082             --  Language name
1083
1084             Put_Line (File, Get_Name_String (Source.Language.Name));
1085
1086             --  Kind
1087
1088             Put_Line (File, Source.Kind'Img);
1089
1090             --  Display path name
1091
1092             Put_Line (File, Get_Name_String (Source.Path.Display_Name));
1093
1094             --  Optional lines:
1095
1096             --  Path name (P=)
1097
1098             if Source.Path.Name /= Source.Path.Display_Name then
1099                Put (File, "P=");
1100                Put_Line (File, Get_Name_String (Source.Path.Name));
1101             end if;
1102
1103             --  Unit name (U=)
1104
1105             if Source.Unit /= No_Unit_Index then
1106                Put (File, "U=");
1107                Put_Line (File, Get_Name_String (Source.Unit.Name));
1108             end if;
1109
1110             --  Multi-source index (I=)
1111
1112             if Source.Index /= 0 then
1113                Put (File, "I=");
1114                Put_Line (File, Source.Index'Img);
1115             end if;
1116
1117             --  Naming exception ("N=T");
1118
1119             if Source.Naming_Exception then
1120                Put_Line (File, "N=T");
1121             end if;
1122
1123             --  Empty line to indicate end of info on this source
1124
1125             Put_Line (File, "");
1126          end if;
1127
1128          Next (Iter);
1129       end loop;
1130
1131       Close (File);
1132    end Write_Source_Info_File;
1133
1134    ---------------
1135    -- Write_Str --
1136    ---------------
1137
1138    procedure Write_Str
1139      (S          : String;
1140       Max_Length : Positive;
1141       Separator  : Character)
1142    is
1143       First : Positive := S'First;
1144       Last  : Natural  := S'Last;
1145
1146    begin
1147       --  Nothing to do for empty strings
1148
1149       if S'Length > 0 then
1150
1151          --  Start on a new line if current line is already longer than
1152          --  Max_Length.
1153
1154          if Positive (Column) >= Max_Length then
1155             Write_Eol;
1156          end if;
1157
1158          --  If length of remainder is longer than Max_Length, we need to
1159          --  cut the remainder in several lines.
1160
1161          while Positive (Column) + S'Last - First > Max_Length loop
1162
1163             --  Try the maximum length possible
1164
1165             Last := First + Max_Length - Positive (Column);
1166
1167             --  Look for last Separator in the line
1168
1169             while Last >= First and then S (Last) /= Separator loop
1170                Last := Last - 1;
1171             end loop;
1172
1173             --  If we do not find a separator, we output the maximum length
1174             --  possible.
1175
1176             if Last < First then
1177                Last := First + Max_Length - Positive (Column);
1178             end if;
1179
1180             Write_Line (S (First .. Last));
1181
1182             --  Set the beginning of the new remainder
1183
1184             First := Last + 1;
1185          end loop;
1186
1187          --  What is left goes to the buffer, without EOL
1188
1189          Write_Str (S (First .. S'Last));
1190       end if;
1191    end Write_Str;
1192 end Prj.Util;