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    -- Nam_In --
1109    -------------
1110
1111    function Nam_In
1112      (T  : Name_Id;
1113       V1 : Name_Id;
1114       V2 : Name_Id) return Boolean
1115    is
1116    begin
1117       return T = V1 or else
1118              T = V2;
1119    end Nam_In;
1120
1121    function Nam_In
1122      (T  : Name_Id;
1123       V1 : Name_Id;
1124       V2 : Name_Id;
1125       V3 : Name_Id) return Boolean
1126    is
1127    begin
1128       return T = V1 or else
1129              T = V2 or else
1130              T = V3;
1131    end Nam_In;
1132
1133    function Nam_In
1134      (T  : Name_Id;
1135       V1 : Name_Id;
1136       V2 : Name_Id;
1137       V3 : Name_Id;
1138       V4 : Name_Id) return Boolean
1139    is
1140    begin
1141       return T = V1 or else
1142              T = V2 or else
1143              T = V3 or else
1144              T = V4;
1145    end Nam_In;
1146
1147    function Nam_In
1148      (T  : Name_Id;
1149       V1 : Name_Id;
1150       V2 : Name_Id;
1151       V3 : Name_Id;
1152       V4 : Name_Id;
1153       V5 : Name_Id) return Boolean
1154    is
1155    begin
1156       return T = V1 or else
1157              T = V2 or else
1158              T = V3 or else
1159              T = V4 or else
1160              T = V5;
1161    end Nam_In;
1162
1163    function Nam_In
1164      (T  : Name_Id;
1165       V1 : Name_Id;
1166       V2 : Name_Id;
1167       V3 : Name_Id;
1168       V4 : Name_Id;
1169       V5 : Name_Id;
1170       V6 : Name_Id) return Boolean
1171    is
1172    begin
1173       return T = V1 or else
1174              T = V2 or else
1175              T = V3 or else
1176              T = V4 or else
1177              T = V5 or else
1178              T = V6;
1179    end Nam_In;
1180
1181    function Nam_In
1182      (T  : Name_Id;
1183       V1 : Name_Id;
1184       V2 : Name_Id;
1185       V3 : Name_Id;
1186       V4 : Name_Id;
1187       V5 : Name_Id;
1188       V6 : Name_Id;
1189       V7 : Name_Id) return Boolean
1190    is
1191    begin
1192       return T = V1 or else
1193              T = V2 or else
1194              T = V3 or else
1195              T = V4 or else
1196              T = V5 or else
1197              T = V6 or else
1198              T = V7;
1199    end Nam_In;
1200
1201    function Nam_In
1202      (T  : Name_Id;
1203       V1 : Name_Id;
1204       V2 : Name_Id;
1205       V3 : Name_Id;
1206       V4 : Name_Id;
1207       V5 : Name_Id;
1208       V6 : Name_Id;
1209       V7 : Name_Id;
1210       V8 : Name_Id) return Boolean
1211    is
1212    begin
1213       return T = V1 or else
1214              T = V2 or else
1215              T = V3 or else
1216              T = V4 or else
1217              T = V5 or else
1218              T = V6 or else
1219              T = V7 or else
1220              T = V8;
1221    end Nam_In;
1222
1223    function Nam_In
1224      (T  : Name_Id;
1225       V1 : Name_Id;
1226       V2 : Name_Id;
1227       V3 : Name_Id;
1228       V4 : Name_Id;
1229       V5 : Name_Id;
1230       V6 : Name_Id;
1231       V7 : Name_Id;
1232       V8 : Name_Id;
1233       V9 : Name_Id) return Boolean
1234    is
1235    begin
1236       return T = V1 or else
1237              T = V2 or else
1238              T = V3 or else
1239              T = V4 or else
1240              T = V5 or else
1241              T = V6 or else
1242              T = V7 or else
1243              T = V8 or else
1244              T = V9;
1245    end Nam_In;
1246
1247    function Nam_In
1248      (T   : Name_Id;
1249       V1  : Name_Id;
1250       V2  : Name_Id;
1251       V3  : Name_Id;
1252       V4  : Name_Id;
1253       V5  : Name_Id;
1254       V6  : Name_Id;
1255       V7  : Name_Id;
1256       V8  : Name_Id;
1257       V9  : Name_Id;
1258       V10 : Name_Id) return Boolean
1259    is
1260    begin
1261       return T = V1 or else
1262              T = V2 or else
1263              T = V3 or else
1264              T = V4 or else
1265              T = V5 or else
1266              T = V6 or else
1267              T = V7 or else
1268              T = V8 or else
1269              T = V9 or else
1270              T = V10;
1271    end Nam_In;
1272
1273    function Nam_In
1274      (T   : Name_Id;
1275       V1  : Name_Id;
1276       V2  : Name_Id;
1277       V3  : Name_Id;
1278       V4  : Name_Id;
1279       V5  : Name_Id;
1280       V6  : Name_Id;
1281       V7  : Name_Id;
1282       V8  : Name_Id;
1283       V9  : Name_Id;
1284       V10 : Name_Id;
1285       V11 : Name_Id) return Boolean
1286    is
1287    begin
1288       return T = V1  or else
1289              T = V2  or else
1290              T = V3  or else
1291              T = V4  or else
1292              T = V5  or else
1293              T = V6  or else
1294              T = V7  or else
1295              T = V8  or else
1296              T = V9  or else
1297              T = V10 or else
1298              T = V11;
1299    end Nam_In;
1300
1301    ------------------
1302    -- Reinitialize --
1303    ------------------
1304
1305    procedure Reinitialize is
1306    begin
1307       Name_Chars.Init;
1308       Name_Entries.Init;
1309
1310       --  Initialize entries for one character names
1311
1312       for C in Character loop
1313          Name_Entries.Append
1314            ((Name_Chars_Index      => Name_Chars.Last,
1315              Name_Len              => 1,
1316              Byte_Info             => 0,
1317              Int_Info              => 0,
1318              Boolean1_Info         => False,
1319              Boolean2_Info         => False,
1320              Boolean3_Info         => False,
1321              Name_Has_No_Encodings => True,
1322              Hash_Link             => No_Name));
1323
1324          Name_Chars.Append (C);
1325          Name_Chars.Append (ASCII.NUL);
1326       end loop;
1327
1328       --  Clear hash table
1329
1330       for J in Hash_Index_Type loop
1331          Hash_Table (J) := No_Name;
1332       end loop;
1333    end Reinitialize;
1334
1335    ----------------------
1336    -- Reset_Name_Table --
1337    ----------------------
1338
1339    procedure Reset_Name_Table is
1340    begin
1341       for J in First_Name_Id .. Name_Entries.Last loop
1342          Name_Entries.Table (J).Int_Info  := 0;
1343          Name_Entries.Table (J).Byte_Info := 0;
1344       end loop;
1345    end Reset_Name_Table;
1346
1347    --------------------------------
1348    -- Set_Character_Literal_Name --
1349    --------------------------------
1350
1351    procedure Set_Character_Literal_Name (C : Char_Code) is
1352    begin
1353       Name_Buffer (1) := 'Q';
1354       Name_Len := 1;
1355       Store_Encoded_Character (C);
1356    end Set_Character_Literal_Name;
1357
1358    -----------------------------
1359    -- Set_Name_Table_Boolean1 --
1360    -----------------------------
1361
1362    procedure Set_Name_Table_Boolean1 (Id : Name_Id; Val : Boolean) is
1363    begin
1364       pragma Assert (Id in Name_Entries.First .. Name_Entries.Last);
1365       Name_Entries.Table (Id).Boolean1_Info := Val;
1366    end Set_Name_Table_Boolean1;
1367
1368    -----------------------------
1369    -- Set_Name_Table_Boolean2 --
1370    -----------------------------
1371
1372    procedure Set_Name_Table_Boolean2 (Id : Name_Id; Val : Boolean) is
1373    begin
1374       pragma Assert (Id in Name_Entries.First .. Name_Entries.Last);
1375       Name_Entries.Table (Id).Boolean2_Info := Val;
1376    end Set_Name_Table_Boolean2;
1377
1378    -----------------------------
1379    -- Set_Name_Table_Boolean3 --
1380    -----------------------------
1381
1382    procedure Set_Name_Table_Boolean3 (Id : Name_Id; Val : Boolean) is
1383    begin
1384       pragma Assert (Id in Name_Entries.First .. Name_Entries.Last);
1385       Name_Entries.Table (Id).Boolean3_Info := Val;
1386    end Set_Name_Table_Boolean3;
1387
1388    -------------------------
1389    -- Set_Name_Table_Byte --
1390    -------------------------
1391
1392    procedure Set_Name_Table_Byte (Id : Name_Id; Val : Byte) is
1393    begin
1394       pragma Assert (Id in Name_Entries.First .. Name_Entries.Last);
1395       Name_Entries.Table (Id).Byte_Info := Val;
1396    end Set_Name_Table_Byte;
1397
1398    -------------------------
1399    -- Set_Name_Table_Int --
1400    -------------------------
1401
1402    procedure Set_Name_Table_Int (Id : Name_Id; Val : Int) is
1403    begin
1404       pragma Assert (Id in Name_Entries.First .. Name_Entries.Last);
1405       Name_Entries.Table (Id).Int_Info := Val;
1406    end Set_Name_Table_Int;
1407
1408    -----------------------------
1409    -- Store_Encoded_Character --
1410    -----------------------------
1411
1412    procedure Store_Encoded_Character (C : Char_Code) is
1413
1414       procedure Set_Hex_Chars (C : Char_Code);
1415       --  Stores given value, which is in the range 0 .. 255, as two hex
1416       --  digits (using lower case a-f) in Name_Buffer, incrementing Name_Len.
1417
1418       -------------------
1419       -- Set_Hex_Chars --
1420       -------------------
1421
1422       procedure Set_Hex_Chars (C : Char_Code) is
1423          Hexd : constant String := "0123456789abcdef";
1424          N    : constant Natural := Natural (C);
1425       begin
1426          Name_Buffer (Name_Len + 1) := Hexd (N / 16 + 1);
1427          Name_Buffer (Name_Len + 2) := Hexd (N mod 16 + 1);
1428          Name_Len := Name_Len + 2;
1429       end Set_Hex_Chars;
1430
1431    --  Start of processing for Store_Encoded_Character
1432
1433    begin
1434       Name_Len := Name_Len + 1;
1435
1436       if In_Character_Range (C) then
1437          declare
1438             CC : constant Character := Get_Character (C);
1439          begin
1440             if CC in 'a' .. 'z' or else CC in '0' .. '9' then
1441                Name_Buffer (Name_Len) := CC;
1442             else
1443                Name_Buffer (Name_Len) := 'U';
1444                Set_Hex_Chars (C);
1445             end if;
1446          end;
1447
1448       elsif In_Wide_Character_Range (C) then
1449          Name_Buffer (Name_Len) := 'W';
1450          Set_Hex_Chars (C / 256);
1451          Set_Hex_Chars (C mod 256);
1452
1453       else
1454          Name_Buffer (Name_Len) := 'W';
1455          Name_Len := Name_Len + 1;
1456          Name_Buffer (Name_Len) := 'W';
1457          Set_Hex_Chars (C / 2 ** 24);
1458          Set_Hex_Chars ((C / 2 ** 16) mod 256);
1459          Set_Hex_Chars ((C / 256) mod 256);
1460          Set_Hex_Chars (C mod 256);
1461       end if;
1462    end Store_Encoded_Character;
1463
1464    --------------------------------------
1465    -- Strip_Qualification_And_Suffixes --
1466    --------------------------------------
1467
1468    procedure Strip_Qualification_And_Suffixes is
1469       J : Integer;
1470
1471    begin
1472       --  Strip package body qualification string off end
1473
1474       for J in reverse 2 .. Name_Len loop
1475          if Name_Buffer (J) = 'X' then
1476             Name_Len := J - 1;
1477             exit;
1478          end if;
1479
1480          exit when Name_Buffer (J) /= 'b'
1481            and then Name_Buffer (J) /= 'n'
1482            and then Name_Buffer (J) /= 'p';
1483       end loop;
1484
1485       --  Find rightmost __ or $ separator if one exists. First we position
1486       --  to start the search. If we have a character constant, position
1487       --  just before it, otherwise position to last character but one
1488
1489       if Name_Buffer (Name_Len) = ''' then
1490          J := Name_Len - 2;
1491          while J > 0 and then Name_Buffer (J) /= ''' loop
1492             J := J - 1;
1493          end loop;
1494
1495       else
1496          J := Name_Len - 1;
1497       end if;
1498
1499       --  Loop to search for rightmost __ or $ (homonym) separator
1500
1501       while J > 1 loop
1502
1503          --  If $ separator, homonym separator, so strip it and keep looking
1504
1505          if Name_Buffer (J) = '$' then
1506             Name_Len := J - 1;
1507             J := Name_Len - 1;
1508
1509          --  Else check for __ found
1510
1511          elsif Name_Buffer (J) = '_' and then Name_Buffer (J + 1) = '_' then
1512
1513             --  Found __ so see if digit follows, and if so, this is a
1514             --  homonym separator, so strip it and keep looking.
1515
1516             if Name_Buffer (J + 2) in '0' .. '9' then
1517                Name_Len := J - 1;
1518                J := Name_Len - 1;
1519
1520             --  If not a homonym separator, then we simply strip the
1521             --  separator and everything that precedes it, and we are done
1522
1523             else
1524                Name_Buffer (1 .. Name_Len - J - 1) :=
1525                  Name_Buffer (J + 2 .. Name_Len);
1526                Name_Len := Name_Len - J - 1;
1527                exit;
1528             end if;
1529
1530          else
1531             J := J - 1;
1532          end if;
1533       end loop;
1534    end Strip_Qualification_And_Suffixes;
1535
1536    ---------------
1537    -- Tree_Read --
1538    ---------------
1539
1540    procedure Tree_Read is
1541    begin
1542       Name_Chars.Tree_Read;
1543       Name_Entries.Tree_Read;
1544
1545       Tree_Read_Data
1546         (Hash_Table'Address,
1547          Hash_Table'Length * (Hash_Table'Component_Size / Storage_Unit));
1548    end Tree_Read;
1549
1550    ----------------
1551    -- Tree_Write --
1552    ----------------
1553
1554    procedure Tree_Write is
1555    begin
1556       Name_Chars.Tree_Write;
1557       Name_Entries.Tree_Write;
1558
1559       Tree_Write_Data
1560         (Hash_Table'Address,
1561          Hash_Table'Length * (Hash_Table'Component_Size / Storage_Unit));
1562    end Tree_Write;
1563
1564    ------------
1565    -- Unlock --
1566    ------------
1567
1568    procedure Unlock is
1569    begin
1570       Name_Chars.Set_Last (Name_Chars.Last - Name_Chars_Reserve);
1571       Name_Entries.Set_Last (Name_Entries.Last - Name_Entries_Reserve);
1572       Name_Chars.Locked := False;
1573       Name_Entries.Locked := False;
1574       Name_Chars.Release;
1575       Name_Entries.Release;
1576    end Unlock;
1577
1578    --------
1579    -- wn --
1580    --------
1581
1582    procedure wn (Id : Name_Id) is
1583       S : Int;
1584
1585    begin
1586       if not Id'Valid then
1587          Write_Str ("<invalid name_id>");
1588
1589       elsif Id = No_Name then
1590          Write_Str ("<No_Name>");
1591
1592       elsif Id = Error_Name then
1593          Write_Str ("<Error_Name>");
1594
1595       else
1596          S := Name_Entries.Table (Id).Name_Chars_Index;
1597          Name_Len := Natural (Name_Entries.Table (Id).Name_Len);
1598
1599          for J in 1 .. Name_Len loop
1600             Write_Char (Name_Chars.Table (S + Int (J)));
1601          end loop;
1602       end if;
1603
1604       Write_Eol;
1605    end wn;
1606
1607    ----------------
1608    -- Write_Name --
1609    ----------------
1610
1611    procedure Write_Name (Id : Name_Id) is
1612    begin
1613       if Id >= First_Name_Id then
1614          Get_Name_String (Id);
1615          Write_Str (Name_Buffer (1 .. Name_Len));
1616       end if;
1617    end Write_Name;
1618
1619    ------------------------
1620    -- Write_Name_Decoded --
1621    ------------------------
1622
1623    procedure Write_Name_Decoded (Id : Name_Id) is
1624    begin
1625       if Id >= First_Name_Id then
1626          Get_Decoded_Name_String (Id);
1627          Write_Str (Name_Buffer (1 .. Name_Len));
1628       end if;
1629    end Write_Name_Decoded;
1630
1631 --  Package initialization, initialize tables
1632
1633 begin
1634    Reinitialize;
1635 end Namet;