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