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 System.Case_Util; use System.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    -- End_Of_File --
  61    -----------------
  62
  63    function End_Of_File (File : Text_File) return Boolean is
  64    begin
  65       if File = null then
  66          Prj.Com.Fail ("End_Of_File attempted on an invalid Text_File");
  67       end if;
  68
  69       return File.End_Of_File_Reached;
  70    end End_Of_File;
  71
  72    -------------------
  73    -- Executable_Of --
  74    -------------------
  75
  76    function Executable_Of
  77      (Project  : Project_Id;
  78       In_Tree  : Project_Tree_Ref;
  79       Main     : File_Name_Type;
  80       Index    : Int;
  81       Ada_Main : Boolean := True) return File_Name_Type
  82    is
  83       pragma Assert (Project /= No_Project);
  84
  85       The_Packages : constant Package_Id :=
  86                        In_Tree.Projects.Table (Project).Decl.Packages;
  87
  88       Builder_Package : constant Prj.Package_Id :=
  89                           Prj.Util.Value_Of
  90                             (Name        => Name_Builder,
  91                              In_Packages => The_Packages,
  92                              In_Tree     => In_Tree);
  93
  94       Executable : Variable_Value :=
  95                      Prj.Util.Value_Of
  96                        (Name                    => Name_Id (Main),
  97                         Index                   => Index,
  98                         Attribute_Or_Array_Name => Name_Executable,
  99                         In_Package              => Builder_Package,
 100                         In_Tree                 => In_Tree);
 101
 102       Executable_Suffix : Variable_Value := Nil_Variable_Value;
 103
 104       Body_Append : constant String := Get_Name_String
 105                                           (In_Tree.Projects.Table
 106                                             (Project).
 107                                               Naming.Ada_Body_Suffix);
 108
 109       Spec_Append : constant String := Get_Name_String
 110                                           (In_Tree.Projects.Table
 111                                             (Project).
 112                                                Naming.Ada_Spec_Suffix);
 113
 114    begin
 115       if Builder_Package /= No_Package then
 116          Executable_Suffix := Prj.Util.Value_Of
 117            (Variable_Name => Name_Executable_Suffix,
 118             In_Variables  => In_Tree.Packages.Table
 119               (Builder_Package).Decl.Attributes,
 120             In_Tree       => In_Tree);
 121
 122          if Executable = Nil_Variable_Value and Ada_Main then
 123             Get_Name_String (Main);
 124
 125             --  Try as index the name minus the implementation suffix or minus
 126             --  the specification suffix.
 127
 128             declare
 129                Name : constant String (1 .. Name_Len) :=
 130                         Name_Buffer (1 .. Name_Len);
 131                Last : Positive := Name_Len;
 132
 133                Naming : constant Naming_Data :=
 134                           In_Tree.Projects.Table (Project).Naming;
 135
 136                Spec_Suffix : constant String :=
 137                                Get_Name_String (Naming.Ada_Spec_Suffix);
 138                Body_Suffix : constant String :=
 139                                Get_Name_String (Naming.Ada_Body_Suffix);
 140
 141                Truncated : Boolean := False;
 142
 143             begin
 144                if Last > Body_Suffix'Length
 145                   and then Name (Last - Body_Suffix'Length + 1 .. Last) =
 146                                                                   Body_Suffix
 147                then
 148                   Truncated := True;
 149                   Last := Last - Body_Suffix'Length;
 150                end if;
 151
 152                if not Truncated
 153                  and then Last > Spec_Suffix'Length
 154                  and then Name (Last - Spec_Suffix'Length + 1 .. Last) =
 155                                                                  Spec_Suffix
 156                then
 157                   Truncated := True;
 158                   Last := Last - Spec_Suffix'Length;
 159                end if;
 160
 161                if Truncated then
 162                   Name_Len := Last;
 163                   Name_Buffer (1 .. Name_Len) := Name (1 .. Last);
 164                   Executable :=
 165                     Prj.Util.Value_Of
 166                       (Name                    => Name_Find,
 167                        Index                   => 0,
 168                        Attribute_Or_Array_Name => Name_Executable,
 169                        In_Package              => Builder_Package,
 170                        In_Tree                 => In_Tree);
 171                end if;
 172             end;
 173          end if;
 174
 175          --  If we have found an Executable attribute, return its value,
 176          --  possibly suffixed by the executable suffix.
 177
 178          if Executable /= Nil_Variable_Value
 179            and then Executable.Value /= Empty_Name
 180          then
 181             --  Get the executable name. If Executable_Suffix is defined,
 182             --  make sure that it will be the extension of the executable.
 183
 184             declare
 185                Saved_EEOT : constant Name_Id := Executable_Extension_On_Target;
 186                Result     : File_Name_Type;
 187
 188             begin
 189                if Executable_Suffix /= Nil_Variable_Value
 190                  and then not Executable_Suffix.Default
 191                then
 192                   Executable_Extension_On_Target := Executable_Suffix.Value;
 193                end if;
 194
 195                Result := Executable_Name (File_Name_Type (Executable.Value));
 196                Executable_Extension_On_Target := Saved_EEOT;
 197                return Result;
 198             end;
 199          end if;
 200       end if;
 201
 202       Get_Name_String (Main);
 203
 204       --  If there is a body suffix or a spec suffix, remove this suffix,
 205       --  otherwise remove any suffix ('.' followed by other characters), if
 206       --  there is one.
 207
 208       if Ada_Main and then Name_Len > Body_Append'Length
 209          and then Name_Buffer (Name_Len - Body_Append'Length + 1 .. Name_Len) =
 210                     Body_Append
 211       then
 212          --  Found the body termination, remove it
 213
 214          Name_Len := Name_Len - Body_Append'Length;
 215
 216       elsif Ada_Main and then Name_Len > Spec_Append'Length
 217          and then Name_Buffer (Name_Len - Spec_Append'Length + 1 .. Name_Len) =
 218                     Spec_Append
 219       then
 220          --  Found the spec termination, remove it
 221
 222          Name_Len := Name_Len - Spec_Append'Length;
 223
 224       else
 225          --  Remove any suffix, if there is one
 226
 227          Get_Name_String (Strip_Suffix (Main));
 228       end if;
 229
 230       if Executable_Suffix /= Nil_Variable_Value
 231         and then not Executable_Suffix.Default
 232       then
 233          --  If attribute Executable_Suffix is specified, add this suffix
 234
 235          declare
 236             Suffix : constant String :=
 237                        Get_Name_String (Executable_Suffix.Value);
 238          begin
 239             Name_Buffer (Name_Len + 1 .. Name_Len + Suffix'Length) := Suffix;
 240             Name_Len := Name_Len + Suffix'Length;
 241             return Name_Find;
 242          end;
 243
 244       else
 245          --  Otherwise, add the standard suffix for the platform, if any
 246
 247          return Executable_Name (Name_Find);
 248       end if;
 249    end Executable_Of;
 250
 251    --------------
 252    -- Get_Line --
 253    --------------
 254
 255    procedure Get_Line
 256      (File : Text_File;
 257       Line : out String;
 258       Last : out Natural)
 259    is
 260       C : Character;
 261
 262       procedure Advance;
 263
 264       -------------
 265       -- Advance --
 266       -------------
 267
 268       procedure Advance is
 269       begin
 270          if File.Cursor = File.Buffer_Len then
 271             File.Buffer_Len :=
 272               Read
 273                (FD => File.FD,
 274                 A  => File.Buffer'Address,
 275                 N  => File.Buffer'Length);
 276
 277             if File.Buffer_Len = 0 then
 278                File.End_Of_File_Reached := True;
 279                return;
 280             else
 281                File.Cursor := 1;
 282             end if;
 283
 284          else
 285             File.Cursor := File.Cursor + 1;
 286          end if;
 287       end Advance;
 288
 289    --  Start of processing for Get_Line
 290
 291    begin
 292       if File = null then
 293          Prj.Com.Fail ("Get_Line attempted on an invalid Text_File");
 294       end if;
 295
 296       Last := Line'First - 1;
 297
 298       if not File.End_Of_File_Reached then
 299          loop
 300             C := File.Buffer (File.Cursor);
 301             exit when C = ASCII.CR or else C = ASCII.LF;
 302             Last := Last + 1;
 303             Line (Last) := C;
 304             Advance;
 305
 306             if File.End_Of_File_Reached then
 307                return;
 308             end if;
 309
 310             exit when Last = Line'Last;
 311          end loop;
 312
 313          if C = ASCII.CR or else C = ASCII.LF then
 314             Advance;
 315
 316             if File.End_Of_File_Reached then
 317                return;
 318             end if;
 319          end if;
 320
 321          if C = ASCII.CR
 322            and then File.Buffer (File.Cursor) = ASCII.LF
 323          then
 324             Advance;
 325          end if;
 326       end if;
 327    end Get_Line;
 328
 329    --------------
 330    -- Is_Valid --
 331    --------------
 332
 333    function Is_Valid (File : Text_File) return Boolean is
 334    begin
 335       return File /= null;
 336    end Is_Valid;
 337
 338    ----------
 339    -- Open --
 340    ----------
 341
 342    procedure Open (File : out Text_File; Name : String) is
 343       FD        : File_Descriptor;
 344       File_Name : String (1 .. Name'Length + 1);
 345
 346    begin
 347       File_Name (1 .. Name'Length) := Name;
 348       File_Name (File_Name'Last) := ASCII.NUL;
 349       FD := Open_Read (Name => File_Name'Address,
 350                        Fmode => GNAT.OS_Lib.Text);
 351       if FD = Invalid_FD then
 352          File := null;
 353       else
 354          File := new Text_File_Data;
 355          File.FD := FD;
 356          File.Buffer_Len :=
 357            Read (FD => FD,
 358                  A  => File.Buffer'Address,
 359                  N  => File.Buffer'Length);
 360
 361          if File.Buffer_Len = 0 then
 362             File.End_Of_File_Reached := True;
 363          else
 364             File.Cursor := 1;
 365          end if;
 366       end if;
 367    end Open;
 368
 369    --------------
 370    -- Value_Of --
 371    --------------
 372
 373    function Value_Of
 374      (Variable : Variable_Value;
 375       Default  : String) return String
 376    is
 377    begin
 378       if Variable.Kind /= Single
 379         or else Variable.Default
 380         or else Variable.Value = No_Name
 381       then
 382          return Default;
 383       else
 384          return Get_Name_String (Variable.Value);
 385       end if;
 386    end Value_Of;
 387
 388    function Value_Of
 389      (Index     : Name_Id;
 390       In_Array  : Array_Element_Id;
 391       In_Tree   : Project_Tree_Ref) return Name_Id
 392    is
 393       Current    : Array_Element_Id := In_Array;
 394       Element    : Array_Element;
 395       Real_Index : Name_Id := Index;
 396
 397    begin
 398       if Current = No_Array_Element then
 399          return No_Name;
 400       end if;
 401
 402       Element := In_Tree.Array_Elements.Table (Current);
 403
 404       if not Element.Index_Case_Sensitive then
 405          Get_Name_String (Index);
 406          To_Lower (Name_Buffer (1 .. Name_Len));
 407          Real_Index := Name_Find;
 408       end if;
 409
 410       while Current /= No_Array_Element loop
 411          Element := In_Tree.Array_Elements.Table (Current);
 412
 413          if Real_Index = Element.Index then
 414             exit when Element.Value.Kind /= Single;
 415             exit when Element.Value.Value = Empty_String;
 416             return Element.Value.Value;
 417          else
 418             Current := Element.Next;
 419          end if;
 420       end loop;
 421
 422       return No_Name;
 423    end Value_Of;
 424
 425    function Value_Of
 426      (Index     : Name_Id;
 427       Src_Index : Int := 0;
 428       In_Array  : Array_Element_Id;
 429       In_Tree   : Project_Tree_Ref) return Variable_Value
 430    is
 431       Current : Array_Element_Id := In_Array;
 432       Element : Array_Element;
 433       Real_Index : Name_Id := Index;
 434
 435    begin
 436       if Current = No_Array_Element then
 437          return Nil_Variable_Value;
 438       end if;
 439
 440       Element := In_Tree.Array_Elements.Table (Current);
 441
 442       if not Element.Index_Case_Sensitive then
 443          Get_Name_String (Index);
 444          To_Lower (Name_Buffer (1 .. Name_Len));
 445          Real_Index := Name_Find;
 446       end if;
 447
 448       while Current /= No_Array_Element loop
 449          Element := In_Tree.Array_Elements.Table (Current);
 450
 451          if Real_Index = Element.Index and then
 452            Src_Index = Element.Src_Index
 453          then
 454             return Element.Value;
 455          else
 456             Current := Element.Next;
 457          end if;
 458       end loop;
 459
 460       return Nil_Variable_Value;
 461    end Value_Of;
 462
 463    function Value_Of
 464      (Name                    : Name_Id;
 465       Index                   : Int := 0;
 466       Attribute_Or_Array_Name : Name_Id;
 467       In_Package              : Package_Id;
 468       In_Tree                 : Project_Tree_Ref) return Variable_Value
 469    is
 470       The_Array     : Array_Element_Id;
 471       The_Attribute : Variable_Value := Nil_Variable_Value;
 472
 473    begin
 474       if In_Package /= No_Package then
 475
 476          --  First, look if there is an array element that fits
 477
 478          The_Array :=
 479            Value_Of
 480              (Name      => Attribute_Or_Array_Name,
 481               In_Arrays => In_Tree.Packages.Table (In_Package).Decl.Arrays,
 482               In_Tree   => In_Tree);
 483          The_Attribute :=
 484            Value_Of
 485              (Index     => Name,
 486               Src_Index => Index,
 487               In_Array  => The_Array,
 488               In_Tree   => In_Tree);
 489
 490          --  If there is no array element, look for a variable
 491
 492          if The_Attribute = Nil_Variable_Value then
 493             The_Attribute :=
 494               Value_Of
 495                 (Variable_Name => Attribute_Or_Array_Name,
 496                  In_Variables  => In_Tree.Packages.Table
 497                                     (In_Package).Decl.Attributes,
 498                  In_Tree       => In_Tree);
 499          end if;
 500       end if;
 501
 502       return The_Attribute;
 503    end Value_Of;
 504
 505    function Value_Of
 506      (Index     : Name_Id;
 507       In_Array  : Name_Id;
 508       In_Arrays : Array_Id;
 509       In_Tree   : Project_Tree_Ref) return Name_Id
 510    is
 511       Current : Array_Id := In_Arrays;
 512       The_Array : Array_Data;
 513
 514    begin
 515       while Current /= No_Array loop
 516          The_Array := In_Tree.Arrays.Table (Current);
 517          if The_Array.Name = In_Array then
 518             return Value_Of
 519               (Index, In_Array => The_Array.Value, In_Tree => In_Tree);
 520          else
 521             Current := The_Array.Next;
 522          end if;
 523       end loop;
 524
 525       return No_Name;
 526    end Value_Of;
 527
 528    function Value_Of
 529      (Name      : Name_Id;
 530       In_Arrays : Array_Id;
 531       In_Tree   : Project_Tree_Ref) return Array_Element_Id
 532    is
 533       Current    : Array_Id := In_Arrays;
 534       The_Array  : Array_Data;
 535
 536    begin
 537       while Current /= No_Array loop
 538          The_Array := In_Tree.Arrays.Table (Current);
 539
 540          if The_Array.Name = Name then
 541             return The_Array.Value;
 542          else
 543             Current := The_Array.Next;
 544          end if;
 545       end loop;
 546
 547       return No_Array_Element;
 548    end Value_Of;
 549
 550    function Value_Of
 551      (Name        : Name_Id;
 552       In_Packages : Package_Id;
 553       In_Tree     : Project_Tree_Ref) return Package_Id
 554    is
 555       Current : Package_Id := In_Packages;
 556       The_Package : Package_Element;
 557
 558    begin
 559       while Current /= No_Package loop
 560          The_Package := In_Tree.Packages.Table (Current);
 561          exit when The_Package.Name /= No_Name
 562            and then The_Package.Name = Name;
 563          Current := The_Package.Next;
 564       end loop;
 565
 566       return Current;
 567    end Value_Of;
 568
 569    function Value_Of
 570      (Variable_Name : Name_Id;
 571       In_Variables  : Variable_Id;
 572       In_Tree       : Project_Tree_Ref) return Variable_Value
 573    is
 574       Current      : Variable_Id := In_Variables;
 575       The_Variable : Variable;
 576
 577    begin
 578       while Current /= No_Variable loop
 579          The_Variable :=
 580            In_Tree.Variable_Elements.Table (Current);
 581
 582          if Variable_Name = The_Variable.Name then
 583             return The_Variable.Value;
 584          else
 585             Current := The_Variable.Next;
 586          end if;
 587       end loop;
 588
 589       return Nil_Variable_Value;
 590    end Value_Of;
 591
 592    ---------------
 593    -- Write_Str --
 594    ---------------
 595
 596    procedure Write_Str
 597      (S          : String;
 598       Max_Length : Positive;
 599       Separator  : Character)
 600    is
 601       First : Positive := S'First;
 602       Last  : Natural  := S'Last;
 603
 604    begin
 605       --  Nothing to do for empty strings
 606
 607       if S'Length > 0 then
 608
 609          --  Start on a new line if current line is already longer than
 610          --  Max_Length.
 611
 612          if Positive (Column) >= Max_Length then
 613             Write_Eol;
 614          end if;
 615
 616          --  If length of remainder is longer than Max_Length, we need to
 617          --  cut the remainder in several lines.
 618
 619          while Positive (Column) + S'Last - First > Max_Length loop
 620
 621             --  Try the maximum length possible
 622
 623             Last := First + Max_Length - Positive (Column);
 624
 625             --  Look for last Separator in the line
 626
 627             while Last >= First and then S (Last) /= Separator loop
 628                Last := Last - 1;
 629             end loop;
 630
 631             --  If we do not find a separator, we output the maximum length
 632             --  possible.
 633
 634             if Last < First then
 635                Last := First + Max_Length - Positive (Column);
 636             end if;
 637
 638             Write_Line (S (First .. Last));
 639
 640             --  Set the beginning of the new remainder
 641
 642             First := Last + 1;
 643          end loop;
 644
 645          --  What is left goes to the buffer, without EOL
 646
 647          Write_Str (S (First .. S'Last));
 648       end if;
 649    end Write_Str;
 650 end Prj.Util;