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