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