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-2007, 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 2,  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 COPYING.  If not, write --
  19 -- to  the  Free Software Foundation,  51  Franklin  Street,  Fifth  Floor, --
  20 -- Boston, MA 02110-1301, USA.                                              --
  21 --                                                                          --
  22 -- GNAT was originally developed  by the GNAT team at  New York University. --
  23 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  24 --                                                                          --
  25 ------------------------------------------------------------------------------
  26
  27 with Ada.Unchecked_Deallocation;
  28
  29 with GNAT.Case_Util; use GNAT.Case_Util;
  30
  31 with Osint;    use Osint;
  32 with Output;   use Output;
  33 with Prj.Com;
  34 with Snames;   use Snames;
  35 with Targparm; use Targparm;
  36
  37 package body Prj.Util is
  38
  39    procedure Free is new Ada.Unchecked_Deallocation
  40      (Text_File_Data, Text_File);
  41
  42    -----------
  43    -- Close --
  44    -----------
  45
  46    procedure Close (File : in out Text_File) is
  47    begin
  48       if File = null then
  49          Prj.Com.Fail ("Close attempted on an invalid Text_File");
  50       end if;
  51
  52       --  Close file, no need to test status, since this is a file that we
  53       --  read, and the file was read successfully before we closed it.
  54
  55       Close (File.FD);
  56       Free (File);
  57    end Close;
  58
  59    ---------------
  60    -- Duplicate --
  61    ---------------
  62
  63    procedure Duplicate
  64      (This    : in out Name_List_Index;
  65       In_Tree : Project_Tree_Ref)
  66    is
  67       Old_Current : Name_List_Index;
  68       New_Current : Name_List_Index;
  69
  70    begin
  71       if This /= No_Name_List then
  72          Old_Current := This;
  73          Name_List_Table.Increment_Last (In_Tree.Name_Lists);
  74          New_Current := Name_List_Table.Last (In_Tree.Name_Lists);
  75          This := New_Current;
  76          In_Tree.Name_Lists.Table (New_Current) :=
  77            (In_Tree.Name_Lists.Table (Old_Current).Name, No_Name_List);
  78
  79          loop
  80             Old_Current := In_Tree.Name_Lists.Table (Old_Current).Next;
  81             exit when Old_Current = No_Name_List;
  82             In_Tree.Name_Lists.Table (New_Current).Next := New_Current + 1;
  83             Name_List_Table.Increment_Last (In_Tree.Name_Lists);
  84             New_Current := New_Current + 1;
  85             In_Tree.Name_Lists.Table (New_Current) :=
  86               (In_Tree.Name_Lists.Table (Old_Current).Name, No_Name_List);
  87          end loop;
  88       end if;
  89    end Duplicate;
  90
  91    -----------------
  92    -- End_Of_File --
  93    -----------------
  94
  95    function End_Of_File (File : Text_File) return Boolean is
  96    begin
  97       if File = null then
  98          Prj.Com.Fail ("End_Of_File attempted on an invalid Text_File");
  99       end if;
 100
 101       return File.End_Of_File_Reached;
 102    end End_Of_File;
 103
 104    -------------------
 105    -- Executable_Of --
 106    -------------------
 107
 108    function Executable_Of
 109      (Project  : Project_Id;
 110       In_Tree  : Project_Tree_Ref;
 111       Main     : File_Name_Type;
 112       Index    : Int;
 113       Ada_Main : Boolean := True) return File_Name_Type
 114    is
 115       pragma Assert (Project /= No_Project);
 116
 117       The_Packages : constant Package_Id :=
 118                        In_Tree.Projects.Table (Project).Decl.Packages;
 119
 120       Builder_Package : constant Prj.Package_Id :=
 121                           Prj.Util.Value_Of
 122                             (Name        => Name_Builder,
 123                              In_Packages => The_Packages,
 124                              In_Tree     => In_Tree);
 125
 126       Executable : Variable_Value :=
 127                      Prj.Util.Value_Of
 128                        (Name                    => Name_Id (Main),
 129                         Index                   => Index,
 130                         Attribute_Or_Array_Name => Name_Executable,
 131                         In_Package              => Builder_Package,
 132                         In_Tree                 => In_Tree);
 133
 134       Executable_Suffix : Variable_Value := Nil_Variable_Value;
 135
 136       Executable_Suffix_Name : Name_Id := No_Name;
 137
 138       Naming : constant Naming_Data := In_Tree.Projects.Table (Project).Naming;
 139
 140       Body_Suffix : constant String :=
 141                       Body_Suffix_Of (In_Tree, "ada", Naming);
 142
 143       Spec_Suffix : constant String :=
 144                       Spec_Suffix_Of (In_Tree, "ada", Naming);
 145
 146    begin
 147       if Builder_Package /= No_Package then
 148          if Get_Mode = Multi_Language then
 149             Executable_Suffix_Name := In_Tree.Config.Executable_Suffix;
 150
 151          else
 152             Executable_Suffix := Prj.Util.Value_Of
 153               (Variable_Name => Name_Executable_Suffix,
 154                In_Variables  => In_Tree.Packages.Table
 155                  (Builder_Package).Decl.Attributes,
 156                In_Tree       => In_Tree);
 157
 158             if Executable_Suffix /= Nil_Variable_Value
 159               and then not Executable_Suffix.Default
 160             then
 161                Executable_Suffix_Name := Executable_Suffix.Value;
 162             end if;
 163          end if;
 164
 165          if Executable = Nil_Variable_Value and Ada_Main then
 166             Get_Name_String (Main);
 167
 168             --  Try as index the name minus the implementation suffix or minus
 169             --  the specification suffix.
 170
 171             declare
 172                Name : constant String (1 .. Name_Len) :=
 173                         Name_Buffer (1 .. Name_Len);
 174                Last : Positive := Name_Len;
 175
 176                Truncated : Boolean := False;
 177
 178             begin
 179                if Last > Body_Suffix'Length
 180                   and then Name (Last - Body_Suffix'Length + 1 .. Last) =
 181                                                                   Body_Suffix
 182                then
 183                   Truncated := True;
 184                   Last := Last - Body_Suffix'Length;
 185                end if;
 186
 187                if not Truncated
 188                  and then Last > Spec_Suffix'Length
 189                  and then Name (Last - Spec_Suffix'Length + 1 .. Last) =
 190                                                                  Spec_Suffix
 191                then
 192                   Truncated := True;
 193                   Last := Last - Spec_Suffix'Length;
 194                end if;
 195
 196                if Truncated then
 197                   Name_Len := Last;
 198                   Name_Buffer (1 .. Name_Len) := Name (1 .. Last);
 199                   Executable :=
 200                     Prj.Util.Value_Of
 201                       (Name                    => Name_Find,
 202                        Index                   => 0,
 203                        Attribute_Or_Array_Name => Name_Executable,
 204                        In_Package              => Builder_Package,
 205                        In_Tree                 => In_Tree);
 206                end if;
 207             end;
 208          end if;
 209
 210          --  If we have found an Executable attribute, return its value,
 211          --  possibly suffixed by the executable suffix.
 212
 213          if Executable /= Nil_Variable_Value
 214            and then Executable.Value /= Empty_Name
 215          then
 216             --  Get the executable name. If Executable_Suffix is defined,
 217             --  make sure that it will be the extension of the executable.
 218
 219             declare
 220                Saved_EEOT : constant Name_Id := Executable_Extension_On_Target;
 221                Result     : File_Name_Type;
 222
 223             begin
 224                if Executable_Suffix_Name /= No_Name then
 225                   Executable_Extension_On_Target := Executable_Suffix_Name;
 226                end if;
 227
 228                Result :=  Executable_Name (File_Name_Type (Executable.Value));
 229                Executable_Extension_On_Target := Saved_EEOT;
 230                return Result;
 231             end;
 232          end if;
 233       end if;
 234
 235       Get_Name_String (Main);
 236
 237       --  If there is a body suffix or a spec suffix, remove this suffix,
 238       --  otherwise remove any suffix ('.' followed by other characters), if
 239       --  there is one.
 240
 241       if Ada_Main and then Name_Len > Body_Suffix'Length
 242          and then Name_Buffer (Name_Len - Body_Suffix'Length + 1 .. Name_Len) =
 243                     Body_Suffix
 244       then
 245          --  Found the body termination, remove it
 246
 247          Name_Len := Name_Len - Body_Suffix'Length;
 248
 249       elsif Ada_Main and then Name_Len > Spec_Suffix'Length
 250          and then Name_Buffer (Name_Len - Spec_Suffix'Length + 1 .. Name_Len) =
 251                     Spec_Suffix
 252       then
 253          --  Found the spec termination, remove it
 254
 255          Name_Len := Name_Len - Spec_Suffix'Length;
 256
 257       else
 258          --  Remove any suffix, if there is one
 259
 260          Get_Name_String (Strip_Suffix (Main));
 261       end if;
 262
 263       if Executable_Suffix /= Nil_Variable_Value
 264         and then not Executable_Suffix.Default
 265       then
 266          --  If attribute Executable_Suffix is specified, add this suffix
 267
 268          declare
 269             Suffix : constant String :=
 270                        Get_Name_String (Executable_Suffix.Value);
 271          begin
 272             Name_Buffer (Name_Len + 1 .. Name_Len + Suffix'Length) := Suffix;
 273             Name_Len := Name_Len + Suffix'Length;
 274             return Name_Find;
 275          end;
 276
 277       else
 278          --  Get the executable name. If Executable_Suffix is defined in the
 279          --  configuration, make sure that it will be the extension of the
 280          --  executable.
 281
 282          declare
 283             Saved_EEOT : constant Name_Id := Executable_Extension_On_Target;
 284             Result     : File_Name_Type;
 285
 286          begin
 287             Executable_Extension_On_Target := In_Tree.Config.Executable_Suffix;
 288             Result := Executable_Name (Name_Find);
 289             Executable_Extension_On_Target := Saved_EEOT;
 290             return Result;
 291          end;
 292       end if;
 293    end Executable_Of;
 294
 295    --------------
 296    -- Get_Line --
 297    --------------
 298
 299    procedure Get_Line
 300      (File : Text_File;
 301       Line : out String;
 302       Last : out Natural)
 303    is
 304       C : Character;
 305
 306       procedure Advance;
 307
 308       -------------
 309       -- Advance --
 310       -------------
 311
 312       procedure Advance is
 313       begin
 314          if File.Cursor = File.Buffer_Len then
 315             File.Buffer_Len :=
 316               Read
 317                (FD => File.FD,
 318                 A  => File.Buffer'Address,
 319                 N  => File.Buffer'Length);
 320
 321             if File.Buffer_Len = 0 then
 322                File.End_Of_File_Reached := True;
 323                return;
 324             else
 325                File.Cursor := 1;
 326             end if;
 327
 328          else
 329             File.Cursor := File.Cursor + 1;
 330          end if;
 331       end Advance;
 332
 333    --  Start of processing for Get_Line
 334
 335    begin
 336       if File = null then
 337          Prj.Com.Fail ("Get_Line attempted on an invalid Text_File");
 338       end if;
 339
 340       Last := Line'First - 1;
 341
 342       if not File.End_Of_File_Reached then
 343          loop
 344             C := File.Buffer (File.Cursor);
 345             exit when C = ASCII.CR or else C = ASCII.LF;
 346             Last := Last + 1;
 347             Line (Last) := C;
 348             Advance;
 349
 350             if File.End_Of_File_Reached then
 351                return;
 352             end if;
 353
 354             exit when Last = Line'Last;
 355          end loop;
 356
 357          if C = ASCII.CR or else C = ASCII.LF then
 358             Advance;
 359
 360             if File.End_Of_File_Reached then
 361                return;
 362             end if;
 363          end if;
 364
 365          if C = ASCII.CR
 366            and then File.Buffer (File.Cursor) = ASCII.LF
 367          then
 368             Advance;
 369          end if;
 370       end if;
 371    end Get_Line;
 372
 373    --------------
 374    -- Is_Valid --
 375    --------------
 376
 377    function Is_Valid (File : Text_File) return Boolean is
 378    begin
 379       return File /= null;
 380    end Is_Valid;
 381
 382    ----------
 383    -- Open --
 384    ----------
 385
 386    procedure Open (File : out Text_File; Name : String) is
 387       FD        : File_Descriptor;
 388       File_Name : String (1 .. Name'Length + 1);
 389
 390    begin
 391       File_Name (1 .. Name'Length) := Name;
 392       File_Name (File_Name'Last) := ASCII.NUL;
 393       FD := Open_Read (Name => File_Name'Address,
 394                        Fmode => GNAT.OS_Lib.Text);
 395
 396       if FD = Invalid_FD then
 397          File := null;
 398
 399       else
 400          File := new Text_File_Data;
 401          File.FD := FD;
 402          File.Buffer_Len :=
 403            Read (FD => FD,
 404                  A  => File.Buffer'Address,
 405                  N  => File.Buffer'Length);
 406
 407          if File.Buffer_Len = 0 then
 408             File.End_Of_File_Reached := True;
 409          else
 410             File.Cursor := 1;
 411          end if;
 412       end if;
 413    end Open;
 414
 415    ---------
 416    -- Put --
 417    ---------
 418
 419    procedure Put
 420      (Into_List : in out Name_List_Index;
 421       From_List : String_List_Id;
 422       In_Tree   : Project_Tree_Ref)
 423    is
 424       Current_Name : Name_List_Index;
 425       List         : String_List_Id;
 426       Element      : String_Element;
 427       Last         : Name_List_Index :=
 428                        Name_List_Table.Last (In_Tree.Name_Lists);
 429
 430    begin
 431       Current_Name := Into_List;
 432       while Current_Name /= No_Name_List and then
 433             In_Tree.Name_Lists.Table (Current_Name).Next /= No_Name_List
 434       loop
 435          Current_Name := In_Tree.Name_Lists.Table (Current_Name).Next;
 436       end loop;
 437
 438       List := From_List;
 439       while List /= Nil_String loop
 440          Element := In_Tree.String_Elements.Table (List);
 441
 442          Name_List_Table.Append
 443            (In_Tree.Name_Lists,
 444             (Name => Element.Value, Next => No_Name_List));
 445
 446          Last := Last + 1;
 447
 448          if Current_Name = No_Name_List then
 449             Into_List := Last;
 450
 451          else
 452             In_Tree.Name_Lists.Table (Current_Name).Next := Last;
 453          end if;
 454
 455          Current_Name := Last;
 456
 457          List := Element.Next;
 458       end loop;
 459    end Put;
 460
 461    --------------
 462    -- Value_Of --
 463    --------------
 464
 465    function Value_Of
 466      (Variable : Variable_Value;
 467       Default  : String) return String
 468    is
 469    begin
 470       if Variable.Kind /= Single
 471         or else Variable.Default
 472         or else Variable.Value = No_Name
 473       then
 474          return Default;
 475       else
 476          return Get_Name_String (Variable.Value);
 477       end if;
 478    end Value_Of;
 479
 480    function Value_Of
 481      (Index    : Name_Id;
 482       In_Array : Array_Element_Id;
 483       In_Tree  : Project_Tree_Ref) return Name_Id
 484    is
 485       Current    : Array_Element_Id;
 486       Element    : Array_Element;
 487       Real_Index : Name_Id := Index;
 488
 489    begin
 490       Current := In_Array;
 491
 492       if Current = No_Array_Element then
 493          return No_Name;
 494       end if;
 495
 496       Element := In_Tree.Array_Elements.Table (Current);
 497
 498       if not Element.Index_Case_Sensitive then
 499          Get_Name_String (Index);
 500          To_Lower (Name_Buffer (1 .. Name_Len));
 501          Real_Index := Name_Find;
 502       end if;
 503
 504       while Current /= No_Array_Element loop
 505          Element := In_Tree.Array_Elements.Table (Current);
 506
 507          if Real_Index = Element.Index then
 508             exit when Element.Value.Kind /= Single;
 509             exit when Element.Value.Value = Empty_String;
 510             return Element.Value.Value;
 511          else
 512             Current := Element.Next;
 513          end if;
 514       end loop;
 515
 516       return No_Name;
 517    end Value_Of;
 518
 519    function Value_Of
 520      (Index                  : Name_Id;
 521       Src_Index              : Int := 0;
 522       In_Array               : Array_Element_Id;
 523       In_Tree                : Project_Tree_Ref;
 524       Force_Lower_Case_Index : Boolean := False) return Variable_Value
 525    is
 526       Current    : Array_Element_Id;
 527       Element    : Array_Element;
 528       Real_Index : Name_Id;
 529
 530    begin
 531       Current := In_Array;
 532
 533       if Current = No_Array_Element then
 534          return Nil_Variable_Value;
 535       end if;
 536
 537       Element := In_Tree.Array_Elements.Table (Current);
 538
 539       Real_Index := Index;
 540
 541       if not Element.Index_Case_Sensitive or Force_Lower_Case_Index then
 542          Get_Name_String (Index);
 543          To_Lower (Name_Buffer (1 .. Name_Len));
 544          Real_Index := Name_Find;
 545       end if;
 546
 547       while Current /= No_Array_Element loop
 548          Element := In_Tree.Array_Elements.Table (Current);
 549
 550          if Real_Index = Element.Index and then
 551            Src_Index = Element.Src_Index
 552          then
 553             return Element.Value;
 554          else
 555             Current := Element.Next;
 556          end if;
 557       end loop;
 558
 559       return Nil_Variable_Value;
 560    end Value_Of;
 561
 562    function Value_Of
 563      (Name                    : Name_Id;
 564       Index                   : Int := 0;
 565       Attribute_Or_Array_Name : Name_Id;
 566       In_Package              : Package_Id;
 567       In_Tree                 : Project_Tree_Ref;
 568       Force_Lower_Case_Index  : Boolean := False) return Variable_Value
 569    is
 570       The_Array     : Array_Element_Id;
 571       The_Attribute : Variable_Value := Nil_Variable_Value;
 572
 573    begin
 574       if In_Package /= No_Package then
 575
 576          --  First, look if there is an array element that fits
 577
 578          The_Array :=
 579            Value_Of
 580              (Name      => Attribute_Or_Array_Name,
 581               In_Arrays => In_Tree.Packages.Table (In_Package).Decl.Arrays,
 582               In_Tree   => In_Tree);
 583          The_Attribute :=
 584            Value_Of
 585              (Index                  => Name,
 586               Src_Index              => Index,
 587               In_Array               => The_Array,
 588               In_Tree                => In_Tree,
 589               Force_Lower_Case_Index => Force_Lower_Case_Index);
 590
 591          --  If there is no array element, look for a variable
 592
 593          if The_Attribute = Nil_Variable_Value then
 594             The_Attribute :=
 595               Value_Of
 596                 (Variable_Name => Attribute_Or_Array_Name,
 597                  In_Variables  => In_Tree.Packages.Table
 598                                     (In_Package).Decl.Attributes,
 599                  In_Tree       => In_Tree);
 600          end if;
 601       end if;
 602
 603       return The_Attribute;
 604    end Value_Of;
 605
 606    function Value_Of
 607      (Index     : Name_Id;
 608       In_Array  : Name_Id;
 609       In_Arrays : Array_Id;
 610       In_Tree   : Project_Tree_Ref) return Name_Id
 611    is
 612       Current   : Array_Id;
 613       The_Array : Array_Data;
 614
 615    begin
 616       Current := In_Arrays;
 617       while Current /= No_Array loop
 618          The_Array := In_Tree.Arrays.Table (Current);
 619          if The_Array.Name = In_Array then
 620             return Value_Of
 621               (Index, In_Array => The_Array.Value, In_Tree => In_Tree);
 622          else
 623             Current := The_Array.Next;
 624          end if;
 625       end loop;
 626
 627       return No_Name;
 628    end Value_Of;
 629
 630    function Value_Of
 631      (Name      : Name_Id;
 632       In_Arrays : Array_Id;
 633       In_Tree   : Project_Tree_Ref) return Array_Element_Id
 634    is
 635       Current   : Array_Id;
 636       The_Array : Array_Data;
 637
 638    begin
 639       Current := In_Arrays;
 640       while Current /= No_Array loop
 641          The_Array := In_Tree.Arrays.Table (Current);
 642
 643          if The_Array.Name = Name then
 644             return The_Array.Value;
 645          else
 646             Current := The_Array.Next;
 647          end if;
 648       end loop;
 649
 650       return No_Array_Element;
 651    end Value_Of;
 652
 653    function Value_Of
 654      (Name        : Name_Id;
 655       In_Packages : Package_Id;
 656       In_Tree     : Project_Tree_Ref) return Package_Id
 657    is
 658       Current     : Package_Id;
 659       The_Package : Package_Element;
 660
 661    begin
 662       Current := In_Packages;
 663       while Current /= No_Package loop
 664          The_Package := In_Tree.Packages.Table (Current);
 665          exit when The_Package.Name /= No_Name
 666            and then The_Package.Name = Name;
 667          Current := The_Package.Next;
 668       end loop;
 669
 670       return Current;
 671    end Value_Of;
 672
 673    function Value_Of
 674      (Variable_Name : Name_Id;
 675       In_Variables  : Variable_Id;
 676       In_Tree       : Project_Tree_Ref) return Variable_Value
 677    is
 678       Current      : Variable_Id;
 679       The_Variable : Variable;
 680
 681    begin
 682       Current := In_Variables;
 683       while Current /= No_Variable loop
 684          The_Variable :=
 685            In_Tree.Variable_Elements.Table (Current);
 686
 687          if Variable_Name = The_Variable.Name then
 688             return The_Variable.Value;
 689          else
 690             Current := The_Variable.Next;
 691          end if;
 692       end loop;
 693
 694       return Nil_Variable_Value;
 695    end Value_Of;
 696
 697    ---------------
 698    -- Write_Str --
 699    ---------------
 700
 701    procedure Write_Str
 702      (S          : String;
 703       Max_Length : Positive;
 704       Separator  : Character)
 705    is
 706       First : Positive := S'First;
 707       Last  : Natural  := S'Last;
 708
 709    begin
 710       --  Nothing to do for empty strings
 711
 712       if S'Length > 0 then
 713
 714          --  Start on a new line if current line is already longer than
 715          --  Max_Length.
 716
 717          if Positive (Column) >= Max_Length then
 718             Write_Eol;
 719          end if;
 720
 721          --  If length of remainder is longer than Max_Length, we need to
 722          --  cut the remainder in several lines.
 723
 724          while Positive (Column) + S'Last - First > Max_Length loop
 725
 726             --  Try the maximum length possible
 727
 728             Last := First + Max_Length - Positive (Column);
 729
 730             --  Look for last Separator in the line
 731
 732             while Last >= First and then S (Last) /= Separator loop
 733                Last := Last - 1;
 734             end loop;
 735
 736             --  If we do not find a separator, we output the maximum length
 737             --  possible.
 738
 739             if Last < First then
 740                Last := First + Max_Length - Positive (Column);
 741             end if;
 742
 743             Write_Line (S (First .. Last));
 744
 745             --  Set the beginning of the new remainder
 746
 747             First := Last + 1;
 748          end loop;
 749
 750          --  What is left goes to the buffer, without EOL
 751
 752          Write_Str (S (First .. S'Last));
 753       end if;
 754    end Write_Str;
 755 end Prj.Util;