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