with Debug; use Debug;
with Opt; use Opt;
with Output; use Output;
with Tree_IO; use Tree_IO;
with Widechar; use Widechar;
package body Namet is
Name_Chars_Reserve : constant := 5000;
Name_Entries_Reserve : constant := 100;
Hash_Num : constant Int := 2**12;
Hash_Max : constant Int := Hash_Num - 1;
subtype Hash_Index_Type is Int range 0 .. Hash_Max;
Hash_Table : array (Hash_Index_Type) of Name_Id;
function Hash return Hash_Index_Type;
pragma Inline (Hash);
procedure Strip_Qualification_And_Suffixes;
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;
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;
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;
procedure Finalize is
Max_Chain_Length : constant := 50;
F : array (Int range 0 .. Max_Chain_Length) of Int;
Probes : Int := 0;
Nsyms : Int := 0;
begin
if Debug_Flag_H then
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
Write_Str ("Hash_Table (");
Write_Int (J);
Write_Str (") has ");
declare
C : Int := 1;
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;
Write_Int (C);
Write_Str (" entries");
Write_Eol;
if C < Max_Chain_Length then
F (C) := F (C) + 1;
else
F (Max_Chain_Length) := F (Max_Chain_Length) + 1;
end if;
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;
end if;
end loop;
Write_Eol;
for J in Int range 0 .. Max_Chain_Length 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 = Max_Chain_Length then
Write_Str (" or greater");
end if;
Write_Str (" = ");
Write_Int (F (J));
Write_Eol;
if J /= 0 then
Nsyms := Nsyms + F (J);
Probes := Probes + F (J) * (1 + J) * 100;
end if;
end if;
end loop;
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 (48 + Probes / 10));
Write_Char (Character'Val (48 + Probes mod 10));
Write_Eol;
Write_Eol;
end if;
end Finalize;
procedure Get_Decoded_Name_String (Id : Name_Id) is
C : Character;
P : Natural;
begin
Get_Name_String (Id);
P := 1;
loop
if P = Name_Len then
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;
Decode : declare
New_Len : Natural;
Old : Positive;
New_Buf : String (1 .. Name_Buffer'Last);
procedure Copy_One_Character;
function Hex (N : Natural) return Word;
procedure Insert_Character (C : Character);
procedure Copy_One_Character is
C : Character;
begin
C := Name_Buffer (Old);
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 Upper_Half_Encoding then
Widechar.Set_Wide (Char_Code (Hex (2)), New_Buf, New_Len);
else
Insert_Character (Character'Val (Hex (2)));
end if;
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);
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);
else
Insert_Character (C);
Old := Old + 1;
end if;
end Copy_One_Character;
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 T := 16 * T + Character'Pos (C) - (Character'Pos ('a') - 10);
end if;
end loop;
return T;
end Hex;
procedure Insert_Character (C : Character) is
begin
New_Len := New_Len + 1;
New_Buf (New_Len) := C;
end Insert_Character;
begin
New_Len := 0;
Old := 1;
while Old <= Name_Len loop
if Name_Buffer (Old) = 'Q'
and then Old < Name_Len
then
Old := Old + 1;
Insert_Character (''');
Copy_One_Character;
Insert_Character (''');
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
Map : constant String :=
"ab " & "ad+ " & "an " & "co& " & "di/ " & "eq= " & "ex**" & "gt> " & "ge>=" & "le<=" & "lt< " & "mo " & "mu* " & "ne/=" & "no " & "or " & "re " & "su- " & "xo ";
J : Integer;
begin
Insert_Character ('"');
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;
if Map (J + 2) /= ' ' then
Insert_Character (Map (J + 2));
if Map (J + 3) /= ' ' then
Insert_Character (Map (J + 3));
end if;
Insert_Character ('"');
while Old <= Name_Len
and then Name_Buffer (Old) in 'a' .. 'z'
loop
Old := Old + 1;
end loop;
else
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;
end if;
end loop;
Name_Len := New_Len;
Name_Buffer (1 .. New_Len) := New_Buf (1 .. New_Len);
end Decode;
end Get_Decoded_Name_String;
procedure Get_Decoded_Name_String_With_Brackets (Id : Name_Id) is
P : Natural;
begin
if Name_Buffer (1) = 'O' then
Get_Decoded_Name_String (Id);
elsif Name_Buffer (1) = 'Q' then
Get_Decoded_Name_String (Id);
else
Get_Name_String (Id);
P := 1;
while P < Name_Len loop
if Name_Buffer (P + 1) in 'A' .. 'Z' then
P := P + 1;
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;
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;
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;
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;
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;
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;
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;
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;
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;
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;
procedure Get_Unqualified_Name_String (Id : Name_Id) is
begin
Get_Name_String (Id);
Strip_Qualification_And_Suffixes;
end Get_Unqualified_Name_String;
function Hash return Hash_Index_Type is
begin
case Name_Len is
when 0 =>
return 0;
when 1 =>
return
Character'Pos (Name_Buffer (1));
when 2 =>
return ((
Character'Pos (Name_Buffer (1))) * 64 +
Character'Pos (Name_Buffer (2))) mod Hash_Num;
when 3 =>
return (((
Character'Pos (Name_Buffer (1))) * 16 +
Character'Pos (Name_Buffer (3))) * 16 +
Character'Pos (Name_Buffer (2))) mod Hash_Num;
when 4 =>
return ((((
Character'Pos (Name_Buffer (1))) * 8 +
Character'Pos (Name_Buffer (2))) * 8 +
Character'Pos (Name_Buffer (3))) * 8 +
Character'Pos (Name_Buffer (4))) mod Hash_Num;
when 5 =>
return (((((
Character'Pos (Name_Buffer (4))) * 8 +
Character'Pos (Name_Buffer (1))) * 4 +
Character'Pos (Name_Buffer (3))) * 4 +
Character'Pos (Name_Buffer (5))) * 8 +
Character'Pos (Name_Buffer (2))) mod Hash_Num;
when 6 =>
return ((((((
Character'Pos (Name_Buffer (5))) * 4 +
Character'Pos (Name_Buffer (1))) * 4 +
Character'Pos (Name_Buffer (4))) * 4 +
Character'Pos (Name_Buffer (2))) * 4 +
Character'Pos (Name_Buffer (6))) * 4 +
Character'Pos (Name_Buffer (3))) mod Hash_Num;
when 7 =>
return (((((((
Character'Pos (Name_Buffer (4))) * 4 +
Character'Pos (Name_Buffer (3))) * 4 +
Character'Pos (Name_Buffer (1))) * 4 +
Character'Pos (Name_Buffer (2))) * 2 +
Character'Pos (Name_Buffer (5))) * 2 +
Character'Pos (Name_Buffer (7))) * 2 +
Character'Pos (Name_Buffer (6))) mod Hash_Num;
when 8 =>
return ((((((((
Character'Pos (Name_Buffer (2))) * 4 +
Character'Pos (Name_Buffer (1))) * 4 +
Character'Pos (Name_Buffer (3))) * 2 +
Character'Pos (Name_Buffer (5))) * 2 +
Character'Pos (Name_Buffer (7))) * 2 +
Character'Pos (Name_Buffer (6))) * 2 +
Character'Pos (Name_Buffer (4))) * 2 +
Character'Pos (Name_Buffer (8))) mod Hash_Num;
when 9 =>
return (((((((((
Character'Pos (Name_Buffer (2))) * 4 +
Character'Pos (Name_Buffer (1))) * 4 +
Character'Pos (Name_Buffer (3))) * 4 +
Character'Pos (Name_Buffer (4))) * 2 +
Character'Pos (Name_Buffer (8))) * 2 +
Character'Pos (Name_Buffer (7))) * 2 +
Character'Pos (Name_Buffer (5))) * 2 +
Character'Pos (Name_Buffer (6))) * 2 +
Character'Pos (Name_Buffer (9))) mod Hash_Num;
when 10 =>
return ((((((((((
Character'Pos (Name_Buffer (01))) * 2 +
Character'Pos (Name_Buffer (02))) * 2 +
Character'Pos (Name_Buffer (08))) * 2 +
Character'Pos (Name_Buffer (03))) * 2 +
Character'Pos (Name_Buffer (04))) * 2 +
Character'Pos (Name_Buffer (09))) * 2 +
Character'Pos (Name_Buffer (06))) * 2 +
Character'Pos (Name_Buffer (05))) * 2 +
Character'Pos (Name_Buffer (07))) * 2 +
Character'Pos (Name_Buffer (10))) mod Hash_Num;
when 11 =>
return (((((((((((
Character'Pos (Name_Buffer (05))) * 2 +
Character'Pos (Name_Buffer (01))) * 2 +
Character'Pos (Name_Buffer (06))) * 2 +
Character'Pos (Name_Buffer (09))) * 2 +
Character'Pos (Name_Buffer (07))) * 2 +
Character'Pos (Name_Buffer (03))) * 2 +
Character'Pos (Name_Buffer (08))) * 2 +
Character'Pos (Name_Buffer (02))) * 2 +
Character'Pos (Name_Buffer (10))) * 2 +
Character'Pos (Name_Buffer (04))) * 2 +
Character'Pos (Name_Buffer (11))) mod Hash_Num;
when 12 =>
return ((((((((((((
Character'Pos (Name_Buffer (03))) * 2 +
Character'Pos (Name_Buffer (02))) * 2 +
Character'Pos (Name_Buffer (05))) * 2 +
Character'Pos (Name_Buffer (01))) * 2 +
Character'Pos (Name_Buffer (06))) * 2 +
Character'Pos (Name_Buffer (04))) * 2 +
Character'Pos (Name_Buffer (08))) * 2 +
Character'Pos (Name_Buffer (11))) * 2 +
Character'Pos (Name_Buffer (07))) * 2 +
Character'Pos (Name_Buffer (09))) * 2 +
Character'Pos (Name_Buffer (10))) * 2 +
Character'Pos (Name_Buffer (12))) mod Hash_Num;
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;
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;
end loop;
for J in Hash_Index_Type loop
Hash_Table (J) := No_Name;
end loop;
end Initialize;
function Is_Internal_Name (Id : Name_Id) return Boolean is
begin
Get_Name_String (Id);
return Is_Internal_Name;
end Is_Internal_Name;
function Is_Internal_Name return Boolean is
begin
if Name_Buffer (1) = '_'
or else Name_Buffer (Name_Len) = '_'
then
return True;
else
for J in reverse 1 .. Name_Len loop
if Is_OK_Internal_Letter (Name_Buffer (J)) then
return True;
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;
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;
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;
function Length_Of_Name (Id : Name_Id) return Nat is
begin
return Int (Name_Entries.Table (Id).Name_Len);
end Length_Of_Name;
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;
function Name_Chars_Address return System.Address is
begin
return Name_Chars.Table (0)'Address;
end Name_Chars_Address;
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;
for J in 1 .. Name_Len loop
Name_Chars.Increment_Last;
Name_Chars.Table (Name_Chars.Last) := Name_Buffer (J);
end loop;
Name_Chars.Increment_Last;
Name_Chars.Table (Name_Chars.Last) := ASCII.NUL;
return Name_Entries.Last;
end Name_Enter;
function Name_Entries_Address return System.Address is
begin
return Name_Entries.Table (First_Name_Id)'Address;
end Name_Entries_Address;
function Name_Entries_Count return Nat is
begin
return Int (Name_Entries.Last - Name_Entries.First + 1);
end Name_Entries_Count;
function Name_Find return Name_Id is
New_Id : Name_Id;
S : Int;
Hash_Index : Hash_Index_Type;
begin
if Name_Len = 1 then
return Name_Id (First_Name_Id + Character'Pos (Name_Buffer (1)));
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;
<<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;
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;
for J in 1 .. Name_Len loop
Name_Chars.Increment_Last;
Name_Chars.Table (Name_Chars.Last) := Name_Buffer (J);
end loop;
Name_Chars.Increment_Last;
Name_Chars.Table (Name_Chars.Last) := ASCII.NUL;
return Name_Entries.Last;
end if;
end Name_Find;
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;
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;
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;
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;
procedure Store_Encoded_Character (C : Char_Code) is
procedure Set_Hex_Chars (C : Char_Code);
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;
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;
procedure Strip_Qualification_And_Suffixes is
J : Integer;
begin
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;
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;
while J > 1 loop
if Name_Buffer (J) = '$' then
Name_Len := J - 1;
J := Name_Len - 1;
elsif Name_Buffer (J) = '_' and then Name_Buffer (J + 1) = '_' then
if Name_Buffer (J + 2) in '0' .. '9' then
Name_Len := J - 1;
J := Name_Len - 1;
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;
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;
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;
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;
procedure wn (Id : Name_Id) is
begin
Write_Name (Id);
Write_Eol;
end wn;
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;
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;
end Namet;