with Atree; use Atree;
with Einfo; use Einfo;
with Errout; use Errout;
with Namet; use Namet;
with Nlists; use Nlists;
with Sinfo; use Sinfo;
with Snames; use Snames;
with Stand; use Stand;
with Stringt; use Stringt;
with Uintp; use Uintp;
with GNAT.HTable; use GNAT.HTable;
package body Sem_Elim is
No_Elimination : Boolean;
type Elim_Data;
type Access_Elim_Data is access Elim_Data;
type Names is array (Nat range <>) of Name_Id;
type Access_Names is access Names;
type Elim_Data is record
Unit_Name : Access_Names;
Entity_Name : Name_Id;
Entity_Scope : Access_Names;
Entity_Node : Node_Id;
Parameter_Types : Access_Names;
Result_Type : Name_Id;
Homonym_Number : Uint;
Hash_Link : Access_Elim_Data;
Homonym : Access_Elim_Data;
end record;
subtype Element is Elim_Data;
subtype Elmt_Ptr is Access_Elim_Data;
subtype Key is Name_Id;
type Header_Num is range 0 .. 1023;
Null_Ptr : constant Elmt_Ptr := null;
package Hash_Subprograms is
function Equal (F1, F2 : Key) return Boolean;
pragma Inline (Equal);
function Get_Key (E : Elmt_Ptr) return Key;
pragma Inline (Get_Key);
function Hash (F : Key) return Header_Num;
pragma Inline (Hash);
function Next (E : Elmt_Ptr) return Elmt_Ptr;
pragma Inline (Next);
procedure Set_Next (E : Elmt_Ptr; Next : Elmt_Ptr);
pragma Inline (Set_Next);
end Hash_Subprograms;
package body Hash_Subprograms is
function Equal (F1, F2 : Key) return Boolean is
begin
return F1 = F2;
end Equal;
function Get_Key (E : Elmt_Ptr) return Key is
begin
return E.Entity_Name;
end Get_Key;
function Hash (F : Key) return Header_Num is
begin
return Header_Num (Int (F) mod 1024);
end Hash;
function Next (E : Elmt_Ptr) return Elmt_Ptr is
begin
return E.Hash_Link;
end Next;
procedure Set_Next (E : Elmt_Ptr; Next : Elmt_Ptr) is
begin
E.Hash_Link := Next;
end Set_Next;
end Hash_Subprograms;
package Elim_Hash_Table is new Static_HTable (
Header_Num => Header_Num,
Element => Element,
Elmt_Ptr => Elmt_Ptr,
Null_Ptr => Null_Ptr,
Set_Next => Hash_Subprograms.Set_Next,
Next => Hash_Subprograms.Next,
Key => Key,
Get_Key => Hash_Subprograms.Get_Key,
Hash => Hash_Subprograms.Hash,
Equal => Hash_Subprograms.Equal);
procedure Check_Eliminated (E : Entity_Id) is
Elmt : Access_Elim_Data;
Scop : Entity_Id;
Form : Entity_Id;
Ctr : Nat;
Ent : Entity_Id;
begin
if No_Elimination then
return;
elsif Ekind (E) not in Subprogram_Kind then
return;
end if;
Elmt := Elim_Hash_Table.Get (Chars (E));
while Elmt /= null loop
if Elmt.Entity_Name /= Chars (E) then
goto Continue;
end if;
Scop := Scope (E);
if Elmt.Entity_Scope /= null then
for J in reverse Elmt.Entity_Scope'Range loop
if Elmt.Entity_Scope (J) /= Chars (Scop) then
goto Continue;
end if;
Scop := Scope (Scop);
if not Is_Compilation_Unit (Scop) and then J = 1 then
goto Continue;
end if;
end loop;
end if;
for J in reverse Elmt.Unit_Name'Range loop
if Elmt.Unit_Name (J) /= Chars (Scop) then
goto Continue;
end if;
Scop := Scope (Scop);
if Scop /= Standard_Standard and then J = 1 then
goto Continue;
end if;
end loop;
if Scop /= Standard_Standard then
goto Continue;
end if;
if Is_Compilation_Unit (E)
and then Is_Subprogram (E)
and then No (Elmt.Entity_Node)
then
Set_Is_Eliminated (E);
return;
elsif (Is_Type (E) or else Is_Object (E))
and then Elmt.Result_Type = No_Name
and then Elmt.Parameter_Types = null
then
Set_Is_Eliminated (E);
return;
elsif Ekind (E) = E_Function
or else Ekind (E) = E_Procedure
then
if Elmt.Homonym_Number /= No_Uint then
Ctr := 1;
Ent := E;
while Present (Homonym (Ent))
and then Scope (Ent) = Scope (Homonym (Ent))
loop
Ctr := Ctr + 1;
Ent := Homonym (Ent);
end loop;
if Ctr /= Elmt.Homonym_Number then
goto Continue;
end if;
end if;
if Elmt.Result_Type /= No_Name then
if Ekind (E) /= E_Function
or else Chars (Etype (E)) /= Elmt.Result_Type
then
goto Continue;
end if;
end if;
if Elmt.Parameter_Types /= null then
Form := First_Formal (E);
if No (Form) and then Elmt.Parameter_Types = null then
null;
elsif Elmt.Parameter_Types = null then
goto Continue;
else
for J in Elmt.Parameter_Types'Range loop
if No (Form)
or else Chars (Etype (Form)) /= Elmt.Parameter_Types (J)
then
goto Continue;
else
Next_Formal (Form);
end if;
end loop;
if Present (Form) then
goto Continue;
end if;
end if;
end if;
Set_Is_Eliminated (E);
return;
end if;
<<Continue>> Elmt := Elmt.Homonym;
end loop;
return;
end Check_Eliminated;
procedure Initialize is
begin
Elim_Hash_Table.Reset;
No_Elimination := True;
end Initialize;
procedure Process_Eliminate_Pragma
(Arg_Unit_Name : Node_Id;
Arg_Entity : Node_Id;
Arg_Parameter_Types : Node_Id;
Arg_Result_Type : Node_Id;
Arg_Homonym_Number : Node_Id)
is
Data : constant Access_Elim_Data := new Elim_Data;
Elmt : Access_Elim_Data;
Num_Names : Nat := 0;
Lit : Node_Id;
Arg_Ent : Entity_Id;
Arg_Uname : Node_Id;
function OK_Selected_Component (N : Node_Id) return Boolean;
function OK_Selected_Component (N : Node_Id) return Boolean is
begin
if Nkind (N) = N_Identifier
or else Nkind (N) = N_Operator_Symbol
then
Num_Names := Num_Names + 1;
return True;
elsif Nkind (N) = N_Selected_Component then
return OK_Selected_Component (Prefix (N))
and then OK_Selected_Component (Selector_Name (N));
else
return False;
end if;
end OK_Selected_Component;
begin
Error_Msg_Name_1 := Name_Eliminate;
if Nkind (Arg_Unit_Name) = N_Identifier then
Data.Unit_Name := new Names'(1 => Chars (Arg_Unit_Name));
Num_Names := 1;
elsif OK_Selected_Component (Arg_Unit_Name) then
Data.Unit_Name := new Names (1 .. Num_Names);
Arg_Uname := Arg_Unit_Name;
for J in reverse 2 .. Num_Names loop
Data.Unit_Name (J) := Chars (Selector_Name (Arg_Uname));
Arg_Uname := Prefix (Arg_Uname);
end loop;
Data.Unit_Name (1) := Chars (Arg_Uname);
else
Error_Msg_N
("wrong form for Unit_Name parameter of pragma%", Arg_Unit_Name);
return;
end if;
if Present (Arg_Entity) then
Num_Names := 0;
if Nkind (Arg_Entity) = N_Identifier
or else Nkind (Arg_Entity) = N_Operator_Symbol
then
Data.Entity_Name := Chars (Arg_Entity);
Data.Entity_Node := Arg_Entity;
Data.Entity_Scope := null;
elsif OK_Selected_Component (Arg_Entity) then
Data.Entity_Scope := new Names (1 .. Num_Names - 1);
Data.Entity_Name := Chars (Selector_Name (Arg_Entity));
Data.Entity_Node := Arg_Entity;
Arg_Ent := Prefix (Arg_Entity);
for J in reverse 2 .. Num_Names - 1 loop
Data.Entity_Scope (J) := Chars (Selector_Name (Arg_Ent));
Arg_Ent := Prefix (Arg_Ent);
end loop;
Data.Entity_Scope (1) := Chars (Arg_Ent);
elsif Nkind (Arg_Entity) = N_String_Literal then
String_To_Name_Buffer (Strval (Arg_Entity));
Data.Entity_Name := Name_Find;
Data.Entity_Node := Arg_Entity;
else
Error_Msg_N
("wrong form for Entity_Argument parameter of pragma%",
Arg_Unit_Name);
return;
end if;
else
Data.Entity_Node := Empty;
Data.Entity_Name := Data.Unit_Name (Num_Names);
end if;
if Present (Arg_Parameter_Types) then
if Nkind (Arg_Parameter_Types) = N_String_Literal
and then Paren_Count (Arg_Parameter_Types) = 1
then
String_To_Name_Buffer (Strval (Arg_Parameter_Types));
Data.Parameter_Types := new Names'(1 => Name_Find);
elsif Nkind (Arg_Parameter_Types) /= N_Aggregate
or else Present (Component_Associations (Arg_Parameter_Types))
or else No (Expressions (Arg_Parameter_Types))
then
Error_Msg_N
("Parameter_Types for pragma% must be list of string literals",
Arg_Parameter_Types);
return;
else
Data.Parameter_Types :=
new Names
(1 .. List_Length (Expressions (Arg_Parameter_Types)));
Lit := First (Expressions (Arg_Parameter_Types));
for J in Data.Parameter_Types'Range loop
if Nkind (Lit) /= N_String_Literal then
Error_Msg_N
("parameter types for pragma% must be string literals",
Lit);
return;
end if;
String_To_Name_Buffer (Strval (Lit));
Data.Parameter_Types (J) := Name_Find;
Next (Lit);
end loop;
end if;
end if;
if Present (Arg_Result_Type) then
if Nkind (Arg_Result_Type) /= N_String_Literal then
Error_Msg_N
("Result_Type argument for pragma% must be string literal",
Arg_Result_Type);
return;
end if;
String_To_Name_Buffer (Strval (Arg_Result_Type));
Data.Result_Type := Name_Find;
else
Data.Result_Type := No_Name;
end if;
if Present (Arg_Homonym_Number) then
if Nkind (Arg_Homonym_Number) /= N_Integer_Literal then
Error_Msg_N
("Homonym_Number argument for pragma% must be integer literal",
Arg_Homonym_Number);
return;
end if;
Data.Homonym_Number := Intval (Arg_Homonym_Number);
else
Data.Homonym_Number := No_Uint;
end if;
Elmt := Elim_Hash_Table.Get (Hash_Subprograms.Get_Key (Data));
if Elmt /= null then
Data.Homonym := Elmt.Homonym;
Elmt.Homonym := Data;
else
Elim_Hash_Table.Set (Data);
end if;
No_Elimination := False;
end Process_Eliminate_Pragma;
end Sem_Elim;