1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
10 -- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
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. --
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. --
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). --
33 ------------------------------------------------------------------------------
36 with Namet
; use Namet
;
37 with Output
; use Output
;
40 package body Stringt
is
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.
46 package String_Chars
is new Table
.Table
(
47 Table_Component_Type
=> Char_Code
,
48 Table_Index_Type
=> Int
,
50 Table_Initial
=> Alloc
.String_Chars_Initial
,
51 Table_Increment
=> Alloc
.String_Chars_Increment
,
52 Table_Name
=> "String_Chars");
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.
58 type String_Entry
is record
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");
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.
76 -------------------------------
77 -- Add_String_To_Name_Buffer --
78 -------------------------------
80 procedure Add_String_To_Name_Buffer
(S
: String_Id
) is
81 Len
: constant Natural := Natural (String_Length
(S
));
84 for J
in 1 .. Len
loop
85 Name_Buffer
(Name_Len
+ J
) :=
86 Get_Character
(Get_String_Char
(S
, Int
(J
)));
89 Name_Len
:= Name_Len
+ Len
;
90 end Add_String_To_Name_Buffer
;
96 function End_String
return String_Id
is
101 ---------------------
102 -- Get_String_Char --
103 ---------------------
105 function Get_String_Char
(Id
: String_Id
; Index
: Int
) return Char_Code
is
107 pragma Assert
(Id
in First_String_Id
.. Strings
.Last
108 and then Index
in 1 .. Strings
.Table
(Id
).Length
);
110 return String_Chars
.Table
(Strings
.Table
(Id
).String_Index
+ Index
- 1);
117 procedure Initialize
is
129 String_Chars
.Locked
:= True;
130 Strings
.Locked
:= True;
131 String_Chars
.Release
;
139 -- Version to start completely new string
141 procedure Start_String
is
143 Strings
.Increment_Last
;
144 Strings
.Table
(Strings
.Last
).String_Index
:= String_Chars
.Last
+ 1;
145 Strings
.Table
(Strings
.Last
).Length
:= 0;
148 -- Version to start from initially stored string
150 procedure Start_String
(S
: String_Id
) is
152 Strings
.Increment_Last
;
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.
157 if Strings
.Table
(S
).String_Index
+ Strings
.Table
(S
).Length
=
158 String_Chars
.Last
+ 1
160 Strings
.Table
(Strings
.Last
).String_Index
:=
161 Strings
.Table
(S
).String_Index
;
163 -- Case of initial string value must be copied to new string
166 Strings
.Table
(Strings
.Last
).String_Index
:=
167 String_Chars
.Last
+ 1;
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));
176 -- In either case the result string length is copied from the argument
178 Strings
.Table
(Strings
.Last
).Length
:= Strings
.Table
(S
).Length
;
181 -----------------------
182 -- Store_String_Char --
183 -----------------------
185 procedure Store_String_Char
(C
: Char_Code
) is
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
;
193 procedure Store_String_Char
(C
: Character) is
195 Store_String_Char
(Get_Char_Code
(C
));
196 end Store_String_Char
;
198 ------------------------
199 -- Store_String_Chars --
200 ------------------------
202 procedure Store_String_Chars
(S
: String) is
204 for J
in S
'First .. S
'Last loop
205 Store_String_Char
(Get_Char_Code
(S
(J
)));
207 end Store_String_Chars
;
209 procedure Store_String_Chars
(S
: String_Id
) is
211 for J
in 1 .. String_Length
(S
) loop
212 Store_String_Char
(Get_String_Char
(S
, J
));
214 end Store_String_Chars
;
216 ----------------------
217 -- Store_String_Int --
218 ----------------------
220 procedure Store_String_Int
(N
: Int
) is
223 Store_String_Char
('-');
224 Store_String_Int
(-N
);
228 Store_String_Int
(N
/ 10);
231 Store_String_Char
(Character'Val (Character'Pos ('0') + N
mod 10));
233 end Store_String_Int
;
235 --------------------------
236 -- String_Chars_Address --
237 --------------------------
239 function String_Chars_Address
return System
.Address
is
241 return String_Chars
.Table
(0)'Address;
242 end String_Chars_Address
;
248 function String_Equal
(L
, R
: String_Id
) return Boolean is
249 Len
: constant Nat
:= Strings
.Table
(L
).Length
;
252 if Len
/= Strings
.Table
(R
).Length
then
255 for J
in 1 .. Len
loop
256 if Get_String_Char
(L
, J
) /= Get_String_Char
(R
, J
) then
265 -----------------------------
266 -- String_From_Name_Buffer --
267 -----------------------------
269 function String_From_Name_Buffer
return String_Id
is
273 for J
in 1 .. Name_Len
loop
274 Store_String_Char
(Get_Char_Code
(Name_Buffer
(J
)));
278 end String_From_Name_Buffer
;
284 function String_Length
(Id
: String_Id
) return Nat
is
286 return Strings
.Table
(Id
).Length
;
289 ---------------------------
290 -- String_To_Name_Buffer --
291 ---------------------------
293 procedure String_To_Name_Buffer
(S
: String_Id
) is
295 Name_Len
:= Natural (String_Length
(S
));
297 for J
in 1 .. Name_Len
loop
299 Get_Character
(Get_String_Char
(S
, Int
(J
)));
301 end String_To_Name_Buffer
;
303 ---------------------
304 -- Strings_Address --
305 ---------------------
307 function Strings_Address
return System
.Address
is
309 return Strings
.Table
(First_String_Id
)'Address;
316 procedure Tree_Read
is
318 String_Chars
.Tree_Read
;
326 procedure Tree_Write
is
328 String_Chars
.Tree_Write
;
338 String_Chars
.Locked
:= False;
339 Strings
.Locked
:= False;
342 -------------------------
343 -- Unstore_String_Char --
344 -------------------------
346 procedure Unstore_String_Char
is
348 String_Chars
.Decrement_Last
;
349 Strings
.Table
(Strings
.Last
).Length
:=
350 Strings
.Table
(Strings
.Last
).Length
- 1;
351 end Unstore_String_Char
;
353 ---------------------
354 -- Write_Char_Code --
355 ---------------------
357 procedure Write_Char_Code
(Code
: Char_Code
) is
359 procedure Write_Hex_Byte
(J
: Natural);
360 -- Write single hex digit
362 procedure Write_Hex_Byte
(J
: Natural) is
363 Hexd
: String := "0123456789abcdef";
366 Write_Char
(Hexd
(J
/ 16 + 1));
367 Write_Char
(Hexd
(J
mod 16 + 1));
370 -- Start of processing for Write_Char_Code
373 if Code
in 16#
20#
.. 16#
7E#
then
374 Write_Char
(Character'Val (Code
));
380 if Code
> 16#FF#
then
381 Write_Hex_Byte
(Natural (Code
/ 256));
384 Write_Hex_Byte
(Natural (Code
mod 256));
390 ------------------------------
391 -- Write_String_Table_Entry --
392 ------------------------------
394 procedure Write_String_Table_Entry
(Id
: String_Id
) is
398 if Id
= No_String
then
399 Write_Str
("no string");
404 for J
in 1 .. String_Length
(Id
) loop
405 C
:= Get_String_Char
(Id
, J
);
407 if Character'Val (C
) = '"' then
417 end Write_String_Table_Entry
;