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