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