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-2015, Free Software Foundation, Inc.         --
  10 --                                                                          --
  11 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  12 -- terms of the  GNU General Public License as published  by the Free Soft- --
  13 -- ware  Foundation;  either version 3,  or (at your option) any later ver- --
  14 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  15 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  16 -- or FITNESS FOR A PARTICULAR PURPOSE.                                     --
  17 --                                                                          --
  18 -- As a special exception under Section 7 of GPL version 3, you are granted --
  19 -- additional permissions described in the GCC Runtime Library Exception,   --
  20 -- version 3.1, as published by the Free Software Foundation.               --
  21 --                                                                          --
  22 -- You should have received a copy of the GNU General Public License and    --
  23 -- a copy of the GCC Runtime Library Exception along with this program;     --
  24 -- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
  25 -- <http://www.gnu.org/licenses/>.                                          --
  26 --                                                                          --
  27 -- GNAT was originally developed  by the GNAT team at  New York University. --
  28 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  29 --                                                                          --
  30 ------------------------------------------------------------------------------
  31
  32 --  WARNING: There is a C version of this package. Any changes to this
  33 --  source file must be properly reflected in the C header file namet.h
  34 --  which is created manually from namet.ads and namet.adb.
  35
  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       if Id in Error_Name_Or_No_Name then
 837          return False;
 838       else
 839          Get_Name_String (Id);
 840          return Is_Internal_Name;
 841       end if;
 842    end Is_Internal_Name;
 843
 844    ----------------------
 845    -- Is_Internal_Name --
 846    ----------------------
 847
 848    --  Version taking its input from Name_Buffer
 849
 850    function Is_Internal_Name return Boolean is
 851       J : Natural;
 852
 853    begin
 854       --  AAny name starting with underscore is internal
 855
 856       if Name_Buffer (1) = '_'
 857         or else Name_Buffer (Name_Len) = '_'
 858       then
 859          return True;
 860
 861       --  Allow quoted character
 862
 863       elsif Name_Buffer (1) = ''' then
 864          return False;
 865
 866       --  All other cases, scan name
 867
 868       else
 869          --  Test backwards, because we only want to test the last entity
 870          --  name if the name we have is qualified with other entities.
 871
 872          J := Name_Len;
 873          while J /= 0 loop
 874
 875             --  Skip stuff between brackets (A-F OK there)
 876
 877             if Name_Buffer (J) = ']' then
 878                loop
 879                   J := J - 1;
 880                   exit when J = 1 or else Name_Buffer (J) = '[';
 881                end loop;
 882
 883             --  Test for internal letter
 884
 885             elsif Is_OK_Internal_Letter (Name_Buffer (J)) then
 886                return True;
 887
 888             --  Quit if we come to terminating double underscore (note that
 889             --  if the current character is an underscore, we know that
 890             --  there is a previous character present, since we already
 891             --  filtered out the case of Name_Buffer (1) = '_' above.
 892
 893             elsif Name_Buffer (J) = '_'
 894               and then Name_Buffer (J - 1) = '_'
 895               and then Name_Buffer (J - 2) /= '_'
 896             then
 897                return False;
 898             end if;
 899
 900             J := J - 1;
 901          end loop;
 902       end if;
 903
 904       return False;
 905    end Is_Internal_Name;
 906
 907    ---------------------------
 908    -- Is_OK_Internal_Letter --
 909    ---------------------------
 910
 911    function Is_OK_Internal_Letter (C : Character) return Boolean is
 912    begin
 913       return C in 'A' .. 'Z'
 914         and then C /= 'O'
 915         and then C /= 'Q'
 916         and then C /= 'U'
 917         and then C /= 'W'
 918         and then C /= 'X';
 919    end Is_OK_Internal_Letter;
 920
 921    ----------------------
 922    -- Is_Operator_Name --
 923    ----------------------
 924
 925    function Is_Operator_Name (Id : Name_Id) return Boolean is
 926       S : Int;
 927    begin
 928       pragma Assert (Id in Name_Entries.First .. Name_Entries.Last);
 929       S := Name_Entries.Table (Id).Name_Chars_Index;
 930       return Name_Chars.Table (S + 1) = 'O';
 931    end Is_Operator_Name;
 932
 933    -------------------
 934    -- Is_Valid_Name --
 935    -------------------
 936
 937    function Is_Valid_Name (Id : Name_Id) return Boolean is
 938    begin
 939       return Id in Name_Entries.First .. Name_Entries.Last;
 940    end Is_Valid_Name;
 941
 942    --------------------
 943    -- Length_Of_Name --
 944    --------------------
 945
 946    function Length_Of_Name (Id : Name_Id) return Nat is
 947    begin
 948       return Int (Name_Entries.Table (Id).Name_Len);
 949    end Length_Of_Name;
 950
 951    ----------
 952    -- Lock --
 953    ----------
 954
 955    procedure Lock is
 956    begin
 957       Name_Chars.Set_Last (Name_Chars.Last + Name_Chars_Reserve);
 958       Name_Entries.Set_Last (Name_Entries.Last + Name_Entries_Reserve);
 959       Name_Chars.Locked := True;
 960       Name_Entries.Locked := True;
 961       Name_Chars.Release;
 962       Name_Entries.Release;
 963    end Lock;
 964
 965    ------------------------
 966    -- Name_Chars_Address --
 967    ------------------------
 968
 969    function Name_Chars_Address return System.Address is
 970    begin
 971       return Name_Chars.Table (0)'Address;
 972    end Name_Chars_Address;
 973
 974    ----------------
 975    -- Name_Enter --
 976    ----------------
 977
 978    function Name_Enter return Name_Id is
 979    begin
 980       Name_Entries.Append
 981         ((Name_Chars_Index      => Name_Chars.Last,
 982           Name_Len              => Short (Name_Len),
 983           Byte_Info             => 0,
 984           Int_Info              => 0,
 985           Boolean1_Info         => False,
 986           Boolean2_Info         => False,
 987           Boolean3_Info         => False,
 988           Name_Has_No_Encodings => False,
 989           Hash_Link             => No_Name));
 990
 991       --  Set corresponding string entry in the Name_Chars table
 992
 993       for J in 1 .. Name_Len loop
 994          Name_Chars.Append (Name_Buffer (J));
 995       end loop;
 996
 997       Name_Chars.Append (ASCII.NUL);
 998
 999       return Name_Entries.Last;
1000    end Name_Enter;
1001
1002    --------------------------
1003    -- Name_Entries_Address --
1004    --------------------------
1005
1006    function Name_Entries_Address return System.Address is
1007    begin
1008       return Name_Entries.Table (First_Name_Id)'Address;
1009    end Name_Entries_Address;
1010
1011    ------------------------
1012    -- Name_Entries_Count --
1013    ------------------------
1014
1015    function Name_Entries_Count return Nat is
1016    begin
1017       return Int (Name_Entries.Last - Name_Entries.First + 1);
1018    end Name_Entries_Count;
1019
1020    ---------------
1021    -- Name_Find --
1022    ---------------
1023
1024    function Name_Find return Name_Id is
1025       New_Id : Name_Id;
1026       --  Id of entry in hash search, and value to be returned
1027
1028       S : Int;
1029       --  Pointer into string table
1030
1031       Hash_Index : Hash_Index_Type;
1032       --  Computed hash index
1033
1034    begin
1035       --  Quick handling for one character names
1036
1037       if Name_Len = 1 then
1038          return Name_Id (First_Name_Id + Character'Pos (Name_Buffer (1)));
1039
1040       --  Otherwise search hash table for existing matching entry
1041
1042       else
1043          Hash_Index := Namet.Hash;
1044          New_Id := Hash_Table (Hash_Index);
1045
1046          if New_Id = No_Name then
1047             Hash_Table (Hash_Index) := Name_Entries.Last + 1;
1048
1049          else
1050             Search : loop
1051                if Name_Len /=
1052                  Integer (Name_Entries.Table (New_Id).Name_Len)
1053                then
1054                   goto No_Match;
1055                end if;
1056
1057                S := Name_Entries.Table (New_Id).Name_Chars_Index;
1058
1059                for J in 1 .. Name_Len loop
1060                   if Name_Chars.Table (S + Int (J)) /= Name_Buffer (J) then
1061                      goto No_Match;
1062                   end if;
1063                end loop;
1064
1065                return New_Id;
1066
1067                --  Current entry in hash chain does not match
1068
1069                <<No_Match>>
1070                   if Name_Entries.Table (New_Id).Hash_Link /= No_Name then
1071                      New_Id := Name_Entries.Table (New_Id).Hash_Link;
1072                   else
1073                      Name_Entries.Table (New_Id).Hash_Link :=
1074                        Name_Entries.Last + 1;
1075                      exit Search;
1076                   end if;
1077             end loop Search;
1078          end if;
1079
1080          --  We fall through here only if a matching entry was not found in the
1081          --  hash table. We now create a new entry in the names table. The hash
1082          --  link pointing to the new entry (Name_Entries.Last+1) has been set.
1083
1084          Name_Entries.Append
1085            ((Name_Chars_Index      => Name_Chars.Last,
1086              Name_Len              => Short (Name_Len),
1087              Hash_Link             => No_Name,
1088              Name_Has_No_Encodings => False,
1089              Int_Info              => 0,
1090              Byte_Info             => 0,
1091              Boolean1_Info         => False,
1092              Boolean2_Info         => False,
1093              Boolean3_Info         => False));
1094
1095          --  Set corresponding string entry in the Name_Chars table
1096
1097          for J in 1 .. Name_Len loop
1098             Name_Chars.Append (Name_Buffer (J));
1099          end loop;
1100
1101          Name_Chars.Append (ASCII.NUL);
1102
1103          return Name_Entries.Last;
1104       end if;
1105    end Name_Find;
1106
1107    -------------------
1108    -- Name_Find_Str --
1109    -------------------
1110
1111    function Name_Find_Str (S : String) return Name_Id is
1112    begin
1113       Name_Len := S'Length;
1114       Name_Buffer (1 .. Name_Len) := S;
1115       return Name_Find;
1116    end Name_Find_Str;
1117
1118    -------------
1119    -- Nam_In --
1120    -------------
1121
1122    function Nam_In
1123      (T  : Name_Id;
1124       V1 : Name_Id;
1125       V2 : Name_Id) return Boolean
1126    is
1127    begin
1128       return T = V1 or else
1129              T = V2;
1130    end Nam_In;
1131
1132    function Nam_In
1133      (T  : Name_Id;
1134       V1 : Name_Id;
1135       V2 : Name_Id;
1136       V3 : Name_Id) return Boolean
1137    is
1138    begin
1139       return T = V1 or else
1140              T = V2 or else
1141              T = V3;
1142    end Nam_In;
1143
1144    function Nam_In
1145      (T  : Name_Id;
1146       V1 : Name_Id;
1147       V2 : Name_Id;
1148       V3 : Name_Id;
1149       V4 : Name_Id) return Boolean
1150    is
1151    begin
1152       return T = V1 or else
1153              T = V2 or else
1154              T = V3 or else
1155              T = V4;
1156    end Nam_In;
1157
1158    function Nam_In
1159      (T  : Name_Id;
1160       V1 : Name_Id;
1161       V2 : Name_Id;
1162       V3 : Name_Id;
1163       V4 : Name_Id;
1164       V5 : Name_Id) return Boolean
1165    is
1166    begin
1167       return T = V1 or else
1168              T = V2 or else
1169              T = V3 or else
1170              T = V4 or else
1171              T = V5;
1172    end Nam_In;
1173
1174    function Nam_In
1175      (T  : Name_Id;
1176       V1 : Name_Id;
1177       V2 : Name_Id;
1178       V3 : Name_Id;
1179       V4 : Name_Id;
1180       V5 : Name_Id;
1181       V6 : 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;
1190    end Nam_In;
1191
1192    function Nam_In
1193      (T  : Name_Id;
1194       V1 : Name_Id;
1195       V2 : Name_Id;
1196       V3 : Name_Id;
1197       V4 : Name_Id;
1198       V5 : Name_Id;
1199       V6 : Name_Id;
1200       V7 : Name_Id) return Boolean
1201    is
1202    begin
1203       return T = V1 or else
1204              T = V2 or else
1205              T = V3 or else
1206              T = V4 or else
1207              T = V5 or else
1208              T = V6 or else
1209              T = V7;
1210    end Nam_In;
1211
1212    function Nam_In
1213      (T  : Name_Id;
1214       V1 : Name_Id;
1215       V2 : Name_Id;
1216       V3 : Name_Id;
1217       V4 : Name_Id;
1218       V5 : Name_Id;
1219       V6 : Name_Id;
1220       V7 : Name_Id;
1221       V8 : Name_Id) return Boolean
1222    is
1223    begin
1224       return T = V1 or else
1225              T = V2 or else
1226              T = V3 or else
1227              T = V4 or else
1228              T = V5 or else
1229              T = V6 or else
1230              T = V7 or else
1231              T = V8;
1232    end Nam_In;
1233
1234    function Nam_In
1235      (T  : Name_Id;
1236       V1 : Name_Id;
1237       V2 : Name_Id;
1238       V3 : Name_Id;
1239       V4 : Name_Id;
1240       V5 : Name_Id;
1241       V6 : Name_Id;
1242       V7 : Name_Id;
1243       V8 : Name_Id;
1244       V9 : Name_Id) return Boolean
1245    is
1246    begin
1247       return T = V1 or else
1248              T = V2 or else
1249              T = V3 or else
1250              T = V4 or else
1251              T = V5 or else
1252              T = V6 or else
1253              T = V7 or else
1254              T = V8 or else
1255              T = V9;
1256    end Nam_In;
1257
1258    function Nam_In
1259      (T   : Name_Id;
1260       V1  : Name_Id;
1261       V2  : Name_Id;
1262       V3  : Name_Id;
1263       V4  : Name_Id;
1264       V5  : Name_Id;
1265       V6  : Name_Id;
1266       V7  : Name_Id;
1267       V8  : Name_Id;
1268       V9  : Name_Id;
1269       V10 : Name_Id) return Boolean
1270    is
1271    begin
1272       return T = V1 or else
1273              T = V2 or else
1274              T = V3 or else
1275              T = V4 or else
1276              T = V5 or else
1277              T = V6 or else
1278              T = V7 or else
1279              T = V8 or else
1280              T = V9 or else
1281              T = V10;
1282    end Nam_In;
1283
1284    function Nam_In
1285      (T   : Name_Id;
1286       V1  : Name_Id;
1287       V2  : Name_Id;
1288       V3  : Name_Id;
1289       V4  : Name_Id;
1290       V5  : Name_Id;
1291       V6  : Name_Id;
1292       V7  : Name_Id;
1293       V8  : Name_Id;
1294       V9  : Name_Id;
1295       V10 : Name_Id;
1296       V11 : Name_Id) return Boolean
1297    is
1298    begin
1299       return T = V1  or else
1300              T = V2  or else
1301              T = V3  or else
1302              T = V4  or else
1303              T = V5  or else
1304              T = V6  or else
1305              T = V7  or else
1306              T = V8  or else
1307              T = V9  or else
1308              T = V10 or else
1309              T = V11;
1310    end Nam_In;
1311
1312    ------------------
1313    -- Reinitialize --
1314    ------------------
1315
1316    procedure Reinitialize is
1317    begin
1318       Name_Chars.Init;
1319       Name_Entries.Init;
1320
1321       --  Initialize entries for one character names
1322
1323       for C in Character loop
1324          Name_Entries.Append
1325            ((Name_Chars_Index      => Name_Chars.Last,
1326              Name_Len              => 1,
1327              Byte_Info             => 0,
1328              Int_Info              => 0,
1329              Boolean1_Info         => False,
1330              Boolean2_Info         => False,
1331              Boolean3_Info         => False,
1332              Name_Has_No_Encodings => True,
1333              Hash_Link             => No_Name));
1334
1335          Name_Chars.Append (C);
1336          Name_Chars.Append (ASCII.NUL);
1337       end loop;
1338
1339       --  Clear hash table
1340
1341       for J in Hash_Index_Type loop
1342          Hash_Table (J) := No_Name;
1343       end loop;
1344    end Reinitialize;
1345
1346    ----------------------
1347    -- Reset_Name_Table --
1348    ----------------------
1349
1350    procedure Reset_Name_Table is
1351    begin
1352       for J in First_Name_Id .. Name_Entries.Last loop
1353          Name_Entries.Table (J).Int_Info  := 0;
1354          Name_Entries.Table (J).Byte_Info := 0;
1355       end loop;
1356    end Reset_Name_Table;
1357
1358    --------------------------------
1359    -- Set_Character_Literal_Name --
1360    --------------------------------
1361
1362    procedure Set_Character_Literal_Name (C : Char_Code) is
1363    begin
1364       Name_Buffer (1) := 'Q';
1365       Name_Len := 1;
1366       Store_Encoded_Character (C);
1367    end Set_Character_Literal_Name;
1368
1369    -----------------------------
1370    -- Set_Name_Table_Boolean1 --
1371    -----------------------------
1372
1373    procedure Set_Name_Table_Boolean1 (Id : Name_Id; Val : Boolean) is
1374    begin
1375       pragma Assert (Id in Name_Entries.First .. Name_Entries.Last);
1376       Name_Entries.Table (Id).Boolean1_Info := Val;
1377    end Set_Name_Table_Boolean1;
1378
1379    -----------------------------
1380    -- Set_Name_Table_Boolean2 --
1381    -----------------------------
1382
1383    procedure Set_Name_Table_Boolean2 (Id : Name_Id; Val : Boolean) is
1384    begin
1385       pragma Assert (Id in Name_Entries.First .. Name_Entries.Last);
1386       Name_Entries.Table (Id).Boolean2_Info := Val;
1387    end Set_Name_Table_Boolean2;
1388
1389    -----------------------------
1390    -- Set_Name_Table_Boolean3 --
1391    -----------------------------
1392
1393    procedure Set_Name_Table_Boolean3 (Id : Name_Id; Val : Boolean) is
1394    begin
1395       pragma Assert (Id in Name_Entries.First .. Name_Entries.Last);
1396       Name_Entries.Table (Id).Boolean3_Info := Val;
1397    end Set_Name_Table_Boolean3;
1398
1399    -------------------------
1400    -- Set_Name_Table_Byte --
1401    -------------------------
1402
1403    procedure Set_Name_Table_Byte (Id : Name_Id; Val : Byte) is
1404    begin
1405       pragma Assert (Id in Name_Entries.First .. Name_Entries.Last);
1406       Name_Entries.Table (Id).Byte_Info := Val;
1407    end Set_Name_Table_Byte;
1408
1409    -------------------------
1410    -- Set_Name_Table_Int --
1411    -------------------------
1412
1413    procedure Set_Name_Table_Int (Id : Name_Id; Val : Int) is
1414    begin
1415       pragma Assert (Id in Name_Entries.First .. Name_Entries.Last);
1416       Name_Entries.Table (Id).Int_Info := Val;
1417    end Set_Name_Table_Int;
1418
1419    -----------------------------
1420    -- Store_Encoded_Character --
1421    -----------------------------
1422
1423    procedure Store_Encoded_Character (C : Char_Code) is
1424
1425       procedure Set_Hex_Chars (C : Char_Code);
1426       --  Stores given value, which is in the range 0 .. 255, as two hex
1427       --  digits (using lower case a-f) in Name_Buffer, incrementing Name_Len.
1428
1429       -------------------
1430       -- Set_Hex_Chars --
1431       -------------------
1432
1433       procedure Set_Hex_Chars (C : Char_Code) is
1434          Hexd : constant String := "0123456789abcdef";
1435          N    : constant Natural := Natural (C);
1436       begin
1437          Name_Buffer (Name_Len + 1) := Hexd (N / 16 + 1);
1438          Name_Buffer (Name_Len + 2) := Hexd (N mod 16 + 1);
1439          Name_Len := Name_Len + 2;
1440       end Set_Hex_Chars;
1441
1442    --  Start of processing for Store_Encoded_Character
1443
1444    begin
1445       Name_Len := Name_Len + 1;
1446
1447       if In_Character_Range (C) then
1448          declare
1449             CC : constant Character := Get_Character (C);
1450          begin
1451             if CC in 'a' .. 'z' or else CC in '0' .. '9' then
1452                Name_Buffer (Name_Len) := CC;
1453             else
1454                Name_Buffer (Name_Len) := 'U';
1455                Set_Hex_Chars (C);
1456             end if;
1457          end;
1458
1459       elsif In_Wide_Character_Range (C) then
1460          Name_Buffer (Name_Len) := 'W';
1461          Set_Hex_Chars (C / 256);
1462          Set_Hex_Chars (C mod 256);
1463
1464       else
1465          Name_Buffer (Name_Len) := 'W';
1466          Name_Len := Name_Len + 1;
1467          Name_Buffer (Name_Len) := 'W';
1468          Set_Hex_Chars (C / 2 ** 24);
1469          Set_Hex_Chars ((C / 2 ** 16) mod 256);
1470          Set_Hex_Chars ((C / 256) mod 256);
1471          Set_Hex_Chars (C mod 256);
1472       end if;
1473    end Store_Encoded_Character;
1474
1475    --------------------------------------
1476    -- Strip_Qualification_And_Suffixes --
1477    --------------------------------------
1478
1479    procedure Strip_Qualification_And_Suffixes is
1480       J : Integer;
1481
1482    begin
1483       --  Strip package body qualification string off end
1484
1485       for J in reverse 2 .. Name_Len loop
1486          if Name_Buffer (J) = 'X' then
1487             Name_Len := J - 1;
1488             exit;
1489          end if;
1490
1491          exit when Name_Buffer (J) /= 'b'
1492            and then Name_Buffer (J) /= 'n'
1493            and then Name_Buffer (J) /= 'p';
1494       end loop;
1495
1496       --  Find rightmost __ or $ separator if one exists. First we position
1497       --  to start the search. If we have a character constant, position
1498       --  just before it, otherwise position to last character but one
1499
1500       if Name_Buffer (Name_Len) = ''' then
1501          J := Name_Len - 2;
1502          while J > 0 and then Name_Buffer (J) /= ''' loop
1503             J := J - 1;
1504          end loop;
1505
1506       else
1507          J := Name_Len - 1;
1508       end if;
1509
1510       --  Loop to search for rightmost __ or $ (homonym) separator
1511
1512       while J > 1 loop
1513
1514          --  If $ separator, homonym separator, so strip it and keep looking
1515
1516          if Name_Buffer (J) = '$' then
1517             Name_Len := J - 1;
1518             J := Name_Len - 1;
1519
1520          --  Else check for __ found
1521
1522          elsif Name_Buffer (J) = '_' and then Name_Buffer (J + 1) = '_' then
1523
1524             --  Found __ so see if digit follows, and if so, this is a
1525             --  homonym separator, so strip it and keep looking.
1526
1527             if Name_Buffer (J + 2) in '0' .. '9' then
1528                Name_Len := J - 1;
1529                J := Name_Len - 1;
1530
1531             --  If not a homonym separator, then we simply strip the
1532             --  separator and everything that precedes it, and we are done
1533
1534             else
1535                Name_Buffer (1 .. Name_Len - J - 1) :=
1536                  Name_Buffer (J + 2 .. Name_Len);
1537                Name_Len := Name_Len - J - 1;
1538                exit;
1539             end if;
1540
1541          else
1542             J := J - 1;
1543          end if;
1544       end loop;
1545    end Strip_Qualification_And_Suffixes;
1546
1547    ---------------
1548    -- Tree_Read --
1549    ---------------
1550
1551    procedure Tree_Read is
1552    begin
1553       Name_Chars.Tree_Read;
1554       Name_Entries.Tree_Read;
1555
1556       Tree_Read_Data
1557         (Hash_Table'Address,
1558          Hash_Table'Length * (Hash_Table'Component_Size / Storage_Unit));
1559    end Tree_Read;
1560
1561    ----------------
1562    -- Tree_Write --
1563    ----------------
1564
1565    procedure Tree_Write is
1566    begin
1567       Name_Chars.Tree_Write;
1568       Name_Entries.Tree_Write;
1569
1570       Tree_Write_Data
1571         (Hash_Table'Address,
1572          Hash_Table'Length * (Hash_Table'Component_Size / Storage_Unit));
1573    end Tree_Write;
1574
1575    ------------
1576    -- Unlock --
1577    ------------
1578
1579    procedure Unlock is
1580    begin
1581       Name_Chars.Set_Last (Name_Chars.Last - Name_Chars_Reserve);
1582       Name_Entries.Set_Last (Name_Entries.Last - Name_Entries_Reserve);
1583       Name_Chars.Locked := False;
1584       Name_Entries.Locked := False;
1585       Name_Chars.Release;
1586       Name_Entries.Release;
1587    end Unlock;
1588
1589    --------
1590    -- wn --
1591    --------
1592
1593    procedure wn (Id : Name_Id) is
1594       S : Int;
1595
1596    begin
1597       if not Id'Valid then
1598          Write_Str ("<invalid name_id>");
1599
1600       elsif Id = No_Name then
1601          Write_Str ("<No_Name>");
1602
1603       elsif Id = Error_Name then
1604          Write_Str ("<Error_Name>");
1605
1606       else
1607          S := Name_Entries.Table (Id).Name_Chars_Index;
1608          Name_Len := Natural (Name_Entries.Table (Id).Name_Len);
1609
1610          for J in 1 .. Name_Len loop
1611             Write_Char (Name_Chars.Table (S + Int (J)));
1612          end loop;
1613       end if;
1614
1615       Write_Eol;
1616    end wn;
1617
1618    ----------------
1619    -- Write_Name --
1620    ----------------
1621
1622    procedure Write_Name (Id : Name_Id) is
1623    begin
1624       if Id >= First_Name_Id then
1625          Get_Name_String (Id);
1626          Write_Str (Name_Buffer (1 .. Name_Len));
1627       end if;
1628    end Write_Name;
1629
1630    ------------------------
1631    -- Write_Name_Decoded --
1632    ------------------------
1633
1634    procedure Write_Name_Decoded (Id : Name_Id) is
1635    begin
1636       if Id >= First_Name_Id then
1637          Get_Decoded_Name_String (Id);
1638          Write_Str (Name_Buffer (1 .. Name_Len));
1639       end if;
1640    end Write_Name_Decoded;
1641
1642 --  Package initialization, initialize tables
1643
1644 begin
1645    Reinitialize;
1646 end Namet;