1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2009, Free Software Foundation, Inc. --
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. --
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. --
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/>. --
27 -- GNAT was originally developed by the GNAT team at New York University. --
28 -- Extensive contributions were provided by Ada Core Technologies Inc. --
30 ------------------------------------------------------------------------------
33 with Namet; use Namet;
34 with Output; use Output;
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,
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
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 -------------------------------
74 -- Add_String_To_Name_Buffer --
75 -------------------------------
77 procedure Add_String_To_Name_Buffer (S : String_Id) is
78 Len : constant Natural := Natural (String_Length (S));
81 for J in 1 .. Len loop
82 Name_Buffer (Name_Len + J) :=
83 Get_Character (Get_String_Char (S, Int (J)));
86 Name_Len := Name_Len + Len;
87 end Add_String_To_Name_Buffer;
93 function End_String return String_Id is
100 ---------------------
102 function Get_String_Char (Id : String_Id; Index : Int) return Char_Code is
104 pragma Assert (Id in First_String_Id .. Strings.Last
105 and then Index in 1 .. Strings.Table (Id).Length);
107 return String_Chars.Table (Strings.Table (Id).String_Index + Index - 1);
114 procedure Initialize is
126 String_Chars.Locked := True;
127 Strings.Locked := True;
128 String_Chars.Release;
136 -- Version to start completely new string
138 procedure Start_String is
140 Strings.Append ((String_Index => String_Chars.Last + 1, Length => 0));
143 -- Version to start from initially stored string
145 procedure Start_String (S : String_Id) is
147 Strings.Increment_Last;
149 -- Case of initial string value is at the end of the string characters
150 -- table, so it does not need copying, instead it can be shared.
152 if Strings.Table (S).String_Index + Strings.Table (S).Length =
153 String_Chars.Last + 1
155 Strings.Table (Strings.Last).String_Index :=
156 Strings.Table (S).String_Index;
158 -- Case of initial string value must be copied to new string
161 Strings.Table (Strings.Last).String_Index :=
162 String_Chars.Last + 1;
164 for J in 1 .. Strings.Table (S).Length loop
166 (String_Chars.Table (Strings.Table (S).String_Index + (J - 1)));
170 -- In either case the result string length is copied from the argument
172 Strings.Table (Strings.Last).Length := Strings.Table (S).Length;
175 -----------------------
176 -- Store_String_Char --
177 -----------------------
179 procedure Store_String_Char (C : Char_Code) is
181 String_Chars.Append (C);
182 Strings.Table (Strings.Last).Length :=
183 Strings.Table (Strings.Last).Length + 1;
184 end Store_String_Char;
186 procedure Store_String_Char (C : Character) is
188 Store_String_Char (Get_Char_Code (C));
189 end Store_String_Char;
191 ------------------------
192 -- Store_String_Chars --
193 ------------------------
195 procedure Store_String_Chars (S : String) is
197 for J in S'First .. S'Last loop
198 Store_String_Char (Get_Char_Code (S (J)));
200 end Store_String_Chars;
202 procedure Store_String_Chars (S : String_Id) is
204 -- We are essentially doing this:
206 -- for J in 1 .. String_Length (S) loop
207 -- Store_String_Char (Get_String_Char (S, J));
210 -- but when the string is long it's more efficient to grow the
211 -- String_Chars table all at once.
213 S_First : constant Int := Strings.Table (S).String_Index;
214 S_Len : constant Int := String_Length (S);
215 Old_Last : constant Int := String_Chars.Last;
216 New_Last : constant Int := Old_Last + S_Len;
219 String_Chars.Set_Last (New_Last);
220 String_Chars.Table (Old_Last + 1 .. New_Last) :=
221 String_Chars.Table (S_First .. S_First + S_Len - 1);
222 Strings.Table (Strings.Last).Length :=
223 Strings.Table (Strings.Last).Length + S_Len;
224 end Store_String_Chars;
226 ----------------------
227 -- Store_String_Int --
228 ----------------------
230 procedure Store_String_Int (N : Int) is
233 Store_String_Char ('-');
234 Store_String_Int (-N);
238 Store_String_Int (N / 10);
241 Store_String_Char (Character'Val (Character'Pos ('0') + N mod 10));
243 end Store_String_Int;
245 --------------------------
246 -- String_Chars_Address --
247 --------------------------
249 function String_Chars_Address return System.Address is
251 return String_Chars.Table (0)'Address;
252 end String_Chars_Address;
258 function String_Equal (L, R : String_Id) return Boolean is
259 Len : constant Nat := Strings.Table (L).Length;
262 if Len /= Strings.Table (R).Length then
265 for J in 1 .. Len loop
266 if Get_String_Char (L, J) /= Get_String_Char (R, J) then
275 -----------------------------
276 -- String_From_Name_Buffer --
277 -----------------------------
279 function String_From_Name_Buffer return String_Id is
283 for J in 1 .. Name_Len loop
284 Store_String_Char (Get_Char_Code (Name_Buffer (J)));
288 end String_From_Name_Buffer;
294 function String_Length (Id : String_Id) return Nat is
296 return Strings.Table (Id).Length;
299 ---------------------------
300 -- String_To_Name_Buffer --
301 ---------------------------
303 procedure String_To_Name_Buffer (S : String_Id) is
305 Name_Len := Natural (String_Length (S));
307 for J in 1 .. Name_Len loop
309 Get_Character (Get_String_Char (S, Int (J)));
311 end String_To_Name_Buffer;
313 ---------------------
314 -- Strings_Address --
315 ---------------------
317 function Strings_Address return System.Address is
319 return Strings.Table (First_String_Id)'Address;
326 procedure Tree_Read is
328 String_Chars.Tree_Read;
336 procedure Tree_Write is
338 String_Chars.Tree_Write;
348 String_Chars.Locked := False;
349 Strings.Locked := False;
352 -------------------------
353 -- Unstore_String_Char --
354 -------------------------
356 procedure Unstore_String_Char is
358 String_Chars.Decrement_Last;
359 Strings.Table (Strings.Last).Length :=
360 Strings.Table (Strings.Last).Length - 1;
361 end Unstore_String_Char;
363 ---------------------
364 -- Write_Char_Code --
365 ---------------------
367 procedure Write_Char_Code (Code : Char_Code) is
369 procedure Write_Hex_Byte (J : Char_Code);
370 -- Write single hex byte (value in range 0 .. 255) as two digits
376 procedure Write_Hex_Byte (J : Char_Code) is
377 Hexd : constant array (Char_Code range 0 .. 15) of Character :=
380 Write_Char (Hexd (J / 16));
381 Write_Char (Hexd (J mod 16));
384 -- Start of processing for Write_Char_Code
387 if Code in 16#20# .. 16#7E# then
388 Write_Char (Character'Val (Code));
394 if Code > 16#FF_FFFF# then
395 Write_Hex_Byte (Code / 2 ** 24);
398 if Code > 16#FFFF# then
399 Write_Hex_Byte ((Code / 2 ** 16) mod 256);
402 if Code > 16#FF# then
403 Write_Hex_Byte ((Code / 256) mod 256);
406 Write_Hex_Byte (Code mod 256);
412 ------------------------------
413 -- Write_String_Table_Entry --
414 ------------------------------
416 procedure Write_String_Table_Entry (Id : String_Id) is
420 if Id = No_String then
421 Write_Str ("no string");
426 for J in 1 .. String_Length (Id) loop
427 C := Get_String_Char (Id, J);
429 if C = Character'Pos ('"') then
435 -- If string is very long, quit
437 if J >= 1000 then -- arbitrary limit
438 Write_Str ("""...etc (length = ");
439 Write_Int (String_Length (Id));
447 end Write_String_Table_Entry;