1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- N A M E 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 32-- WARNING: There is a C version of this package. Any changes to this 33-- source file must be properly reflected in the C header file namet.h 34-- which is created manually from namet.ads and namet.adb. 35 36with Debug; use Debug; 37with Opt; use Opt; 38with Output; use Output; 39with System; use System; 40with Tree_IO; use Tree_IO; 41with Widechar; 42 43with Interfaces; use Interfaces; 44 45package body Namet is 46 47 Name_Chars_Reserve : constant := 5000; 48 Name_Entries_Reserve : constant := 100; 49 -- The names table is locked during gigi processing, since gigi assumes 50 -- that the table does not move. After returning from gigi, the names 51 -- table is unlocked again, since writing library file information needs 52 -- to generate some extra names. To avoid the inefficiency of always 53 -- reallocating during this second unlocked phase, we reserve a bit of 54 -- extra space before doing the release call. 55 56 Hash_Num : constant Int := 2**16; 57 -- Number of headers in the hash table. Current hash algorithm is closely 58 -- tailored to this choice, so it can only be changed if a corresponding 59 -- change is made to the hash algorithm. 60 61 Hash_Max : constant Int := Hash_Num - 1; 62 -- Indexes in the hash header table run from 0 to Hash_Num - 1 63 64 subtype Hash_Index_Type is Int range 0 .. Hash_Max; 65 -- Range of hash index values 66 67 Hash_Table : array (Hash_Index_Type) of Name_Id; 68 -- The hash table is used to locate existing entries in the names table. 69 -- The entries point to the first names table entry whose hash value 70 -- matches the hash code. Then subsequent names table entries with the 71 -- same hash code value are linked through the Hash_Link fields. 72 73 ----------------------- 74 -- Local Subprograms -- 75 ----------------------- 76 77 function Hash (Buf : Bounded_String) return Hash_Index_Type; 78 pragma Inline (Hash); 79 -- Compute hash code for name stored in Buf 80 81 procedure Strip_Qualification_And_Suffixes (Buf : in out Bounded_String); 82 -- Given an encoded entity name in Buf, remove package body 83 -- suffix as described for Strip_Package_Body_Suffix, and also remove 84 -- all qualification, i.e. names followed by two underscores. 85 86 ----------------------------- 87 -- Add_Char_To_Name_Buffer -- 88 ----------------------------- 89 90 procedure Add_Char_To_Name_Buffer (C : Character) is 91 begin 92 Append (Global_Name_Buffer, C); 93 end Add_Char_To_Name_Buffer; 94 95 ---------------------------- 96 -- Add_Nat_To_Name_Buffer -- 97 ---------------------------- 98 99 procedure Add_Nat_To_Name_Buffer (V : Nat) is 100 begin 101 Append (Global_Name_Buffer, V); 102 end Add_Nat_To_Name_Buffer; 103 104 ---------------------------- 105 -- Add_Str_To_Name_Buffer -- 106 ---------------------------- 107 108 procedure Add_Str_To_Name_Buffer (S : String) is 109 begin 110 Append (Global_Name_Buffer, S); 111 end Add_Str_To_Name_Buffer; 112 113 ------------ 114 -- Append -- 115 ------------ 116 117 procedure Append (Buf : in out Bounded_String; C : Character) is 118 begin 119 Buf.Length := Buf.Length + 1; 120 121 if Buf.Length > Buf.Chars'Last then 122 Write_Str ("Name buffer overflow; Max_Length = "); 123 Write_Int (Int (Buf.Max_Length)); 124 Write_Line (""); 125 raise Program_Error; 126 end if; 127 128 Buf.Chars (Buf.Length) := C; 129 end Append; 130 131 procedure Append (Buf : in out Bounded_String; V : Nat) is 132 begin 133 if V >= 10 then 134 Append (Buf, V / 10); 135 end if; 136 137 Append (Buf, Character'Val (Character'Pos ('0') + V rem 10)); 138 end Append; 139 140 procedure Append (Buf : in out Bounded_String; S : String) is 141 First : constant Natural := Buf.Length + 1; 142 begin 143 Buf.Length := Buf.Length + S'Length; 144 145 if Buf.Length > Buf.Chars'Last then 146 Write_Str ("Name buffer overflow; Max_Length = "); 147 Write_Int (Int (Buf.Max_Length)); 148 Write_Line (""); 149 raise Program_Error; 150 end if; 151 152 Buf.Chars (First .. Buf.Length) := S; 153 -- A loop calling Append(Character) would be cleaner, but this slice 154 -- assignment is substantially faster. 155 end Append; 156 157 procedure Append (Buf : in out Bounded_String; Buf2 : Bounded_String) is 158 begin 159 Append (Buf, Buf2.Chars (1 .. Buf2.Length)); 160 end Append; 161 162 procedure Append (Buf : in out Bounded_String; Id : Valid_Name_Id) is 163 pragma Assert (Is_Valid_Name (Id)); 164 165 Index : constant Int := Name_Entries.Table (Id).Name_Chars_Index; 166 Len : constant Short := Name_Entries.Table (Id).Name_Len; 167 Chars : Name_Chars.Table_Type renames 168 Name_Chars.Table (Index + 1 .. Index + Int (Len)); 169 begin 170 Append (Buf, String (Chars)); 171 end Append; 172 173 -------------------- 174 -- Append_Decoded -- 175 -------------------- 176 177 procedure Append_Decoded 178 (Buf : in out Bounded_String; 179 Id : Valid_Name_Id) 180 is 181 C : Character; 182 P : Natural; 183 Temp : Bounded_String; 184 185 begin 186 Append (Temp, Id); 187 188 -- Skip scan if we already know there are no encodings 189 190 if Name_Entries.Table (Id).Name_Has_No_Encodings then 191 goto Done; 192 end if; 193 194 -- Quick loop to see if there is anything special to do 195 196 P := 1; 197 loop 198 if P = Temp.Length then 199 Name_Entries.Table (Id).Name_Has_No_Encodings := True; 200 goto Done; 201 202 else 203 C := Temp.Chars (P); 204 205 exit when 206 C = 'U' or else 207 C = 'W' or else 208 C = 'Q' or else 209 C = 'O'; 210 211 P := P + 1; 212 end if; 213 end loop; 214 215 -- Here we have at least some encoding that we must decode 216 217 Decode : declare 218 New_Len : Natural; 219 Old : Positive; 220 New_Buf : String (1 .. Temp.Chars'Last); 221 222 procedure Copy_One_Character; 223 -- Copy a character from Temp.Chars to New_Buf. Includes case 224 -- of copying a Uhh,Whhhh,WWhhhhhhhh sequence and decoding it. 225 226 function Hex (N : Natural) return Word; 227 -- Scans past N digits using Old pointer and returns hex value 228 229 procedure Insert_Character (C : Character); 230 -- Insert a new character into output decoded name 231 232 ------------------------ 233 -- Copy_One_Character -- 234 ------------------------ 235 236 procedure Copy_One_Character is 237 C : Character; 238 239 begin 240 C := Temp.Chars (Old); 241 242 -- U (upper half insertion case) 243 244 if C = 'U' 245 and then Old < Temp.Length 246 and then Temp.Chars (Old + 1) not in 'A' .. 'Z' 247 and then Temp.Chars (Old + 1) /= '_' 248 then 249 Old := Old + 1; 250 251 -- If we have upper half encoding, then we have to set an 252 -- appropriate wide character sequence for this character. 253 254 if Upper_Half_Encoding then 255 Widechar.Set_Wide (Char_Code (Hex (2)), New_Buf, New_Len); 256 257 -- For other encoding methods, upper half characters can 258 -- simply use their normal representation. 259 260 else 261 declare 262 W2 : constant Word := Hex (2); 263 begin 264 pragma Assert (W2 <= 255); 265 -- Add assumption to facilitate static analysis. Note 266 -- that we cannot use pragma Assume for bootstrap 267 -- reasons. 268 Insert_Character (Character'Val (W2)); 269 end; 270 end if; 271 272 -- WW (wide wide character insertion) 273 274 elsif C = 'W' 275 and then Old < Temp.Length 276 and then Temp.Chars (Old + 1) = 'W' 277 then 278 Old := Old + 2; 279 Widechar.Set_Wide (Char_Code (Hex (8)), New_Buf, New_Len); 280 281 -- W (wide character insertion) 282 283 elsif C = 'W' 284 and then Old < Temp.Length 285 and then Temp.Chars (Old + 1) not in 'A' .. 'Z' 286 and then Temp.Chars (Old + 1) /= '_' 287 then 288 Old := Old + 1; 289 Widechar.Set_Wide (Char_Code (Hex (4)), New_Buf, New_Len); 290 291 -- Any other character is copied unchanged 292 293 else 294 Insert_Character (C); 295 Old := Old + 1; 296 end if; 297 end Copy_One_Character; 298 299 --------- 300 -- Hex -- 301 --------- 302 303 function Hex (N : Natural) return Word is 304 T : Word := 0; 305 C : Character; 306 307 begin 308 for J in 1 .. N loop 309 C := Temp.Chars (Old); 310 Old := Old + 1; 311 312 pragma Assert (C in '0' .. '9' or else C in 'a' .. 'f'); 313 314 if C <= '9' then 315 T := 16 * T + Character'Pos (C) - Character'Pos ('0'); 316 else -- C in 'a' .. 'f' 317 T := 16 * T + Character'Pos (C) - (Character'Pos ('a') - 10); 318 end if; 319 end loop; 320 321 return T; 322 end Hex; 323 324 ---------------------- 325 -- Insert_Character -- 326 ---------------------- 327 328 procedure Insert_Character (C : Character) is 329 begin 330 New_Len := New_Len + 1; 331 New_Buf (New_Len) := C; 332 end Insert_Character; 333 334 -- Start of processing for Decode 335 336 begin 337 New_Len := 0; 338 Old := 1; 339 340 -- Loop through characters of name 341 342 while Old <= Temp.Length loop 343 344 -- Case of character literal, put apostrophes around character 345 346 if Temp.Chars (Old) = 'Q' 347 and then Old < Temp.Length 348 then 349 Old := Old + 1; 350 Insert_Character ('''); 351 Copy_One_Character; 352 Insert_Character ('''); 353 354 -- Case of operator name 355 356 elsif Temp.Chars (Old) = 'O' 357 and then Old < Temp.Length 358 and then Temp.Chars (Old + 1) not in 'A' .. 'Z' 359 and then Temp.Chars (Old + 1) /= '_' 360 then 361 Old := Old + 1; 362 363 declare 364 -- This table maps the 2nd and 3rd characters of the name 365 -- into the required output. Two blanks means leave the 366 -- name alone 367 368 Map : constant String := 369 "ab " & -- Oabs => "abs" 370 "ad+ " & -- Oadd => "+" 371 "an " & -- Oand => "and" 372 "co& " & -- Oconcat => "&" 373 "di/ " & -- Odivide => "/" 374 "eq= " & -- Oeq => "=" 375 "ex**" & -- Oexpon => "**" 376 "gt> " & -- Ogt => ">" 377 "ge>=" & -- Oge => ">=" 378 "le<=" & -- Ole => "<=" 379 "lt< " & -- Olt => "<" 380 "mo " & -- Omod => "mod" 381 "mu* " & -- Omutliply => "*" 382 "ne/=" & -- One => "/=" 383 "no " & -- Onot => "not" 384 "or " & -- Oor => "or" 385 "re " & -- Orem => "rem" 386 "su- " & -- Osubtract => "-" 387 "xo "; -- Oxor => "xor" 388 389 J : Integer; 390 391 begin 392 Insert_Character ('"'); 393 394 -- Search the map. Note that this loop must terminate, if 395 -- not we have some kind of internal error, and a constraint 396 -- error may be raised. 397 398 J := Map'First; 399 loop 400 exit when Temp.Chars (Old) = Map (J) 401 and then Temp.Chars (Old + 1) = Map (J + 1); 402 J := J + 4; 403 end loop; 404 405 -- Special operator name 406 407 if Map (J + 2) /= ' ' then 408 Insert_Character (Map (J + 2)); 409 410 if Map (J + 3) /= ' ' then 411 Insert_Character (Map (J + 3)); 412 end if; 413 414 Insert_Character ('"'); 415 416 -- Skip past original operator name in input 417 418 while Old <= Temp.Length 419 and then Temp.Chars (Old) in 'a' .. 'z' 420 loop 421 Old := Old + 1; 422 end loop; 423 424 -- For other operator names, leave them in lower case, 425 -- surrounded by apostrophes 426 427 else 428 -- Copy original operator name from input to output 429 430 while Old <= Temp.Length 431 and then Temp.Chars (Old) in 'a' .. 'z' 432 loop 433 Copy_One_Character; 434 end loop; 435 436 Insert_Character ('"'); 437 end if; 438 end; 439 440 -- Else copy one character and keep going 441 442 else 443 Copy_One_Character; 444 end if; 445 end loop; 446 447 -- Copy new buffer as result 448 449 Temp.Length := New_Len; 450 Temp.Chars (1 .. New_Len) := New_Buf (1 .. New_Len); 451 end Decode; 452 453 <<Done>> 454 Append (Buf, Temp); 455 end Append_Decoded; 456 457 ---------------------------------- 458 -- Append_Decoded_With_Brackets -- 459 ---------------------------------- 460 461 procedure Append_Decoded_With_Brackets 462 (Buf : in out Bounded_String; 463 Id : Valid_Name_Id) 464 is 465 P : Natural; 466 467 begin 468 -- Case of operator name, normal decoding is fine 469 470 if Buf.Chars (1) = 'O' then 471 Append_Decoded (Buf, Id); 472 473 -- For character literals, normal decoding is fine 474 475 elsif Buf.Chars (1) = 'Q' then 476 Append_Decoded (Buf, Id); 477 478 -- Only remaining issue is U/W/WW sequences 479 480 else 481 declare 482 Temp : Bounded_String; 483 begin 484 Append (Temp, Id); 485 486 P := 1; 487 while P < Temp.Length loop 488 if Temp.Chars (P + 1) in 'A' .. 'Z' then 489 P := P + 1; 490 491 -- Uhh encoding 492 493 elsif Temp.Chars (P) = 'U' then 494 for J in reverse P + 3 .. P + Temp.Length loop 495 Temp.Chars (J + 3) := Temp.Chars (J); 496 end loop; 497 498 Temp.Length := Temp.Length + 3; 499 Temp.Chars (P + 3) := Temp.Chars (P + 2); 500 Temp.Chars (P + 2) := Temp.Chars (P + 1); 501 Temp.Chars (P) := '['; 502 Temp.Chars (P + 1) := '"'; 503 Temp.Chars (P + 4) := '"'; 504 Temp.Chars (P + 5) := ']'; 505 P := P + 6; 506 507 -- WWhhhhhhhh encoding 508 509 elsif Temp.Chars (P) = 'W' 510 and then P + 9 <= Temp.Length 511 and then Temp.Chars (P + 1) = 'W' 512 and then Temp.Chars (P + 2) not in 'A' .. 'Z' 513 and then Temp.Chars (P + 2) /= '_' 514 then 515 Temp.Chars (P + 12 .. Temp.Length + 2) := 516 Temp.Chars (P + 10 .. Temp.Length); 517 Temp.Chars (P) := '['; 518 Temp.Chars (P + 1) := '"'; 519 Temp.Chars (P + 10) := '"'; 520 Temp.Chars (P + 11) := ']'; 521 Temp.Length := Temp.Length + 2; 522 P := P + 12; 523 524 -- Whhhh encoding 525 526 elsif Temp.Chars (P) = 'W' 527 and then P < Temp.Length 528 and then Temp.Chars (P + 1) not in 'A' .. 'Z' 529 and then Temp.Chars (P + 1) /= '_' 530 then 531 Temp.Chars (P + 8 .. P + Temp.Length + 3) := 532 Temp.Chars (P + 5 .. Temp.Length); 533 Temp.Chars (P + 2 .. P + 5) := Temp.Chars (P + 1 .. P + 4); 534 Temp.Chars (P) := '['; 535 Temp.Chars (P + 1) := '"'; 536 Temp.Chars (P + 6) := '"'; 537 Temp.Chars (P + 7) := ']'; 538 Temp.Length := Temp.Length + 3; 539 P := P + 8; 540 541 else 542 P := P + 1; 543 end if; 544 end loop; 545 546 Append (Buf, Temp); 547 end; 548 end if; 549 end Append_Decoded_With_Brackets; 550 551 -------------------- 552 -- Append_Encoded -- 553 -------------------- 554 555 procedure Append_Encoded (Buf : in out Bounded_String; C : Char_Code) is 556 procedure Set_Hex_Chars (C : Char_Code); 557 -- Stores given value, which is in the range 0 .. 255, as two hex 558 -- digits (using lower case a-f) in Buf.Chars, incrementing Buf.Length. 559 560 ------------------- 561 -- Set_Hex_Chars -- 562 ------------------- 563 564 procedure Set_Hex_Chars (C : Char_Code) is 565 Hexd : constant String := "0123456789abcdef"; 566 N : constant Natural := Natural (C); 567 begin 568 Buf.Chars (Buf.Length + 1) := Hexd (N / 16 + 1); 569 Buf.Chars (Buf.Length + 2) := Hexd (N mod 16 + 1); 570 Buf.Length := Buf.Length + 2; 571 end Set_Hex_Chars; 572 573 -- Start of processing for Append_Encoded 574 575 begin 576 Buf.Length := Buf.Length + 1; 577 578 if In_Character_Range (C) then 579 declare 580 CC : constant Character := Get_Character (C); 581 begin 582 if CC in 'a' .. 'z' or else CC in '0' .. '9' then 583 Buf.Chars (Buf.Length) := CC; 584 else 585 Buf.Chars (Buf.Length) := 'U'; 586 Set_Hex_Chars (C); 587 end if; 588 end; 589 590 elsif In_Wide_Character_Range (C) then 591 Buf.Chars (Buf.Length) := 'W'; 592 Set_Hex_Chars (C / 256); 593 Set_Hex_Chars (C mod 256); 594 595 else 596 Buf.Chars (Buf.Length) := 'W'; 597 Buf.Length := Buf.Length + 1; 598 Buf.Chars (Buf.Length) := 'W'; 599 Set_Hex_Chars (C / 2 ** 24); 600 Set_Hex_Chars ((C / 2 ** 16) mod 256); 601 Set_Hex_Chars ((C / 256) mod 256); 602 Set_Hex_Chars (C mod 256); 603 end if; 604 end Append_Encoded; 605 606 ------------------------ 607 -- Append_Unqualified -- 608 ------------------------ 609 610 procedure Append_Unqualified 611 (Buf : in out Bounded_String; 612 Id : Valid_Name_Id) 613 is 614 Temp : Bounded_String; 615 begin 616 Append (Temp, Id); 617 Strip_Qualification_And_Suffixes (Temp); 618 Append (Buf, Temp); 619 end Append_Unqualified; 620 621 -------------------------------- 622 -- Append_Unqualified_Decoded -- 623 -------------------------------- 624 625 procedure Append_Unqualified_Decoded 626 (Buf : in out Bounded_String; 627 Id : Valid_Name_Id) 628 is 629 Temp : Bounded_String; 630 begin 631 Append_Decoded (Temp, Id); 632 Strip_Qualification_And_Suffixes (Temp); 633 Append (Buf, Temp); 634 end Append_Unqualified_Decoded; 635 636 -------------- 637 -- Finalize -- 638 -------------- 639 640 procedure Finalize is 641 F : array (Int range 0 .. 50) of Int; 642 -- N'th entry is the number of chains of length N, except last entry, 643 -- which is the number of chains of length F'Last or more. 644 645 Max_Chain_Length : Nat := 0; 646 -- Maximum length of all chains 647 648 Probes : Nat := 0; 649 -- Used to compute average number of probes 650 651 Nsyms : Nat := 0; 652 -- Number of symbols in table 653 654 Verbosity : constant Int range 1 .. 3 := 1; 655 pragma Warnings (Off, Verbosity); 656 -- This constant indicates the level of verbosity in the output from 657 -- this procedure. Currently this can only be changed by editing the 658 -- declaration above and recompiling. That's good enough in practice, 659 -- since we very rarely need to use this debug option. Settings are: 660 -- 661 -- 1 => print basic summary information 662 -- 2 => in addition print number of entries per hash chain 663 -- 3 => in addition print content of entries 664 665 Zero : constant Int := Character'Pos ('0'); 666 667 begin 668 if not Debug_Flag_H then 669 return; 670 end if; 671 672 for J in F'Range loop 673 F (J) := 0; 674 end loop; 675 676 for J in Hash_Index_Type loop 677 if Hash_Table (J) = No_Name then 678 F (0) := F (0) + 1; 679 680 else 681 declare 682 C : Nat; 683 N : Name_Id; 684 S : Int; 685 686 begin 687 C := 0; 688 N := Hash_Table (J); 689 690 while N /= No_Name loop 691 N := Name_Entries.Table (N).Hash_Link; 692 C := C + 1; 693 end loop; 694 695 Nsyms := Nsyms + 1; 696 Probes := Probes + (1 + C) * 100; 697 698 if C > Max_Chain_Length then 699 Max_Chain_Length := C; 700 end if; 701 702 if Verbosity >= 2 then 703 Write_Str ("Hash_Table ("); 704 Write_Int (J); 705 Write_Str (") has "); 706 Write_Int (C); 707 Write_Str (" entries"); 708 Write_Eol; 709 end if; 710 711 if C < F'Last then 712 F (C) := F (C) + 1; 713 else 714 F (F'Last) := F (F'Last) + 1; 715 end if; 716 717 if Verbosity >= 3 then 718 N := Hash_Table (J); 719 while N /= No_Name loop 720 S := Name_Entries.Table (N).Name_Chars_Index; 721 722 Write_Str (" "); 723 724 for J in 1 .. Name_Entries.Table (N).Name_Len loop 725 Write_Char (Name_Chars.Table (S + Int (J))); 726 end loop; 727 728 Write_Eol; 729 730 N := Name_Entries.Table (N).Hash_Link; 731 end loop; 732 end if; 733 end; 734 end if; 735 end loop; 736 737 Write_Eol; 738 739 for J in F'Range loop 740 if F (J) /= 0 then 741 Write_Str ("Number of hash chains of length "); 742 743 if J < 10 then 744 Write_Char (' '); 745 end if; 746 747 Write_Int (J); 748 749 if J = F'Last then 750 Write_Str (" or greater"); 751 end if; 752 753 Write_Str (" = "); 754 Write_Int (F (J)); 755 Write_Eol; 756 end if; 757 end loop; 758 759 -- Print out average number of probes, in the case where Name_Find is 760 -- called for a string that is already in the table. 761 762 Write_Eol; 763 Write_Str ("Average number of probes for lookup = "); 764 pragma Assert (Nsyms /= 0); 765 -- Add assumption to facilitate static analysis. Here Nsyms cannot be 766 -- zero because many symbols are added to the table by default. 767 Probes := Probes / Nsyms; 768 Write_Int (Probes / 200); 769 Write_Char ('.'); 770 Probes := (Probes mod 200) / 2; 771 Write_Char (Character'Val (Zero + Probes / 10)); 772 Write_Char (Character'Val (Zero + Probes mod 10)); 773 Write_Eol; 774 775 Write_Str ("Max_Chain_Length = "); 776 Write_Int (Max_Chain_Length); 777 Write_Eol; 778 Write_Str ("Name_Chars'Length = "); 779 Write_Int (Name_Chars.Last - Name_Chars.First + 1); 780 Write_Eol; 781 Write_Str ("Name_Entries'Length = "); 782 Write_Int (Int (Name_Entries.Last - Name_Entries.First + 1)); 783 Write_Eol; 784 Write_Str ("Nsyms = "); 785 Write_Int (Nsyms); 786 Write_Eol; 787 end Finalize; 788 789 ----------------------------- 790 -- Get_Decoded_Name_String -- 791 ----------------------------- 792 793 procedure Get_Decoded_Name_String (Id : Valid_Name_Id) is 794 begin 795 Global_Name_Buffer.Length := 0; 796 Append_Decoded (Global_Name_Buffer, Id); 797 end Get_Decoded_Name_String; 798 799 ------------------------------------------- 800 -- Get_Decoded_Name_String_With_Brackets -- 801 ------------------------------------------- 802 803 procedure Get_Decoded_Name_String_With_Brackets (Id : Valid_Name_Id) is 804 begin 805 Global_Name_Buffer.Length := 0; 806 Append_Decoded_With_Brackets (Global_Name_Buffer, Id); 807 end Get_Decoded_Name_String_With_Brackets; 808 809 ------------------------ 810 -- Get_Last_Two_Chars -- 811 ------------------------ 812 813 procedure Get_Last_Two_Chars 814 (N : Valid_Name_Id; 815 C1 : out Character; 816 C2 : out Character) 817 is 818 NE : Name_Entry renames Name_Entries.Table (N); 819 NEL : constant Int := Int (NE.Name_Len); 820 821 begin 822 if NEL >= 2 then 823 C1 := Name_Chars.Table (NE.Name_Chars_Index + NEL - 1); 824 C2 := Name_Chars.Table (NE.Name_Chars_Index + NEL - 0); 825 else 826 C1 := ASCII.NUL; 827 C2 := ASCII.NUL; 828 end if; 829 end Get_Last_Two_Chars; 830 831 --------------------- 832 -- Get_Name_String -- 833 --------------------- 834 835 procedure Get_Name_String (Id : Valid_Name_Id) is 836 begin 837 Global_Name_Buffer.Length := 0; 838 Append (Global_Name_Buffer, Id); 839 end Get_Name_String; 840 841 function Get_Name_String (Id : Valid_Name_Id) return String is 842 Buf : Bounded_String (Max_Length => Natural (Length_Of_Name (Id))); 843 begin 844 Append (Buf, Id); 845 return +Buf; 846 end Get_Name_String; 847 848 -------------------------------- 849 -- Get_Name_String_And_Append -- 850 -------------------------------- 851 852 procedure Get_Name_String_And_Append (Id : Valid_Name_Id) is 853 begin 854 Append (Global_Name_Buffer, Id); 855 end Get_Name_String_And_Append; 856 857 ----------------------------- 858 -- Get_Name_Table_Boolean1 -- 859 ----------------------------- 860 861 function Get_Name_Table_Boolean1 (Id : Valid_Name_Id) return Boolean is 862 begin 863 pragma Assert (Is_Valid_Name (Id)); 864 return Name_Entries.Table (Id).Boolean1_Info; 865 end Get_Name_Table_Boolean1; 866 867 ----------------------------- 868 -- Get_Name_Table_Boolean2 -- 869 ----------------------------- 870 871 function Get_Name_Table_Boolean2 (Id : Valid_Name_Id) return Boolean is 872 begin 873 pragma Assert (Is_Valid_Name (Id)); 874 return Name_Entries.Table (Id).Boolean2_Info; 875 end Get_Name_Table_Boolean2; 876 877 ----------------------------- 878 -- Get_Name_Table_Boolean3 -- 879 ----------------------------- 880 881 function Get_Name_Table_Boolean3 (Id : Valid_Name_Id) return Boolean is 882 begin 883 pragma Assert (Is_Valid_Name (Id)); 884 return Name_Entries.Table (Id).Boolean3_Info; 885 end Get_Name_Table_Boolean3; 886 887 ------------------------- 888 -- Get_Name_Table_Byte -- 889 ------------------------- 890 891 function Get_Name_Table_Byte (Id : Valid_Name_Id) return Byte is 892 begin 893 pragma Assert (Is_Valid_Name (Id)); 894 return Name_Entries.Table (Id).Byte_Info; 895 end Get_Name_Table_Byte; 896 897 ------------------------- 898 -- Get_Name_Table_Int -- 899 ------------------------- 900 901 function Get_Name_Table_Int (Id : Valid_Name_Id) return Int is 902 begin 903 pragma Assert (Is_Valid_Name (Id)); 904 return Name_Entries.Table (Id).Int_Info; 905 end Get_Name_Table_Int; 906 907 ----------------------------------------- 908 -- Get_Unqualified_Decoded_Name_String -- 909 ----------------------------------------- 910 911 procedure Get_Unqualified_Decoded_Name_String (Id : Valid_Name_Id) is 912 begin 913 Global_Name_Buffer.Length := 0; 914 Append_Unqualified_Decoded (Global_Name_Buffer, Id); 915 end Get_Unqualified_Decoded_Name_String; 916 917 --------------------------------- 918 -- Get_Unqualified_Name_String -- 919 --------------------------------- 920 921 procedure Get_Unqualified_Name_String (Id : Valid_Name_Id) is 922 begin 923 Global_Name_Buffer.Length := 0; 924 Append_Unqualified (Global_Name_Buffer, Id); 925 end Get_Unqualified_Name_String; 926 927 ---------- 928 -- Hash -- 929 ---------- 930 931 function Hash (Buf : Bounded_String) return Hash_Index_Type is 932 933 -- This hash function looks at every character, in order to make it 934 -- likely that similar strings get different hash values. The rotate by 935 -- 7 bits has been determined empirically to be good, and it doesn't 936 -- lose bits like a shift would. The final conversion can't overflow, 937 -- because the table is 2**16 in size. This function probably needs to 938 -- be changed if the hash table size is changed. 939 940 -- Note that we could get some speed improvement by aligning the string 941 -- to 32 or 64 bits, and doing word-wise xor's. We could also implement 942 -- a growable table. It doesn't seem worth the trouble to do those 943 -- things, for now. 944 945 Result : Unsigned_16 := 0; 946 947 begin 948 for J in 1 .. Buf.Length loop 949 Result := Rotate_Left (Result, 7) xor Character'Pos (Buf.Chars (J)); 950 end loop; 951 952 return Hash_Index_Type (Result); 953 end Hash; 954 955 ---------------- 956 -- Initialize -- 957 ---------------- 958 959 procedure Initialize is 960 begin 961 null; 962 end Initialize; 963 964 ---------------- 965 -- Insert_Str -- 966 ---------------- 967 968 procedure Insert_Str 969 (Buf : in out Bounded_String; 970 S : String; 971 Index : Positive) 972 is 973 SL : constant Natural := S'Length; 974 975 begin 976 Buf.Chars (Index + SL .. Buf.Length + SL) := 977 Buf.Chars (Index .. Buf.Length); 978 Buf.Chars (Index .. Index + SL - 1) := S; 979 Buf.Length := Buf.Length + SL; 980 end Insert_Str; 981 982 ------------------------------- 983 -- Insert_Str_In_Name_Buffer -- 984 ------------------------------- 985 986 procedure Insert_Str_In_Name_Buffer (S : String; Index : Positive) is 987 begin 988 Insert_Str (Global_Name_Buffer, S, Index); 989 end Insert_Str_In_Name_Buffer; 990 991 ---------------------- 992 -- Is_Internal_Name -- 993 ---------------------- 994 995 function Is_Internal_Name (Buf : Bounded_String) return Boolean is 996 J : Natural; 997 998 begin 999 -- Any name starting or ending with underscore is internal 1000 1001 if Buf.Chars (1) = '_' 1002 or else Buf.Chars (Buf.Length) = '_' 1003 then 1004 return True; 1005 1006 -- Allow quoted character 1007 1008 elsif Buf.Chars (1) = ''' then 1009 return False; 1010 1011 -- All other cases, scan name 1012 1013 else 1014 -- Test backwards, because we only want to test the last entity 1015 -- name if the name we have is qualified with other entities. 1016 1017 J := Buf.Length; 1018 while J /= 0 loop 1019 1020 -- Skip stuff between brackets (A-F OK there) 1021 1022 if Buf.Chars (J) = ']' then 1023 loop 1024 J := J - 1; 1025 exit when J = 1 or else Buf.Chars (J) = '['; 1026 end loop; 1027 1028 -- Test for internal letter 1029 1030 elsif Is_OK_Internal_Letter (Buf.Chars (J)) then 1031 return True; 1032 1033 -- Quit if we come to terminating double underscore (note that 1034 -- if the current character is an underscore, we know that 1035 -- there is a previous character present, since we already 1036 -- filtered out the case of Buf.Chars (1) = '_' above. 1037 1038 elsif Buf.Chars (J) = '_' 1039 and then Buf.Chars (J - 1) = '_' 1040 and then Buf.Chars (J - 2) /= '_' 1041 then 1042 return False; 1043 end if; 1044 1045 J := J - 1; 1046 end loop; 1047 end if; 1048 1049 return False; 1050 end Is_Internal_Name; 1051 1052 function Is_Internal_Name (Id : Valid_Name_Id) return Boolean is 1053 Buf : Bounded_String (Max_Length => Natural (Length_Of_Name (Id))); 1054 begin 1055 Append (Buf, Id); 1056 return Is_Internal_Name (Buf); 1057 end Is_Internal_Name; 1058 1059 function Is_Internal_Name return Boolean is 1060 begin 1061 return Is_Internal_Name (Global_Name_Buffer); 1062 end Is_Internal_Name; 1063 1064 --------------------------- 1065 -- Is_OK_Internal_Letter -- 1066 --------------------------- 1067 1068 function Is_OK_Internal_Letter (C : Character) return Boolean is 1069 begin 1070 return C in 'A' .. 'Z' 1071 and then C /= 'O' 1072 and then C /= 'Q' 1073 and then C /= 'U' 1074 and then C /= 'W' 1075 and then C /= 'X'; 1076 end Is_OK_Internal_Letter; 1077 1078 ---------------------- 1079 -- Is_Operator_Name -- 1080 ---------------------- 1081 1082 function Is_Operator_Name (Id : Valid_Name_Id) return Boolean is 1083 S : Int; 1084 begin 1085 pragma Assert (Is_Valid_Name (Id)); 1086 S := Name_Entries.Table (Id).Name_Chars_Index; 1087 return Name_Chars.Table (S + 1) = 'O'; 1088 end Is_Operator_Name; 1089 1090 ------------------- 1091 -- Is_Valid_Name -- 1092 ------------------- 1093 1094 function Is_Valid_Name (Id : Name_Id) return Boolean is 1095 begin 1096 return Id in Name_Entries.First .. Name_Entries.Last; 1097 end Is_Valid_Name; 1098 1099 -------------------- 1100 -- Length_Of_Name -- 1101 -------------------- 1102 1103 function Length_Of_Name (Id : Valid_Name_Id) return Nat is 1104 begin 1105 return Int (Name_Entries.Table (Id).Name_Len); 1106 end Length_Of_Name; 1107 1108 ---------- 1109 -- Lock -- 1110 ---------- 1111 1112 procedure Lock is 1113 begin 1114 Name_Chars.Set_Last (Name_Chars.Last + Name_Chars_Reserve); 1115 Name_Entries.Set_Last (Name_Entries.Last + Name_Entries_Reserve); 1116 Name_Chars.Release; 1117 Name_Chars.Locked := True; 1118 Name_Entries.Release; 1119 Name_Entries.Locked := True; 1120 end Lock; 1121 1122 ---------------- 1123 -- Name_Enter -- 1124 ---------------- 1125 1126 function Name_Enter 1127 (Buf : Bounded_String := Global_Name_Buffer) return Valid_Name_Id 1128 is 1129 begin 1130 Name_Entries.Append 1131 ((Name_Chars_Index => Name_Chars.Last, 1132 Name_Len => Short (Buf.Length), 1133 Byte_Info => 0, 1134 Int_Info => 0, 1135 Boolean1_Info => False, 1136 Boolean2_Info => False, 1137 Boolean3_Info => False, 1138 Name_Has_No_Encodings => False, 1139 Hash_Link => No_Name)); 1140 1141 -- Set corresponding string entry in the Name_Chars table 1142 1143 for J in 1 .. Buf.Length loop 1144 Name_Chars.Append (Buf.Chars (J)); 1145 end loop; 1146 1147 Name_Chars.Append (ASCII.NUL); 1148 1149 return Name_Entries.Last; 1150 end Name_Enter; 1151 1152 function Name_Enter (S : String) return Valid_Name_Id is 1153 Buf : Bounded_String (Max_Length => S'Length); 1154 begin 1155 Append (Buf, S); 1156 return Name_Enter (Buf); 1157 end Name_Enter; 1158 1159 ------------------------ 1160 -- Name_Entries_Count -- 1161 ------------------------ 1162 1163 function Name_Entries_Count return Nat is 1164 begin 1165 return Int (Name_Entries.Last - Name_Entries.First + 1); 1166 end Name_Entries_Count; 1167 1168 --------------- 1169 -- Name_Find -- 1170 --------------- 1171 1172 function Name_Find 1173 (Buf : Bounded_String := Global_Name_Buffer) return Valid_Name_Id 1174 is 1175 New_Id : Name_Id; 1176 -- Id of entry in hash search, and value to be returned 1177 1178 S : Int; 1179 -- Pointer into string table 1180 1181 Hash_Index : Hash_Index_Type; 1182 -- Computed hash index 1183 1184 begin 1185 -- Quick handling for one character names 1186 1187 if Buf.Length = 1 then 1188 return Valid_Name_Id (First_Name_Id + Character'Pos (Buf.Chars (1))); 1189 1190 -- Otherwise search hash table for existing matching entry 1191 1192 else 1193 Hash_Index := Namet.Hash (Buf); 1194 New_Id := Hash_Table (Hash_Index); 1195 1196 if New_Id = No_Name then 1197 Hash_Table (Hash_Index) := Name_Entries.Last + 1; 1198 1199 else 1200 Search : loop 1201 if Buf.Length /= 1202 Integer (Name_Entries.Table (New_Id).Name_Len) 1203 then 1204 goto No_Match; 1205 end if; 1206 1207 S := Name_Entries.Table (New_Id).Name_Chars_Index; 1208 1209 for J in 1 .. Buf.Length loop 1210 if Name_Chars.Table (S + Int (J)) /= Buf.Chars (J) then 1211 goto No_Match; 1212 end if; 1213 end loop; 1214 1215 return New_Id; 1216 1217 -- Current entry in hash chain does not match 1218 1219 <<No_Match>> 1220 if Name_Entries.Table (New_Id).Hash_Link /= No_Name then 1221 New_Id := Name_Entries.Table (New_Id).Hash_Link; 1222 else 1223 Name_Entries.Table (New_Id).Hash_Link := 1224 Name_Entries.Last + 1; 1225 exit Search; 1226 end if; 1227 end loop Search; 1228 end if; 1229 1230 -- We fall through here only if a matching entry was not found in the 1231 -- hash table. We now create a new entry in the names table. The hash 1232 -- link pointing to the new entry (Name_Entries.Last+1) has been set. 1233 1234 Name_Entries.Append 1235 ((Name_Chars_Index => Name_Chars.Last, 1236 Name_Len => Short (Buf.Length), 1237 Hash_Link => No_Name, 1238 Name_Has_No_Encodings => False, 1239 Int_Info => 0, 1240 Byte_Info => 0, 1241 Boolean1_Info => False, 1242 Boolean2_Info => False, 1243 Boolean3_Info => False)); 1244 1245 -- Set corresponding string entry in the Name_Chars table 1246 1247 for J in 1 .. Buf.Length loop 1248 Name_Chars.Append (Buf.Chars (J)); 1249 end loop; 1250 1251 Name_Chars.Append (ASCII.NUL); 1252 1253 return Name_Entries.Last; 1254 end if; 1255 end Name_Find; 1256 1257 function Name_Find (S : String) return Valid_Name_Id is 1258 Buf : Bounded_String (Max_Length => S'Length); 1259 begin 1260 Append (Buf, S); 1261 return Name_Find (Buf); 1262 end Name_Find; 1263 1264 ------------- 1265 -- Nam_In -- 1266 ------------- 1267 1268 function Nam_In 1269 (T : Name_Id; 1270 V1 : Name_Id; 1271 V2 : Name_Id) return Boolean 1272 is 1273 begin 1274 return T = V1 or else 1275 T = V2; 1276 end Nam_In; 1277 1278 function Nam_In 1279 (T : Name_Id; 1280 V1 : Name_Id; 1281 V2 : Name_Id; 1282 V3 : Name_Id) return Boolean 1283 is 1284 begin 1285 return T = V1 or else 1286 T = V2 or else 1287 T = V3; 1288 end Nam_In; 1289 1290 function Nam_In 1291 (T : Name_Id; 1292 V1 : Name_Id; 1293 V2 : Name_Id; 1294 V3 : Name_Id; 1295 V4 : Name_Id) return Boolean 1296 is 1297 begin 1298 return T = V1 or else 1299 T = V2 or else 1300 T = V3 or else 1301 T = V4; 1302 end Nam_In; 1303 1304 function Nam_In 1305 (T : Name_Id; 1306 V1 : Name_Id; 1307 V2 : Name_Id; 1308 V3 : Name_Id; 1309 V4 : Name_Id; 1310 V5 : Name_Id) return Boolean 1311 is 1312 begin 1313 return T = V1 or else 1314 T = V2 or else 1315 T = V3 or else 1316 T = V4 or else 1317 T = V5; 1318 end Nam_In; 1319 1320 function Nam_In 1321 (T : Name_Id; 1322 V1 : Name_Id; 1323 V2 : Name_Id; 1324 V3 : Name_Id; 1325 V4 : Name_Id; 1326 V5 : Name_Id; 1327 V6 : Name_Id) return Boolean 1328 is 1329 begin 1330 return T = V1 or else 1331 T = V2 or else 1332 T = V3 or else 1333 T = V4 or else 1334 T = V5 or else 1335 T = V6; 1336 end Nam_In; 1337 1338 function Nam_In 1339 (T : Name_Id; 1340 V1 : Name_Id; 1341 V2 : Name_Id; 1342 V3 : Name_Id; 1343 V4 : Name_Id; 1344 V5 : Name_Id; 1345 V6 : Name_Id; 1346 V7 : Name_Id) return Boolean 1347 is 1348 begin 1349 return T = V1 or else 1350 T = V2 or else 1351 T = V3 or else 1352 T = V4 or else 1353 T = V5 or else 1354 T = V6 or else 1355 T = V7; 1356 end Nam_In; 1357 1358 function Nam_In 1359 (T : Name_Id; 1360 V1 : Name_Id; 1361 V2 : Name_Id; 1362 V3 : Name_Id; 1363 V4 : Name_Id; 1364 V5 : Name_Id; 1365 V6 : Name_Id; 1366 V7 : Name_Id; 1367 V8 : Name_Id) return Boolean 1368 is 1369 begin 1370 return T = V1 or else 1371 T = V2 or else 1372 T = V3 or else 1373 T = V4 or else 1374 T = V5 or else 1375 T = V6 or else 1376 T = V7 or else 1377 T = V8; 1378 end Nam_In; 1379 1380 function Nam_In 1381 (T : Name_Id; 1382 V1 : Name_Id; 1383 V2 : Name_Id; 1384 V3 : Name_Id; 1385 V4 : Name_Id; 1386 V5 : Name_Id; 1387 V6 : Name_Id; 1388 V7 : Name_Id; 1389 V8 : Name_Id; 1390 V9 : Name_Id) return Boolean 1391 is 1392 begin 1393 return T = V1 or else 1394 T = V2 or else 1395 T = V3 or else 1396 T = V4 or else 1397 T = V5 or else 1398 T = V6 or else 1399 T = V7 or else 1400 T = V8 or else 1401 T = V9; 1402 end Nam_In; 1403 1404 function Nam_In 1405 (T : Name_Id; 1406 V1 : Name_Id; 1407 V2 : Name_Id; 1408 V3 : Name_Id; 1409 V4 : Name_Id; 1410 V5 : Name_Id; 1411 V6 : Name_Id; 1412 V7 : Name_Id; 1413 V8 : Name_Id; 1414 V9 : Name_Id; 1415 V10 : Name_Id) return Boolean 1416 is 1417 begin 1418 return T = V1 or else 1419 T = V2 or else 1420 T = V3 or else 1421 T = V4 or else 1422 T = V5 or else 1423 T = V6 or else 1424 T = V7 or else 1425 T = V8 or else 1426 T = V9 or else 1427 T = V10; 1428 end Nam_In; 1429 1430 function Nam_In 1431 (T : Name_Id; 1432 V1 : Name_Id; 1433 V2 : Name_Id; 1434 V3 : Name_Id; 1435 V4 : Name_Id; 1436 V5 : Name_Id; 1437 V6 : Name_Id; 1438 V7 : Name_Id; 1439 V8 : Name_Id; 1440 V9 : Name_Id; 1441 V10 : Name_Id; 1442 V11 : Name_Id) return Boolean 1443 is 1444 begin 1445 return T = V1 or else 1446 T = V2 or else 1447 T = V3 or else 1448 T = V4 or else 1449 T = V5 or else 1450 T = V6 or else 1451 T = V7 or else 1452 T = V8 or else 1453 T = V9 or else 1454 T = V10 or else 1455 T = V11; 1456 end Nam_In; 1457 1458 function Nam_In 1459 (T : Name_Id; 1460 V1 : Name_Id; 1461 V2 : Name_Id; 1462 V3 : Name_Id; 1463 V4 : Name_Id; 1464 V5 : Name_Id; 1465 V6 : Name_Id; 1466 V7 : Name_Id; 1467 V8 : Name_Id; 1468 V9 : Name_Id; 1469 V10 : Name_Id; 1470 V11 : Name_Id; 1471 V12 : Name_Id) return Boolean 1472 is 1473 begin 1474 return T = V1 or else 1475 T = V2 or else 1476 T = V3 or else 1477 T = V4 or else 1478 T = V5 or else 1479 T = V6 or else 1480 T = V7 or else 1481 T = V8 or else 1482 T = V9 or else 1483 T = V10 or else 1484 T = V11 or else 1485 T = V12; 1486 end Nam_In; 1487 1488 ----------------- 1489 -- Name_Equals -- 1490 ----------------- 1491 1492 function Name_Equals 1493 (N1 : Valid_Name_Id; 1494 N2 : Valid_Name_Id) return Boolean 1495 is 1496 begin 1497 return N1 = N2 or else Get_Name_String (N1) = Get_Name_String (N2); 1498 end Name_Equals; 1499 1500 ------------------ 1501 -- Reinitialize -- 1502 ------------------ 1503 1504 procedure Reinitialize is 1505 begin 1506 Name_Chars.Init; 1507 Name_Entries.Init; 1508 1509 -- Initialize entries for one character names 1510 1511 for C in Character loop 1512 Name_Entries.Append 1513 ((Name_Chars_Index => Name_Chars.Last, 1514 Name_Len => 1, 1515 Byte_Info => 0, 1516 Int_Info => 0, 1517 Boolean1_Info => False, 1518 Boolean2_Info => False, 1519 Boolean3_Info => False, 1520 Name_Has_No_Encodings => True, 1521 Hash_Link => No_Name)); 1522 1523 Name_Chars.Append (C); 1524 Name_Chars.Append (ASCII.NUL); 1525 end loop; 1526 1527 -- Clear hash table 1528 1529 for J in Hash_Index_Type loop 1530 Hash_Table (J) := No_Name; 1531 end loop; 1532 end Reinitialize; 1533 1534 ---------------------- 1535 -- Reset_Name_Table -- 1536 ---------------------- 1537 1538 procedure Reset_Name_Table is 1539 begin 1540 for J in First_Name_Id .. Name_Entries.Last loop 1541 Name_Entries.Table (J).Int_Info := 0; 1542 Name_Entries.Table (J).Byte_Info := 0; 1543 end loop; 1544 end Reset_Name_Table; 1545 1546 -------------------------------- 1547 -- Set_Character_Literal_Name -- 1548 -------------------------------- 1549 1550 procedure Set_Character_Literal_Name 1551 (Buf : in out Bounded_String; 1552 C : Char_Code) 1553 is 1554 begin 1555 Buf.Length := 0; 1556 Append (Buf, 'Q'); 1557 Append_Encoded (Buf, C); 1558 end Set_Character_Literal_Name; 1559 1560 procedure Set_Character_Literal_Name (C : Char_Code) is 1561 begin 1562 Set_Character_Literal_Name (Global_Name_Buffer, C); 1563 end Set_Character_Literal_Name; 1564 1565 ----------------------------- 1566 -- Set_Name_Table_Boolean1 -- 1567 ----------------------------- 1568 1569 procedure Set_Name_Table_Boolean1 (Id : Valid_Name_Id; Val : Boolean) is 1570 begin 1571 pragma Assert (Is_Valid_Name (Id)); 1572 Name_Entries.Table (Id).Boolean1_Info := Val; 1573 end Set_Name_Table_Boolean1; 1574 1575 ----------------------------- 1576 -- Set_Name_Table_Boolean2 -- 1577 ----------------------------- 1578 1579 procedure Set_Name_Table_Boolean2 (Id : Valid_Name_Id; Val : Boolean) is 1580 begin 1581 pragma Assert (Is_Valid_Name (Id)); 1582 Name_Entries.Table (Id).Boolean2_Info := Val; 1583 end Set_Name_Table_Boolean2; 1584 1585 ----------------------------- 1586 -- Set_Name_Table_Boolean3 -- 1587 ----------------------------- 1588 1589 procedure Set_Name_Table_Boolean3 (Id : Valid_Name_Id; Val : Boolean) is 1590 begin 1591 pragma Assert (Is_Valid_Name (Id)); 1592 Name_Entries.Table (Id).Boolean3_Info := Val; 1593 end Set_Name_Table_Boolean3; 1594 1595 ------------------------- 1596 -- Set_Name_Table_Byte -- 1597 ------------------------- 1598 1599 procedure Set_Name_Table_Byte (Id : Valid_Name_Id; Val : Byte) is 1600 begin 1601 pragma Assert (Is_Valid_Name (Id)); 1602 Name_Entries.Table (Id).Byte_Info := Val; 1603 end Set_Name_Table_Byte; 1604 1605 ------------------------- 1606 -- Set_Name_Table_Int -- 1607 ------------------------- 1608 1609 procedure Set_Name_Table_Int (Id : Valid_Name_Id; Val : Int) is 1610 begin 1611 pragma Assert (Is_Valid_Name (Id)); 1612 Name_Entries.Table (Id).Int_Info := Val; 1613 end Set_Name_Table_Int; 1614 1615 ----------------------------- 1616 -- Store_Encoded_Character -- 1617 ----------------------------- 1618 1619 procedure Store_Encoded_Character (C : Char_Code) is 1620 begin 1621 Append_Encoded (Global_Name_Buffer, C); 1622 end Store_Encoded_Character; 1623 1624 -------------------------------------- 1625 -- Strip_Qualification_And_Suffixes -- 1626 -------------------------------------- 1627 1628 procedure Strip_Qualification_And_Suffixes (Buf : in out Bounded_String) is 1629 J : Integer; 1630 1631 begin 1632 -- Strip package body qualification string off end 1633 1634 for J in reverse 2 .. Buf.Length loop 1635 if Buf.Chars (J) = 'X' then 1636 Buf.Length := J - 1; 1637 exit; 1638 end if; 1639 1640 exit when Buf.Chars (J) /= 'b' 1641 and then Buf.Chars (J) /= 'n' 1642 and then Buf.Chars (J) /= 'p'; 1643 end loop; 1644 1645 -- Find rightmost __ or $ separator if one exists. First we position 1646 -- to start the search. If we have a character constant, position 1647 -- just before it, otherwise position to last character but one 1648 1649 if Buf.Chars (Buf.Length) = ''' then 1650 J := Buf.Length - 2; 1651 while J > 0 and then Buf.Chars (J) /= ''' loop 1652 J := J - 1; 1653 end loop; 1654 1655 else 1656 J := Buf.Length - 1; 1657 end if; 1658 1659 -- Loop to search for rightmost __ or $ (homonym) separator 1660 1661 while J > 1 loop 1662 1663 -- If $ separator, homonym separator, so strip it and keep looking 1664 1665 if Buf.Chars (J) = '$' then 1666 Buf.Length := J - 1; 1667 J := Buf.Length - 1; 1668 1669 -- Else check for __ found 1670 1671 elsif Buf.Chars (J) = '_' and then Buf.Chars (J + 1) = '_' then 1672 1673 -- Found __ so see if digit follows, and if so, this is a 1674 -- homonym separator, so strip it and keep looking. 1675 1676 if Buf.Chars (J + 2) in '0' .. '9' then 1677 Buf.Length := J - 1; 1678 J := Buf.Length - 1; 1679 1680 -- If not a homonym separator, then we simply strip the 1681 -- separator and everything that precedes it, and we are done 1682 1683 else 1684 Buf.Chars (1 .. Buf.Length - J - 1) := 1685 Buf.Chars (J + 2 .. Buf.Length); 1686 Buf.Length := Buf.Length - J - 1; 1687 exit; 1688 end if; 1689 1690 else 1691 J := J - 1; 1692 end if; 1693 end loop; 1694 end Strip_Qualification_And_Suffixes; 1695 1696 --------------- 1697 -- To_String -- 1698 --------------- 1699 1700 function To_String (Buf : Bounded_String) return String is 1701 begin 1702 return Buf.Chars (1 .. Buf.Length); 1703 end To_String; 1704 1705 --------------- 1706 -- Tree_Read -- 1707 --------------- 1708 1709 procedure Tree_Read is 1710 begin 1711 Name_Chars.Tree_Read; 1712 Name_Entries.Tree_Read; 1713 1714 Tree_Read_Data 1715 (Hash_Table'Address, 1716 Hash_Table'Length * (Hash_Table'Component_Size / Storage_Unit)); 1717 end Tree_Read; 1718 1719 ---------------- 1720 -- Tree_Write -- 1721 ---------------- 1722 1723 procedure Tree_Write is 1724 begin 1725 Name_Chars.Tree_Write; 1726 Name_Entries.Tree_Write; 1727 1728 Tree_Write_Data 1729 (Hash_Table'Address, 1730 Hash_Table'Length * (Hash_Table'Component_Size / Storage_Unit)); 1731 end Tree_Write; 1732 1733 ------------ 1734 -- Unlock -- 1735 ------------ 1736 1737 procedure Unlock is 1738 begin 1739 Name_Chars.Locked := False; 1740 Name_Chars.Set_Last (Name_Chars.Last - Name_Chars_Reserve); 1741 Name_Chars.Release; 1742 Name_Entries.Locked := False; 1743 Name_Entries.Set_Last (Name_Entries.Last - Name_Entries_Reserve); 1744 Name_Entries.Release; 1745 end Unlock; 1746 1747 -------- 1748 -- wn -- 1749 -------- 1750 1751 procedure wn (Id : Name_Id) is 1752 begin 1753 if Is_Valid_Name (Id) then 1754 declare 1755 Buf : Bounded_String (Max_Length => Natural (Length_Of_Name (Id))); 1756 begin 1757 Append (Buf, Id); 1758 Write_Str (Buf.Chars (1 .. Buf.Length)); 1759 end; 1760 1761 elsif Id = No_Name then 1762 Write_Str ("<No_Name>"); 1763 1764 elsif Id = Error_Name then 1765 Write_Str ("<Error_Name>"); 1766 1767 else 1768 Write_Str ("<invalid name_id>"); 1769 Write_Int (Int (Id)); 1770 end if; 1771 1772 Write_Eol; 1773 end wn; 1774 1775 ---------------- 1776 -- Write_Name -- 1777 ---------------- 1778 1779 procedure Write_Name (Id : Valid_Name_Id) is 1780 Buf : Bounded_String (Max_Length => Natural (Length_Of_Name (Id))); 1781 begin 1782 Append (Buf, Id); 1783 Write_Str (Buf.Chars (1 .. Buf.Length)); 1784 end Write_Name; 1785 1786 ------------------------ 1787 -- Write_Name_Decoded -- 1788 ------------------------ 1789 1790 procedure Write_Name_Decoded (Id : Valid_Name_Id) is 1791 Buf : Bounded_String; 1792 begin 1793 Append_Decoded (Buf, Id); 1794 Write_Str (Buf.Chars (1 .. Buf.Length)); 1795 end Write_Name_Decoded; 1796 1797-- Package initialization, initialize tables 1798 1799begin 1800 Reinitialize; 1801end Namet; 1802