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-2013, 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 125 -- Set up the null string 126 127 Start_String; 128 Null_String_Id := End_String; 129 end Initialize; 130 131 ---------- 132 -- Lock -- 133 ---------- 134 135 procedure Lock is 136 begin 137 String_Chars.Locked := True; 138 Strings.Locked := True; 139 String_Chars.Release; 140 Strings.Release; 141 end Lock; 142 143 ---------- 144 -- Mark -- 145 ---------- 146 147 procedure Mark is 148 begin 149 Strings_Last := Strings.Last; 150 String_Chars_Last := String_Chars.Last; 151 end Mark; 152 153 ------------- 154 -- Release -- 155 ------------- 156 157 procedure Release is 158 begin 159 Strings.Set_Last (Strings_Last); 160 String_Chars.Set_Last (String_Chars_Last); 161 end Release; 162 163 ------------------ 164 -- Start_String -- 165 ------------------ 166 167 -- Version to start completely new string 168 169 procedure Start_String is 170 begin 171 Strings.Append ((String_Index => String_Chars.Last + 1, Length => 0)); 172 end Start_String; 173 174 -- Version to start from initially stored string 175 176 procedure Start_String (S : String_Id) is 177 begin 178 Strings.Increment_Last; 179 180 -- Case of initial string value is at the end of the string characters 181 -- table, so it does not need copying, instead it can be shared. 182 183 if Strings.Table (S).String_Index + Strings.Table (S).Length = 184 String_Chars.Last + 1 185 then 186 Strings.Table (Strings.Last).String_Index := 187 Strings.Table (S).String_Index; 188 189 -- Case of initial string value must be copied to new string 190 191 else 192 Strings.Table (Strings.Last).String_Index := 193 String_Chars.Last + 1; 194 195 for J in 1 .. Strings.Table (S).Length loop 196 String_Chars.Append 197 (String_Chars.Table (Strings.Table (S).String_Index + (J - 1))); 198 end loop; 199 end if; 200 201 -- In either case the result string length is copied from the argument 202 203 Strings.Table (Strings.Last).Length := Strings.Table (S).Length; 204 end Start_String; 205 206 ----------------------- 207 -- Store_String_Char -- 208 ----------------------- 209 210 procedure Store_String_Char (C : Char_Code) is 211 begin 212 String_Chars.Append (C); 213 Strings.Table (Strings.Last).Length := 214 Strings.Table (Strings.Last).Length + 1; 215 end Store_String_Char; 216 217 procedure Store_String_Char (C : Character) is 218 begin 219 Store_String_Char (Get_Char_Code (C)); 220 end Store_String_Char; 221 222 ------------------------ 223 -- Store_String_Chars -- 224 ------------------------ 225 226 procedure Store_String_Chars (S : String) is 227 begin 228 for J in S'First .. S'Last loop 229 Store_String_Char (Get_Char_Code (S (J))); 230 end loop; 231 end Store_String_Chars; 232 233 procedure Store_String_Chars (S : String_Id) is 234 235 -- We are essentially doing this: 236 237 -- for J in 1 .. String_Length (S) loop 238 -- Store_String_Char (Get_String_Char (S, J)); 239 -- end loop; 240 241 -- but when the string is long it's more efficient to grow the 242 -- String_Chars table all at once. 243 244 S_First : constant Int := Strings.Table (S).String_Index; 245 S_Len : constant Int := String_Length (S); 246 Old_Last : constant Int := String_Chars.Last; 247 New_Last : constant Int := Old_Last + S_Len; 248 249 begin 250 String_Chars.Set_Last (New_Last); 251 String_Chars.Table (Old_Last + 1 .. New_Last) := 252 String_Chars.Table (S_First .. S_First + S_Len - 1); 253 Strings.Table (Strings.Last).Length := 254 Strings.Table (Strings.Last).Length + S_Len; 255 end Store_String_Chars; 256 257 ---------------------- 258 -- Store_String_Int -- 259 ---------------------- 260 261 procedure Store_String_Int (N : Int) is 262 begin 263 if N < 0 then 264 Store_String_Char ('-'); 265 Store_String_Int (-N); 266 267 else 268 if N > 9 then 269 Store_String_Int (N / 10); 270 end if; 271 272 Store_String_Char (Character'Val (Character'Pos ('0') + N mod 10)); 273 end if; 274 end Store_String_Int; 275 276 -------------------------- 277 -- String_Chars_Address -- 278 -------------------------- 279 280 function String_Chars_Address return System.Address is 281 begin 282 return String_Chars.Table (0)'Address; 283 end String_Chars_Address; 284 285 ------------------ 286 -- String_Equal -- 287 ------------------ 288 289 function String_Equal (L, R : String_Id) return Boolean is 290 Len : constant Nat := Strings.Table (L).Length; 291 292 begin 293 if Len /= Strings.Table (R).Length then 294 return False; 295 else 296 for J in 1 .. Len loop 297 if Get_String_Char (L, J) /= Get_String_Char (R, J) then 298 return False; 299 end if; 300 end loop; 301 302 return True; 303 end if; 304 end String_Equal; 305 306 ----------------------------- 307 -- String_From_Name_Buffer -- 308 ----------------------------- 309 310 function String_From_Name_Buffer return String_Id is 311 begin 312 Start_String; 313 314 for J in 1 .. Name_Len loop 315 Store_String_Char (Get_Char_Code (Name_Buffer (J))); 316 end loop; 317 318 return End_String; 319 end String_From_Name_Buffer; 320 321 ------------------- 322 -- String_Length -- 323 ------------------- 324 325 function String_Length (Id : String_Id) return Nat is 326 begin 327 return Strings.Table (Id).Length; 328 end String_Length; 329 330 --------------------------- 331 -- String_To_Name_Buffer -- 332 --------------------------- 333 334 procedure String_To_Name_Buffer (S : String_Id) is 335 begin 336 Name_Len := Natural (String_Length (S)); 337 338 for J in 1 .. Name_Len loop 339 Name_Buffer (J) := 340 Get_Character (Get_String_Char (S, Int (J))); 341 end loop; 342 end String_To_Name_Buffer; 343 344 --------------------- 345 -- Strings_Address -- 346 --------------------- 347 348 function Strings_Address return System.Address is 349 begin 350 return Strings.Table (First_String_Id)'Address; 351 end Strings_Address; 352 353 --------------- 354 -- Tree_Read -- 355 --------------- 356 357 procedure Tree_Read is 358 begin 359 String_Chars.Tree_Read; 360 Strings.Tree_Read; 361 end Tree_Read; 362 363 ---------------- 364 -- Tree_Write -- 365 ---------------- 366 367 procedure Tree_Write is 368 begin 369 String_Chars.Tree_Write; 370 Strings.Tree_Write; 371 end Tree_Write; 372 373 ------------ 374 -- Unlock -- 375 ------------ 376 377 procedure Unlock is 378 begin 379 String_Chars.Locked := False; 380 Strings.Locked := False; 381 end Unlock; 382 383 ------------------------- 384 -- Unstore_String_Char -- 385 ------------------------- 386 387 procedure Unstore_String_Char is 388 begin 389 String_Chars.Decrement_Last; 390 Strings.Table (Strings.Last).Length := 391 Strings.Table (Strings.Last).Length - 1; 392 end Unstore_String_Char; 393 394 --------------------- 395 -- Write_Char_Code -- 396 --------------------- 397 398 procedure Write_Char_Code (Code : Char_Code) is 399 400 procedure Write_Hex_Byte (J : Char_Code); 401 -- Write single hex byte (value in range 0 .. 255) as two digits 402 403 -------------------- 404 -- Write_Hex_Byte -- 405 -------------------- 406 407 procedure Write_Hex_Byte (J : Char_Code) is 408 Hexd : constant array (Char_Code range 0 .. 15) of Character := 409 "0123456789abcdef"; 410 begin 411 Write_Char (Hexd (J / 16)); 412 Write_Char (Hexd (J mod 16)); 413 end Write_Hex_Byte; 414 415 -- Start of processing for Write_Char_Code 416 417 begin 418 if Code in 16#20# .. 16#7E# then 419 Write_Char (Character'Val (Code)); 420 421 else 422 Write_Char ('['); 423 Write_Char ('"'); 424 425 if Code > 16#FF_FFFF# then 426 Write_Hex_Byte (Code / 2 ** 24); 427 end if; 428 429 if Code > 16#FFFF# then 430 Write_Hex_Byte ((Code / 2 ** 16) mod 256); 431 end if; 432 433 if Code > 16#FF# then 434 Write_Hex_Byte ((Code / 256) mod 256); 435 end if; 436 437 Write_Hex_Byte (Code mod 256); 438 Write_Char ('"'); 439 Write_Char (']'); 440 end if; 441 end Write_Char_Code; 442 443 ------------------------------ 444 -- Write_String_Table_Entry -- 445 ------------------------------ 446 447 procedure Write_String_Table_Entry (Id : String_Id) is 448 C : Char_Code; 449 450 begin 451 if Id = No_String then 452 Write_Str ("no string"); 453 454 else 455 Write_Char ('"'); 456 457 for J in 1 .. String_Length (Id) loop 458 C := Get_String_Char (Id, J); 459 460 if C = Character'Pos ('"') then 461 Write_Str (""""""); 462 else 463 Write_Char_Code (C); 464 end if; 465 466 -- If string is very long, quit 467 468 if J >= 1000 then -- arbitrary limit 469 Write_Str ("""...etc (length = "); 470 Write_Int (String_Length (Id)); 471 Write_Str (")"); 472 return; 473 end if; 474 end loop; 475 476 Write_Char ('"'); 477 end if; 478 end Write_String_Table_Entry; 479 480end Stringt; 481