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