|
111
|
1 ------------------------------------------------------------------------------
|
|
|
2 -- --
|
|
|
3 -- GNAT COMPILER COMPONENTS --
|
|
|
4 -- --
|
|
|
5 -- S T R I N G T --
|
|
|
6 -- --
|
|
|
7 -- B o d y --
|
|
|
8 -- --
|
|
131
|
9 -- Copyright (C) 1992-2018, Free Software Foundation, Inc. --
|
|
111
|
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 -- 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. --
|
|
|
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 -- Append --
|
|
|
80 ------------
|
|
|
81
|
|
|
82 procedure Append (Buf : in out Bounded_String; S : String_Id) is
|
|
|
83 begin
|
|
|
84 for X in 1 .. String_Length (S) loop
|
|
|
85 Append (Buf, Get_Character (Get_String_Char (S, X)));
|
|
|
86 end loop;
|
|
|
87 end Append;
|
|
|
88
|
|
|
89 ----------------
|
|
|
90 -- End_String --
|
|
|
91 ----------------
|
|
|
92
|
|
|
93 function End_String return String_Id is
|
|
|
94 begin
|
|
|
95 return Strings.Last;
|
|
|
96 end End_String;
|
|
|
97
|
|
|
98 ---------------------
|
|
|
99 -- Get_String_Char --
|
|
|
100 ---------------------
|
|
|
101
|
|
|
102 function Get_String_Char (Id : String_Id; Index : Int) return Char_Code is
|
|
|
103 begin
|
|
|
104 pragma Assert (Id in First_String_Id .. Strings.Last
|
|
|
105 and then Index in 1 .. Strings.Table (Id).Length);
|
|
|
106
|
|
|
107 return String_Chars.Table (Strings.Table (Id).String_Index + Index - 1);
|
|
|
108 end Get_String_Char;
|
|
|
109
|
|
|
110 ----------------
|
|
|
111 -- Initialize --
|
|
|
112 ----------------
|
|
|
113
|
|
|
114 procedure Initialize is
|
|
|
115 begin
|
|
|
116 String_Chars.Init;
|
|
|
117 Strings.Init;
|
|
|
118
|
|
|
119 -- Set up the null string
|
|
|
120
|
|
|
121 Start_String;
|
|
|
122 Null_String_Id := End_String;
|
|
|
123 end Initialize;
|
|
|
124
|
|
|
125 ----------
|
|
|
126 -- Lock --
|
|
|
127 ----------
|
|
|
128
|
|
|
129 procedure Lock is
|
|
|
130 begin
|
|
|
131 String_Chars.Release;
|
|
|
132 String_Chars.Locked := True;
|
|
|
133 Strings.Release;
|
|
|
134 Strings.Locked := True;
|
|
|
135 end Lock;
|
|
|
136
|
|
|
137 ----------
|
|
|
138 -- Mark --
|
|
|
139 ----------
|
|
|
140
|
|
|
141 procedure Mark is
|
|
|
142 begin
|
|
|
143 Strings_Last := Strings.Last;
|
|
|
144 String_Chars_Last := String_Chars.Last;
|
|
|
145 end Mark;
|
|
|
146
|
|
|
147 -------------
|
|
|
148 -- Release --
|
|
|
149 -------------
|
|
|
150
|
|
|
151 procedure Release is
|
|
|
152 begin
|
|
|
153 Strings.Set_Last (Strings_Last);
|
|
|
154 String_Chars.Set_Last (String_Chars_Last);
|
|
|
155 end Release;
|
|
|
156
|
|
|
157 ------------------
|
|
|
158 -- Start_String --
|
|
|
159 ------------------
|
|
|
160
|
|
|
161 -- Version to start completely new string
|
|
|
162
|
|
|
163 procedure Start_String is
|
|
|
164 begin
|
|
|
165 Strings.Append ((String_Index => String_Chars.Last + 1, Length => 0));
|
|
|
166 end Start_String;
|
|
|
167
|
|
|
168 -- Version to start from initially stored string
|
|
|
169
|
|
|
170 procedure Start_String (S : String_Id) is
|
|
|
171 begin
|
|
|
172 Strings.Increment_Last;
|
|
|
173
|
|
|
174 -- Case of initial string value is at the end of the string characters
|
|
|
175 -- table, so it does not need copying, instead it can be shared.
|
|
|
176
|
|
|
177 if Strings.Table (S).String_Index + Strings.Table (S).Length =
|
|
|
178 String_Chars.Last + 1
|
|
|
179 then
|
|
|
180 Strings.Table (Strings.Last).String_Index :=
|
|
|
181 Strings.Table (S).String_Index;
|
|
|
182
|
|
|
183 -- Case of initial string value must be copied to new string
|
|
|
184
|
|
|
185 else
|
|
|
186 Strings.Table (Strings.Last).String_Index :=
|
|
|
187 String_Chars.Last + 1;
|
|
|
188
|
|
|
189 for J in 1 .. Strings.Table (S).Length loop
|
|
|
190 String_Chars.Append
|
|
|
191 (String_Chars.Table (Strings.Table (S).String_Index + (J - 1)));
|
|
|
192 end loop;
|
|
|
193 end if;
|
|
|
194
|
|
|
195 -- In either case the result string length is copied from the argument
|
|
|
196
|
|
|
197 Strings.Table (Strings.Last).Length := Strings.Table (S).Length;
|
|
|
198 end Start_String;
|
|
|
199
|
|
|
200 -----------------------
|
|
|
201 -- Store_String_Char --
|
|
|
202 -----------------------
|
|
|
203
|
|
|
204 procedure Store_String_Char (C : Char_Code) is
|
|
|
205 begin
|
|
|
206 String_Chars.Append (C);
|
|
|
207 Strings.Table (Strings.Last).Length :=
|
|
|
208 Strings.Table (Strings.Last).Length + 1;
|
|
|
209 end Store_String_Char;
|
|
|
210
|
|
|
211 procedure Store_String_Char (C : Character) is
|
|
|
212 begin
|
|
|
213 Store_String_Char (Get_Char_Code (C));
|
|
|
214 end Store_String_Char;
|
|
|
215
|
|
|
216 ------------------------
|
|
|
217 -- Store_String_Chars --
|
|
|
218 ------------------------
|
|
|
219
|
|
|
220 procedure Store_String_Chars (S : String) is
|
|
|
221 begin
|
|
|
222 for J in S'First .. S'Last loop
|
|
|
223 Store_String_Char (Get_Char_Code (S (J)));
|
|
|
224 end loop;
|
|
|
225 end Store_String_Chars;
|
|
|
226
|
|
|
227 procedure Store_String_Chars (S : String_Id) is
|
|
|
228
|
|
|
229 -- We are essentially doing this:
|
|
|
230
|
|
|
231 -- for J in 1 .. String_Length (S) loop
|
|
|
232 -- Store_String_Char (Get_String_Char (S, J));
|
|
|
233 -- end loop;
|
|
|
234
|
|
|
235 -- but when the string is long it's more efficient to grow the
|
|
|
236 -- String_Chars table all at once.
|
|
|
237
|
|
|
238 S_First : constant Int := Strings.Table (S).String_Index;
|
|
|
239 S_Len : constant Nat := String_Length (S);
|
|
|
240 Old_Last : constant Int := String_Chars.Last;
|
|
|
241 New_Last : constant Int := Old_Last + S_Len;
|
|
|
242
|
|
|
243 begin
|
|
|
244 String_Chars.Set_Last (New_Last);
|
|
|
245 String_Chars.Table (Old_Last + 1 .. New_Last) :=
|
|
|
246 String_Chars.Table (S_First .. S_First + S_Len - 1);
|
|
|
247 Strings.Table (Strings.Last).Length :=
|
|
|
248 Strings.Table (Strings.Last).Length + S_Len;
|
|
|
249 end Store_String_Chars;
|
|
|
250
|
|
|
251 ----------------------
|
|
|
252 -- Store_String_Int --
|
|
|
253 ----------------------
|
|
|
254
|
|
|
255 procedure Store_String_Int (N : Int) is
|
|
|
256 begin
|
|
|
257 if N < 0 then
|
|
|
258 Store_String_Char ('-');
|
|
|
259 Store_String_Int (-N);
|
|
|
260
|
|
|
261 else
|
|
|
262 if N > 9 then
|
|
|
263 Store_String_Int (N / 10);
|
|
|
264 end if;
|
|
|
265
|
|
|
266 Store_String_Char (Character'Val (Character'Pos ('0') + N mod 10));
|
|
|
267 end if;
|
|
|
268 end Store_String_Int;
|
|
|
269
|
|
|
270 --------------------------
|
|
|
271 -- String_Chars_Address --
|
|
|
272 --------------------------
|
|
|
273
|
|
|
274 function String_Chars_Address return System.Address is
|
|
|
275 begin
|
|
|
276 return String_Chars.Table (0)'Address;
|
|
|
277 end String_Chars_Address;
|
|
|
278
|
|
|
279 ------------------
|
|
|
280 -- String_Equal --
|
|
|
281 ------------------
|
|
|
282
|
|
|
283 function String_Equal (L, R : String_Id) return Boolean is
|
|
|
284 Len : constant Nat := Strings.Table (L).Length;
|
|
|
285
|
|
|
286 begin
|
|
|
287 if Len /= Strings.Table (R).Length then
|
|
|
288 return False;
|
|
|
289 else
|
|
|
290 for J in 1 .. Len loop
|
|
|
291 if Get_String_Char (L, J) /= Get_String_Char (R, J) then
|
|
|
292 return False;
|
|
|
293 end if;
|
|
|
294 end loop;
|
|
|
295
|
|
|
296 return True;
|
|
|
297 end if;
|
|
|
298 end String_Equal;
|
|
|
299
|
|
|
300 -----------------------------
|
|
|
301 -- String_From_Name_Buffer --
|
|
|
302 -----------------------------
|
|
|
303
|
|
|
304 function String_From_Name_Buffer
|
|
|
305 (Buf : Bounded_String := Global_Name_Buffer) return String_Id
|
|
|
306 is
|
|
|
307 begin
|
|
|
308 Start_String;
|
|
|
309 Store_String_Chars (+Buf);
|
|
|
310 return End_String;
|
|
|
311 end String_From_Name_Buffer;
|
|
|
312
|
|
|
313 -------------------
|
|
|
314 -- String_Length --
|
|
|
315 -------------------
|
|
|
316
|
|
|
317 function String_Length (Id : String_Id) return Nat is
|
|
|
318 begin
|
|
|
319 return Strings.Table (Id).Length;
|
|
|
320 end String_Length;
|
|
|
321
|
|
|
322 --------------------
|
|
|
323 -- String_To_Name --
|
|
|
324 --------------------
|
|
|
325
|
|
|
326 function String_To_Name (S : String_Id) return Name_Id is
|
|
|
327 Buf : Bounded_String;
|
|
|
328 begin
|
|
|
329 Append (Buf, S);
|
|
|
330 return Name_Find (Buf);
|
|
|
331 end String_To_Name;
|
|
|
332
|
|
|
333 ---------------------------
|
|
|
334 -- String_To_Name_Buffer --
|
|
|
335 ---------------------------
|
|
|
336
|
|
|
337 procedure String_To_Name_Buffer (S : String_Id) is
|
|
|
338 begin
|
|
|
339 Name_Len := 0;
|
|
|
340 Append (Global_Name_Buffer, S);
|
|
|
341 end String_To_Name_Buffer;
|
|
|
342
|
|
|
343 ---------------------
|
|
|
344 -- Strings_Address --
|
|
|
345 ---------------------
|
|
|
346
|
|
|
347 function Strings_Address return System.Address is
|
|
|
348 begin
|
|
|
349 return Strings.Table (First_String_Id)'Address;
|
|
|
350 end Strings_Address;
|
|
|
351
|
|
|
352 ---------------
|
|
|
353 -- Tree_Read --
|
|
|
354 ---------------
|
|
|
355
|
|
|
356 procedure Tree_Read is
|
|
|
357 begin
|
|
|
358 String_Chars.Tree_Read;
|
|
|
359 Strings.Tree_Read;
|
|
|
360 end Tree_Read;
|
|
|
361
|
|
|
362 ----------------
|
|
|
363 -- Tree_Write --
|
|
|
364 ----------------
|
|
|
365
|
|
|
366 procedure Tree_Write is
|
|
|
367 begin
|
|
|
368 String_Chars.Tree_Write;
|
|
|
369 Strings.Tree_Write;
|
|
|
370 end Tree_Write;
|
|
|
371
|
|
|
372 ------------
|
|
|
373 -- Unlock --
|
|
|
374 ------------
|
|
|
375
|
|
|
376 procedure Unlock is
|
|
|
377 begin
|
|
|
378 String_Chars.Locked := False;
|
|
|
379 Strings.Locked := False;
|
|
|
380 end Unlock;
|
|
|
381
|
|
|
382 -------------------------
|
|
|
383 -- Unstore_String_Char --
|
|
|
384 -------------------------
|
|
|
385
|
|
|
386 procedure Unstore_String_Char is
|
|
|
387 begin
|
|
|
388 String_Chars.Decrement_Last;
|
|
|
389 Strings.Table (Strings.Last).Length :=
|
|
|
390 Strings.Table (Strings.Last).Length - 1;
|
|
|
391 end Unstore_String_Char;
|
|
|
392
|
|
|
393 ---------------------
|
|
|
394 -- Write_Char_Code --
|
|
|
395 ---------------------
|
|
|
396
|
|
|
397 procedure Write_Char_Code (Code : Char_Code) is
|
|
|
398
|
|
|
399 procedure Write_Hex_Byte (J : Char_Code);
|
|
|
400 -- Write single hex byte (value in range 0 .. 255) as two digits
|
|
|
401
|
|
|
402 --------------------
|
|
|
403 -- Write_Hex_Byte --
|
|
|
404 --------------------
|
|
|
405
|
|
|
406 procedure Write_Hex_Byte (J : Char_Code) is
|
|
|
407 Hexd : constant array (Char_Code range 0 .. 15) of Character :=
|
|
|
408 "0123456789abcdef";
|
|
|
409 begin
|
|
|
410 Write_Char (Hexd (J / 16));
|
|
|
411 Write_Char (Hexd (J mod 16));
|
|
|
412 end Write_Hex_Byte;
|
|
|
413
|
|
|
414 -- Start of processing for Write_Char_Code
|
|
|
415
|
|
|
416 begin
|
|
|
417 if Code in 16#20# .. 16#7E# then
|
|
|
418 Write_Char (Character'Val (Code));
|
|
|
419
|
|
|
420 else
|
|
|
421 Write_Char ('[');
|
|
|
422 Write_Char ('"');
|
|
|
423
|
|
|
424 if Code > 16#FF_FFFF# then
|
|
|
425 Write_Hex_Byte (Code / 2 ** 24);
|
|
|
426 end if;
|
|
|
427
|
|
|
428 if Code > 16#FFFF# then
|
|
|
429 Write_Hex_Byte ((Code / 2 ** 16) mod 256);
|
|
|
430 end if;
|
|
|
431
|
|
|
432 if Code > 16#FF# then
|
|
|
433 Write_Hex_Byte ((Code / 256) mod 256);
|
|
|
434 end if;
|
|
|
435
|
|
|
436 Write_Hex_Byte (Code mod 256);
|
|
|
437 Write_Char ('"');
|
|
|
438 Write_Char (']');
|
|
|
439 end if;
|
|
|
440 end Write_Char_Code;
|
|
|
441
|
|
|
442 ------------------------------
|
|
|
443 -- Write_String_Table_Entry --
|
|
|
444 ------------------------------
|
|
|
445
|
|
|
446 procedure Write_String_Table_Entry (Id : String_Id) is
|
|
|
447 C : Char_Code;
|
|
|
448
|
|
|
449 begin
|
|
|
450 if Id = No_String then
|
|
|
451 Write_Str ("no string");
|
|
|
452
|
|
|
453 else
|
|
|
454 Write_Char ('"');
|
|
|
455
|
|
|
456 for J in 1 .. String_Length (Id) loop
|
|
|
457 C := Get_String_Char (Id, J);
|
|
|
458
|
|
|
459 if C = Character'Pos ('"') then
|
|
|
460 Write_Str ("""""");
|
|
|
461 else
|
|
|
462 Write_Char_Code (C);
|
|
|
463 end if;
|
|
|
464
|
|
|
465 -- If string is very long, quit
|
|
|
466
|
|
|
467 if J >= 1000 then -- arbitrary limit
|
|
|
468 Write_Str ("""...etc (length = ");
|
|
|
469 Write_Int (String_Length (Id));
|
|
|
470 Write_Str (")");
|
|
|
471 return;
|
|
|
472 end if;
|
|
|
473 end loop;
|
|
|
474
|
|
|
475 Write_Char ('"');
|
|
|
476 end if;
|
|
|
477 end Write_String_Table_Entry;
|
|
|
478
|
|
|
479 end Stringt;
|
