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