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-2015, 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    -- Add_String_To_Name_Buffer --
  80    -------------------------------
  81
  82    procedure Add_String_To_Name_Buffer (S : String_Id) is
  83    begin
  84       Append (Global_Name_Buffer, S);
  85    end Add_String_To_Name_Buffer;
  86
  87    procedure Append (Buf : in out Bounded_String; S : String_Id) is
  88    begin
  89       for X in 1 .. String_Length (S) loop
  90          Append (Buf, Get_Character (Get_String_Char (S, X)));
  91       end loop;
  92    end Append;
  93
  94    ----------------
  95    -- End_String --
  96    ----------------
  97
  98    function End_String return String_Id is
  99    begin
 100       return Strings.Last;
 101    end End_String;
 102
 103    ---------------------
 104    -- Get_String_Char --
 105    ---------------------
 106
 107    function Get_String_Char (Id : String_Id; Index : Int) return Char_Code is
 108    begin
 109       pragma Assert (Id in First_String_Id .. Strings.Last
 110                        and then Index in 1 .. Strings.Table (Id).Length);
 111
 112       return String_Chars.Table (Strings.Table (Id).String_Index + Index - 1);
 113    end Get_String_Char;
 114
 115    ----------------
 116    -- Initialize --
 117    ----------------
 118
 119    procedure Initialize is
 120    begin
 121       String_Chars.Init;
 122       Strings.Init;
 123
 124       --  Set up the null string
 125
 126       Start_String;
 127       Null_String_Id := End_String;
 128    end Initialize;
 129
 130    ----------
 131    -- Lock --
 132    ----------
 133
 134    procedure Lock is
 135    begin
 136       String_Chars.Locked := True;
 137       Strings.Locked := True;
 138       String_Chars.Release;
 139       Strings.Release;
 140    end Lock;
 141
 142    ----------
 143    -- Mark --
 144    ----------
 145
 146    procedure Mark is
 147    begin
 148       Strings_Last := Strings.Last;
 149       String_Chars_Last := String_Chars.Last;
 150    end Mark;
 151
 152    -------------
 153    -- Release --
 154    -------------
 155
 156    procedure Release is
 157    begin
 158       Strings.Set_Last (Strings_Last);
 159       String_Chars.Set_Last (String_Chars_Last);
 160    end Release;
 161
 162    ------------------
 163    -- Start_String --
 164    ------------------
 165
 166    --  Version to start completely new string
 167
 168    procedure Start_String is
 169    begin
 170       Strings.Append ((String_Index => String_Chars.Last + 1, Length => 0));
 171    end Start_String;
 172
 173    --  Version to start from initially stored string
 174
 175    procedure Start_String (S : String_Id) is
 176    begin
 177       Strings.Increment_Last;
 178
 179       --  Case of initial string value is at the end of the string characters
 180       --  table, so it does not need copying, instead it can be shared.
 181
 182       if Strings.Table (S).String_Index + Strings.Table (S).Length =
 183                                                     String_Chars.Last + 1
 184       then
 185          Strings.Table (Strings.Last).String_Index :=
 186            Strings.Table (S).String_Index;
 187
 188       --  Case of initial string value must be copied to new string
 189
 190       else
 191          Strings.Table (Strings.Last).String_Index :=
 192            String_Chars.Last + 1;
 193
 194          for J in 1 .. Strings.Table (S).Length loop
 195             String_Chars.Append
 196               (String_Chars.Table (Strings.Table (S).String_Index + (J - 1)));
 197          end loop;
 198       end if;
 199
 200       --  In either case the result string length is copied from the argument
 201
 202       Strings.Table (Strings.Last).Length := Strings.Table (S).Length;
 203    end Start_String;
 204
 205    -----------------------
 206    -- Store_String_Char --
 207    -----------------------
 208
 209    procedure Store_String_Char (C : Char_Code) is
 210    begin
 211       String_Chars.Append (C);
 212       Strings.Table (Strings.Last).Length :=
 213         Strings.Table (Strings.Last).Length + 1;
 214    end Store_String_Char;
 215
 216    procedure Store_String_Char (C : Character) is
 217    begin
 218       Store_String_Char (Get_Char_Code (C));
 219    end Store_String_Char;
 220
 221    ------------------------
 222    -- Store_String_Chars --
 223    ------------------------
 224
 225    procedure Store_String_Chars (S : String) is
 226    begin
 227       for J in S'First .. S'Last loop
 228          Store_String_Char (Get_Char_Code (S (J)));
 229       end loop;
 230    end Store_String_Chars;
 231
 232    procedure Store_String_Chars (S : String_Id) is
 233
 234       --  We are essentially doing this:
 235
 236       --   for J in 1 .. String_Length (S) loop
 237       --      Store_String_Char (Get_String_Char (S, J));
 238       --   end loop;
 239
 240       --  but when the string is long it's more efficient to grow the
 241       --  String_Chars table all at once.
 242
 243       S_First  : constant Int := Strings.Table (S).String_Index;
 244       S_Len    : constant Nat := String_Length (S);
 245       Old_Last : constant Int := String_Chars.Last;
 246       New_Last : constant Int := Old_Last + S_Len;
 247
 248    begin
 249       String_Chars.Set_Last (New_Last);
 250       String_Chars.Table (Old_Last + 1 .. New_Last) :=
 251         String_Chars.Table (S_First .. S_First + S_Len - 1);
 252       Strings.Table (Strings.Last).Length :=
 253         Strings.Table (Strings.Last).Length + S_Len;
 254    end Store_String_Chars;
 255
 256    ----------------------
 257    -- Store_String_Int --
 258    ----------------------
 259
 260    procedure Store_String_Int (N : Int) is
 261    begin
 262       if N < 0 then
 263          Store_String_Char ('-');
 264          Store_String_Int (-N);
 265
 266       else
 267          if N > 9 then
 268             Store_String_Int (N / 10);
 269          end if;
 270
 271          Store_String_Char (Character'Val (Character'Pos ('0') + N mod 10));
 272       end if;
 273    end Store_String_Int;
 274
 275    --------------------------
 276    -- String_Chars_Address --
 277    --------------------------
 278
 279    function String_Chars_Address return System.Address is
 280    begin
 281       return String_Chars.Table (0)'Address;
 282    end String_Chars_Address;
 283
 284    ------------------
 285    -- String_Equal --
 286    ------------------
 287
 288    function String_Equal (L, R : String_Id) return Boolean is
 289       Len : constant Nat := Strings.Table (L).Length;
 290
 291    begin
 292       if Len /= Strings.Table (R).Length then
 293          return False;
 294       else
 295          for J in 1 .. Len loop
 296             if Get_String_Char (L, J) /= Get_String_Char (R, J) then
 297                return False;
 298             end if;
 299          end loop;
 300
 301          return True;
 302       end if;
 303    end String_Equal;
 304
 305    -----------------------------
 306    -- String_From_Name_Buffer --
 307    -----------------------------
 308
 309    function String_From_Name_Buffer
 310      (Buf : Bounded_String := Global_Name_Buffer) return String_Id
 311    is
 312    begin
 313       Start_String;
 314       Store_String_Chars (+Buf);
 315       return End_String;
 316    end String_From_Name_Buffer;
 317
 318    -------------------
 319    -- String_Length --
 320    -------------------
 321
 322    function String_Length (Id : String_Id) return Nat is
 323    begin
 324       return Strings.Table (Id).Length;
 325    end String_Length;
 326
 327    ---------------------------
 328    -- String_To_Name_Buffer --
 329    ---------------------------
 330
 331    procedure String_To_Name_Buffer (S : String_Id) is
 332    begin
 333       Name_Len := 0;
 334       Append (Global_Name_Buffer, S);
 335    end String_To_Name_Buffer;
 336
 337    ---------------------
 338    -- Strings_Address --
 339    ---------------------
 340
 341    function Strings_Address return System.Address is
 342    begin
 343       return Strings.Table (First_String_Id)'Address;
 344    end Strings_Address;
 345
 346    ---------------
 347    -- Tree_Read --
 348    ---------------
 349
 350    procedure Tree_Read is
 351    begin
 352       String_Chars.Tree_Read;
 353       Strings.Tree_Read;
 354    end Tree_Read;
 355
 356    ----------------
 357    -- Tree_Write --
 358    ----------------
 359
 360    procedure Tree_Write is
 361    begin
 362       String_Chars.Tree_Write;
 363       Strings.Tree_Write;
 364    end Tree_Write;
 365
 366    ------------
 367    -- Unlock --
 368    ------------
 369
 370    procedure Unlock is
 371    begin
 372       String_Chars.Locked := False;
 373       Strings.Locked := False;
 374    end Unlock;
 375
 376    -------------------------
 377    -- Unstore_String_Char --
 378    -------------------------
 379
 380    procedure Unstore_String_Char is
 381    begin
 382       String_Chars.Decrement_Last;
 383       Strings.Table (Strings.Last).Length :=
 384         Strings.Table (Strings.Last).Length - 1;
 385    end Unstore_String_Char;
 386
 387    ---------------------
 388    -- Write_Char_Code --
 389    ---------------------
 390
 391    procedure Write_Char_Code (Code : Char_Code) is
 392
 393       procedure Write_Hex_Byte (J : Char_Code);
 394       --  Write single hex byte (value in range 0 .. 255) as two digits
 395
 396       --------------------
 397       -- Write_Hex_Byte --
 398       --------------------
 399
 400       procedure Write_Hex_Byte (J : Char_Code) is
 401          Hexd : constant array (Char_Code range 0 .. 15) of Character :=
 402                   "0123456789abcdef";
 403       begin
 404          Write_Char (Hexd (J / 16));
 405          Write_Char (Hexd (J mod 16));
 406       end Write_Hex_Byte;
 407
 408    --  Start of processing for Write_Char_Code
 409
 410    begin
 411       if Code in 16#20# .. 16#7E# then
 412          Write_Char (Character'Val (Code));
 413
 414       else
 415          Write_Char ('[');
 416          Write_Char ('"');
 417
 418          if Code > 16#FF_FFFF# then
 419             Write_Hex_Byte (Code / 2 ** 24);
 420          end if;
 421
 422          if Code > 16#FFFF# then
 423             Write_Hex_Byte ((Code / 2 ** 16) mod 256);
 424          end if;
 425
 426          if Code > 16#FF# then
 427             Write_Hex_Byte ((Code / 256) mod 256);
 428          end if;
 429
 430          Write_Hex_Byte (Code mod 256);
 431          Write_Char ('"');
 432          Write_Char (']');
 433       end if;
 434    end Write_Char_Code;
 435
 436    ------------------------------
 437    -- Write_String_Table_Entry --
 438    ------------------------------
 439
 440    procedure Write_String_Table_Entry (Id : String_Id) is
 441       C : Char_Code;
 442
 443    begin
 444       if Id = No_String then
 445          Write_Str ("no string");
 446
 447       else
 448          Write_Char ('"');
 449
 450          for J in 1 .. String_Length (Id) loop
 451             C := Get_String_Char (Id, J);
 452
 453             if C = Character'Pos ('"') then
 454                Write_Str ("""""");
 455             else
 456                Write_Char_Code (C);
 457             end if;
 458
 459             --  If string is very long, quit
 460
 461             if J >= 1000 then  --  arbitrary limit
 462                Write_Str ("""...etc (length = ");
 463                Write_Int (String_Length (Id));
 464                Write_Str (")");
 465                return;
 466             end if;
 467          end loop;
 468
 469          Write_Char ('"');
 470       end if;
 471    end Write_String_Table_Entry;
 472
 473 end Stringt;