blob: 50dc783322b90a5a162d3172b391eb2f7c5eec51 [file] [log] [blame]
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- N A M E T --
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2022, 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. 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 COPYING3. If not, go to --
-- http://www.gnu.org/licenses for a complete copy of the license. --
-- --
-- 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 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 (Buf : Bounded_String) return Hash_Index_Type;
pragma Inline (Hash);
-- Compute hash code for name stored in Buf
procedure Strip_Qualification_And_Suffixes (Buf : in out Bounded_String);
-- Given an encoded entity name in Buf, remove package body
-- suffix as described for Strip_Package_Body_Suffix, and also remove
-- all qualification, i.e. names followed by two underscores.
-----------------------------
-- Add_Char_To_Name_Buffer --
-----------------------------
procedure Add_Char_To_Name_Buffer (C : Character) is
begin
Append (Global_Name_Buffer, C);
end Add_Char_To_Name_Buffer;
----------------------------
-- Add_Nat_To_Name_Buffer --
----------------------------
procedure Add_Nat_To_Name_Buffer (V : Nat) is
begin
Append (Global_Name_Buffer, V);
end Add_Nat_To_Name_Buffer;
----------------------------
-- Add_Str_To_Name_Buffer --
----------------------------
procedure Add_Str_To_Name_Buffer (S : String) is
begin
Append (Global_Name_Buffer, S);
end Add_Str_To_Name_Buffer;
------------
-- Append --
------------
procedure Append (Buf : in out Bounded_String; C : Character) is
begin
Buf.Length := Buf.Length + 1;
if Buf.Length > Buf.Chars'Last then
Write_Str ("Name buffer overflow; Max_Length = ");
Write_Int (Int (Buf.Max_Length));
Write_Line ("");
raise Program_Error;
end if;
Buf.Chars (Buf.Length) := C;
end Append;
procedure Append (Buf : in out Bounded_String; V : Nat) is
begin
if V >= 10 then
Append (Buf, V / 10);
end if;
Append (Buf, Character'Val (Character'Pos ('0') + V rem 10));
end Append;
procedure Append (Buf : in out Bounded_String; S : String) is
First : constant Natural := Buf.Length + 1;
begin
Buf.Length := Buf.Length + S'Length;
if Buf.Length > Buf.Chars'Last then
Write_Str ("Name buffer overflow; Max_Length = ");
Write_Int (Int (Buf.Max_Length));
Write_Line ("");
raise Program_Error;
end if;
Buf.Chars (First .. Buf.Length) := S;
-- A loop calling Append(Character) would be cleaner, but this slice
-- assignment is substantially faster.
end Append;
procedure Append (Buf : in out Bounded_String; Buf2 : Bounded_String) is
begin
Append (Buf, Buf2.Chars (1 .. Buf2.Length));
end Append;
procedure Append (Buf : in out Bounded_String; Id : Valid_Name_Id) is
pragma Assert (Is_Valid_Name (Id));
Index : constant Int := Name_Entries.Table (Id).Name_Chars_Index;
Len : constant Short := Name_Entries.Table (Id).Name_Len;
Chars : Name_Chars.Table_Type renames
Name_Chars.Table (Index + 1 .. Index + Int (Len));
begin
Append (Buf, String (Chars));
end Append;
--------------------
-- Append_Decoded --
--------------------
procedure Append_Decoded
(Buf : in out Bounded_String;
Id : Valid_Name_Id)
is
Temp : Bounded_String;
function Has_Encodings (Temp : Bounded_String) return Boolean;
-- True if Temp contains encoded characters. If not, we can set
-- Name_Has_No_Encodings to True below, and never call this again
-- on the same Name_Id.
function Has_Encodings (Temp : Bounded_String) return Boolean is
begin
for J in 1 .. Temp.Length loop
if Temp.Chars (J) in 'U' | 'W' | 'Q' | 'O' then
return True;
end if;
end loop;
return False;
end Has_Encodings;
begin
Append (Temp, Id);
-- Skip scan if we already know there are no encodings (i.e. the first
-- time this was called on Id, the Has_Encodings call below returned
-- False).
if Name_Entries.Table (Id).Name_Has_No_Encodings then
goto Done;
end if;
if not Has_Encodings (Temp) then
Name_Entries.Table (Id).Name_Has_No_Encodings := True;
goto Done;
end if;
-- Here we have at least some encoding that we must decode
Decode : declare
New_Len : Natural;
Old : Positive;
New_Buf : String (1 .. Temp.Chars'Last);
procedure Copy_One_Character;
-- Copy a character from Temp.Chars 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 := Temp.Chars (Old);
-- U (upper half insertion case)
if C = 'U'
and then Old < Temp.Length
and then Temp.Chars (Old + 1) not in 'A' .. 'Z' | '_'
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
declare
W2 : constant Word := Hex (2);
begin
pragma Assert (W2 <= 255);
-- Add assumption to facilitate static analysis. Note
-- that we cannot use pragma Assume for bootstrap
-- reasons.
Insert_Character (Character'Val (W2));
end;
end if;
-- WW (wide wide character insertion)
elsif C = 'W'
and then Old < Temp.Length
and then Temp.Chars (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 < Temp.Length
and then Temp.Chars (Old + 1) not in 'A' .. 'Z' | '_'
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 := Temp.Chars (Old);
Old := Old + 1;
pragma Assert (C in '0' .. '9' | '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 <= Temp.Length loop
-- Case of character literal, put apostrophes around character
if Temp.Chars (Old) = 'Q'
and then Old < Temp.Length
then
Old := Old + 1;
Insert_Character (''');
Copy_One_Character;
Insert_Character (''');
-- Case of operator name
elsif Temp.Chars (Old) = 'O'
and then Old < Temp.Length
and then Temp.Chars (Old + 1) not in 'A' .. 'Z' | '_'
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 Temp.Chars (Old) = Map (J)
and then Temp.Chars (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 <= Temp.Length
and then Temp.Chars (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 <= Temp.Length
and then Temp.Chars (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
Temp.Length := New_Len;
Temp.Chars (1 .. New_Len) := New_Buf (1 .. New_Len);
end Decode;
<<Done>>
Append (Buf, Temp);
end Append_Decoded;
----------------------------------
-- Append_Decoded_With_Brackets --
----------------------------------
procedure Append_Decoded_With_Brackets
(Buf : in out Bounded_String;
Id : Valid_Name_Id)
is
P : Natural;
begin
-- Case of operator name, normal decoding is fine
if Buf.Chars (1) = 'O' then
Append_Decoded (Buf, Id);
-- For character literals, normal decoding is fine
elsif Buf.Chars (1) = 'Q' then
Append_Decoded (Buf, Id);
-- Only remaining issue is U/W/WW sequences
else
declare
Temp : Bounded_String;
begin
Append (Temp, Id);
P := 1;
while P < Temp.Length loop
if Temp.Chars (P + 1) in 'A' .. 'Z' then
P := P + 1;
-- Uhh encoding
elsif Temp.Chars (P) = 'U' then
for J in reverse P + 3 .. P + Temp.Length loop
Temp.Chars (J + 3) := Temp.Chars (J);
end loop;
Temp.Length := Temp.Length + 3;
Temp.Chars (P + 3) := Temp.Chars (P + 2);
Temp.Chars (P + 2) := Temp.Chars (P + 1);
Temp.Chars (P) := '[';
Temp.Chars (P + 1) := '"';
Temp.Chars (P + 4) := '"';
Temp.Chars (P + 5) := ']';
P := P + 6;
-- WWhhhhhhhh encoding
elsif Temp.Chars (P) = 'W'
and then P + 9 <= Temp.Length
and then Temp.Chars (P + 1) = 'W'
and then Temp.Chars (P + 2) not in 'A' .. 'Z' | '_'
then
Temp.Chars (P + 12 .. Temp.Length + 2) :=
Temp.Chars (P + 10 .. Temp.Length);
Temp.Chars (P) := '[';
Temp.Chars (P + 1) := '"';
Temp.Chars (P + 10) := '"';
Temp.Chars (P + 11) := ']';
Temp.Length := Temp.Length + 2;
P := P + 12;
-- Whhhh encoding
elsif Temp.Chars (P) = 'W'
and then P < Temp.Length
and then Temp.Chars (P + 1) not in 'A' .. 'Z' | '_'
then
Temp.Chars (P + 8 .. P + Temp.Length + 3) :=
Temp.Chars (P + 5 .. Temp.Length);
Temp.Chars (P + 2 .. P + 5) := Temp.Chars (P + 1 .. P + 4);
Temp.Chars (P) := '[';
Temp.Chars (P + 1) := '"';
Temp.Chars (P + 6) := '"';
Temp.Chars (P + 7) := ']';
Temp.Length := Temp.Length + 3;
P := P + 8;
else
P := P + 1;
end if;
end loop;
Append (Buf, Temp);
end;
end if;
end Append_Decoded_With_Brackets;
--------------------
-- Append_Encoded --
--------------------
procedure Append_Encoded (Buf : in out Bounded_String; 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 Buf.Chars, incrementing Buf.Length.
-------------------
-- Set_Hex_Chars --
-------------------
procedure Set_Hex_Chars (C : Char_Code) is
Hexd : constant String := "0123456789abcdef";
N : constant Natural := Natural (C);
begin
Buf.Chars (Buf.Length + 1) := Hexd (N / 16 + 1);
Buf.Chars (Buf.Length + 2) := Hexd (N mod 16 + 1);
Buf.Length := Buf.Length + 2;
end Set_Hex_Chars;
-- Start of processing for Append_Encoded
begin
Buf.Length := Buf.Length + 1;
if In_Character_Range (C) then
declare
CC : constant Character := Get_Character (C);
begin
if CC in 'a' .. 'z' | '0' .. '9' then
Buf.Chars (Buf.Length) := CC;
else
Buf.Chars (Buf.Length) := 'U';
Set_Hex_Chars (C);
end if;
end;
elsif In_Wide_Character_Range (C) then
Buf.Chars (Buf.Length) := 'W';
Set_Hex_Chars (C / 256);
Set_Hex_Chars (C mod 256);
else
Buf.Chars (Buf.Length) := 'W';
Buf.Length := Buf.Length + 1;
Buf.Chars (Buf.Length) := '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 Append_Encoded;
------------------------
-- Append_Unqualified --
------------------------
procedure Append_Unqualified
(Buf : in out Bounded_String;
Id : Valid_Name_Id)
is
Temp : Bounded_String;
begin
Append (Temp, Id);
Strip_Qualification_And_Suffixes (Temp);
Append (Buf, Temp);
end Append_Unqualified;
--------------------------------
-- Append_Unqualified_Decoded --
--------------------------------
procedure Append_Unqualified_Decoded
(Buf : in out Bounded_String;
Id : Valid_Name_Id)
is
Temp : Bounded_String;
begin
Append_Decoded (Temp, Id);
Strip_Qualification_And_Suffixes (Temp);
Append (Buf, Temp);
end Append_Unqualified_Decoded;
--------------------------------
-- Destroy_Global_Name_Buffer --
--------------------------------
procedure Destroy_Global_Name_Buffer is
procedure Do_It;
-- Do the work. Needed only for "pragma Debug" below, so we don't do
-- anything in production mode.
procedure Do_It is
begin
Global_Name_Buffer.Length := Global_Name_Buffer.Max_Length;
Global_Name_Buffer.Chars := (others => '!');
end Do_It;
pragma Debug (Do_It);
begin
null;
end Destroy_Global_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 : Nat := 0;
-- Maximum length of all chains
Probes : Nat := 0;
-- Used to compute average number of probes
Nsyms : Nat := 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 : Nat;
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 = ");
pragma Assert (Nsyms /= 0);
-- Add assumption to facilitate static analysis. Here Nsyms cannot be
-- zero because many symbols are added to the table by default.
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 : Valid_Name_Id) is
begin
Global_Name_Buffer.Length := 0;
Append_Decoded (Global_Name_Buffer, Id);
end Get_Decoded_Name_String;
-------------------------------------------
-- Get_Decoded_Name_String_With_Brackets --
-------------------------------------------
procedure Get_Decoded_Name_String_With_Brackets (Id : Valid_Name_Id) is
begin
Global_Name_Buffer.Length := 0;
Append_Decoded_With_Brackets (Global_Name_Buffer, Id);
end Get_Decoded_Name_String_With_Brackets;
------------------------
-- Get_Last_Two_Chars --
------------------------
procedure Get_Last_Two_Chars
(N : Valid_Name_Id;
C1 : out Character;
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 Get_Name_String (Id : Valid_Name_Id) is
begin
Global_Name_Buffer.Length := 0;
Append (Global_Name_Buffer, Id);
end Get_Name_String;
function Get_Name_String (Id : Valid_Name_Id) return String is
Buf : Bounded_String (Max_Length => Natural (Length_Of_Name (Id)));
begin
Append (Buf, Id);
return +Buf;
end Get_Name_String;
--------------------------------
-- Get_Name_String_And_Append --
--------------------------------
procedure Get_Name_String_And_Append (Id : Valid_Name_Id) is
begin
Append (Global_Name_Buffer, Id);
end Get_Name_String_And_Append;
-----------------------------
-- Get_Name_Table_Boolean1 --
-----------------------------
function Get_Name_Table_Boolean1 (Id : Valid_Name_Id) return Boolean is
begin
pragma Assert (Is_Valid_Name (Id));
return Name_Entries.Table (Id).Boolean1_Info;
end Get_Name_Table_Boolean1;
-----------------------------
-- Get_Name_Table_Boolean2 --
-----------------------------
function Get_Name_Table_Boolean2 (Id : Valid_Name_Id) return Boolean is
begin
pragma Assert (Is_Valid_Name (Id));
return Name_Entries.Table (Id).Boolean2_Info;
end Get_Name_Table_Boolean2;
-----------------------------
-- Get_Name_Table_Boolean3 --
-----------------------------
function Get_Name_Table_Boolean3 (Id : Valid_Name_Id) return Boolean is
begin
pragma Assert (Is_Valid_Name (Id));
return Name_Entries.Table (Id).Boolean3_Info;
end Get_Name_Table_Boolean3;
-------------------------
-- Get_Name_Table_Byte --
-------------------------
function Get_Name_Table_Byte (Id : Valid_Name_Id) return Byte is
begin
pragma Assert (Is_Valid_Name (Id));
return Name_Entries.Table (Id).Byte_Info;
end Get_Name_Table_Byte;
-------------------------
-- Get_Name_Table_Int --
-------------------------
function Get_Name_Table_Int (Id : Valid_Name_Id) return Int is
begin
pragma Assert (Is_Valid_Name (Id));
return Name_Entries.Table (Id).Int_Info;
end Get_Name_Table_Int;
-----------------------------------------
-- Get_Unqualified_Decoded_Name_String --
-----------------------------------------
procedure Get_Unqualified_Decoded_Name_String (Id : Valid_Name_Id) is
begin
Global_Name_Buffer.Length := 0;
Append_Unqualified_Decoded (Global_Name_Buffer, Id);
end Get_Unqualified_Decoded_Name_String;
---------------------------------
-- Get_Unqualified_Name_String --
---------------------------------
procedure Get_Unqualified_Name_String (Id : Valid_Name_Id) is
begin
Global_Name_Buffer.Length := 0;
Append_Unqualified (Global_Name_Buffer, Id);
end Get_Unqualified_Name_String;
----------
-- Hash --
----------
function Hash (Buf : Bounded_String) 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 .. Buf.Length loop
Result := Rotate_Left (Result, 7) xor Character'Pos (Buf.Chars (J));
end loop;
return Hash_Index_Type (Result);
end Hash;
----------------
-- Initialize --
----------------
procedure Initialize is
begin
null;
end Initialize;
----------------
-- Insert_Str --
----------------
procedure Insert_Str
(Buf : in out Bounded_String;
S : String;
Index : Positive)
is
SL : constant Natural := S'Length;
begin
Buf.Chars (Index + SL .. Buf.Length + SL) :=
Buf.Chars (Index .. Buf.Length);
Buf.Chars (Index .. Index + SL - 1) := S;
Buf.Length := Buf.Length + SL;
end Insert_Str;
-------------------------------
-- Insert_Str_In_Name_Buffer --
-------------------------------
procedure Insert_Str_In_Name_Buffer (S : String; Index : Positive) is
begin
Insert_Str (Global_Name_Buffer, S, Index);
end Insert_Str_In_Name_Buffer;
----------------------
-- Is_Internal_Name --
----------------------
function Is_Internal_Name (Buf : Bounded_String) return Boolean is
J : Natural;
begin
-- Any name starting or ending with underscore is internal
if Buf.Chars (1) = '_' or else Buf.Chars (Buf.Length) = '_' then
return True;
-- Allow quoted character
elsif Buf.Chars (1) = ''' then
return False;
-- All other cases, scan name
else
-- Test backwards, because we only want to test the last entity
-- name if the name we have is qualified with other entities.
J := Buf.Length;
while J /= 0 loop
-- Skip stuff between brackets (A-F OK there)
if Buf.Chars (J) = ']' then
loop
J := J - 1;
exit when J = 1 or else Buf.Chars (J) = '[';
end loop;
-- Test for internal letter
elsif Is_OK_Internal_Letter (Buf.Chars (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 Buf.Chars (1) = '_' above.
elsif Buf.Chars (J) = '_'
and then Buf.Chars (J - 1) = '_'
and then Buf.Chars (J - 2) /= '_'
then
return False;
end if;
J := J - 1;
end loop;
end if;
return False;
end Is_Internal_Name;
function Is_Internal_Name (Id : Valid_Name_Id) return Boolean is
Buf : Bounded_String (Max_Length => Natural (Length_Of_Name (Id)));
begin
Append (Buf, Id);
return Is_Internal_Name (Buf);
end Is_Internal_Name;
function Is_Internal_Name return Boolean is
begin
return Is_Internal_Name (Global_Name_Buffer);
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 not in 'O' | 'Q' | 'U' | 'W' | 'X';
end Is_OK_Internal_Letter;
----------------------
-- Is_Operator_Name --
----------------------
function Is_Operator_Name (Id : Valid_Name_Id) return Boolean is
S : Int;
begin
pragma Assert (Is_Valid_Name (Id));
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;
------------------
-- Last_Name_Id --
------------------
function Last_Name_Id return Name_Id is
begin
return Name_Id (Int (First_Name_Id) + Name_Entries_Count - 1);
end Last_Name_Id;
--------------------
-- Length_Of_Name --
--------------------
function Length_Of_Name (Id : Valid_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.Release;
Name_Chars.Locked := True;
Name_Entries.Release;
Name_Entries.Locked := True;
end Lock;
----------------
-- Name_Enter --
----------------
function Name_Enter
(Buf : Bounded_String := Global_Name_Buffer) return Valid_Name_Id
is
begin
Name_Entries.Append
((Name_Chars_Index => Name_Chars.Last,
Name_Len => Short (Buf.Length),
Byte_Info => 0,
Int_Info => 0,
Hash_Link => No_Name,
Name_Has_No_Encodings => False,
Boolean1_Info => False,
Boolean2_Info => False,
Boolean3_Info => False,
Spare => False));
-- Set corresponding string entry in the Name_Chars table
for J in 1 .. Buf.Length loop
Name_Chars.Append (Buf.Chars (J));
end loop;
Name_Chars.Append (ASCII.NUL);
return Name_Entries.Last;
end Name_Enter;
function Name_Enter (S : String) return Valid_Name_Id is
Buf : Bounded_String (Max_Length => S'Length);
begin
Append (Buf, S);
return Name_Enter (Buf);
end Name_Enter;
------------------------
-- 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
(Buf : Bounded_String := Global_Name_Buffer) return Valid_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
Result : Valid_Name_Id;
begin
-- Quick handling for one character names
if Buf.Length = 1 then
Result := First_Name_Id + Character'Pos (Buf.Chars (1));
-- Otherwise search hash table for existing matching entry
else
Hash_Index := Namet.Hash (Buf);
New_Id := Hash_Table (Hash_Index);
if New_Id = No_Name then
Hash_Table (Hash_Index) := Name_Entries.Last + 1;
else
Search : loop
if Buf.Length /=
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 .. Buf.Length loop
if Name_Chars.Table (S + Int (J)) /= Buf.Chars (J) then
goto No_Match;
end if;
end loop;
Result := New_Id;
goto Done;
-- 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 (Buf.Length),
Hash_Link => No_Name,
Int_Info => 0,
Byte_Info => 0,
Name_Has_No_Encodings => False,
Boolean1_Info => False,
Boolean2_Info => False,
Boolean3_Info => False,
Spare => False));
-- Set corresponding string entry in the Name_Chars table
for J in 1 .. Buf.Length loop
Name_Chars.Append (Buf.Chars (J));
end loop;
Name_Chars.Append (ASCII.NUL);
Result := Name_Entries.Last;
end if;
<<Done>>
return Result;
end Name_Find;
function Name_Find (S : String) return Valid_Name_Id is
Buf : Bounded_String (Max_Length => S'Length);
begin
Append (Buf, S);
return Name_Find (Buf);
end Name_Find;
-----------------
-- Name_Equals --
-----------------
function Name_Equals
(N1 : Valid_Name_Id;
N2 : Valid_Name_Id) return Boolean
is
begin
return N1 = N2 or else Get_Name_String (N1) = Get_Name_String (N2);
end Name_Equals;
-------------
-- Present --
-------------
function Present (Nam : File_Name_Type) return Boolean is
begin
return Nam /= No_File;
end Present;
-------------
-- Present --
-------------
function Present (Nam : Name_Id) return Boolean is
begin
return Nam /= No_Name;
end Present;
-------------
-- Present --
-------------
function Present (Nam : Unit_Name_Type) return Boolean is
begin
return Nam /= No_Unit_Name;
end Present;
------------------
-- 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,
Hash_Link => No_Name,
Name_Has_No_Encodings => True,
Boolean1_Info => False,
Boolean2_Info => False,
Boolean3_Info => False,
Spare => False));
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
(Buf : in out Bounded_String;
C : Char_Code)
is
begin
Buf.Length := 0;
Append (Buf, 'Q');
Append_Encoded (Buf, C);
end Set_Character_Literal_Name;
procedure Set_Character_Literal_Name (C : Char_Code) is
begin
Set_Character_Literal_Name (Global_Name_Buffer, C);
end Set_Character_Literal_Name;
-----------------------------
-- Set_Name_Table_Boolean1 --
-----------------------------
procedure Set_Name_Table_Boolean1 (Id : Valid_Name_Id; Val : Boolean) is
begin
pragma Assert (Is_Valid_Name (Id));
Name_Entries.Table (Id).Boolean1_Info := Val;
end Set_Name_Table_Boolean1;
-----------------------------
-- Set_Name_Table_Boolean2 --
-----------------------------
procedure Set_Name_Table_Boolean2 (Id : Valid_Name_Id; Val : Boolean) is
begin
pragma Assert (Is_Valid_Name (Id));
Name_Entries.Table (Id).Boolean2_Info := Val;
end Set_Name_Table_Boolean2;
-----------------------------
-- Set_Name_Table_Boolean3 --
-----------------------------
procedure Set_Name_Table_Boolean3 (Id : Valid_Name_Id; Val : Boolean) is
begin
pragma Assert (Is_Valid_Name (Id));
Name_Entries.Table (Id).Boolean3_Info := Val;
end Set_Name_Table_Boolean3;
-------------------------
-- Set_Name_Table_Byte --
-------------------------
procedure Set_Name_Table_Byte (Id : Valid_Name_Id; Val : Byte) is
begin
pragma Assert (Is_Valid_Name (Id));
Name_Entries.Table (Id).Byte_Info := Val;
end Set_Name_Table_Byte;
-------------------------
-- Set_Name_Table_Int --
-------------------------
procedure Set_Name_Table_Int (Id : Valid_Name_Id; Val : Int) is
begin
pragma Assert (Is_Valid_Name (Id));
Name_Entries.Table (Id).Int_Info := Val;
end Set_Name_Table_Int;
-----------------------------
-- Store_Encoded_Character --
-----------------------------
procedure Store_Encoded_Character (C : Char_Code) is
begin
Append_Encoded (Global_Name_Buffer, C);
end Store_Encoded_Character;
--------------------------------------
-- Strip_Qualification_And_Suffixes --
--------------------------------------
procedure Strip_Qualification_And_Suffixes (Buf : in out Bounded_String) is
J : Integer;
begin
-- Strip package body qualification string off end
for J in reverse 2 .. Buf.Length loop
if Buf.Chars (J) = 'X' then
Buf.Length := J - 1;
exit;
end if;
exit when Buf.Chars (J) not in 'b' | 'n' | '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 Buf.Chars (Buf.Length) = ''' then
J := Buf.Length - 2;
while J > 0 and then Buf.Chars (J) /= ''' loop
J := J - 1;
end loop;
else
J := Buf.Length - 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 Buf.Chars (J) = '$' then
Buf.Length := J - 1;
J := Buf.Length - 1;
-- Else check for __ found
elsif Buf.Chars (J) = '_' and then Buf.Chars (J + 1) = '_' then
-- Found __ so see if digit follows, and if so, this is a
-- homonym separator, so strip it and keep looking.
if Buf.Chars (J + 2) in '0' .. '9' then
Buf.Length := J - 1;
J := Buf.Length - 1;
-- If not a homonym separator, then we simply strip the
-- separator and everything that precedes it, and we are done
else
Buf.Chars (1 .. Buf.Length - J - 1) :=
Buf.Chars (J + 2 .. Buf.Length);
Buf.Length := Buf.Length - J - 1;
exit;
end if;
else
J := J - 1;
end if;
end loop;
end Strip_Qualification_And_Suffixes;
---------------
-- To_String --
---------------
function To_String (Buf : Bounded_String) return String is
begin
return Buf.Chars (1 .. Buf.Length);
end To_String;
------------
-- Unlock --
------------
procedure Unlock is
begin
Name_Chars.Locked := False;
Name_Chars.Set_Last (Name_Chars.Last - Name_Chars_Reserve);
Name_Chars.Release;
Name_Entries.Locked := False;
Name_Entries.Set_Last (Name_Entries.Last - Name_Entries_Reserve);
Name_Entries.Release;
end Unlock;
--------
-- wn --
--------
procedure wn (Id : Name_Id) is
begin
Write_Name_For_Debug (Id);
Write_Eol;
end wn;
----------------
-- Write_Name --
----------------
procedure Write_Name (Id : Valid_Name_Id) is
Buf : Bounded_String (Max_Length => Natural (Length_Of_Name (Id)));
begin
Append (Buf, Id);
Write_Str (Buf.Chars (1 .. Buf.Length));
end Write_Name;
------------------------
-- Write_Name_Decoded --
------------------------
procedure Write_Name_Decoded (Id : Valid_Name_Id) is
Buf : Bounded_String;
begin
Append_Decoded (Buf, Id);
Write_Str (Buf.Chars (1 .. Buf.Length));
end Write_Name_Decoded;
--------------------------
-- Write_Name_For_Debug --
--------------------------
procedure Write_Name_For_Debug (Id : Name_Id; Quote : String := "") is
begin
if Is_Valid_Name (Id) then
Write_Str (Quote);
declare
Buf : Bounded_String (Max_Length => Natural (Length_Of_Name (Id)));
begin
Append (Buf, Id);
Write_Str (Buf.Chars (1 .. Buf.Length));
end;
Write_Str (Quote);
elsif Id = No_Name then
Write_Str ("<No_Name>");
elsif Id = Error_Name then
Write_Str ("<Error_Name>");
else
Write_Str ("<invalid name ");
Write_Int (Int (Id));
Write_Str (">");
end if;
end Write_Name_For_Debug;
-- Package initialization, initialize tables
begin
Reinitialize;
end Namet;