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------------------------------------------------------------------------------ 31 32with Alloc; 33with Namet; use Namet; 34with Output; use Output; 35with Table; 36 37package body Stringt is 38 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. 42 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"); 50 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. 54 55 type String_Entry is record 56 String_Index : Int; 57 Length : Nat; 58 end record; 59 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"); 67 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. 72 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. 78 79 ------------------------------- 80 -- Add_String_To_Name_Buffer -- 81 ------------------------------- 82 83 procedure Add_String_To_Name_Buffer (S : String_Id) is 84 Len : constant Natural := Natural (String_Length (S)); 85 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; 91 92 Name_Len := Name_Len + Len; 93 end Add_String_To_Name_Buffer; 94 95 ---------------- 96 -- End_String -- 97 ---------------- 98 99 function End_String return String_Id is 100 begin 101 return Strings.Last; 102 end End_String; 103 104 --------------------- 105 -- Get_String_Char -- 106 --------------------- 107 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); 112 113 return String_Chars.Table (Strings.Table (Id).String_Index + Index - 1); 114 end Get_String_Char; 115 116 ---------------- 117 -- Initialize -- 118 ---------------- 119 120 procedure Initialize is 121 begin 122 String_Chars.Init; 123 Strings.Init; 124 end Initialize; 125 126 ---------- 127 -- Lock -- 128 ---------- 129 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; 137 138 ---------- 139 -- Mark -- 140 ---------- 141 142 procedure Mark is 143 begin 144 Strings_Last := Strings.Last; 145 String_Chars_Last := String_Chars.Last; 146 end Mark; 147 148 ------------- 149 -- Release -- 150 ------------- 151 152 procedure Release is 153 begin 154 Strings.Set_Last (Strings_Last); 155 String_Chars.Set_Last (String_Chars_Last); 156 end Release; 157 158 ------------------ 159 -- Start_String -- 160 ------------------ 161 162 -- Version to start completely new string 163 164 procedure Start_String is 165 begin 166 Strings.Append ((String_Index => String_Chars.Last + 1, Length => 0)); 167 end Start_String; 168 169 -- Version to start from initially stored string 170 171 procedure Start_String (S : String_Id) is 172 begin 173 Strings.Increment_Last; 174 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. 177 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; 183 184 -- Case of initial string value must be copied to new string 185 186 else 187 Strings.Table (Strings.Last).String_Index := 188 String_Chars.Last + 1; 189 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; 195 196 -- In either case the result string length is copied from the argument 197 198 Strings.Table (Strings.Last).Length := Strings.Table (S).Length; 199 end Start_String; 200 201 ----------------------- 202 -- Store_String_Char -- 203 ----------------------- 204 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; 211 212 procedure Store_String_Char (C : Character) is 213 begin 214 Store_String_Char (Get_Char_Code (C)); 215 end Store_String_Char; 216 217 ------------------------ 218 -- Store_String_Chars -- 219 ------------------------ 220 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; 227 228 procedure Store_String_Chars (S : String_Id) is 229 230 -- We are essentially doing this: 231 232 -- for J in 1 .. String_Length (S) loop 233 -- Store_String_Char (Get_String_Char (S, J)); 234 -- end loop; 235 236 -- but when the string is long it's more efficient to grow the 237 -- String_Chars table all at once. 238 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; 243 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; 251 252 ---------------------- 253 -- Store_String_Int -- 254 ---------------------- 255 256 procedure Store_String_Int (N : Int) is 257 begin 258 if N < 0 then 259 Store_String_Char ('-'); 260 Store_String_Int (-N); 261 262 else 263 if N > 9 then 264 Store_String_Int (N / 10); 265 end if; 266 267 Store_String_Char (Character'Val (Character'Pos ('0') + N mod 10)); 268 end if; 269 end Store_String_Int; 270 271 -------------------------- 272 -- String_Chars_Address -- 273 -------------------------- 274 275 function String_Chars_Address return System.Address is 276 begin 277 return String_Chars.Table (0)'Address; 278 end String_Chars_Address; 279 280 ------------------ 281 -- String_Equal -- 282 ------------------ 283 284 function String_Equal (L, R : String_Id) return Boolean is 285 Len : constant Nat := Strings.Table (L).Length; 286 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; 296 297 return True; 298 end if; 299 end String_Equal; 300 301 ----------------------------- 302 -- String_From_Name_Buffer -- 303 ----------------------------- 304 305 function String_From_Name_Buffer return String_Id is 306 begin 307 Start_String; 308 309 for J in 1 .. Name_Len loop 310 Store_String_Char (Get_Char_Code (Name_Buffer (J))); 311 end loop; 312 313 return End_String; 314 end String_From_Name_Buffer; 315 316 ------------------- 317 -- String_Length -- 318 ------------------- 319 320 function String_Length (Id : String_Id) return Nat is 321 begin 322 return Strings.Table (Id).Length; 323 end String_Length; 324 325 --------------------------- 326 -- String_To_Name_Buffer -- 327 --------------------------- 328 329 procedure String_To_Name_Buffer (S : String_Id) is 330 begin 331 Name_Len := Natural (String_Length (S)); 332 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; 338 339 --------------------- 340 -- Strings_Address -- 341 --------------------- 342 343 function Strings_Address return System.Address is 344 begin 345 return Strings.Table (First_String_Id)'Address; 346 end Strings_Address; 347 348 --------------- 349 -- Tree_Read -- 350 --------------- 351 352 procedure Tree_Read is 353 begin 354 String_Chars.Tree_Read; 355 Strings.Tree_Read; 356 end Tree_Read; 357 358 ---------------- 359 -- Tree_Write -- 360 ---------------- 361 362 procedure Tree_Write is 363 begin 364 String_Chars.Tree_Write; 365 Strings.Tree_Write; 366 end Tree_Write; 367 368 ------------ 369 -- Unlock -- 370 ------------ 371 372 procedure Unlock is 373 begin 374 String_Chars.Locked := False; 375 Strings.Locked := False; 376 end Unlock; 377 378 ------------------------- 379 -- Unstore_String_Char -- 380 ------------------------- 381 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; 388 389 --------------------- 390 -- Write_Char_Code -- 391 --------------------- 392 393 procedure Write_Char_Code (Code : Char_Code) is 394 395 procedure Write_Hex_Byte (J : Char_Code); 396 -- Write single hex byte (value in range 0 .. 255) as two digits 397 398 -------------------- 399 -- Write_Hex_Byte -- 400 -------------------- 401 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; 409 410 -- Start of processing for Write_Char_Code 411 412 begin 413 if Code in 16#20# .. 16#7E# then 414 Write_Char (Character'Val (Code)); 415 416 else 417 Write_Char ('['); 418 Write_Char ('"'); 419 420 if Code > 16#FF_FFFF# then 421 Write_Hex_Byte (Code / 2 ** 24); 422 end if; 423 424 if Code > 16#FFFF# then 425 Write_Hex_Byte ((Code / 2 ** 16) mod 256); 426 end if; 427 428 if Code > 16#FF# then 429 Write_Hex_Byte ((Code / 256) mod 256); 430 end if; 431 432 Write_Hex_Byte (Code mod 256); 433 Write_Char ('"'); 434 Write_Char (']'); 435 end if; 436 end Write_Char_Code; 437 438 ------------------------------ 439 -- Write_String_Table_Entry -- 440 ------------------------------ 441 442 procedure Write_String_Table_Entry (Id : String_Id) is 443 C : Char_Code; 444 445 begin 446 if Id = No_String then 447 Write_Str ("no string"); 448 449 else 450 Write_Char ('"'); 451 452 for J in 1 .. String_Length (Id) loop 453 C := Get_String_Char (Id, J); 454 455 if C = Character'Pos ('"') then 456 Write_Str (""""""); 457 else 458 Write_Char_Code (C); 459 end if; 460 461 -- If string is very long, quit 462 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; 470 471 Write_Char ('"'); 472 end if; 473 end Write_String_Table_Entry; 474 475end Stringt; 476