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-2007, 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,  51  Franklin  Street,  Fifth  Floor, --
  20 -- Boston, MA 02110-1301, 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 namet.h
  36 --  which is created manually from namet.ads and namet.adb.
  37
  38 with Debug;    use Debug;
  39 with Opt;      use Opt;
  40 with Output;   use Output;
  41 with Tree_IO;  use Tree_IO;
  42 with Widechar; use Widechar;
  43
  44 package body Namet is
  45
  46    Name_Chars_Reserve   : constant := 5000;
  47    Name_Entries_Reserve : constant := 100;
  48    --  The names table is locked during gigi processing, since gigi assumes
  49    --  that the table does not move. After returning from gigi, the names
  50    --  table is unlocked again, since writing library file information needs
  51    --  to generate some extra names. To avoid the inefficiency of always
  52    --  reallocating during this second unlocked phase, we reserve a bit of
  53    --  extra space before doing the release call.
  54
  55    Hash_Num : constant Int := 2**12;
  56    --  Number of headers in the hash table. Current hash algorithm is closely
  57    --  tailored to this choice, so it can only be changed if a corresponding
  58    --  change is made to the hash 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       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 (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       --  Skip scan if we already know there are no encodings
 248
 249       if Name_Entries.Table (Id).Name_Has_No_Encodings then
 250          return;
 251       end if;
 252
 253       --  Quick loop to see if there is anything special to do
 254
 255       P := 1;
 256       loop
 257          if P = Name_Len then
 258             Name_Entries.Table (Id).Name_Has_No_Encodings := True;
 259             return;
 260
 261          else
 262             C := Name_Buffer (P);
 263
 264             exit when
 265               C = 'U' or else
 266               C = 'W' or else
 267               C = 'Q' or else
 268               C = 'O';
 269
 270             P := P + 1;
 271          end if;
 272       end loop;
 273
 274       --  Here we have at least some encoding that we must decode
 275
 276       Decode : declare
 277          New_Len : Natural;
 278          Old     : Positive;
 279          New_Buf : String (1 .. Name_Buffer'Last);
 280
 281          procedure Copy_One_Character;
 282          --  Copy a character from Name_Buffer to New_Buf. Includes case
 283          --  of copying a Uhh,Whhhh,WWhhhhhhhh sequence and decoding it.
 284
 285          function Hex (N : Natural) return Word;
 286          --  Scans past N digits using Old pointer and returns hex value
 287
 288          procedure Insert_Character (C : Character);
 289          --  Insert a new character into output decoded name
 290
 291          ------------------------
 292          -- Copy_One_Character --
 293          ------------------------
 294
 295          procedure Copy_One_Character is
 296             C : Character;
 297
 298          begin
 299             C := Name_Buffer (Old);
 300
 301             --  U (upper half insertion case)
 302
 303             if C = 'U'
 304               and then Old < Name_Len
 305               and then Name_Buffer (Old + 1) not in 'A' .. 'Z'
 306               and then Name_Buffer (Old + 1) /= '_'
 307             then
 308                Old := Old + 1;
 309
 310                --  If we have upper half encoding, then we have to set an
 311                --  appropriate wide character sequence for this character.
 312
 313                if Upper_Half_Encoding then
 314                   Widechar.Set_Wide (Char_Code (Hex (2)), New_Buf, New_Len);
 315
 316                   --  For other encoding methods, upper half characters can
 317                   --  simply use their normal representation.
 318
 319                else
 320                   Insert_Character (Character'Val (Hex (2)));
 321                end if;
 322
 323             --  WW (wide wide character insertion)
 324
 325             elsif C = 'W'
 326               and then Old < Name_Len
 327               and then Name_Buffer (Old + 1) = 'W'
 328             then
 329                Old := Old + 2;
 330                Widechar.Set_Wide (Char_Code (Hex (8)), New_Buf, New_Len);
 331
 332             --  W (wide character insertion)
 333
 334             elsif C = 'W'
 335               and then Old < Name_Len
 336               and then Name_Buffer (Old + 1) not in 'A' .. 'Z'
 337               and then Name_Buffer (Old + 1) /= '_'
 338             then
 339                Old := Old + 1;
 340                Widechar.Set_Wide (Char_Code (Hex (4)), New_Buf, New_Len);
 341
 342             --  Any other character is copied unchanged
 343
 344             else
 345                Insert_Character (C);
 346                Old := Old + 1;
 347             end if;
 348          end Copy_One_Character;
 349
 350          ---------
 351          -- Hex --
 352          ---------
 353
 354          function Hex (N : Natural) return Word is
 355             T : Word := 0;
 356             C : Character;
 357
 358          begin
 359             for J in 1 .. N loop
 360                C := Name_Buffer (Old);
 361                Old := Old + 1;
 362
 363                pragma Assert (C in '0' .. '9' or else C in 'a' .. 'f');
 364
 365                if C <= '9' then
 366                   T := 16 * T + Character'Pos (C) - Character'Pos ('0');
 367                else -- C in 'a' .. 'f'
 368                   T := 16 * T + Character'Pos (C) - (Character'Pos ('a') - 10);
 369                end if;
 370             end loop;
 371
 372             return T;
 373          end Hex;
 374
 375          ----------------------
 376          -- Insert_Character --
 377          ----------------------
 378
 379          procedure Insert_Character (C : Character) is
 380          begin
 381             New_Len := New_Len + 1;
 382             New_Buf (New_Len) := C;
 383          end Insert_Character;
 384
 385       --  Start of processing for Decode
 386
 387       begin
 388          New_Len := 0;
 389          Old := 1;
 390
 391          --  Loop through characters of name
 392
 393          while Old <= Name_Len loop
 394
 395             --  Case of character literal, put apostrophes around character
 396
 397             if Name_Buffer (Old) = 'Q'
 398               and then Old < Name_Len
 399             then
 400                Old := Old + 1;
 401                Insert_Character (''');
 402                Copy_One_Character;
 403                Insert_Character (''');
 404
 405             --  Case of operator name
 406
 407             elsif Name_Buffer (Old) = 'O'
 408               and then Old < Name_Len
 409               and then Name_Buffer (Old + 1) not in 'A' .. 'Z'
 410               and then Name_Buffer (Old + 1) /= '_'
 411             then
 412                Old := Old + 1;
 413
 414                declare
 415                   --  This table maps the 2nd and 3rd characters of the name
 416                   --  into the required output. Two blanks means leave the
 417                   --  name alone
 418
 419                   Map : constant String :=
 420                      "ab  " &               --  Oabs         => "abs"
 421                      "ad+ " &               --  Oadd         => "+"
 422                      "an  " &               --  Oand         => "and"
 423                      "co& " &               --  Oconcat      => "&"
 424                      "di/ " &               --  Odivide      => "/"
 425                      "eq= " &               --  Oeq          => "="
 426                      "ex**" &               --  Oexpon       => "**"
 427                      "gt> " &               --  Ogt          => ">"
 428                      "ge>=" &               --  Oge          => ">="
 429                      "le<=" &               --  Ole          => "<="
 430                      "lt< " &               --  Olt          => "<"
 431                      "mo  " &               --  Omod         => "mod"
 432                      "mu* " &               --  Omutliply    => "*"
 433                      "ne/=" &               --  One          => "/="
 434                      "no  " &               --  Onot         => "not"
 435                      "or  " &               --  Oor          => "or"
 436                      "re  " &               --  Orem         => "rem"
 437                      "su- " &               --  Osubtract    => "-"
 438                      "xo  ";                --  Oxor         => "xor"
 439
 440                   J : Integer;
 441
 442                begin
 443                   Insert_Character ('"');
 444
 445                   --  Search the map. Note that this loop must terminate, if
 446                   --  not we have some kind of internal error, and a constraint
 447                   --  error may be raised.
 448
 449                   J := Map'First;
 450                   loop
 451                      exit when Name_Buffer (Old) = Map (J)
 452                        and then Name_Buffer (Old + 1) = Map (J + 1);
 453                      J := J + 4;
 454                   end loop;
 455
 456                   --  Special operator name
 457
 458                   if Map (J + 2) /= ' ' then
 459                      Insert_Character (Map (J + 2));
 460
 461                      if Map (J + 3) /= ' ' then
 462                         Insert_Character (Map (J + 3));
 463                      end if;
 464
 465                      Insert_Character ('"');
 466
 467                      --  Skip past original operator name in input
 468
 469                      while Old <= Name_Len
 470                        and then Name_Buffer (Old) in 'a' .. 'z'
 471                      loop
 472                         Old := Old + 1;
 473                      end loop;
 474
 475                   --  For other operator names, leave them in lower case,
 476                   --  surrounded by apostrophes
 477
 478                   else
 479                      --  Copy original operator name from input to output
 480
 481                      while Old <= Name_Len
 482                         and then Name_Buffer (Old) in 'a' .. 'z'
 483                      loop
 484                         Copy_One_Character;
 485                      end loop;
 486
 487                      Insert_Character ('"');
 488                   end if;
 489                end;
 490
 491             --  Else copy one character and keep going
 492
 493             else
 494                Copy_One_Character;
 495             end if;
 496          end loop;
 497
 498          --  Copy new buffer as result
 499
 500          Name_Len := New_Len;
 501          Name_Buffer (1 .. New_Len) := New_Buf (1 .. New_Len);
 502       end Decode;
 503    end Get_Decoded_Name_String;
 504
 505    -------------------------------------------
 506    -- Get_Decoded_Name_String_With_Brackets --
 507    -------------------------------------------
 508
 509    procedure Get_Decoded_Name_String_With_Brackets (Id : Name_Id) is
 510       P : Natural;
 511
 512    begin
 513       --  Case of operator name, normal decoding is fine
 514
 515       if Name_Buffer (1) = 'O' then
 516          Get_Decoded_Name_String (Id);
 517
 518       --  For character literals, normal decoding is fine
 519
 520       elsif Name_Buffer (1) = 'Q' then
 521          Get_Decoded_Name_String (Id);
 522
 523       --  Only remaining issue is U/W/WW sequences
 524
 525       else
 526          Get_Name_String (Id);
 527
 528          P := 1;
 529          while P < Name_Len loop
 530             if Name_Buffer (P + 1) in 'A' .. 'Z' then
 531                P := P + 1;
 532
 533             --  Uhh encoding
 534
 535             elsif Name_Buffer (P) = 'U' then
 536                for J in reverse P + 3 .. P + Name_Len loop
 537                   Name_Buffer (J + 3) := Name_Buffer (J);
 538                end loop;
 539
 540                Name_Len := Name_Len + 3;
 541                Name_Buffer (P + 3) := Name_Buffer (P + 2);
 542                Name_Buffer (P + 2) := Name_Buffer (P + 1);
 543                Name_Buffer (P)     := '[';
 544                Name_Buffer (P + 1) := '"';
 545                Name_Buffer (P + 4) := '"';
 546                Name_Buffer (P + 5) := ']';
 547                P := P + 6;
 548
 549             --  WWhhhhhhhh encoding
 550
 551             elsif Name_Buffer (P) = 'W'
 552               and then P + 9 <= Name_Len
 553               and then Name_Buffer (P + 1) = 'W'
 554               and then Name_Buffer (P + 2) not in 'A' .. 'Z'
 555               and then Name_Buffer (P + 2) /= '_'
 556             then
 557                Name_Buffer (P + 12 .. Name_Len + 2) :=
 558                  Name_Buffer (P + 10 .. Name_Len);
 559                Name_Buffer (P)     := '[';
 560                Name_Buffer (P + 1) := '"';
 561                Name_Buffer (P + 10) := '"';
 562                Name_Buffer (P + 11) := ']';
 563                Name_Len := Name_Len + 2;
 564                P := P + 12;
 565
 566             --  Whhhh encoding
 567
 568             elsif Name_Buffer (P) = 'W'
 569               and then P < Name_Len
 570               and then Name_Buffer (P + 1) not in 'A' .. 'Z'
 571               and then Name_Buffer (P + 1) /= '_'
 572             then
 573                Name_Buffer (P + 8 .. P + Name_Len + 3) :=
 574                  Name_Buffer (P + 5 .. Name_Len);
 575                Name_Buffer (P + 2 .. P + 5) := Name_Buffer (P + 1 .. P + 4);
 576                Name_Buffer (P)     := '[';
 577                Name_Buffer (P + 1) := '"';
 578                Name_Buffer (P + 6) := '"';
 579                Name_Buffer (P + 7) := ']';
 580                Name_Len := Name_Len + 3;
 581                P := P + 8;
 582
 583             else
 584                P := P + 1;
 585             end if;
 586          end loop;
 587       end if;
 588    end Get_Decoded_Name_String_With_Brackets;
 589
 590    ------------------------
 591    -- Get_Last_Two_Chars --
 592    ------------------------
 593
 594    procedure Get_Last_Two_Chars (N : Name_Id; C1, C2 : out Character) is
 595       NE  : Name_Entry renames Name_Entries.Table (N);
 596       NEL : constant Int := Int (NE.Name_Len);
 597
 598    begin
 599       if NEL >= 2 then
 600          C1 := Name_Chars.Table (NE.Name_Chars_Index + NEL - 1);
 601          C2 := Name_Chars.Table (NE.Name_Chars_Index + NEL - 0);
 602       else
 603          C1 := ASCII.NUL;
 604          C2 := ASCII.NUL;
 605       end if;
 606    end Get_Last_Two_Chars;
 607
 608    ---------------------
 609    -- Get_Name_String --
 610    ---------------------
 611
 612    --  Procedure version leaving result in Name_Buffer, length in Name_Len
 613
 614    procedure Get_Name_String (Id : Name_Id) is
 615       S : Int;
 616
 617    begin
 618       pragma Assert (Id in Name_Entries.First .. Name_Entries.Last);
 619
 620       S := Name_Entries.Table (Id).Name_Chars_Index;
 621       Name_Len := Natural (Name_Entries.Table (Id).Name_Len);
 622
 623       for J in 1 .. Name_Len loop
 624          Name_Buffer (J) := Name_Chars.Table (S + Int (J));
 625       end loop;
 626    end Get_Name_String;
 627
 628    ---------------------
 629    -- Get_Name_String --
 630    ---------------------
 631
 632    --  Function version returning a string
 633
 634    function Get_Name_String (Id : Name_Id) return String is
 635       S : Int;
 636
 637    begin
 638       pragma Assert (Id in Name_Entries.First .. Name_Entries.Last);
 639       S := Name_Entries.Table (Id).Name_Chars_Index;
 640
 641       declare
 642          R : String (1 .. Natural (Name_Entries.Table (Id).Name_Len));
 643
 644       begin
 645          for J in R'Range loop
 646             R (J) := Name_Chars.Table (S + Int (J));
 647          end loop;
 648
 649          return R;
 650       end;
 651    end Get_Name_String;
 652
 653    --------------------------------
 654    -- Get_Name_String_And_Append --
 655    --------------------------------
 656
 657    procedure Get_Name_String_And_Append (Id : Name_Id) is
 658       S : Int;
 659
 660    begin
 661       pragma Assert (Id in Name_Entries.First .. Name_Entries.Last);
 662
 663       S := Name_Entries.Table (Id).Name_Chars_Index;
 664
 665       for J in 1 .. Natural (Name_Entries.Table (Id).Name_Len) loop
 666          Name_Len := Name_Len + 1;
 667          Name_Buffer (Name_Len) := Name_Chars.Table (S + Int (J));
 668       end loop;
 669    end Get_Name_String_And_Append;
 670
 671    -------------------------
 672    -- Get_Name_Table_Byte --
 673    -------------------------
 674
 675    function Get_Name_Table_Byte (Id : Name_Id) return Byte is
 676    begin
 677       pragma Assert (Id in Name_Entries.First .. Name_Entries.Last);
 678       return Name_Entries.Table (Id).Byte_Info;
 679    end Get_Name_Table_Byte;
 680
 681    -------------------------
 682    -- Get_Name_Table_Info --
 683    -------------------------
 684
 685    function Get_Name_Table_Info (Id : Name_Id) return Int is
 686    begin
 687       pragma Assert (Id in Name_Entries.First .. Name_Entries.Last);
 688       return Name_Entries.Table (Id).Int_Info;
 689    end Get_Name_Table_Info;
 690
 691    -----------------------------------------
 692    -- Get_Unqualified_Decoded_Name_String --
 693    -----------------------------------------
 694
 695    procedure Get_Unqualified_Decoded_Name_String (Id : Name_Id) is
 696    begin
 697       Get_Decoded_Name_String (Id);
 698       Strip_Qualification_And_Suffixes;
 699    end Get_Unqualified_Decoded_Name_String;
 700
 701    ---------------------------------
 702    -- Get_Unqualified_Name_String --
 703    ---------------------------------
 704
 705    procedure Get_Unqualified_Name_String (Id : Name_Id) is
 706    begin
 707       Get_Name_String (Id);
 708       Strip_Qualification_And_Suffixes;
 709    end Get_Unqualified_Name_String;
 710
 711    ----------
 712    -- Hash --
 713    ----------
 714
 715    function Hash return Hash_Index_Type is
 716    begin
 717       --  For the cases of 1-12 characters, all characters participate in the
 718       --  hash. The positioning is randomized, with the bias that characters
 719       --  later on participate fully (i.e. are added towards the right side).
 720
 721       case Name_Len is
 722
 723          when 0 =>
 724             return 0;
 725
 726          when 1 =>
 727             return
 728                Character'Pos (Name_Buffer (1));
 729
 730          when 2 =>
 731             return ((
 732               Character'Pos (Name_Buffer (1))) * 64 +
 733               Character'Pos (Name_Buffer (2))) mod Hash_Num;
 734
 735          when 3 =>
 736             return (((
 737               Character'Pos (Name_Buffer (1))) * 16 +
 738               Character'Pos (Name_Buffer (3))) * 16 +
 739               Character'Pos (Name_Buffer (2))) mod Hash_Num;
 740
 741          when 4 =>
 742             return ((((
 743               Character'Pos (Name_Buffer (1))) * 8 +
 744               Character'Pos (Name_Buffer (2))) * 8 +
 745               Character'Pos (Name_Buffer (3))) * 8 +
 746               Character'Pos (Name_Buffer (4))) mod Hash_Num;
 747
 748          when 5 =>
 749             return (((((
 750               Character'Pos (Name_Buffer (4))) * 8 +
 751               Character'Pos (Name_Buffer (1))) * 4 +
 752               Character'Pos (Name_Buffer (3))) * 4 +
 753               Character'Pos (Name_Buffer (5))) * 8 +
 754               Character'Pos (Name_Buffer (2))) mod Hash_Num;
 755
 756          when 6 =>
 757             return ((((((
 758               Character'Pos (Name_Buffer (5))) * 4 +
 759               Character'Pos (Name_Buffer (1))) * 4 +
 760               Character'Pos (Name_Buffer (4))) * 4 +
 761               Character'Pos (Name_Buffer (2))) * 4 +
 762               Character'Pos (Name_Buffer (6))) * 4 +
 763               Character'Pos (Name_Buffer (3))) mod Hash_Num;
 764
 765          when 7 =>
 766             return (((((((
 767               Character'Pos (Name_Buffer (4))) * 4 +
 768               Character'Pos (Name_Buffer (3))) * 4 +
 769               Character'Pos (Name_Buffer (1))) * 4 +
 770               Character'Pos (Name_Buffer (2))) * 2 +
 771               Character'Pos (Name_Buffer (5))) * 2 +
 772               Character'Pos (Name_Buffer (7))) * 2 +
 773               Character'Pos (Name_Buffer (6))) mod Hash_Num;
 774
 775          when 8 =>
 776             return ((((((((
 777               Character'Pos (Name_Buffer (2))) * 4 +
 778               Character'Pos (Name_Buffer (1))) * 4 +
 779               Character'Pos (Name_Buffer (3))) * 2 +
 780               Character'Pos (Name_Buffer (5))) * 2 +
 781               Character'Pos (Name_Buffer (7))) * 2 +
 782               Character'Pos (Name_Buffer (6))) * 2 +
 783               Character'Pos (Name_Buffer (4))) * 2 +
 784               Character'Pos (Name_Buffer (8))) mod Hash_Num;
 785
 786          when 9 =>
 787             return (((((((((
 788               Character'Pos (Name_Buffer (2))) * 4 +
 789               Character'Pos (Name_Buffer (1))) * 4 +
 790               Character'Pos (Name_Buffer (3))) * 4 +
 791               Character'Pos (Name_Buffer (4))) * 2 +
 792               Character'Pos (Name_Buffer (8))) * 2 +
 793               Character'Pos (Name_Buffer (7))) * 2 +
 794               Character'Pos (Name_Buffer (5))) * 2 +
 795               Character'Pos (Name_Buffer (6))) * 2 +
 796               Character'Pos (Name_Buffer (9))) mod Hash_Num;
 797
 798          when 10 =>
 799             return ((((((((((
 800               Character'Pos (Name_Buffer (01))) * 2 +
 801               Character'Pos (Name_Buffer (02))) * 2 +
 802               Character'Pos (Name_Buffer (08))) * 2 +
 803               Character'Pos (Name_Buffer (03))) * 2 +
 804               Character'Pos (Name_Buffer (04))) * 2 +
 805               Character'Pos (Name_Buffer (09))) * 2 +
 806               Character'Pos (Name_Buffer (06))) * 2 +
 807               Character'Pos (Name_Buffer (05))) * 2 +
 808               Character'Pos (Name_Buffer (07))) * 2 +
 809               Character'Pos (Name_Buffer (10))) mod Hash_Num;
 810
 811          when 11 =>
 812             return (((((((((((
 813               Character'Pos (Name_Buffer (05))) * 2 +
 814               Character'Pos (Name_Buffer (01))) * 2 +
 815               Character'Pos (Name_Buffer (06))) * 2 +
 816               Character'Pos (Name_Buffer (09))) * 2 +
 817               Character'Pos (Name_Buffer (07))) * 2 +
 818               Character'Pos (Name_Buffer (03))) * 2 +
 819               Character'Pos (Name_Buffer (08))) * 2 +
 820               Character'Pos (Name_Buffer (02))) * 2 +
 821               Character'Pos (Name_Buffer (10))) * 2 +
 822               Character'Pos (Name_Buffer (04))) * 2 +
 823               Character'Pos (Name_Buffer (11))) mod Hash_Num;
 824
 825          when 12 =>
 826             return ((((((((((((
 827               Character'Pos (Name_Buffer (03))) * 2 +
 828               Character'Pos (Name_Buffer (02))) * 2 +
 829               Character'Pos (Name_Buffer (05))) * 2 +
 830               Character'Pos (Name_Buffer (01))) * 2 +
 831               Character'Pos (Name_Buffer (06))) * 2 +
 832               Character'Pos (Name_Buffer (04))) * 2 +
 833               Character'Pos (Name_Buffer (08))) * 2 +
 834               Character'Pos (Name_Buffer (11))) * 2 +
 835               Character'Pos (Name_Buffer (07))) * 2 +
 836               Character'Pos (Name_Buffer (09))) * 2 +
 837               Character'Pos (Name_Buffer (10))) * 2 +
 838               Character'Pos (Name_Buffer (12))) mod Hash_Num;
 839
 840          --  Names longer than 12 characters are handled by taking the first
 841          --  6 odd numbered characters and the last 6 even numbered characters.
 842
 843          when others => declare
 844                Even_Name_Len : constant Integer := (Name_Len) / 2 * 2;
 845          begin
 846             return ((((((((((((
 847               Character'Pos (Name_Buffer (01))) * 2 +
 848               Character'Pos (Name_Buffer (Even_Name_Len - 10))) * 2 +
 849               Character'Pos (Name_Buffer (03))) * 2 +
 850               Character'Pos (Name_Buffer (Even_Name_Len - 08))) * 2 +
 851               Character'Pos (Name_Buffer (05))) * 2 +
 852               Character'Pos (Name_Buffer (Even_Name_Len - 06))) * 2 +
 853               Character'Pos (Name_Buffer (07))) * 2 +
 854               Character'Pos (Name_Buffer (Even_Name_Len - 04))) * 2 +
 855               Character'Pos (Name_Buffer (09))) * 2 +
 856               Character'Pos (Name_Buffer (Even_Name_Len - 02))) * 2 +
 857               Character'Pos (Name_Buffer (11))) * 2 +
 858               Character'Pos (Name_Buffer (Even_Name_Len))) mod Hash_Num;
 859          end;
 860       end case;
 861    end Hash;
 862
 863    ----------------
 864    -- Initialize --
 865    ----------------
 866
 867    procedure Initialize is
 868    begin
 869       Name_Chars.Init;
 870       Name_Entries.Init;
 871
 872       --  Initialize entries for one character names
 873
 874       for C in Character loop
 875          Name_Entries.Append
 876            ((Name_Chars_Index      => Name_Chars.Last,
 877              Name_Len              => 1,
 878              Byte_Info             => 0,
 879              Int_Info              => 0,
 880              Name_Has_No_Encodings => True,
 881              Hash_Link             => No_Name));
 882
 883          Name_Chars.Append (C);
 884          Name_Chars.Append (ASCII.NUL);
 885       end loop;
 886
 887       --  Clear hash table
 888
 889       for J in Hash_Index_Type loop
 890          Hash_Table (J) := No_Name;
 891       end loop;
 892    end Initialize;
 893
 894    ----------------------
 895    -- Is_Internal_Name --
 896    ----------------------
 897
 898    --  Version taking an argument
 899
 900    function Is_Internal_Name (Id : Name_Id) return Boolean is
 901    begin
 902       Get_Name_String (Id);
 903       return Is_Internal_Name;
 904    end Is_Internal_Name;
 905
 906    ----------------------
 907    -- Is_Internal_Name --
 908    ----------------------
 909
 910    --  Version taking its input from Name_Buffer
 911
 912    function Is_Internal_Name return Boolean is
 913    begin
 914       if Name_Buffer (1) = '_'
 915         or else Name_Buffer (Name_Len) = '_'
 916       then
 917          return True;
 918
 919       else
 920          --  Test backwards, because we only want to test the last entity
 921          --  name if the name we have is qualified with other entities.
 922
 923          for J in reverse 1 .. Name_Len loop
 924             if Is_OK_Internal_Letter (Name_Buffer (J)) then
 925                return True;
 926
 927             --  Quit if we come to terminating double underscore (note that
 928             --  if the current character is an underscore, we know that
 929             --  there is a previous character present, since we already
 930             --  filtered out the case of Name_Buffer (1) = '_' above.
 931
 932             elsif Name_Buffer (J) = '_'
 933               and then Name_Buffer (J - 1) = '_'
 934               and then Name_Buffer (J - 2) /= '_'
 935             then
 936                return False;
 937             end if;
 938          end loop;
 939       end if;
 940
 941       return False;
 942    end Is_Internal_Name;
 943
 944    ---------------------------
 945    -- Is_OK_Internal_Letter --
 946    ---------------------------
 947
 948    function Is_OK_Internal_Letter (C : Character) return Boolean is
 949    begin
 950       return C in 'A' .. 'Z'
 951         and then C /= 'O'
 952         and then C /= 'Q'
 953         and then C /= 'U'
 954         and then C /= 'W'
 955         and then C /= 'X';
 956    end Is_OK_Internal_Letter;
 957
 958    ----------------------
 959    -- Is_Operator_Name --
 960    ----------------------
 961
 962    function Is_Operator_Name (Id : Name_Id) return Boolean is
 963       S : Int;
 964    begin
 965       pragma Assert (Id in Name_Entries.First .. Name_Entries.Last);
 966       S := Name_Entries.Table (Id).Name_Chars_Index;
 967       return Name_Chars.Table (S + 1) = 'O';
 968    end Is_Operator_Name;
 969
 970    -------------------
 971    -- Is_Valid_Name --
 972    -------------------
 973
 974    function Is_Valid_Name (Id : Name_Id) return Boolean is
 975    begin
 976       return Id in Name_Entries.First .. Name_Entries.Last;
 977    end Is_Valid_Name;
 978
 979    --------------------
 980    -- Length_Of_Name --
 981    --------------------
 982
 983    function Length_Of_Name (Id : Name_Id) return Nat is
 984    begin
 985       return Int (Name_Entries.Table (Id).Name_Len);
 986    end Length_Of_Name;
 987
 988    ----------
 989    -- Lock --
 990    ----------
 991
 992    procedure Lock is
 993    begin
 994       Name_Chars.Set_Last (Name_Chars.Last + Name_Chars_Reserve);
 995       Name_Entries.Set_Last (Name_Entries.Last + Name_Entries_Reserve);
 996       Name_Chars.Locked := True;
 997       Name_Entries.Locked := True;
 998       Name_Chars.Release;
 999       Name_Entries.Release;
1000    end Lock;
1001
1002    ------------------------
1003    -- Name_Chars_Address --
1004    ------------------------
1005
1006    function Name_Chars_Address return System.Address is
1007    begin
1008       return Name_Chars.Table (0)'Address;
1009    end Name_Chars_Address;
1010
1011    ----------------
1012    -- Name_Enter --
1013    ----------------
1014
1015    function Name_Enter return Name_Id is
1016    begin
1017       Name_Entries.Append
1018         ((Name_Chars_Index      => Name_Chars.Last,
1019           Name_Len              => Short (Name_Len),
1020           Byte_Info             => 0,
1021           Int_Info              => 0,
1022           Name_Has_No_Encodings => False,
1023           Hash_Link             => No_Name));
1024
1025       --  Set corresponding string entry in the Name_Chars table
1026
1027       for J in 1 .. Name_Len loop
1028          Name_Chars.Append (Name_Buffer (J));
1029       end loop;
1030
1031       Name_Chars.Append (ASCII.NUL);
1032
1033       return Name_Entries.Last;
1034    end Name_Enter;
1035
1036    --------------------------
1037    -- Name_Entries_Address --
1038    --------------------------
1039
1040    function Name_Entries_Address return System.Address is
1041    begin
1042       return Name_Entries.Table (First_Name_Id)'Address;
1043    end Name_Entries_Address;
1044
1045    ------------------------
1046    -- Name_Entries_Count --
1047    ------------------------
1048
1049    function Name_Entries_Count return Nat is
1050    begin
1051       return Int (Name_Entries.Last - Name_Entries.First + 1);
1052    end Name_Entries_Count;
1053
1054    ---------------
1055    -- Name_Find --
1056    ---------------
1057
1058    function Name_Find return Name_Id is
1059       New_Id : Name_Id;
1060       --  Id of entry in hash search, and value to be returned
1061
1062       S : Int;
1063       --  Pointer into string table
1064
1065       Hash_Index : Hash_Index_Type;
1066       --  Computed hash index
1067
1068    begin
1069       --  Quick handling for one character names
1070
1071       if Name_Len = 1 then
1072          return Name_Id (First_Name_Id + Character'Pos (Name_Buffer (1)));
1073
1074       --  Otherwise search hash table for existing matching entry
1075
1076       else
1077          Hash_Index := Namet.Hash;
1078          New_Id := Hash_Table (Hash_Index);
1079
1080          if New_Id = No_Name then
1081             Hash_Table (Hash_Index) := Name_Entries.Last + 1;
1082
1083          else
1084             Search : loop
1085                if Name_Len /=
1086                  Integer (Name_Entries.Table (New_Id).Name_Len)
1087                then
1088                   goto No_Match;
1089                end if;
1090
1091                S := Name_Entries.Table (New_Id).Name_Chars_Index;
1092
1093                for J in 1 .. Name_Len loop
1094                   if Name_Chars.Table (S + Int (J)) /= Name_Buffer (J) then
1095                      goto No_Match;
1096                   end if;
1097                end loop;
1098
1099                return New_Id;
1100
1101                --  Current entry in hash chain does not match
1102
1103                <<No_Match>>
1104                   if Name_Entries.Table (New_Id).Hash_Link /= No_Name then
1105                      New_Id := Name_Entries.Table (New_Id).Hash_Link;
1106                   else
1107                      Name_Entries.Table (New_Id).Hash_Link :=
1108                        Name_Entries.Last + 1;
1109                      exit Search;
1110                   end if;
1111             end loop Search;
1112          end if;
1113
1114          --  We fall through here only if a matching entry was not found in the
1115          --  hash table. We now create a new entry in the names table. The hash
1116          --  link pointing to the new entry (Name_Entries.Last+1) has been set.
1117
1118          Name_Entries.Append
1119            ((Name_Chars_Index      => Name_Chars.Last,
1120              Name_Len              => Short (Name_Len),
1121              Hash_Link             => No_Name,
1122              Name_Has_No_Encodings => False,
1123              Int_Info              => 0,
1124              Byte_Info             => 0));
1125
1126          --  Set corresponding string entry in the Name_Chars table
1127
1128          for J in 1 .. Name_Len loop
1129             Name_Chars.Append (Name_Buffer (J));
1130          end loop;
1131
1132          Name_Chars.Append (ASCII.NUL);
1133
1134          return Name_Entries.Last;
1135       end if;
1136    end Name_Find;
1137
1138    ----------------------
1139    -- Reset_Name_Table --
1140    ----------------------
1141
1142    procedure Reset_Name_Table is
1143    begin
1144       for J in First_Name_Id .. Name_Entries.Last loop
1145          Name_Entries.Table (J).Int_Info  := 0;
1146          Name_Entries.Table (J).Byte_Info := 0;
1147       end loop;
1148    end Reset_Name_Table;
1149
1150    --------------------------------
1151    -- Set_Character_Literal_Name --
1152    --------------------------------
1153
1154    procedure Set_Character_Literal_Name (C : Char_Code) is
1155    begin
1156       Name_Buffer (1) := 'Q';
1157       Name_Len := 1;
1158       Store_Encoded_Character (C);
1159    end Set_Character_Literal_Name;
1160
1161    -------------------------
1162    -- Set_Name_Table_Byte --
1163    -------------------------
1164
1165    procedure Set_Name_Table_Byte (Id : Name_Id; Val : Byte) is
1166    begin
1167       pragma Assert (Id in Name_Entries.First .. Name_Entries.Last);
1168       Name_Entries.Table (Id).Byte_Info := Val;
1169    end Set_Name_Table_Byte;
1170
1171    -------------------------
1172    -- Set_Name_Table_Info --
1173    -------------------------
1174
1175    procedure Set_Name_Table_Info (Id : Name_Id; Val : Int) is
1176    begin
1177       pragma Assert (Id in Name_Entries.First .. Name_Entries.Last);
1178       Name_Entries.Table (Id).Int_Info := Val;
1179    end Set_Name_Table_Info;
1180
1181    -----------------------------
1182    -- Store_Encoded_Character --
1183    -----------------------------
1184
1185    procedure Store_Encoded_Character (C : Char_Code) is
1186
1187       procedure Set_Hex_Chars (C : Char_Code);
1188       --  Stores given value, which is in the range 0 .. 255, as two hex
1189       --  digits (using lower case a-f) in Name_Buffer, incrementing Name_Len.
1190
1191       -------------------
1192       -- Set_Hex_Chars --
1193       -------------------
1194
1195       procedure Set_Hex_Chars (C : Char_Code) is
1196          Hexd : constant String := "0123456789abcdef";
1197          N    : constant Natural := Natural (C);
1198       begin
1199          Name_Buffer (Name_Len + 1) := Hexd (N / 16 + 1);
1200          Name_Buffer (Name_Len + 2) := Hexd (N mod 16 + 1);
1201          Name_Len := Name_Len + 2;
1202       end Set_Hex_Chars;
1203
1204    --  Start of processing for Store_Encoded_Character
1205
1206    begin
1207       Name_Len := Name_Len + 1;
1208
1209       if In_Character_Range (C) then
1210          declare
1211             CC : constant Character := Get_Character (C);
1212          begin
1213             if CC in 'a' .. 'z' or else CC in '0' .. '9' then
1214                Name_Buffer (Name_Len) := CC;
1215             else
1216                Name_Buffer (Name_Len) := 'U';
1217                Set_Hex_Chars (C);
1218             end if;
1219          end;
1220
1221       elsif In_Wide_Character_Range (C) then
1222          Name_Buffer (Name_Len) := 'W';
1223          Set_Hex_Chars (C / 256);
1224          Set_Hex_Chars (C mod 256);
1225
1226       else
1227          Name_Buffer (Name_Len) := 'W';
1228          Name_Len := Name_Len + 1;
1229          Name_Buffer (Name_Len) := 'W';
1230          Set_Hex_Chars (C / 2 ** 24);
1231          Set_Hex_Chars ((C / 2 ** 16) mod 256);
1232          Set_Hex_Chars ((C / 256) mod 256);
1233          Set_Hex_Chars (C mod 256);
1234       end if;
1235    end Store_Encoded_Character;
1236
1237    --------------------------------------
1238    -- Strip_Qualification_And_Suffixes --
1239    --------------------------------------
1240
1241    procedure Strip_Qualification_And_Suffixes is
1242       J : Integer;
1243
1244    begin
1245       --  Strip package body qualification string off end
1246
1247       for J in reverse 2 .. Name_Len loop
1248          if Name_Buffer (J) = 'X' then
1249             Name_Len := J - 1;
1250             exit;
1251          end if;
1252
1253          exit when Name_Buffer (J) /= 'b'
1254            and then Name_Buffer (J) /= 'n'
1255            and then Name_Buffer (J) /= 'p';
1256       end loop;
1257
1258       --  Find rightmost __ or $ separator if one exists. First we position
1259       --  to start the search. If we have a character constant, position
1260       --  just before it, otherwise position to last character but one
1261
1262       if Name_Buffer (Name_Len) = ''' then
1263          J := Name_Len - 2;
1264          while J > 0 and then Name_Buffer (J) /= ''' loop
1265             J := J - 1;
1266          end loop;
1267
1268       else
1269          J := Name_Len - 1;
1270       end if;
1271
1272       --  Loop to search for rightmost __ or $ (homonym) separator
1273
1274       while J > 1 loop
1275
1276          --  If $ separator, homonym separator, so strip it and keep looking
1277
1278          if Name_Buffer (J) = '$' then
1279             Name_Len := J - 1;
1280             J := Name_Len - 1;
1281
1282          --  Else check for __ found
1283
1284          elsif Name_Buffer (J) = '_' and then Name_Buffer (J + 1) = '_' then
1285
1286             --  Found __ so see if digit follows, and if so, this is a
1287             --  homonym separator, so strip it and keep looking.
1288
1289             if Name_Buffer (J + 2) in '0' .. '9' then
1290                Name_Len := J - 1;
1291                J := Name_Len - 1;
1292
1293             --  If not a homonym separator, then we simply strip the
1294             --  separator and everything that precedes it, and we are done
1295
1296             else
1297                Name_Buffer (1 .. Name_Len - J - 1) :=
1298                  Name_Buffer (J + 2 .. Name_Len);
1299                Name_Len := Name_Len - J - 1;
1300                exit;
1301             end if;
1302
1303          else
1304             J := J - 1;
1305          end if;
1306       end loop;
1307    end Strip_Qualification_And_Suffixes;
1308
1309    ---------------
1310    -- Tree_Read --
1311    ---------------
1312
1313    procedure Tree_Read is
1314    begin
1315       Name_Chars.Tree_Read;
1316       Name_Entries.Tree_Read;
1317
1318       Tree_Read_Data
1319         (Hash_Table'Address,
1320          Hash_Table'Length * (Hash_Table'Component_Size / Storage_Unit));
1321    end Tree_Read;
1322
1323    ----------------
1324    -- Tree_Write --
1325    ----------------
1326
1327    procedure Tree_Write is
1328    begin
1329       Name_Chars.Tree_Write;
1330       Name_Entries.Tree_Write;
1331
1332       Tree_Write_Data
1333         (Hash_Table'Address,
1334          Hash_Table'Length * (Hash_Table'Component_Size / Storage_Unit));
1335    end Tree_Write;
1336
1337    ------------
1338    -- Unlock --
1339    ------------
1340
1341    procedure Unlock is
1342    begin
1343       Name_Chars.Set_Last (Name_Chars.Last - Name_Chars_Reserve);
1344       Name_Entries.Set_Last (Name_Entries.Last - Name_Entries_Reserve);
1345       Name_Chars.Locked := False;
1346       Name_Entries.Locked := False;
1347       Name_Chars.Release;
1348       Name_Entries.Release;
1349    end Unlock;
1350
1351    --------
1352    -- wn --
1353    --------
1354
1355    procedure wn (Id : Name_Id) is
1356       S : Int;
1357
1358    begin
1359       if not Id'Valid then
1360          Write_Str ("<invalid name_id>");
1361
1362       elsif Id = No_Name then
1363          Write_Str ("<No_Name>");
1364
1365       elsif Id = Error_Name then
1366          Write_Str ("<Error_Name>");
1367
1368       else
1369          S := Name_Entries.Table (Id).Name_Chars_Index;
1370          Name_Len := Natural (Name_Entries.Table (Id).Name_Len);
1371
1372          for J in 1 .. Name_Len loop
1373             Write_Char (Name_Chars.Table (S + Int (J)));
1374          end loop;
1375       end if;
1376
1377       Write_Eol;
1378    end wn;
1379
1380    ----------------
1381    -- Write_Name --
1382    ----------------
1383
1384    procedure Write_Name (Id : Name_Id) is
1385    begin
1386       if Id >= First_Name_Id then
1387          Get_Name_String (Id);
1388          Write_Str (Name_Buffer (1 .. Name_Len));
1389       end if;
1390    end Write_Name;
1391
1392    ------------------------
1393    -- Write_Name_Decoded --
1394    ------------------------
1395
1396    procedure Write_Name_Decoded (Id : Name_Id) is
1397    begin
1398       if Id >= First_Name_Id then
1399          Get_Decoded_Name_String (Id);
1400          Write_Str (Name_Buffer (1 .. Name_Len));
1401       end if;
1402    end Write_Name_Decoded;
1403
1404 end Namet;