gcc/ada/stringt.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                              S T R I N G T                               --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 1992-2017, 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 3,  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.                                     --
  17 --                                                                          --
  18 -- As a special exception under Section 7 of GPL version 3, you are granted --
  19 -- additional permissions described in the GCC Runtime Library Exception,   --
  20 -- version 3.1, as published by the Free Software Foundation.               --
  21 --                                                                          --
  22 -- You should have received a copy of the GNU General Public License and    --
  23 -- a copy of the GCC Runtime Library Exception along with this program;     --
  24 -- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
  25 -- <http://www.gnu.org/licenses/>.                                          --
  26 --                                                                          --
  27 -- GNAT was originally developed  by the GNAT team at  New York University. --
  28 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  29 --                                                                          --
  30 ------------------------------------------------------------------------------
  31
  32 with Alloc;
  33 with Output; use Output;
  34 with Table;
  35
  36 package body Stringt is
  37
  38    --  The following table stores the sequence of character codes for the
  39    --  stored string constants. The entries are referenced from the
  40    --  separate Strings table.
  41
  42    package String_Chars is new Table.Table (
  43      Table_Component_Type => Char_Code,
  44      Table_Index_Type     => Int,
  45      Table_Low_Bound      => 0,
  46      Table_Initial        => Alloc.String_Chars_Initial,
  47      Table_Increment      => Alloc.String_Chars_Increment,
  48      Table_Name           => "String_Chars");
  49
  50    --  The String_Id values reference entries in the Strings table, which
  51    --  contains String_Entry records that record the length of each stored
  52    --  string and its starting location in the String_Chars table.
  53
  54    type String_Entry is record
  55       String_Index : Int;
  56       Length       : Nat;
  57    end record;
  58
  59    package Strings is new Table.Table (
  60      Table_Component_Type => String_Entry,
  61      Table_Index_Type     => String_Id'Base,
  62      Table_Low_Bound      => First_String_Id,
  63      Table_Initial        => Alloc.Strings_Initial,
  64      Table_Increment      => Alloc.Strings_Increment,
  65      Table_Name           => "Strings");
  66
  67    --  Note: it is possible that two entries in the Strings table can share
  68    --  string data in the String_Chars table, and in particular this happens
  69    --  when Start_String is called with a parameter that is the last string
  70    --  currently allocated in the table.
  71
  72    Strings_Last      : String_Id := First_String_Id;
  73    String_Chars_Last : Int := 0;
  74    --  Strings_Last and String_Chars_Last are used by procedure Mark and
  75    --  Release to get a snapshot of the tables and to restore them to their
  76    --  previous situation.
  77
  78    ------------
  79    -- Append --
  80    ------------
  81
  82    procedure Append (Buf : in out Bounded_String; S : String_Id) is
  83    begin
  84       for X in 1 .. String_Length (S) loop
  85          Append (Buf, Get_Character (Get_String_Char (S, X)));
  86       end loop;
  87    end Append;
  88
  89    ----------------
  90    -- End_String --
  91    ----------------
  92
  93    function End_String return String_Id is
  94    begin
  95       return Strings.Last;
  96    end End_String;
  97
  98    ---------------------
  99    -- Get_String_Char --
 100    ---------------------
 101
 102    function Get_String_Char (Id : String_Id; Index : Int) return Char_Code is
 103    begin
 104       pragma Assert (Id in First_String_Id .. Strings.Last
 105                        and then Index in 1 .. Strings.Table (Id).Length);
 106
 107       return String_Chars.Table (Strings.Table (Id).String_Index + Index - 1);
 108    end Get_String_Char;
 109
 110    ----------------
 111    -- Initialize --
 112    ----------------
 113
 114    procedure Initialize is
 115    begin
 116       String_Chars.Init;
 117       Strings.Init;
 118
 119       --  Set up the null string
 120
 121       Start_String;
 122       Null_String_Id := End_String;
 123    end Initialize;
 124
 125    ----------
 126    -- Lock --
 127    ----------
 128
 129    procedure Lock is
 130    begin
 131       String_Chars.Release;
 132       String_Chars.Locked := True;
 133       Strings.Release;
 134       Strings.Locked := True;
 135    end Lock;
 136
 137    ----------
 138    -- Mark --
 139    ----------
 140
 141    procedure Mark is
 142    begin
 143       Strings_Last := Strings.Last;
 144       String_Chars_Last := String_Chars.Last;
 145    end Mark;
 146
 147    -------------
 148    -- Release --
 149    -------------
 150
 151    procedure Release is
 152    begin
 153       Strings.Set_Last (Strings_Last);
 154       String_Chars.Set_Last (String_Chars_Last);
 155    end Release;
 156
 157    ------------------
 158    -- Start_String --
 159    ------------------
 160
 161    --  Version to start completely new string
 162
 163    procedure Start_String is
 164    begin
 165       Strings.Append ((String_Index => String_Chars.Last + 1, Length => 0));
 166    end Start_String;
 167
 168    --  Version to start from initially stored string
 169
 170    procedure Start_String (S : String_Id) is
 171    begin
 172       Strings.Increment_Last;
 173
 174       --  Case of initial string value is at the end of the string characters
 175       --  table, so it does not need copying, instead it can be shared.
 176
 177       if Strings.Table (S).String_Index + Strings.Table (S).Length =
 178                                                     String_Chars.Last + 1
 179       then
 180          Strings.Table (Strings.Last).String_Index :=
 181            Strings.Table (S).String_Index;
 182
 183       --  Case of initial string value must be copied to new string
 184
 185       else
 186          Strings.Table (Strings.Last).String_Index :=
 187            String_Chars.Last + 1;
 188
 189          for J in 1 .. Strings.Table (S).Length loop
 190             String_Chars.Append
 191               (String_Chars.Table (Strings.Table (S).String_Index + (J - 1)));
 192          end loop;
 193       end if;
 194
 195       --  In either case the result string length is copied from the argument
 196
 197       Strings.Table (Strings.Last).Length := Strings.Table (S).Length;
 198    end Start_String;
 199
 200    -----------------------
 201    -- Store_String_Char --
 202    -----------------------
 203
 204    procedure Store_String_Char (C : Char_Code) is
 205    begin
 206       String_Chars.Append (C);
 207       Strings.Table (Strings.Last).Length :=
 208         Strings.Table (Strings.Last).Length + 1;
 209    end Store_String_Char;
 210
 211    procedure Store_String_Char (C : Character) is
 212    begin
 213       Store_String_Char (Get_Char_Code (C));
 214    end Store_String_Char;
 215
 216    ------------------------
 217    -- Store_String_Chars --
 218    ------------------------
 219
 220    procedure Store_String_Chars (S : String) is
 221    begin
 222       for J in S'First .. S'Last loop
 223          Store_String_Char (Get_Char_Code (S (J)));
 224       end loop;
 225    end Store_String_Chars;
 226
 227    procedure Store_String_Chars (S : String_Id) is
 228
 229       --  We are essentially doing this:
 230
 231       --   for J in 1 .. String_Length (S) loop
 232       --      Store_String_Char (Get_String_Char (S, J));
 233       --   end loop;
 234
 235       --  but when the string is long it's more efficient to grow the
 236       --  String_Chars table all at once.
 237
 238       S_First  : constant Int := Strings.Table (S).String_Index;
 239       S_Len    : constant Nat := String_Length (S);
 240       Old_Last : constant Int := String_Chars.Last;
 241       New_Last : constant Int := Old_Last + S_Len;
 242
 243    begin
 244       String_Chars.Set_Last (New_Last);
 245       String_Chars.Table (Old_Last + 1 .. New_Last) :=
 246         String_Chars.Table (S_First .. S_First + S_Len - 1);
 247       Strings.Table (Strings.Last).Length :=
 248         Strings.Table (Strings.Last).Length + S_Len;
 249    end Store_String_Chars;
 250
 251    ----------------------
 252    -- Store_String_Int --
 253    ----------------------
 254
 255    procedure Store_String_Int (N : Int) is
 256    begin
 257       if N < 0 then
 258          Store_String_Char ('-');
 259          Store_String_Int (-N);
 260
 261       else
 262          if N > 9 then
 263             Store_String_Int (N / 10);
 264          end if;
 265
 266          Store_String_Char (Character'Val (Character'Pos ('0') + N mod 10));
 267       end if;
 268    end Store_String_Int;
 269
 270    --------------------------
 271    -- String_Chars_Address --
 272    --------------------------
 273
 274    function String_Chars_Address return System.Address is
 275    begin
 276       return String_Chars.Table (0)'Address;
 277    end String_Chars_Address;
 278
 279    ------------------
 280    -- String_Equal --
 281    ------------------
 282
 283    function String_Equal (L, R : String_Id) return Boolean is
 284       Len : constant Nat := Strings.Table (L).Length;
 285
 286    begin
 287       if Len /= Strings.Table (R).Length then
 288          return False;
 289       else
 290          for J in 1 .. Len loop
 291             if Get_String_Char (L, J) /= Get_String_Char (R, J) then
 292                return False;
 293             end if;
 294          end loop;
 295
 296          return True;
 297       end if;
 298    end String_Equal;
 299
 300    -----------------------------
 301    -- String_From_Name_Buffer --
 302    -----------------------------
 303
 304    function String_From_Name_Buffer
 305      (Buf : Bounded_String := Global_Name_Buffer) return String_Id
 306    is
 307    begin
 308       Start_String;
 309       Store_String_Chars (+Buf);
 310       return End_String;
 311    end String_From_Name_Buffer;
 312
 313    -------------------
 314    -- String_Length --
 315    -------------------
 316
 317    function String_Length (Id : String_Id) return Nat is
 318    begin
 319       return Strings.Table (Id).Length;
 320    end String_Length;
 321
 322    --------------------
 323    -- String_To_Name --
 324    --------------------
 325
 326    function String_To_Name (S : String_Id) return Name_Id is
 327       Buf : Bounded_String;
 328    begin
 329       Append (Buf, S);
 330       return Name_Find (Buf);
 331    end String_To_Name;
 332
 333    ---------------------------
 334    -- String_To_Name_Buffer --
 335    ---------------------------
 336
 337    procedure String_To_Name_Buffer (S : String_Id) is
 338    begin
 339       Name_Len := 0;
 340       Append (Global_Name_Buffer, S);
 341    end String_To_Name_Buffer;
 342
 343    ---------------------
 344    -- Strings_Address --
 345    ---------------------
 346
 347    function Strings_Address return System.Address is
 348    begin
 349       return Strings.Table (First_String_Id)'Address;
 350    end Strings_Address;
 351
 352    ---------------
 353    -- Tree_Read --
 354    ---------------
 355
 356    procedure Tree_Read is
 357    begin
 358       String_Chars.Tree_Read;
 359       Strings.Tree_Read;
 360    end Tree_Read;
 361
 362    ----------------
 363    -- Tree_Write --
 364    ----------------
 365
 366    procedure Tree_Write is
 367    begin
 368       String_Chars.Tree_Write;
 369       Strings.Tree_Write;
 370    end Tree_Write;
 371
 372    ------------
 373    -- Unlock --
 374    ------------
 375
 376    procedure Unlock is
 377    begin
 378       String_Chars.Locked := False;
 379       Strings.Locked := False;
 380    end Unlock;
 381
 382    -------------------------
 383    -- Unstore_String_Char --
 384    -------------------------
 385
 386    procedure Unstore_String_Char is
 387    begin
 388       String_Chars.Decrement_Last;
 389       Strings.Table (Strings.Last).Length :=
 390         Strings.Table (Strings.Last).Length - 1;
 391    end Unstore_String_Char;
 392
 393    ---------------------
 394    -- Write_Char_Code --
 395    ---------------------
 396
 397    procedure Write_Char_Code (Code : Char_Code) is
 398
 399       procedure Write_Hex_Byte (J : Char_Code);
 400       --  Write single hex byte (value in range 0 .. 255) as two digits
 401
 402       --------------------
 403       -- Write_Hex_Byte --
 404       --------------------
 405
 406       procedure Write_Hex_Byte (J : Char_Code) is
 407          Hexd : constant array (Char_Code range 0 .. 15) of Character :=
 408                   "0123456789abcdef";
 409       begin
 410          Write_Char (Hexd (J / 16));
 411          Write_Char (Hexd (J mod 16));
 412       end Write_Hex_Byte;
 413
 414    --  Start of processing for Write_Char_Code
 415
 416    begin
 417       if Code in 16#20# .. 16#7E# then
 418          Write_Char (Character'Val (Code));
 419
 420       else
 421          Write_Char ('[');
 422          Write_Char ('"');
 423
 424          if Code > 16#FF_FFFF# then
 425             Write_Hex_Byte (Code / 2 ** 24);
 426          end if;
 427
 428          if Code > 16#FFFF# then
 429             Write_Hex_Byte ((Code / 2 ** 16) mod 256);
 430          end if;
 431
 432          if Code > 16#FF# then
 433             Write_Hex_Byte ((Code / 256) mod 256);
 434          end if;
 435
 436          Write_Hex_Byte (Code mod 256);
 437          Write_Char ('"');
 438          Write_Char (']');
 439       end if;
 440    end Write_Char_Code;
 441
 442    ------------------------------
 443    -- Write_String_Table_Entry --
 444    ------------------------------
 445
 446    procedure Write_String_Table_Entry (Id : String_Id) is
 447       C : Char_Code;
 448
 449    begin
 450       if Id = No_String then
 451          Write_Str ("no string");
 452
 453       else
 454          Write_Char ('"');
 455
 456          for J in 1 .. String_Length (Id) loop
 457             C := Get_String_Char (Id, J);
 458
 459             if C = Character'Pos ('"') then
 460                Write_Str ("""""");
 461             else
 462                Write_Char_Code (C);
 463             end if;
 464
 465             --  If string is very long, quit
 466
 467             if J >= 1000 then  --  arbitrary limit
 468                Write_Str ("""...etc (length = ");
 469                Write_Int (String_Length (Id));
 470                Write_Str (")");
 471                return;
 472             end if;
 473          end loop;
 474
 475          Write_Char ('"');
 476       end if;
 477    end Write_String_Table_Entry;
 478
 479 end Stringt;