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