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-2019, 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 Output; use Output; 34with Table; 35 36package body Stringt is 37 38 -- The following table stores the sequence of character codes for the 39 -- stored string constants. The entries are referenced from the 40 -- separate Strings table. 41 42 package String_Chars is new Table.Table ( 43 Table_Component_Type => Char_Code, 44 Table_Index_Type => Int, 45 Table_Low_Bound => 0, 46 Table_Initial => Alloc.String_Chars_Initial, 47 Table_Increment => Alloc.String_Chars_Increment, 48 Table_Name => "String_Chars"); 49 50 -- The String_Id values reference entries in the Strings table, which 51 -- contains String_Entry records that record the length of each stored 52 -- string and its starting location in the String_Chars table. 53 54 type String_Entry is record 55 String_Index : Int; 56 Length : Nat; 57 end record; 58 59 package Strings is new Table.Table ( 60 Table_Component_Type => String_Entry, 61 Table_Index_Type => String_Id'Base, 62 Table_Low_Bound => First_String_Id, 63 Table_Initial => Alloc.Strings_Initial, 64 Table_Increment => Alloc.Strings_Increment, 65 Table_Name => "Strings"); 66 67 -- Note: it is possible that two entries in the Strings table can share 68 -- string data in the String_Chars table, and in particular this happens 69 -- when Start_String is called with a parameter that is the last string 70 -- currently allocated in the table. 71 72 Strings_Last : String_Id := First_String_Id; 73 String_Chars_Last : Int := 0; 74 -- Strings_Last and String_Chars_Last are used by procedure Mark and 75 -- Release to get a snapshot of the tables and to restore them to their 76 -- previous situation. 77 78 ------------ 79 -- Append -- 80 ------------ 81 82 procedure Append (Buf : in out Bounded_String; S : String_Id) is 83 begin 84 for X in 1 .. String_Length (S) loop 85 Append (Buf, Get_Character (Get_String_Char (S, X))); 86 end loop; 87 end Append; 88 89 ---------------- 90 -- End_String -- 91 ---------------- 92 93 function End_String return String_Id is 94 begin 95 return Strings.Last; 96 end End_String; 97 98 --------------------- 99 -- Get_String_Char -- 100 --------------------- 101 102 function Get_String_Char (Id : String_Id; Index : Int) return Char_Code is 103 begin 104 pragma Assert (Id in First_String_Id .. Strings.Last 105 and then Index in 1 .. Strings.Table (Id).Length); 106 107 return String_Chars.Table (Strings.Table (Id).String_Index + Index - 1); 108 end Get_String_Char; 109 110 ---------------- 111 -- Initialize -- 112 ---------------- 113 114 procedure Initialize is 115 begin 116 String_Chars.Init; 117 Strings.Init; 118 119 -- Set up the null string 120 121 Start_String; 122 Null_String_Id := End_String; 123 end Initialize; 124 125 ---------- 126 -- Lock -- 127 ---------- 128 129 procedure Lock is 130 begin 131 String_Chars.Release; 132 String_Chars.Locked := True; 133 Strings.Release; 134 Strings.Locked := True; 135 end Lock; 136 137 ---------- 138 -- Mark -- 139 ---------- 140 141 procedure Mark is 142 begin 143 Strings_Last := Strings.Last; 144 String_Chars_Last := String_Chars.Last; 145 end Mark; 146 147 ------------- 148 -- Release -- 149 ------------- 150 151 procedure Release is 152 begin 153 Strings.Set_Last (Strings_Last); 154 String_Chars.Set_Last (String_Chars_Last); 155 end Release; 156 157 ------------------ 158 -- Start_String -- 159 ------------------ 160 161 -- Version to start completely new string 162 163 procedure Start_String is 164 begin 165 Strings.Append ((String_Index => String_Chars.Last + 1, Length => 0)); 166 end Start_String; 167 168 -- Version to start from initially stored string 169 170 procedure Start_String (S : String_Id) is 171 begin 172 Strings.Increment_Last; 173 174 -- Case of initial string value is at the end of the string characters 175 -- table, so it does not need copying, instead it can be shared. 176 177 if Strings.Table (S).String_Index + Strings.Table (S).Length = 178 String_Chars.Last + 1 179 then 180 Strings.Table (Strings.Last).String_Index := 181 Strings.Table (S).String_Index; 182 183 -- Case of initial string value must be copied to new string 184 185 else 186 Strings.Table (Strings.Last).String_Index := 187 String_Chars.Last + 1; 188 189 for J in 1 .. Strings.Table (S).Length loop 190 String_Chars.Append 191 (String_Chars.Table (Strings.Table (S).String_Index + (J - 1))); 192 end loop; 193 end if; 194 195 -- In either case the result string length is copied from the argument 196 197 Strings.Table (Strings.Last).Length := Strings.Table (S).Length; 198 end Start_String; 199 200 ----------------------- 201 -- Store_String_Char -- 202 ----------------------- 203 204 procedure Store_String_Char (C : Char_Code) is 205 begin 206 String_Chars.Append (C); 207 Strings.Table (Strings.Last).Length := 208 Strings.Table (Strings.Last).Length + 1; 209 end Store_String_Char; 210 211 procedure Store_String_Char (C : Character) is 212 begin 213 Store_String_Char (Get_Char_Code (C)); 214 end Store_String_Char; 215 216 ------------------------ 217 -- Store_String_Chars -- 218 ------------------------ 219 220 procedure Store_String_Chars (S : String) is 221 begin 222 for J in S'First .. S'Last loop 223 Store_String_Char (Get_Char_Code (S (J))); 224 end loop; 225 end Store_String_Chars; 226 227 procedure Store_String_Chars (S : String_Id) is 228 229 -- We are essentially doing this: 230 231 -- for J in 1 .. String_Length (S) loop 232 -- Store_String_Char (Get_String_Char (S, J)); 233 -- end loop; 234 235 -- but when the string is long it's more efficient to grow the 236 -- String_Chars table all at once. 237 238 S_First : constant Int := Strings.Table (S).String_Index; 239 S_Len : constant Nat := String_Length (S); 240 Old_Last : constant Int := String_Chars.Last; 241 New_Last : constant Int := Old_Last + S_Len; 242 243 begin 244 String_Chars.Set_Last (New_Last); 245 String_Chars.Table (Old_Last + 1 .. New_Last) := 246 String_Chars.Table (S_First .. S_First + S_Len - 1); 247 Strings.Table (Strings.Last).Length := 248 Strings.Table (Strings.Last).Length + S_Len; 249 end Store_String_Chars; 250 251 ---------------------- 252 -- Store_String_Int -- 253 ---------------------- 254 255 procedure Store_String_Int (N : Int) is 256 begin 257 if N < 0 then 258 Store_String_Char ('-'); 259 Store_String_Int (-N); 260 261 else 262 if N > 9 then 263 Store_String_Int (N / 10); 264 end if; 265 266 Store_String_Char (Character'Val (Character'Pos ('0') + N mod 10)); 267 end if; 268 end Store_String_Int; 269 270 -------------------------- 271 -- String_Chars_Address -- 272 -------------------------- 273 274 function String_Chars_Address return System.Address is 275 begin 276 return String_Chars.Table (0)'Address; 277 end String_Chars_Address; 278 279 ------------------ 280 -- String_Equal -- 281 ------------------ 282 283 function String_Equal (L, R : String_Id) return Boolean is 284 Len : constant Nat := Strings.Table (L).Length; 285 286 begin 287 if Len /= Strings.Table (R).Length then 288 return False; 289 else 290 for J in 1 .. Len loop 291 if Get_String_Char (L, J) /= Get_String_Char (R, J) then 292 return False; 293 end if; 294 end loop; 295 296 return True; 297 end if; 298 end String_Equal; 299 300 ----------------------------- 301 -- String_From_Name_Buffer -- 302 ----------------------------- 303 304 function String_From_Name_Buffer 305 (Buf : Bounded_String := Global_Name_Buffer) return String_Id 306 is 307 begin 308 Start_String; 309 Store_String_Chars (+Buf); 310 return End_String; 311 end String_From_Name_Buffer; 312 313 ------------------- 314 -- String_Length -- 315 ------------------- 316 317 function String_Length (Id : String_Id) return Nat is 318 begin 319 return Strings.Table (Id).Length; 320 end String_Length; 321 322 -------------------- 323 -- String_To_Name -- 324 -------------------- 325 326 function String_To_Name (S : String_Id) return Name_Id is 327 Buf : Bounded_String; 328 begin 329 Append (Buf, S); 330 return Name_Find (Buf); 331 end String_To_Name; 332 333 --------------------------- 334 -- String_To_Name_Buffer -- 335 --------------------------- 336 337 procedure String_To_Name_Buffer (S : String_Id) is 338 begin 339 Name_Len := 0; 340 Append (Global_Name_Buffer, S); 341 end String_To_Name_Buffer; 342 343 --------------------- 344 -- Strings_Address -- 345 --------------------- 346 347 function Strings_Address return System.Address is 348 begin 349 return Strings.Table (First_String_Id)'Address; 350 end Strings_Address; 351 352 --------------- 353 -- Tree_Read -- 354 --------------- 355 356 procedure Tree_Read is 357 begin 358 String_Chars.Tree_Read; 359 Strings.Tree_Read; 360 end Tree_Read; 361 362 ---------------- 363 -- Tree_Write -- 364 ---------------- 365 366 procedure Tree_Write is 367 begin 368 String_Chars.Tree_Write; 369 Strings.Tree_Write; 370 end Tree_Write; 371 372 ------------ 373 -- Unlock -- 374 ------------ 375 376 procedure Unlock is 377 begin 378 String_Chars.Locked := False; 379 Strings.Locked := False; 380 end Unlock; 381 382 ------------------------- 383 -- Unstore_String_Char -- 384 ------------------------- 385 386 procedure Unstore_String_Char is 387 begin 388 String_Chars.Decrement_Last; 389 Strings.Table (Strings.Last).Length := 390 Strings.Table (Strings.Last).Length - 1; 391 end Unstore_String_Char; 392 393 --------------------- 394 -- Write_Char_Code -- 395 --------------------- 396 397 procedure Write_Char_Code (Code : Char_Code) is 398 399 procedure Write_Hex_Byte (J : Char_Code); 400 -- Write single hex byte (value in range 0 .. 255) as two digits 401 402 -------------------- 403 -- Write_Hex_Byte -- 404 -------------------- 405 406 procedure Write_Hex_Byte (J : Char_Code) is 407 Hexd : constant array (Char_Code range 0 .. 15) of Character := 408 "0123456789abcdef"; 409 begin 410 Write_Char (Hexd (J / 16)); 411 Write_Char (Hexd (J mod 16)); 412 end Write_Hex_Byte; 413 414 -- Start of processing for Write_Char_Code 415 416 begin 417 if Code in 16#20# .. 16#7E# then 418 Write_Char (Character'Val (Code)); 419 420 else 421 Write_Char ('['); 422 Write_Char ('"'); 423 424 if Code > 16#FF_FFFF# then 425 Write_Hex_Byte (Code / 2 ** 24); 426 end if; 427 428 if Code > 16#FFFF# then 429 Write_Hex_Byte ((Code / 2 ** 16) mod 256); 430 end if; 431 432 if Code > 16#FF# then 433 Write_Hex_Byte ((Code / 256) mod 256); 434 end if; 435 436 Write_Hex_Byte (Code mod 256); 437 Write_Char ('"'); 438 Write_Char (']'); 439 end if; 440 end Write_Char_Code; 441 442 ------------------------------ 443 -- Write_String_Table_Entry -- 444 ------------------------------ 445 446 procedure Write_String_Table_Entry (Id : String_Id) is 447 C : Char_Code; 448 449 begin 450 if Id = No_String then 451 Write_Str ("no string"); 452 453 else 454 Write_Char ('"'); 455 456 for J in 1 .. String_Length (Id) loop 457 C := Get_String_Char (Id, J); 458 459 if C = Character'Pos ('"') then 460 Write_Str (""""""); 461 else 462 Write_Char_Code (C); 463 end if; 464 465 -- If string is very long, quit 466 467 if J >= 1000 then -- arbitrary limit 468 Write_Str ("""...etc (length = "); 469 Write_Int (String_Length (Id)); 470 Write_Str (")"); 471 return; 472 end if; 473 end loop; 474 475 Write_Char ('"'); 476 end if; 477 end Write_String_Table_Entry; 478 479end Stringt; 480