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