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