1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
10 -- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
12 -- GNAT is free software; you can redistribute it and/or modify it under --
13 -- terms of the GNU General Public License as published by the Free Soft- --
14 -- ware Foundation; either version 2, or (at your option) any later ver- --
15 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
16 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
17 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
18 -- for more details. You should have received a copy of the GNU General --
19 -- Public License distributed with GNAT; see file COPYING. If not, write --
20 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
21 -- MA 02111-1307, USA. --
23 -- As a special exception, if other files instantiate generics from this --
24 -- unit, or you link this unit with other files to produce an executable, --
25 -- this unit does not by itself cause the resulting executable to be --
26 -- covered by the GNU General Public License. This exception does not --
27 -- however invalidate any other reasons why the executable file might be --
28 -- covered by the GNU Public License. --
30 -- GNAT was originally developed by the GNAT team at New York University. --
31 -- Extensive contributions were provided by Ada Core Technologies Inc. --
33 ------------------------------------------------------------------------------
36 with Namet; use Namet;
37 with Output; use Output;
40 package body Stringt is
42 -- The following table stores the sequence of character codes for the
43 -- stored string constants. The entries are referenced from the
44 -- separate Strings table.
46 package String_Chars is new Table.Table (
47 Table_Component_Type => Char_Code,
48 Table_Index_Type => Int,
50 Table_Initial => Alloc.String_Chars_Initial,
51 Table_Increment => Alloc.String_Chars_Increment,
52 Table_Name => "String_Chars");
54 -- The String_Id values reference entries in the Strings table, which
55 -- contains String_Entry records that record the length of each stored
56 -- string and its starting location in the String_Chars table.
58 type String_Entry is record
63 package Strings is new Table.Table (
64 Table_Component_Type => String_Entry,
65 Table_Index_Type => String_Id,
66 Table_Low_Bound => First_String_Id,
67 Table_Initial => Alloc.Strings_Initial,
68 Table_Increment => Alloc.Strings_Increment,
69 Table_Name => "Strings");
71 -- Note: it is possible that two entries in the Strings table can share
72 -- string data in the String_Chars table, and in particular this happens
73 -- when Start_String is called with a parameter that is the last string
74 -- currently allocated in the table.
76 -------------------------------
77 -- Add_String_To_Name_Buffer --
78 -------------------------------
80 procedure Add_String_To_Name_Buffer (S : String_Id) is
81 Len : constant Natural := Natural (String_Length (S));
84 for J in 1 .. Len loop
85 Name_Buffer (Name_Len + J) :=
86 Get_Character (Get_String_Char (S, Int (J)));
89 Name_Len := Name_Len + Len;
90 end Add_String_To_Name_Buffer;
96 function End_String return String_Id is
101 ---------------------
102 -- Get_String_Char --
103 ---------------------
105 function Get_String_Char (Id : String_Id; Index : Int) return Char_Code is
107 pragma Assert (Id in First_String_Id .. Strings.Last
108 and then Index in 1 .. Strings.Table (Id).Length);
110 return String_Chars.Table (Strings.Table (Id).String_Index + Index - 1);
117 procedure Initialize is
129 String_Chars.Locked := True;
130 Strings.Locked := True;
131 String_Chars.Release;
139 -- Version to start completely new string
141 procedure Start_String is
143 Strings.Increment_Last;
144 Strings.Table (Strings.Last).String_Index := String_Chars.Last + 1;
145 Strings.Table (Strings.Last).Length := 0;
148 -- Version to start from initially stored string
150 procedure Start_String (S : String_Id) is
152 Strings.Increment_Last;
154 -- Case of initial string value is at the end of the string characters
155 -- table, so it does not need copying, instead it can be shared.
157 if Strings.Table (S).String_Index + Strings.Table (S).Length =
158 String_Chars.Last + 1
160 Strings.Table (Strings.Last).String_Index :=
161 Strings.Table (S).String_Index;
163 -- Case of initial string value must be copied to new string
166 Strings.Table (Strings.Last).String_Index :=
167 String_Chars.Last + 1;
169 for J in 1 .. Strings.Table (S).Length loop
170 String_Chars.Increment_Last;
171 String_Chars.Table (String_Chars.Last) :=
172 String_Chars.Table (Strings.Table (S).String_Index + (J - 1));
176 -- In either case the result string length is copied from the argument
178 Strings.Table (Strings.Last).Length := Strings.Table (S).Length;
181 -----------------------
182 -- Store_String_Char --
183 -----------------------
185 procedure Store_String_Char (C : Char_Code) is
187 String_Chars.Increment_Last;
188 String_Chars.Table (String_Chars.Last) := C;
189 Strings.Table (Strings.Last).Length :=
190 Strings.Table (Strings.Last).Length + 1;
191 end Store_String_Char;
193 procedure Store_String_Char (C : Character) is
195 Store_String_Char (Get_Char_Code (C));
196 end Store_String_Char;
198 ------------------------
199 -- Store_String_Chars --
200 ------------------------
202 procedure Store_String_Chars (S : String) is
204 for J in S'First .. S'Last loop
205 Store_String_Char (Get_Char_Code (S (J)));
207 end Store_String_Chars;
209 procedure Store_String_Chars (S : String_Id) is
211 for J in 1 .. String_Length (S) loop
212 Store_String_Char (Get_String_Char (S, J));
214 end Store_String_Chars;
216 ----------------------
217 -- Store_String_Int --
218 ----------------------
220 procedure Store_String_Int (N : Int) is
223 Store_String_Char ('-');
224 Store_String_Int (-N);
228 Store_String_Int (N / 10);
231 Store_String_Char (Character'Val (Character'Pos ('0') + N mod 10));
233 end Store_String_Int;
235 --------------------------
236 -- String_Chars_Address --
237 --------------------------
239 function String_Chars_Address return System.Address is
241 return String_Chars.Table (0)'Address;
242 end String_Chars_Address;
248 function String_Equal (L, R : String_Id) return Boolean is
249 Len : constant Nat := Strings.Table (L).Length;
252 if Len /= Strings.Table (R).Length then
255 for J in 1 .. Len loop
256 if Get_String_Char (L, J) /= Get_String_Char (R, J) then
265 -----------------------------
266 -- String_From_Name_Buffer --
267 -----------------------------
269 function String_From_Name_Buffer return String_Id is
273 for J in 1 .. Name_Len loop
274 Store_String_Char (Get_Char_Code (Name_Buffer (J)));
278 end String_From_Name_Buffer;
284 function String_Length (Id : String_Id) return Nat is
286 return Strings.Table (Id).Length;
289 ---------------------------
290 -- String_To_Name_Buffer --
291 ---------------------------
293 procedure String_To_Name_Buffer (S : String_Id) is
295 Name_Len := Natural (String_Length (S));
297 for J in 1 .. Name_Len loop
299 Get_Character (Get_String_Char (S, Int (J)));
301 end String_To_Name_Buffer;
303 ---------------------
304 -- Strings_Address --
305 ---------------------
307 function Strings_Address return System.Address is
309 return Strings.Table (First_String_Id)'Address;
316 procedure Tree_Read is
318 String_Chars.Tree_Read;
326 procedure Tree_Write is
328 String_Chars.Tree_Write;
338 String_Chars.Locked := False;
339 Strings.Locked := False;
342 -------------------------
343 -- Unstore_String_Char --
344 -------------------------
346 procedure Unstore_String_Char is
348 String_Chars.Decrement_Last;
349 Strings.Table (Strings.Last).Length :=
350 Strings.Table (Strings.Last).Length - 1;
351 end Unstore_String_Char;
353 ---------------------
354 -- Write_Char_Code --
355 ---------------------
357 procedure Write_Char_Code (Code : Char_Code) is
359 procedure Write_Hex_Byte (J : Natural);
360 -- Write single hex digit
362 procedure Write_Hex_Byte (J : Natural) is
363 Hexd : String := "0123456789abcdef";
366 Write_Char (Hexd (J / 16 + 1));
367 Write_Char (Hexd (J mod 16 + 1));
370 -- Start of processing for Write_Char_Code
373 if Code in 16#20# .. 16#7E# then
374 Write_Char (Character'Val (Code));
380 if Code > 16#FF# then
381 Write_Hex_Byte (Natural (Code / 256));
384 Write_Hex_Byte (Natural (Code mod 256));
390 ------------------------------
391 -- Write_String_Table_Entry --
392 ------------------------------
394 procedure Write_String_Table_Entry (Id : String_Id) is
398 if Id = No_String then
399 Write_Str ("no string");
404 for J in 1 .. String_Length (Id) loop
405 C := Get_String_Char (Id, J);
407 if Character'Val (C) = '"' then
417 end Write_String_Table_Entry;