------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- N A M E T --
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2013, 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 --
-- . --
-- --
-- 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
<>
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;
-------------
-- Nam_In --
-------------
function Nam_In
(T : Name_Id;
V1 : Name_Id;
V2 : Name_Id) return Boolean
is
begin
return T = V1 or else
T = V2;
end Nam_In;
function Nam_In
(T : Name_Id;
V1 : Name_Id;
V2 : Name_Id;
V3 : Name_Id) return Boolean
is
begin
return T = V1 or else
T = V2 or else
T = V3;
end Nam_In;
function Nam_In
(T : Name_Id;
V1 : Name_Id;
V2 : Name_Id;
V3 : Name_Id;
V4 : Name_Id) return Boolean
is
begin
return T = V1 or else
T = V2 or else
T = V3 or else
T = V4;
end Nam_In;
function Nam_In
(T : Name_Id;
V1 : Name_Id;
V2 : Name_Id;
V3 : Name_Id;
V4 : Name_Id;
V5 : Name_Id) return Boolean
is
begin
return T = V1 or else
T = V2 or else
T = V3 or else
T = V4 or else
T = V5;
end Nam_In;
function Nam_In
(T : Name_Id;
V1 : Name_Id;
V2 : Name_Id;
V3 : Name_Id;
V4 : Name_Id;
V5 : Name_Id;
V6 : Name_Id) return Boolean
is
begin
return T = V1 or else
T = V2 or else
T = V3 or else
T = V4 or else
T = V5 or else
T = V6;
end Nam_In;
function Nam_In
(T : Name_Id;
V1 : Name_Id;
V2 : Name_Id;
V3 : Name_Id;
V4 : Name_Id;
V5 : Name_Id;
V6 : Name_Id;
V7 : Name_Id) return Boolean
is
begin
return T = V1 or else
T = V2 or else
T = V3 or else
T = V4 or else
T = V5 or else
T = V6 or else
T = V7;
end Nam_In;
------------------
-- 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 ("");
elsif Id = No_Name then
Write_Str ("");
elsif Id = Error_Name then
Write_Str ("");
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;