with Atree; use Atree;
with Casing; use Casing;
with Einfo; use Einfo;
with Errout; use Errout;
with Exp_Dist; use Exp_Dist;
with Exp_Tss; use Exp_Tss;
with Nlists; use Nlists;
with Nmake; use Nmake;
with Namet; use Namet;
with Opt; use Opt;
with Rtsfind; use Rtsfind;
with Sem; use Sem;
with Sem_Res; use Sem_Res;
with Sem_Util; use Sem_Util;
with Sinfo; use Sinfo;
with Snames; use Snames;
with Stand; use Stand;
with Stringt; use Stringt;
with Tbuild; use Tbuild;
package body Sem_Dist is
procedure RAS_E_Dereference (Pref : Node_Id);
function Full_Qualified_Name (E : Entity_Id) return String_Id;
procedure Add_Stub_Constructs (N : Node_Id) is
U : constant Node_Id := Unit (N);
Spec : Entity_Id := Empty;
Exp : Node_Id := U;
begin
pragma Assert (Distribution_Stub_Mode /= No_Stubs);
if Nkind (U) = N_Package_Declaration then
Spec := Defining_Entity (Specification (U));
elsif Nkind (U) = N_Package_Body then
Spec := Corresponding_Spec (U);
else pragma Assert (Nkind (U) = N_Package_Instantiation);
Exp := Instance_Spec (U);
Spec := Defining_Entity (Specification (Exp));
end if;
pragma Assert (Is_Shared_Passive (Spec)
or else Is_Remote_Call_Interface (Spec));
if Distribution_Stub_Mode = Generate_Caller_Stub_Body then
if Is_Shared_Passive (Spec) then
null;
elsif Nkind (U) = N_Package_Body then
Error_Msg_N
("Specification file expected from command line", U);
else
Expand_Calling_Stubs_Bodies (Exp);
end if;
else
if Is_Shared_Passive (Spec) then
Build_Passive_Partition_Stub (Exp);
else
Expand_Receiving_Stubs_Bodies (Exp);
end if;
end if;
end Add_Stub_Constructs;
function Build_RAS_Primitive_Specification
(Subp_Spec : Node_Id;
Remote_Object_Type : Node_Id) return Node_Id
is
Loc : constant Source_Ptr := Sloc (Subp_Spec);
Primitive_Spec : constant Node_Id :=
Copy_Specification (Loc,
Spec => Subp_Spec,
New_Name => Name_Call);
Subtype_Mark_For_Self : Node_Id;
begin
if No (Parameter_Specifications (Primitive_Spec)) then
Set_Parameter_Specifications (Primitive_Spec, New_List);
end if;
if Nkind (Remote_Object_Type) in N_Entity then
Subtype_Mark_For_Self :=
New_Occurrence_Of (Remote_Object_Type, Loc);
else
Subtype_Mark_For_Self := Remote_Object_Type;
end if;
Prepend_To (
Parameter_Specifications (Primitive_Spec),
Make_Parameter_Specification (Loc,
Defining_Identifier =>
Make_Defining_Identifier (Loc, Name_uS),
Parameter_Type =>
Make_Access_Definition (Loc,
Subtype_Mark =>
Subtype_Mark_For_Self)));
Set_Comes_From_Source (
Defining_Unit_Name (Primitive_Spec), True);
return Primitive_Spec;
end Build_RAS_Primitive_Specification;
function Full_Qualified_Name (E : Entity_Id) return String_Id is
Ent : Entity_Id := E;
Parent_Name : String_Id := No_String;
begin
if Nkind (Ent) = N_Defining_Program_Unit_Name then
Ent := Defining_Identifier (Ent);
end if;
if Present (Scope (Scope (Ent))) then
Parent_Name := Full_Qualified_Name (Scope (Ent));
end if;
if Chars (Ent) = No_Name then
return Parent_Name;
end if;
if Parent_Name /= No_String then
Start_String (Parent_Name);
Store_String_Char (Get_Char_Code ('.'));
else
Start_String;
end if;
Get_Name_String (Chars (Ent));
Set_Casing (All_Lower_Case);
Store_String_Chars (Name_Buffer (1 .. Name_Len));
return End_String;
end Full_Qualified_Name;
function Is_All_Remote_Call (N : Node_Id) return Boolean is
Par : Node_Id;
begin
if (Nkind (N) = N_Function_Call
or else Nkind (N) = N_Procedure_Call_Statement)
and then Nkind (Name (N)) in N_Has_Entity
and then Is_Remote_Call_Interface (Entity (Name (N)))
and then Has_All_Calls_Remote (Scope (Entity (Name (N))))
and then Comes_From_Source (N)
then
Par := Parent (Entity (Name (N)));
while Present (Par)
and then (Nkind (Par) /= N_Package_Specification
or else Is_Wrapper_Package (Defining_Entity (Par)))
loop
Par := Parent (Par);
end loop;
if Present (Par) then
return
not Scope_Within_Or_Same (Current_Scope, Defining_Entity (Par));
else
return False;
end if;
else
return False;
end if;
end Is_All_Remote_Call;
function Package_Specification_Of_Scope (E : Entity_Id) return Node_Id is
N : Node_Id := Parent (E);
begin
while Nkind (N) /= N_Package_Specification loop
N := Parent (N);
end loop;
return N;
end Package_Specification_Of_Scope;
procedure Process_Partition_Id (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
Ety : Entity_Id;
Get_Pt_Id : Node_Id;
Get_Pt_Id_Call : Node_Id;
Prefix_String : String_Id;
Typ : constant Entity_Id := Etype (N);
begin
Ety := Entity (Prefix (N));
while (Present (Scope (Ety))
and then Scope (Ety) /= Standard_Standard)
and not Is_Child_Unit (Ety)
loop
Ety := Scope (Ety);
end loop;
if Is_Remote_Call_Interface (Ety) then
Get_Pt_Id := New_Occurrence_Of
(RTE (RE_Get_Active_Partition_Id), Loc);
elsif Is_Shared_Passive (Ety) then
Get_Pt_Id := New_Occurrence_Of
(RTE (RE_Get_Passive_Partition_Id), Loc);
else
Get_Pt_Id := New_Occurrence_Of
(RTE (RE_Get_Local_Partition_Id), Loc);
end if;
Get_Library_Unit_Name_String (Unit_Declaration_Node (Ety));
Prefix_String := String_From_Name_Buffer;
if Is_Remote_Call_Interface (Ety)
or else Is_Shared_Passive (Ety)
then
Get_Pt_Id_Call :=
Make_Function_Call (Loc,
Name => Get_Pt_Id,
Parameter_Associations =>
New_List (Make_String_Literal (Loc, Prefix_String)));
else
Get_Pt_Id_Call := Make_Function_Call (Loc, Get_Pt_Id);
end if;
Rewrite (N, Convert_To (Typ, Get_Pt_Id_Call));
Analyze_And_Resolve (N, Typ);
end Process_Partition_Id;
procedure Process_Remote_AST_Attribute
(N : Node_Id;
New_Type : Entity_Id)
is
Loc : constant Source_Ptr := Sloc (N);
Remote_Subp : Entity_Id;
Tick_Access_Conv_Call : Node_Id;
Remote_Subp_Decl : Node_Id;
RS_Pkg_Specif : Node_Id;
RS_Pkg_E : Entity_Id;
RAS_Type : Entity_Id := New_Type;
Async_E : Entity_Id;
All_Calls_Remote_E : Entity_Id;
Attribute_Subp : Entity_Id;
begin
Remote_Subp := Entity (Prefix (N));
if not Expander_Active then
return;
end if;
if Ekind (RAS_Type) /= E_Record_Type then
RAS_Type := Equivalent_Type (RAS_Type);
end if;
Attribute_Subp := TSS (RAS_Type, TSS_RAS_Access);
pragma Assert (Present (Attribute_Subp));
Remote_Subp_Decl := Unit_Declaration_Node (Remote_Subp);
if Nkind (Remote_Subp_Decl) = N_Subprogram_Body then
Remote_Subp := Corresponding_Spec (Remote_Subp_Decl);
Remote_Subp_Decl := Unit_Declaration_Node (Remote_Subp);
end if;
RS_Pkg_Specif := Parent (Remote_Subp_Decl);
RS_Pkg_E := Defining_Entity (RS_Pkg_Specif);
Async_E :=
Boolean_Literals (Ekind (Remote_Subp) = E_Procedure
and then Is_Asynchronous (Remote_Subp));
All_Calls_Remote_E :=
Boolean_Literals (Has_All_Calls_Remote (RS_Pkg_E));
Tick_Access_Conv_Call :=
Make_Function_Call (Loc,
Name => New_Occurrence_Of (Attribute_Subp, Loc),
Parameter_Associations =>
New_List (
Make_String_Literal (Loc, Full_Qualified_Name (RS_Pkg_E)),
Build_Subprogram_Id (Loc, Remote_Subp),
New_Occurrence_Of (Async_E, Loc),
New_Occurrence_Of (All_Calls_Remote_E, Loc)));
Rewrite (N, Tick_Access_Conv_Call);
Analyze_And_Resolve (N, RAS_Type);
end Process_Remote_AST_Attribute;
procedure Process_Remote_AST_Declaration (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
User_Type : constant Node_Id := Defining_Identifier (N);
Scop : constant Entity_Id := Scope (User_Type);
Is_RCI : constant Boolean :=
Is_Remote_Call_Interface (Scop);
Is_RT : constant Boolean :=
Is_Remote_Types (Scop);
Type_Def : constant Node_Id := Type_Definition (N);
Parameter : Node_Id;
Is_Degenerate : Boolean;
Subpkg : constant Entity_Id :=
Make_Defining_Identifier
(Loc, New_Internal_Name ('S'));
Subpkg_Decl : Node_Id;
Vis_Decls : constant List_Id := New_List;
Priv_Decls : constant List_Id := New_List;
Obj_Type : constant Entity_Id :=
Make_Defining_Identifier
(Loc, New_External_Name (
Chars (User_Type), 'R'));
Full_Obj_Type : constant Entity_Id :=
Make_Defining_Identifier
(Loc, Chars (Obj_Type));
RACW_Type : constant Entity_Id :=
Make_Defining_Identifier
(Loc, New_External_Name (
Chars (User_Type), 'P'));
Fat_Type : constant Entity_Id :=
Make_Defining_Identifier
(Loc, Chars (User_Type));
Fat_Type_Decl : Node_Id;
begin
Append_To (Vis_Decls,
Make_Private_Type_Declaration (Loc,
Defining_Identifier => Obj_Type,
Abstract_Present => True,
Tagged_Present => True,
Limited_Present => True));
Append_To (Priv_Decls,
Make_Full_Type_Declaration (Loc,
Defining_Identifier =>
Full_Obj_Type,
Type_Definition =>
Make_Record_Definition (Loc,
Abstract_Present => True,
Tagged_Present => True,
Limited_Present => True,
Null_Present => True,
Component_List => Empty)));
Is_Degenerate := False;
Parameter := First (Parameter_Specifications (Type_Def));
Parameters : while Present (Parameter) loop
if Nkind (Parameter_Type (Parameter)) = N_Access_Definition then
Error_Msg_N ("formal parameter& has anonymous access type?",
Defining_Identifier (Parameter));
Is_Degenerate := True;
exit Parameters;
end if;
Next (Parameter);
end loop Parameters;
if Is_Degenerate then
Error_Msg_NE (
"remote access-to-subprogram type& can only be null?",
Defining_Identifier (Parameter), User_Type);
else
Append_To (Vis_Decls,
Make_Abstract_Subprogram_Declaration (Loc,
Specification => Build_RAS_Primitive_Specification (
Subp_Spec => Type_Def,
Remote_Object_Type => Obj_Type)));
end if;
Append_To (Vis_Decls,
Make_Full_Type_Declaration (Loc,
Defining_Identifier => RACW_Type,
Type_Definition =>
Make_Access_To_Object_Definition (Loc,
All_Present => True,
Subtype_Indication =>
Make_Attribute_Reference (Loc,
Prefix =>
New_Occurrence_Of (Obj_Type, Loc),
Attribute_Name =>
Name_Class))));
Set_Is_Remote_Call_Interface (RACW_Type, Is_RCI);
Set_Is_Remote_Types (RACW_Type, Is_RT);
Subpkg_Decl :=
Make_Package_Declaration (Loc,
Make_Package_Specification (Loc,
Defining_Unit_Name =>
Subpkg,
Visible_Declarations =>
Vis_Decls,
Private_Declarations =>
Priv_Decls,
End_Label =>
New_Occurrence_Of (Subpkg, Loc)));
Set_Is_Remote_Call_Interface (Subpkg, Is_RCI);
Set_Is_Remote_Types (Subpkg, Is_RT);
Insert_After_And_Analyze (N, Subpkg_Decl);
Fat_Type_Decl := Make_Full_Type_Declaration (Loc,
Defining_Identifier => Fat_Type,
Type_Definition =>
Make_Record_Definition (Loc,
Component_List =>
Make_Component_List (Loc,
Component_Items => New_List (
Make_Component_Declaration (Loc,
Defining_Identifier =>
Make_Defining_Identifier (Loc, Name_Ras),
Component_Definition =>
Make_Component_Definition (Loc,
Aliased_Present =>
False,
Subtype_Indication =>
New_Occurrence_Of (RACW_Type, Loc)))))));
Set_Equivalent_Type (User_Type, Fat_Type);
Set_Corresponding_Remote_Type (Fat_Type, User_Type);
Insert_After_And_Analyze (Subpkg_Decl, Fat_Type_Decl);
Set_Suppress_Init_Proc (Fat_Type);
if Expander_Active then
Add_RAST_Features (Parent (User_Type));
end if;
end Process_Remote_AST_Declaration;
procedure RAS_E_Dereference (Pref : Node_Id) is
Loc : constant Source_Ptr := Sloc (Pref);
Call_Node : Node_Id;
New_Type : constant Entity_Id := Etype (Pref);
Explicit_Deref : constant Node_Id := Parent (Pref);
Deref_Subp_Call : constant Node_Id := Parent (Explicit_Deref);
Deref_Proc : Entity_Id;
Params : List_Id;
begin
if Nkind (Deref_Subp_Call) = N_Procedure_Call_Statement then
Params := Parameter_Associations (Deref_Subp_Call);
if Present (Params) then
Prepend (Pref, Params);
else
Params := New_List (Pref);
end if;
elsif Nkind (Deref_Subp_Call) = N_Indexed_Component then
Params := Expressions (Deref_Subp_Call);
if Present (Params) then
Prepend (Pref, Params);
else
Params := New_List (Pref);
end if;
else
return;
end if;
if not Expander_Active then
return;
end if;
Deref_Proc := TSS (New_Type, TSS_RAS_Dereference);
pragma Assert (Present (Deref_Proc));
if Ekind (Deref_Proc) = E_Function then
Call_Node :=
Make_Function_Call (Loc,
Name => New_Occurrence_Of (Deref_Proc, Loc),
Parameter_Associations => Params);
else
Call_Node :=
Make_Procedure_Call_Statement (Loc,
Name => New_Occurrence_Of (Deref_Proc, Loc),
Parameter_Associations => Params);
end if;
Rewrite (Deref_Subp_Call, Call_Node);
Analyze (Deref_Subp_Call);
end RAS_E_Dereference;
function Remote_AST_E_Dereference (P : Node_Id) return Boolean is
ET : constant Entity_Id := Etype (P);
begin
if Comes_From_Source (P)
and then Is_Record_Type (ET)
and then (Is_Remote_Call_Interface (ET)
or else Is_Remote_Types (ET))
and then Present (Corresponding_Remote_Type (ET))
and then (Nkind (Parent (Parent (P))) = N_Procedure_Call_Statement
or else Nkind (Parent (Parent (P))) = N_Indexed_Component)
and then Expander_Active
then
RAS_E_Dereference (P);
return True;
else
return False;
end if;
end Remote_AST_E_Dereference;
function Remote_AST_I_Dereference (P : Node_Id) return Boolean is
ET : constant Entity_Id := Etype (P);
Deref : Node_Id;
begin
if Comes_From_Source (P)
and then (Is_Remote_Call_Interface (ET)
or else Is_Remote_Types (ET))
and then Present (Corresponding_Remote_Type (ET))
and then Ekind (Entity (P)) /= E_Function
then
Deref :=
Make_Explicit_Dereference (Sloc (P),
Prefix => Relocate_Node (P));
Rewrite (P, Deref);
Set_Etype (P, ET);
RAS_E_Dereference (Prefix (P));
return True;
end if;
return False;
end Remote_AST_I_Dereference;
function Remote_AST_Null_Value
(N : Node_Id;
Typ : Entity_Id) return Boolean
is
Loc : constant Source_Ptr := Sloc (N);
Target_Type : Entity_Id;
begin
if not Expander_Active then
return False;
elsif Ekind (Typ) = E_Access_Subprogram_Type
and then (Is_Remote_Call_Interface (Typ)
or else Is_Remote_Types (Typ))
and then Comes_From_Source (N)
and then Expander_Active
then
Target_Type := Equivalent_Type (Typ);
elsif Ekind (Typ) = E_Record_Type
and then Present (Corresponding_Remote_Type (Typ))
then
Target_Type := Typ;
else
return False;
end if;
Rewrite (N,
Make_Aggregate (Loc,
Component_Associations => New_List (
Make_Component_Association (Loc,
Choices => New_List (
Make_Identifier (Loc, Name_Ras)),
Expression =>
Make_Null (Loc)))));
Analyze_And_Resolve (N, Target_Type);
return True;
end Remote_AST_Null_Value;
end Sem_Dist;