-- --
-- B o d y --
-- --
--- $Revision: 1.86 $
--- --
--- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2006, 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, --
-- 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). --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
-- 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;
pragma Inline (Hash);
-- Compute hash code for name stored in Name_Buffer (length in Name_Len)
- procedure Strip_Qualification_And_Package_Body_Suffix;
+ 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
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;
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
-- Here we have at least some encoding that we must decode
- -- Here we have to decode one or more Uhh or Whhhh sequences
-
- declare
+ Decode : 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.
+ -- 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);
+ -- Insert a new character into output decoded name
+
+ ------------------------
+ -- Copy_One_Character --
+ ------------------------
+
procedure Copy_One_Character is
C : Character;
begin
C := Name_Buffer (Old);
- if C = 'U' then
+ -- 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;
- Insert_Character (Character'Val (Hex (2)));
- elsif C = 'W' then
+ -- 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 (Name_Buffer (Old));
+ Insert_Character (C);
Old := Old + 1;
end if;
end Copy_One_Character;
- function Hex (N : Natural) return Natural is
- T : Natural := 0;
+ ---------
+ -- Hex --
+ ---------
+
+ function Hex (N : Natural) return Word is
+ T : Word := 0;
C : Character;
begin
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;
- -- Actual decoding processing
+ -- Start of processing for Decode
begin
New_Len := 0;
-- Case of character literal, put apostrophes around character
- if Name_Buffer (Old) = 'Q' then
+ if Name_Buffer (Old) = 'Q'
+ and then Old < Name_Len
+ then
Old := Old + 1;
Insert_Character (''');
Copy_One_Character;
-- Case of operator name
- elsif Name_Buffer (Old) = 'O' then
+ 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
Name_Len := New_Len;
Name_Buffer (1 .. New_Len) := New_Buf (1 .. New_Len);
- end;
-
+ end Decode;
end Get_Decoded_Name_String;
-------------------------------------------
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);
P := 1;
while P < Name_Len loop
- if Name_Buffer (P) = 'U' then
+ 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_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
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;
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;
procedure Get_Unqualified_Decoded_Name_String (Id : Name_Id) is
begin
Get_Decoded_Name_String (Id);
- Strip_Qualification_And_Package_Body_Suffix;
+ Strip_Qualification_And_Suffixes;
end Get_Unqualified_Decoded_Name_String;
---------------------------------
procedure Get_Unqualified_Name_String (Id : Name_Id) is
begin
Get_Name_String (Id);
- Strip_Qualification_And_Package_Body_Suffix;
+ Strip_Qualification_And_Suffixes;
end Get_Unqualified_Name_String;
----------
----------
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
+ case Name_Len is
+
+ when 0 =>
+ return 0;
when 1 =>
return
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;
-- 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
-- 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;
+
+ -------------------
+ -- 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;
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;
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 I in 1 .. Name_Len loop
- Name_Chars.Increment_Last;
- Name_Chars.Table (Name_Chars.Last) := Name_Buffer (I);
+ for J in 1 .. Name_Len loop
+ 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;
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;
- -------------------------------------------------
- -- Strip_Qualification_And_Package_Body_Suffix --
- -------------------------------------------------
+ --------------------------------------
+ -- Strip_Qualification_And_Suffixes --
+ --------------------------------------
+
+ procedure Strip_Qualification_And_Suffixes is
+ J : Integer;
- procedure Strip_Qualification_And_Package_Body_Suffix is
begin
-- Strip package body qualification string off end
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.
+ -- 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
- 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;
+ 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_Package_Body_Suffix;
+ end Strip_Qualification_And_Suffixes;
---------------
-- Tree_Read --
--------
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
