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