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_1 : Name_Id;
 530       Real_Index_2 : Name_Id;
 531
 532    begin
 533       Current := In_Array;
 534
 535       if Current = No_Array_Element then
 536          return Nil_Variable_Value;
 537       end if;
 538
 539       Element := In_Tree.Array_Elements.Table (Current);
 540
 541       Real_Index_1 := Index;
 542
 543       if not Element.Index_Case_Sensitive or Force_Lower_Case_Index then
 544          Get_Name_String (Index);
 545          To_Lower (Name_Buffer (1 .. Name_Len));
 546          Real_Index_1 := Name_Find;
 547       end if;
 548
 549       while Current /= No_Array_Element loop
 550          Element := In_Tree.Array_Elements.Table (Current);
 551          Real_Index_2 := Element.Index;
 552
 553          if not Element.Index_Case_Sensitive or Force_Lower_Case_Index then
 554             Get_Name_String (Element.Index);
 555             To_Lower (Name_Buffer (1 .. Name_Len));
 556             Real_Index_2 := Name_Find;
 557          end if;
 558
 559          if Real_Index_1 = Real_Index_2 and then
 560            Src_Index = Element.Src_Index
 561          then
 562             return Element.Value;
 563          else
 564             Current := Element.Next;
 565          end if;
 566       end loop;
 567
 568       return Nil_Variable_Value;
 569    end Value_Of;
 570
 571    function Value_Of
 572      (Name                    : Name_Id;
 573       Index                   : Int := 0;
 574       Attribute_Or_Array_Name : Name_Id;
 575       In_Package              : Package_Id;
 576       In_Tree                 : Project_Tree_Ref;
 577       Force_Lower_Case_Index  : Boolean := False) return Variable_Value
 578    is
 579       The_Array     : Array_Element_Id;
 580       The_Attribute : Variable_Value := Nil_Variable_Value;
 581
 582    begin
 583       if In_Package /= No_Package then
 584
 585          --  First, look if there is an array element that fits
 586
 587          The_Array :=
 588            Value_Of
 589              (Name      => Attribute_Or_Array_Name,
 590               In_Arrays => In_Tree.Packages.Table (In_Package).Decl.Arrays,
 591               In_Tree   => In_Tree);
 592          The_Attribute :=
 593            Value_Of
 594              (Index                  => Name,
 595               Src_Index              => Index,
 596               In_Array               => The_Array,
 597               In_Tree                => In_Tree,
 598               Force_Lower_Case_Index => Force_Lower_Case_Index);
 599
 600          --  If there is no array element, look for a variable
 601
 602          if The_Attribute = Nil_Variable_Value then
 603             The_Attribute :=
 604               Value_Of
 605                 (Variable_Name => Attribute_Or_Array_Name,
 606                  In_Variables  => In_Tree.Packages.Table
 607                                     (In_Package).Decl.Attributes,
 608                  In_Tree       => In_Tree);
 609          end if;
 610       end if;
 611
 612       return The_Attribute;
 613    end Value_Of;
 614
 615    function Value_Of
 616      (Index     : Name_Id;
 617       In_Array  : Name_Id;
 618       In_Arrays : Array_Id;
 619       In_Tree   : Project_Tree_Ref) return Name_Id
 620    is
 621       Current   : Array_Id;
 622       The_Array : Array_Data;
 623
 624    begin
 625       Current := In_Arrays;
 626       while Current /= No_Array loop
 627          The_Array := In_Tree.Arrays.Table (Current);
 628          if The_Array.Name = In_Array then
 629             return Value_Of
 630               (Index, In_Array => The_Array.Value, In_Tree => In_Tree);
 631          else
 632             Current := The_Array.Next;
 633          end if;
 634       end loop;
 635
 636       return No_Name;
 637    end Value_Of;
 638
 639    function Value_Of
 640      (Name      : Name_Id;
 641       In_Arrays : Array_Id;
 642       In_Tree   : Project_Tree_Ref) return Array_Element_Id
 643    is
 644       Current   : Array_Id;
 645       The_Array : Array_Data;
 646
 647    begin
 648       Current := In_Arrays;
 649       while Current /= No_Array loop
 650          The_Array := In_Tree.Arrays.Table (Current);
 651
 652          if The_Array.Name = Name then
 653             return The_Array.Value;
 654          else
 655             Current := The_Array.Next;
 656          end if;
 657       end loop;
 658
 659       return No_Array_Element;
 660    end Value_Of;
 661
 662    function Value_Of
 663      (Name        : Name_Id;
 664       In_Packages : Package_Id;
 665       In_Tree     : Project_Tree_Ref) return Package_Id
 666    is
 667       Current     : Package_Id;
 668       The_Package : Package_Element;
 669
 670    begin
 671       Current := In_Packages;
 672       while Current /= No_Package loop
 673          The_Package := In_Tree.Packages.Table (Current);
 674          exit when The_Package.Name /= No_Name
 675            and then The_Package.Name = Name;
 676          Current := The_Package.Next;
 677       end loop;
 678
 679       return Current;
 680    end Value_Of;
 681
 682    function Value_Of
 683      (Variable_Name : Name_Id;
 684       In_Variables  : Variable_Id;
 685       In_Tree       : Project_Tree_Ref) return Variable_Value
 686    is
 687       Current      : Variable_Id;
 688       The_Variable : Variable;
 689
 690    begin
 691       Current := In_Variables;
 692       while Current /= No_Variable loop
 693          The_Variable :=
 694            In_Tree.Variable_Elements.Table (Current);
 695
 696          if Variable_Name = The_Variable.Name then
 697             return The_Variable.Value;
 698          else
 699             Current := The_Variable.Next;
 700          end if;
 701       end loop;
 702
 703       return Nil_Variable_Value;
 704    end Value_Of;
 705
 706    ---------------
 707    -- Write_Str --
 708    ---------------
 709
 710    procedure Write_Str
 711      (S          : String;
 712       Max_Length : Positive;
 713       Separator  : Character)
 714    is
 715       First : Positive := S'First;
 716       Last  : Natural  := S'Last;
 717
 718    begin
 719       --  Nothing to do for empty strings
 720
 721       if S'Length > 0 then
 722
 723          --  Start on a new line if current line is already longer than
 724          --  Max_Length.
 725
 726          if Positive (Column) >= Max_Length then
 727             Write_Eol;
 728          end if;
 729
 730          --  If length of remainder is longer than Max_Length, we need to
 731          --  cut the remainder in several lines.
 732
 733          while Positive (Column) + S'Last - First > Max_Length loop
 734
 735             --  Try the maximum length possible
 736
 737             Last := First + Max_Length - Positive (Column);
 738
 739             --  Look for last Separator in the line
 740
 741             while Last >= First and then S (Last) /= Separator loop
 742                Last := Last - 1;
 743             end loop;
 744
 745             --  If we do not find a separator, we output the maximum length
 746             --  possible.
 747
 748             if Last < First then
 749                Last := First + Max_Length - Positive (Column);
 750             end if;
 751
 752             Write_Line (S (First .. Last));
 753
 754             --  Set the beginning of the new remainder
 755
 756             First := Last + 1;
 757          end loop;
 758
 759          --  What is left goes to the buffer, without EOL
 760
 761          Write_Str (S (First .. S'Last));
 762       end if;
 763    end Write_Str;
 764 end Prj.Util;