gcc/ada/namet.adb

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