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