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-2010, 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       In_Tree : Project_Tree_Ref)
 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 (In_Tree.Name_Lists);
 141          New_Current := Name_List_Table.Last (In_Tree.Name_Lists);
 142          This := New_Current;
 143          In_Tree.Name_Lists.Table (New_Current) :=
 144            (In_Tree.Name_Lists.Table (Old_Current).Name, No_Name_List);
 145
 146          loop
 147             Old_Current := In_Tree.Name_Lists.Table (Old_Current).Next;
 148             exit when Old_Current = No_Name_List;
 149             In_Tree.Name_Lists.Table (New_Current).Next := New_Current + 1;
 150             Name_List_Table.Increment_Last (In_Tree.Name_Lists);
 151             New_Current := New_Current + 1;
 152             In_Tree.Name_Lists.Table (New_Current) :=
 153               (In_Tree.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       In_Tree  : Project_Tree_Ref;
 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                              In_Tree     => In_Tree);
 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                         In_Tree                 => In_Tree);
 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                    In_Tree.Packages.Table (Builder_Package).Decl.Attributes,
 270                  In_Tree       => In_Tree);
 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                        In_Tree                 => In_Tree);
 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       Current_Name : Name_List_Index;
 558       List         : String_List_Id;
 559       Element      : String_Element;
 560       Last         : Name_List_Index :=
 561                        Name_List_Table.Last (In_Tree.Name_Lists);
 562       Value        : Name_Id;
 563
 564    begin
 565       Current_Name := Into_List;
 566       while Current_Name /= No_Name_List
 567         and then In_Tree.Name_Lists.Table (Current_Name).Next /= No_Name_List
 568       loop
 569          Current_Name := In_Tree.Name_Lists.Table (Current_Name).Next;
 570       end loop;
 571
 572       List := From_List;
 573       while List /= Nil_String loop
 574          Element := In_Tree.String_Elements.Table (List);
 575          Value := Element.Value;
 576
 577          if Lower_Case then
 578             Get_Name_String (Value);
 579             To_Lower (Name_Buffer (1 .. Name_Len));
 580             Value := Name_Find;
 581          end if;
 582
 583          Name_List_Table.Append
 584            (In_Tree.Name_Lists, (Name => Value, Next => No_Name_List));
 585
 586          Last := Last + 1;
 587
 588          if Current_Name = No_Name_List then
 589             Into_List := Last;
 590
 591          else
 592             In_Tree.Name_Lists.Table (Current_Name).Next := Last;
 593          end if;
 594
 595          Current_Name := Last;
 596
 597          List := Element.Next;
 598       end loop;
 599    end Put;
 600
 601    procedure Put (File : Text_File; S : String) is
 602       Len : Integer;
 603    begin
 604       if File = null then
 605          Prj.Com.Fail ("Attempted to write on an invalid Text_File");
 606
 607       elsif not File.Out_File then
 608          Prj.Com.Fail ("Attempted to write an in Text_File");
 609       end if;
 610
 611       if File.Buffer_Len + S'Length > File.Buffer'Last then
 612          --  Write buffer
 613          Len := Write (File.FD, File.Buffer'Address, File.Buffer_Len);
 614
 615          if Len /= File.Buffer_Len then
 616             Prj.Com.Fail ("Failed to write to an out Text_File");
 617          end if;
 618
 619          File.Buffer_Len := 0;
 620       end if;
 621
 622       File.Buffer (File.Buffer_Len + 1 .. File.Buffer_Len + S'Length) := S;
 623       File.Buffer_Len := File.Buffer_Len + S'Length;
 624    end Put;
 625
 626    --------------
 627    -- Put_Line --
 628    --------------
 629
 630    procedure Put_Line (File : Text_File; Line : String) is
 631       L : String (1 .. Line'Length + 1);
 632    begin
 633       L (1 .. Line'Length) := Line;
 634       L (L'Last) := ASCII.LF;
 635       Put (File, L);
 636    end Put_Line;
 637
 638    ---------------------------
 639    -- Read_Source_Info_File --
 640    ---------------------------
 641
 642    procedure Read_Source_Info_File (Tree : Project_Tree_Ref) is
 643       File : Text_File;
 644       Info : Source_Info_Iterator;
 645       Proj : Name_Id;
 646
 647       procedure Report_Error;
 648
 649       ------------------
 650       -- Report_Error --
 651       ------------------
 652
 653       procedure Report_Error is
 654       begin
 655          Write_Line ("errors in source info file """ &
 656                      Tree.Source_Info_File_Name.all & '"');
 657          Tree.Source_Info_File_Exists := False;
 658       end Report_Error;
 659
 660    begin
 661       Source_Info_Project_HTable.Reset;
 662       Source_Info_Table.Init;
 663
 664       if Tree.Source_Info_File_Name = null then
 665          Tree.Source_Info_File_Exists := False;
 666          return;
 667       end if;
 668
 669       Open (File, Tree.Source_Info_File_Name.all);
 670
 671       if not Is_Valid (File) then
 672          if Opt.Verbose_Mode then
 673             Write_Line ("source info file " & Tree.Source_Info_File_Name.all &
 674                         " does not exist");
 675          end if;
 676
 677          Tree.Source_Info_File_Exists := False;
 678          return;
 679       end if;
 680
 681       Tree.Source_Info_File_Exists := True;
 682
 683       if Opt.Verbose_Mode then
 684          Write_Line ("Reading source info file " &
 685                      Tree.Source_Info_File_Name.all);
 686       end if;
 687
 688       Source_Loop :
 689       while not End_Of_File (File) loop
 690          Info := (new Source_Info_Data, 0);
 691          Source_Info_Table.Increment_Last;
 692
 693          --  project name
 694          Get_Line (File, Name_Buffer, Name_Len);
 695          Proj := Name_Find;
 696          Info.Info.Project := Proj;
 697          Info.Next := Source_Info_Project_HTable.Get (Proj);
 698          Source_Info_Project_HTable.Set (Proj, Source_Info_Table.Last);
 699
 700          if End_Of_File (File) then
 701             Report_Error;
 702             exit Source_Loop;
 703          end if;
 704
 705          --  language name
 706          Get_Line (File, Name_Buffer, Name_Len);
 707          Info.Info.Language := Name_Find;
 708
 709          if End_Of_File (File) then
 710             Report_Error;
 711             exit Source_Loop;
 712          end if;
 713
 714          --  kind
 715          Get_Line (File, Name_Buffer, Name_Len);
 716          Info.Info.Kind := Source_Kind'Value (Name_Buffer (1 .. Name_Len));
 717
 718          if End_Of_File (File) then
 719             Report_Error;
 720             exit Source_Loop;
 721          end if;
 722
 723          --  display path name
 724          Get_Line (File, Name_Buffer, Name_Len);
 725          Info.Info.Display_Path_Name := Name_Find;
 726          Info.Info.Path_Name := Info.Info.Display_Path_Name;
 727
 728          if End_Of_File (File) then
 729             Report_Error;
 730             exit Source_Loop;
 731          end if;
 732
 733          --  optional fields
 734          Option_Loop :
 735          loop
 736             Get_Line (File, Name_Buffer, Name_Len);
 737             exit Option_Loop when Name_Len = 0;
 738
 739             if Name_Len <= 2 then
 740                Report_Error;
 741                exit Source_Loop;
 742
 743             else
 744                if Name_Buffer (1 .. 2) = "P=" then
 745                   Name_Buffer (1 .. Name_Len - 2) :=
 746                     Name_Buffer (3 .. Name_Len);
 747                   Name_Len := Name_Len - 2;
 748                   Info.Info.Path_Name := Name_Find;
 749
 750                elsif Name_Buffer (1 .. 2) = "U=" then
 751                   Name_Buffer (1 .. Name_Len - 2) :=
 752                     Name_Buffer (3 .. Name_Len);
 753                   Name_Len := Name_Len - 2;
 754                   Info.Info.Unit_Name := Name_Find;
 755
 756                elsif Name_Buffer (1 .. 2) = "I=" then
 757                   Info.Info.Index := Int'Value (Name_Buffer (3 .. Name_Len));
 758
 759                elsif Name_Buffer (1 .. Name_Len) = "N=T" then
 760                   Info.Info.Naming_Exception := True;
 761
 762                else
 763                   Report_Error;
 764                   exit Source_Loop;
 765                end if;
 766             end if;
 767          end loop Option_Loop;
 768
 769          Source_Info_Table.Table (Source_Info_Table.Last) := Info;
 770       end loop Source_Loop;
 771
 772       Close (File);
 773
 774    exception
 775       when others =>
 776          Close (File);
 777          Report_Error;
 778    end Read_Source_Info_File;
 779
 780    --------------------
 781    -- Source_Info_Of --
 782    --------------------
 783
 784    function Source_Info_Of (Iter : Source_Info_Iterator) return Source_Info is
 785    begin
 786       return Iter.Info;
 787    end Source_Info_Of;
 788
 789    --------------
 790    -- Value_Of --
 791    --------------
 792
 793    function Value_Of
 794      (Variable : Variable_Value;
 795       Default  : String) return String
 796    is
 797    begin
 798       if Variable.Kind /= Single
 799         or else Variable.Default
 800         or else Variable.Value = No_Name
 801       then
 802          return Default;
 803       else
 804          return Get_Name_String (Variable.Value);
 805       end if;
 806    end Value_Of;
 807
 808    function Value_Of
 809      (Index    : Name_Id;
 810       In_Array : Array_Element_Id;
 811       In_Tree  : Project_Tree_Ref) return Name_Id
 812    is
 813       Current    : Array_Element_Id;
 814       Element    : Array_Element;
 815       Real_Index : Name_Id := Index;
 816
 817    begin
 818       Current := In_Array;
 819
 820       if Current = No_Array_Element then
 821          return No_Name;
 822       end if;
 823
 824       Element := In_Tree.Array_Elements.Table (Current);
 825
 826       if not Element.Index_Case_Sensitive then
 827          Get_Name_String (Index);
 828          To_Lower (Name_Buffer (1 .. Name_Len));
 829          Real_Index := Name_Find;
 830       end if;
 831
 832       while Current /= No_Array_Element loop
 833          Element := In_Tree.Array_Elements.Table (Current);
 834
 835          if Real_Index = Element.Index then
 836             exit when Element.Value.Kind /= Single;
 837             exit when Element.Value.Value = Empty_String;
 838             return Element.Value.Value;
 839          else
 840             Current := Element.Next;
 841          end if;
 842       end loop;
 843
 844       return No_Name;
 845    end Value_Of;
 846
 847    function Value_Of
 848      (Index                  : Name_Id;
 849       Src_Index              : Int := 0;
 850       In_Array               : Array_Element_Id;
 851       In_Tree                : Project_Tree_Ref;
 852       Force_Lower_Case_Index : Boolean := False;
 853       Allow_Wildcards        : Boolean := False) return Variable_Value
 854    is
 855       Current      : Array_Element_Id;
 856       Element      : Array_Element;
 857       Real_Index_1 : Name_Id;
 858       Real_Index_2 : Name_Id;
 859
 860    begin
 861       Current := In_Array;
 862
 863       if Current = No_Array_Element then
 864          return Nil_Variable_Value;
 865       end if;
 866
 867       Element := In_Tree.Array_Elements.Table (Current);
 868
 869       Real_Index_1 := Index;
 870
 871       if not Element.Index_Case_Sensitive or else Force_Lower_Case_Index then
 872          if Index /= All_Other_Names then
 873             Get_Name_String (Index);
 874             To_Lower (Name_Buffer (1 .. Name_Len));
 875             Real_Index_1 := Name_Find;
 876          end if;
 877       end if;
 878
 879       while Current /= No_Array_Element loop
 880          Element := In_Tree.Array_Elements.Table (Current);
 881          Real_Index_2 := Element.Index;
 882
 883          if not Element.Index_Case_Sensitive
 884            or else Force_Lower_Case_Index
 885          then
 886             if Element.Index /= All_Other_Names then
 887                Get_Name_String (Element.Index);
 888                To_Lower (Name_Buffer (1 .. Name_Len));
 889                Real_Index_2 := Name_Find;
 890             end if;
 891          end if;
 892
 893          if Src_Index = Element.Src_Index and then
 894            (Real_Index_1 = Real_Index_2 or else
 895               (Real_Index_2 /= All_Other_Names and then
 896                Allow_Wildcards and then
 897                  Match (Get_Name_String (Real_Index_1),
 898                         Compile (Get_Name_String (Real_Index_2),
 899                                  Glob => True))))
 900          then
 901             return Element.Value;
 902          else
 903             Current := Element.Next;
 904          end if;
 905       end loop;
 906
 907       return Nil_Variable_Value;
 908    end Value_Of;
 909
 910    function Value_Of
 911      (Name                    : Name_Id;
 912       Index                   : Int := 0;
 913       Attribute_Or_Array_Name : Name_Id;
 914       In_Package              : Package_Id;
 915       In_Tree                 : Project_Tree_Ref;
 916       Force_Lower_Case_Index  : Boolean := False;
 917       Allow_Wildcards         : Boolean := False) return Variable_Value
 918    is
 919       The_Array     : Array_Element_Id;
 920       The_Attribute : Variable_Value := Nil_Variable_Value;
 921
 922    begin
 923       if In_Package /= No_Package then
 924
 925          --  First, look if there is an array element that fits
 926
 927          The_Array :=
 928            Value_Of
 929              (Name      => Attribute_Or_Array_Name,
 930               In_Arrays => In_Tree.Packages.Table (In_Package).Decl.Arrays,
 931               In_Tree   => In_Tree);
 932          The_Attribute :=
 933            Value_Of
 934              (Index                  => Name,
 935               Src_Index              => Index,
 936               In_Array               => The_Array,
 937               In_Tree                => In_Tree,
 938               Force_Lower_Case_Index => Force_Lower_Case_Index,
 939               Allow_Wildcards        => Allow_Wildcards);
 940
 941          --  If there is no array element, look for a variable
 942
 943          if The_Attribute = Nil_Variable_Value then
 944             The_Attribute :=
 945               Value_Of
 946                 (Variable_Name => Attribute_Or_Array_Name,
 947                  In_Variables  => In_Tree.Packages.Table
 948                                     (In_Package).Decl.Attributes,
 949                  In_Tree       => In_Tree);
 950          end if;
 951       end if;
 952
 953       return The_Attribute;
 954    end Value_Of;
 955
 956    function Value_Of
 957      (Index     : Name_Id;
 958       In_Array  : Name_Id;
 959       In_Arrays : Array_Id;
 960       In_Tree   : Project_Tree_Ref) return Name_Id
 961    is
 962       Current   : Array_Id;
 963       The_Array : Array_Data;
 964
 965    begin
 966       Current := In_Arrays;
 967       while Current /= No_Array loop
 968          The_Array := In_Tree.Arrays.Table (Current);
 969          if The_Array.Name = In_Array then
 970             return Value_Of
 971               (Index, In_Array => The_Array.Value, In_Tree => In_Tree);
 972          else
 973             Current := The_Array.Next;
 974          end if;
 975       end loop;
 976
 977       return No_Name;
 978    end Value_Of;
 979
 980    function Value_Of
 981      (Name      : Name_Id;
 982       In_Arrays : Array_Id;
 983       In_Tree   : Project_Tree_Ref) return Array_Element_Id
 984    is
 985       Current   : Array_Id;
 986       The_Array : Array_Data;
 987
 988    begin
 989       Current := In_Arrays;
 990       while Current /= No_Array loop
 991          The_Array := In_Tree.Arrays.Table (Current);
 992
 993          if The_Array.Name = Name then
 994             return The_Array.Value;
 995          else
 996             Current := The_Array.Next;
 997          end if;
 998       end loop;
 999
1000       return No_Array_Element;
1001    end Value_Of;
1002
1003    function Value_Of
1004      (Name        : Name_Id;
1005       In_Packages : Package_Id;
1006       In_Tree     : Project_Tree_Ref) return Package_Id
1007    is
1008       Current     : Package_Id;
1009       The_Package : Package_Element;
1010
1011    begin
1012       Current := In_Packages;
1013       while Current /= No_Package loop
1014          The_Package := In_Tree.Packages.Table (Current);
1015          exit when The_Package.Name /= No_Name
1016            and then The_Package.Name = Name;
1017          Current := The_Package.Next;
1018       end loop;
1019
1020       return Current;
1021    end Value_Of;
1022
1023    function Value_Of
1024      (Variable_Name : Name_Id;
1025       In_Variables  : Variable_Id;
1026       In_Tree       : Project_Tree_Ref) return Variable_Value
1027    is
1028       Current      : Variable_Id;
1029       The_Variable : Variable;
1030
1031    begin
1032       Current := In_Variables;
1033       while Current /= No_Variable loop
1034          The_Variable :=
1035            In_Tree.Variable_Elements.Table (Current);
1036
1037          if Variable_Name = The_Variable.Name then
1038             return The_Variable.Value;
1039          else
1040             Current := The_Variable.Next;
1041          end if;
1042       end loop;
1043
1044       return Nil_Variable_Value;
1045    end Value_Of;
1046
1047    ----------------------------
1048    -- Write_Source_Info_File --
1049    ----------------------------
1050
1051    procedure Write_Source_Info_File (Tree : Project_Tree_Ref) is
1052       Iter   : Source_Iterator := For_Each_Source (Tree);
1053       Source : Prj.Source_Id;
1054       File   : Text_File;
1055
1056    begin
1057       if Opt.Verbose_Mode then
1058          Write_Line ("Writing new source info file " &
1059                      Tree.Source_Info_File_Name.all);
1060       end if;
1061
1062       Create (File, Tree.Source_Info_File_Name.all);
1063
1064       if not Is_Valid (File) then
1065          Write_Line ("warning: unable to create source info file """ &
1066                      Tree.Source_Info_File_Name.all & '"');
1067          return;
1068       end if;
1069
1070       loop
1071          Source := Element (Iter);
1072          exit when Source = No_Source;
1073
1074          if not Source.Locally_Removed and then
1075            Source.Replaced_By = No_Source
1076          then
1077             --  Project name
1078
1079             Put_Line (File, Get_Name_String (Source.Project.Name));
1080
1081             --  Language name
1082
1083             Put_Line (File, Get_Name_String (Source.Language.Name));
1084
1085             --  Kind
1086
1087             Put_Line (File, Source.Kind'Img);
1088
1089             --  Display path name
1090
1091             Put_Line (File, Get_Name_String (Source.Path.Display_Name));
1092
1093             --  Optional lines:
1094
1095             --  Path name (P=)
1096
1097             if Source.Path.Name /= Source.Path.Display_Name then
1098                Put (File, "P=");
1099                Put_Line (File, Get_Name_String (Source.Path.Name));
1100             end if;
1101
1102             --  Unit name (U=)
1103
1104             if Source.Unit /= No_Unit_Index then
1105                Put (File, "U=");
1106                Put_Line (File, Get_Name_String (Source.Unit.Name));
1107             end if;
1108
1109             --  Multi-source index (I=)
1110
1111             if Source.Index /= 0 then
1112                Put (File, "I=");
1113                Put_Line (File, Source.Index'Img);
1114             end if;
1115
1116             --  Naming exception ("N=T");
1117
1118             if Source.Naming_Exception then
1119                Put_Line (File, "N=T");
1120             end if;
1121
1122             --  Empty line to indicate end of info on this source
1123
1124             Put_Line (File, "");
1125          end if;
1126
1127          Next (Iter);
1128       end loop;
1129
1130       Close (File);
1131    end Write_Source_Info_File;
1132
1133    ---------------
1134    -- Write_Str --
1135    ---------------
1136
1137    procedure Write_Str
1138      (S          : String;
1139       Max_Length : Positive;
1140       Separator  : Character)
1141    is
1142       First : Positive := S'First;
1143       Last  : Natural  := S'Last;
1144
1145    begin
1146       --  Nothing to do for empty strings
1147
1148       if S'Length > 0 then
1149
1150          --  Start on a new line if current line is already longer than
1151          --  Max_Length.
1152
1153          if Positive (Column) >= Max_Length then
1154             Write_Eol;
1155          end if;
1156
1157          --  If length of remainder is longer than Max_Length, we need to
1158          --  cut the remainder in several lines.
1159
1160          while Positive (Column) + S'Last - First > Max_Length loop
1161
1162             --  Try the maximum length possible
1163
1164             Last := First + Max_Length - Positive (Column);
1165
1166             --  Look for last Separator in the line
1167
1168             while Last >= First and then S (Last) /= Separator loop
1169                Last := Last - 1;
1170             end loop;
1171
1172             --  If we do not find a separator, we output the maximum length
1173             --  possible.
1174
1175             if Last < First then
1176                Last := First + Max_Length - Positive (Column);
1177             end if;
1178
1179             Write_Line (S (First .. Last));
1180
1181             --  Set the beginning of the new remainder
1182
1183             First := Last + 1;
1184          end loop;
1185
1186          --  What is left goes to the buffer, without EOL
1187
1188          Write_Str (S (First .. S'Last));
1189       end if;
1190    end Write_Str;
1191 end Prj.Util;