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