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