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 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
  30 with Osint;    use Osint;
  31 with Output;   use Output;
  32 with Prj.Com;
  33 with Snames;   use Snames;
  34 with Targparm; use Targparm;
  35
  36 package body Prj.Util is
  37
  38    procedure Free is new Ada.Unchecked_Deallocation
  39      (Text_File_Data, Text_File);
  40
  41    -----------
  42    -- Close --
  43    -----------
  44
  45    procedure Close (File : in out Text_File) is
  46    begin
  47       if File = null then
  48          Prj.Com.Fail ("Close attempted on an invalid Text_File");
  49       end if;
  50
  51       --  Close file, no need to test status, since this is a file that we
  52       --  read, and the file was read successfully before we closed it.
  53
  54       Close (File.FD);
  55       Free (File);
  56    end Close;
  57
  58    ---------------
  59    -- Duplicate --
  60    ---------------
  61
  62    procedure Duplicate
  63      (This    : in out Name_List_Index;
  64       In_Tree : Project_Tree_Ref)
  65    is
  66       Old_Current : Name_List_Index;
  67       New_Current : Name_List_Index;
  68
  69    begin
  70       if This /= No_Name_List then
  71          Old_Current := This;
  72          Name_List_Table.Increment_Last (In_Tree.Name_Lists);
  73          New_Current := Name_List_Table.Last (In_Tree.Name_Lists);
  74          This := New_Current;
  75          In_Tree.Name_Lists.Table (New_Current) :=
  76            (In_Tree.Name_Lists.Table (Old_Current).Name, No_Name_List);
  77
  78          loop
  79             Old_Current := In_Tree.Name_Lists.Table (Old_Current).Next;
  80             exit when Old_Current = No_Name_List;
  81             In_Tree.Name_Lists.Table (New_Current).Next := New_Current + 1;
  82             Name_List_Table.Increment_Last (In_Tree.Name_Lists);
  83             New_Current := New_Current + 1;
  84             In_Tree.Name_Lists.Table (New_Current) :=
  85               (In_Tree.Name_Lists.Table (Old_Current).Name, No_Name_List);
  86          end loop;
  87       end if;
  88    end Duplicate;
  89
  90    -----------------
  91    -- End_Of_File --
  92    -----------------
  93
  94    function End_Of_File (File : Text_File) return Boolean is
  95    begin
  96       if File = null then
  97          Prj.Com.Fail ("End_Of_File attempted on an invalid Text_File");
  98       end if;
  99
 100       return File.End_Of_File_Reached;
 101    end End_Of_File;
 102
 103    -------------------
 104    -- Executable_Of --
 105    -------------------
 106
 107    function Executable_Of
 108      (Project  : Project_Id;
 109       In_Tree  : Project_Tree_Ref;
 110       Main     : File_Name_Type;
 111       Index    : Int;
 112       Ada_Main : Boolean := True) return File_Name_Type
 113    is
 114       pragma Assert (Project /= No_Project);
 115
 116       The_Packages : constant Package_Id :=
 117                        In_Tree.Projects.Table (Project).Decl.Packages;
 118
 119       Builder_Package : constant Prj.Package_Id :=
 120                           Prj.Util.Value_Of
 121                             (Name        => Name_Builder,
 122                              In_Packages => The_Packages,
 123                              In_Tree     => In_Tree);
 124
 125       Executable : Variable_Value :=
 126                      Prj.Util.Value_Of
 127                        (Name                    => Name_Id (Main),
 128                         Index                   => Index,
 129                         Attribute_Or_Array_Name => Name_Executable,
 130                         In_Package              => Builder_Package,
 131                         In_Tree                 => In_Tree);
 132
 133       Executable_Suffix : Variable_Value := Nil_Variable_Value;
 134
 135       Executable_Suffix_Name : Name_Id := No_Name;
 136
 137       Naming : constant Naming_Data := In_Tree.Projects.Table (Project).Naming;
 138
 139       Body_Suffix : constant String :=
 140                       Body_Suffix_Of (In_Tree, "ada", Naming);
 141
 142       Spec_Suffix : constant String :=
 143                       Spec_Suffix_Of (In_Tree, "ada", Naming);
 144
 145    begin
 146       if Builder_Package /= No_Package then
 147          if Get_Mode = Multi_Language then
 148             Executable_Suffix_Name :=
 149               In_Tree.Projects.Table (Project).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 :=
 288               In_Tree.Projects.Table (Project).Config.Executable_Suffix;
 289             Result := Executable_Name (Name_Find);
 290             Executable_Extension_On_Target := Saved_EEOT;
 291             return Result;
 292          end;
 293       end if;
 294    end Executable_Of;
 295
 296    --------------
 297    -- Get_Line --
 298    --------------
 299
 300    procedure Get_Line
 301      (File : Text_File;
 302       Line : out String;
 303       Last : out Natural)
 304    is
 305       C : Character;
 306
 307       procedure Advance;
 308
 309       -------------
 310       -- Advance --
 311       -------------
 312
 313       procedure Advance is
 314       begin
 315          if File.Cursor = File.Buffer_Len then
 316             File.Buffer_Len :=
 317               Read
 318                (FD => File.FD,
 319                 A  => File.Buffer'Address,
 320                 N  => File.Buffer'Length);
 321
 322             if File.Buffer_Len = 0 then
 323                File.End_Of_File_Reached := True;
 324                return;
 325             else
 326                File.Cursor := 1;
 327             end if;
 328
 329          else
 330             File.Cursor := File.Cursor + 1;
 331          end if;
 332       end Advance;
 333
 334    --  Start of processing for Get_Line
 335
 336    begin
 337       if File = null then
 338          Prj.Com.Fail ("Get_Line attempted on an invalid Text_File");
 339       end if;
 340
 341       Last := Line'First - 1;
 342
 343       if not File.End_Of_File_Reached then
 344          loop
 345             C := File.Buffer (File.Cursor);
 346             exit when C = ASCII.CR or else C = ASCII.LF;
 347             Last := Last + 1;
 348             Line (Last) := C;
 349             Advance;
 350
 351             if File.End_Of_File_Reached then
 352                return;
 353             end if;
 354
 355             exit when Last = Line'Last;
 356          end loop;
 357
 358          if C = ASCII.CR or else C = ASCII.LF then
 359             Advance;
 360
 361             if File.End_Of_File_Reached then
 362                return;
 363             end if;
 364          end if;
 365
 366          if C = ASCII.CR
 367            and then File.Buffer (File.Cursor) = ASCII.LF
 368          then
 369             Advance;
 370          end if;
 371       end if;
 372    end Get_Line;
 373
 374    --------------
 375    -- Is_Valid --
 376    --------------
 377
 378    function Is_Valid (File : Text_File) return Boolean is
 379    begin
 380       return File /= null;
 381    end Is_Valid;
 382
 383    ----------
 384    -- Open --
 385    ----------
 386
 387    procedure Open (File : out Text_File; Name : String) is
 388       FD        : File_Descriptor;
 389       File_Name : String (1 .. Name'Length + 1);
 390
 391    begin
 392       File_Name (1 .. Name'Length) := Name;
 393       File_Name (File_Name'Last) := ASCII.NUL;
 394       FD := Open_Read (Name => File_Name'Address,
 395                        Fmode => GNAT.OS_Lib.Text);
 396
 397       if FD = Invalid_FD then
 398          File := null;
 399
 400       else
 401          File := new Text_File_Data;
 402          File.FD := FD;
 403          File.Buffer_Len :=
 404            Read (FD => FD,
 405                  A  => File.Buffer'Address,
 406                  N  => File.Buffer'Length);
 407
 408          if File.Buffer_Len = 0 then
 409             File.End_Of_File_Reached := True;
 410          else
 411             File.Cursor := 1;
 412          end if;
 413       end if;
 414    end Open;
 415
 416    ---------
 417    -- Put --
 418    ---------
 419
 420    procedure Put
 421      (Into_List : in out Name_List_Index;
 422       From_List : String_List_Id;
 423       In_Tree   : Project_Tree_Ref)
 424    is
 425       Current_Name : Name_List_Index;
 426       List         : String_List_Id;
 427       Element      : String_Element;
 428       Last         : Name_List_Index :=
 429                        Name_List_Table.Last (In_Tree.Name_Lists);
 430
 431    begin
 432       Current_Name := Into_List;
 433       while Current_Name /= No_Name_List and then
 434             In_Tree.Name_Lists.Table (Current_Name).Next /= No_Name_List
 435       loop
 436          Current_Name := In_Tree.Name_Lists.Table (Current_Name).Next;
 437       end loop;
 438
 439       List := From_List;
 440       while List /= Nil_String loop
 441          Element := In_Tree.String_Elements.Table (List);
 442
 443          Name_List_Table.Append
 444            (In_Tree.Name_Lists,
 445             (Name => Element.Value, Next => No_Name_List));
 446
 447          Last := Last + 1;
 448
 449          if Current_Name = No_Name_List then
 450             Into_List := Last;
 451
 452          else
 453             In_Tree.Name_Lists.Table (Current_Name).Next := Last;
 454          end if;
 455
 456          Current_Name := Last;
 457
 458          List := Element.Next;
 459       end loop;
 460    end Put;
 461
 462    --------------
 463    -- Value_Of --
 464    --------------
 465
 466    function Value_Of
 467      (Variable : Variable_Value;
 468       Default  : String) return String
 469    is
 470    begin
 471       if Variable.Kind /= Single
 472         or else Variable.Default
 473         or else Variable.Value = No_Name
 474       then
 475          return Default;
 476       else
 477          return Get_Name_String (Variable.Value);
 478       end if;
 479    end Value_Of;
 480
 481    function Value_Of
 482      (Index    : Name_Id;
 483       In_Array : Array_Element_Id;
 484       In_Tree  : Project_Tree_Ref) return Name_Id
 485    is
 486       Current    : Array_Element_Id;
 487       Element    : Array_Element;
 488       Real_Index : Name_Id := Index;
 489
 490    begin
 491       Current := In_Array;
 492
 493       if Current = No_Array_Element then
 494          return No_Name;
 495       end if;
 496
 497       Element := In_Tree.Array_Elements.Table (Current);
 498
 499       if not Element.Index_Case_Sensitive then
 500          Get_Name_String (Index);
 501          To_Lower (Name_Buffer (1 .. Name_Len));
 502          Real_Index := Name_Find;
 503       end if;
 504
 505       while Current /= No_Array_Element loop
 506          Element := In_Tree.Array_Elements.Table (Current);
 507
 508          if Real_Index = Element.Index then
 509             exit when Element.Value.Kind /= Single;
 510             exit when Element.Value.Value = Empty_String;
 511             return Element.Value.Value;
 512          else
 513             Current := Element.Next;
 514          end if;
 515       end loop;
 516
 517       return No_Name;
 518    end Value_Of;
 519
 520    function Value_Of
 521      (Index                  : Name_Id;
 522       Src_Index              : Int := 0;
 523       In_Array               : Array_Element_Id;
 524       In_Tree                : Project_Tree_Ref;
 525       Force_Lower_Case_Index : Boolean := False) return Variable_Value
 526    is
 527       Current    : Array_Element_Id;
 528       Element    : Array_Element;
 529       Real_Index : Name_Id;
 530
 531    begin
 532       Current := In_Array;
 533
 534       if Current = No_Array_Element then
 535          return Nil_Variable_Value;
 536       end if;
 537
 538       Element := In_Tree.Array_Elements.Table (Current);
 539
 540       Real_Index := Index;
 541
 542       if not Element.Index_Case_Sensitive or Force_Lower_Case_Index then
 543          Get_Name_String (Index);
 544          To_Lower (Name_Buffer (1 .. Name_Len));
 545          Real_Index := Name_Find;
 546       end if;
 547
 548       while Current /= No_Array_Element loop
 549          Element := In_Tree.Array_Elements.Table (Current);
 550
 551          if Real_Index = Element.Index and then
 552            Src_Index = Element.Src_Index
 553          then
 554             return Element.Value;
 555          else
 556             Current := Element.Next;
 557          end if;
 558       end loop;
 559
 560       return Nil_Variable_Value;
 561    end Value_Of;
 562
 563    function Value_Of
 564      (Name                    : Name_Id;
 565       Index                   : Int := 0;
 566       Attribute_Or_Array_Name : Name_Id;
 567       In_Package              : Package_Id;
 568       In_Tree                 : Project_Tree_Ref;
 569       Force_Lower_Case_Index  : Boolean := False) return Variable_Value
 570    is
 571       The_Array     : Array_Element_Id;
 572       The_Attribute : Variable_Value := Nil_Variable_Value;
 573
 574    begin
 575       if In_Package /= No_Package then
 576
 577          --  First, look if there is an array element that fits
 578
 579          The_Array :=
 580            Value_Of
 581              (Name      => Attribute_Or_Array_Name,
 582               In_Arrays => In_Tree.Packages.Table (In_Package).Decl.Arrays,
 583               In_Tree   => In_Tree);
 584          The_Attribute :=
 585            Value_Of
 586              (Index                  => Name,
 587               Src_Index              => Index,
 588               In_Array               => The_Array,
 589               In_Tree                => In_Tree,
 590               Force_Lower_Case_Index => Force_Lower_Case_Index);
 591
 592          --  If there is no array element, look for a variable
 593
 594          if The_Attribute = Nil_Variable_Value then
 595             The_Attribute :=
 596               Value_Of
 597                 (Variable_Name => Attribute_Or_Array_Name,
 598                  In_Variables  => In_Tree.Packages.Table
 599                                     (In_Package).Decl.Attributes,
 600                  In_Tree       => In_Tree);
 601          end if;
 602       end if;
 603
 604       return The_Attribute;
 605    end Value_Of;
 606
 607    function Value_Of
 608      (Index     : Name_Id;
 609       In_Array  : Name_Id;
 610       In_Arrays : Array_Id;
 611       In_Tree   : Project_Tree_Ref) return Name_Id
 612    is
 613       Current   : Array_Id;
 614       The_Array : Array_Data;
 615
 616    begin
 617       Current := In_Arrays;
 618       while Current /= No_Array loop
 619          The_Array := In_Tree.Arrays.Table (Current);
 620          if The_Array.Name = In_Array then
 621             return Value_Of
 622               (Index, In_Array => The_Array.Value, In_Tree => In_Tree);
 623          else
 624             Current := The_Array.Next;
 625          end if;
 626       end loop;
 627
 628       return No_Name;
 629    end Value_Of;
 630
 631    function Value_Of
 632      (Name      : Name_Id;
 633       In_Arrays : Array_Id;
 634       In_Tree   : Project_Tree_Ref) return Array_Element_Id
 635    is
 636       Current   : Array_Id;
 637       The_Array : Array_Data;
 638
 639    begin
 640       Current := In_Arrays;
 641       while Current /= No_Array loop
 642          The_Array := In_Tree.Arrays.Table (Current);
 643
 644          if The_Array.Name = Name then
 645             return The_Array.Value;
 646          else
 647             Current := The_Array.Next;
 648          end if;
 649       end loop;
 650
 651       return No_Array_Element;
 652    end Value_Of;
 653
 654    function Value_Of
 655      (Name        : Name_Id;
 656       In_Packages : Package_Id;
 657       In_Tree     : Project_Tree_Ref) return Package_Id
 658    is
 659       Current     : Package_Id;
 660       The_Package : Package_Element;
 661
 662    begin
 663       Current := In_Packages;
 664       while Current /= No_Package loop
 665          The_Package := In_Tree.Packages.Table (Current);
 666          exit when The_Package.Name /= No_Name
 667            and then The_Package.Name = Name;
 668          Current := The_Package.Next;
 669       end loop;
 670
 671       return Current;
 672    end Value_Of;
 673
 674    function Value_Of
 675      (Variable_Name : Name_Id;
 676       In_Variables  : Variable_Id;
 677       In_Tree       : Project_Tree_Ref) return Variable_Value
 678    is
 679       Current      : Variable_Id;
 680       The_Variable : Variable;
 681
 682    begin
 683       Current := In_Variables;
 684       while Current /= No_Variable loop
 685          The_Variable :=
 686            In_Tree.Variable_Elements.Table (Current);
 687
 688          if Variable_Name = The_Variable.Name then
 689             return The_Variable.Value;
 690          else
 691             Current := The_Variable.Next;
 692          end if;
 693       end loop;
 694
 695       return Nil_Variable_Value;
 696    end Value_Of;
 697
 698    ---------------
 699    -- Write_Str --
 700    ---------------
 701
 702    procedure Write_Str
 703      (S          : String;
 704       Max_Length : Positive;
 705       Separator  : Character)
 706    is
 707       First : Positive := S'First;
 708       Last  : Natural  := S'Last;
 709
 710    begin
 711       --  Nothing to do for empty strings
 712
 713       if S'Length > 0 then
 714
 715          --  Start on a new line if current line is already longer than
 716          --  Max_Length.
 717
 718          if Positive (Column) >= Max_Length then
 719             Write_Eol;
 720          end if;
 721
 722          --  If length of remainder is longer than Max_Length, we need to
 723          --  cut the remainder in several lines.
 724
 725          while Positive (Column) + S'Last - First > Max_Length loop
 726
 727             --  Try the maximum length possible
 728
 729             Last := First + Max_Length - Positive (Column);
 730
 731             --  Look for last Separator in the line
 732
 733             while Last >= First and then S (Last) /= Separator loop
 734                Last := Last - 1;
 735             end loop;
 736
 737             --  If we do not find a separator, we output the maximum length
 738             --  possible.
 739
 740             if Last < First then
 741                Last := First + Max_Length - Positive (Column);
 742             end if;
 743
 744             Write_Line (S (First .. Last));
 745
 746             --  Set the beginning of the new remainder
 747
 748             First := Last + 1;
 749          end loop;
 750
 751          --  What is left goes to the buffer, without EOL
 752
 753          Write_Str (S (First .. S'Last));
 754       end if;
 755    end Write_Str;
 756 end Prj.Util;