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-2004 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 2,  or (at your option) any later ver- --
  14 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  15 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  16 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  17 -- for  more details.  You should have  received  a copy of the GNU General --
  18 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  19 -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  20 -- MA 02111-1307, USA.                                                      --
  21 --                                                                          --
  22 -- As a special exception,  if other files  instantiate  generics from this --
  23 -- unit, or you link  this unit with other files  to produce an executable, --
  24 -- this  unit  does not  by itself cause  the resulting  executable  to  be --
  25 -- covered  by the  GNU  General  Public  License.  This exception does not --
  26 -- however invalidate  any other reasons why  the executable file  might be --
  27 -- covered by the  GNU Public License.                                      --
  28 --                                                                          --
  29 -- GNAT was originally developed  by the GNAT team at  New York University. --
  30 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  31 --                                                                          --
  32 ------------------------------------------------------------------------------
  33
  34 --  WARNING: There is a C version of this package. Any changes to this
  35 --  source file must be properly reflected in the C header file a-namet.h
  36 --  which is created manually from namet.ads and namet.adb.
  37
  38 with Debug;    use Debug;
  39 with Output;   use Output;
  40 with Tree_IO;  use Tree_IO;
  41 with Widechar; use Widechar;
  42
  43 package body Namet is
  44
  45    Name_Chars_Reserve   : constant := 5000;
  46    Name_Entries_Reserve : constant := 100;
  47    --  The names table is locked during gigi processing, since gigi assumes
  48    --  that the table does not move. After returning from gigi, the names
  49    --  table is unlocked again, since writing library file information needs
  50    --  to generate some extra names. To avoid the inefficiency of always
  51    --  reallocating during this second unlocked phase, we reserve a bit of
  52    --  extra space before doing the release call.
  53
  54    Hash_Num : constant Int := 2**12;
  55    --  Number of headers in the hash table. Current hash algorithm is closely
  56    --  tailored to this choice, so it can only be changed if a corresponding
  57    --  change is made to the hash alogorithm.
  58
  59    Hash_Max : constant Int := Hash_Num - 1;
  60    --  Indexes in the hash header table run from 0 to Hash_Num - 1
  61
  62    subtype Hash_Index_Type is Int range 0 .. Hash_Max;
  63    --  Range of hash index values
  64
  65    Hash_Table : array (Hash_Index_Type) of Name_Id;
  66    --  The hash table is used to locate existing entries in the names table.
  67    --  The entries point to the first names table entry whose hash value
  68    --  matches the hash code. Then subsequent names table entries with the
  69    --  same hash code value are linked through the Hash_Link fields.
  70
  71    -----------------------
  72    -- Local Subprograms --
  73    -----------------------
  74
  75    function Hash return Hash_Index_Type;
  76    pragma Inline (Hash);
  77    --  Compute hash code for name stored in Name_Buffer (length in Name_Len)
  78
  79    procedure Strip_Qualification_And_Suffixes;
  80    --  Given an encoded entity name in Name_Buffer, remove package body
  81    --  suffix as described for Strip_Package_Body_Suffix, and also remove
  82    --  all qualification, i.e. names followed by two underscores. The
  83    --  contents of Name_Buffer is modified by this call, and on return
  84    --  Name_Buffer and Name_Len reflect the stripped name.
  85
  86    -----------------------------
  87    -- Add_Char_To_Name_Buffer --
  88    -----------------------------
  89
  90    procedure Add_Char_To_Name_Buffer (C : Character) is
  91    begin
  92       if Name_Len < Name_Buffer'Last then
  93          Name_Len := Name_Len + 1;
  94          Name_Buffer (Name_Len) := C;
  95       end if;
  96    end Add_Char_To_Name_Buffer;
  97
  98    ----------------------------
  99    -- Add_Nat_To_Name_Buffer --
 100    ----------------------------
 101
 102    procedure Add_Nat_To_Name_Buffer (V : Nat) is
 103    begin
 104       if V >= 10 then
 105          Add_Nat_To_Name_Buffer (V / 10);
 106       end if;
 107
 108       Add_Char_To_Name_Buffer (Character'Val (Character'Pos ('0') + V rem 10));
 109    end Add_Nat_To_Name_Buffer;
 110
 111    ----------------------------
 112    -- Add_Str_To_Name_Buffer --
 113    ----------------------------
 114
 115    procedure Add_Str_To_Name_Buffer (S : String) is
 116    begin
 117       for J in S'Range loop
 118          Add_Char_To_Name_Buffer (S (J));
 119       end loop;
 120    end Add_Str_To_Name_Buffer;
 121
 122
 123    --------------
 124    -- Finalize --
 125    --------------
 126
 127    procedure Finalize is
 128       Max_Chain_Length : constant := 50;
 129       --  Max length of chains for which specific information is output
 130
 131       F : array (Int range 0 .. Max_Chain_Length) of Int;
 132       --  N'th entry is number of chains of length N
 133
 134       Probes : Int := 0;
 135       --  Used to compute average number of probes
 136
 137       Nsyms : Int := 0;
 138       --  Number of symbols in table
 139
 140    begin
 141       if Debug_Flag_H then
 142
 143          for J in F'Range loop
 144             F (J) := 0;
 145          end loop;
 146
 147          for I in Hash_Index_Type loop
 148             if Hash_Table (I) = No_Name then
 149                F (0) := F (0) + 1;
 150
 151             else
 152                Write_Str ("Hash_Table (");
 153                Write_Int (Int (I));
 154                Write_Str (") has ");
 155
 156                declare
 157                   C : Int := 1;
 158                   N : Name_Id;
 159                   S : Int;
 160
 161                begin
 162                   C := 0;
 163                   N := Hash_Table (I);
 164
 165                   while N /= No_Name loop
 166                      N := Name_Entries.Table (N).Hash_Link;
 167                      C := C + 1;
 168                   end loop;
 169
 170                   Write_Int (C);
 171                   Write_Str (" entries");
 172                   Write_Eol;
 173
 174                   if C < Max_Chain_Length then
 175                      F (C) := F (C) + 1;
 176                   else
 177                      F (Max_Chain_Length) := F (Max_Chain_Length) + 1;
 178                   end if;
 179
 180                   N := Hash_Table (I);
 181
 182                   while N /= No_Name loop
 183                      S := Name_Entries.Table (N).Name_Chars_Index;
 184                      Write_Str ("      ");
 185
 186                      for J in 1 .. Name_Entries.Table (N).Name_Len loop
 187                         Write_Char (Name_Chars.Table (S + Int (J)));
 188                      end loop;
 189
 190                      Write_Eol;
 191                      N := Name_Entries.Table (N).Hash_Link;
 192                   end loop;
 193                end;
 194             end if;
 195          end loop;
 196
 197          Write_Eol;
 198
 199          for I in Int range 0 .. Max_Chain_Length loop
 200             if F (I) /= 0 then
 201                Write_Str ("Number of hash chains of length ");
 202
 203                if I < 10 then
 204                   Write_Char (' ');
 205                end if;
 206
 207                Write_Int (I);
 208
 209                if I = Max_Chain_Length then
 210                   Write_Str (" or greater");
 211                end if;
 212
 213                Write_Str (" = ");
 214                Write_Int (F (I));
 215                Write_Eol;
 216
 217                if I /= 0 then
 218                   Nsyms := Nsyms + F (I);
 219                   Probes := Probes + F (I) * (1 + I) * 100;
 220                end if;
 221             end if;
 222          end loop;
 223
 224          Write_Eol;
 225          Write_Str ("Average number of probes for lookup = ");
 226          Probes := Probes / Nsyms;
 227          Write_Int (Probes / 200);
 228          Write_Char ('.');
 229          Probes := (Probes mod 200) / 2;
 230          Write_Char (Character'Val (48 + Probes / 10));
 231          Write_Char (Character'Val (48 + Probes mod 10));
 232          Write_Eol;
 233          Write_Eol;
 234       end if;
 235    end Finalize;
 236
 237    -----------------------------
 238    -- Get_Decoded_Name_String --
 239    -----------------------------
 240
 241    procedure Get_Decoded_Name_String (Id : Name_Id) is
 242       C : Character;
 243       P : Natural;
 244
 245    begin
 246       Get_Name_String (Id);
 247
 248       --  Quick loop to see if there is anything special to do
 249
 250       P := 1;
 251       loop
 252          if P = Name_Len then
 253             return;
 254
 255          else
 256             C := Name_Buffer (P);
 257
 258             exit when
 259               C = 'U' or else
 260               C = 'W' or else
 261               C = 'Q' or else
 262               C = 'O';
 263
 264             P := P + 1;
 265          end if;
 266       end loop;
 267
 268       --  Here we have at least some encoding that we must decode
 269
 270       Decode : declare
 271          New_Len : Natural;
 272          Old     : Positive;
 273          New_Buf : String (1 .. Name_Buffer'Last);
 274
 275          procedure Copy_One_Character;
 276          --  Copy a character from Name_Buffer to New_Buf. Includes case
 277          --  of copying a Uhh or Whhhh sequence and decoding it.
 278
 279          function Hex (N : Natural) return Natural;
 280          --  Scans past N digits using Old pointer and returns hex value
 281
 282          procedure Insert_Character (C : Character);
 283          --  Insert a new character into output decoded name
 284
 285          ------------------------
 286          -- Copy_One_Character --
 287          ------------------------
 288
 289          procedure Copy_One_Character is
 290             C : Character;
 291
 292          begin
 293             C := Name_Buffer (Old);
 294
 295             --  U (upper half insertion case)
 296
 297             if C = 'U'
 298               and then Old < Name_Len
 299               and then Name_Buffer (Old + 1) not in 'A' .. 'Z'
 300               and then Name_Buffer (Old + 1) /= '_'
 301             then
 302                Old := Old + 1;
 303                Insert_Character (Character'Val (Hex (2)));
 304
 305             --  W (wide character insertion)
 306
 307             elsif C = 'W'
 308               and then Old < Name_Len
 309               and then Name_Buffer (Old + 1) not in 'A' .. 'Z'
 310               and then Name_Buffer (Old + 1) /= '_'
 311             then
 312                Old := Old + 1;
 313                Widechar.Set_Wide (Char_Code (Hex (4)), New_Buf, New_Len);
 314
 315             --  Any other character is copied unchanged
 316
 317             else
 318                Insert_Character (C);
 319                Old := Old + 1;
 320             end if;
 321          end Copy_One_Character;
 322
 323          ---------
 324          -- Hex --
 325          ---------
 326
 327          function Hex (N : Natural) return Natural is
 328             T : Natural := 0;
 329             C : Character;
 330
 331          begin
 332             for J in 1 .. N loop
 333                C := Name_Buffer (Old);
 334                Old := Old + 1;
 335
 336                pragma Assert (C in '0' .. '9' or else C in 'a' .. 'f');
 337
 338                if C <= '9' then
 339                   T := 16 * T + Character'Pos (C) - Character'Pos ('0');
 340                else -- C in 'a' .. 'f'
 341                   T := 16 * T + Character'Pos (C) - (Character'Pos ('a') - 10);
 342                end if;
 343             end loop;
 344
 345             return T;
 346          end Hex;
 347
 348          ----------------------
 349          -- Insert_Character --
 350          ----------------------
 351
 352          procedure Insert_Character (C : Character) is
 353          begin
 354             New_Len := New_Len + 1;
 355             New_Buf (New_Len) := C;
 356          end Insert_Character;
 357
 358       --  Start of processing for Decode
 359
 360       begin
 361          New_Len := 0;
 362          Old := 1;
 363
 364          --  Loop through characters of name
 365
 366          while Old <= Name_Len loop
 367
 368             --  Case of character literal, put apostrophes around character
 369
 370             if Name_Buffer (Old) = 'Q'
 371               and then Old < Name_Len
 372             then
 373                Old := Old + 1;
 374                Insert_Character (''');
 375                Copy_One_Character;
 376                Insert_Character (''');
 377
 378             --  Case of operator name
 379
 380             elsif Name_Buffer (Old) = 'O'
 381               and then Old < Name_Len
 382               and then Name_Buffer (Old + 1) not in 'A' .. 'Z'
 383               and then Name_Buffer (Old + 1) /= '_'
 384             then
 385                Old := Old + 1;
 386
 387                declare
 388                   --  This table maps the 2nd and 3rd characters of the name
 389                   --  into the required output. Two blanks means leave the
 390                   --  name alone
 391
 392                   Map : constant String :=
 393                      "ab  " &               --  Oabs         => "abs"
 394                      "ad+ " &               --  Oadd         => "+"
 395                      "an  " &               --  Oand         => "and"
 396                      "co& " &               --  Oconcat      => "&"
 397                      "di/ " &               --  Odivide      => "/"
 398                      "eq= " &               --  Oeq          => "="
 399                      "ex**" &               --  Oexpon       => "**"
 400                      "gt> " &               --  Ogt          => ">"
 401                      "ge>=" &               --  Oge          => ">="
 402                      "le<=" &               --  Ole          => "<="
 403                      "lt< " &               --  Olt          => "<"
 404                      "mo  " &               --  Omod         => "mod"
 405                      "mu* " &               --  Omutliply    => "*"
 406                      "ne/=" &               --  One          => "/="
 407                      "no  " &               --  Onot         => "not"
 408                      "or  " &               --  Oor          => "or"
 409                      "re  " &               --  Orem         => "rem"
 410                      "su- " &               --  Osubtract    => "-"
 411                      "xo  ";                --  Oxor         => "xor"
 412
 413                   J : Integer;
 414
 415                begin
 416                   Insert_Character ('"');
 417
 418                   --  Search the map. Note that this loop must terminate, if
 419                   --  not we have some kind of internal error, and a constraint
 420                   --  constraint error may be raised.
 421
 422                   J := Map'First;
 423                   loop
 424                      exit when Name_Buffer (Old) = Map (J)
 425                        and then Name_Buffer (Old + 1) = Map (J + 1);
 426                      J := J + 4;
 427                   end loop;
 428
 429                   --  Special operator name
 430
 431                   if Map (J + 2) /= ' ' then
 432                      Insert_Character (Map (J + 2));
 433
 434                      if Map (J + 3) /= ' ' then
 435                         Insert_Character (Map (J + 3));
 436                      end if;
 437
 438                      Insert_Character ('"');
 439
 440                      --  Skip past original operator name in input
 441
 442                      while Old <= Name_Len
 443                        and then Name_Buffer (Old) in 'a' .. 'z'
 444                      loop
 445                         Old := Old + 1;
 446                      end loop;
 447
 448                   --  For other operator names, leave them in lower case,
 449                   --  surrounded by apostrophes
 450
 451                   else
 452                      --  Copy original operator name from input to output
 453
 454                      while Old <= Name_Len
 455                         and then Name_Buffer (Old) in 'a' .. 'z'
 456                      loop
 457                         Copy_One_Character;
 458                      end loop;
 459
 460                      Insert_Character ('"');
 461                   end if;
 462                end;
 463
 464             --  Else copy one character and keep going
 465
 466             else
 467                Copy_One_Character;
 468             end if;
 469          end loop;
 470
 471          --  Copy new buffer as result
 472
 473          Name_Len := New_Len;
 474          Name_Buffer (1 .. New_Len) := New_Buf (1 .. New_Len);
 475       end Decode;
 476    end Get_Decoded_Name_String;
 477
 478    -------------------------------------------
 479    -- Get_Decoded_Name_String_With_Brackets --
 480    -------------------------------------------
 481
 482    procedure Get_Decoded_Name_String_With_Brackets (Id : Name_Id) is
 483       P : Natural;
 484
 485    begin
 486       --  Case of operator name, normal decoding is fine
 487
 488       if Name_Buffer (1) = 'O' then
 489          Get_Decoded_Name_String (Id);
 490
 491       --  For character literals, normal decoding is fine
 492
 493       elsif Name_Buffer (1) = 'Q' then
 494          Get_Decoded_Name_String (Id);
 495
 496       --  Only remaining issue is U/W sequences
 497
 498       else
 499          Get_Name_String (Id);
 500
 501          P := 1;
 502          while P < Name_Len loop
 503             if Name_Buffer (P + 1) in 'A' .. 'Z' then
 504                P := P + 1;
 505
 506             elsif Name_Buffer (P) = 'U' then
 507                for J in reverse P + 3 .. P + Name_Len loop
 508                   Name_Buffer (J + 3) := Name_Buffer (J);
 509                end loop;
 510
 511                Name_Len := Name_Len + 3;
 512                Name_Buffer (P + 3) := Name_Buffer (P + 2);
 513                Name_Buffer (P + 2) := Name_Buffer (P + 1);
 514                Name_Buffer (P)     := '[';
 515                Name_Buffer (P + 1) := '"';
 516                Name_Buffer (P + 4) := '"';
 517                Name_Buffer (P + 5) := ']';
 518                P := P + 6;
 519
 520             elsif Name_Buffer (P) = 'W' then
 521                Name_Buffer (P + 8 .. P + Name_Len + 5) :=
 522                  Name_Buffer (P + 5 .. Name_Len);
 523                Name_Buffer (P + 5) := Name_Buffer (P + 4);
 524                Name_Buffer (P + 4) := Name_Buffer (P + 3);
 525                Name_Buffer (P + 3) := Name_Buffer (P + 2);
 526                Name_Buffer (P + 2) := Name_Buffer (P + 1);
 527                Name_Buffer (P)     := '[';
 528                Name_Buffer (P + 1) := '"';
 529                Name_Buffer (P + 6) := '"';
 530                Name_Buffer (P + 7) := ']';
 531                Name_Len := Name_Len + 5;
 532                P := P + 8;
 533
 534             else
 535                P := P + 1;
 536             end if;
 537          end loop;
 538       end if;
 539    end Get_Decoded_Name_String_With_Brackets;
 540
 541    ------------------------
 542    -- Get_Last_Two_Chars --
 543    ------------------------
 544
 545    procedure Get_Last_Two_Chars (N : Name_Id; C1, C2 : out Character) is
 546       NE  : Name_Entry renames Name_Entries.Table (N);
 547       NEL : constant Int := Int (NE.Name_Len);
 548
 549    begin
 550       if NEL >= 2 then
 551          C1 := Name_Chars.Table (NE.Name_Chars_Index + NEL - 1);
 552          C2 := Name_Chars.Table (NE.Name_Chars_Index + NEL - 0);
 553       else
 554          C1 := ASCII.NUL;
 555          C2 := ASCII.NUL;
 556       end if;
 557    end Get_Last_Two_Chars;
 558
 559    ---------------------
 560    -- Get_Name_String --
 561    ---------------------
 562
 563    procedure Get_Name_String (Id : Name_Id) is
 564       S : Int;
 565
 566    begin
 567       pragma Assert (Id in Name_Entries.First .. Name_Entries.Last);
 568
 569       S := Name_Entries.Table (Id).Name_Chars_Index;
 570       Name_Len := Natural (Name_Entries.Table (Id).Name_Len);
 571
 572       for J in 1 .. Name_Len loop
 573          Name_Buffer (J) := Name_Chars.Table (S + Int (J));
 574       end loop;
 575    end Get_Name_String;
 576
 577    function Get_Name_String (Id : Name_Id) return String is
 578       S : Int;
 579
 580    begin
 581       pragma Assert (Id in Name_Entries.First .. Name_Entries.Last);
 582       S := Name_Entries.Table (Id).Name_Chars_Index;
 583
 584       declare
 585          R : String (1 .. Natural (Name_Entries.Table (Id).Name_Len));
 586
 587       begin
 588          for J in R'Range loop
 589             R (J) := Name_Chars.Table (S + Int (J));
 590          end loop;
 591
 592          return R;
 593       end;
 594    end Get_Name_String;
 595
 596    --------------------------------
 597    -- Get_Name_String_And_Append --
 598    --------------------------------
 599
 600    procedure Get_Name_String_And_Append (Id : Name_Id) is
 601       S : Int;
 602
 603    begin
 604       pragma Assert (Id in Name_Entries.First .. Name_Entries.Last);
 605
 606       S := Name_Entries.Table (Id).Name_Chars_Index;
 607
 608       for J in 1 .. Natural (Name_Entries.Table (Id).Name_Len) loop
 609          Name_Len := Name_Len + 1;
 610          Name_Buffer (Name_Len) := Name_Chars.Table (S + Int (J));
 611       end loop;
 612    end Get_Name_String_And_Append;
 613
 614    -------------------------
 615    -- Get_Name_Table_Byte --
 616    -------------------------
 617
 618    function Get_Name_Table_Byte (Id : Name_Id) return Byte is
 619    begin
 620       pragma Assert (Id in Name_Entries.First .. Name_Entries.Last);
 621       return Name_Entries.Table (Id).Byte_Info;
 622    end Get_Name_Table_Byte;
 623
 624    -------------------------
 625    -- Get_Name_Table_Info --
 626    -------------------------
 627
 628    function Get_Name_Table_Info (Id : Name_Id) return Int is
 629    begin
 630       pragma Assert (Id in Name_Entries.First .. Name_Entries.Last);
 631       return Name_Entries.Table (Id).Int_Info;
 632    end Get_Name_Table_Info;
 633
 634    -----------------------------------------
 635    -- Get_Unqualified_Decoded_Name_String --
 636    -----------------------------------------
 637
 638    procedure Get_Unqualified_Decoded_Name_String (Id : Name_Id) is
 639    begin
 640       Get_Decoded_Name_String (Id);
 641       Strip_Qualification_And_Suffixes;
 642    end Get_Unqualified_Decoded_Name_String;
 643
 644    ---------------------------------
 645    -- Get_Unqualified_Name_String --
 646    ---------------------------------
 647
 648    procedure Get_Unqualified_Name_String (Id : Name_Id) is
 649    begin
 650       Get_Name_String (Id);
 651       Strip_Qualification_And_Suffixes;
 652    end Get_Unqualified_Name_String;
 653
 654    ----------
 655    -- Hash --
 656    ----------
 657
 658    function Hash return Hash_Index_Type is
 659       subtype Int_0_12 is Int range 0 .. 12;
 660       --  Used to avoid when others on case jump below
 661
 662       Even_Name_Len : Integer;
 663       --  Last even numbered position (used for >12 case)
 664
 665    begin
 666
 667       --  Special test for 12 (rather than counting on a when others for the
 668       --  case statement below) avoids some Ada compilers converting the case
 669       --  statement into successive jumps.
 670
 671       --  The case of a name longer than 12 characters is handled by taking
 672       --  the first 6 odd numbered characters and the last 6 even numbered
 673       --  characters
 674
 675       if Name_Len > 12 then
 676          Even_Name_Len := (Name_Len) / 2 * 2;
 677
 678          return ((((((((((((
 679            Character'Pos (Name_Buffer (01))) * 2 +
 680            Character'Pos (Name_Buffer (Even_Name_Len - 10))) * 2 +
 681            Character'Pos (Name_Buffer (03))) * 2 +
 682            Character'Pos (Name_Buffer (Even_Name_Len - 08))) * 2 +
 683            Character'Pos (Name_Buffer (05))) * 2 +
 684            Character'Pos (Name_Buffer (Even_Name_Len - 06))) * 2 +
 685            Character'Pos (Name_Buffer (07))) * 2 +
 686            Character'Pos (Name_Buffer (Even_Name_Len - 04))) * 2 +
 687            Character'Pos (Name_Buffer (09))) * 2 +
 688            Character'Pos (Name_Buffer (Even_Name_Len - 02))) * 2 +
 689            Character'Pos (Name_Buffer (11))) * 2 +
 690            Character'Pos (Name_Buffer (Even_Name_Len))) mod Hash_Num;
 691       end if;
 692
 693       --  For the cases of 1-12 characters, all characters participate in the
 694       --  hash. The positioning is randomized, with the bias that characters
 695       --  later on participate fully (i.e. are added towards the right side).
 696
 697       case Int_0_12 (Name_Len) is
 698
 699          when 0 =>
 700             return 0;
 701
 702          when 1 =>
 703             return
 704                Character'Pos (Name_Buffer (1));
 705
 706          when 2 =>
 707             return ((
 708               Character'Pos (Name_Buffer (1))) * 64 +
 709               Character'Pos (Name_Buffer (2))) mod Hash_Num;
 710
 711          when 3 =>
 712             return (((
 713               Character'Pos (Name_Buffer (1))) * 16 +
 714               Character'Pos (Name_Buffer (3))) * 16 +
 715               Character'Pos (Name_Buffer (2))) mod Hash_Num;
 716
 717          when 4 =>
 718             return ((((
 719               Character'Pos (Name_Buffer (1))) * 8 +
 720               Character'Pos (Name_Buffer (2))) * 8 +
 721               Character'Pos (Name_Buffer (3))) * 8 +
 722               Character'Pos (Name_Buffer (4))) mod Hash_Num;
 723
 724          when 5 =>
 725             return (((((
 726               Character'Pos (Name_Buffer (4))) * 8 +
 727               Character'Pos (Name_Buffer (1))) * 4 +
 728               Character'Pos (Name_Buffer (3))) * 4 +
 729               Character'Pos (Name_Buffer (5))) * 8 +
 730               Character'Pos (Name_Buffer (2))) mod Hash_Num;
 731
 732          when 6 =>
 733             return ((((((
 734               Character'Pos (Name_Buffer (5))) * 4 +
 735               Character'Pos (Name_Buffer (1))) * 4 +
 736               Character'Pos (Name_Buffer (4))) * 4 +
 737               Character'Pos (Name_Buffer (2))) * 4 +
 738               Character'Pos (Name_Buffer (6))) * 4 +
 739               Character'Pos (Name_Buffer (3))) mod Hash_Num;
 740
 741          when 7 =>
 742             return (((((((
 743               Character'Pos (Name_Buffer (4))) * 4 +
 744               Character'Pos (Name_Buffer (3))) * 4 +
 745               Character'Pos (Name_Buffer (1))) * 4 +
 746               Character'Pos (Name_Buffer (2))) * 2 +
 747               Character'Pos (Name_Buffer (5))) * 2 +
 748               Character'Pos (Name_Buffer (7))) * 2 +
 749               Character'Pos (Name_Buffer (6))) mod Hash_Num;
 750
 751          when 8 =>
 752             return ((((((((
 753               Character'Pos (Name_Buffer (2))) * 4 +
 754               Character'Pos (Name_Buffer (1))) * 4 +
 755               Character'Pos (Name_Buffer (3))) * 2 +
 756               Character'Pos (Name_Buffer (5))) * 2 +
 757               Character'Pos (Name_Buffer (7))) * 2 +
 758               Character'Pos (Name_Buffer (6))) * 2 +
 759               Character'Pos (Name_Buffer (4))) * 2 +
 760               Character'Pos (Name_Buffer (8))) mod Hash_Num;
 761
 762          when 9 =>
 763             return (((((((((
 764               Character'Pos (Name_Buffer (2))) * 4 +
 765               Character'Pos (Name_Buffer (1))) * 4 +
 766               Character'Pos (Name_Buffer (3))) * 4 +
 767               Character'Pos (Name_Buffer (4))) * 2 +
 768               Character'Pos (Name_Buffer (8))) * 2 +
 769               Character'Pos (Name_Buffer (7))) * 2 +
 770               Character'Pos (Name_Buffer (5))) * 2 +
 771               Character'Pos (Name_Buffer (6))) * 2 +
 772               Character'Pos (Name_Buffer (9))) mod Hash_Num;
 773
 774          when 10 =>
 775             return ((((((((((
 776               Character'Pos (Name_Buffer (01))) * 2 +
 777               Character'Pos (Name_Buffer (02))) * 2 +
 778               Character'Pos (Name_Buffer (08))) * 2 +
 779               Character'Pos (Name_Buffer (03))) * 2 +
 780               Character'Pos (Name_Buffer (04))) * 2 +
 781               Character'Pos (Name_Buffer (09))) * 2 +
 782               Character'Pos (Name_Buffer (06))) * 2 +
 783               Character'Pos (Name_Buffer (05))) * 2 +
 784               Character'Pos (Name_Buffer (07))) * 2 +
 785               Character'Pos (Name_Buffer (10))) mod Hash_Num;
 786
 787          when 11 =>
 788             return (((((((((((
 789               Character'Pos (Name_Buffer (05))) * 2 +
 790               Character'Pos (Name_Buffer (01))) * 2 +
 791               Character'Pos (Name_Buffer (06))) * 2 +
 792               Character'Pos (Name_Buffer (09))) * 2 +
 793               Character'Pos (Name_Buffer (07))) * 2 +
 794               Character'Pos (Name_Buffer (03))) * 2 +
 795               Character'Pos (Name_Buffer (08))) * 2 +
 796               Character'Pos (Name_Buffer (02))) * 2 +
 797               Character'Pos (Name_Buffer (10))) * 2 +
 798               Character'Pos (Name_Buffer (04))) * 2 +
 799               Character'Pos (Name_Buffer (11))) mod Hash_Num;
 800
 801          when 12 =>
 802             return ((((((((((((
 803               Character'Pos (Name_Buffer (03))) * 2 +
 804               Character'Pos (Name_Buffer (02))) * 2 +
 805               Character'Pos (Name_Buffer (05))) * 2 +
 806               Character'Pos (Name_Buffer (01))) * 2 +
 807               Character'Pos (Name_Buffer (06))) * 2 +
 808               Character'Pos (Name_Buffer (04))) * 2 +
 809               Character'Pos (Name_Buffer (08))) * 2 +
 810               Character'Pos (Name_Buffer (11))) * 2 +
 811               Character'Pos (Name_Buffer (07))) * 2 +
 812               Character'Pos (Name_Buffer (09))) * 2 +
 813               Character'Pos (Name_Buffer (10))) * 2 +
 814               Character'Pos (Name_Buffer (12))) mod Hash_Num;
 815
 816       end case;
 817    end Hash;
 818
 819    ----------------
 820    -- Initialize --
 821    ----------------
 822
 823    procedure Initialize is
 824
 825    begin
 826       Name_Chars.Init;
 827       Name_Entries.Init;
 828
 829       --  Initialize entries for one character names
 830
 831       for C in Character loop
 832          Name_Entries.Increment_Last;
 833          Name_Entries.Table (Name_Entries.Last).Name_Chars_Index :=
 834            Name_Chars.Last;
 835          Name_Entries.Table (Name_Entries.Last).Name_Len  := 1;
 836          Name_Entries.Table (Name_Entries.Last).Hash_Link := No_Name;
 837          Name_Entries.Table (Name_Entries.Last).Int_Info  := 0;
 838          Name_Entries.Table (Name_Entries.Last).Byte_Info := 0;
 839          Name_Chars.Increment_Last;
 840          Name_Chars.Table (Name_Chars.Last) := C;
 841          Name_Chars.Increment_Last;
 842          Name_Chars.Table (Name_Chars.Last) := ASCII.NUL;
 843       end loop;
 844
 845       --  Clear hash table
 846
 847       for J in Hash_Index_Type loop
 848          Hash_Table (J) := No_Name;
 849       end loop;
 850    end Initialize;
 851
 852    ----------------------
 853    -- Is_Internal_Name --
 854    ----------------------
 855
 856    function Is_Internal_Name (Id : Name_Id) return Boolean is
 857    begin
 858       Get_Name_String (Id);
 859       return Is_Internal_Name;
 860    end Is_Internal_Name;
 861
 862    function Is_Internal_Name return Boolean is
 863    begin
 864       if Name_Buffer (1) = '_'
 865         or else Name_Buffer (Name_Len) = '_'
 866       then
 867          return True;
 868
 869       else
 870          --  Test backwards, because we only want to test the last entity
 871          --  name if the name we have is qualified with other entities.
 872
 873          for J in reverse 1 .. Name_Len loop
 874             if Is_OK_Internal_Letter (Name_Buffer (J)) then
 875                return True;
 876
 877             --  Quit if we come to terminating double underscore (note that
 878             --  if the current character is an underscore, we know that
 879             --  there is a previous character present, since we already
 880             --  filtered out the case of Name_Buffer (1) = '_' above.
 881
 882             elsif Name_Buffer (J) = '_'
 883               and then Name_Buffer (J - 1) = '_'
 884               and then Name_Buffer (J - 2) /= '_'
 885             then
 886                return False;
 887             end if;
 888          end loop;
 889       end if;
 890
 891       return False;
 892    end Is_Internal_Name;
 893
 894    ---------------------------
 895    -- Is_OK_Internal_Letter --
 896    ---------------------------
 897
 898    function Is_OK_Internal_Letter (C : Character) return Boolean is
 899    begin
 900       return C in 'A' .. 'Z'
 901         and then C /= 'O'
 902         and then C /= 'Q'
 903         and then C /= 'U'
 904         and then C /= 'W'
 905         and then C /= 'X';
 906    end Is_OK_Internal_Letter;
 907
 908    ----------------------
 909    -- Is_Operator_Name --
 910    ----------------------
 911
 912    function Is_Operator_Name (Id : Name_Id) return Boolean is
 913       S : Int;
 914    begin
 915       pragma Assert (Id in Name_Entries.First .. Name_Entries.Last);
 916       S := Name_Entries.Table (Id).Name_Chars_Index;
 917       return Name_Chars.Table (S + 1) = 'O';
 918    end Is_Operator_Name;
 919
 920    --------------------
 921    -- Length_Of_Name --
 922    --------------------
 923
 924    function Length_Of_Name (Id : Name_Id) return Nat is
 925    begin
 926       return Int (Name_Entries.Table (Id).Name_Len);
 927    end Length_Of_Name;
 928
 929    ----------
 930    -- Lock --
 931    ----------
 932
 933    procedure Lock is
 934    begin
 935       Name_Chars.Set_Last (Name_Chars.Last + Name_Chars_Reserve);
 936       Name_Entries.Set_Last (Name_Entries.Last + Name_Entries_Reserve);
 937       Name_Chars.Locked := True;
 938       Name_Entries.Locked := True;
 939       Name_Chars.Release;
 940       Name_Entries.Release;
 941    end Lock;
 942
 943    ------------------------
 944    -- Name_Chars_Address --
 945    ------------------------
 946
 947    function Name_Chars_Address return System.Address is
 948    begin
 949       return Name_Chars.Table (0)'Address;
 950    end Name_Chars_Address;
 951
 952    ----------------
 953    -- Name_Enter --
 954    ----------------
 955
 956    function Name_Enter return Name_Id is
 957    begin
 958       Name_Entries.Increment_Last;
 959       Name_Entries.Table (Name_Entries.Last).Name_Chars_Index :=
 960         Name_Chars.Last;
 961       Name_Entries.Table (Name_Entries.Last).Name_Len  := Short (Name_Len);
 962       Name_Entries.Table (Name_Entries.Last).Hash_Link := No_Name;
 963       Name_Entries.Table (Name_Entries.Last).Int_Info  := 0;
 964       Name_Entries.Table (Name_Entries.Last).Byte_Info := 0;
 965
 966       --  Set corresponding string entry in the Name_Chars table
 967
 968       for J in 1 .. Name_Len loop
 969          Name_Chars.Increment_Last;
 970          Name_Chars.Table (Name_Chars.Last) := Name_Buffer (J);
 971       end loop;
 972
 973       Name_Chars.Increment_Last;
 974       Name_Chars.Table (Name_Chars.Last) := ASCII.NUL;
 975
 976       return Name_Entries.Last;
 977    end Name_Enter;
 978
 979    --------------------------
 980    -- Name_Entries_Address --
 981    --------------------------
 982
 983    function Name_Entries_Address return System.Address is
 984    begin
 985       return Name_Entries.Table (First_Name_Id)'Address;
 986    end Name_Entries_Address;
 987
 988    ------------------------
 989    -- Name_Entries_Count --
 990    ------------------------
 991
 992    function Name_Entries_Count return Nat is
 993    begin
 994       return Int (Name_Entries.Last - Name_Entries.First + 1);
 995    end Name_Entries_Count;
 996
 997    ---------------
 998    -- Name_Find --
 999    ---------------
1000
1001    function Name_Find return Name_Id is
1002       New_Id : Name_Id;
1003       --  Id of entry in hash search, and value to be returned
1004
1005       S : Int;
1006       --  Pointer into string table
1007
1008       Hash_Index : Hash_Index_Type;
1009       --  Computed hash index
1010
1011    begin
1012       --  Quick handling for one character names
1013
1014       if Name_Len = 1 then
1015          return Name_Id (First_Name_Id + Character'Pos (Name_Buffer (1)));
1016
1017       --  Otherwise search hash table for existing matching entry
1018
1019       else
1020          Hash_Index := Namet.Hash;
1021          New_Id := Hash_Table (Hash_Index);
1022
1023          if New_Id = No_Name then
1024             Hash_Table (Hash_Index) := Name_Entries.Last + 1;
1025
1026          else
1027             Search : loop
1028                if Name_Len /=
1029                  Integer (Name_Entries.Table (New_Id).Name_Len)
1030                then
1031                   goto No_Match;
1032                end if;
1033
1034                S := Name_Entries.Table (New_Id).Name_Chars_Index;
1035
1036                for I in 1 .. Name_Len loop
1037                   if Name_Chars.Table (S + Int (I)) /= Name_Buffer (I) then
1038                      goto No_Match;
1039                   end if;
1040                end loop;
1041
1042                return New_Id;
1043
1044                --  Current entry in hash chain does not match
1045
1046                <<No_Match>>
1047                   if Name_Entries.Table (New_Id).Hash_Link /= No_Name then
1048                      New_Id := Name_Entries.Table (New_Id).Hash_Link;
1049                   else
1050                      Name_Entries.Table (New_Id).Hash_Link :=
1051                        Name_Entries.Last + 1;
1052                      exit Search;
1053                   end if;
1054
1055             end loop Search;
1056          end if;
1057
1058          --  We fall through here only if a matching entry was not found in the
1059          --  hash table. We now create a new entry in the names table. The hash
1060          --  link pointing to the new entry (Name_Entries.Last+1) has been set.
1061
1062          Name_Entries.Increment_Last;
1063          Name_Entries.Table (Name_Entries.Last).Name_Chars_Index :=
1064            Name_Chars.Last;
1065          Name_Entries.Table (Name_Entries.Last).Name_Len  := Short (Name_Len);
1066          Name_Entries.Table (Name_Entries.Last).Hash_Link := No_Name;
1067          Name_Entries.Table (Name_Entries.Last).Int_Info  := 0;
1068          Name_Entries.Table (Name_Entries.Last).Byte_Info := 0;
1069
1070          --  Set corresponding string entry in the Name_Chars table
1071
1072          for I in 1 .. Name_Len loop
1073             Name_Chars.Increment_Last;
1074             Name_Chars.Table (Name_Chars.Last) := Name_Buffer (I);
1075          end loop;
1076
1077          Name_Chars.Increment_Last;
1078          Name_Chars.Table (Name_Chars.Last) := ASCII.NUL;
1079
1080          return Name_Entries.Last;
1081       end if;
1082    end Name_Find;
1083
1084    ----------------------
1085    -- Reset_Name_Table --
1086    ----------------------
1087
1088    procedure Reset_Name_Table is
1089    begin
1090       for J in First_Name_Id .. Name_Entries.Last loop
1091          Name_Entries.Table (J).Int_Info  := 0;
1092          Name_Entries.Table (J).Byte_Info := 0;
1093       end loop;
1094    end Reset_Name_Table;
1095
1096    --------------------------------
1097    -- Set_Character_Literal_Name --
1098    --------------------------------
1099
1100    procedure Set_Character_Literal_Name (C : Char_Code) is
1101    begin
1102       Name_Buffer (1) := 'Q';
1103       Name_Len := 1;
1104       Store_Encoded_Character (C);
1105    end Set_Character_Literal_Name;
1106
1107    -------------------------
1108    -- Set_Name_Table_Byte --
1109    -------------------------
1110
1111    procedure Set_Name_Table_Byte (Id : Name_Id; Val : Byte) is
1112    begin
1113       pragma Assert (Id in Name_Entries.First .. Name_Entries.Last);
1114       Name_Entries.Table (Id).Byte_Info := Val;
1115    end Set_Name_Table_Byte;
1116
1117    -------------------------
1118    -- Set_Name_Table_Info --
1119    -------------------------
1120
1121    procedure Set_Name_Table_Info (Id : Name_Id; Val : Int) is
1122    begin
1123       pragma Assert (Id in Name_Entries.First .. Name_Entries.Last);
1124       Name_Entries.Table (Id).Int_Info := Val;
1125    end Set_Name_Table_Info;
1126
1127    -----------------------------
1128    -- Store_Encoded_Character --
1129    -----------------------------
1130
1131    procedure Store_Encoded_Character (C : Char_Code) is
1132
1133       procedure Set_Hex_Chars (N : Natural);
1134       --  Stores given value, which is in the range 0 .. 255, as two hex
1135       --  digits (using lower case a-f) in Name_Buffer, incrementing Name_Len
1136
1137       procedure Set_Hex_Chars (N : Natural) is
1138          Hexd : constant String := "0123456789abcdef";
1139
1140       begin
1141          Name_Buffer (Name_Len + 1) := Hexd (N / 16 + 1);
1142          Name_Buffer (Name_Len + 2) := Hexd (N mod 16 + 1);
1143          Name_Len := Name_Len + 2;
1144       end Set_Hex_Chars;
1145
1146    begin
1147       Name_Len := Name_Len + 1;
1148
1149       if In_Character_Range (C) then
1150          declare
1151             CC : constant Character := Get_Character (C);
1152
1153          begin
1154             if CC in 'a' .. 'z' or else CC in '0' .. '9' then
1155                Name_Buffer (Name_Len) := CC;
1156
1157             else
1158                Name_Buffer (Name_Len) := 'U';
1159                Set_Hex_Chars (Natural (C));
1160             end if;
1161          end;
1162
1163       else
1164          Name_Buffer (Name_Len) := 'W';
1165          Set_Hex_Chars (Natural (C) / 256);
1166          Set_Hex_Chars (Natural (C) mod 256);
1167       end if;
1168
1169    end Store_Encoded_Character;
1170
1171    --------------------------------------
1172    -- Strip_Qualification_And_Suffixes --
1173    --------------------------------------
1174
1175    procedure Strip_Qualification_And_Suffixes is
1176       J : Integer;
1177
1178    begin
1179       --  Strip package body qualification string off end
1180
1181       for J in reverse 2 .. Name_Len loop
1182          if Name_Buffer (J) = 'X' then
1183             Name_Len := J - 1;
1184             exit;
1185          end if;
1186
1187          exit when Name_Buffer (J) /= 'b'
1188            and then Name_Buffer (J) /= 'n'
1189            and then Name_Buffer (J) /= 'p';
1190       end loop;
1191
1192       --  Find rightmost __ or $ separator if one exists. First we position
1193       --  to start the search. If we have a character constant, position
1194       --  just before it, otherwise position to last character but one
1195
1196       if Name_Buffer (Name_Len) = ''' then
1197          J := Name_Len - 2;
1198          while J > 0 and then Name_Buffer (J) /= ''' loop
1199             J := J - 1;
1200          end loop;
1201
1202       else
1203          J := Name_Len - 1;
1204       end if;
1205
1206       --  Loop to search for rightmost __ or $ (homonym) separator
1207
1208       while J > 1 loop
1209
1210          --  If $ separator, homonym separator, so strip it and keep looking
1211
1212          if Name_Buffer (J) = '$' then
1213             Name_Len := J - 1;
1214             J := Name_Len - 1;
1215
1216          --  Else check for __ found
1217
1218          elsif Name_Buffer (J) = '_' and then Name_Buffer (J + 1) = '_' then
1219
1220             --  Found __ so see if digit follows, and if so, this is a
1221             --  homonym separator, so strip it and keep looking.
1222
1223             if Name_Buffer (J + 2) in '0' .. '9' then
1224                Name_Len := J - 1;
1225                J := Name_Len - 1;
1226
1227             --  If not a homonym separator, then we simply strip the
1228             --  separator and everything that precedes it, and we are done
1229
1230             else
1231                Name_Buffer (1 .. Name_Len - J - 1) :=
1232                  Name_Buffer (J + 2 .. Name_Len);
1233                Name_Len := Name_Len - J - 1;
1234                exit;
1235             end if;
1236
1237          else
1238             J := J - 1;
1239          end if;
1240       end loop;
1241    end Strip_Qualification_And_Suffixes;
1242
1243    ---------------
1244    -- Tree_Read --
1245    ---------------
1246
1247    procedure Tree_Read is
1248    begin
1249       Name_Chars.Tree_Read;
1250       Name_Entries.Tree_Read;
1251
1252       Tree_Read_Data
1253         (Hash_Table'Address,
1254          Hash_Table'Length * (Hash_Table'Component_Size / Storage_Unit));
1255    end Tree_Read;
1256
1257    ----------------
1258    -- Tree_Write --
1259    ----------------
1260
1261    procedure Tree_Write is
1262    begin
1263       Name_Chars.Tree_Write;
1264       Name_Entries.Tree_Write;
1265
1266       Tree_Write_Data
1267         (Hash_Table'Address,
1268          Hash_Table'Length * (Hash_Table'Component_Size / Storage_Unit));
1269    end Tree_Write;
1270
1271    ------------
1272    -- Unlock --
1273    ------------
1274
1275    procedure Unlock is
1276    begin
1277       Name_Chars.Set_Last (Name_Chars.Last - Name_Chars_Reserve);
1278       Name_Entries.Set_Last (Name_Entries.Last - Name_Entries_Reserve);
1279       Name_Chars.Locked := False;
1280       Name_Entries.Locked := False;
1281       Name_Chars.Release;
1282       Name_Entries.Release;
1283    end Unlock;
1284
1285    --------
1286    -- wn --
1287    --------
1288
1289    procedure wn (Id : Name_Id) is
1290    begin
1291       Write_Name (Id);
1292       Write_Eol;
1293    end wn;
1294
1295    ----------------
1296    -- Write_Name --
1297    ----------------
1298
1299    procedure Write_Name (Id : Name_Id) is
1300    begin
1301       if Id >= First_Name_Id then
1302          Get_Name_String (Id);
1303          Write_Str (Name_Buffer (1 .. Name_Len));
1304       end if;
1305    end Write_Name;
1306
1307    ------------------------
1308    -- Write_Name_Decoded --
1309    ------------------------
1310
1311    procedure Write_Name_Decoded (Id : Name_Id) is
1312    begin
1313       if Id >= First_Name_Id then
1314          Get_Decoded_Name_String (Id);
1315          Write_Str (Name_Buffer (1 .. Name_Len));
1316       end if;
1317    end Write_Name_Decoded;
1318
1319 end Namet;