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