aboutsummaryrefslogtreecommitdiffstats
path: root/gcc-4.8.3/gcc/ada/namet.adb
diff options
context:
space:
mode:
Diffstat (limited to 'gcc-4.8.3/gcc/ada/namet.adb')
-rw-r--r--gcc-4.8.3/gcc/ada/namet.adb1343
1 files changed, 1343 insertions, 0 deletions
diff --git a/gcc-4.8.3/gcc/ada/namet.adb b/gcc-4.8.3/gcc/ada/namet.adb
new file mode 100644
index 000000000..2842dfd4e
--- /dev/null
+++ b/gcc-4.8.3/gcc/ada/namet.adb
@@ -0,0 +1,1343 @@
+------------------------------------------------------------------------------
+-- --
+-- GNAT COMPILER COMPONENTS --
+-- --
+-- N A M E T --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 1992-2010, 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, 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_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_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
+ Get_Name_String (Id);
+ return Is_Internal_Name;
+ end Is_Internal_Name;
+
+ ----------------------
+ -- Is_Internal_Name --
+ ----------------------
+
+ -- Version taking its input from Name_Buffer
+
+ 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;
+
+ ----------------------
+ -- 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,
+ 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));
+
+ -- 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;
+
+ ------------------
+ -- 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,
+ 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_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 (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;