path: root/gcc/ada/namet.adb

------------------------------------------------------------------------------
--                                                                          --
--                         GNAT COMPILER COMPONENTS                         --
--                                                                          --
--                                N A M E T                                 --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--          Copyright (C) 1992-2015, Free Software Foundation, Inc.         --
--                                                                          --
-- GNAT is free software;  you can  redistribute it  and/or modify it under --
-- terms of the  GNU General Public License as published  by the Free Soft- --
-- ware  Foundation;  either version 3,  or (at your option) any later ver- --
-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE.                                     --
--                                                                          --
-- As a special exception under Section 7 of GPL version 3, you are granted --
-- additional permissions described in the GCC Runtime Library Exception,   --
-- version 3.1, as published by the Free Software Foundation.               --
--                                                                          --
-- You should have received a copy of the GNU General Public License and    --
-- a copy of the GCC Runtime Library Exception along with this program;     --
-- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
-- <http://www.gnu.org/licenses/>.                                          --
--                                                                          --
-- GNAT was originally developed  by the GNAT team at  New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc.      --
--                                                                          --
------------------------------------------------------------------------------

--  WARNING: There is a C version of this package. Any changes to this
--  source file must be properly reflected in the C header file namet.h
--  which is created manually from namet.ads and namet.adb.

with Debug;    use Debug;
with Opt;      use Opt;
with Output;   use Output;
with Tree_IO;  use Tree_IO;
with Widechar; use Widechar;

with Interfaces; use Interfaces;

package body Namet is

   Name_Chars_Reserve   : constant := 5000;
   Name_Entries_Reserve : constant := 100;
   --  The names table is locked during gigi processing, since gigi assumes
   --  that the table does not move. After returning from gigi, the names
   --  table is unlocked again, since writing library file information needs
   --  to generate some extra names. To avoid the inefficiency of always
   --  reallocating during this second unlocked phase, we reserve a bit of
   --  extra space before doing the release call.

   Hash_Num : constant Int := 2**16;
   --  Number of headers in the hash table. Current hash algorithm is closely
   --  tailored to this choice, so it can only be changed if a corresponding
   --  change is made to the hash algorithm.

   Hash_Max : constant Int := Hash_Num - 1;
   --  Indexes in the hash header table run from 0 to Hash_Num - 1

   subtype Hash_Index_Type is Int range 0 .. Hash_Max;
   --  Range of hash index values

   Hash_Table : array (Hash_Index_Type) of Name_Id;
   --  The hash table is used to locate existing entries in the names table.
   --  The entries point to the first names table entry whose hash value
   --  matches the hash code. Then subsequent names table entries with the
   --  same hash code value are linked through the Hash_Link fields.

   -----------------------
   -- Local Subprograms --
   -----------------------

   function Hash return Hash_Index_Type;
   pragma Inline (Hash);
   --  Compute hash code for name stored in Name_Buffer (length in Name_Len)

   procedure Strip_Qualification_And_Suffixes;
   --  Given an encoded entity name in Name_Buffer, remove package body
   --  suffix as described for Strip_Package_Body_Suffix, and also remove
   --  all qualification, i.e. names followed by two underscores. The
   --  contents of Name_Buffer is modified by this call, and on return
   --  Name_Buffer and Name_Len reflect the stripped name.

   -----------------------------
   -- Add_Char_To_Name_Buffer --
   -----------------------------

   procedure Add_Char_To_Name_Buffer (C : Character) is
   begin
      if Name_Len < Name_Buffer'Last then
         Name_Len := Name_Len + 1;
         Name_Buffer (Name_Len) := C;
      end if;
   end Add_Char_To_Name_Buffer;

   ----------------------------
   -- Add_Nat_To_Name_Buffer --
   ----------------------------

   procedure Add_Nat_To_Name_Buffer (V : Nat) is
   begin
      if V >= 10 then
         Add_Nat_To_Name_Buffer (V / 10);
      end if;

      Add_Char_To_Name_Buffer (Character'Val (Character'Pos ('0') + V rem 10));
   end Add_Nat_To_Name_Buffer;

   ----------------------------
   -- Add_Str_To_Name_Buffer --
   ----------------------------

   procedure Add_Str_To_Name_Buffer (S : String) is
   begin
      for J in S'Range loop
         Add_Char_To_Name_Buffer (S (J));
      end loop;
   end Add_Str_To_Name_Buffer;

   --------------
   -- Finalize --
   --------------

   procedure Finalize is
      F : array (Int range 0 .. 50) of Int;
      --  N'th entry is the number of chains of length N, except last entry,
      --  which is the number of chains of length F'Last or more.

      Max_Chain_Length : Int := 0;
      --  Maximum length of all chains

      Probes : Int := 0;
      --  Used to compute average number of probes

      Nsyms : Int := 0;
      --  Number of symbols in table

      Verbosity : constant Int range 1 .. 3 := 1;
      pragma Warnings (Off, Verbosity);
      --  This constant indicates the level of verbosity in the output from
      --  this procedure. Currently this can only be changed by editing the
      --  declaration above and recompiling. That's good enough in practice,
      --  since we very rarely need to use this debug option. Settings are:
      --
      --    1 => print basic summary information
      --    2 => in addition print number of entries per hash chain
      --    3 => in addition print content of entries

      Zero : constant Int := Character'Pos ('0');

   begin
      if not Debug_Flag_H then
         return;
      end if;

      for J in F'Range loop
         F (J) := 0;
      end loop;

      for J in Hash_Index_Type loop
         if Hash_Table (J) = No_Name then
            F (0) := F (0) + 1;

         else
            declare
               C : Int;
               N : Name_Id;
               S : Int;

            begin
               C := 0;
               N := Hash_Table (J);

               while N /= No_Name loop
                  N := Name_Entries.Table (N).Hash_Link;
                  C := C + 1;
               end loop;

               Nsyms := Nsyms + 1;
               Probes := Probes + (1 + C) * 100;

               if C > Max_Chain_Length then
                  Max_Chain_Length := C;
               end if;

               if Verbosity >= 2 then
                  Write_Str ("Hash_Table (");
                  Write_Int (J);
                  Write_Str (") has ");
                  Write_Int (C);
                  Write_Str (" entries");
                  Write_Eol;
               end if;

               if C < F'Last then
                  F (C) := F (C) + 1;
               else
                  F (F'Last) := F (F'Last) + 1;
               end if;

               if Verbosity >= 3 then
                  N := Hash_Table (J);
                  while N /= No_Name loop
                     S := Name_Entries.Table (N).Name_Chars_Index;

                     Write_Str ("      ");

                     for J in 1 .. Name_Entries.Table (N).Name_Len loop
                        Write_Char (Name_Chars.Table (S + Int (J)));
                     end loop;

                     Write_Eol;

                     N := Name_Entries.Table (N).Hash_Link;
                  end loop;
               end if;
            end;
         end if;
      end loop;

      Write_Eol;

      for J in F'Range loop
         if F (J) /= 0 then
            Write_Str ("Number of hash chains of length ");

            if J < 10 then
               Write_Char (' ');
            end if;

            Write_Int (J);

            if J = F'Last then
               Write_Str (" or greater");
            end if;

            Write_Str (" = ");
            Write_Int (F (J));
            Write_Eol;
         end if;
      end loop;

      --  Print out average number of probes, in the case where Name_Find is
      --  called for a string that is already in the table.

      Write_Eol;
      Write_Str ("Average number of probes for lookup = ");
      Probes := Probes / Nsyms;
      Write_Int (Probes / 200);
      Write_Char ('.');
      Probes := (Probes mod 200) / 2;
      Write_Char (Character'Val (Zero + Probes / 10));
      Write_Char (Character'Val (Zero + Probes mod 10));
      Write_Eol;

      Write_Str ("Max_Chain_Length = ");
      Write_Int (Max_Chain_Length);
      Write_Eol;
      Write_Str ("Name_Chars'Length = ");
      Write_Int (Name_Chars.Last - Name_Chars.First + 1);
      Write_Eol;
      Write_Str ("Name_Entries'Length = ");
      Write_Int (Int (Name_Entries.Last - Name_Entries.First + 1));
      Write_Eol;
      Write_Str ("Nsyms = ");
      Write_Int (Nsyms);
      Write_Eol;
   end Finalize;

   -----------------------------
   -- Get_Decoded_Name_String --
   -----------------------------

   procedure Get_Decoded_Name_String (Id : Name_Id) is
      C : Character;
      P : Natural;

   begin
      Get_Name_String (Id);

      --  Skip scan if we already know there are no encodings

      if Name_Entries.Table (Id).Name_Has_No_Encodings then
         return;
      end if;

      --  Quick loop to see if there is anything special to do

      P := 1;
      loop
         if P = Name_Len then
            Name_Entries.Table (Id).Name_Has_No_Encodings := True;
            return;

         else
            C := Name_Buffer (P);

            exit when
              C = 'U' or else
              C = 'W' or else
              C = 'Q' or else
              C = 'O';

            P := P + 1;
         end if;
      end loop;

      --  Here we have at least some encoding that we must decode

      Decode : declare
         New_Len : Natural;
         Old     : Positive;
         New_Buf : String (1 .. Name_Buffer'Last);

         procedure Copy_One_Character;
         --  Copy a character from Name_Buffer to New_Buf. Includes case
         --  of copying a Uhh,Whhhh,WWhhhhhhhh sequence and decoding it.

         function Hex (N : Natural) return Word;
         --  Scans past N digits using Old pointer and returns hex value

         procedure Insert_Character (C : Character);
         --  Insert a new character into output decoded name

         ------------------------
         -- Copy_One_Character --
         ------------------------

         procedure Copy_One_Character is
            C : Character;

         begin
            C := Name_Buffer (Old);

            --  U (upper half insertion case)

            if C = 'U'
              and then Old < Name_Len
              and then Name_Buffer (Old + 1) not in 'A' .. 'Z'
              and then Name_Buffer (Old + 1) /= '_'
            then
               Old := Old + 1;

               --  If we have upper half encoding, then we have to set an
               --  appropriate wide character sequence for this character.

               if Upper_Half_Encoding then
                  Widechar.Set_Wide (Char_Code (Hex (2)), New_Buf, New_Len);

                  --  For other encoding methods, upper half characters can
                  --  simply use their normal representation.

               else
                  Insert_Character (Character'Val (Hex (2)));
               end if;

            --  WW (wide wide character insertion)

            elsif C = 'W'
              and then Old < Name_Len
              and then Name_Buffer (Old + 1) = 'W'
            then
               Old := Old + 2;
               Widechar.Set_Wide (Char_Code (Hex (8)), New_Buf, New_Len);

            --  W (wide character insertion)

            elsif C = 'W'
              and then Old < Name_Len
              and then Name_Buffer (Old + 1) not in 'A' .. 'Z'
              and then Name_Buffer (Old + 1) /= '_'
            then
               Old := Old + 1;
               Widechar.Set_Wide (Char_Code (Hex (4)), New_Buf, New_Len);

            --  Any other character is copied unchanged

            else
               Insert_Character (C);
               Old := Old + 1;
            end if;
         end Copy_One_Character;

         ---------
         -- Hex --
         ---------

         function Hex (N : Natural) return Word is
            T : Word := 0;
            C : Character;

         begin
            for J in 1 .. N loop
               C := Name_Buffer (Old);
               Old := Old + 1;

               pragma Assert (C in '0' .. '9' or else C in 'a' .. 'f');

               if C <= '9' then
                  T := 16 * T + Character'Pos (C) - Character'Pos ('0');
               else -- C in 'a' .. 'f'
                  T := 16 * T + Character'Pos (C) - (Character'Pos ('a') - 10);
               end if;
            end loop;

            return T;
         end Hex;

         ----------------------
         -- Insert_Character --
         ----------------------

         procedure Insert_Character (C : Character) is
         begin
            New_Len := New_Len + 1;
            New_Buf (New_Len) := C;
         end Insert_Character;

      --  Start of processing for Decode

      begin
         New_Len := 0;
         Old := 1;

         --  Loop through characters of name

         while Old <= Name_Len loop

            --  Case of character literal, put apostrophes around character

            if Name_Buffer (Old) = 'Q'
              and then Old < Name_Len
            then
               Old := Old + 1;
               Insert_Character (''');
               Copy_One_Character;
               Insert_Character (''');

            --  Case of operator name

            elsif Name_Buffer (Old) = 'O'
              and then Old < Name_Len
              and then Name_Buffer (Old + 1) not in 'A' .. 'Z'
              and then Name_Buffer (Old + 1) /= '_'
            then
               Old := Old + 1;

               declare
                  --  This table maps the 2nd and 3rd characters of the name
                  --  into the required output. Two blanks means leave the
                  --  name alone

                  Map : constant String :=
                     "ab  " &               --  Oabs         => "abs"
                     "ad+ " &               --  Oadd         => "+"
                     "an  " &               --  Oand         => "and"
                     "co& " &               --  Oconcat      => "&"
                     "di/ " &               --  Odivide      => "/"
                     "eq= " &               --  Oeq          => "="
                     "ex**" &               --  Oexpon       => "**"
                     "gt> " &               --  Ogt          => ">"
                     "ge>=" &               --  Oge          => ">="
                     "le<=" &               --  Ole          => "<="
                     "lt< " &               --  Olt          => "<"
                     "mo  " &               --  Omod         => "mod"
                     "mu* " &               --  Omutliply    => "*"
                     "ne/=" &               --  One          => "/="
                     "no  " &               --  Onot         => "not"
                     "or  " &               --  Oor          => "or"
                     "re  " &               --  Orem         => "rem"
                     "su- " &               --  Osubtract    => "-"
                     "xo  ";                --  Oxor         => "xor"

                  J : Integer;

               begin
                  Insert_Character ('"');

                  --  Search the map. Note that this loop must terminate, if
                  --  not we have some kind of internal error, and a constraint
                  --  error may be raised.

                  J := Map'First;
                  loop
                     exit when Name_Buffer (Old) = Map (J)
                       and then Name_Buffer (Old + 1) = Map (J + 1);
                     J := J + 4;
                  end loop;

                  --  Special operator name

                  if Map (J + 2) /= ' ' then
                     Insert_Character (Map (J + 2));

                     if Map (J + 3) /= ' ' then
                        Insert_Character (Map (J + 3));
                     end if;

                     Insert_Character ('"');

                     --  Skip past original operator name in input

                     while Old <= Name_Len
                       and then Name_Buffer (Old) in 'a' .. 'z'
                     loop
                        Old := Old + 1;
                     end loop;

                  --  For other operator names, leave them in lower case,
                  --  surrounded by apostrophes

                  else
                     --  Copy original operator name from input to output

                     while Old <= Name_Len
                        and then Name_Buffer (Old) in 'a' .. 'z'
                     loop
                        Copy_One_Character;
                     end loop;

                     Insert_Character ('"');
                  end if;
               end;

            --  Else copy one character and keep going

            else
               Copy_One_Character;
            end if;
         end loop;

         --  Copy new buffer as result

         Name_Len := New_Len;
         Name_Buffer (1 .. New_Len) := New_Buf (1 .. New_Len);
      end Decode;
   end Get_Decoded_Name_String;

   -------------------------------------------
   -- Get_Decoded_Name_String_With_Brackets --
   -------------------------------------------

   procedure Get_Decoded_Name_String_With_Brackets (Id : Name_Id) is
      P : Natural;

   begin
      --  Case of operator name, normal decoding is fine

      if Name_Buffer (1) = 'O' then
         Get_Decoded_Name_String (Id);

      --  For character literals, normal decoding is fine

      elsif Name_Buffer (1) = 'Q' then
         Get_Decoded_Name_String (Id);

      --  Only remaining issue is U/W/WW sequences

      else
         Get_Name_String (Id);

         P := 1;
         while P < Name_Len loop
            if Name_Buffer (P + 1) in 'A' .. 'Z' then
               P := P + 1;

            --  Uhh encoding

            elsif Name_Buffer (P) = 'U' then
               for J in reverse P + 3 .. P + Name_Len loop
                  Name_Buffer (J + 3) := Name_Buffer (J);
               end loop;

               Name_Len := Name_Len + 3;
               Name_Buffer (P + 3) := Name_Buffer (P + 2);
               Name_Buffer (P + 2) := Name_Buffer (P + 1);
               Name_Buffer (P)     := '[';
               Name_Buffer (P + 1) := '"';
               Name_Buffer (P + 4) := '"';
               Name_Buffer (P + 5) := ']';
               P := P + 6;

            --  WWhhhhhhhh encoding

            elsif Name_Buffer (P) = 'W'
              and then P + 9 <= Name_Len
              and then Name_Buffer (P + 1) = 'W'
              and then Name_Buffer (P + 2) not in 'A' .. 'Z'
              and then Name_Buffer (P + 2) /= '_'
            then
               Name_Buffer (P + 12 .. Name_Len + 2) :=
                 Name_Buffer (P + 10 .. Name_Len);
               Name_Buffer (P)     := '[';
               Name_Buffer (P + 1) := '"';
               Name_Buffer (P + 10) := '"';
               Name_Buffer (P + 11) := ']';
               Name_Len := Name_Len + 2;
               P := P + 12;

            --  Whhhh encoding

            elsif Name_Buffer (P) = 'W'
              and then P < Name_Len
              and then Name_Buffer (P + 1) not in 'A' .. 'Z'
              and then Name_Buffer (P + 1) /= '_'
            then
               Name_Buffer (P + 8 .. P + Name_Len + 3) :=
                 Name_Buffer (P + 5 .. Name_Len);
               Name_Buffer (P + 2 .. P + 5) := Name_Buffer (P + 1 .. P + 4);
               Name_Buffer (P)     := '[';
               Name_Buffer (P + 1) := '"';
               Name_Buffer (P + 6) := '"';
               Name_Buffer (P + 7) := ']';
               Name_Len := Name_Len + 3;
               P := P + 8;

            else
               P := P + 1;
            end if;
         end loop;
      end if;
   end Get_Decoded_Name_String_With_Brackets;

   ------------------------
   -- Get_Last_Two_Chars --
   ------------------------

   procedure Get_Last_Two_Chars
     (N  : Name_Id;
      C1 : out Character;
      C2 : out Character)
   is
      NE  : Name_Entry renames Name_Entries.Table (N);
      NEL : constant Int := Int (NE.Name_Len);

   begin
      if NEL >= 2 then
         C1 := Name_Chars.Table (NE.Name_Chars_Index + NEL - 1);
         C2 := Name_Chars.Table (NE.Name_Chars_Index + NEL - 0);
      else
         C1 := ASCII.NUL;
         C2 := ASCII.NUL;
      end if;
   end Get_Last_Two_Chars;

   ---------------------
   -- Get_Name_String --
   ---------------------

   --  Procedure version leaving result in Name_Buffer, length in Name_Len

   procedure Get_Name_String (Id : Name_Id) is
      S : Int;

   begin
      pragma Assert (Id in Name_Entries.First .. Name_Entries.Last);

      S := Name_Entries.Table (Id).Name_Chars_Index;
      Name_Len := Natural (Name_Entries.Table (Id).Name_Len);

      for J in 1 .. Name_Len loop
         Name_Buffer (J) := Name_Chars.Table (S + Int (J));
      end loop;
   end Get_Name_String;

   ---------------------
   -- Get_Name_String --
   ---------------------

   --  Function version returning a string

   function Get_Name_String (Id : Name_Id) return String is
      S : Int;

   begin
      pragma Assert (Id in Name_Entries.First .. Name_Entries.Last);
      S := Name_Entries.Table (Id).Name_Chars_Index;

      declare
         R : String (1 .. Natural (Name_Entries.Table (Id).Name_Len));

      begin
         for J in R'Range loop
            R (J) := Name_Chars.Table (S + Int (J));
         end loop;

         return R;
      end;
   end Get_Name_String;

   --------------------------------
   -- Get_Name_String_And_Append --
   --------------------------------

   procedure Get_Name_String_And_Append (Id : Name_Id) is
      S : Int;

   begin
      pragma Assert (Id in Name_Entries.First .. Name_Entries.Last);

      S := Name_Entries.Table (Id).Name_Chars_Index;

      for J in 1 .. Natural (Name_Entries.Table (Id).Name_Len) loop
         Name_Len := Name_Len + 1;
         Name_Buffer (Name_Len) := Name_Chars.Table (S + Int (J));
      end loop;
   end Get_Name_String_And_Append;

   -----------------------------
   -- Get_Name_Table_Boolean1 --
   -----------------------------

   function Get_Name_Table_Boolean1 (Id : Name_Id) return Boolean is
   begin
      pragma Assert (Id in Name_Entries.First .. Name_Entries.Last);
      return Name_Entries.Table (Id).Boolean1_Info;
   end Get_Name_Table_Boolean1;

   -----------------------------
   -- Get_Name_Table_Boolean2 --
   -----------------------------

   function Get_Name_Table_Boolean2 (Id : Name_Id) return Boolean is
   begin
      pragma Assert (Id in Name_Entries.First .. Name_Entries.Last);
      return Name_Entries.Table (Id).Boolean2_Info;
   end Get_Name_Table_Boolean2;

   -----------------------------
   -- Get_Name_Table_Boolean3 --
   -----------------------------

   function Get_Name_Table_Boolean3 (Id : Name_Id) return Boolean is
   begin
      pragma Assert (Id in Name_Entries.First .. Name_Entries.Last);
      return Name_Entries.Table (Id).Boolean3_Info;
   end Get_Name_Table_Boolean3;

   -------------------------
   -- Get_Name_Table_Byte --
   -------------------------

   function Get_Name_Table_Byte (Id : Name_Id) return Byte is
   begin
      pragma Assert (Id in Name_Entries.First .. Name_Entries.Last);
      return Name_Entries.Table (Id).Byte_Info;
   end Get_Name_Table_Byte;

   -------------------------
   -- Get_Name_Table_Int --
   -------------------------

   function Get_Name_Table_Int (Id : Name_Id) return Int is
   begin
      pragma Assert (Id in Name_Entries.First .. Name_Entries.Last);
      return Name_Entries.Table (Id).Int_Info;
   end Get_Name_Table_Int;

   -----------------------------------------
   -- Get_Unqualified_Decoded_Name_String --
   -----------------------------------------

   procedure Get_Unqualified_Decoded_Name_String (Id : Name_Id) is
   begin
      Get_Decoded_Name_String (Id);
      Strip_Qualification_And_Suffixes;
   end Get_Unqualified_Decoded_Name_String;

   ---------------------------------
   -- Get_Unqualified_Name_String --
   ---------------------------------

   procedure Get_Unqualified_Name_String (Id : Name_Id) is
   begin
      Get_Name_String (Id);
      Strip_Qualification_And_Suffixes;
   end Get_Unqualified_Name_String;

   ----------
   -- Hash --
   ----------

   function Hash return Hash_Index_Type is

      --  This hash function looks at every character, in order to make it
      --  likely that similar strings get different hash values. The rotate by
      --  7 bits has been determined empirically to be good, and it doesn't
      --  lose bits like a shift would. The final conversion can't overflow,
      --  because the table is 2**16 in size. This function probably needs to
      --  be changed if the hash table size is changed.

      --  Note that we could get some speed improvement by aligning the string
      --  to 32 or 64 bits, and doing word-wise xor's. We could also implement
      --  a growable table. It doesn't seem worth the trouble to do those
      --  things, for now.

      Result : Unsigned_16 := 0;

   begin
      for J in 1 .. Name_Len loop
         Result := Rotate_Left (Result, 7) xor Character'Pos (Name_Buffer (J));
      end loop;

      return Hash_Index_Type (Result);
   end Hash;

   ----------------
   -- Initialize --
   ----------------

   procedure Initialize is
   begin
      null;
   end Initialize;

   -------------------------------
   -- Insert_Str_In_Name_Buffer --
   -------------------------------

   procedure Insert_Str_In_Name_Buffer (S : String; Index : Positive) is
      SL : constant Natural := S'Length;
   begin
      Name_Buffer (Index + SL .. Name_Len + SL) :=
        Name_Buffer (Index .. Name_Len);
      Name_Buffer (Index .. Index + SL - 1) := S;
      Name_Len := Name_Len + SL;
   end Insert_Str_In_Name_Buffer;

   ----------------------
   -- Is_Internal_Name --
   ----------------------

   --  Version taking an argument

   function Is_Internal_Name (Id : Name_Id) return Boolean is
   begin
      if Id in Error_Name_Or_No_Name then
         return False;
      else
         Get_Name_String (Id);
         return Is_Internal_Name;
      end if;
   end Is_Internal_Name;

   ----------------------
   -- Is_Internal_Name --
   ----------------------

   --  Version taking its input from Name_Buffer

   function Is_Internal_Name return Boolean is
      J : Natural;

   begin
      --  AAny name starting with underscore is internal

      if Name_Buffer (1) = '_'
        or else Name_Buffer (Name_Len) = '_'
      then
         return True;

      --  Allow quoted character

      elsif Name_Buffer (1) = ''' then
         return False;

      --  All other cases, scan name

      else
         --  Test backwards, because we only want to test the last entity
         --  name if the name we have is qualified with other entities.

         J := Name_Len;
         while J /= 0 loop

            --  Skip stuff between brackets (A-F OK there)

            if Name_Buffer (J) = ']' then
               loop
                  J := J - 1;
                  exit when J = 1 or else Name_Buffer (J) = '[';
               end loop;

            --  Test for internal letter

            elsif Is_OK_Internal_Letter (Name_Buffer (J)) then
               return True;

            --  Quit if we come to terminating double underscore (note that
            --  if the current character is an underscore, we know that
            --  there is a previous character present, since we already
            --  filtered out the case of Name_Buffer (1) = '_' above.

            elsif Name_Buffer (J) = '_'
              and then Name_Buffer (J - 1) = '_'
              and then Name_Buffer (J - 2) /= '_'
            then
               return False;
            end if;

            J := J - 1;
         end loop;
      end if;

      return False;
   end Is_Internal_Name;

   ---------------------------
   -- Is_OK_Internal_Letter --
   ---------------------------

   function Is_OK_Internal_Letter (C : Character) return Boolean is
   begin
      return C in 'A' .. 'Z'
        and then C /= 'O'
        and then C /= 'Q'
        and then C /= 'U'
        and then C /= 'W'
        and then C /= 'X';
   end Is_OK_Internal_Letter;

   ----------------------
   -- Is_Operator_Name --
   ----------------------

   function Is_Operator_Name (Id : Name_Id) return Boolean is
      S : Int;
   begin
      pragma Assert (Id in Name_Entries.First .. Name_Entries.Last);
      S := Name_Entries.Table (Id).Name_Chars_Index;
      return Name_Chars.Table (S + 1) = 'O';
   end Is_Operator_Name;

   -------------------
   -- Is_Valid_Name --
   -------------------

   function Is_Valid_Name (Id : Name_Id) return Boolean is
   begin
      return Id in Name_Entries.First .. Name_Entries.Last;
   end Is_Valid_Name;

   --------------------
   -- Length_Of_Name --
   --------------------

   function Length_Of_Name (Id : Name_Id) return Nat is
   begin
      return Int (Name_Entries.Table (Id).Name_Len);
   end Length_Of_Name;

   ----------
   -- Lock --
   ----------

   procedure Lock is
   begin
      Name_Chars.Set_Last (Name_Chars.Last + Name_Chars_Reserve);
      Name_Entries.Set_Last (Name_Entries.Last + Name_Entries_Reserve);
      Name_Chars.Locked := True;
      Name_Entries.Locked := True;
      Name_Chars.Release;
      Name_Entries.Release;
   end Lock;

   ------------------------
   -- Name_Chars_Address --
   ------------------------

   function Name_Chars_Address return System.Address is
   begin
      return Name_Chars.Table (0)'Address;
   end Name_Chars_Address;

   ----------------
   -- Name_Enter --
   ----------------

   function Name_Enter return Name_Id is
   begin
      Name_Entries.Append
        ((Name_Chars_Index      => Name_Chars.Last,
          Name_Len              => Short (Name_Len),
          Byte_Info             => 0,
          Int_Info              => 0,
          Boolean1_Info         => False,
          Boolean2_Info         => False,
          Boolean3_Info         => False,
          Name_Has_No_Encodings => False,
          Hash_Link             => No_Name));

      --  Set corresponding string entry in the Name_Chars table

      for J in 1 .. Name_Len loop
         Name_Chars.Append (Name_Buffer (J));
      end loop;

      Name_Chars.Append (ASCII.NUL);

      return Name_Entries.Last;
   end Name_Enter;

   --------------------------
   -- Name_Entries_Address --
   --------------------------

   function Name_Entries_Address return System.Address is
   begin
      return Name_Entries.Table (First_Name_Id)'Address;
   end Name_Entries_Address;

   ------------------------
   -- Name_Entries_Count --
   ------------------------

   function Name_Entries_Count return Nat is
   begin
      return Int (Name_Entries.Last - Name_Entries.First + 1);
   end Name_Entries_Count;

   ---------------
   -- Name_Find --
   ---------------

   function Name_Find return Name_Id is
      New_Id : Name_Id;
      --  Id of entry in hash search, and value to be returned

      S : Int;
      --  Pointer into string table

      Hash_Index : Hash_Index_Type;
      --  Computed hash index

   begin
      --  Quick handling for one character names

      if Name_Len = 1 then
         return Name_Id (First_Name_Id + Character'Pos (Name_Buffer (1)));

      --  Otherwise search hash table for existing matching entry

      else
         Hash_Index := Namet.Hash;
         New_Id := Hash_Table (Hash_Index);

         if New_Id = No_Name then
            Hash_Table (Hash_Index) := Name_Entries.Last + 1;

         else
            Search : loop
               if Name_Len /=
                 Integer (Name_Entries.Table (New_Id).Name_Len)
               then
                  goto No_Match;
               end if;

               S := Name_Entries.Table (New_Id).Name_Chars_Index;

               for J in 1 .. Name_Len loop
                  if Name_Chars.Table (S + Int (J)) /= Name_Buffer (J) then
                     goto No_Match;
                  end if;
               end loop;

               return New_Id;

               --  Current entry in hash chain does not match

               <<No_Match>>
                  if Name_Entries.Table (New_Id).Hash_Link /= No_Name then
                     New_Id := Name_Entries.Table (New_Id).Hash_Link;
                  else
                     Name_Entries.Table (New_Id).Hash_Link :=
                       Name_Entries.Last + 1;
                     exit Search;
                  end if;
            end loop Search;
         end if;

         --  We fall through here only if a matching entry was not found in the
         --  hash table. We now create a new entry in the names table. The hash
         --  link pointing to the new entry (Name_Entries.Last+1) has been set.

         Name_Entries.Append
           ((Name_Chars_Index      => Name_Chars.Last,
             Name_Len              => Short (Name_Len),
             Hash_Link             => No_Name,
             Name_Has_No_Encodings => False,
             Int_Info              => 0,
             Byte_Info             => 0,
             Boolean1_Info         => False,
             Boolean2_Info         => False,
             Boolean3_Info         => False));

         --  Set corresponding string entry in the Name_Chars table

         for J in 1 .. Name_Len loop
            Name_Chars.Append (Name_Buffer (J));
         end loop;

         Name_Chars.Append (ASCII.NUL);

         return Name_Entries.Last;
      end if;
   end Name_Find;

   -------------------
   -- Name_Find_Str --
   -------------------

   function Name_Find_Str (S : String) return Name_Id is
   begin
      Name_Len := S'Length;
      Name_Buffer (1 .. Name_Len) := S;
      return Name_Find;
   end Name_Find_Str;

   -------------
   -- Nam_In --
   -------------

   function Nam_In
     (T  : Name_Id;
      V1 : Name_Id;
      V2 : Name_Id) return Boolean
   is
   begin
      return T = V1 or else
             T = V2;
   end Nam_In;

   function Nam_In
     (T  : Name_Id;
      V1 : Name_Id;
      V2 : Name_Id;
      V3 : Name_Id) return Boolean
   is
   begin
      return T = V1 or else
             T = V2 or else
             T = V3;
   end Nam_In;

   function Nam_In
     (T  : Name_Id;
      V1 : Name_Id;
      V2 : Name_Id;
      V3 : Name_Id;
      V4 : Name_Id) return Boolean
   is
   begin
      return T = V1 or else
             T = V2 or else
             T = V3 or else
             T = V4;
   end Nam_In;

   function Nam_In
     (T  : Name_Id;
      V1 : Name_Id;
      V2 : Name_Id;
      V3 : Name_Id;
      V4 : Name_Id;
      V5 : Name_Id) return Boolean
   is
   begin
      return T = V1 or else
             T = V2 or else
             T = V3 or else
             T = V4 or else
             T = V5;
   end Nam_In;

   function Nam_In
     (T  : Name_Id;
      V1 : Name_Id;
      V2 : Name_Id;
      V3 : Name_Id;
      V4 : Name_Id;
      V5 : Name_Id;
      V6 : Name_Id) return Boolean
   is
   begin
      return T = V1 or else
             T = V2 or else
             T = V3 or else
             T = V4 or else
             T = V5 or else
             T = V6;
   end Nam_In;

   function Nam_In
     (T  : Name_Id;
      V1 : Name_Id;
      V2 : Name_Id;
      V3 : Name_Id;
      V4 : Name_Id;
      V5 : Name_Id;
      V6 : Name_Id;
      V7 : Name_Id) return Boolean
   is
   begin
      return T = V1 or else
             T = V2 or else
             T = V3 or else
             T = V4 or else
             T = V5 or else
             T = V6 or else
             T = V7;
   end Nam_In;

   function Nam_In
     (T  : Name_Id;
      V1 : Name_Id;
      V2 : Name_Id;
      V3 : Name_Id;
      V4 : Name_Id;
      V5 : Name_Id;
      V6 : Name_Id;
      V7 : Name_Id;
      V8 : Name_Id) return Boolean
   is
   begin
      return T = V1 or else
             T = V2 or else
             T = V3 or else
             T = V4 or else
             T = V5 or else
             T = V6 or else
             T = V7 or else
             T = V8;
   end Nam_In;

   function Nam_In
     (T  : Name_Id;
      V1 : Name_Id;
      V2 : Name_Id;
      V3 : Name_Id;
      V4 : Name_Id;
      V5 : Name_Id;
      V6 : Name_Id;
      V7 : Name_Id;
      V8 : Name_Id;
      V9 : Name_Id) return Boolean
   is
   begin
      return T = V1 or else
             T = V2 or else
             T = V3 or else
             T = V4 or else
             T = V5 or else
             T = V6 or else
             T = V7 or else
             T = V8 or else
             T = V9;
   end Nam_In;

   function Nam_In
     (T   : Name_Id;
      V1  : Name_Id;
      V2  : Name_Id;
      V3  : Name_Id;
      V4  : Name_Id;
      V5  : Name_Id;
      V6  : Name_Id;
      V7  : Name_Id;
      V8  : Name_Id;
      V9  : Name_Id;
      V10 : Name_Id) return Boolean
   is
   begin
      return T = V1 or else
             T = V2 or else
             T = V3 or else
             T = V4 or else
             T = V5 or else
             T = V6 or else
             T = V7 or else
             T = V8 or else
             T = V9 or else
             T = V10;
   end Nam_In;

   function Nam_In
     (T   : Name_Id;
      V1  : Name_Id;
      V2  : Name_Id;
      V3  : Name_Id;
      V4  : Name_Id;
      V5  : Name_Id;
      V6  : Name_Id;
      V7  : Name_Id;
      V8  : Name_Id;
      V9  : Name_Id;
      V10 : Name_Id;
      V11 : Name_Id) return Boolean
   is
   begin
      return T = V1  or else
             T = V2  or else
             T = V3  or else
             T = V4  or else
             T = V5  or else
             T = V6  or else
             T = V7  or else
             T = V8  or else
             T = V9  or else
             T = V10 or else
             T = V11;
   end Nam_In;

   -----------------
   -- Name_Equals --
   -----------------

   function Name_Equals (N1 : Name_Id; N2 : Name_Id) return Boolean is
   begin
      if N1 = N2 then
         return True;
      end if;

      declare
         L1 : constant Int := Int (Name_Entries.Table (N1).Name_Len);
         L2 : constant Int := Int (Name_Entries.Table (N2).Name_Len);

      begin
         if L1 /= L2 then
            return False;
         end if;

         declare
            use Name_Chars;
            I1 : constant Int := Name_Entries.Table (N1).Name_Chars_Index;
            I2 : constant Int := Name_Entries.Table (N2).Name_Chars_Index;

         begin
            return (Name_Chars.Table (1 + I1 .. I1 + L1) =
                    Name_Chars.Table (1 + I2 .. I2 + L2));
         end;
      end;
   end Name_Equals;

   ------------------
   -- Reinitialize --
   ------------------

   procedure Reinitialize is
   begin
      Name_Chars.Init;
      Name_Entries.Init;

      --  Initialize entries for one character names

      for C in Character loop
         Name_Entries.Append
           ((Name_Chars_Index      => Name_Chars.Last,
             Name_Len              => 1,
             Byte_Info             => 0,
             Int_Info              => 0,
             Boolean1_Info         => False,
             Boolean2_Info         => False,
             Boolean3_Info         => False,
             Name_Has_No_Encodings => True,
             Hash_Link             => No_Name));

         Name_Chars.Append (C);
         Name_Chars.Append (ASCII.NUL);
      end loop;

      --  Clear hash table

      for J in Hash_Index_Type loop
         Hash_Table (J) := No_Name;
      end loop;
   end Reinitialize;

   ----------------------
   -- Reset_Name_Table --
   ----------------------

   procedure Reset_Name_Table is
   begin
      for J in First_Name_Id .. Name_Entries.Last loop
         Name_Entries.Table (J).Int_Info  := 0;
         Name_Entries.Table (J).Byte_Info := 0;
      end loop;
   end Reset_Name_Table;

   --------------------------------
   -- Set_Character_Literal_Name --
   --------------------------------

   procedure Set_Character_Literal_Name (C : Char_Code) is
   begin
      Name_Buffer (1) := 'Q';
      Name_Len := 1;
      Store_Encoded_Character (C);
   end Set_Character_Literal_Name;

   -----------------------------
   -- Set_Name_Table_Boolean1 --
   -----------------------------

   procedure Set_Name_Table_Boolean1 (Id : Name_Id; Val : Boolean) is
   begin
      pragma Assert (Id in Name_Entries.First .. Name_Entries.Last);
      Name_Entries.Table (Id).Boolean1_Info := Val;
   end Set_Name_Table_Boolean1;

   -----------------------------
   -- Set_Name_Table_Boolean2 --
   -----------------------------

   procedure Set_Name_Table_Boolean2 (Id : Name_Id; Val : Boolean) is
   begin
      pragma Assert (Id in Name_Entries.First .. Name_Entries.Last);
      Name_Entries.Table (Id).Boolean2_Info := Val;
   end Set_Name_Table_Boolean2;

   -----------------------------
   -- Set_Name_Table_Boolean3 --
   -----------------------------

   procedure Set_Name_Table_Boolean3 (Id : Name_Id; Val : Boolean) is
   begin
      pragma Assert (Id in Name_Entries.First .. Name_Entries.Last);
      Name_Entries.Table (Id).Boolean3_Info := Val;
   end Set_Name_Table_Boolean3;

   -------------------------
   -- Set_Name_Table_Byte --
   -------------------------

   procedure Set_Name_Table_Byte (Id : Name_Id; Val : Byte) is
   begin
      pragma Assert (Id in Name_Entries.First .. Name_Entries.Last);
      Name_Entries.Table (Id).Byte_Info := Val;
   end Set_Name_Table_Byte;

   -------------------------
   -- Set_Name_Table_Int --
   -------------------------

   procedure Set_Name_Table_Int (Id : Name_Id; Val : Int) is
   begin
      pragma Assert (Id in Name_Entries.First .. Name_Entries.Last);
      Name_Entries.Table (Id).Int_Info := Val;
   end Set_Name_Table_Int;

   -----------------------------
   -- Store_Encoded_Character --
   -----------------------------

   procedure Store_Encoded_Character (C : Char_Code) is
      procedure Set_Hex_Chars (C : Char_Code);
      --  Stores given value, which is in the range 0 .. 255, as two hex
      --  digits (using lower case a-f) in Name_Buffer, incrementing Name_Len.

      -------------------
      -- Set_Hex_Chars --
      -------------------

      procedure Set_Hex_Chars (C : Char_Code) is
         Hexd : constant String := "0123456789abcdef";
         N    : constant Natural := Natural (C);
      begin
         Name_Buffer (Name_Len + 1) := Hexd (N / 16 + 1);
         Name_Buffer (Name_Len + 2) := Hexd (N mod 16 + 1);
         Name_Len := Name_Len + 2;
      end Set_Hex_Chars;

   --  Start of processing for Store_Encoded_Character

   begin
      Name_Len := Name_Len + 1;

      if In_Character_Range (C) then
         declare
            CC : constant Character := Get_Character (C);
         begin
            if CC in 'a' .. 'z' or else CC in '0' .. '9' then
               Name_Buffer (Name_Len) := CC;
            else
               Name_Buffer (Name_Len) := 'U';
               Set_Hex_Chars (C);
            end if;
         end;

      elsif In_Wide_Character_Range (C) then
         Name_Buffer (Name_Len) := 'W';
         Set_Hex_Chars (C / 256);
         Set_Hex_Chars (C mod 256);

      else
         Name_Buffer (Name_Len) := 'W';
         Name_Len := Name_Len + 1;
         Name_Buffer (Name_Len) := 'W';
         Set_Hex_Chars (C / 2 ** 24);
         Set_Hex_Chars ((C / 2 ** 16) mod 256);
         Set_Hex_Chars ((C / 256) mod 256);
         Set_Hex_Chars (C mod 256);
      end if;
   end Store_Encoded_Character;

   --------------------------------------
   -- Strip_Qualification_And_Suffixes --
   --------------------------------------

   procedure Strip_Qualification_And_Suffixes is
      J : Integer;

   begin
      --  Strip package body qualification string off end

      for J in reverse 2 .. Name_Len loop
         if Name_Buffer (J) = 'X' then
            Name_Len := J - 1;
            exit;
         end if;

         exit when Name_Buffer (J) /= 'b'
           and then Name_Buffer (J) /= 'n'
           and then Name_Buffer (J) /= 'p';
      end loop;

      --  Find rightmost __ or $ separator if one exists. First we position
      --  to start the search. If we have a character constant, position
      --  just before it, otherwise position to last character but one

      if Name_Buffer (Name_Len) = ''' then
         J := Name_Len - 2;
         while J > 0 and then Name_Buffer (J) /= ''' loop
            J := J - 1;
         end loop;

      else
         J := Name_Len - 1;
      end if;

      --  Loop to search for rightmost __ or $ (homonym) separator

      while J > 1 loop

         --  If $ separator, homonym separator, so strip it and keep looking

         if Name_Buffer (J) = '$' then
            Name_Len := J - 1;
            J := Name_Len - 1;

         --  Else check for __ found

         elsif Name_Buffer (J) = '_' and then Name_Buffer (J + 1) = '_' then

            --  Found __ so see if digit follows, and if so, this is a
            --  homonym separator, so strip it and keep looking.

            if Name_Buffer (J + 2) in '0' .. '9' then
               Name_Len := J - 1;
               J := Name_Len - 1;

            --  If not a homonym separator, then we simply strip the
            --  separator and everything that precedes it, and we are done

            else
               Name_Buffer (1 .. Name_Len - J - 1) :=
                 Name_Buffer (J + 2 .. Name_Len);
               Name_Len := Name_Len - J - 1;
               exit;
            end if;

         else
            J := J - 1;
         end if;
      end loop;
   end Strip_Qualification_And_Suffixes;

   ---------------
   -- Tree_Read --
   ---------------

   procedure Tree_Read is
   begin
      Name_Chars.Tree_Read;
      Name_Entries.Tree_Read;

      Tree_Read_Data
        (Hash_Table'Address,
         Hash_Table'Length * (Hash_Table'Component_Size / Storage_Unit));
   end Tree_Read;

   ----------------
   -- Tree_Write --
   ----------------

   procedure Tree_Write is
   begin
      Name_Chars.Tree_Write;
      Name_Entries.Tree_Write;

      Tree_Write_Data
        (Hash_Table'Address,
         Hash_Table'Length * (Hash_Table'Component_Size / Storage_Unit));
   end Tree_Write;

   ------------
   -- Unlock --
   ------------

   procedure Unlock is
   begin
      Name_Chars.Set_Last (Name_Chars.Last - Name_Chars_Reserve);
      Name_Entries.Set_Last (Name_Entries.Last - Name_Entries_Reserve);
      Name_Chars.Locked := False;
      Name_Entries.Locked := False;
      Name_Chars.Release;
      Name_Entries.Release;
   end Unlock;

   --------
   -- wn --
   --------

   procedure wn (Id : Name_Id) is
      S : Int;

   begin
      if not Id'Valid then
         Write_Str ("<invalid name_id>");

      elsif Id = No_Name then
         Write_Str ("<No_Name>");

      elsif Id = Error_Name then
         Write_Str ("<Error_Name>");

      else
         S := Name_Entries.Table (Id).Name_Chars_Index;
         Name_Len := Natural (Name_Entries.Table (Id).Name_Len);

         for J in 1 .. Name_Len loop
            Write_Char (Name_Chars.Table (S + Int (J)));
         end loop;
      end if;

      Write_Eol;
   end wn;

   ----------------
   -- Write_Name --
   ----------------

   procedure Write_Name (Id : Name_Id) is
   begin
      if Id >= First_Name_Id then
         Get_Name_String (Id);
         Write_Str (Name_Buffer (1 .. Name_Len));
      end if;
   end Write_Name;

   ------------------------
   -- Write_Name_Decoded --
   ------------------------

   procedure Write_Name_Decoded (Id : Name_Id) is
   begin
      if Id >= First_Name_Id then
         Get_Decoded_Name_String (Id);
         Write_Str (Name_Buffer (1 .. Name_Len));
      end if;
   end Write_Name_Decoded;

--  Package initialization, initialize tables

begin
   Reinitialize;
end Namet;