with Atree; use Atree;
with Einfo; use Einfo;
with Errout; use Errout;
with Namet; use Namet;
with Nlists; use Nlists;
with Sem_Prag; use Sem_Prag;
with Sinput; use Sinput;
with Sinfo; use Sinfo;
with Snames; use Snames;
with Stand; use Stand;
with Stringt; use Stringt;
with Table;
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;
Source_Location : Name_Id;
Hash_Link : Access_Elim_Data;
Homonym : Access_Elim_Data;
Prag : Node_Id;
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);
type Elim_Entity_Entry is record
Prag : Node_Id;
Subp : Entity_Id;
end record;
package Elim_Entities is new Table.Table (
Table_Component_Type => Elim_Entity_Entry,
Table_Index_Type => Name_Id,
Table_Low_Bound => First_Name_Id,
Table_Initial => 50,
Table_Increment => 200,
Table_Name => "Elim_Entries");
procedure Check_Eliminated (E : Entity_Id) is
Elmt : Access_Elim_Data;
Scop : Entity_Id;
Form : Entity_Id;
function Original_Chars (S : Entity_Id) return Name_Id;
function Original_Chars (S : Entity_Id) return Name_Id is
begin
if Ekind (S) /= E_Protected_Type
or else Comes_From_Source (S)
then
return Chars (S);
else
return Chars (Defining_Identifier (Original_Node (Parent (S))));
end if;
end Original_Chars;
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
declare
procedure Set_Eliminated;
procedure Set_Eliminated is
begin
Set_Is_Eliminated (E);
Elim_Entities.Append ((Prag => Elmt.Prag, Subp => E));
end Set_Eliminated;
begin
if Elmt.Entity_Name /= Chars (E) then
goto Continue;
end if;
Scop := Scope (E);
while Ekind (Scop) = E_Block loop
Scop := Scope (Scop);
end loop;
if Elmt.Entity_Scope /= null then
for J in reverse Elmt.Entity_Scope'Range loop
if Elmt.Entity_Scope (J) /= Original_Chars (Scop) then
goto Continue;
end if;
Scop := Scope (Scop);
while Ekind (Scop) = E_Block loop
Scop := Scope (Scop);
end loop;
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);
while Ekind (Scop) = E_Block loop
Scop := Scope (Scop);
end loop;
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_Eliminated;
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_Eliminated;
return;
elsif Ekind (E) = E_Function
or else Ekind (E) = E_Procedure
then
if Elmt.Source_Location /= No_Name then
Get_Name_String (Elmt.Source_Location);
declare
Sloc_Trace : constant String :=
Name_Buffer (1 .. Name_Len);
Idx : Natural := Sloc_Trace'First;
Last : constant Natural := Sloc_Trace'Last;
P : Source_Ptr;
Sindex : Source_File_Index;
function File_Name_Match return Boolean;
function Line_Num_Match return Boolean;
function Different_Trace_Lengths return Boolean;
function Skip_Spaces return Natural;
function Different_Trace_Lengths return Boolean is
begin
P := Instantiation (Sindex);
if (P = No_Location and then Idx /= 0)
or else
(P /= No_Location and then Idx = 0)
then
return True;
else
if P /= No_Location then
Sindex := Get_Source_File_Index (P);
Get_Name_String (File_Name (Sindex));
end if;
return False;
end if;
end Different_Trace_Lengths;
function File_Name_Match return Boolean is
Tmp_Idx : Natural;
End_Idx : Natural;
begin
if Idx = 0 then
return False;
end if;
Tmp_Idx := Idx - 1;
loop
if Tmp_Idx >= Last then
return False;
elsif Sloc_Trace (Tmp_Idx + 1) = ':' then
exit;
else
Tmp_Idx := Tmp_Idx + 1;
end if;
end loop;
End_Idx := Tmp_Idx;
loop
if End_Idx < Idx then
return False;
elsif Sloc_Trace (End_Idx) /= ' ' then
exit;
else
End_Idx := End_Idx - 1;
end if;
end loop;
if Sloc_Trace (Idx .. End_Idx) =
Name_Buffer (1 .. Name_Len)
then
Idx := Tmp_Idx + 2;
Idx := Skip_Spaces;
return True;
else
return False;
end if;
end File_Name_Match;
function Line_Num_Match return Boolean is
N : Int := 0;
begin
if Idx = 0 then
return False;
end if;
while Idx <= Last
and then Sloc_Trace (Idx) in '0' .. '9'
loop
N := N * 10 +
(Character'Pos (Sloc_Trace (Idx)) -
Character'Pos ('0'));
Idx := Idx + 1;
end loop;
if Get_Physical_Line_Number (P) =
Physical_Line_Number (N)
then
while Idx <= Last and then
Sloc_Trace (Idx) /= '['
loop
Idx := Idx + 1;
end loop;
if Idx <= Last and then
Sloc_Trace (Idx) = '['
then
Idx := Idx + 1;
Idx := Skip_Spaces;
else
Idx := 0;
end if;
return True;
else
return False;
end if;
end Line_Num_Match;
function Skip_Spaces return Natural is
Res : Natural := Idx;
begin
while Sloc_Trace (Res) = ' ' loop
Res := Res + 1;
if Res > Last then
Res := 0;
exit;
end if;
end loop;
return Res;
end Skip_Spaces;
begin
P := Sloc (E);
Sindex := Get_Source_File_Index (P);
Get_Name_String (File_Name (Sindex));
Idx := Skip_Spaces;
while Idx > 0 loop
if not File_Name_Match then
goto Continue;
elsif not Line_Num_Match then
goto Continue;
end if;
if Different_Trace_Lengths then
goto Continue;
end if;
end loop;
end;
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'Length = 1
and then Elmt.Parameter_Types (1) = No_Name
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_Eliminated;
return;
end if;
end;
<<Continue>>
Elmt := Elmt.Homonym;
end loop;
return;
end Check_Eliminated;
procedure Eliminate_Error_Msg (N : Node_Id; E : Entity_Id) is
begin
for J in Elim_Entities.First .. Elim_Entities.Last loop
if E = Elim_Entities.Table (J).Subp then
Error_Msg_Sloc := Sloc (Elim_Entities.Table (J).Prag);
Error_Msg_NE ("cannot call subprogram & eliminated #", N, E);
return;
end if;
end loop;
raise Program_Error;
end Eliminate_Error_Msg;
procedure Initialize is
begin
Elim_Hash_Table.Reset;
Elim_Entities.Init;
No_Elimination := True;
end Initialize;
procedure Process_Eliminate_Pragma
(Pragma_Node : Node_Id;
Arg_Unit_Name : Node_Id;
Arg_Entity : Node_Id;
Arg_Parameter_Types : Node_Id;
Arg_Result_Type : Node_Id;
Arg_Source_Location : 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
Data.Prag := Pragma_Node;
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 Is_Config_Static_String (Arg_Entity) then
Data.Entity_Name := Name_Find;
Data.Entity_Node := Arg_Entity;
else
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_Aggregate then
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 Is_Config_Static_String (Lit) then
Data.Parameter_Types (J) := Name_Find;
Next (Lit);
else
return;
end if;
end loop;
elsif Paren_Count (Arg_Parameter_Types) /= 1 then
Error_Msg_N
("wrong form for argument of pragma Eliminate",
Arg_Parameter_Types);
return;
elsif Is_Config_Static_String (Arg_Parameter_Types) then
String_To_Name_Buffer (Strval (Arg_Parameter_Types));
if Name_Len = 0 then
Data.Parameter_Types := new Names'(1 => No_Name);
else
Data.Parameter_Types := new Names'(1 => Name_Find);
end if;
else
return;
end if;
end if;
if Present (Arg_Result_Type) then
if Is_Config_Static_String (Arg_Result_Type) then
Data.Result_Type := Name_Find;
else
return;
end if;
else
Data.Result_Type := No_Name;
end if;
if Present (Arg_Source_Location) then
if Is_Config_Static_String (Arg_Source_Location) then
Data.Source_Location := Name_Find;
else
return;
end if;
else
Data.Source_Location := No_Name;
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;