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