1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2012, 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 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. --
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. --
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/>. --
27 -- GNAT was originally developed by the GNAT team at New York University. --
28 -- Extensive contributions were provided by Ada Core Technologies Inc. --
30 ------------------------------------------------------------------------------
33 with Namet
; use Namet
;
34 with Output
; use Output
;
37 package body Stringt
is
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.
43 package String_Chars
is new Table
.Table
(
44 Table_Component_Type
=> Char_Code
,
45 Table_Index_Type
=> Int
,
47 Table_Initial
=> Alloc
.String_Chars_Initial
,
48 Table_Increment
=> Alloc
.String_Chars_Increment
,
49 Table_Name
=> "String_Chars");
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.
55 type String_Entry
is record
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");
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.
73 Strings_Last
: String_Id
:= First_String_Id
;
74 String_Chars_Last
: Int
:= 0;
75 -- Strings_Last and String_Chars_Last are used by procedure Mark and
76 -- Release to get a snapshot of the tables and to restore them to their
77 -- previous situation.
79 -------------------------------
80 -- Add_String_To_Name_Buffer --
81 -------------------------------
83 procedure Add_String_To_Name_Buffer
(S
: String_Id
) is
84 Len
: constant Natural := Natural (String_Length
(S
));
87 for J
in 1 .. Len
loop
88 Name_Buffer
(Name_Len
+ J
) :=
89 Get_Character
(Get_String_Char
(S
, Int
(J
)));
92 Name_Len
:= Name_Len
+ Len
;
93 end Add_String_To_Name_Buffer
;
99 function End_String
return String_Id
is
104 ---------------------
105 -- Get_String_Char --
106 ---------------------
108 function Get_String_Char
(Id
: String_Id
; Index
: Int
) return Char_Code
is
110 pragma Assert
(Id
in First_String_Id
.. Strings
.Last
111 and then Index
in 1 .. Strings
.Table
(Id
).Length
);
113 return String_Chars
.Table
(Strings
.Table
(Id
).String_Index
+ Index
- 1);
120 procedure Initialize
is
132 String_Chars
.Locked
:= True;
133 Strings
.Locked
:= True;
134 String_Chars
.Release
;
144 Strings_Last
:= Strings
.Last
;
145 String_Chars_Last
:= String_Chars
.Last
;
154 Strings
.Set_Last
(Strings_Last
);
155 String_Chars
.Set_Last
(String_Chars_Last
);
162 -- Version to start completely new string
164 procedure Start_String
is
166 Strings
.Append
((String_Index
=> String_Chars
.Last
+ 1, Length
=> 0));
169 -- Version to start from initially stored string
171 procedure Start_String
(S
: String_Id
) is
173 Strings
.Increment_Last
;
175 -- Case of initial string value is at the end of the string characters
176 -- table, so it does not need copying, instead it can be shared.
178 if Strings
.Table
(S
).String_Index
+ Strings
.Table
(S
).Length
=
179 String_Chars
.Last
+ 1
181 Strings
.Table
(Strings
.Last
).String_Index
:=
182 Strings
.Table
(S
).String_Index
;
184 -- Case of initial string value must be copied to new string
187 Strings
.Table
(Strings
.Last
).String_Index
:=
188 String_Chars
.Last
+ 1;
190 for J
in 1 .. Strings
.Table
(S
).Length
loop
192 (String_Chars
.Table
(Strings
.Table
(S
).String_Index
+ (J
- 1)));
196 -- In either case the result string length is copied from the argument
198 Strings
.Table
(Strings
.Last
).Length
:= Strings
.Table
(S
).Length
;
201 -----------------------
202 -- Store_String_Char --
203 -----------------------
205 procedure Store_String_Char
(C
: Char_Code
) is
207 String_Chars
.Append
(C
);
208 Strings
.Table
(Strings
.Last
).Length
:=
209 Strings
.Table
(Strings
.Last
).Length
+ 1;
210 end Store_String_Char
;
212 procedure Store_String_Char
(C
: Character) is
214 Store_String_Char
(Get_Char_Code
(C
));
215 end Store_String_Char
;
217 ------------------------
218 -- Store_String_Chars --
219 ------------------------
221 procedure Store_String_Chars
(S
: String) is
223 for J
in S
'First .. S
'Last loop
224 Store_String_Char
(Get_Char_Code
(S
(J
)));
226 end Store_String_Chars
;
228 procedure Store_String_Chars
(S
: String_Id
) is
230 -- We are essentially doing this:
232 -- for J in 1 .. String_Length (S) loop
233 -- Store_String_Char (Get_String_Char (S, J));
236 -- but when the string is long it's more efficient to grow the
237 -- String_Chars table all at once.
239 S_First
: constant Int
:= Strings
.Table
(S
).String_Index
;
240 S_Len
: constant Int
:= String_Length
(S
);
241 Old_Last
: constant Int
:= String_Chars
.Last
;
242 New_Last
: constant Int
:= Old_Last
+ S_Len
;
245 String_Chars
.Set_Last
(New_Last
);
246 String_Chars
.Table
(Old_Last
+ 1 .. New_Last
) :=
247 String_Chars
.Table
(S_First
.. S_First
+ S_Len
- 1);
248 Strings
.Table
(Strings
.Last
).Length
:=
249 Strings
.Table
(Strings
.Last
).Length
+ S_Len
;
250 end Store_String_Chars
;
252 ----------------------
253 -- Store_String_Int --
254 ----------------------
256 procedure Store_String_Int
(N
: Int
) is
259 Store_String_Char
('-');
260 Store_String_Int
(-N
);
264 Store_String_Int
(N
/ 10);
267 Store_String_Char
(Character'Val (Character'Pos ('0') + N
mod 10));
269 end Store_String_Int
;
271 --------------------------
272 -- String_Chars_Address --
273 --------------------------
275 function String_Chars_Address
return System
.Address
is
277 return String_Chars
.Table
(0)'Address;
278 end String_Chars_Address
;
284 function String_Equal
(L
, R
: String_Id
) return Boolean is
285 Len
: constant Nat
:= Strings
.Table
(L
).Length
;
288 if Len
/= Strings
.Table
(R
).Length
then
291 for J
in 1 .. Len
loop
292 if Get_String_Char
(L
, J
) /= Get_String_Char
(R
, J
) then
301 -----------------------------
302 -- String_From_Name_Buffer --
303 -----------------------------
305 function String_From_Name_Buffer
return String_Id
is
309 for J
in 1 .. Name_Len
loop
310 Store_String_Char
(Get_Char_Code
(Name_Buffer
(J
)));
314 end String_From_Name_Buffer
;
320 function String_Length
(Id
: String_Id
) return Nat
is
322 return Strings
.Table
(Id
).Length
;
325 ---------------------------
326 -- String_To_Name_Buffer --
327 ---------------------------
329 procedure String_To_Name_Buffer
(S
: String_Id
) is
331 Name_Len
:= Natural (String_Length
(S
));
333 for J
in 1 .. Name_Len
loop
335 Get_Character
(Get_String_Char
(S
, Int
(J
)));
337 end String_To_Name_Buffer
;
339 ---------------------
340 -- Strings_Address --
341 ---------------------
343 function Strings_Address
return System
.Address
is
345 return Strings
.Table
(First_String_Id
)'Address;
352 procedure Tree_Read
is
354 String_Chars
.Tree_Read
;
362 procedure Tree_Write
is
364 String_Chars
.Tree_Write
;
374 String_Chars
.Locked
:= False;
375 Strings
.Locked
:= False;
378 -------------------------
379 -- Unstore_String_Char --
380 -------------------------
382 procedure Unstore_String_Char
is
384 String_Chars
.Decrement_Last
;
385 Strings
.Table
(Strings
.Last
).Length
:=
386 Strings
.Table
(Strings
.Last
).Length
- 1;
387 end Unstore_String_Char
;
389 ---------------------
390 -- Write_Char_Code --
391 ---------------------
393 procedure Write_Char_Code
(Code
: Char_Code
) is
395 procedure Write_Hex_Byte
(J
: Char_Code
);
396 -- Write single hex byte (value in range 0 .. 255) as two digits
402 procedure Write_Hex_Byte
(J
: Char_Code
) is
403 Hexd
: constant array (Char_Code
range 0 .. 15) of Character :=
406 Write_Char
(Hexd
(J
/ 16));
407 Write_Char
(Hexd
(J
mod 16));
410 -- Start of processing for Write_Char_Code
413 if Code
in 16#
20#
.. 16#
7E#
then
414 Write_Char
(Character'Val (Code
));
420 if Code
> 16#FF_FFFF#
then
421 Write_Hex_Byte
(Code
/ 2 ** 24);
424 if Code
> 16#FFFF#
then
425 Write_Hex_Byte
((Code
/ 2 ** 16) mod 256);
428 if Code
> 16#FF#
then
429 Write_Hex_Byte
((Code
/ 256) mod 256);
432 Write_Hex_Byte
(Code
mod 256);
438 ------------------------------
439 -- Write_String_Table_Entry --
440 ------------------------------
442 procedure Write_String_Table_Entry
(Id
: String_Id
) is
446 if Id
= No_String
then
447 Write_Str
("no string");
452 for J
in 1 .. String_Length
(Id
) loop
453 C
:= Get_String_Char
(Id
, J
);
455 if C
= Character'Pos ('"') then
461 -- If string is very long, quit
463 if J
>= 1000 then -- arbitrary limit
464 Write_Str
("""...etc (length = ");
465 Write_Int
(String_Length
(Id
));
473 end Write_String_Table_Entry
;