1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- N A M E T -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 1992-2021, Free Software Foundation, Inc. -- 10-- -- 11-- GNAT is free software; you can redistribute it and/or modify it under -- 12-- terms of the GNU General Public License as published by the Free Soft- -- 13-- ware Foundation; either version 3, or (at your option) any later ver- -- 14-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- 15-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- 16-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- 17-- for more details. You should have received a copy of the GNU General -- 18-- Public License distributed with GNAT; see file COPYING3. If not, go to -- 19-- http://www.gnu.org/licenses for a complete copy of the license. -- 20-- -- 21-- GNAT was originally developed by the GNAT team at New York University. -- 22-- Extensive contributions were provided by Ada Core Technologies Inc. -- 23-- -- 24------------------------------------------------------------------------------ 25 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 Hash_Link => No_Name, 1137 Name_Has_No_Encodings => False, 1138 Boolean1_Info => False, 1139 Boolean2_Info => False, 1140 Boolean3_Info => False, 1141 Spare => False)); 1142 1143 -- Set corresponding string entry in the Name_Chars table 1144 1145 for J in 1 .. Buf.Length loop 1146 Name_Chars.Append (Buf.Chars (J)); 1147 end loop; 1148 1149 Name_Chars.Append (ASCII.NUL); 1150 1151 return Name_Entries.Last; 1152 end Name_Enter; 1153 1154 function Name_Enter (S : String) return Valid_Name_Id is 1155 Buf : Bounded_String (Max_Length => S'Length); 1156 begin 1157 Append (Buf, S); 1158 return Name_Enter (Buf); 1159 end Name_Enter; 1160 1161 ------------------------ 1162 -- Name_Entries_Count -- 1163 ------------------------ 1164 1165 function Name_Entries_Count return Nat is 1166 begin 1167 return Int (Name_Entries.Last - Name_Entries.First + 1); 1168 end Name_Entries_Count; 1169 1170 --------------- 1171 -- Name_Find -- 1172 --------------- 1173 1174 function Name_Find 1175 (Buf : Bounded_String := Global_Name_Buffer) return Valid_Name_Id 1176 is 1177 New_Id : Name_Id; 1178 -- Id of entry in hash search, and value to be returned 1179 1180 S : Int; 1181 -- Pointer into string table 1182 1183 Hash_Index : Hash_Index_Type; 1184 -- Computed hash index 1185 1186 Result : Valid_Name_Id; 1187 1188 begin 1189 -- Quick handling for one character names 1190 1191 if Buf.Length = 1 then 1192 Result := First_Name_Id + Character'Pos (Buf.Chars (1)); 1193 1194 -- Otherwise search hash table for existing matching entry 1195 1196 else 1197 Hash_Index := Namet.Hash (Buf); 1198 New_Id := Hash_Table (Hash_Index); 1199 1200 if New_Id = No_Name then 1201 Hash_Table (Hash_Index) := Name_Entries.Last + 1; 1202 1203 else 1204 Search : loop 1205 if Buf.Length /= 1206 Integer (Name_Entries.Table (New_Id).Name_Len) 1207 then 1208 goto No_Match; 1209 end if; 1210 1211 S := Name_Entries.Table (New_Id).Name_Chars_Index; 1212 1213 for J in 1 .. Buf.Length loop 1214 if Name_Chars.Table (S + Int (J)) /= Buf.Chars (J) then 1215 goto No_Match; 1216 end if; 1217 end loop; 1218 1219 Result := New_Id; 1220 goto Done; 1221 1222 -- Current entry in hash chain does not match 1223 1224 <<No_Match>> 1225 if Name_Entries.Table (New_Id).Hash_Link /= No_Name then 1226 New_Id := Name_Entries.Table (New_Id).Hash_Link; 1227 else 1228 Name_Entries.Table (New_Id).Hash_Link := 1229 Name_Entries.Last + 1; 1230 exit Search; 1231 end if; 1232 end loop Search; 1233 end if; 1234 1235 -- We fall through here only if a matching entry was not found in the 1236 -- hash table. We now create a new entry in the names table. The hash 1237 -- link pointing to the new entry (Name_Entries.Last+1) has been set. 1238 1239 Name_Entries.Append 1240 ((Name_Chars_Index => Name_Chars.Last, 1241 Name_Len => Short (Buf.Length), 1242 Hash_Link => No_Name, 1243 Int_Info => 0, 1244 Byte_Info => 0, 1245 Name_Has_No_Encodings => False, 1246 Boolean1_Info => False, 1247 Boolean2_Info => False, 1248 Boolean3_Info => False, 1249 Spare => False)); 1250 1251 -- Set corresponding string entry in the Name_Chars table 1252 1253 for J in 1 .. Buf.Length loop 1254 Name_Chars.Append (Buf.Chars (J)); 1255 end loop; 1256 1257 Name_Chars.Append (ASCII.NUL); 1258 1259 Result := Name_Entries.Last; 1260 end if; 1261 1262 <<Done>> 1263 return Result; 1264 end Name_Find; 1265 1266 function Name_Find (S : String) return Valid_Name_Id is 1267 Buf : Bounded_String (Max_Length => S'Length); 1268 begin 1269 Append (Buf, S); 1270 return Name_Find (Buf); 1271 end Name_Find; 1272 1273 ----------------- 1274 -- Name_Equals -- 1275 ----------------- 1276 1277 function Name_Equals 1278 (N1 : Valid_Name_Id; 1279 N2 : Valid_Name_Id) return Boolean 1280 is 1281 begin 1282 return N1 = N2 or else Get_Name_String (N1) = Get_Name_String (N2); 1283 end Name_Equals; 1284 1285 ------------- 1286 -- Present -- 1287 ------------- 1288 1289 function Present (Nam : File_Name_Type) return Boolean is 1290 begin 1291 return Nam /= No_File; 1292 end Present; 1293 1294 ------------- 1295 -- Present -- 1296 ------------- 1297 1298 function Present (Nam : Name_Id) return Boolean is 1299 begin 1300 return Nam /= No_Name; 1301 end Present; 1302 1303 ------------- 1304 -- Present -- 1305 ------------- 1306 1307 function Present (Nam : Unit_Name_Type) return Boolean is 1308 begin 1309 return Nam /= No_Unit_Name; 1310 end Present; 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 Hash_Link => No_Name, 1330 Name_Has_No_Encodings => True, 1331 Boolean1_Info => False, 1332 Boolean2_Info => False, 1333 Boolean3_Info => False, 1334 Spare => False)); 1335 1336 Name_Chars.Append (C); 1337 Name_Chars.Append (ASCII.NUL); 1338 end loop; 1339 1340 -- Clear hash table 1341 1342 for J in Hash_Index_Type loop 1343 Hash_Table (J) := No_Name; 1344 end loop; 1345 end Reinitialize; 1346 1347 ---------------------- 1348 -- Reset_Name_Table -- 1349 ---------------------- 1350 1351 procedure Reset_Name_Table is 1352 begin 1353 for J in First_Name_Id .. Name_Entries.Last loop 1354 Name_Entries.Table (J).Int_Info := 0; 1355 Name_Entries.Table (J).Byte_Info := 0; 1356 end loop; 1357 end Reset_Name_Table; 1358 1359 -------------------------------- 1360 -- Set_Character_Literal_Name -- 1361 -------------------------------- 1362 1363 procedure Set_Character_Literal_Name 1364 (Buf : in out Bounded_String; 1365 C : Char_Code) 1366 is 1367 begin 1368 Buf.Length := 0; 1369 Append (Buf, 'Q'); 1370 Append_Encoded (Buf, C); 1371 end Set_Character_Literal_Name; 1372 1373 procedure Set_Character_Literal_Name (C : Char_Code) is 1374 begin 1375 Set_Character_Literal_Name (Global_Name_Buffer, C); 1376 end Set_Character_Literal_Name; 1377 1378 ----------------------------- 1379 -- Set_Name_Table_Boolean1 -- 1380 ----------------------------- 1381 1382 procedure Set_Name_Table_Boolean1 (Id : Valid_Name_Id; Val : Boolean) is 1383 begin 1384 pragma Assert (Is_Valid_Name (Id)); 1385 Name_Entries.Table (Id).Boolean1_Info := Val; 1386 end Set_Name_Table_Boolean1; 1387 1388 ----------------------------- 1389 -- Set_Name_Table_Boolean2 -- 1390 ----------------------------- 1391 1392 procedure Set_Name_Table_Boolean2 (Id : Valid_Name_Id; Val : Boolean) is 1393 begin 1394 pragma Assert (Is_Valid_Name (Id)); 1395 Name_Entries.Table (Id).Boolean2_Info := Val; 1396 end Set_Name_Table_Boolean2; 1397 1398 ----------------------------- 1399 -- Set_Name_Table_Boolean3 -- 1400 ----------------------------- 1401 1402 procedure Set_Name_Table_Boolean3 (Id : Valid_Name_Id; Val : Boolean) is 1403 begin 1404 pragma Assert (Is_Valid_Name (Id)); 1405 Name_Entries.Table (Id).Boolean3_Info := Val; 1406 end Set_Name_Table_Boolean3; 1407 1408 ------------------------- 1409 -- Set_Name_Table_Byte -- 1410 ------------------------- 1411 1412 procedure Set_Name_Table_Byte (Id : Valid_Name_Id; Val : Byte) is 1413 begin 1414 pragma Assert (Is_Valid_Name (Id)); 1415 Name_Entries.Table (Id).Byte_Info := Val; 1416 end Set_Name_Table_Byte; 1417 1418 ------------------------- 1419 -- Set_Name_Table_Int -- 1420 ------------------------- 1421 1422 procedure Set_Name_Table_Int (Id : Valid_Name_Id; Val : Int) is 1423 begin 1424 pragma Assert (Is_Valid_Name (Id)); 1425 Name_Entries.Table (Id).Int_Info := Val; 1426 end Set_Name_Table_Int; 1427 1428 ----------------------------- 1429 -- Store_Encoded_Character -- 1430 ----------------------------- 1431 1432 procedure Store_Encoded_Character (C : Char_Code) is 1433 begin 1434 Append_Encoded (Global_Name_Buffer, C); 1435 end Store_Encoded_Character; 1436 1437 -------------------------------------- 1438 -- Strip_Qualification_And_Suffixes -- 1439 -------------------------------------- 1440 1441 procedure Strip_Qualification_And_Suffixes (Buf : in out Bounded_String) is 1442 J : Integer; 1443 1444 begin 1445 -- Strip package body qualification string off end 1446 1447 for J in reverse 2 .. Buf.Length loop 1448 if Buf.Chars (J) = 'X' then 1449 Buf.Length := J - 1; 1450 exit; 1451 end if; 1452 1453 exit when Buf.Chars (J) /= 'b' 1454 and then Buf.Chars (J) /= 'n' 1455 and then Buf.Chars (J) /= 'p'; 1456 end loop; 1457 1458 -- Find rightmost __ or $ separator if one exists. First we position 1459 -- to start the search. If we have a character constant, position 1460 -- just before it, otherwise position to last character but one 1461 1462 if Buf.Chars (Buf.Length) = ''' then 1463 J := Buf.Length - 2; 1464 while J > 0 and then Buf.Chars (J) /= ''' loop 1465 J := J - 1; 1466 end loop; 1467 1468 else 1469 J := Buf.Length - 1; 1470 end if; 1471 1472 -- Loop to search for rightmost __ or $ (homonym) separator 1473 1474 while J > 1 loop 1475 1476 -- If $ separator, homonym separator, so strip it and keep looking 1477 1478 if Buf.Chars (J) = '$' then 1479 Buf.Length := J - 1; 1480 J := Buf.Length - 1; 1481 1482 -- Else check for __ found 1483 1484 elsif Buf.Chars (J) = '_' and then Buf.Chars (J + 1) = '_' then 1485 1486 -- Found __ so see if digit follows, and if so, this is a 1487 -- homonym separator, so strip it and keep looking. 1488 1489 if Buf.Chars (J + 2) in '0' .. '9' then 1490 Buf.Length := J - 1; 1491 J := Buf.Length - 1; 1492 1493 -- If not a homonym separator, then we simply strip the 1494 -- separator and everything that precedes it, and we are done 1495 1496 else 1497 Buf.Chars (1 .. Buf.Length - J - 1) := 1498 Buf.Chars (J + 2 .. Buf.Length); 1499 Buf.Length := Buf.Length - J - 1; 1500 exit; 1501 end if; 1502 1503 else 1504 J := J - 1; 1505 end if; 1506 end loop; 1507 end Strip_Qualification_And_Suffixes; 1508 1509 --------------- 1510 -- To_String -- 1511 --------------- 1512 1513 function To_String (Buf : Bounded_String) return String is 1514 begin 1515 return Buf.Chars (1 .. Buf.Length); 1516 end To_String; 1517 1518 ------------ 1519 -- Unlock -- 1520 ------------ 1521 1522 procedure Unlock is 1523 begin 1524 Name_Chars.Locked := False; 1525 Name_Chars.Set_Last (Name_Chars.Last - Name_Chars_Reserve); 1526 Name_Chars.Release; 1527 Name_Entries.Locked := False; 1528 Name_Entries.Set_Last (Name_Entries.Last - Name_Entries_Reserve); 1529 Name_Entries.Release; 1530 end Unlock; 1531 1532 -------- 1533 -- wn -- 1534 -------- 1535 1536 procedure wn (Id : Name_Id) is 1537 begin 1538 if Is_Valid_Name (Id) then 1539 declare 1540 Buf : Bounded_String (Max_Length => Natural (Length_Of_Name (Id))); 1541 begin 1542 Append (Buf, Id); 1543 Write_Str (Buf.Chars (1 .. Buf.Length)); 1544 end; 1545 1546 elsif Id = No_Name then 1547 Write_Str ("<No_Name>"); 1548 1549 elsif Id = Error_Name then 1550 Write_Str ("<Error_Name>"); 1551 1552 else 1553 Write_Str ("<invalid name_id>"); 1554 Write_Int (Int (Id)); 1555 end if; 1556 1557 Write_Eol; 1558 end wn; 1559 1560 ---------------- 1561 -- Write_Name -- 1562 ---------------- 1563 1564 procedure Write_Name (Id : Valid_Name_Id) is 1565 Buf : Bounded_String (Max_Length => Natural (Length_Of_Name (Id))); 1566 begin 1567 Append (Buf, Id); 1568 Write_Str (Buf.Chars (1 .. Buf.Length)); 1569 end Write_Name; 1570 1571 ------------------------ 1572 -- Write_Name_Decoded -- 1573 ------------------------ 1574 1575 procedure Write_Name_Decoded (Id : Valid_Name_Id) is 1576 Buf : Bounded_String; 1577 begin 1578 Append_Decoded (Buf, Id); 1579 Write_Str (Buf.Chars (1 .. Buf.Length)); 1580 end Write_Name_Decoded; 1581 1582-- Package initialization, initialize tables 1583 1584begin 1585 Reinitialize; 1586end Namet; 1587