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