Mercurial > hg > CbC > CbC_gcc

comparison gcc/ada/stringt.adb @ 111:04ced10e8804

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
gcc 7
author kono
date Fri, 27 Oct 2017 22:46:09 +0900
parents
children 84e7813d76e9
comparison
equal deleted inserted replaced
68:561a7518be6b 111:04ced10e8804
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-2017, 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 -- 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;