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