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 --                            $Revision$
  10 --                                                                          --
  11 --             Copyright (C) 2001 Free Software Foundation, Inc.            --
  12 --                                                                          --
  13 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  14 -- terms of the  GNU General Public License as published  by the Free Soft- --
  15 -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  16 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  17 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  18 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  19 -- for  more details.  You should have  received  a copy of the GNU General --
  20 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  21 -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  22 -- MA 02111-1307, USA.                                                      --
  23 --                                                                          --
  24 -- GNAT was originally developed  by the GNAT team at  New York University. --
  25 -- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
  26 --                                                                          --
  27 ------------------------------------------------------------------------------
  28
  29 with Ada.Unchecked_Deallocation;
  30
  31 with Namet;    use Namet;
  32 with Osint;
  33 with Output;   use Output;
  34 with Stringt;  use Stringt;
  35
  36 package body Prj.Util is
  37
  38    procedure Free is new Ada.Unchecked_Deallocation
  39      (Text_File_Data, Text_File);
  40
  41    -----------
  42    -- Close --
  43    -----------
  44
  45    procedure Close (File : in out Text_File) is
  46    begin
  47       if File = null then
  48          Osint.Fail ("Close attempted on an invalid Text_File");
  49       end if;
  50
  51       Close (File.FD);
  52       Free (File);
  53    end Close;
  54
  55    -----------------
  56    -- End_Of_File --
  57    -----------------
  58
  59    function End_Of_File (File : Text_File) return Boolean is
  60    begin
  61       if File = null then
  62          Osint.Fail ("End_Of_File attempted on an invalid Text_File");
  63       end if;
  64
  65       return File.End_Of_File_Reached;
  66    end End_Of_File;
  67
  68    --------------
  69    -- Get_Line --
  70    --------------
  71
  72    procedure Get_Line
  73      (File : Text_File;
  74       Line : out String;
  75       Last : out Natural)
  76    is
  77       C : Character;
  78
  79       procedure Advance;
  80
  81       -------------
  82       -- Advance --
  83       -------------
  84
  85       procedure Advance is
  86       begin
  87          if File.Cursor = File.Buffer_Len then
  88             File.Buffer_Len :=
  89               Read
  90                (FD => File.FD,
  91                 A  => File.Buffer'Address,
  92                 N  => File.Buffer'Length);
  93
  94             if File.Buffer_Len = 0 then
  95                File.End_Of_File_Reached := True;
  96                return;
  97             else
  98                File.Cursor := 1;
  99             end if;
 100
 101          else
 102             File.Cursor := File.Cursor + 1;
 103          end if;
 104       end Advance;
 105
 106    --  Start of processing for Get_Line
 107
 108    begin
 109       if File = null then
 110          Osint.Fail ("Get_Line attempted on an invalid Text_File");
 111       end if;
 112
 113       Last := Line'First - 1;
 114
 115       if not File.End_Of_File_Reached then
 116          loop
 117             C := File.Buffer (File.Cursor);
 118             exit when C = ASCII.CR or else C = ASCII.LF;
 119             Last := Last + 1;
 120             Line (Last) := C;
 121             Advance;
 122
 123             if File.End_Of_File_Reached then
 124                return;
 125             end if;
 126
 127             exit when Last = Line'Last;
 128          end loop;
 129
 130          if C = ASCII.CR or else C = ASCII.LF then
 131             Advance;
 132
 133             if File.End_Of_File_Reached then
 134                return;
 135             end if;
 136          end if;
 137
 138          if C = ASCII.CR
 139            and then File.Buffer (File.Cursor) = ASCII.LF
 140          then
 141             Advance;
 142          end if;
 143       end if;
 144    end Get_Line;
 145
 146    --------------
 147    -- Is_Valid --
 148    --------------
 149
 150    function Is_Valid (File : Text_File) return Boolean is
 151    begin
 152       return File /= null;
 153    end Is_Valid;
 154
 155    ----------
 156    -- Open --
 157    ----------
 158
 159    procedure Open (File : out Text_File; Name : in String) is
 160       FD        : File_Descriptor;
 161       File_Name : String (1 .. Name'Length + 1);
 162
 163    begin
 164       File_Name (1 .. Name'Length) := Name;
 165       File_Name (File_Name'Last) := ASCII.NUL;
 166       FD := Open_Read (Name => File_Name'Address,
 167                             Fmode => GNAT.OS_Lib.Text);
 168       if FD = Invalid_FD then
 169          File := null;
 170       else
 171          File := new Text_File_Data;
 172          File.FD := FD;
 173          File.Buffer_Len :=
 174            Read (FD => FD,
 175                  A  => File.Buffer'Address,
 176                  N  => File.Buffer'Length);
 177
 178          if File.Buffer_Len = 0 then
 179             File.End_Of_File_Reached := True;
 180          else
 181             File.Cursor := 1;
 182          end if;
 183       end if;
 184    end Open;
 185
 186    --------------
 187    -- Value_Of --
 188    --------------
 189
 190    function Value_Of
 191      (Variable : Variable_Value;
 192       Default  : String)
 193       return     String
 194    is
 195    begin
 196       if Variable.Kind /= Single
 197         or else Variable.Default
 198         or else Variable.Value = No_String then
 199          return Default;
 200
 201       else
 202          String_To_Name_Buffer (Variable.Value);
 203          return Name_Buffer (1 .. Name_Len);
 204       end if;
 205    end Value_Of;
 206
 207    function Value_Of
 208      (Index    : Name_Id;
 209       In_Array : Array_Element_Id)
 210       return     Name_Id
 211    is
 212       Current : Array_Element_Id := In_Array;
 213       Element : Array_Element;
 214
 215    begin
 216       while Current /= No_Array_Element loop
 217          Element := Array_Elements.Table (Current);
 218
 219          if Index = Element.Index then
 220             exit when Element.Value.Kind /= Single;
 221             exit when String_Length (Element.Value.Value) = 0;
 222             String_To_Name_Buffer (Element.Value.Value);
 223             return Name_Find;
 224          else
 225             Current := Element.Next;
 226          end if;
 227       end loop;
 228
 229       return No_Name;
 230    end Value_Of;
 231
 232    function Value_Of
 233      (Index    : Name_Id;
 234       In_Array : Array_Element_Id)
 235       return     Variable_Value
 236    is
 237       Current : Array_Element_Id := In_Array;
 238       Element : Array_Element;
 239
 240    begin
 241       while Current /= No_Array_Element loop
 242          Element := Array_Elements.Table (Current);
 243
 244          if Index = Element.Index then
 245             return Element.Value;
 246          else
 247             Current := Element.Next;
 248          end if;
 249       end loop;
 250
 251       return Nil_Variable_Value;
 252    end Value_Of;
 253
 254    function Value_Of
 255      (Name                    : Name_Id;
 256       Attribute_Or_Array_Name : Name_Id;
 257       In_Package              : Package_Id)
 258       return                    Variable_Value
 259    is
 260       The_Array     : Array_Element_Id;
 261       The_Attribute : Variable_Value := Nil_Variable_Value;
 262
 263    begin
 264       if In_Package /= No_Package then
 265
 266          --  First, look if there is an array element that fits
 267
 268          The_Array :=
 269            Value_Of
 270              (Name      => Attribute_Or_Array_Name,
 271               In_Arrays => Packages.Table (In_Package).Decl.Arrays);
 272          The_Attribute :=
 273            Value_Of
 274              (Index    => Name,
 275               In_Array => The_Array);
 276
 277          --  If there is no array element, look for a variable
 278
 279          if The_Attribute = Nil_Variable_Value then
 280             The_Attribute :=
 281               Value_Of
 282                 (Variable_Name => Attribute_Or_Array_Name,
 283                  In_Variables  => Packages.Table (In_Package).Decl.Attributes);
 284          end if;
 285       end if;
 286
 287       return The_Attribute;
 288    end Value_Of;
 289
 290    function Value_Of
 291      (Index     : Name_Id;
 292       In_Array  : Name_Id;
 293       In_Arrays : Array_Id)
 294       return      Name_Id
 295    is
 296       Current : Array_Id := In_Arrays;
 297       The_Array : Array_Data;
 298
 299    begin
 300       while Current /= No_Array loop
 301          The_Array := Arrays.Table (Current);
 302          if The_Array.Name = In_Array then
 303             return Value_Of (Index, In_Array => The_Array.Value);
 304          else
 305             Current := The_Array.Next;
 306          end if;
 307       end loop;
 308
 309       return No_Name;
 310    end Value_Of;
 311
 312    function Value_Of
 313      (Name      : Name_Id;
 314       In_Arrays : Array_Id)
 315       return      Array_Element_Id
 316    is
 317       Current : Array_Id := In_Arrays;
 318       The_Array          : Array_Data;
 319
 320    begin
 321       while Current /= No_Array loop
 322          The_Array := Arrays.Table (Current);
 323
 324          if The_Array.Name = Name then
 325             return The_Array.Value;
 326          else
 327             Current := The_Array.Next;
 328          end if;
 329       end loop;
 330
 331       return No_Array_Element;
 332    end Value_Of;
 333
 334    function Value_Of
 335      (Name        : Name_Id;
 336       In_Packages : Package_Id)
 337       return        Package_Id
 338    is
 339       Current : Package_Id := In_Packages;
 340       The_Package : Package_Element;
 341
 342    begin
 343       while Current /= No_Package loop
 344          The_Package := Packages.Table (Current);
 345          exit when The_Package.Name /= No_Name
 346            and then The_Package.Name = Name;
 347          Current := The_Package.Next;
 348       end loop;
 349
 350       return Current;
 351    end Value_Of;
 352
 353    function Value_Of
 354      (Variable_Name : Name_Id;
 355       In_Variables  : Variable_Id)
 356       return          Variable_Value
 357    is
 358       Current : Variable_Id := In_Variables;
 359       The_Variable : Variable;
 360
 361    begin
 362       while Current /= No_Variable loop
 363          The_Variable := Variable_Elements.Table (Current);
 364
 365          if Variable_Name = The_Variable.Name then
 366             return The_Variable.Value;
 367          else
 368             Current := The_Variable.Next;
 369          end if;
 370       end loop;
 371
 372       return Nil_Variable_Value;
 373    end Value_Of;
 374
 375    ---------------
 376    -- Write_Str --
 377    ---------------
 378
 379    procedure Write_Str
 380      (S          : String;
 381       Max_Length : Positive;
 382       Separator  : Character)
 383    is
 384       First : Positive := S'First;
 385       Last  : Natural  := S'Last;
 386
 387    begin
 388       --  Nothing to do for empty strings
 389
 390       if S'Length > 0 then
 391
 392          --  Start on a new line if current line is already longer than
 393          --  Max_Length.
 394
 395          if Positive (Column) >= Max_Length then
 396             Write_Eol;
 397          end if;
 398
 399          --  If length of remainder is longer than Max_Length, we need to
 400          --  cut the remainder in several lines.
 401
 402          while Positive (Column) + S'Last - First > Max_Length loop
 403
 404             --  Try the maximum length possible
 405
 406             Last := First + Max_Length - Positive (Column);
 407
 408             --  Look for last Separator in the line
 409
 410             while Last >= First and then S (Last) /= Separator loop
 411                Last := Last - 1;
 412             end loop;
 413
 414             --  If we do not find a separator, we output the maximum length
 415             --  possible.
 416
 417             if Last < First then
 418                Last := First + Max_Length - Positive (Column);
 419             end if;
 420
 421             Write_Line (S (First .. Last));
 422
 423             --  Set the beginning of the new remainder
 424
 425             First := Last + 1;
 426          end loop;
 427
 428          --  What is left goes to the buffer, without EOL
 429
 430          Write_Str (S (First .. S'Last));
 431       end if;
 432    end Write_Str;
 433
 434 end Prj.Util;