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