New Language: Ada

git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@45955 138bc75d-0d04-0410-961f-82ee72b054a4

1 files changed, 1216 insertions, 0 deletions

diff --git a/gcc/ada/namet.adb b/gcc/ada/namet.adb
new file mode 100644
index 00000000000..4fe8c1a74e5
--- /dev/null
+++ b/gcc/ada/namet.adb
@@ -0,0 +1,1216 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                                N A M E T                                 --
+--                                                                          --
+--                                 B o d y                                  --
+--                                                                          --
+--                            $Revision: 1.86 $
+--                                                                          --
+--          Copyright (C) 1992-2001 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 2,  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.  See the GNU General Public License --
+-- for  more details.  You should have  received  a copy of the GNU General --
+-- Public License  distributed with GNAT;  see file COPYING.  If not, write --
+-- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
+-- MA 02111-1307, USA.                                                      --
+--                                                                          --
+-- As a special exception,  if other files  instantiate  generics from this --
+-- unit, or you link  this unit with other files  to produce an executable, --
+-- this  unit  does not  by itself cause  the resulting  executable  to  be --
+-- covered  by the  GNU  General  Public  License.  This exception does not --
+-- however invalidate  any other reasons why  the executable file  might be --
+-- covered by the  GNU Public License.                                      --
+--                                                                          --
+-- GNAT was originally developed  by the GNAT team at  New York University. --
+-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+--                                                                          --
+------------------------------------------------------------------------------
+
+--  WARNING: There is a C version of this package. Any changes to this
+--  source file must be properly reflected in the C header file a-namet.h
+--  which is created manually from namet.ads and namet.adb.
+
+with Debug;    use Debug;
+with Output;   use Output;
+with Tree_IO;  use Tree_IO;
+with Widechar; use Widechar;
+
+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**12;
+   --  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 alogorithm.
+
+   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_Package_Body_Suffix;
+   --  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
+      Max_Chain_Length : constant := 50;
+      --  Max length of chains for which specific information is output
+
+      F : array (Int range 0 .. Max_Chain_Length) of Int;
+      --  N'th entry is number of chains of length N
+
+      Probes : Int := 0;
+      --  Used to compute average number of probes
+
+      Nsyms : Int := 0;
+      --  Number of symbols in table
+
+   begin
+      if Debug_Flag_H then
+
+         for J in F'Range loop
+            F (J) := 0;
+         end loop;
+
+         for I in Hash_Index_Type loop
+            if Hash_Table (I) = No_Name then
+               F (0) := F (0) + 1;
+
+            else
+               Write_Str ("Hash_Table (");
+               Write_Int (Int (I));
+               Write_Str (") has ");
+
+               declare
+                  C : Int := 1;
+                  N : Name_Id;
+                  S : Int;
+
+               begin
+                  C := 0;
+                  N := Hash_Table (I);
+
+                  while N /= No_Name loop
+                     N := Name_Entries.Table (N).Hash_Link;
+                     C := C + 1;
+                  end loop;
+
+                  Write_Int (C);
+                  Write_Str (" entries");
+                  Write_Eol;
+
+                  if C < Max_Chain_Length then
+                     F (C) := F (C) + 1;
+                  else
+                     F (Max_Chain_Length) := F (Max_Chain_Length) + 1;
+                  end if;
+
+                  N := Hash_Table (I);
+
+                  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;
+            end if;
+         end loop;
+
+         Write_Eol;
+
+         for I in Int range 0 .. Max_Chain_Length loop
+            if F (I) /= 0 then
+               Write_Str ("Number of hash chains of length ");
+
+               if I < 10 then
+                  Write_Char (' ');
+               end if;
+
+               Write_Int (I);
+
+               if I = Max_Chain_Length then
+                  Write_Str (" or greater");
+               end if;
+
+               Write_Str (" = ");
+               Write_Int (F (I));
+               Write_Eol;
+
+               if I /= 0 then
+                  Nsyms := Nsyms + F (I);
+                  Probes := Probes + F (I) * (1 + I) * 100;
+               end if;
+            end if;
+         end loop;
+
+         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 (48 + Probes / 10));
+         Write_Char (Character'Val (48 + Probes mod 10));
+         Write_Eol;
+         Write_Eol;
+      end if;
+   end Finalize;
+
+   -----------------------------
+   -- Get_Decoded_Name_String --
+   -----------------------------
+
+   procedure Get_Decoded_Name_String (Id : Name_Id) is
+      C : Character;
+      P : Natural;
+
+   begin
+      Get_Name_String (Id);
+
+      --  Quick loop to see if there is anything special to do
+
+      P := 1;
+      loop
+         if P = Name_Len then
+            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
+
+      --  Here we have to decode one or more Uhh or Whhhh sequences
+
+      declare
+         New_Len : Natural;
+         Old     : Positive;
+         New_Buf : String (1 .. Name_Buffer'Last);
+
+         procedure Insert_Character (C : Character);
+         --  Insert a new character into output decoded name
+
+         procedure Copy_One_Character;
+         --  Copy a character from Name_Buffer to New_Buf. Includes case
+         --  of copying a Uhh or Whhhh sequence and decoding it.
+
+         function Hex (N : Natural) return Natural;
+         --  Scans past N digits using Old pointer and returns hex value
+
+         procedure Copy_One_Character is
+            C : Character;
+
+         begin
+            C := Name_Buffer (Old);
+
+            if C = 'U' then
+               Old := Old + 1;
+               Insert_Character (Character'Val (Hex (2)));
+
+            elsif C = 'W' then
+               Old := Old + 1;
+               Widechar.Set_Wide (Char_Code (Hex (4)), New_Buf, New_Len);
+
+            else
+               Insert_Character (Name_Buffer (Old));
+               Old := Old + 1;
+            end if;
+         end Copy_One_Character;
+
+         function Hex (N : Natural) return Natural is
+            T : Natural := 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;
+
+         procedure Insert_Character (C : Character) is
+         begin
+            New_Len := New_Len + 1;
+            New_Buf (New_Len) := C;
+         end Insert_Character;
+
+      --  Actual decoding processing
+
+      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' then
+               Old := Old + 1;
+               Insert_Character (''');
+               Copy_One_Character;
+               Insert_Character (''');
+
+            --  Case of operator name
+
+            elsif Name_Buffer (Old) = 'O' 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
+                  --  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;
+
+   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 sequences
+
+      else
+         Get_Name_String (Id);
+
+         P := 1;
+         while P < Name_Len loop
+            if 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;
+
+            elsif Name_Buffer (P) = 'W' then
+               Name_Buffer (P + 8 .. P + Name_Len + 5) :=
+                 Name_Buffer (P + 5 .. Name_Len);
+               Name_Buffer (P + 5) := Name_Buffer (P + 4);
+               Name_Buffer (P + 4) := Name_Buffer (P + 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 + 6) := '"';
+               Name_Buffer (P + 7) := ']';
+               Name_Len := Name_Len + 5;
+               P := P + 8;
+
+            else
+               P := P + 1;
+            end if;
+         end loop;
+      end if;
+   end Get_Decoded_Name_String_With_Brackets;
+
+   ---------------------
+   -- Get_Name_String --
+   ---------------------
+
+   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;
+
+   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_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_Info --
+   -------------------------
+
+   function Get_Name_Table_Info (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_Info;
+
+   -----------------------------------------
+   -- Get_Unqualified_Decoded_Name_String --
+   -----------------------------------------
+
+   procedure Get_Unqualified_Decoded_Name_String (Id : Name_Id) is
+   begin
+      Get_Decoded_Name_String (Id);
+      Strip_Qualification_And_Package_Body_Suffix;
+   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_Package_Body_Suffix;
+   end Get_Unqualified_Name_String;
+
+   ----------
+   -- Hash --
+   ----------
+
+   function Hash return Hash_Index_Type is
+      subtype Int_1_12 is Int range 1 .. 12;
+      --  Used to avoid when others on case jump below
+
+      Even_Name_Len : Integer;
+      --  Last even numbered position (used for >12 case)
+
+   begin
+
+      --  Special test for 12 (rather than counting on a when others for the
+      --  case statement below) avoids some Ada compilers converting the case
+      --  statement into successive jumps.
+
+      --  The case of a name longer than 12 characters is handled by taking
+      --  the first 6 odd numbered characters and the last 6 even numbered
+      --  characters
+
+      if Name_Len > 12 then
+         Even_Name_Len := (Name_Len) / 2 * 2;
+
+         return ((((((((((((
+           Character'Pos (Name_Buffer (01))) * 2 +
+           Character'Pos (Name_Buffer (Even_Name_Len - 10))) * 2 +
+           Character'Pos (Name_Buffer (03))) * 2 +
+           Character'Pos (Name_Buffer (Even_Name_Len - 08))) * 2 +
+           Character'Pos (Name_Buffer (05))) * 2 +
+           Character'Pos (Name_Buffer (Even_Name_Len - 06))) * 2 +
+           Character'Pos (Name_Buffer (07))) * 2 +
+           Character'Pos (Name_Buffer (Even_Name_Len - 04))) * 2 +
+           Character'Pos (Name_Buffer (09))) * 2 +
+           Character'Pos (Name_Buffer (Even_Name_Len - 02))) * 2 +
+           Character'Pos (Name_Buffer (11))) * 2 +
+           Character'Pos (Name_Buffer (Even_Name_Len))) mod Hash_Num;
+      end if;
+
+      --  For the cases of 1-12 characters, all characters participate in the
+      --  hash. The positioning is randomized, with the bias that characters
+      --  later on participate fully (i.e. are added towards the right side).
+
+      case Int_1_12 (Name_Len) is
+
+         when 1 =>
+            return
+               Character'Pos (Name_Buffer (1));
+
+         when 2 =>
+            return ((
+              Character'Pos (Name_Buffer (1))) * 64 +
+              Character'Pos (Name_Buffer (2))) mod Hash_Num;
+
+         when 3 =>
+            return (((
+              Character'Pos (Name_Buffer (1))) * 16 +
+              Character'Pos (Name_Buffer (3))) * 16 +
+              Character'Pos (Name_Buffer (2))) mod Hash_Num;
+
+         when 4 =>
+            return ((((
+              Character'Pos (Name_Buffer (1))) * 8 +
+              Character'Pos (Name_Buffer (2))) * 8 +
+              Character'Pos (Name_Buffer (3))) * 8 +
+              Character'Pos (Name_Buffer (4))) mod Hash_Num;
+
+         when 5 =>
+            return (((((
+              Character'Pos (Name_Buffer (4))) * 8 +
+              Character'Pos (Name_Buffer (1))) * 4 +
+              Character'Pos (Name_Buffer (3))) * 4 +
+              Character'Pos (Name_Buffer (5))) * 8 +
+              Character'Pos (Name_Buffer (2))) mod Hash_Num;
+
+         when 6 =>
+            return ((((((
+              Character'Pos (Name_Buffer (5))) * 4 +
+              Character'Pos (Name_Buffer (1))) * 4 +
+              Character'Pos (Name_Buffer (4))) * 4 +
+              Character'Pos (Name_Buffer (2))) * 4 +
+              Character'Pos (Name_Buffer (6))) * 4 +
+              Character'Pos (Name_Buffer (3))) mod Hash_Num;
+
+         when 7 =>
+            return (((((((
+              Character'Pos (Name_Buffer (4))) * 4 +
+              Character'Pos (Name_Buffer (3))) * 4 +
+              Character'Pos (Name_Buffer (1))) * 4 +
+              Character'Pos (Name_Buffer (2))) * 2 +
+              Character'Pos (Name_Buffer (5))) * 2 +
+              Character'Pos (Name_Buffer (7))) * 2 +
+              Character'Pos (Name_Buffer (6))) mod Hash_Num;
+
+         when 8 =>
+            return ((((((((
+              Character'Pos (Name_Buffer (2))) * 4 +
+              Character'Pos (Name_Buffer (1))) * 4 +
+              Character'Pos (Name_Buffer (3))) * 2 +
+              Character'Pos (Name_Buffer (5))) * 2 +
+              Character'Pos (Name_Buffer (7))) * 2 +
+              Character'Pos (Name_Buffer (6))) * 2 +
+              Character'Pos (Name_Buffer (4))) * 2 +
+              Character'Pos (Name_Buffer (8))) mod Hash_Num;
+
+         when 9 =>
+            return (((((((((
+              Character'Pos (Name_Buffer (2))) * 4 +
+              Character'Pos (Name_Buffer (1))) * 4 +
+              Character'Pos (Name_Buffer (3))) * 4 +
+              Character'Pos (Name_Buffer (4))) * 2 +
+              Character'Pos (Name_Buffer (8))) * 2 +
+              Character'Pos (Name_Buffer (7))) * 2 +
+              Character'Pos (Name_Buffer (5))) * 2 +
+              Character'Pos (Name_Buffer (6))) * 2 +
+              Character'Pos (Name_Buffer (9))) mod Hash_Num;
+
+         when 10 =>
+            return ((((((((((
+              Character'Pos (Name_Buffer (01))) * 2 +
+              Character'Pos (Name_Buffer (02))) * 2 +
+              Character'Pos (Name_Buffer (08))) * 2 +
+              Character'Pos (Name_Buffer (03))) * 2 +
+              Character'Pos (Name_Buffer (04))) * 2 +
+              Character'Pos (Name_Buffer (09))) * 2 +
+              Character'Pos (Name_Buffer (06))) * 2 +
+              Character'Pos (Name_Buffer (05))) * 2 +
+              Character'Pos (Name_Buffer (07))) * 2 +
+              Character'Pos (Name_Buffer (10))) mod Hash_Num;
+
+         when 11 =>
+            return (((((((((((
+              Character'Pos (Name_Buffer (05))) * 2 +
+              Character'Pos (Name_Buffer (01))) * 2 +
+              Character'Pos (Name_Buffer (06))) * 2 +
+              Character'Pos (Name_Buffer (09))) * 2 +
+              Character'Pos (Name_Buffer (07))) * 2 +
+              Character'Pos (Name_Buffer (03))) * 2 +
+              Character'Pos (Name_Buffer (08))) * 2 +
+              Character'Pos (Name_Buffer (02))) * 2 +
+              Character'Pos (Name_Buffer (10))) * 2 +
+              Character'Pos (Name_Buffer (04))) * 2 +
+              Character'Pos (Name_Buffer (11))) mod Hash_Num;
+
+         when 12 =>
+            return ((((((((((((
+              Character'Pos (Name_Buffer (03))) * 2 +
+              Character'Pos (Name_Buffer (02))) * 2 +
+              Character'Pos (Name_Buffer (05))) * 2 +
+              Character'Pos (Name_Buffer (01))) * 2 +
+              Character'Pos (Name_Buffer (06))) * 2 +
+              Character'Pos (Name_Buffer (04))) * 2 +
+              Character'Pos (Name_Buffer (08))) * 2 +
+              Character'Pos (Name_Buffer (11))) * 2 +
+              Character'Pos (Name_Buffer (07))) * 2 +
+              Character'Pos (Name_Buffer (09))) * 2 +
+              Character'Pos (Name_Buffer (10))) * 2 +
+              Character'Pos (Name_Buffer (12))) mod Hash_Num;
+
+      end case;
+   end Hash;
+
+   ----------------
+   -- Initialize --
+   ----------------
+
+   procedure Initialize is
+
+   begin
+      Name_Chars.Init;
+      Name_Entries.Init;
+
+      --  Initialize entries for one character names
+
+      for C in Character loop
+         Name_Entries.Increment_Last;
+         Name_Entries.Table (Name_Entries.Last).Name_Chars_Index :=
+           Name_Chars.Last;
+         Name_Entries.Table (Name_Entries.Last).Name_Len  := 1;
+         Name_Entries.Table (Name_Entries.Last).Hash_Link := No_Name;
+         Name_Entries.Table (Name_Entries.Last).Int_Info  := 0;
+         Name_Entries.Table (Name_Entries.Last).Byte_Info := 0;
+         Name_Chars.Increment_Last;
+         Name_Chars.Table (Name_Chars.Last) := C;
+         Name_Chars.Increment_Last;
+         Name_Chars.Table (Name_Chars.Last) := ASCII.NUL;
+      end loop;
+
+      --  Clear hash table
+
+      for J in Hash_Index_Type loop
+         Hash_Table (J) := No_Name;
+      end loop;
+   end Initialize;
+
+   ----------------------
+   -- Is_Internal_Name --
+   ----------------------
+
+   function Is_Internal_Name (Id : Name_Id) return Boolean is
+   begin
+      Get_Name_String (Id);
+      return Is_Internal_Name;
+   end Is_Internal_Name;
+
+   function Is_Internal_Name return Boolean is
+   begin
+      if Name_Buffer (1) = '_'
+        or else Name_Buffer (Name_Len) = '_'
+      then
+         return True;
+
+      else
+         --  Test backwards, because we only want to test the last entity
+         --  name if the name we have is qualified with other entities.
+
+         for J in reverse 1 .. Name_Len loop
+            if 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;
+         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;
+
+   --------------------
+   -- 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.Increment_Last;
+      Name_Entries.Table (Name_Entries.Last).Name_Chars_Index :=
+        Name_Chars.Last;
+      Name_Entries.Table (Name_Entries.Last).Name_Len  := Short (Name_Len);
+      Name_Entries.Table (Name_Entries.Last).Hash_Link := No_Name;
+      Name_Entries.Table (Name_Entries.Last).Int_Info  := 0;
+      Name_Entries.Table (Name_Entries.Last).Byte_Info := 0;
+
+      --  Set corresponding string entry in the Name_Chars table
+
+      for J in 1 .. Name_Len loop
+         Name_Chars.Increment_Last;
+         Name_Chars.Table (Name_Chars.Last) := Name_Buffer (J);
+      end loop;
+
+      Name_Chars.Increment_Last;
+      Name_Chars.Table (Name_Chars.Last) := 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 I in 1 .. Name_Len loop
+                  if Name_Chars.Table (S + Int (I)) /= Name_Buffer (I) 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.Increment_Last;
+         Name_Entries.Table (Name_Entries.Last).Name_Chars_Index :=
+           Name_Chars.Last;
+         Name_Entries.Table (Name_Entries.Last).Name_Len  := Short (Name_Len);
+         Name_Entries.Table (Name_Entries.Last).Hash_Link := No_Name;
+         Name_Entries.Table (Name_Entries.Last).Int_Info  := 0;
+         Name_Entries.Table (Name_Entries.Last).Byte_Info := 0;
+
+         --  Set corresponding string entry in the Name_Chars table
+
+         for I in 1 .. Name_Len loop
+            Name_Chars.Increment_Last;
+            Name_Chars.Table (Name_Chars.Last) := Name_Buffer (I);
+         end loop;
+
+         Name_Chars.Increment_Last;
+         Name_Chars.Table (Name_Chars.Last) := ASCII.NUL;
+
+         return Name_Entries.Last;
+      end if;
+   end Name_Find;
+
+   ----------------------
+   -- 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_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_Info --
+   -------------------------
+
+   procedure Set_Name_Table_Info (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_Info;
+
+   -----------------------------
+   -- Store_Encoded_Character --
+   -----------------------------
+
+   procedure Store_Encoded_Character (C : Char_Code) is
+
+      procedure Set_Hex_Chars (N : Natural);
+      --  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
+
+      procedure Set_Hex_Chars (N : Natural) is
+         Hexd : constant String := "0123456789abcdef";
+
+      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;
+
+   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 (Natural (C));
+            end if;
+         end;
+
+      else
+         Name_Buffer (Name_Len) := 'W';
+         Set_Hex_Chars (Natural (C) / 256);
+         Set_Hex_Chars (Natural (C) mod 256);
+      end if;
+
+   end Store_Encoded_Character;
+
+   -------------------------------------------------
+   -- Strip_Qualification_And_Package_Body_Suffix --
+   -------------------------------------------------
+
+   procedure Strip_Qualification_And_Package_Body_Suffix is
+   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 __ separator if one exists and strip it
+      --  and everything that precedes it from the name.
+
+      for J in reverse 2 .. Name_Len - 2 loop
+         if Name_Buffer (J) = '_' and then Name_Buffer (J + 1) = '_' then
+            Name_Buffer (1 .. Name_Len - J - 1) :=
+              Name_Buffer (J + 2 .. Name_Len);
+            Name_Len := Name_Len - J - 1;
+            exit;
+         end if;
+      end loop;
+   end Strip_Qualification_And_Package_Body_Suffix;
+
+   ---------------
+   -- 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
+   begin
+      Write_Name (Id);
+      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;
+
+end Namet;