1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2007, Free Software Foundation, Inc. --
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. --
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. --
29 -- GNAT was originally developed by the GNAT team at New York University. --
30 -- Extensive contributions were provided by Ada Core Technologies Inc. --
32 ------------------------------------------------------------------------------
35 with Namet; use Namet;
36 with Output; use Output;
39 package body Stringt is
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.
45 package String_Chars is new Table.Table (
46 Table_Component_Type => Char_Code,
47 Table_Index_Type => Int,
49 Table_Initial => Alloc.String_Chars_Initial,
50 Table_Increment => Alloc.String_Chars_Increment,
51 Table_Name => "String_Chars");
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.
57 type String_Entry is record
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");
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.
75 -------------------------------
76 -- Add_String_To_Name_Buffer --
77 -------------------------------
79 procedure Add_String_To_Name_Buffer (S : String_Id) is
80 Len : constant Natural := Natural (String_Length (S));
83 for J in 1 .. Len loop
84 Name_Buffer (Name_Len + J) :=
85 Get_Character (Get_String_Char (S, Int (J)));
88 Name_Len := Name_Len + Len;
89 end Add_String_To_Name_Buffer;
95 function End_String return String_Id is
100 ---------------------
101 -- Get_String_Char --
102 ---------------------
104 function Get_String_Char (Id : String_Id; Index : Int) return Char_Code is
106 pragma Assert (Id in First_String_Id .. Strings.Last
107 and then Index in 1 .. Strings.Table (Id).Length);
109 return String_Chars.Table (Strings.Table (Id).String_Index + Index - 1);
116 procedure Initialize is
128 String_Chars.Locked := True;
129 Strings.Locked := True;
130 String_Chars.Release;
138 -- Version to start completely new string
140 procedure Start_String is
142 Strings.Append ((String_Index => String_Chars.Last + 1, Length => 0));
145 -- Version to start from initially stored string
147 procedure Start_String (S : String_Id) is
149 Strings.Increment_Last;
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.
154 if Strings.Table (S).String_Index + Strings.Table (S).Length =
155 String_Chars.Last + 1
157 Strings.Table (Strings.Last).String_Index :=
158 Strings.Table (S).String_Index;
160 -- Case of initial string value must be copied to new string
163 Strings.Table (Strings.Last).String_Index :=
164 String_Chars.Last + 1;
166 for J in 1 .. Strings.Table (S).Length loop
168 (String_Chars.Table (Strings.Table (S).String_Index + (J - 1)));
172 -- In either case the result string length is copied from the argument
174 Strings.Table (Strings.Last).Length := Strings.Table (S).Length;
177 -----------------------
178 -- Store_String_Char --
179 -----------------------
181 procedure Store_String_Char (C : Char_Code) is
183 String_Chars.Append (C);
184 Strings.Table (Strings.Last).Length :=
185 Strings.Table (Strings.Last).Length + 1;
186 end Store_String_Char;
188 procedure Store_String_Char (C : Character) is
190 Store_String_Char (Get_Char_Code (C));
191 end Store_String_Char;
193 ------------------------
194 -- Store_String_Chars --
195 ------------------------
197 procedure Store_String_Chars (S : String) is
199 for J in S'First .. S'Last loop
200 Store_String_Char (Get_Char_Code (S (J)));
202 end Store_String_Chars;
204 procedure Store_String_Chars (S : String_Id) is
206 -- We are essentially doing this:
208 -- for J in 1 .. String_Length (S) loop
209 -- Store_String_Char (Get_String_Char (S, J));
212 -- but when the string is long it's more efficient to grow the
213 -- String_Chars table all at once.
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;
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;
228 ----------------------
229 -- Store_String_Int --
230 ----------------------
232 procedure Store_String_Int (N : Int) is
235 Store_String_Char ('-');
236 Store_String_Int (-N);
240 Store_String_Int (N / 10);
243 Store_String_Char (Character'Val (Character'Pos ('0') + N mod 10));
245 end Store_String_Int;
247 --------------------------
248 -- String_Chars_Address --
249 --------------------------
251 function String_Chars_Address return System.Address is
253 return String_Chars.Table (0)'Address;
254 end String_Chars_Address;
260 function String_Equal (L, R : String_Id) return Boolean is
261 Len : constant Nat := Strings.Table (L).Length;
264 if Len /= Strings.Table (R).Length then
267 for J in 1 .. Len loop
268 if Get_String_Char (L, J) /= Get_String_Char (R, J) then
277 -----------------------------
278 -- String_From_Name_Buffer --
279 -----------------------------
281 function String_From_Name_Buffer return String_Id is
285 for J in 1 .. Name_Len loop
286 Store_String_Char (Get_Char_Code (Name_Buffer (J)));
290 end String_From_Name_Buffer;
296 function String_Length (Id : String_Id) return Nat is
298 return Strings.Table (Id).Length;
301 ---------------------------
302 -- String_To_Name_Buffer --
303 ---------------------------
305 procedure String_To_Name_Buffer (S : String_Id) is
307 Name_Len := Natural (String_Length (S));
309 for J in 1 .. Name_Len loop
311 Get_Character (Get_String_Char (S, Int (J)));
313 end String_To_Name_Buffer;
315 ---------------------
316 -- Strings_Address --
317 ---------------------
319 function Strings_Address return System.Address is
321 return Strings.Table (First_String_Id)'Address;
328 procedure Tree_Read is
330 String_Chars.Tree_Read;
338 procedure Tree_Write is
340 String_Chars.Tree_Write;
350 String_Chars.Locked := False;
351 Strings.Locked := False;
354 -------------------------
355 -- Unstore_String_Char --
356 -------------------------
358 procedure Unstore_String_Char is
360 String_Chars.Decrement_Last;
361 Strings.Table (Strings.Last).Length :=
362 Strings.Table (Strings.Last).Length - 1;
363 end Unstore_String_Char;
365 ---------------------
366 -- Write_Char_Code --
367 ---------------------
369 procedure Write_Char_Code (Code : Char_Code) is
371 procedure Write_Hex_Byte (J : Char_Code);
372 -- Write single hex byte (value in range 0 .. 255) as two digits
378 procedure Write_Hex_Byte (J : Char_Code) is
379 Hexd : constant array (Char_Code range 0 .. 15) of Character :=
382 Write_Char (Hexd (J / 16));
383 Write_Char (Hexd (J mod 16));
386 -- Start of processing for Write_Char_Code
389 if Code in 16#20# .. 16#7E# then
390 Write_Char (Character'Val (Code));
396 if Code > 16#FF_FFFF# then
397 Write_Hex_Byte (Code / 2 ** 24);
400 if Code > 16#FFFF# then
401 Write_Hex_Byte ((Code / 2 ** 16) mod 256);
404 if Code > 16#FF# then
405 Write_Hex_Byte ((Code / 256) mod 256);
408 Write_Hex_Byte (Code mod 256);
414 ------------------------------
415 -- Write_String_Table_Entry --
416 ------------------------------
418 procedure Write_String_Table_Entry (Id : String_Id) is
422 if Id = No_String then
423 Write_Str ("no string");
428 for J in 1 .. String_Length (Id) loop
429 C := Get_String_Char (Id, J);
431 if Character'Val (C) = '"' then
438 -- If string is very long, quit
440 if J >= 1000 then -- arbitrary limit
441 Write_Str ("""...etc (length = ");
442 Write_Int (String_Length (Id));
450 end Write_String_Table_Entry;