-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2004 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2009, 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- --
+-- 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. 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. --
+-- or FITNESS FOR A PARTICULAR PURPOSE. --
-- --
--- 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. --
+-- 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 a-namet.h
+-- 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;
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.
+ -- 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
end loop;
end Add_Str_To_Name_Buffer;
-
--------------
-- Finalize --
--------------
else
Write_Str ("Hash_Table (");
- Write_Int (Int (J));
+ Write_Int (J);
Write_Str (") has ");
declare
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
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
-- 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.
+ -- error may be raised.
J := Map'First;
loop
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
-- 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;
+ 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
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 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;
+ 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.Increment_Last;
- Name_Chars.Table (Name_Chars.Last) := Name_Buffer (J);
+ Name_Chars.Append (Name_Buffer (J));
end loop;
- Name_Chars.Increment_Last;
- Name_Chars.Table (Name_Chars.Last) := ASCII.NUL;
+ Name_Chars.Append (ASCII.NUL);
return Name_Entries.Last;
end Name_Enter;
Name_Entries.Last + 1;
exit Search;
end if;
-
end loop Search;
end if;
-- 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;
+ 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.Increment_Last;
- Name_Chars.Table (Name_Chars.Last) := Name_Buffer (J);
+ Name_Chars.Append (Name_Buffer (J));
end loop;
- Name_Chars.Increment_Last;
- Name_Chars.Table (Name_Chars.Last) := ASCII.NUL;
+ Name_Chars.Append (ASCII.NUL);
return Name_Entries.Last;
end if;
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;
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;
--------------------------------------
--------
procedure wn (Id : Name_Id) is
+ S : Int;
+
begin
- Write_Name (Id);
+ 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;
OSDN Git Service
