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