-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2003 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2005 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- --
-- 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. --
+-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
+-- Boston, MA 02110-1301, 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, --
-- 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;
end loop;
end Add_Str_To_Name_Buffer;
-
--------------
-- Finalize --
--------------
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
+ for J in Hash_Index_Type loop
+ if Hash_Table (J) = No_Name then
F (0) := F (0) + 1;
else
Write_Str ("Hash_Table (");
- Write_Int (Int (I));
+ Write_Int (Int (J));
Write_Str (") has ");
declare
begin
C := 0;
- N := Hash_Table (I);
+ N := Hash_Table (J);
while N /= No_Name loop
N := Name_Entries.Table (N).Hash_Link;
F (Max_Chain_Length) := F (Max_Chain_Length) + 1;
end if;
- N := Hash_Table (I);
+ N := Hash_Table (J);
while N /= No_Name loop
S := Name_Entries.Table (N).Name_Chars_Index;
Write_Eol;
- for I in Int range 0 .. Max_Chain_Length loop
- if F (I) /= 0 then
+ for J in Int range 0 .. Max_Chain_Length loop
+ if F (J) /= 0 then
Write_Str ("Number of hash chains of length ");
- if I < 10 then
+ if J < 10 then
Write_Char (' ');
end if;
- Write_Int (I);
+ Write_Int (J);
- if I = Max_Chain_Length then
+ if J = Max_Chain_Length then
Write_Str (" or greater");
end if;
Write_Str (" = ");
- Write_Int (F (I));
+ Write_Int (F (J));
Write_Eol;
- if I /= 0 then
- Nsyms := Nsyms + F (I);
- Probes := Probes + F (I) * (1 + I) * 100;
+ if J /= 0 then
+ Nsyms := Nsyms + F (J);
+ Probes := Probes + F (J) * (1 + J) * 100;
end if;
end if;
end loop;
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.
+ -- of copying a Uhh,Whhhh,WWhhhhhhhh sequence and decoding it.
- function Hex (N : Natural) return Natural;
+ function Hex (N : Natural) return Word;
-- Scans past N digits using Old pointer and returns hex value
procedure Insert_Character (C : Character);
and then Name_Buffer (Old + 1) /= '_'
then
Old := Old + 1;
- Insert_Character (Character'Val (Hex (2)));
+
+ -- 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)
-- Hex --
---------
- function Hex (N : Natural) return Natural is
- T : Natural := 0;
+ function Hex (N : Natural) return Word is
+ T : Word := 0;
C : Character;
begin
elsif Name_Buffer (1) = 'Q' then
Get_Decoded_Name_String (Id);
- -- Only remaining issue is U/W sequences
+ -- Only remaining issue is U/W/WW sequences
else
Get_Name_String (Id);
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);
Name_Buffer (P + 5) := ']';
P := P + 6;
- elsif Name_Buffer (P) = 'W' then
- Name_Buffer (P + 8 .. P + Name_Len + 5) :=
+ -- 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 + 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 + 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 + 5;
+ Name_Len := Name_Len + 3;
P := P + 8;
else
-- Get_Name_String --
---------------------
+ -- Procedure version leaving result in Name_Buffer, length in Name_Len
+
procedure Get_Name_String (Id : Name_Id) is
S : Int;
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;
----------
function Hash return Hash_Index_Type is
- subtype Int_0_12 is Int range 0 .. 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_0_12 (Name_Len) is
+ case Name_Len is
when 0 =>
return 0;
Character'Pos (Name_Buffer (10))) * 2 +
Character'Pos (Name_Buffer (12))) mod Hash_Num;
+ -- Names longer than 12 characters are handled by taking the first
+ -- 6 odd numbered characters and the last 6 even numbered characters.
+
+ when others => declare
+ Even_Name_Len : constant Integer := (Name_Len) / 2 * 2;
+ begin
+ 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;
end case;
end Hash;
----------------
procedure Initialize is
-
begin
Name_Chars.Init;
Name_Entries.Init;
-- 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) = '_'
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;
+
--------------------
-- Length_Of_Name --
--------------------
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
+ 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;
-- Set corresponding string entry in the Name_Chars table
- for I in 1 .. Name_Len loop
+ for J in 1 .. Name_Len loop
Name_Chars.Increment_Last;
- Name_Chars.Table (Name_Chars.Last) := Name_Buffer (I);
+ Name_Chars.Table (Name_Chars.Last) := Name_Buffer (J);
end loop;
Name_Chars.Increment_Last;
procedure Store_Encoded_Character (C : Char_Code) is
- procedure Set_Hex_Chars (N : Natural);
+ 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
+ -- digits (using lower case a-f) in Name_Buffer, incrementing Name_Len.
- procedure Set_Hex_Chars (N : Natural) is
- Hexd : constant String := "0123456789abcdef";
+ -------------------
+ -- 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 (Natural (C));
+ 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';
- Set_Hex_Chars (Natural (C) / 256);
- Set_Hex_Chars (Natural (C) mod 256);
+ 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;
--------------------------------------
OSDN Git Service
