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