gcc/ada/namet.adb

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