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