File : 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-2015, 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 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. --
17 -- --
18 -- --
19 -- --
20 -- --
21 -- --
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/>. --
26 -- --
27 -- GNAT was originally developed by the GNAT team at New York University. --
28 -- Extensive contributions were provided by Ada Core Technologies Inc. --
29 -- --
30 ------------------------------------------------------------------------------
31
32 with Alloc;
33 with Output; use Output;
34 with Table;
35
36 package body Stringt is
37
38 -- The following table stores the sequence of character codes for the
39 -- stored string constants. The entries are referenced from the
40 -- separate Strings table.
41
42 package String_Chars is new Table.Table (
43 Table_Component_Type => Char_Code,
44 Table_Index_Type => Int,
45 Table_Low_Bound => 0,
46 Table_Initial => Alloc.String_Chars_Initial,
47 Table_Increment => Alloc.String_Chars_Increment,
48 Table_Name => "String_Chars");
49
50 -- The String_Id values reference entries in the Strings table, which
51 -- contains String_Entry records that record the length of each stored
52 -- string and its starting location in the String_Chars table.
53
54 type String_Entry is record
55 String_Index : Int;
56 Length : Nat;
57 end record;
58
59 package Strings is new Table.Table (
60 Table_Component_Type => String_Entry,
61 Table_Index_Type => String_Id'Base,
62 Table_Low_Bound => First_String_Id,
63 Table_Initial => Alloc.Strings_Initial,
64 Table_Increment => Alloc.Strings_Increment,
65 Table_Name => "Strings");
66
67 -- Note: it is possible that two entries in the Strings table can share
68 -- string data in the String_Chars table, and in particular this happens
69 -- when Start_String is called with a parameter that is the last string
70 -- currently allocated in the table.
71
72 Strings_Last : String_Id := First_String_Id;
73 String_Chars_Last : Int := 0;
74 -- Strings_Last and String_Chars_Last are used by procedure Mark and
75 -- Release to get a snapshot of the tables and to restore them to their
76 -- previous situation.
77
78 -------------------------------
79 -- Add_String_To_Name_Buffer --
80 -------------------------------
81
82 procedure Add_String_To_Name_Buffer (S : String_Id) is
83 begin
84 Append (Global_Name_Buffer, S);
85 end Add_String_To_Name_Buffer;
86
87 procedure Append (Buf : in out Bounded_String; S : String_Id) is
88 begin
89 for X in 1 .. String_Length (S) loop
90 Append (Buf, Get_Character (Get_String_Char (S, X)));
91 end loop;
92 end Append;
93
94 ----------------
95 -- End_String --
96 ----------------
97
98 function End_String return String_Id is
99 begin
100 return Strings.Last;
101 end End_String;
102
103 ---------------------
104 -- Get_String_Char --
105 ---------------------
106
107 function Get_String_Char (Id : String_Id; Index : Int) return Char_Code is
108 begin
109 pragma Assert (Id in First_String_Id .. Strings.Last
110 and then Index in 1 .. Strings.Table (Id).Length);
111
112 return String_Chars.Table (Strings.Table (Id).String_Index + Index - 1);
113 end Get_String_Char;
114
115 ----------------
116 -- Initialize --
117 ----------------
118
119 procedure Initialize is
120 begin
121 String_Chars.Init;
122 Strings.Init;
123
124 -- Set up the null string
125
126 Start_String;
127 Null_String_Id := End_String;
128 end Initialize;
129
130 ----------
131 -- Lock --
132 ----------
133
134 procedure Lock is
135 begin
136 String_Chars.Locked := True;
137 Strings.Locked := True;
138 String_Chars.Release;
139 Strings.Release;
140 end Lock;
141
142 ----------
143 -- Mark --
144 ----------
145
146 procedure Mark is
147 begin
148 Strings_Last := Strings.Last;
149 String_Chars_Last := String_Chars.Last;
150 end Mark;
151
152 -------------
153 -- Release --
154 -------------
155
156 procedure Release is
157 begin
158 Strings.Set_Last (Strings_Last);
159 String_Chars.Set_Last (String_Chars_Last);
160 end Release;
161
162 ------------------
163 -- Start_String --
164 ------------------
165
166 -- Version to start completely new string
167
168 procedure Start_String is
169 begin
170 Strings.Append ((String_Index => String_Chars.Last + 1, Length => 0));
171 end Start_String;
172
173 -- Version to start from initially stored string
174
175 procedure Start_String (S : String_Id) is
176 begin
177 Strings.Increment_Last;
178
179 -- Case of initial string value is at the end of the string characters
180 -- table, so it does not need copying, instead it can be shared.
181
182 if Strings.Table (S).String_Index + Strings.Table (S).Length =
183 String_Chars.Last + 1
184 then
185 Strings.Table (Strings.Last).String_Index :=
186 Strings.Table (S).String_Index;
187
188 -- Case of initial string value must be copied to new string
189
190 else
191 Strings.Table (Strings.Last).String_Index :=
192 String_Chars.Last + 1;
193
194 for J in 1 .. Strings.Table (S).Length loop
195 String_Chars.Append
196 (String_Chars.Table (Strings.Table (S).String_Index + (J - 1)));
197 end loop;
198 end if;
199
200 -- In either case the result string length is copied from the argument
201
202 Strings.Table (Strings.Last).Length := Strings.Table (S).Length;
203 end Start_String;
204
205 -----------------------
206 -- Store_String_Char --
207 -----------------------
208
209 procedure Store_String_Char (C : Char_Code) is
210 begin
211 String_Chars.Append (C);
212 Strings.Table (Strings.Last).Length :=
213 Strings.Table (Strings.Last).Length + 1;
214 end Store_String_Char;
215
216 procedure Store_String_Char (C : Character) is
217 begin
218 Store_String_Char (Get_Char_Code (C));
219 end Store_String_Char;
220
221 ------------------------
222 -- Store_String_Chars --
223 ------------------------
224
225 procedure Store_String_Chars (S : String) is
226 begin
227 for J in S'First .. S'Last loop
228 Store_String_Char (Get_Char_Code (S (J)));
229 end loop;
230 end Store_String_Chars;
231
232 procedure Store_String_Chars (S : String_Id) is
233
234 -- We are essentially doing this:
235
236 -- for J in 1 .. String_Length (S) loop
237 -- Store_String_Char (Get_String_Char (S, J));
238 -- end loop;
239
240 -- but when the string is long it's more efficient to grow the
241 -- String_Chars table all at once.
242
243 S_First : constant Int := Strings.Table (S).String_Index;
244 S_Len : constant Nat := String_Length (S);
245 Old_Last : constant Int := String_Chars.Last;
246 New_Last : constant Int := Old_Last + S_Len;
247
248 begin
249 String_Chars.Set_Last (New_Last);
250 String_Chars.Table (Old_Last + 1 .. New_Last) :=
251 String_Chars.Table (S_First .. S_First + S_Len - 1);
252 Strings.Table (Strings.Last).Length :=
253 Strings.Table (Strings.Last).Length + S_Len;
254 end Store_String_Chars;
255
256 ----------------------
257 -- Store_String_Int --
258 ----------------------
259
260 procedure Store_String_Int (N : Int) is
261 begin
262 if N < 0 then
263 Store_String_Char ('-');
264 Store_String_Int (-N);
265
266 else
267 if N > 9 then
268 Store_String_Int (N / 10);
269 end if;
270
271 Store_String_Char (Character'Val (Character'Pos ('0') + N mod 10));
272 end if;
273 end Store_String_Int;
274
275 --------------------------
276 -- String_Chars_Address --
277 --------------------------
278
279 function String_Chars_Address return System.Address is
280 begin
281 return String_Chars.Table (0)'Address;
282 end String_Chars_Address;
283
284 ------------------
285 -- String_Equal --
286 ------------------
287
288 function String_Equal (L, R : String_Id) return Boolean is
289 Len : constant Nat := Strings.Table (L).Length;
290
291 begin
292 if Len /= Strings.Table (R).Length then
293 return False;
294 else
295 for J in 1 .. Len loop
296 if Get_String_Char (L, J) /= Get_String_Char (R, J) then
297 return False;
298 end if;
299 end loop;
300
301 return True;
302 end if;
303 end String_Equal;
304
305 -----------------------------
306 -- String_From_Name_Buffer --
307 -----------------------------
308
309 function String_From_Name_Buffer
310 (Buf : Bounded_String := Global_Name_Buffer) return String_Id
311 is
312 begin
313 Start_String;
314 Store_String_Chars (+Buf);
315 return End_String;
316 end String_From_Name_Buffer;
317
318 -------------------
319 -- String_Length --
320 -------------------
321
322 function String_Length (Id : String_Id) return Nat is
323 begin
324 return Strings.Table (Id).Length;
325 end String_Length;
326
327 ---------------------------
328 -- String_To_Name_Buffer --
329 ---------------------------
330
331 procedure String_To_Name_Buffer (S : String_Id) is
332 begin
333 Name_Len := 0;
334 Append (Global_Name_Buffer, S);
335 end String_To_Name_Buffer;
336
337 ---------------------
338 -- Strings_Address --
339 ---------------------
340
341 function Strings_Address return System.Address is
342 begin
343 return Strings.Table (First_String_Id)'Address;
344 end Strings_Address;
345
346 ---------------
347 -- Tree_Read --
348 ---------------
349
350 procedure Tree_Read is
351 begin
352 String_Chars.Tree_Read;
353 Strings.Tree_Read;
354 end Tree_Read;
355
356 ----------------
357 -- Tree_Write --
358 ----------------
359
360 procedure Tree_Write is
361 begin
362 String_Chars.Tree_Write;
363 Strings.Tree_Write;
364 end Tree_Write;
365
366 ------------
367 -- Unlock --
368 ------------
369
370 procedure Unlock is
371 begin
372 String_Chars.Locked := False;
373 Strings.Locked := False;
374 end Unlock;
375
376 -------------------------
377 -- Unstore_String_Char --
378 -------------------------
379
380 procedure Unstore_String_Char is
381 begin
382 String_Chars.Decrement_Last;
383 Strings.Table (Strings.Last).Length :=
384 Strings.Table (Strings.Last).Length - 1;
385 end Unstore_String_Char;
386
387 ---------------------
388 -- Write_Char_Code --
389 ---------------------
390
391 procedure Write_Char_Code (Code : Char_Code) is
392
393 procedure Write_Hex_Byte (J : Char_Code);
394 -- Write single hex byte (value in range 0 .. 255) as two digits
395
396 --------------------
397 -- Write_Hex_Byte --
398 --------------------
399
400 procedure Write_Hex_Byte (J : Char_Code) is
401 Hexd : constant array (Char_Code range 0 .. 15) of Character :=
402 "0123456789abcdef";
403 begin
404 Write_Char (Hexd (J / 16));
405 Write_Char (Hexd (J mod 16));
406 end Write_Hex_Byte;
407
408 -- Start of processing for Write_Char_Code
409
410 begin
411 if Code in 16#20# .. 16#7E# then
412 Write_Char (Character'Val (Code));
413
414 else
415 Write_Char ('[');
416 Write_Char ('"');
417
418 if Code > 16#FF_FFFF# then
419 Write_Hex_Byte (Code / 2 ** 24);
420 end if;
421
422 if Code > 16#FFFF# then
423 Write_Hex_Byte ((Code / 2 ** 16) mod 256);
424 end if;
425
426 if Code > 16#FF# then
427 Write_Hex_Byte ((Code / 256) mod 256);
428 end if;
429
430 Write_Hex_Byte (Code mod 256);
431 Write_Char ('"');
432 Write_Char (']');
433 end if;
434 end Write_Char_Code;
435
436 ------------------------------
437 -- Write_String_Table_Entry --
438 ------------------------------
439
440 procedure Write_String_Table_Entry (Id : String_Id) is
441 C : Char_Code;
442
443 begin
444 if Id = No_String then
445 Write_Str ("no string");
446
447 else
448 Write_Char ('"');
449
450 for J in 1 .. String_Length (Id) loop
451 C := Get_String_Char (Id, J);
452
453 if C = Character'Pos ('"') then
454 Write_Str ("""""");
455 else
456 Write_Char_Code (C);
457 end if;
458
459 -- If string is very long, quit
460
461 if J >= 1000 then -- arbitrary limit
462 Write_Str ("""...etc (length = ");
463 Write_Int (String_Length (Id));
464 Write_Str (")");
465 return;
466 end if;
467 end loop;
468
469 Write_Char ('"');
470 end if;
471 end Write_String_Table_Entry;
472
473 end Stringt;