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