1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2002 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 2, 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. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING. If not, write --
19 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
20 -- MA 02111-1307, USA. --
22 -- As a special exception, if other files instantiate generics from this --
23 -- unit, or you link this unit with other files to produce an executable, --
24 -- this unit does not by itself cause the resulting executable to be --
25 -- covered by the GNU General Public License. This exception does not --
26 -- however invalidate any other reasons why the executable file might be --
27 -- covered by the GNU Public License. --
29 -- GNAT was originally developed by the GNAT team at New York University. --
30 -- Extensive contributions were provided by Ada Core Technologies Inc. --
32 ------------------------------------------------------------------------------
35 with Namet; use Namet;
36 with Output; use Output;
39 package body Stringt is
41 -- The following table stores the sequence of character codes for the
42 -- stored string constants. The entries are referenced from the
43 -- separate Strings table.
45 package String_Chars is new Table.Table (
46 Table_Component_Type => Char_Code,
47 Table_Index_Type => Int,
49 Table_Initial => Alloc.String_Chars_Initial,
50 Table_Increment => Alloc.String_Chars_Increment,
51 Table_Name => "String_Chars");
53 -- The String_Id values reference entries in the Strings table, which
54 -- contains String_Entry records that record the length of each stored
55 -- string and its starting location in the String_Chars table.
57 type String_Entry is record
62 package Strings is new Table.Table (
63 Table_Component_Type => String_Entry,
64 Table_Index_Type => String_Id,
65 Table_Low_Bound => First_String_Id,
66 Table_Initial => Alloc.Strings_Initial,
67 Table_Increment => Alloc.Strings_Increment,
68 Table_Name => "Strings");
70 -- Note: it is possible that two entries in the Strings table can share
71 -- string data in the String_Chars table, and in particular this happens
72 -- when Start_String is called with a parameter that is the last string
73 -- currently allocated in the table.
75 -------------------------------
76 -- Add_String_To_Name_Buffer --
77 -------------------------------
79 procedure Add_String_To_Name_Buffer (S : String_Id) is
80 Len : constant Natural := Natural (String_Length (S));
83 for J in 1 .. Len loop
84 Name_Buffer (Name_Len + J) :=
85 Get_Character (Get_String_Char (S, Int (J)));
88 Name_Len := Name_Len + Len;
89 end Add_String_To_Name_Buffer;
95 function End_String return String_Id is
100 ---------------------
101 -- Get_String_Char --
102 ---------------------
104 function Get_String_Char (Id : String_Id; Index : Int) return Char_Code is
106 pragma Assert (Id in First_String_Id .. Strings.Last
107 and then Index in 1 .. Strings.Table (Id).Length);
109 return String_Chars.Table (Strings.Table (Id).String_Index + Index - 1);
116 procedure Initialize is
128 String_Chars.Locked := True;
129 Strings.Locked := True;
130 String_Chars.Release;
138 -- Version to start completely new string
140 procedure Start_String is
142 Strings.Increment_Last;
143 Strings.Table (Strings.Last).String_Index := String_Chars.Last + 1;
144 Strings.Table (Strings.Last).Length := 0;
147 -- Version to start from initially stored string
149 procedure Start_String (S : String_Id) is
151 Strings.Increment_Last;
153 -- Case of initial string value is at the end of the string characters
154 -- table, so it does not need copying, instead it can be shared.
156 if Strings.Table (S).String_Index + Strings.Table (S).Length =
157 String_Chars.Last + 1
159 Strings.Table (Strings.Last).String_Index :=
160 Strings.Table (S).String_Index;
162 -- Case of initial string value must be copied to new string
165 Strings.Table (Strings.Last).String_Index :=
166 String_Chars.Last + 1;
168 for J in 1 .. Strings.Table (S).Length loop
169 String_Chars.Increment_Last;
170 String_Chars.Table (String_Chars.Last) :=
171 String_Chars.Table (Strings.Table (S).String_Index + (J - 1));
175 -- In either case the result string length is copied from the argument
177 Strings.Table (Strings.Last).Length := Strings.Table (S).Length;
180 -----------------------
181 -- Store_String_Char --
182 -----------------------
184 procedure Store_String_Char (C : Char_Code) is
186 String_Chars.Increment_Last;
187 String_Chars.Table (String_Chars.Last) := C;
188 Strings.Table (Strings.Last).Length :=
189 Strings.Table (Strings.Last).Length + 1;
190 end Store_String_Char;
192 procedure Store_String_Char (C : Character) is
194 Store_String_Char (Get_Char_Code (C));
195 end Store_String_Char;
197 ------------------------
198 -- Store_String_Chars --
199 ------------------------
201 procedure Store_String_Chars (S : String) is
203 for J in S'First .. S'Last loop
204 Store_String_Char (Get_Char_Code (S (J)));
206 end Store_String_Chars;
208 procedure Store_String_Chars (S : String_Id) is
210 for J in 1 .. String_Length (S) loop
211 Store_String_Char (Get_String_Char (S, J));
213 end Store_String_Chars;
215 ----------------------
216 -- Store_String_Int --
217 ----------------------
219 procedure Store_String_Int (N : Int) is
222 Store_String_Char ('-');
223 Store_String_Int (-N);
227 Store_String_Int (N / 10);
230 Store_String_Char (Character'Val (Character'Pos ('0') + N mod 10));
232 end Store_String_Int;
234 --------------------------
235 -- String_Chars_Address --
236 --------------------------
238 function String_Chars_Address return System.Address is
240 return String_Chars.Table (0)'Address;
241 end String_Chars_Address;
247 function String_Equal (L, R : String_Id) return Boolean is
248 Len : constant Nat := Strings.Table (L).Length;
251 if Len /= Strings.Table (R).Length then
254 for J in 1 .. Len loop
255 if Get_String_Char (L, J) /= Get_String_Char (R, J) then
264 -----------------------------
265 -- String_From_Name_Buffer --
266 -----------------------------
268 function String_From_Name_Buffer return String_Id is
272 for J in 1 .. Name_Len loop
273 Store_String_Char (Get_Char_Code (Name_Buffer (J)));
277 end String_From_Name_Buffer;
283 function String_Length (Id : String_Id) return Nat is
285 return Strings.Table (Id).Length;
288 ---------------------------
289 -- String_To_Name_Buffer --
290 ---------------------------
292 procedure String_To_Name_Buffer (S : String_Id) is
294 Name_Len := Natural (String_Length (S));
296 for J in 1 .. Name_Len loop
298 Get_Character (Get_String_Char (S, Int (J)));
300 end String_To_Name_Buffer;
302 ---------------------
303 -- Strings_Address --
304 ---------------------
306 function Strings_Address return System.Address is
308 return Strings.Table (First_String_Id)'Address;
315 procedure Tree_Read is
317 String_Chars.Tree_Read;
325 procedure Tree_Write is
327 String_Chars.Tree_Write;
337 String_Chars.Locked := False;
338 Strings.Locked := False;
341 -------------------------
342 -- Unstore_String_Char --
343 -------------------------
345 procedure Unstore_String_Char is
347 String_Chars.Decrement_Last;
348 Strings.Table (Strings.Last).Length :=
349 Strings.Table (Strings.Last).Length - 1;
350 end Unstore_String_Char;
352 ---------------------
353 -- Write_Char_Code --
354 ---------------------
356 procedure Write_Char_Code (Code : Char_Code) is
358 procedure Write_Hex_Byte (J : Natural);
359 -- Write single hex digit
365 procedure Write_Hex_Byte (J : Natural) is
366 Hexd : constant String := "0123456789abcdef";
369 Write_Char (Hexd (J / 16 + 1));
370 Write_Char (Hexd (J mod 16 + 1));
373 -- Start of processing for Write_Char_Code
376 if Code in 16#20# .. 16#7E# then
377 Write_Char (Character'Val (Code));
383 if Code > 16#FF# then
384 Write_Hex_Byte (Natural (Code / 256));
387 Write_Hex_Byte (Natural (Code mod 256));
393 ------------------------------
394 -- Write_String_Table_Entry --
395 ------------------------------
397 procedure Write_String_Table_Entry (Id : String_Id) is
401 if Id = No_String then
402 Write_Str ("no string");
407 for J in 1 .. String_Length (Id) loop
408 C := Get_String_Char (Id, J);
410 if Character'Val (C) = '"' then
420 end Write_String_Table_Entry;