Implement -mmemcpy-strategy= and -mmemset-strategy= options
[official-gcc.git] / gcc / ada / stringt.adb
blobc0ec2f10fdf9253523a95923f2b45e3108042550
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-2012, 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 ------------------------------------------------------------------------------
32 with Alloc;
33 with Namet; use Namet;
34 with Output; use Output;
35 with Table;
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,
46 Table_Low_Bound => 0,
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
56 String_Index : Int;
57 Length : Nat;
58 end 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));
86 begin
87 for J in 1 .. Len loop
88 Name_Buffer (Name_Len + J) :=
89 Get_Character (Get_String_Char (S, Int (J)));
90 end loop;
92 Name_Len := Name_Len + Len;
93 end Add_String_To_Name_Buffer;
95 ----------------
96 -- End_String --
97 ----------------
99 function End_String return String_Id is
100 begin
101 return Strings.Last;
102 end End_String;
104 ---------------------
105 -- Get_String_Char --
106 ---------------------
108 function Get_String_Char (Id : String_Id; Index : Int) return Char_Code is
109 begin
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);
114 end Get_String_Char;
116 ----------------
117 -- Initialize --
118 ----------------
120 procedure Initialize is
121 begin
122 String_Chars.Init;
123 Strings.Init;
124 end Initialize;
126 ----------
127 -- Lock --
128 ----------
130 procedure Lock is
131 begin
132 String_Chars.Locked := True;
133 Strings.Locked := True;
134 String_Chars.Release;
135 Strings.Release;
136 end Lock;
138 ----------
139 -- Mark --
140 ----------
142 procedure Mark is
143 begin
144 Strings_Last := Strings.Last;
145 String_Chars_Last := String_Chars.Last;
146 end Mark;
148 -------------
149 -- Release --
150 -------------
152 procedure Release is
153 begin
154 Strings.Set_Last (Strings_Last);
155 String_Chars.Set_Last (String_Chars_Last);
156 end Release;
158 ------------------
159 -- Start_String --
160 ------------------
162 -- Version to start completely new string
164 procedure Start_String is
165 begin
166 Strings.Append ((String_Index => String_Chars.Last + 1, Length => 0));
167 end Start_String;
169 -- Version to start from initially stored string
171 procedure Start_String (S : String_Id) is
172 begin
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
180 then
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
186 else
187 Strings.Table (Strings.Last).String_Index :=
188 String_Chars.Last + 1;
190 for J in 1 .. Strings.Table (S).Length loop
191 String_Chars.Append
192 (String_Chars.Table (Strings.Table (S).String_Index + (J - 1)));
193 end loop;
194 end if;
196 -- In either case the result string length is copied from the argument
198 Strings.Table (Strings.Last).Length := Strings.Table (S).Length;
199 end Start_String;
201 -----------------------
202 -- Store_String_Char --
203 -----------------------
205 procedure Store_String_Char (C : Char_Code) is
206 begin
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
213 begin
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
222 begin
223 for J in S'First .. S'Last loop
224 Store_String_Char (Get_Char_Code (S (J)));
225 end loop;
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));
234 -- end loop;
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;
244 begin
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
257 begin
258 if N < 0 then
259 Store_String_Char ('-');
260 Store_String_Int (-N);
262 else
263 if N > 9 then
264 Store_String_Int (N / 10);
265 end if;
267 Store_String_Char (Character'Val (Character'Pos ('0') + N mod 10));
268 end if;
269 end Store_String_Int;
271 --------------------------
272 -- String_Chars_Address --
273 --------------------------
275 function String_Chars_Address return System.Address is
276 begin
277 return String_Chars.Table (0)'Address;
278 end String_Chars_Address;
280 ------------------
281 -- String_Equal --
282 ------------------
284 function String_Equal (L, R : String_Id) return Boolean is
285 Len : constant Nat := Strings.Table (L).Length;
287 begin
288 if Len /= Strings.Table (R).Length then
289 return False;
290 else
291 for J in 1 .. Len loop
292 if Get_String_Char (L, J) /= Get_String_Char (R, J) then
293 return False;
294 end if;
295 end loop;
297 return True;
298 end if;
299 end String_Equal;
301 -----------------------------
302 -- String_From_Name_Buffer --
303 -----------------------------
305 function String_From_Name_Buffer return String_Id is
306 begin
307 Start_String;
309 for J in 1 .. Name_Len loop
310 Store_String_Char (Get_Char_Code (Name_Buffer (J)));
311 end loop;
313 return End_String;
314 end String_From_Name_Buffer;
316 -------------------
317 -- String_Length --
318 -------------------
320 function String_Length (Id : String_Id) return Nat is
321 begin
322 return Strings.Table (Id).Length;
323 end String_Length;
325 ---------------------------
326 -- String_To_Name_Buffer --
327 ---------------------------
329 procedure String_To_Name_Buffer (S : String_Id) is
330 begin
331 Name_Len := Natural (String_Length (S));
333 for J in 1 .. Name_Len loop
334 Name_Buffer (J) :=
335 Get_Character (Get_String_Char (S, Int (J)));
336 end loop;
337 end String_To_Name_Buffer;
339 ---------------------
340 -- Strings_Address --
341 ---------------------
343 function Strings_Address return System.Address is
344 begin
345 return Strings.Table (First_String_Id)'Address;
346 end Strings_Address;
348 ---------------
349 -- Tree_Read --
350 ---------------
352 procedure Tree_Read is
353 begin
354 String_Chars.Tree_Read;
355 Strings.Tree_Read;
356 end Tree_Read;
358 ----------------
359 -- Tree_Write --
360 ----------------
362 procedure Tree_Write is
363 begin
364 String_Chars.Tree_Write;
365 Strings.Tree_Write;
366 end Tree_Write;
368 ------------
369 -- Unlock --
370 ------------
372 procedure Unlock is
373 begin
374 String_Chars.Locked := False;
375 Strings.Locked := False;
376 end Unlock;
378 -------------------------
379 -- Unstore_String_Char --
380 -------------------------
382 procedure Unstore_String_Char is
383 begin
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
398 --------------------
399 -- Write_Hex_Byte --
400 --------------------
402 procedure Write_Hex_Byte (J : Char_Code) is
403 Hexd : constant array (Char_Code range 0 .. 15) of Character :=
404 "0123456789abcdef";
405 begin
406 Write_Char (Hexd (J / 16));
407 Write_Char (Hexd (J mod 16));
408 end Write_Hex_Byte;
410 -- Start of processing for Write_Char_Code
412 begin
413 if Code in 16#20# .. 16#7E# then
414 Write_Char (Character'Val (Code));
416 else
417 Write_Char ('[');
418 Write_Char ('"');
420 if Code > 16#FF_FFFF# then
421 Write_Hex_Byte (Code / 2 ** 24);
422 end if;
424 if Code > 16#FFFF# then
425 Write_Hex_Byte ((Code / 2 ** 16) mod 256);
426 end if;
428 if Code > 16#FF# then
429 Write_Hex_Byte ((Code / 256) mod 256);
430 end if;
432 Write_Hex_Byte (Code mod 256);
433 Write_Char ('"');
434 Write_Char (']');
435 end if;
436 end Write_Char_Code;
438 ------------------------------
439 -- Write_String_Table_Entry --
440 ------------------------------
442 procedure Write_String_Table_Entry (Id : String_Id) is
443 C : Char_Code;
445 begin
446 if Id = No_String then
447 Write_Str ("no string");
449 else
450 Write_Char ('"');
452 for J in 1 .. String_Length (Id) loop
453 C := Get_String_Char (Id, J);
455 if C = Character'Pos ('"') then
456 Write_Str ("""""");
457 else
458 Write_Char_Code (C);
459 end if;
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));
466 Write_Str (")");
467 return;
468 end if;
469 end loop;
471 Write_Char ('"');
472 end if;
473 end Write_String_Table_Entry;
475 end Stringt;