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 632 (N : Name_Id; 633 C1 : out Character; 634 C2 : out Character) 635 is 636 NE : Name_Entry renames Name_Entries.Table (N); 637 NEL : constant Int := Int (NE.Name_Len); 638 639 begin 640 if NEL >= 2 then 641 C1 := Name_Chars.Table (NE.Name_Chars_Index + NEL - 1); 642 C2 := Name_Chars.Table (NE.Name_Chars_Index + NEL - 0); 643 else 644 C1 := ASCII.NUL; 645 C2 := ASCII.NUL; 646 end if; 647 end Get_Last_Two_Chars; 648 649 --------------------- 650 -- Get_Name_String -- 651 --------------------- 652 653 -- Procedure version leaving result in Name_Buffer, length in Name_Len 654 655 procedure Get_Name_String (Id : Name_Id) is 656 S : Int; 657 658 begin 659 pragma Assert (Id in Name_Entries.First .. Name_Entries.Last); 660 661 S := Name_Entries.Table (Id).Name_Chars_Index; 662 Name_Len := Natural (Name_Entries.Table (Id).Name_Len); 663 664 for J in 1 .. Name_Len loop 665 Name_Buffer (J) := Name_Chars.Table (S + Int (J)); 666 end loop; 667 end Get_Name_String; 668 669 --------------------- 670 -- Get_Name_String -- 671 --------------------- 672 673 -- Function version returning a string 674 675 function Get_Name_String (Id : Name_Id) return String is 676 S : Int; 677 678 begin 679 pragma Assert (Id in Name_Entries.First .. Name_Entries.Last); 680 S := Name_Entries.Table (Id).Name_Chars_Index; 681 682 declare 683 R : String (1 .. Natural (Name_Entries.Table (Id).Name_Len)); 684 685 begin 686 for J in R'Range loop 687 R (J) := Name_Chars.Table (S + Int (J)); 688 end loop; 689 690 return R; 691 end; 692 end Get_Name_String; 693 694 -------------------------------- 695 -- Get_Name_String_And_Append -- 696 -------------------------------- 697 698 procedure Get_Name_String_And_Append (Id : Name_Id) is 699 S : Int; 700 701 begin 702 pragma Assert (Id in Name_Entries.First .. Name_Entries.Last); 703 704 S := Name_Entries.Table (Id).Name_Chars_Index; 705 706 for J in 1 .. Natural (Name_Entries.Table (Id).Name_Len) loop 707 Name_Len := Name_Len + 1; 708 Name_Buffer (Name_Len) := Name_Chars.Table (S + Int (J)); 709 end loop; 710 end Get_Name_String_And_Append; 711 712 ----------------------------- 713 -- Get_Name_Table_Boolean1 -- 714 ----------------------------- 715 716 function Get_Name_Table_Boolean1 (Id : Name_Id) return Boolean is 717 begin 718 pragma Assert (Id in Name_Entries.First .. Name_Entries.Last); 719 return Name_Entries.Table (Id).Boolean1_Info; 720 end Get_Name_Table_Boolean1; 721 722 ----------------------------- 723 -- Get_Name_Table_Boolean2 -- 724 ----------------------------- 725 726 function Get_Name_Table_Boolean2 (Id : Name_Id) return Boolean is 727 begin 728 pragma Assert (Id in Name_Entries.First .. Name_Entries.Last); 729 return Name_Entries.Table (Id).Boolean2_Info; 730 end Get_Name_Table_Boolean2; 731 732 ----------------------------- 733 -- Get_Name_Table_Boolean3 -- 734 ----------------------------- 735 736 function Get_Name_Table_Boolean3 (Id : Name_Id) return Boolean is 737 begin 738 pragma Assert (Id in Name_Entries.First .. Name_Entries.Last); 739 return Name_Entries.Table (Id).Boolean3_Info; 740 end Get_Name_Table_Boolean3; 741 742 ------------------------- 743 -- Get_Name_Table_Byte -- 744 ------------------------- 745 746 function Get_Name_Table_Byte (Id : Name_Id) return Byte is 747 begin 748 pragma Assert (Id in Name_Entries.First .. Name_Entries.Last); 749 return Name_Entries.Table (Id).Byte_Info; 750 end Get_Name_Table_Byte; 751 752 ------------------------- 753 -- Get_Name_Table_Int -- 754 ------------------------- 755 756 function Get_Name_Table_Int (Id : Name_Id) return Int is 757 begin 758 pragma Assert (Id in Name_Entries.First .. Name_Entries.Last); 759 return Name_Entries.Table (Id).Int_Info; 760 end Get_Name_Table_Int; 761 762 ----------------------------------------- 763 -- Get_Unqualified_Decoded_Name_String -- 764 ----------------------------------------- 765 766 procedure Get_Unqualified_Decoded_Name_String (Id : Name_Id) is 767 begin 768 Get_Decoded_Name_String (Id); 769 Strip_Qualification_And_Suffixes; 770 end Get_Unqualified_Decoded_Name_String; 771 772 --------------------------------- 773 -- Get_Unqualified_Name_String -- 774 --------------------------------- 775 776 procedure Get_Unqualified_Name_String (Id : Name_Id) is 777 begin 778 Get_Name_String (Id); 779 Strip_Qualification_And_Suffixes; 780 end Get_Unqualified_Name_String; 781 782 ---------- 783 -- Hash -- 784 ---------- 785 786 function Hash return Hash_Index_Type is 787 788 -- This hash function looks at every character, in order to make it 789 -- likely that similar strings get different hash values. The rotate by 790 -- 7 bits has been determined empirically to be good, and it doesn't 791 -- lose bits like a shift would. The final conversion can't overflow, 792 -- because the table is 2**16 in size. This function probably needs to 793 -- be changed if the hash table size is changed. 794 795 -- Note that we could get some speed improvement by aligning the string 796 -- to 32 or 64 bits, and doing word-wise xor's. We could also implement 797 -- a growable table. It doesn't seem worth the trouble to do those 798 -- things, for now. 799 800 Result : Unsigned_16 := 0; 801 802 begin 803 for J in 1 .. Name_Len loop 804 Result := Rotate_Left (Result, 7) xor Character'Pos (Name_Buffer (J)); 805 end loop; 806 807 return Hash_Index_Type (Result); 808 end Hash; 809 810 ---------------- 811 -- Initialize -- 812 ---------------- 813 814 procedure Initialize is 815 begin 816 null; 817 end Initialize; 818 819 ------------------------------- 820 -- Insert_Str_In_Name_Buffer -- 821 ------------------------------- 822 823 procedure Insert_Str_In_Name_Buffer (S : String; Index : Positive) is 824 SL : constant Natural := S'Length; 825 begin 826 Name_Buffer (Index + SL .. Name_Len + SL) := 827 Name_Buffer (Index .. Name_Len); 828 Name_Buffer (Index .. Index + SL - 1) := S; 829 Name_Len := Name_Len + SL; 830 end Insert_Str_In_Name_Buffer; 831 832 ---------------------- 833 -- Is_Internal_Name -- 834 ---------------------- 835 836 -- Version taking an argument 837 838 function Is_Internal_Name (Id : Name_Id) return Boolean is 839 begin 840 if Id in Error_Name_Or_No_Name then 841 return False; 842 else 843 Get_Name_String (Id); 844 return Is_Internal_Name; 845 end if; 846 end Is_Internal_Name; 847 848 ---------------------- 849 -- Is_Internal_Name -- 850 ---------------------- 851 852 -- Version taking its input from Name_Buffer 853 854 function Is_Internal_Name return Boolean is 855 J : Natural; 856 857 begin 858 -- AAny name starting with underscore is internal 859 860 if Name_Buffer (1) = '_' 861 or else Name_Buffer (Name_Len) = '_' 862 then 863 return True; 864 865 -- Allow quoted character 866 867 elsif Name_Buffer (1) = ''' then 868 return False; 869 870 -- All other cases, scan name 871 872 else 873 -- Test backwards, because we only want to test the last entity 874 -- name if the name we have is qualified with other entities. 875 876 J := Name_Len; 877 while J /= 0 loop 878 879 -- Skip stuff between brackets (A-F OK there) 880 881 if Name_Buffer (J) = ']' then 882 loop 883 J := J - 1; 884 exit when J = 1 or else Name_Buffer (J) = '['; 885 end loop; 886 887 -- Test for internal letter 888 889 elsif Is_OK_Internal_Letter (Name_Buffer (J)) then 890 return True; 891 892 -- Quit if we come to terminating double underscore (note that 893 -- if the current character is an underscore, we know that 894 -- there is a previous character present, since we already 895 -- filtered out the case of Name_Buffer (1) = '_' above. 896 897 elsif Name_Buffer (J) = '_' 898 and then Name_Buffer (J - 1) = '_' 899 and then Name_Buffer (J - 2) /= '_' 900 then 901 return False; 902 end if; 903 904 J := J - 1; 905 end loop; 906 end if; 907 908 return False; 909 end Is_Internal_Name; 910 911 --------------------------- 912 -- Is_OK_Internal_Letter -- 913 --------------------------- 914 915 function Is_OK_Internal_Letter (C : Character) return Boolean is 916 begin 917 return C in 'A' .. 'Z' 918 and then C /= 'O' 919 and then C /= 'Q' 920 and then C /= 'U' 921 and then C /= 'W' 922 and then C /= 'X'; 923 end Is_OK_Internal_Letter; 924 925 ---------------------- 926 -- Is_Operator_Name -- 927 ---------------------- 928 929 function Is_Operator_Name (Id : Name_Id) return Boolean is 930 S : Int; 931 begin 932 pragma Assert (Id in Name_Entries.First .. Name_Entries.Last); 933 S := Name_Entries.Table (Id).Name_Chars_Index; 934 return Name_Chars.Table (S + 1) = 'O'; 935 end Is_Operator_Name; 936 937 ------------------- 938 -- Is_Valid_Name -- 939 ------------------- 940 941 function Is_Valid_Name (Id : Name_Id) return Boolean is 942 begin 943 return Id in Name_Entries.First .. Name_Entries.Last; 944 end Is_Valid_Name; 945 946 -------------------- 947 -- Length_Of_Name -- 948 -------------------- 949 950 function Length_Of_Name (Id : Name_Id) return Nat is 951 begin 952 return Int (Name_Entries.Table (Id).Name_Len); 953 end Length_Of_Name; 954 955 ---------- 956 -- Lock -- 957 ---------- 958 959 procedure Lock is 960 begin 961 Name_Chars.Set_Last (Name_Chars.Last + Name_Chars_Reserve); 962 Name_Entries.Set_Last (Name_Entries.Last + Name_Entries_Reserve); 963 Name_Chars.Locked := True; 964 Name_Entries.Locked := True; 965 Name_Chars.Release; 966 Name_Entries.Release; 967 end Lock; 968 969 ------------------------ 970 -- Name_Chars_Address -- 971 ------------------------ 972 973 function Name_Chars_Address return System.Address is 974 begin 975 return Name_Chars.Table (0)'Address; 976 end Name_Chars_Address; 977 978 ---------------- 979 -- Name_Enter -- 980 ---------------- 981 982 function Name_Enter return Name_Id is 983 begin 984 Name_Entries.Append 985 ((Name_Chars_Index => Name_Chars.Last, 986 Name_Len => Short (Name_Len), 987 Byte_Info => 0, 988 Int_Info => 0, 989 Boolean1_Info => False, 990 Boolean2_Info => False, 991 Boolean3_Info => False, 992 Name_Has_No_Encodings => False, 993 Hash_Link => No_Name)); 994 995 -- Set corresponding string entry in the Name_Chars table 996 997 for J in 1 .. Name_Len loop 998 Name_Chars.Append (Name_Buffer (J)); 999 end loop; 1000 1001 Name_Chars.Append (ASCII.NUL); 1002 1003 return Name_Entries.Last; 1004 end Name_Enter; 1005 1006 -------------------------- 1007 -- Name_Entries_Address -- 1008 -------------------------- 1009 1010 function Name_Entries_Address return System.Address is 1011 begin 1012 return Name_Entries.Table (First_Name_Id)'Address; 1013 end Name_Entries_Address; 1014 1015 ------------------------ 1016 -- Name_Entries_Count -- 1017 ------------------------ 1018 1019 function Name_Entries_Count return Nat is 1020 begin 1021 return Int (Name_Entries.Last - Name_Entries.First + 1); 1022 end Name_Entries_Count; 1023 1024 --------------- 1025 -- Name_Find -- 1026 --------------- 1027 1028 function Name_Find return Name_Id is 1029 New_Id : Name_Id; 1030 -- Id of entry in hash search, and value to be returned 1031 1032 S : Int; 1033 -- Pointer into string table 1034 1035 Hash_Index : Hash_Index_Type; 1036 -- Computed hash index 1037 1038 begin 1039 -- Quick handling for one character names 1040 1041 if Name_Len = 1 then 1042 return Name_Id (First_Name_Id + Character'Pos (Name_Buffer (1))); 1043 1044 -- Otherwise search hash table for existing matching entry 1045 1046 else 1047 Hash_Index := Namet.Hash; 1048 New_Id := Hash_Table (Hash_Index); 1049 1050 if New_Id = No_Name then 1051 Hash_Table (Hash_Index) := Name_Entries.Last + 1; 1052 1053 else 1054 Search : loop 1055 if Name_Len /= 1056 Integer (Name_Entries.Table (New_Id).Name_Len) 1057 then 1058 goto No_Match; 1059 end if; 1060 1061 S := Name_Entries.Table (New_Id).Name_Chars_Index; 1062 1063 for J in 1 .. Name_Len loop 1064 if Name_Chars.Table (S + Int (J)) /= Name_Buffer (J) then 1065 goto No_Match; 1066 end if; 1067 end loop; 1068 1069 return New_Id; 1070 1071 -- Current entry in hash chain does not match 1072 1073 <<No_Match>> 1074 if Name_Entries.Table (New_Id).Hash_Link /= No_Name then 1075 New_Id := Name_Entries.Table (New_Id).Hash_Link; 1076 else 1077 Name_Entries.Table (New_Id).Hash_Link := 1078 Name_Entries.Last + 1; 1079 exit Search; 1080 end if; 1081 end loop Search; 1082 end if; 1083 1084 -- We fall through here only if a matching entry was not found in the 1085 -- hash table. We now create a new entry in the names table. The hash 1086 -- link pointing to the new entry (Name_Entries.Last+1) has been set. 1087 1088 Name_Entries.Append 1089 ((Name_Chars_Index => Name_Chars.Last, 1090 Name_Len => Short (Name_Len), 1091 Hash_Link => No_Name, 1092 Name_Has_No_Encodings => False, 1093 Int_Info => 0, 1094 Byte_Info => 0, 1095 Boolean1_Info => False, 1096 Boolean2_Info => False, 1097 Boolean3_Info => False)); 1098 1099 -- Set corresponding string entry in the Name_Chars table 1100 1101 for J in 1 .. Name_Len loop 1102 Name_Chars.Append (Name_Buffer (J)); 1103 end loop; 1104 1105 Name_Chars.Append (ASCII.NUL); 1106 1107 return Name_Entries.Last; 1108 end if; 1109 end Name_Find; 1110 1111 ------------------- 1112 -- Name_Find_Str -- 1113 ------------------- 1114 1115 function Name_Find_Str (S : String) return Name_Id is 1116 begin 1117 Name_Len := S'Length; 1118 Name_Buffer (1 .. Name_Len) := S; 1119 return Name_Find; 1120 end Name_Find_Str; 1121 1122 ------------- 1123 -- Nam_In -- 1124 ------------- 1125 1126 function Nam_In 1127 (T : Name_Id; 1128 V1 : Name_Id; 1129 V2 : Name_Id) return Boolean 1130 is 1131 begin 1132 return T = V1 or else 1133 T = V2; 1134 end Nam_In; 1135 1136 function Nam_In 1137 (T : Name_Id; 1138 V1 : Name_Id; 1139 V2 : Name_Id; 1140 V3 : Name_Id) return Boolean 1141 is 1142 begin 1143 return T = V1 or else 1144 T = V2 or else 1145 T = V3; 1146 end Nam_In; 1147 1148 function Nam_In 1149 (T : Name_Id; 1150 V1 : Name_Id; 1151 V2 : Name_Id; 1152 V3 : Name_Id; 1153 V4 : Name_Id) return Boolean 1154 is 1155 begin 1156 return T = V1 or else 1157 T = V2 or else 1158 T = V3 or else 1159 T = V4; 1160 end Nam_In; 1161 1162 function Nam_In 1163 (T : Name_Id; 1164 V1 : Name_Id; 1165 V2 : Name_Id; 1166 V3 : Name_Id; 1167 V4 : Name_Id; 1168 V5 : Name_Id) return Boolean 1169 is 1170 begin 1171 return T = V1 or else 1172 T = V2 or else 1173 T = V3 or else 1174 T = V4 or else 1175 T = V5; 1176 end Nam_In; 1177 1178 function Nam_In 1179 (T : Name_Id; 1180 V1 : Name_Id; 1181 V2 : Name_Id; 1182 V3 : Name_Id; 1183 V4 : Name_Id; 1184 V5 : Name_Id; 1185 V6 : Name_Id) return Boolean 1186 is 1187 begin 1188 return T = V1 or else 1189 T = V2 or else 1190 T = V3 or else 1191 T = V4 or else 1192 T = V5 or else 1193 T = V6; 1194 end Nam_In; 1195 1196 function Nam_In 1197 (T : Name_Id; 1198 V1 : Name_Id; 1199 V2 : Name_Id; 1200 V3 : Name_Id; 1201 V4 : Name_Id; 1202 V5 : Name_Id; 1203 V6 : Name_Id; 1204 V7 : Name_Id) return Boolean 1205 is 1206 begin 1207 return T = V1 or else 1208 T = V2 or else 1209 T = V3 or else 1210 T = V4 or else 1211 T = V5 or else 1212 T = V6 or else 1213 T = V7; 1214 end Nam_In; 1215 1216 function Nam_In 1217 (T : Name_Id; 1218 V1 : Name_Id; 1219 V2 : Name_Id; 1220 V3 : Name_Id; 1221 V4 : Name_Id; 1222 V5 : Name_Id; 1223 V6 : Name_Id; 1224 V7 : Name_Id; 1225 V8 : Name_Id) return Boolean 1226 is 1227 begin 1228 return T = V1 or else 1229 T = V2 or else 1230 T = V3 or else 1231 T = V4 or else 1232 T = V5 or else 1233 T = V6 or else 1234 T = V7 or else 1235 T = V8; 1236 end Nam_In; 1237 1238 function Nam_In 1239 (T : Name_Id; 1240 V1 : Name_Id; 1241 V2 : Name_Id; 1242 V3 : Name_Id; 1243 V4 : Name_Id; 1244 V5 : Name_Id; 1245 V6 : Name_Id; 1246 V7 : Name_Id; 1247 V8 : Name_Id; 1248 V9 : Name_Id) return Boolean 1249 is 1250 begin 1251 return T = V1 or else 1252 T = V2 or else 1253 T = V3 or else 1254 T = V4 or else 1255 T = V5 or else 1256 T = V6 or else 1257 T = V7 or else 1258 T = V8 or else 1259 T = V9; 1260 end Nam_In; 1261 1262 function Nam_In 1263 (T : Name_Id; 1264 V1 : Name_Id; 1265 V2 : Name_Id; 1266 V3 : Name_Id; 1267 V4 : Name_Id; 1268 V5 : Name_Id; 1269 V6 : Name_Id; 1270 V7 : Name_Id; 1271 V8 : Name_Id; 1272 V9 : Name_Id; 1273 V10 : Name_Id) return Boolean 1274 is 1275 begin 1276 return T = V1 or else 1277 T = V2 or else 1278 T = V3 or else 1279 T = V4 or else 1280 T = V5 or else 1281 T = V6 or else 1282 T = V7 or else 1283 T = V8 or else 1284 T = V9 or else 1285 T = V10; 1286 end Nam_In; 1287 1288 function Nam_In 1289 (T : Name_Id; 1290 V1 : Name_Id; 1291 V2 : Name_Id; 1292 V3 : Name_Id; 1293 V4 : Name_Id; 1294 V5 : Name_Id; 1295 V6 : Name_Id; 1296 V7 : Name_Id; 1297 V8 : Name_Id; 1298 V9 : Name_Id; 1299 V10 : Name_Id; 1300 V11 : Name_Id) return Boolean 1301 is 1302 begin 1303 return T = V1 or else 1304 T = V2 or else 1305 T = V3 or else 1306 T = V4 or else 1307 T = V5 or else 1308 T = V6 or else 1309 T = V7 or else 1310 T = V8 or else 1311 T = V9 or else 1312 T = V10 or else 1313 T = V11; 1314 end Nam_In; 1315 1316 ----------------- 1317 -- Name_Equals -- 1318 ----------------- 1319 1320 function Name_Equals (N1 : Name_Id; N2 : Name_Id) return Boolean is 1321 begin 1322 if N1 = N2 then 1323 return True; 1324 end if; 1325 1326 declare 1327 L1 : constant Int := Int (Name_Entries.Table (N1).Name_Len); 1328 L2 : constant Int := Int (Name_Entries.Table (N2).Name_Len); 1329 1330 begin 1331 if L1 /= L2 then 1332 return False; 1333 end if; 1334 1335 declare 1336 use Name_Chars; 1337 I1 : constant Int := Name_Entries.Table (N1).Name_Chars_Index; 1338 I2 : constant Int := Name_Entries.Table (N2).Name_Chars_Index; 1339 1340 begin 1341 return (Name_Chars.Table (1 + I1 .. I1 + L1) = 1342 Name_Chars.Table (1 + I2 .. I2 + L2)); 1343 end; 1344 end; 1345 end Name_Equals; 1346 1347 ------------------ 1348 -- Reinitialize -- 1349 ------------------ 1350 1351 procedure Reinitialize is 1352 begin 1353 Name_Chars.Init; 1354 Name_Entries.Init; 1355 1356 -- Initialize entries for one character names 1357 1358 for C in Character loop 1359 Name_Entries.Append 1360 ((Name_Chars_Index => Name_Chars.Last, 1361 Name_Len => 1, 1362 Byte_Info => 0, 1363 Int_Info => 0, 1364 Boolean1_Info => False, 1365 Boolean2_Info => False, 1366 Boolean3_Info => False, 1367 Name_Has_No_Encodings => True, 1368 Hash_Link => No_Name)); 1369 1370 Name_Chars.Append (C); 1371 Name_Chars.Append (ASCII.NUL); 1372 end loop; 1373 1374 -- Clear hash table 1375 1376 for J in Hash_Index_Type loop 1377 Hash_Table (J) := No_Name; 1378 end loop; 1379 end Reinitialize; 1380 1381 ---------------------- 1382 -- Reset_Name_Table -- 1383 ---------------------- 1384 1385 procedure Reset_Name_Table is 1386 begin 1387 for J in First_Name_Id .. Name_Entries.Last loop 1388 Name_Entries.Table (J).Int_Info := 0; 1389 Name_Entries.Table (J).Byte_Info := 0; 1390 end loop; 1391 end Reset_Name_Table; 1392 1393 -------------------------------- 1394 -- Set_Character_Literal_Name -- 1395 -------------------------------- 1396 1397 procedure Set_Character_Literal_Name (C : Char_Code) is 1398 begin 1399 Name_Buffer (1) := 'Q'; 1400 Name_Len := 1; 1401 Store_Encoded_Character (C); 1402 end Set_Character_Literal_Name; 1403 1404 ----------------------------- 1405 -- Set_Name_Table_Boolean1 -- 1406 ----------------------------- 1407 1408 procedure Set_Name_Table_Boolean1 (Id : Name_Id; Val : Boolean) is 1409 begin 1410 pragma Assert (Id in Name_Entries.First .. Name_Entries.Last); 1411 Name_Entries.Table (Id).Boolean1_Info := Val; 1412 end Set_Name_Table_Boolean1; 1413 1414 ----------------------------- 1415 -- Set_Name_Table_Boolean2 -- 1416 ----------------------------- 1417 1418 procedure Set_Name_Table_Boolean2 (Id : Name_Id; Val : Boolean) is 1419 begin 1420 pragma Assert (Id in Name_Entries.First .. Name_Entries.Last); 1421 Name_Entries.Table (Id).Boolean2_Info := Val; 1422 end Set_Name_Table_Boolean2; 1423 1424 ----------------------------- 1425 -- Set_Name_Table_Boolean3 -- 1426 ----------------------------- 1427 1428 procedure Set_Name_Table_Boolean3 (Id : Name_Id; Val : Boolean) is 1429 begin 1430 pragma Assert (Id in Name_Entries.First .. Name_Entries.Last); 1431 Name_Entries.Table (Id).Boolean3_Info := Val; 1432 end Set_Name_Table_Boolean3; 1433 1434 ------------------------- 1435 -- Set_Name_Table_Byte -- 1436 ------------------------- 1437 1438 procedure Set_Name_Table_Byte (Id : Name_Id; Val : Byte) is 1439 begin 1440 pragma Assert (Id in Name_Entries.First .. Name_Entries.Last); 1441 Name_Entries.Table (Id).Byte_Info := Val; 1442 end Set_Name_Table_Byte; 1443 1444 ------------------------- 1445 -- Set_Name_Table_Int -- 1446 ------------------------- 1447 1448 procedure Set_Name_Table_Int (Id : Name_Id; Val : Int) is 1449 begin 1450 pragma Assert (Id in Name_Entries.First .. Name_Entries.Last); 1451 Name_Entries.Table (Id).Int_Info := Val; 1452 end Set_Name_Table_Int; 1453 1454 ----------------------------- 1455 -- Store_Encoded_Character -- 1456 ----------------------------- 1457 1458 procedure Store_Encoded_Character (C : Char_Code) is 1459 procedure Set_Hex_Chars (C : Char_Code); 1460 -- Stores given value, which is in the range 0 .. 255, as two hex 1461 -- digits (using lower case a-f) in Name_Buffer, incrementing Name_Len. 1462 1463 ------------------- 1464 -- Set_Hex_Chars -- 1465 ------------------- 1466 1467 procedure Set_Hex_Chars (C : Char_Code) is 1468 Hexd : constant String := "0123456789abcdef"; 1469 N : constant Natural := Natural (C); 1470 begin 1471 Name_Buffer (Name_Len + 1) := Hexd (N / 16 + 1); 1472 Name_Buffer (Name_Len + 2) := Hexd (N mod 16 + 1); 1473 Name_Len := Name_Len + 2; 1474 end Set_Hex_Chars; 1475 1476 -- Start of processing for Store_Encoded_Character 1477 1478 begin 1479 Name_Len := Name_Len + 1; 1480 1481 if In_Character_Range (C) then 1482 declare 1483 CC : constant Character := Get_Character (C); 1484 begin 1485 if CC in 'a' .. 'z' or else CC in '0' .. '9' then 1486 Name_Buffer (Name_Len) := CC; 1487 else 1488 Name_Buffer (Name_Len) := 'U'; 1489 Set_Hex_Chars (C); 1490 end if; 1491 end; 1492 1493 elsif In_Wide_Character_Range (C) then 1494 Name_Buffer (Name_Len) := 'W'; 1495 Set_Hex_Chars (C / 256); 1496 Set_Hex_Chars (C mod 256); 1497 1498 else 1499 Name_Buffer (Name_Len) := 'W'; 1500 Name_Len := Name_Len + 1; 1501 Name_Buffer (Name_Len) := 'W'; 1502 Set_Hex_Chars (C / 2 ** 24); 1503 Set_Hex_Chars ((C / 2 ** 16) mod 256); 1504 Set_Hex_Chars ((C / 256) mod 256); 1505 Set_Hex_Chars (C mod 256); 1506 end if; 1507 end Store_Encoded_Character; 1508 1509 -------------------------------------- 1510 -- Strip_Qualification_And_Suffixes -- 1511 -------------------------------------- 1512 1513 procedure Strip_Qualification_And_Suffixes is 1514 J : Integer; 1515 1516 begin 1517 -- Strip package body qualification string off end 1518 1519 for J in reverse 2 .. Name_Len loop 1520 if Name_Buffer (J) = 'X' then 1521 Name_Len := J - 1; 1522 exit; 1523 end if; 1524 1525 exit when Name_Buffer (J) /= 'b' 1526 and then Name_Buffer (J) /= 'n' 1527 and then Name_Buffer (J) /= 'p'; 1528 end loop; 1529 1530 -- Find rightmost __ or $ separator if one exists. First we position 1531 -- to start the search. If we have a character constant, position 1532 -- just before it, otherwise position to last character but one 1533 1534 if Name_Buffer (Name_Len) = ''' then 1535 J := Name_Len - 2; 1536 while J > 0 and then Name_Buffer (J) /= ''' loop 1537 J := J - 1; 1538 end loop; 1539 1540 else 1541 J := Name_Len - 1; 1542 end if; 1543 1544 -- Loop to search for rightmost __ or $ (homonym) separator 1545 1546 while J > 1 loop 1547 1548 -- If $ separator, homonym separator, so strip it and keep looking 1549 1550 if Name_Buffer (J) = '$' then 1551 Name_Len := J - 1; 1552 J := Name_Len - 1; 1553 1554 -- Else check for __ found 1555 1556 elsif Name_Buffer (J) = '_' and then Name_Buffer (J + 1) = '_' then 1557 1558 -- Found __ so see if digit follows, and if so, this is a 1559 -- homonym separator, so strip it and keep looking. 1560 1561 if Name_Buffer (J + 2) in '0' .. '9' then 1562 Name_Len := J - 1; 1563 J := Name_Len - 1; 1564 1565 -- If not a homonym separator, then we simply strip the 1566 -- separator and everything that precedes it, and we are done 1567 1568 else 1569 Name_Buffer (1 .. Name_Len - J - 1) := 1570 Name_Buffer (J + 2 .. Name_Len); 1571 Name_Len := Name_Len - J - 1; 1572 exit; 1573 end if; 1574 1575 else 1576 J := J - 1; 1577 end if; 1578 end loop; 1579 end Strip_Qualification_And_Suffixes; 1580 1581 --------------- 1582 -- Tree_Read -- 1583 --------------- 1584 1585 procedure Tree_Read is 1586 begin 1587 Name_Chars.Tree_Read; 1588 Name_Entries.Tree_Read; 1589 1590 Tree_Read_Data 1591 (Hash_Table'Address, 1592 Hash_Table'Length * (Hash_Table'Component_Size / Storage_Unit)); 1593 end Tree_Read; 1594 1595 ---------------- 1596 -- Tree_Write -- 1597 ---------------- 1598 1599 procedure Tree_Write is 1600 begin 1601 Name_Chars.Tree_Write; 1602 Name_Entries.Tree_Write; 1603 1604 Tree_Write_Data 1605 (Hash_Table'Address, 1606 Hash_Table'Length * (Hash_Table'Component_Size / Storage_Unit)); 1607 end Tree_Write; 1608 1609 ------------ 1610 -- Unlock -- 1611 ------------ 1612 1613 procedure Unlock is 1614 begin 1615 Name_Chars.Set_Last (Name_Chars.Last - Name_Chars_Reserve); 1616 Name_Entries.Set_Last (Name_Entries.Last - Name_Entries_Reserve); 1617 Name_Chars.Locked := False; 1618 Name_Entries.Locked := False; 1619 Name_Chars.Release; 1620 Name_Entries.Release; 1621 end Unlock; 1622 1623 -------- 1624 -- wn -- 1625 -------- 1626 1627 procedure wn (Id : Name_Id) is 1628 S : Int; 1629 1630 begin 1631 if not Id'Valid then 1632 Write_Str ("<invalid name_id>"); 1633 1634 elsif Id = No_Name then 1635 Write_Str ("<No_Name>"); 1636 1637 elsif Id = Error_Name then 1638 Write_Str ("<Error_Name>"); 1639 1640 else 1641 S := Name_Entries.Table (Id).Name_Chars_Index; 1642 Name_Len := Natural (Name_Entries.Table (Id).Name_Len); 1643 1644 for J in 1 .. Name_Len loop 1645 Write_Char (Name_Chars.Table (S + Int (J))); 1646 end loop; 1647 end if; 1648 1649 Write_Eol; 1650 end wn; 1651 1652 ---------------- 1653 -- Write_Name -- 1654 ---------------- 1655 1656 procedure Write_Name (Id : Name_Id) is 1657 begin 1658 if Id >= First_Name_Id then 1659 Get_Name_String (Id); 1660 Write_Str (Name_Buffer (1 .. Name_Len)); 1661 end if; 1662 end Write_Name; 1663 1664 ------------------------ 1665 -- Write_Name_Decoded -- 1666 ------------------------ 1667 1668 procedure Write_Name_Decoded (Id : Name_Id) is 1669 begin 1670 if Id >= First_Name_Id then 1671 Get_Decoded_Name_String (Id); 1672 Write_Str (Name_Buffer (1 .. Name_Len)); 1673 end if; 1674 end Write_Name_Decoded; 1675 1676-- Package initialization, initialize tables 1677 1678begin 1679 Reinitialize; 1680end Namet; 1681