with Atree; use Atree;
with Einfo; use Einfo;
with Elists; use Elists;
with Exp_Tss; use Exp_Tss;
with Exp_Util; use Exp_Util;
with GNAT.HTable; use GNAT.HTable;
with Lib; use Lib;
with Namet; use Namet;
with Nlists; use Nlists;
with Nmake; use Nmake;
with Opt; use Opt;
with Rtsfind; use Rtsfind;
with Sem; use Sem;
with Sem_Ch3; use Sem_Ch3;
with Sem_Ch8; use Sem_Ch8;
with Sem_Dist; use Sem_Dist;
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;
with Uintp; use Uintp;
with Uname; use Uname;
package body Exp_Dist is
procedure Build_General_Calling_Stubs
(Decls : in List_Id;
Statements : in List_Id;
Target_Partition : in Entity_Id;
RPC_Receiver : in Node_Id;
Subprogram_Id : in Node_Id;
Asynchronous : in Node_Id := Empty;
Is_Known_Asynchronous : in Boolean := False;
Is_Known_Non_Asynchronous : in Boolean := False;
Is_Function : in Boolean;
Spec : in Node_Id;
Object_Type : in Entity_Id := Empty;
Nod : in Node_Id);
function Build_Subprogram_Calling_Stubs
(Vis_Decl : Node_Id;
Subp_Id : Int;
Asynchronous : Boolean;
Dynamically_Asynchronous : Boolean := False;
Stub_Type : Entity_Id := Empty;
Locator : Entity_Id := Empty;
New_Name : Name_Id := No_Name)
return Node_Id;
function Build_Subprogram_Receiving_Stubs
(Vis_Decl : Node_Id;
Asynchronous : Boolean;
Dynamically_Asynchronous : Boolean := False;
Stub_Type : Entity_Id := Empty;
RACW_Type : Entity_Id := Empty;
Parent_Primitive : Entity_Id := Empty)
return Node_Id;
function Build_Ordered_Parameters_List (Spec : Node_Id) return List_Id;
procedure Add_Calling_Stubs_To_Declarations
(Pkg_Spec : in Node_Id;
Decls : in List_Id);
procedure Add_Receiving_Stubs_To_Declarations
(Pkg_Spec : in Node_Id;
Decls : in List_Id);
procedure Add_RAS_Dereference_Attribute (N : in Node_Id);
procedure Add_RAS_Access_Attribute (N : in Node_Id);
function Could_Be_Asynchronous (Spec : Node_Id) return Boolean;
function Get_Pkg_Name_String_Id (Decl_Node : Node_Id) return String_Id;
function Get_String_Id (Val : String) return String_Id;
function Pack_Entity_Into_Stream_Access
(Loc : Source_Ptr;
Stream : Entity_Id;
Object : Entity_Id;
Etyp : Entity_Id := Empty)
return Node_Id;
function Pack_Node_Into_Stream
(Loc : Source_Ptr;
Stream : Entity_Id;
Object : Node_Id;
Etyp : Entity_Id)
return Node_Id;
function Pack_Node_Into_Stream_Access
(Loc : Source_Ptr;
Stream : Entity_Id;
Object : Node_Id;
Etyp : Entity_Id)
return Node_Id;
function Copy_Specification
(Loc : Source_Ptr;
Spec : Node_Id;
Object_Type : Entity_Id := Empty;
Stub_Type : Entity_Id := Empty;
New_Name : Name_Id := No_Name)
return Node_Id;
function Scope_Of_Spec (Spec : Node_Id) return Entity_Id;
function Need_Extra_Constrained (Parameter : Node_Id) return Boolean;
function Is_RACW_Controlling_Formal
(Parameter : Node_Id; Stub_Type : Entity_Id)
return Boolean;
type Stub_Structure is record
Stub_Type : Entity_Id;
Stub_Type_Access : Entity_Id;
Object_RPC_Receiver : Entity_Id;
RPC_Receiver_Stream : Entity_Id;
RPC_Receiver_Result : Entity_Id;
RACW_Type : Entity_Id;
end record;
Empty_Stub_Structure : constant Stub_Structure :=
(Empty, Empty, Empty, Empty, Empty, Empty);
type Hash_Index is range 0 .. 50;
function Hash (F : Entity_Id) return Hash_Index;
package Stubs_Table is
new Simple_HTable (Header_Num => Hash_Index,
Element => Stub_Structure,
No_Element => Empty_Stub_Structure,
Key => Entity_Id,
Hash => Hash,
Equal => "=");
package Asynchronous_Flags_Table is
new Simple_HTable (Header_Num => Hash_Index,
Element => Node_Id,
No_Element => Empty,
Key => Entity_Id,
Hash => Hash,
Equal => "=");
package RCI_Locator_Table is
new Simple_HTable (Header_Num => Hash_Index,
Element => Entity_Id,
No_Element => Empty,
Key => Entity_Id,
Hash => Hash,
Equal => "=");
package RCI_Calling_Stubs_Table is
new Simple_HTable (Header_Num => Hash_Index,
Element => Entity_Id,
No_Element => Empty,
Key => Entity_Id,
Hash => Hash,
Equal => "=");
procedure Add_Stub_Type
(Designated_Type : in Entity_Id;
RACW_Type : in Entity_Id;
Decls : in List_Id;
Stub_Type : out Entity_Id;
Stub_Type_Access : out Entity_Id;
Object_RPC_Receiver : out Entity_Id;
Existing : out Boolean);
procedure Add_RACW_Read_Attribute
(RACW_Type : in Entity_Id;
Stub_Type : in Entity_Id;
Stub_Type_Access : in Entity_Id;
Declarations : in List_Id);
procedure Add_RACW_Write_Attribute
(RACW_Type : in Entity_Id;
Stub_Type : in Entity_Id;
Stub_Type_Access : in Entity_Id;
Object_RPC_Receiver : in Entity_Id;
Declarations : in List_Id);
procedure Add_RACW_Read_Write_Attributes
(RACW_Type : in Entity_Id;
Stub_Type : in Entity_Id;
Stub_Type_Access : in Entity_Id;
Object_RPC_Receiver : in Entity_Id;
Declarations : in List_Id);
function RCI_Package_Locator
(Loc : Source_Ptr;
Package_Spec : Node_Id)
return Node_Id;
function Make_Tag_Check (Loc : Source_Ptr; N : Node_Id) return Node_Id;
function Input_With_Tag_Check
(Loc : Source_Ptr;
Var_Type : Entity_Id;
Stream : Entity_Id)
return Node_Id;
RCI_Cache : Node_Id;
Output_From_Constrained : constant array (Boolean) of Name_Id :=
(False => Name_Output,
True => Name_Write);
procedure Add_Calling_Stubs_To_Declarations
(Pkg_Spec : in Node_Id;
Decls : in List_Id)
is
Current_Subprogram_Number : Int := 0;
Current_Declaration : Node_Id;
Loc : constant Source_Ptr := Sloc (Pkg_Spec);
RCI_Instantiation : Node_Id;
Subp_Stubs : Node_Id;
begin
RCI_Instantiation := RCI_Package_Locator (Loc, Pkg_Spec);
RCI_Cache := Defining_Unit_Name (RCI_Instantiation);
Append_To (Decls, RCI_Instantiation);
Analyze (RCI_Instantiation);
Current_Declaration := First (Visible_Declarations (Pkg_Spec));
while Current_Declaration /= Empty loop
if Nkind (Current_Declaration) = N_Subprogram_Declaration
and then Comes_From_Source (Current_Declaration)
then
pragma Assert (Current_Subprogram_Number =
Get_Subprogram_Id (Defining_Unit_Name (Specification (
Current_Declaration))));
Subp_Stubs :=
Build_Subprogram_Calling_Stubs (
Vis_Decl => Current_Declaration,
Subp_Id => Current_Subprogram_Number,
Asynchronous =>
Nkind (Specification (Current_Declaration)) =
N_Procedure_Specification
and then
Is_Asynchronous (Defining_Unit_Name (Specification
(Current_Declaration))));
Append_To (Decls, Subp_Stubs);
Analyze (Subp_Stubs);
Current_Subprogram_Number := Current_Subprogram_Number + 1;
end if;
Next (Current_Declaration);
end loop;
end Add_Calling_Stubs_To_Declarations;
procedure Add_RACW_Features (RACW_Type : in Entity_Id)
is
Desig : constant Entity_Id :=
Etype (Designated_Type (RACW_Type));
Decls : List_Id :=
List_Containing (Declaration_Node (RACW_Type));
Same_Scope : constant Boolean :=
Scope (Desig) = Scope (RACW_Type);
Stub_Type : Entity_Id;
Stub_Type_Access : Entity_Id;
Object_RPC_Receiver : Entity_Id;
Existing : Boolean;
begin
if not Expander_Active then
return;
end if;
if Same_Scope then
Decls := Private_Declarations
(Package_Specification_Of_Scope (Current_Scope));
elsif Nkind (Parent (Decls)) = N_Package_Specification
and then Present (Private_Declarations (Parent (Decls)))
then
Decls := Private_Declarations (Parent (Decls));
end if;
if No (Decls) then
return;
end if;
Add_Stub_Type
(Designated_Type => Desig,
RACW_Type => RACW_Type,
Decls => Decls,
Stub_Type => Stub_Type,
Stub_Type_Access => Stub_Type_Access,
Object_RPC_Receiver => Object_RPC_Receiver,
Existing => Existing);
Add_RACW_Read_Write_Attributes
(RACW_Type => RACW_Type,
Stub_Type => Stub_Type,
Stub_Type_Access => Stub_Type_Access,
Object_RPC_Receiver => Object_RPC_Receiver,
Declarations => Decls);
if not Same_Scope and then not Existing then
Add_RACW_Primitive_Declarations_And_Bodies
(Designated_Type => Desig,
Insertion_Node =>
Parent (Declaration_Node (Object_RPC_Receiver)),
Decls => Decls);
else
Add_Access_Type_To_Process (E => Desig, A => RACW_Type);
end if;
end Add_RACW_Features;
procedure Add_RACW_Primitive_Declarations_And_Bodies
(Designated_Type : in Entity_Id;
Insertion_Node : in Node_Id;
Decls : in List_Id)
is
Loc : constant Source_Ptr := Sloc (Insertion_Node);
Stub_Elements : constant Stub_Structure :=
Stubs_Table.Get (Designated_Type);
pragma Assert (Stub_Elements /= Empty_Stub_Structure);
Current_Insertion_Node : Node_Id := Insertion_Node;
RPC_Receiver_Declarations : List_Id;
RPC_Receiver_Statements : List_Id;
RPC_Receiver_Case_Alternatives : constant List_Id := New_List;
RPC_Receiver_Subp_Id : Entity_Id;
Current_Primitive_Elmt : Elmt_Id;
Current_Primitive : Entity_Id;
Current_Primitive_Body : Node_Id;
Current_Primitive_Spec : Node_Id;
Current_Primitive_Decl : Node_Id;
Current_Primitive_Number : Int := 0;
Current_Primitive_Alias : Node_Id;
Current_Receiver : Entity_Id;
Current_Receiver_Body : Node_Id;
RPC_Receiver_Decl : Node_Id;
Possibly_Asynchronous : Boolean;
begin
if not Expander_Active then
return;
end if;
if Present (Primitive_Operations (Designated_Type)) then
Current_Primitive_Elmt :=
First_Elmt (Primitive_Operations (Designated_Type));
while Current_Primitive_Elmt /= No_Elmt loop
Current_Primitive := Node (Current_Primitive_Elmt);
if Chars (Current_Primitive) /= Name_uSize
and then Chars (Current_Primitive) /= Name_uDeep_Finalize
then
Current_Primitive_Alias := Current_Primitive;
while Present (Alias (Current_Primitive_Alias)) loop
pragma Assert
(Current_Primitive_Alias
/= Alias (Current_Primitive_Alias));
Current_Primitive_Alias := Alias (Current_Primitive_Alias);
end loop;
Current_Primitive_Spec :=
Copy_Specification (Loc,
Spec => Parent (Current_Primitive_Alias),
Object_Type => Designated_Type,
Stub_Type => Stub_Elements.Stub_Type);
Current_Primitive_Decl :=
Make_Subprogram_Declaration (Loc,
Specification => Current_Primitive_Spec);
Insert_After (Current_Insertion_Node, Current_Primitive_Decl);
Analyze (Current_Primitive_Decl);
Current_Insertion_Node := Current_Primitive_Decl;
Possibly_Asynchronous :=
Nkind (Current_Primitive_Spec) = N_Procedure_Specification
and then Could_Be_Asynchronous (Current_Primitive_Spec);
Current_Primitive_Body :=
Build_Subprogram_Calling_Stubs
(Vis_Decl => Current_Primitive_Decl,
Subp_Id => Current_Primitive_Number,
Asynchronous => Possibly_Asynchronous,
Dynamically_Asynchronous => Possibly_Asynchronous,
Stub_Type => Stub_Elements.Stub_Type);
Append_To (Decls, Current_Primitive_Body);
Current_Receiver_Body :=
Build_Subprogram_Receiving_Stubs
(Vis_Decl => Current_Primitive_Decl,
Asynchronous => Possibly_Asynchronous,
Dynamically_Asynchronous => Possibly_Asynchronous,
Stub_Type => Stub_Elements.Stub_Type,
RACW_Type => Stub_Elements.RACW_Type,
Parent_Primitive => Current_Primitive);
Current_Receiver :=
Defining_Unit_Name (Specification (Current_Receiver_Body));
Append_To (Decls, Current_Receiver_Body);
Append_To (RPC_Receiver_Case_Alternatives,
Make_Case_Statement_Alternative (Loc,
Discrete_Choices => New_List (
Make_Integer_Literal (Loc, Current_Primitive_Number)),
Statements => New_List (
Make_Procedure_Call_Statement (Loc,
Name =>
New_Occurrence_Of (Current_Receiver, Loc),
Parameter_Associations => New_List (
New_Occurrence_Of
(Stub_Elements.RPC_Receiver_Stream, Loc),
New_Occurrence_Of
(Stub_Elements.RPC_Receiver_Result, Loc))))));
Current_Primitive_Number := Current_Primitive_Number + 1;
end if;
Next_Elmt (Current_Primitive_Elmt);
end loop;
end if;
Append_To (RPC_Receiver_Case_Alternatives,
Make_Case_Statement_Alternative (Loc,
Discrete_Choices => New_List (Make_Others_Choice (Loc)),
Statements => New_List (Make_Null_Statement (Loc))));
RPC_Receiver_Subp_Id :=
Make_Defining_Identifier (Loc, New_Internal_Name ('S'));
RPC_Receiver_Declarations := New_List (
Make_Object_Declaration (Loc,
Defining_Identifier => RPC_Receiver_Subp_Id,
Object_Definition =>
New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc)));
RPC_Receiver_Statements := New_List (
Make_Attribute_Reference (Loc,
Prefix =>
New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc),
Attribute_Name =>
Name_Read,
Expressions => New_List (
New_Occurrence_Of (Stub_Elements.RPC_Receiver_Stream, Loc),
New_Occurrence_Of (RPC_Receiver_Subp_Id, Loc))));
Append_To (RPC_Receiver_Statements,
Make_Case_Statement (Loc,
Expression =>
New_Occurrence_Of (RPC_Receiver_Subp_Id, Loc),
Alternatives => RPC_Receiver_Case_Alternatives));
RPC_Receiver_Decl :=
Make_Subprogram_Body (Loc,
Specification =>
Copy_Specification (Loc,
Parent (Stub_Elements.Object_RPC_Receiver)),
Declarations => RPC_Receiver_Declarations,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => RPC_Receiver_Statements));
Append_To (Decls, RPC_Receiver_Decl);
end Add_RACW_Primitive_Declarations_And_Bodies;
procedure Add_RACW_Read_Attribute
(RACW_Type : in Entity_Id;
Stub_Type : in Entity_Id;
Stub_Type_Access : in Entity_Id;
Declarations : in List_Id)
is
Loc : constant Source_Ptr := Sloc (RACW_Type);
Proc_Spec : Node_Id;
Proc_Body_Spec : Node_Id;
Proc_Decl : Node_Id;
Attr_Decl : Node_Id;
Body_Node : Node_Id;
Decls : List_Id;
Statements : List_Id;
Local_Statements : List_Id;
Remote_Statements : List_Id;
Procedure_Name : constant Name_Id :=
New_Internal_Name ('R');
Source_Partition : constant Entity_Id :=
Make_Defining_Identifier
(Loc, New_Internal_Name ('P'));
Source_Receiver : constant Entity_Id :=
Make_Defining_Identifier
(Loc, New_Internal_Name ('S'));
Source_Address : constant Entity_Id :=
Make_Defining_Identifier
(Loc, New_Internal_Name ('P'));
Stream_Parameter : constant Entity_Id :=
Make_Defining_Identifier
(Loc, New_Internal_Name ('S'));
Result : constant Entity_Id :=
Make_Defining_Identifier
(Loc, New_Internal_Name ('P'));
Stubbed_Result : constant Entity_Id :=
Make_Defining_Identifier
(Loc, New_Internal_Name ('S'));
Asynchronous_Flag : constant Entity_Id :=
Make_Defining_Identifier
(Loc, New_Internal_Name ('S'));
Asynchronous_Node : constant Node_Id :=
New_Occurrence_Of (Standard_False, Loc);
begin
Append_To (Declarations,
Make_Object_Declaration (Loc,
Defining_Identifier => Asynchronous_Flag,
Constant_Present => True,
Object_Definition => New_Occurrence_Of (Standard_Boolean, Loc),
Expression => Asynchronous_Node));
Asynchronous_Flags_Table.Set (RACW_Type, Asynchronous_Node);
Decls := New_List (
Make_Object_Declaration (Loc,
Defining_Identifier => Source_Partition,
Object_Definition =>
New_Occurrence_Of (RTE (RE_Partition_ID), Loc)),
Make_Object_Declaration (Loc,
Defining_Identifier => Source_Receiver,
Object_Definition =>
New_Occurrence_Of (RTE (RE_Unsigned_64), Loc)),
Make_Object_Declaration (Loc,
Defining_Identifier => Source_Address,
Object_Definition =>
New_Occurrence_Of (RTE (RE_Unsigned_64), Loc)),
Make_Object_Declaration (Loc,
Defining_Identifier => Stubbed_Result,
Object_Definition =>
New_Occurrence_Of (Stub_Type_Access, Loc)));
Statements := New_List (
Make_Attribute_Reference (Loc,
Prefix =>
New_Occurrence_Of (RTE (RE_Partition_ID), Loc),
Attribute_Name => Name_Read,
Expressions => New_List (
New_Occurrence_Of (Stream_Parameter, Loc),
New_Occurrence_Of (Source_Partition, Loc))),
Make_Attribute_Reference (Loc,
Prefix =>
New_Occurrence_Of (RTE (RE_Unsigned_64), Loc),
Attribute_Name =>
Name_Read,
Expressions => New_List (
New_Occurrence_Of (Stream_Parameter, Loc),
New_Occurrence_Of (Source_Receiver, Loc))),
Make_Attribute_Reference (Loc,
Prefix =>
New_Occurrence_Of (RTE (RE_Unsigned_64), Loc),
Attribute_Name =>
Name_Read,
Expressions => New_List (
New_Occurrence_Of (Stream_Parameter, Loc),
New_Occurrence_Of (Source_Address, Loc))));
Append_To (Statements,
Make_Implicit_If_Statement (RACW_Type,
Condition =>
Make_Op_Eq (Loc,
Left_Opnd => New_Occurrence_Of (Source_Address, Loc),
Right_Opnd => Make_Integer_Literal (Loc, Uint_0)),
Then_Statements => New_List (
Make_Assignment_Statement (Loc,
Name => New_Occurrence_Of (Result, Loc),
Expression => Make_Null (Loc)),
Make_Return_Statement (Loc))));
Local_Statements := New_List (
Make_Assignment_Statement (Loc,
Name => New_Occurrence_Of (Result, Loc),
Expression =>
Unchecked_Convert_To (RACW_Type,
OK_Convert_To (RTE (RE_Address),
New_Occurrence_Of (Source_Address, Loc)))));
Remote_Statements := New_List (
Make_Assignment_Statement (Loc,
Name => New_Occurrence_Of (Stubbed_Result, Loc),
Expression =>
Make_Allocator (Loc,
New_Occurrence_Of (Stub_Type, Loc))),
Make_Assignment_Statement (Loc,
Name => Make_Selected_Component (Loc,
Prefix => New_Occurrence_Of (Stubbed_Result, Loc),
Selector_Name => Make_Identifier (Loc, Name_Origin)),
Expression =>
New_Occurrence_Of (Source_Partition, Loc)),
Make_Assignment_Statement (Loc,
Name => Make_Selected_Component (Loc,
Prefix => New_Occurrence_Of (Stubbed_Result, Loc),
Selector_Name => Make_Identifier (Loc, Name_Receiver)),
Expression =>
New_Occurrence_Of (Source_Receiver, Loc)),
Make_Assignment_Statement (Loc,
Name => Make_Selected_Component (Loc,
Prefix => New_Occurrence_Of (Stubbed_Result, Loc),
Selector_Name => Make_Identifier (Loc, Name_Addr)),
Expression =>
New_Occurrence_Of (Source_Address, Loc)));
Append_To (Remote_Statements,
Make_Assignment_Statement (Loc,
Name => Make_Selected_Component (Loc,
Prefix => New_Occurrence_Of (Stubbed_Result, Loc),
Selector_Name => Make_Identifier (Loc, Name_Asynchronous)),
Expression =>
New_Occurrence_Of (Asynchronous_Flag, Loc)));
Append_To (Remote_Statements,
Make_Procedure_Call_Statement (Loc,
Name =>
New_Occurrence_Of (RTE (RE_Get_Unique_Remote_Pointer), Loc),
Parameter_Associations => New_List (
Unchecked_Convert_To (RTE (RE_RACW_Stub_Type_Access),
New_Occurrence_Of (Stubbed_Result, Loc)))));
Append_To (Remote_Statements,
Make_Assignment_Statement (Loc,
Name => New_Occurrence_Of (Result, Loc),
Expression => Unchecked_Convert_To (RACW_Type,
New_Occurrence_Of (Stubbed_Result, Loc))));
Append_To (Statements,
Make_Implicit_If_Statement (RACW_Type,
Condition =>
Make_Op_Eq (Loc,
Left_Opnd =>
Make_Function_Call (Loc,
Name =>
New_Occurrence_Of (RTE (RE_Get_Local_Partition_Id), Loc)),
Right_Opnd => New_Occurrence_Of (Source_Partition, Loc)),
Then_Statements => Local_Statements,
Else_Statements => Remote_Statements));
Proc_Spec :=
Make_Procedure_Specification (Loc,
Defining_Unit_Name =>
Make_Defining_Identifier (Loc, Procedure_Name),
Parameter_Specifications => New_List (
Make_Parameter_Specification (Loc,
Defining_Identifier => Stream_Parameter,
Parameter_Type =>
Make_Access_Definition (Loc,
Subtype_Mark =>
Make_Attribute_Reference (Loc,
Prefix =>
New_Occurrence_Of (RTE (RE_Root_Stream_Type), Loc),
Attribute_Name =>
Name_Class))),
Make_Parameter_Specification (Loc,
Defining_Identifier => Result,
Out_Present => True,
Parameter_Type =>
New_Occurrence_Of (RACW_Type, Loc))));
Proc_Body_Spec :=
Make_Procedure_Specification (Loc,
Defining_Unit_Name =>
Make_Defining_Identifier (Loc, Procedure_Name),
Parameter_Specifications => New_List (
Make_Parameter_Specification (Loc,
Defining_Identifier =>
Make_Defining_Identifier (Loc, Chars (Stream_Parameter)),
Parameter_Type =>
Make_Access_Definition (Loc,
Subtype_Mark =>
Make_Attribute_Reference (Loc,
Prefix =>
New_Occurrence_Of (RTE (RE_Root_Stream_Type), Loc),
Attribute_Name =>
Name_Class))),
Make_Parameter_Specification (Loc,
Defining_Identifier =>
Make_Defining_Identifier (Loc, Chars (Result)),
Out_Present => True,
Parameter_Type =>
New_Occurrence_Of (RACW_Type, Loc))));
Body_Node :=
Make_Subprogram_Body (Loc,
Specification => Proc_Body_Spec,
Declarations => Decls,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => Statements));
Proc_Decl :=
Make_Subprogram_Declaration (Loc, Specification => Proc_Spec);
Attr_Decl :=
Make_Attribute_Definition_Clause (Loc,
Name => New_Occurrence_Of (RACW_Type, Loc),
Chars => Name_Read,
Expression =>
New_Occurrence_Of (Defining_Unit_Name (Proc_Spec), Loc));
Insert_After (Declaration_Node (RACW_Type), Proc_Decl);
Insert_After (Proc_Decl, Attr_Decl);
Append_To (Declarations, Body_Node);
end Add_RACW_Read_Attribute;
procedure Add_RACW_Read_Write_Attributes
(RACW_Type : in Entity_Id;
Stub_Type : in Entity_Id;
Stub_Type_Access : in Entity_Id;
Object_RPC_Receiver : in Entity_Id;
Declarations : in List_Id)
is
begin
Add_RACW_Write_Attribute
(RACW_Type => RACW_Type,
Stub_Type => Stub_Type,
Stub_Type_Access => Stub_Type_Access,
Object_RPC_Receiver => Object_RPC_Receiver,
Declarations => Declarations);
Add_RACW_Read_Attribute
(RACW_Type => RACW_Type,
Stub_Type => Stub_Type,
Stub_Type_Access => Stub_Type_Access,
Declarations => Declarations);
end Add_RACW_Read_Write_Attributes;
procedure Add_RACW_Write_Attribute
(RACW_Type : in Entity_Id;
Stub_Type : in Entity_Id;
Stub_Type_Access : in Entity_Id;
Object_RPC_Receiver : in Entity_Id;
Declarations : in List_Id)
is
Loc : constant Source_Ptr := Sloc (RACW_Type);
Proc_Spec : Node_Id;
Proc_Body_Spec : Node_Id;
Body_Node : Node_Id;
Proc_Decl : Node_Id;
Attr_Decl : Node_Id;
Statements : List_Id;
Local_Statements : List_Id;
Remote_Statements : List_Id;
Null_Statements : List_Id;
Procedure_Name : constant Name_Id := New_Internal_Name ('R');
Stream_Parameter : constant Entity_Id :=
Make_Defining_Identifier
(Loc, New_Internal_Name ('S'));
Object : constant Entity_Id :=
Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
begin
Local_Statements := New_List (
Pack_Entity_Into_Stream_Access (Loc,
Stream => Stream_Parameter,
Object => RTE (RE_Get_Local_Partition_Id)),
Pack_Node_Into_Stream_Access (Loc,
Stream => Stream_Parameter,
Object => OK_Convert_To (RTE (RE_Unsigned_64),
Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (Object_RPC_Receiver, Loc),
Attribute_Name => Name_Address)),
Etyp => RTE (RE_Unsigned_64)),
Pack_Node_Into_Stream_Access (Loc,
Stream => Stream_Parameter,
Object => OK_Convert_To (RTE (RE_Unsigned_64),
Make_Attribute_Reference (Loc,
Prefix =>
Make_Explicit_Dereference (Loc,
Prefix => New_Occurrence_Of (Object, Loc)),
Attribute_Name => Name_Address)),
Etyp => RTE (RE_Unsigned_64)));
Remote_Statements := New_List (
Pack_Node_Into_Stream_Access (Loc,
Stream => Stream_Parameter,
Object =>
Make_Selected_Component (Loc,
Prefix => Unchecked_Convert_To (Stub_Type_Access,
New_Occurrence_Of (Object, Loc)),
Selector_Name =>
Make_Identifier (Loc, Name_Origin)),
Etyp => RTE (RE_Partition_ID)),
Pack_Node_Into_Stream_Access (Loc,
Stream => Stream_Parameter,
Object =>
Make_Selected_Component (Loc,
Prefix => Unchecked_Convert_To (Stub_Type_Access,
New_Occurrence_Of (Object, Loc)),
Selector_Name =>
Make_Identifier (Loc, Name_Receiver)),
Etyp => RTE (RE_Unsigned_64)),
Pack_Node_Into_Stream_Access (Loc,
Stream => Stream_Parameter,
Object =>
Make_Selected_Component (Loc,
Prefix => Unchecked_Convert_To (Stub_Type_Access,
New_Occurrence_Of (Object, Loc)),
Selector_Name =>
Make_Identifier (Loc, Name_Addr)),
Etyp => RTE (RE_Unsigned_64)));
Null_Statements := New_List (
Pack_Entity_Into_Stream_Access (Loc,
Stream => Stream_Parameter,
Object => RTE (RE_Get_Local_Partition_Id)),
Pack_Node_Into_Stream_Access (Loc,
Stream => Stream_Parameter,
Object => OK_Convert_To (RTE (RE_Unsigned_64),
Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (Object_RPC_Receiver, Loc),
Attribute_Name => Name_Address)),
Etyp => RTE (RE_Unsigned_64)),
Pack_Node_Into_Stream_Access (Loc,
Stream => Stream_Parameter,
Object => Make_Integer_Literal (Loc, Uint_0),
Etyp => RTE (RE_Unsigned_64)));
Statements := New_List (
Make_Implicit_If_Statement (RACW_Type,
Condition =>
Make_Op_Eq (Loc,
Left_Opnd => New_Occurrence_Of (Object, Loc),
Right_Opnd => Make_Null (Loc)),
Then_Statements => Null_Statements,
Elsif_Parts => New_List (
Make_Elsif_Part (Loc,
Condition =>
Make_Op_Eq (Loc,
Left_Opnd =>
Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (Object, Loc),
Attribute_Name => Name_Tag),
Right_Opnd =>
Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (Stub_Type, Loc),
Attribute_Name => Name_Tag)),
Then_Statements => Remote_Statements)),
Else_Statements => Local_Statements));
Proc_Spec :=
Make_Procedure_Specification (Loc,
Defining_Unit_Name =>
Make_Defining_Identifier (Loc, Procedure_Name),
Parameter_Specifications => New_List (
Make_Parameter_Specification (Loc,
Defining_Identifier => Stream_Parameter,
Parameter_Type =>
Make_Access_Definition (Loc,
Subtype_Mark =>
Make_Attribute_Reference (Loc,
Prefix =>
New_Occurrence_Of (RTE (RE_Root_Stream_Type), Loc),
Attribute_Name =>
Name_Class))),
Make_Parameter_Specification (Loc,
Defining_Identifier => Object,
In_Present => True,
Parameter_Type =>
New_Occurrence_Of (RACW_Type, Loc))));
Proc_Decl :=
Make_Subprogram_Declaration (Loc, Specification => Proc_Spec);
Attr_Decl :=
Make_Attribute_Definition_Clause (Loc,
Name => New_Occurrence_Of (RACW_Type, Loc),
Chars => Name_Write,
Expression =>
New_Occurrence_Of (Defining_Unit_Name (Proc_Spec), Loc));
Proc_Body_Spec :=
Make_Procedure_Specification (Loc,
Defining_Unit_Name =>
Make_Defining_Identifier (Loc, Procedure_Name),
Parameter_Specifications => New_List (
Make_Parameter_Specification (Loc,
Defining_Identifier =>
Make_Defining_Identifier (Loc, Chars (Stream_Parameter)),
Parameter_Type =>
Make_Access_Definition (Loc,
Subtype_Mark =>
Make_Attribute_Reference (Loc,
Prefix =>
New_Occurrence_Of (RTE (RE_Root_Stream_Type), Loc),
Attribute_Name =>
Name_Class))),
Make_Parameter_Specification (Loc,
Defining_Identifier =>
Make_Defining_Identifier (Loc, Chars (Object)),
In_Present => True,
Parameter_Type =>
New_Occurrence_Of (RACW_Type, Loc))));
Body_Node :=
Make_Subprogram_Body (Loc,
Specification => Proc_Body_Spec,
Declarations => No_List,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => Statements));
Insert_After (Declaration_Node (RACW_Type), Proc_Decl);
Insert_After (Proc_Decl, Attr_Decl);
Append_To (Declarations, Body_Node);
end Add_RACW_Write_Attribute;
procedure Add_RAS_Access_Attribute (N : in Node_Id) is
Ras_Type : constant Entity_Id := Defining_Identifier (N);
Fat_Type : constant Entity_Id := Equivalent_Type (Ras_Type);
Proc_Decls : constant List_Id := New_List;
Proc_Statements : constant List_Id := New_List;
Proc_Spec : Node_Id;
Proc_Body : Node_Id;
Proc : Node_Id;
Param : Node_Id;
Package_Name : Node_Id;
Subp_Id : Node_Id;
Asynchronous : Node_Id;
Return_Value : Node_Id;
Loc : constant Source_Ptr := Sloc (N);
procedure Set_Field (Field_Name : in Name_Id; Value : in Node_Id);
procedure Set_Field (Field_Name : in Name_Id; Value : in Node_Id)
is
begin
Append_To (Proc_Statements,
Make_Assignment_Statement (Loc,
Name =>
Make_Selected_Component (Loc,
Prefix => New_Occurrence_Of (Return_Value, Loc),
Selector_Name => Make_Identifier (Loc, Field_Name)),
Expression => Value));
end Set_Field;
begin
Param := Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
Package_Name := Make_Defining_Identifier (Loc, New_Internal_Name ('S'));
Subp_Id := Make_Defining_Identifier (Loc, New_Internal_Name ('N'));
Asynchronous := Make_Defining_Identifier (Loc, New_Internal_Name ('B'));
Return_Value := Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
Append_To (Proc_Decls,
Make_Object_Declaration (Loc,
Defining_Identifier => Return_Value,
Object_Definition =>
New_Occurrence_Of (Fat_Type, Loc)));
Set_Field (Name_Ras,
OK_Convert_To (RTE (RE_Unsigned_64), New_Occurrence_Of (Param, Loc)));
Set_Field (Name_Origin,
Unchecked_Convert_To (Standard_Integer,
Make_Function_Call (Loc,
Name =>
New_Occurrence_Of (RTE (RE_Get_Active_Partition_Id), Loc),
Parameter_Associations => New_List (
New_Occurrence_Of (Package_Name, Loc)))));
Set_Field (Name_Receiver,
Make_Function_Call (Loc,
Name =>
New_Occurrence_Of (RTE (RE_Get_RCI_Package_Receiver), Loc),
Parameter_Associations => New_List (
New_Occurrence_Of (Package_Name, Loc))));
Set_Field (Name_Subp_Id,
New_Occurrence_Of (Subp_Id, Loc));
Set_Field (Name_Async,
New_Occurrence_Of (Asynchronous, Loc));
Append_To (Proc_Statements,
Make_Return_Statement (Loc,
Expression =>
New_Occurrence_Of (Return_Value, Loc)));
Proc := Make_Defining_Identifier (Loc, Name_uRAS_Access);
Proc_Spec :=
Make_Function_Specification (Loc,
Defining_Unit_Name => Proc,
Parameter_Specifications => New_List (
Make_Parameter_Specification (Loc,
Defining_Identifier => Param,
Parameter_Type =>
New_Occurrence_Of (RTE (RE_Address), Loc)),
Make_Parameter_Specification (Loc,
Defining_Identifier => Package_Name,
Parameter_Type =>
New_Occurrence_Of (Standard_String, Loc)),
Make_Parameter_Specification (Loc,
Defining_Identifier => Subp_Id,
Parameter_Type =>
New_Occurrence_Of (Standard_Natural, Loc)),
Make_Parameter_Specification (Loc,
Defining_Identifier => Asynchronous,
Parameter_Type =>
New_Occurrence_Of (Standard_Boolean, Loc))),
Subtype_Mark =>
New_Occurrence_Of (Fat_Type, Loc));
Set_Ekind (Proc, E_Function);
Set_Etype (Proc, New_Occurrence_Of (Fat_Type, Loc));
Proc_Body :=
Make_Subprogram_Body (Loc,
Specification => Proc_Spec,
Declarations => Proc_Decls,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => Proc_Statements));
Set_TSS (Fat_Type, Proc);
end Add_RAS_Access_Attribute;
procedure Add_RAS_Dereference_Attribute (N : in Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
Type_Def : constant Node_Id := Type_Definition (N);
Ras_Type : constant Entity_Id := Defining_Identifier (N);
Fat_Type : constant Entity_Id := Equivalent_Type (Ras_Type);
Proc_Decls : constant List_Id := New_List;
Proc_Statements : constant List_Id := New_List;
Inner_Decls : constant List_Id := New_List;
Inner_Statements : constant List_Id := New_List;
Direct_Statements : constant List_Id := New_List;
Proc : Node_Id;
Proc_Spec : Node_Id;
Proc_Body : Node_Id;
Param_Specs : constant List_Id := New_List;
Param_Assoc : constant List_Id := New_List;
Pointer : Node_Id;
Converted_Ras : Node_Id;
Target_Partition : Node_Id;
RPC_Receiver : Node_Id;
Subprogram_Id : Node_Id;
Asynchronous : Node_Id;
Is_Function : constant Boolean :=
Nkind (Type_Def) = N_Access_Function_Definition;
Spec : constant Node_Id := Type_Def;
Current_Parameter : Node_Id;
begin
Pointer :=
Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
Target_Partition :=
Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
Append_To (Proc_Decls,
Make_Object_Declaration (Loc,
Defining_Identifier => Target_Partition,
Constant_Present => True,
Object_Definition =>
New_Occurrence_Of (RTE (RE_Partition_ID), Loc),
Expression =>
Unchecked_Convert_To (RTE (RE_Partition_ID),
Make_Selected_Component (Loc,
Prefix =>
New_Occurrence_Of (Pointer, Loc),
Selector_Name =>
Make_Identifier (Loc, Name_Origin)))));
RPC_Receiver :=
Make_Selected_Component (Loc,
Prefix =>
New_Occurrence_Of (Pointer, Loc),
Selector_Name =>
Make_Identifier (Loc, Name_Receiver));
Subprogram_Id :=
Unchecked_Convert_To (RTE (RE_Subprogram_Id),
Make_Selected_Component (Loc,
Prefix =>
New_Occurrence_Of (Pointer, Loc),
Selector_Name =>
Make_Identifier (Loc, Name_Subp_Id)));
if Is_Function then
Asynchronous := Empty;
else
Asynchronous :=
Make_Selected_Component (Loc,
Prefix =>
New_Occurrence_Of (Pointer, Loc),
Selector_Name =>
Make_Identifier (Loc, Name_Async));
end if;
if Present (Parameter_Specifications (Type_Def)) then
Current_Parameter := First (Parameter_Specifications (Type_Def));
while Current_Parameter /= Empty loop
Append_To (Param_Specs,
Make_Parameter_Specification (Loc,
Defining_Identifier =>
Make_Defining_Identifier (Loc,
Chars => Chars (Defining_Identifier (Current_Parameter))),
In_Present => In_Present (Current_Parameter),
Out_Present => Out_Present (Current_Parameter),
Parameter_Type =>
New_Occurrence_Of
(Etype (Parameter_Type (Current_Parameter)), Loc),
Expression =>
New_Copy_Tree (Expression (Current_Parameter))));
Append_To (Param_Assoc,
Make_Identifier (Loc,
Chars => Chars (Defining_Identifier (Current_Parameter))));
Next (Current_Parameter);
end loop;
end if;
Proc := Make_Defining_Identifier (Loc, Name_uRAS_Dereference);
if Is_Function then
Proc_Spec :=
Make_Function_Specification (Loc,
Defining_Unit_Name => Proc,
Parameter_Specifications => Param_Specs,
Subtype_Mark =>
New_Occurrence_Of (
Entity (Subtype_Mark (Spec)), Loc));
Set_Ekind (Proc, E_Function);
Set_Etype (Proc,
New_Occurrence_Of (Entity (Subtype_Mark (Spec)), Loc));
else
Proc_Spec :=
Make_Procedure_Specification (Loc,
Defining_Unit_Name => Proc,
Parameter_Specifications => Param_Specs);
Set_Ekind (Proc, E_Procedure);
Set_Etype (Proc, Standard_Void_Type);
end if;
Build_General_Calling_Stubs
(Decls => Inner_Decls,
Statements => Inner_Statements,
Target_Partition => Target_Partition,
RPC_Receiver => RPC_Receiver,
Subprogram_Id => Subprogram_Id,
Asynchronous => Asynchronous,
Is_Known_Non_Asynchronous => Is_Function,
Is_Function => Is_Function,
Spec => Proc_Spec,
Nod => N);
Converted_Ras :=
Unchecked_Convert_To (Ras_Type,
OK_Convert_To (RTE (RE_Address),
Make_Selected_Component (Loc,
Prefix => New_Occurrence_Of (Pointer, Loc),
Selector_Name => Make_Identifier (Loc, Name_Ras))));
if Is_Function then
Append_To (Direct_Statements,
Make_Return_Statement (Loc,
Expression =>
Make_Function_Call (Loc,
Name =>
Make_Explicit_Dereference (Loc,
Prefix => Converted_Ras),
Parameter_Associations => Param_Assoc)));
else
Append_To (Direct_Statements,
Make_Procedure_Call_Statement (Loc,
Name =>
Make_Explicit_Dereference (Loc,
Prefix => Converted_Ras),
Parameter_Associations => Param_Assoc));
end if;
Prepend_To (Param_Specs,
Make_Parameter_Specification (Loc,
Defining_Identifier => Pointer,
In_Present => True,
Parameter_Type =>
New_Occurrence_Of (Fat_Type, Loc)));
Append_To (Proc_Statements,
Make_Implicit_If_Statement (N,
Condition =>
Make_And_Then (Loc,
Left_Opnd =>
Make_Op_Ne (Loc,
Left_Opnd =>
Make_Selected_Component (Loc,
Prefix => New_Occurrence_Of (Pointer, Loc),
Selector_Name => Make_Identifier (Loc, Name_Ras)),
Right_Opnd =>
Make_Integer_Literal (Loc, Uint_0)),
Right_Opnd =>
Make_Op_Eq (Loc,
Left_Opnd =>
New_Occurrence_Of (Target_Partition, Loc),
Right_Opnd =>
Make_Function_Call (Loc,
New_Occurrence_Of (
RTE (RE_Get_Local_Partition_Id), Loc)))),
Then_Statements =>
Direct_Statements,
Else_Statements => New_List (
Make_Block_Statement (Loc,
Declarations => Inner_Decls,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => Inner_Statements)))));
Proc_Body :=
Make_Subprogram_Body (Loc,
Specification => Proc_Spec,
Declarations => Proc_Decls,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => Proc_Statements));
Set_TSS (Fat_Type, Defining_Unit_Name (Proc_Spec));
end Add_RAS_Dereference_Attribute;
procedure Add_RAST_Features (Vis_Decl : Node_Id) is
begin
if Present (TSS (Equivalent_Type (Defining_Identifier
(Vis_Decl)), Name_uRAS_Access))
then
return;
end if;
Add_RAS_Dereference_Attribute (Vis_Decl);
Add_RAS_Access_Attribute (Vis_Decl);
end Add_RAST_Features;
procedure Add_Receiving_Stubs_To_Declarations
(Pkg_Spec : in Node_Id;
Decls : in List_Id)
is
Loc : constant Source_Ptr := Sloc (Pkg_Spec);
Stream_Parameter : Node_Id;
Result_Parameter : Node_Id;
Pkg_RPC_Receiver : Node_Id;
Pkg_RPC_Receiver_Spec : Node_Id;
Pkg_RPC_Receiver_Formals : List_Id;
Pkg_RPC_Receiver_Decls : List_Id;
Pkg_RPC_Receiver_Statements : List_Id;
Pkg_RPC_Receiver_Cases : List_Id := New_List;
Pkg_RPC_Receiver_Body : Node_Id;
Subp_Id : Node_Id;
Current_Declaration : Node_Id;
Current_Subprogram_Number : Int := 0;
Current_Stubs : Node_Id;
Actuals : List_Id;
Dummy_Register_Name : Name_Id;
Dummy_Register_Spec : Node_Id;
Dummy_Register_Decl : Node_Id;
Dummy_Register_Body : Node_Id;
begin
Stream_Parameter :=
Make_Defining_Identifier (Loc, New_Internal_Name ('S'));
Result_Parameter :=
Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
Subp_Id :=
Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
Pkg_RPC_Receiver :=
Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
Pkg_RPC_Receiver_Formals := New_List (
Make_Parameter_Specification (Loc,
Defining_Identifier => Stream_Parameter,
Parameter_Type =>
Make_Access_Definition (Loc,
Subtype_Mark =>
New_Occurrence_Of (RTE (RE_Params_Stream_Type), Loc))),
Make_Parameter_Specification (Loc,
Defining_Identifier => Result_Parameter,
Parameter_Type =>
Make_Access_Definition (Loc,
Subtype_Mark =>
New_Occurrence_Of (RTE (RE_Params_Stream_Type), Loc))));
Pkg_RPC_Receiver_Spec :=
Make_Procedure_Specification (Loc,
Defining_Unit_Name => Pkg_RPC_Receiver,
Parameter_Specifications => Pkg_RPC_Receiver_Formals);
Pkg_RPC_Receiver_Decls := New_List (
Make_Object_Declaration (Loc,
Defining_Identifier => Subp_Id,
Object_Definition =>
New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc)));
Pkg_RPC_Receiver_Statements := New_List (
Make_Attribute_Reference (Loc,
Prefix =>
New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc),
Attribute_Name =>
Name_Read,
Expressions => New_List (
New_Occurrence_Of (Stream_Parameter, Loc),
New_Occurrence_Of (Subp_Id, Loc))));
Current_Declaration := First (Visible_Declarations (Pkg_Spec));
while Current_Declaration /= Empty loop
if Nkind (Current_Declaration) = N_Subprogram_Declaration
and then Comes_From_Source (Current_Declaration)
then
pragma Assert (Current_Subprogram_Number =
Get_Subprogram_Id (Defining_Unit_Name (Specification (
Current_Declaration))));
Current_Stubs :=
Build_Subprogram_Receiving_Stubs
(Vis_Decl => Current_Declaration,
Asynchronous =>
Nkind (Specification (Current_Declaration)) =
N_Procedure_Specification
and then Is_Asynchronous
(Defining_Unit_Name (Specification
(Current_Declaration))));
Append_To (Decls, Current_Stubs);
Analyze (Current_Stubs);
Actuals := New_List (New_Occurrence_Of (Stream_Parameter, Loc));
if Nkind (Specification (Current_Declaration))
= N_Function_Specification
or else
not Is_Asynchronous (
Defining_Entity (Specification (Current_Declaration)))
then
Append_To (Actuals,
New_Occurrence_Of (Result_Parameter, Loc));
end if;
Append_To (Pkg_RPC_Receiver_Cases,
Make_Case_Statement_Alternative (Loc,
Discrete_Choices =>
New_List (
Make_Integer_Literal (Loc, Current_Subprogram_Number)),
Statements =>
New_List (
Make_Procedure_Call_Statement (Loc,
Name =>
New_Occurrence_Of (
Defining_Entity (Current_Stubs), Loc),
Parameter_Associations =>
Actuals))));
Current_Subprogram_Number := Current_Subprogram_Number + 1;
end if;
Next (Current_Declaration);
end loop;
Append_To (Pkg_RPC_Receiver_Cases,
Make_Case_Statement_Alternative (Loc,
Discrete_Choices =>
New_List (Make_Others_Choice (Loc)),
Statements =>
New_List (Make_Null_Statement (Loc))));
Append_To (Pkg_RPC_Receiver_Statements,
Make_Case_Statement (Loc,
Expression =>
New_Occurrence_Of (Subp_Id, Loc),
Alternatives => Pkg_RPC_Receiver_Cases));
Pkg_RPC_Receiver_Body :=
Make_Subprogram_Body (Loc,
Specification => Pkg_RPC_Receiver_Spec,
Declarations => Pkg_RPC_Receiver_Decls,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => Pkg_RPC_Receiver_Statements));
Append_To (Decls, Pkg_RPC_Receiver_Body);
Analyze (Pkg_RPC_Receiver_Body);
Dummy_Register_Name := New_Internal_Name ('P');
Dummy_Register_Spec :=
Make_Package_Specification (Loc,
Defining_Unit_Name =>
Make_Defining_Identifier (Loc, Dummy_Register_Name),
Visible_Declarations => No_List,
End_Label => Empty);
Dummy_Register_Decl :=
Make_Package_Declaration (Loc,
Specification => Dummy_Register_Spec);
Append_To (Decls,
Dummy_Register_Decl);
Analyze (Dummy_Register_Decl);
Dummy_Register_Body :=
Make_Package_Body (Loc,
Defining_Unit_Name =>
Make_Defining_Identifier (Loc, Dummy_Register_Name),
Declarations => No_List,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => New_List (
Make_Procedure_Call_Statement (Loc,
Name =>
New_Occurrence_Of (RTE (RE_Register_Receiving_Stub), Loc),
Parameter_Associations => New_List (
Make_String_Literal (Loc,
Strval => Get_Pkg_Name_String_Id (Pkg_Spec)),
Make_Attribute_Reference (Loc,
Prefix =>
New_Occurrence_Of (Pkg_RPC_Receiver, Loc),
Attribute_Name =>
Name_Unrestricted_Access),
Make_Attribute_Reference (Loc,
Prefix =>
New_Occurrence_Of (Defining_Entity (Pkg_Spec), Loc),
Attribute_Name =>
Name_Version))))));
Append_To (Decls, Dummy_Register_Body);
Analyze (Dummy_Register_Body);
end Add_Receiving_Stubs_To_Declarations;
procedure Add_Stub_Type
(Designated_Type : in Entity_Id;
RACW_Type : in Entity_Id;
Decls : in List_Id;
Stub_Type : out Entity_Id;
Stub_Type_Access : out Entity_Id;
Object_RPC_Receiver : out Entity_Id;
Existing : out Boolean)
is
Loc : constant Source_Ptr := Sloc (RACW_Type);
Stub_Elements : constant Stub_Structure :=
Stubs_Table.Get (Designated_Type);
Stub_Type_Declaration : Node_Id;
Stub_Type_Access_Declaration : Node_Id;
Object_RPC_Receiver_Declaration : Node_Id;
RPC_Receiver_Stream : Entity_Id;
RPC_Receiver_Result : Entity_Id;
begin
if Stub_Elements /= Empty_Stub_Structure then
Stub_Type := Stub_Elements.Stub_Type;
Stub_Type_Access := Stub_Elements.Stub_Type_Access;
Object_RPC_Receiver := Stub_Elements.Object_RPC_Receiver;
Existing := True;
return;
end if;
Existing := False;
Stub_Type :=
Make_Defining_Identifier (Loc, New_Internal_Name ('S'));
Stub_Type_Access :=
Make_Defining_Identifier (Loc, New_Internal_Name ('S'));
Object_RPC_Receiver :=
Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
RPC_Receiver_Stream :=
Make_Defining_Identifier (Loc, New_Internal_Name ('S'));
RPC_Receiver_Result :=
Make_Defining_Identifier (Loc, New_Internal_Name ('S'));
Stubs_Table.Set (Designated_Type,
(Stub_Type => Stub_Type,
Stub_Type_Access => Stub_Type_Access,
Object_RPC_Receiver => Object_RPC_Receiver,
RPC_Receiver_Stream => RPC_Receiver_Stream,
RPC_Receiver_Result => RPC_Receiver_Result,
RACW_Type => RACW_Type));
Stub_Type_Declaration :=
Make_Full_Type_Declaration (Loc,
Defining_Identifier => Stub_Type,
Type_Definition =>
Make_Record_Definition (Loc,
Tagged_Present => True,
Limited_Present => True,
Component_List =>
Make_Component_List (Loc,
Component_Items => New_List (
Make_Component_Declaration (Loc,
Defining_Identifier =>
Make_Defining_Identifier (Loc, Name_Origin),
Subtype_Indication =>
New_Occurrence_Of (RTE (RE_Partition_ID), Loc)),
Make_Component_Declaration (Loc,
Defining_Identifier =>
Make_Defining_Identifier (Loc, Name_Receiver),
Subtype_Indication =>
New_Occurrence_Of (RTE (RE_Unsigned_64), Loc)),
Make_Component_Declaration (Loc,
Defining_Identifier =>
Make_Defining_Identifier (Loc, Name_Addr),
Subtype_Indication =>
New_Occurrence_Of (RTE (RE_Unsigned_64), Loc)),
Make_Component_Declaration (Loc,
Defining_Identifier =>
Make_Defining_Identifier (Loc, Name_Asynchronous),
Subtype_Indication =>
New_Occurrence_Of (Standard_Boolean, Loc))))));
Append_To (Decls, Stub_Type_Declaration);
Analyze (Stub_Type_Declaration);
Derive_Subprograms (Parent_Type => Designated_Type,
Derived_Type => Stub_Type);
Stub_Type_Access_Declaration :=
Make_Full_Type_Declaration (Loc,
Defining_Identifier => Stub_Type_Access,
Type_Definition =>
Make_Access_To_Object_Definition (Loc,
Subtype_Indication => New_Occurrence_Of (Stub_Type, Loc)));
Append_To (Decls, Stub_Type_Access_Declaration);
Analyze (Stub_Type_Access_Declaration);
Object_RPC_Receiver_Declaration :=
Make_Subprogram_Declaration (Loc,
Make_Procedure_Specification (Loc,
Defining_Unit_Name => Object_RPC_Receiver,
Parameter_Specifications => New_List (
Make_Parameter_Specification (Loc,
Defining_Identifier => RPC_Receiver_Stream,
Parameter_Type =>
Make_Access_Definition (Loc,
Subtype_Mark =>
New_Occurrence_Of (RTE (RE_Params_Stream_Type), Loc))),
Make_Parameter_Specification (Loc,
Defining_Identifier => RPC_Receiver_Result,
Parameter_Type =>
Make_Access_Definition (Loc,
Subtype_Mark =>
New_Occurrence_Of
(RTE (RE_Params_Stream_Type), Loc))))));
Append_To (Decls, Object_RPC_Receiver_Declaration);
end Add_Stub_Type;
procedure Build_General_Calling_Stubs
(Decls : List_Id;
Statements : List_Id;
Target_Partition : Entity_Id;
RPC_Receiver : Node_Id;
Subprogram_Id : Node_Id;
Asynchronous : Node_Id := Empty;
Is_Known_Asynchronous : Boolean := False;
Is_Known_Non_Asynchronous : Boolean := False;
Is_Function : Boolean;
Spec : Node_Id;
Object_Type : Entity_Id := Empty;
Nod : Node_Id)
is
Loc : constant Source_Ptr := Sloc (Nod);
Stream_Parameter : Node_Id;
Result_Parameter : Node_Id;
Exception_Return_Parameter : Node_Id;
Current_Parameter : Node_Id;
Ordered_Parameters_List : constant List_Id :=
Build_Ordered_Parameters_List (Spec);
Asynchronous_Statements : List_Id := No_List;
Non_Asynchronous_Statements : List_Id := No_List;
Extra_Formal_Statements : constant List_Id := New_List;
begin
Stream_Parameter :=
Make_Defining_Identifier (Loc, New_Internal_Name ('S'));
Append_To (Decls,
Make_Object_Declaration (Loc,
Defining_Identifier => Stream_Parameter,
Aliased_Present => True,
Object_Definition =>
Make_Subtype_Indication (Loc,
Subtype_Mark =>
New_Occurrence_Of (RTE (RE_Params_Stream_Type), Loc),
Constraint =>
Make_Index_Or_Discriminant_Constraint (Loc,
Constraints =>
New_List (Make_Integer_Literal (Loc, 0))))));
if not Is_Known_Asynchronous then
Result_Parameter :=
Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
Append_To (Decls,
Make_Object_Declaration (Loc,
Defining_Identifier => Result_Parameter,
Aliased_Present => True,
Object_Definition =>
Make_Subtype_Indication (Loc,
Subtype_Mark =>
New_Occurrence_Of (RTE (RE_Params_Stream_Type), Loc),
Constraint =>
Make_Index_Or_Discriminant_Constraint (Loc,
Constraints =>
New_List (Make_Integer_Literal (Loc, 0))))));
Exception_Return_Parameter :=
Make_Defining_Identifier (Loc, New_Internal_Name ('E'));
Append_To (Decls,
Make_Object_Declaration (Loc,
Defining_Identifier => Exception_Return_Parameter,
Object_Definition =>
New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc)));
else
Result_Parameter := Empty;
Exception_Return_Parameter := Empty;
end if;
Append_To (Statements,
Make_Attribute_Reference (Loc,
Prefix =>
New_Occurrence_Of (RTE (RE_Unsigned_64), Loc),
Attribute_Name => Name_Write,
Expressions => New_List (
Make_Attribute_Reference (Loc,
Prefix =>
New_Occurrence_Of (Stream_Parameter, Loc),
Attribute_Name =>
Name_Access),
RPC_Receiver)));
Append_To (Statements,
Make_Attribute_Reference (Loc,
Prefix =>
New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc),
Attribute_Name =>
Name_Write,
Expressions => New_List (
Make_Attribute_Reference (Loc,
Prefix =>
New_Occurrence_Of (Stream_Parameter, Loc),
Attribute_Name => Name_Access),
Subprogram_Id)));
Current_Parameter := First (Ordered_Parameters_List);
while Current_Parameter /= Empty loop
if Is_RACW_Controlling_Formal (Current_Parameter, Object_Type) then
Append_To (Statements,
Pack_Node_Into_Stream (Loc,
Stream => Stream_Parameter,
Object =>
Make_Selected_Component (Loc,
Prefix =>
New_Occurrence_Of (
Defining_Identifier (Current_Parameter), Loc),
Selector_Name =>
Make_Identifier (Loc, Name_Addr)),
Etyp => RTE (RE_Unsigned_64)));
else
declare
Etyp : constant Entity_Id :=
Etype (Parameter_Type (Current_Parameter));
Constrained : constant Boolean :=
Is_Constrained (Etyp)
or else Is_Elementary_Type (Etyp);
begin
if In_Present (Current_Parameter)
or else not Out_Present (Current_Parameter)
or else not Constrained
then
Append_To (Statements,
Make_Attribute_Reference (Loc,
Prefix =>
New_Occurrence_Of (Etyp, Loc),
Attribute_Name => Output_From_Constrained (Constrained),
Expressions => New_List (
Make_Attribute_Reference (Loc,
Prefix =>
New_Occurrence_Of (Stream_Parameter, Loc),
Attribute_Name => Name_Access),
New_Occurrence_Of (
Defining_Identifier (Current_Parameter), Loc))));
end if;
end;
end if;
if Nkind (Parameter_Type (Current_Parameter)) /= N_Access_Definition
and then Need_Extra_Constrained (Current_Parameter)
then
declare
Extra_Parameter : constant Entity_Id :=
Make_Defining_Identifier
(Loc, New_Internal_Name ('P'));
begin
Append_To (Decls,
Make_Object_Declaration (Loc,
Defining_Identifier => Extra_Parameter,
Constant_Present => True,
Object_Definition =>
New_Occurrence_Of (Standard_Boolean, Loc),
Expression =>
Make_Attribute_Reference (Loc,
Prefix =>
New_Occurrence_Of (
Defining_Identifier (Current_Parameter), Loc),
Attribute_Name => Name_Constrained)));
Append_To (Extra_Formal_Statements,
Make_Attribute_Reference (Loc,
Prefix =>
New_Occurrence_Of (Standard_Boolean, Loc),
Attribute_Name =>
Name_Write,
Expressions => New_List (
Make_Attribute_Reference (Loc,
Prefix =>
New_Occurrence_Of (Stream_Parameter, Loc),
Attribute_Name =>
Name_Access),
New_Occurrence_Of (Extra_Parameter, Loc))));
end;
end if;
Next (Current_Parameter);
end loop;
Append_List_To (Statements, Extra_Formal_Statements);
if not Is_Known_Non_Asynchronous then
Asynchronous_Statements := New_List (
Make_Procedure_Call_Statement (Loc,
Name =>
New_Occurrence_Of (RTE (RE_Do_Apc), Loc),
Parameter_Associations => New_List (
New_Occurrence_Of (Target_Partition, Loc),
Make_Attribute_Reference (Loc,
Prefix =>
New_Occurrence_Of (Stream_Parameter, Loc),
Attribute_Name =>
Name_Access))));
else
Asynchronous_Statements := No_List;
end if;
if not Is_Known_Asynchronous then
Non_Asynchronous_Statements := New_List (
Make_Procedure_Call_Statement (Loc,
Name =>
New_Occurrence_Of (RTE (RE_Do_Rpc), Loc),
Parameter_Associations => New_List (
New_Occurrence_Of (Target_Partition, Loc),
Make_Attribute_Reference (Loc,
Prefix =>
New_Occurrence_Of (Stream_Parameter, Loc),
Attribute_Name =>
Name_Access),
Make_Attribute_Reference (Loc,
Prefix =>
New_Occurrence_Of (Result_Parameter, Loc),
Attribute_Name =>
Name_Access))));
Append_To (Non_Asynchronous_Statements,
Make_Attribute_Reference (Loc,
Prefix =>
New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc),
Attribute_Name =>
Name_Read,
Expressions => New_List (
Make_Attribute_Reference (Loc,
Prefix =>
New_Occurrence_Of (Result_Parameter, Loc),
Attribute_Name =>
Name_Access),
New_Occurrence_Of (Exception_Return_Parameter, Loc))));
Append_To (Non_Asynchronous_Statements,
Make_Procedure_Call_Statement (Loc,
Name =>
New_Occurrence_Of (RTE (RE_Reraise_Occurrence), Loc),
Parameter_Associations => New_List (
New_Occurrence_Of (Exception_Return_Parameter, Loc))));
if Is_Function then
Append_To (Non_Asynchronous_Statements,
Make_Tag_Check (Loc,
Make_Return_Statement (Loc,
Expression =>
Make_Attribute_Reference (Loc,
Prefix =>
New_Occurrence_Of (
Etype (Subtype_Mark (Spec)), Loc),
Attribute_Name => Name_Input,
Expressions => New_List (
Make_Attribute_Reference (Loc,
Prefix =>
New_Occurrence_Of (Result_Parameter, Loc),
Attribute_Name => Name_Access))))));
else
Current_Parameter :=
First (Ordered_Parameters_List);
while Current_Parameter /= Empty loop
if Out_Present (Current_Parameter)
and then
Etype (Parameter_Type (Current_Parameter)) /= Object_Type
then
Append_To (Non_Asynchronous_Statements,
Make_Attribute_Reference (Loc,
Prefix =>
New_Occurrence_Of (
Etype (Parameter_Type (Current_Parameter)), Loc),
Attribute_Name => Name_Read,
Expressions => New_List (
Make_Attribute_Reference (Loc,
Prefix =>
New_Occurrence_Of (Result_Parameter, Loc),
Attribute_Name =>
Name_Access),
New_Occurrence_Of (
Defining_Identifier (Current_Parameter), Loc))));
end if;
Next (Current_Parameter);
end loop;
end if;
end if;
if Is_Known_Asynchronous then
Append_List_To (Statements, Asynchronous_Statements);
elsif Is_Known_Non_Asynchronous then
Append_List_To (Statements, Non_Asynchronous_Statements);
else
pragma Assert (Asynchronous /= Empty);
Prepend_To (Asynchronous_Statements,
Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (Standard_Boolean, Loc),
Attribute_Name => Name_Write,
Expressions => New_List (
Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (Stream_Parameter, Loc),
Attribute_Name => Name_Access),
New_Occurrence_Of (Standard_True, Loc))));
Prepend_To (Non_Asynchronous_Statements,
Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (Standard_Boolean, Loc),
Attribute_Name => Name_Write,
Expressions => New_List (
Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (Stream_Parameter, Loc),
Attribute_Name => Name_Access),
New_Occurrence_Of (Standard_False, Loc))));
Append_To (Statements,
Make_Implicit_If_Statement (Nod,
Condition => Asynchronous,
Then_Statements => Asynchronous_Statements,
Else_Statements => Non_Asynchronous_Statements));
end if;
end Build_General_Calling_Stubs;
function Build_Ordered_Parameters_List (Spec : Node_Id) return List_Id is
Constrained_List : List_Id;
Unconstrained_List : List_Id;
Current_Parameter : Node_Id;
begin
if not Present (Parameter_Specifications (Spec)) then
return New_List;
end if;
Constrained_List := New_List;
Unconstrained_List := New_List;
Current_Parameter := First (Parameter_Specifications (Spec));
while Current_Parameter /= Empty loop
if Nkind (Parameter_Type (Current_Parameter)) = N_Access_Definition
or else
Is_Constrained (Etype (Parameter_Type (Current_Parameter)))
or else
Is_Elementary_Type (Etype (Parameter_Type (Current_Parameter)))
then
Append_To (Constrained_List, New_Copy (Current_Parameter));
else
Append_To (Unconstrained_List, New_Copy (Current_Parameter));
end if;
Next (Current_Parameter);
end loop;
Append_List_To (Unconstrained_List, Constrained_List);
return Unconstrained_List;
end Build_Ordered_Parameters_List;
procedure Build_Passive_Partition_Stub (U : Node_Id) is
Pkg_Spec : Node_Id;
L : List_Id;
Reg : Node_Id;
Loc : constant Source_Ptr := Sloc (U);
Dist_OK : Entity_Id;
begin
Dist_OK := RTE (RE_Params_Stream_Type);
if Nkind (U) = N_Package_Declaration then
Pkg_Spec := Specification (U);
L := Visible_Declarations (Pkg_Spec);
else
Pkg_Spec := Parent (Corresponding_Spec (U));
L := Declarations (U);
end if;
Reg :=
Make_Procedure_Call_Statement (Loc,
Name =>
New_Occurrence_Of (RTE (RE_Register_Passive_Package), Loc),
Parameter_Associations => New_List (
Make_String_Literal (Loc, Get_Pkg_Name_String_Id (Pkg_Spec)),
Make_Attribute_Reference (Loc,
Prefix =>
New_Occurrence_Of (Defining_Entity (Pkg_Spec), Loc),
Attribute_Name =>
Name_Version)));
Append_To (L, Reg);
Analyze (Reg);
end Build_Passive_Partition_Stub;
function Build_Subprogram_Calling_Stubs
(Vis_Decl : Node_Id;
Subp_Id : Int;
Asynchronous : Boolean;
Dynamically_Asynchronous : Boolean := False;
Stub_Type : Entity_Id := Empty;
Locator : Entity_Id := Empty;
New_Name : Name_Id := No_Name)
return Node_Id
is
Loc : constant Source_Ptr := Sloc (Vis_Decl);
Target_Partition : Node_Id;
Decls : constant List_Id := New_List;
Statements : constant List_Id := New_List;
Subp_Spec : Node_Id;
Controlling_Parameter : Entity_Id := Empty;
RPC_Receiver : Node_Id;
Asynchronous_Expr : Node_Id := Empty;
RCI_Locator : Entity_Id;
Spec_To_Use : Node_Id;
procedure Insert_Partition_Check (Parameter : in Node_Id);
procedure Insert_Partition_Check (Parameter : in Node_Id) is
Parameter_Entity : constant Entity_Id :=
Defining_Identifier (Parameter);
Designated_Object : Node_Id;
Condition : Node_Id;
begin
if Nkind (Parameter_Type (Parameter)) = N_Access_Definition then
Designated_Object :=
Make_Explicit_Dereference (Loc,
Prefix => New_Occurrence_Of (Parameter_Entity, Loc));
else
Designated_Object := New_Occurrence_Of (Parameter_Entity, Loc);
end if;
Condition :=
Make_Op_Eq (Loc,
Left_Opnd =>
Make_Selected_Component (Loc,
Prefix =>
New_Occurrence_Of (Parameter_Entity, Loc),
Selector_Name =>
Make_Identifier (Loc, Name_Origin)),
Right_Opnd =>
Make_Selected_Component (Loc,
Prefix =>
New_Occurrence_Of (Controlling_Parameter, Loc),
Selector_Name =>
Make_Identifier (Loc, Name_Origin)));
Append_To (Decls,
Make_Raise_Constraint_Error (Loc,
Condition =>
Make_Op_Not (Loc, Right_Opnd => Condition),
Reason => CE_Partition_Check_Failed));
end Insert_Partition_Check;
begin
Target_Partition :=
Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
Subp_Spec := Copy_Specification (Loc,
Spec => Specification (Vis_Decl),
New_Name => New_Name);
if Locator = Empty then
RCI_Locator := RCI_Cache;
Spec_To_Use := Specification (Vis_Decl);
else
RCI_Locator := Locator;
Spec_To_Use := Subp_Spec;
end if;
if Stub_Type /= Empty
and then Present (Parameter_Specifications (Spec_To_Use))
then
declare
Current_Parameter : Node_Id :=
First (Parameter_Specifications
(Spec_To_Use));
begin
while Current_Parameter /= Empty loop
if
Is_RACW_Controlling_Formal (Current_Parameter, Stub_Type)
then
if Controlling_Parameter = Empty then
Controlling_Parameter :=
Defining_Identifier (Current_Parameter);
else
Insert_Partition_Check (Current_Parameter);
end if;
end if;
Next (Current_Parameter);
end loop;
end;
end if;
if Stub_Type /= Empty then
pragma Assert (Controlling_Parameter /= Empty);
Append_To (Decls,
Make_Object_Declaration (Loc,
Defining_Identifier => Target_Partition,
Constant_Present => True,
Object_Definition =>
New_Occurrence_Of (RTE (RE_Partition_ID), Loc),
Expression =>
Make_Selected_Component (Loc,
Prefix =>
New_Occurrence_Of (Controlling_Parameter, Loc),
Selector_Name =>
Make_Identifier (Loc, Name_Origin))));
RPC_Receiver :=
Make_Selected_Component (Loc,
Prefix =>
New_Occurrence_Of (Controlling_Parameter, Loc),
Selector_Name =>
Make_Identifier (Loc, Name_Receiver));
else
Append_To (Decls,
Make_Object_Declaration (Loc,
Defining_Identifier => Target_Partition,
Constant_Present => True,
Object_Definition =>
New_Occurrence_Of (RTE (RE_Partition_ID), Loc),
Expression =>
Make_Function_Call (Loc,
Name => Make_Selected_Component (Loc,
Prefix =>
Make_Identifier (Loc, Chars (RCI_Locator)),
Selector_Name =>
Make_Identifier (Loc, Name_Get_Active_Partition_ID)))));
RPC_Receiver :=
Make_Selected_Component (Loc,
Prefix =>
Make_Identifier (Loc, Chars (RCI_Locator)),
Selector_Name =>
Make_Identifier (Loc, Name_Get_RCI_Package_Receiver));
end if;
if Dynamically_Asynchronous then
Asynchronous_Expr :=
Make_Selected_Component (Loc,
Prefix =>
New_Occurrence_Of (Controlling_Parameter, Loc),
Selector_Name =>
Make_Identifier (Loc, Name_Asynchronous));
end if;
Build_General_Calling_Stubs
(Decls => Decls,
Statements => Statements,
Target_Partition => Target_Partition,
RPC_Receiver => RPC_Receiver,
Subprogram_Id => Make_Integer_Literal (Loc, Subp_Id),
Asynchronous => Asynchronous_Expr,
Is_Known_Asynchronous => Asynchronous
and then not Dynamically_Asynchronous,
Is_Known_Non_Asynchronous
=> not Asynchronous
and then not Dynamically_Asynchronous,
Is_Function => Nkind (Spec_To_Use) =
N_Function_Specification,
Spec => Spec_To_Use,
Object_Type => Stub_Type,
Nod => Vis_Decl);
RCI_Calling_Stubs_Table.Set
(Defining_Unit_Name (Specification (Vis_Decl)),
Defining_Unit_Name (Spec_To_Use));
return
Make_Subprogram_Body (Loc,
Specification => Subp_Spec,
Declarations => Decls,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc, Statements));
end Build_Subprogram_Calling_Stubs;
function Build_Subprogram_Receiving_Stubs
(Vis_Decl : Node_Id;
Asynchronous : Boolean;
Dynamically_Asynchronous : Boolean := False;
Stub_Type : Entity_Id := Empty;
RACW_Type : Entity_Id := Empty;
Parent_Primitive : Entity_Id := Empty)
return Node_Id
is
Loc : constant Source_Ptr := Sloc (Vis_Decl);
Stream_Parameter : Node_Id;
Result_Parameter : Node_Id;
Decls : List_Id := New_List;
Statements : List_Id := New_List;
Extra_Formal_Statements : List_Id := New_List;
After_Statements : List_Id := New_List;
Inner_Decls : List_Id := No_List;
Excep_Handler : Node_Id;
Excep_Choice : Entity_Id;
Excep_Code : List_Id;
Parameter_List : List_Id := New_List;
Current_Parameter : Node_Id;
Ordered_Parameters_List : constant List_Id :=
Build_Ordered_Parameters_List (Specification (Vis_Decl));
Subp_Spec : Node_Id;
Called_Subprogram : Node_Id;
Null_Raise_Statement : Node_Id;
Dynamic_Async : Entity_Id;
begin
if RACW_Type /= Empty then
Called_Subprogram :=
New_Occurrence_Of (Parent_Primitive, Loc);
else
Called_Subprogram :=
New_Occurrence_Of (
Defining_Unit_Name (Specification (Vis_Decl)), Loc);
end if;
Stream_Parameter :=
Make_Defining_Identifier (Loc, New_Internal_Name ('S'));
if Dynamically_Asynchronous then
Dynamic_Async :=
Make_Defining_Identifier (Loc, New_Internal_Name ('S'));
else
Dynamic_Async := Empty;
end if;
if not Asynchronous or else Dynamically_Asynchronous then
Result_Parameter :=
Make_Defining_Identifier (Loc, New_Internal_Name ('S'));
Null_Raise_Statement :=
Make_Attribute_Reference (Loc,
Prefix =>
New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc),
Attribute_Name => Name_Write,
Expressions => New_List (
New_Occurrence_Of (Result_Parameter, Loc),
New_Occurrence_Of (RTE (RE_Null_Occurrence), Loc)));
if Dynamically_Asynchronous then
Null_Raise_Statement :=
Make_Implicit_If_Statement (Vis_Decl,
Condition =>
Make_Op_Not (Loc, New_Occurrence_Of (Dynamic_Async, Loc)),
Then_Statements => New_List (Null_Raise_Statement));
end if;
Append_To (After_Statements, Null_Raise_Statement);
else
Result_Parameter := Empty;
end if;
Current_Parameter := First (Ordered_Parameters_List);
while Current_Parameter /= Empty loop
declare
Etyp : Entity_Id;
Constrained : Boolean;
Object : Entity_Id;
Expr : Node_Id := Empty;
begin
Object := Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
Set_Ekind (Object, E_Variable);
if
Is_RACW_Controlling_Formal (Current_Parameter, Stub_Type)
then
Etyp := RTE (RE_Unsigned_64);
else
Etyp := Etype (Parameter_Type (Current_Parameter));
end if;
Constrained :=
Is_Constrained (Etyp) or else Is_Elementary_Type (Etyp);
if In_Present (Current_Parameter)
or else not Out_Present (Current_Parameter)
or else not Constrained
then
if Constrained then
Append_To (Statements,
Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (Etyp, Loc),
Attribute_Name => Name_Read,
Expressions => New_List (
New_Occurrence_Of (Stream_Parameter, Loc),
New_Occurrence_Of (Object, Loc))));
else
Expr := Input_With_Tag_Check (Loc,
Var_Type => Etyp,
Stream => Stream_Parameter);
Append_To (Decls, Expr);
Expr := Make_Function_Call (Loc,
New_Occurrence_Of (Defining_Unit_Name
(Specification (Expr)), Loc));
end if;
end if;
Append_To (Decls,
Make_Object_Declaration (Loc,
Defining_Identifier => Object,
Constant_Present =>
not Constrained and then not Out_Present (Current_Parameter),
Object_Definition =>
New_Occurrence_Of (Etyp, Loc),
Expression => Expr));
if Out_Present (Current_Parameter)
and then
Etype (Parameter_Type (Current_Parameter)) /= Stub_Type
then
Append_To (After_Statements,
Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (Etyp, Loc),
Attribute_Name => Name_Write,
Expressions => New_List (
New_Occurrence_Of (Result_Parameter, Loc),
New_Occurrence_Of (Object, Loc))));
end if;
if
Is_RACW_Controlling_Formal (Current_Parameter, Stub_Type)
then
if Nkind (Parameter_Type (Current_Parameter)) /=
N_Access_Definition
then
Append_To (Parameter_List,
Make_Parameter_Association (Loc,
Selector_Name =>
New_Occurrence_Of (
Defining_Identifier (Current_Parameter), Loc),
Explicit_Actual_Parameter =>
Make_Explicit_Dereference (Loc,
Unchecked_Convert_To (RACW_Type,
OK_Convert_To (RTE (RE_Address),
New_Occurrence_Of (Object, Loc))))));
else
Append_To (Parameter_List,
Make_Parameter_Association (Loc,
Selector_Name =>
New_Occurrence_Of (
Defining_Identifier (Current_Parameter), Loc),
Explicit_Actual_Parameter =>
Unchecked_Convert_To (RACW_Type,
OK_Convert_To (RTE (RE_Address),
New_Occurrence_Of (Object, Loc)))));
end if;
else
Append_To (Parameter_List,
Make_Parameter_Association (Loc,
Selector_Name =>
New_Occurrence_Of (
Defining_Identifier (Current_Parameter), Loc),
Explicit_Actual_Parameter =>
New_Occurrence_Of (Object, Loc)));
end if;
if Nkind (Parameter_Type (Current_Parameter)) /=
N_Access_Definition
and then
Ekind (Defining_Identifier (Current_Parameter)) /= E_Void
and then
Present (Extra_Constrained
(Defining_Identifier (Current_Parameter)))
then
declare
Extra_Parameter : constant Entity_Id :=
Extra_Constrained
(Defining_Identifier
(Current_Parameter));
Formal_Entity : constant Entity_Id :=
Make_Defining_Identifier
(Loc, Chars (Extra_Parameter));
Formal_Type : constant Entity_Id :=
Etype (Extra_Parameter);
begin
Append_To (Decls,
Make_Object_Declaration (Loc,
Defining_Identifier => Formal_Entity,
Object_Definition =>
New_Occurrence_Of (Formal_Type, Loc)));
Append_To (Extra_Formal_Statements,
Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (Formal_Type, Loc),
Attribute_Name => Name_Read,
Expressions => New_List (
New_Occurrence_Of (Stream_Parameter, Loc),
New_Occurrence_Of (Formal_Entity, Loc))));
Set_Extra_Constrained (Object, Formal_Entity);
end;
end if;
end;
Next (Current_Parameter);
end loop;
Append_List_To (Statements, Extra_Formal_Statements);
if Nkind (Specification (Vis_Decl)) = N_Function_Specification then
declare
Etyp : constant Entity_Id :=
Etype (Subtype_Mark (Specification (Vis_Decl)));
Result : constant Node_Id :=
Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
begin
Inner_Decls := New_List (
Make_Object_Declaration (Loc,
Defining_Identifier => Result,
Constant_Present => True,
Object_Definition => New_Occurrence_Of (Etyp, Loc),
Expression =>
Make_Function_Call (Loc,
Name => Called_Subprogram,
Parameter_Associations => Parameter_List)));
Append_To (After_Statements,
Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (Etyp, Loc),
Attribute_Name => Name_Output,
Expressions => New_List (
New_Occurrence_Of (Result_Parameter, Loc),
New_Occurrence_Of (Result, Loc))));
end;
Append_To (Statements,
Make_Block_Statement (Loc,
Declarations => Inner_Decls,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => After_Statements)));
else
if Dynamically_Asynchronous then
Append_To (Decls,
Make_Object_Declaration (Loc,
Defining_Identifier => Dynamic_Async,
Object_Definition =>
New_Occurrence_Of (Standard_Boolean, Loc)));
Append_To (Statements,
Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (Standard_Boolean, Loc),
Attribute_Name => Name_Read,
Expressions => New_List (
New_Occurrence_Of (Stream_Parameter, Loc),
New_Occurrence_Of (Dynamic_Async, Loc))));
end if;
Append_To (Statements,
Make_Procedure_Call_Statement (Loc,
Name => Called_Subprogram,
Parameter_Associations => Parameter_List));
Append_List_To (Statements, After_Statements);
end if;
if Asynchronous and then not Dynamically_Asynchronous then
Subp_Spec :=
Make_Procedure_Specification (Loc,
Defining_Unit_Name =>
Make_Defining_Identifier (Loc, New_Internal_Name ('F')),
Parameter_Specifications => New_List (
Make_Parameter_Specification (Loc,
Defining_Identifier => Stream_Parameter,
Parameter_Type =>
Make_Access_Definition (Loc,
Subtype_Mark =>
New_Occurrence_Of (RTE (RE_Params_Stream_Type), Loc)))));
Excep_Handler :=
Make_Exception_Handler (Loc,
Exception_Choices =>
New_List (Make_Others_Choice (Loc)),
Statements => New_List (
Make_Null_Statement (Loc)));
else
Excep_Choice :=
Make_Defining_Identifier (Loc, New_Internal_Name ('E'));
Excep_Code := New_List (
Make_Attribute_Reference (Loc,
Prefix =>
New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc),
Attribute_Name => Name_Write,
Expressions => New_List (
New_Occurrence_Of (Result_Parameter, Loc),
New_Occurrence_Of (Excep_Choice, Loc))));
if Dynamically_Asynchronous then
Excep_Code := New_List (
Make_Implicit_If_Statement (Vis_Decl,
Condition => Make_Op_Not (Loc,
New_Occurrence_Of (Dynamic_Async, Loc)),
Then_Statements => Excep_Code));
end if;
Excep_Handler :=
Make_Exception_Handler (Loc,
Choice_Parameter => Excep_Choice,
Exception_Choices => New_List (Make_Others_Choice (Loc)),
Statements => Excep_Code);
Subp_Spec :=
Make_Procedure_Specification (Loc,
Defining_Unit_Name =>
Make_Defining_Identifier (Loc, New_Internal_Name ('F')),
Parameter_Specifications => New_List (
Make_Parameter_Specification (Loc,
Defining_Identifier => Stream_Parameter,
Parameter_Type =>
Make_Access_Definition (Loc,
Subtype_Mark =>
New_Occurrence_Of (RTE (RE_Params_Stream_Type), Loc))),
Make_Parameter_Specification (Loc,
Defining_Identifier => Result_Parameter,
Parameter_Type =>
Make_Access_Definition (Loc,
Subtype_Mark =>
New_Occurrence_Of (RTE (RE_Params_Stream_Type), Loc)))));
end if;
return
Make_Subprogram_Body (Loc,
Specification => Subp_Spec,
Declarations => Decls,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => Statements,
Exception_Handlers => New_List (Excep_Handler)));
end Build_Subprogram_Receiving_Stubs;
function Copy_Specification
(Loc : Source_Ptr;
Spec : Node_Id;
Object_Type : Entity_Id := Empty;
Stub_Type : Entity_Id := Empty;
New_Name : Name_Id := No_Name)
return Node_Id
is
Parameters : List_Id := No_List;
Current_Parameter : Node_Id;
Current_Type : Node_Id;
Name_For_New_Spec : Name_Id;
New_Identifier : Entity_Id;
begin
if New_Name = No_Name then
Name_For_New_Spec := Chars (Defining_Unit_Name (Spec));
else
Name_For_New_Spec := New_Name;
end if;
if Present (Parameter_Specifications (Spec)) then
Parameters := New_List;
Current_Parameter := First (Parameter_Specifications (Spec));
while Current_Parameter /= Empty loop
Current_Type := Parameter_Type (Current_Parameter);
if Nkind (Current_Type) = N_Access_Definition then
if Object_Type = Empty then
Current_Type :=
Make_Access_Definition (Loc,
Subtype_Mark =>
New_Occurrence_Of (Etype (
Subtype_Mark (Current_Type)), Loc));
else
pragma Assert
(Root_Type (Etype (Subtype_Mark (Current_Type)))
= Root_Type (Object_Type));
Current_Type :=
Make_Access_Definition (Loc,
Subtype_Mark => New_Occurrence_Of (Stub_Type, Loc));
end if;
elsif Object_Type /= Empty
and then Etype (Current_Type) = Object_Type
then
Current_Type := New_Occurrence_Of (Stub_Type, Loc);
else
Current_Type := New_Occurrence_Of (Etype (Current_Type), Loc);
end if;
New_Identifier := Make_Defining_Identifier (Loc,
Chars (Defining_Identifier (Current_Parameter)));
Append_To (Parameters,
Make_Parameter_Specification (Loc,
Defining_Identifier => New_Identifier,
Parameter_Type => Current_Type,
In_Present => In_Present (Current_Parameter),
Out_Present => Out_Present (Current_Parameter),
Expression =>
New_Copy_Tree (Expression (Current_Parameter))));
Next (Current_Parameter);
end loop;
end if;
if Nkind (Spec) = N_Function_Specification then
return
Make_Function_Specification (Loc,
Defining_Unit_Name =>
Make_Defining_Identifier (Loc,
Chars => Name_For_New_Spec),
Parameter_Specifications => Parameters,
Subtype_Mark =>
New_Occurrence_Of (Etype (Subtype_Mark (Spec)), Loc));
else
return
Make_Procedure_Specification (Loc,
Defining_Unit_Name =>
Make_Defining_Identifier (Loc,
Chars => Name_For_New_Spec),
Parameter_Specifications => Parameters);
end if;
end Copy_Specification;
function Could_Be_Asynchronous (Spec : Node_Id) return Boolean is
Current_Parameter : Node_Id;
begin
if Present (Parameter_Specifications (Spec)) then
Current_Parameter := First (Parameter_Specifications (Spec));
while Current_Parameter /= Empty loop
if Out_Present (Current_Parameter) then
return False;
end if;
Next (Current_Parameter);
end loop;
end if;
return True;
end Could_Be_Asynchronous;
procedure Expand_All_Calls_Remote_Subprogram_Call (N : in Node_Id) is
Called_Subprogram : constant Entity_Id := Entity (Name (N));
RCI_Package : constant Entity_Id := Scope (Called_Subprogram);
Loc : constant Source_Ptr := Sloc (N);
RCI_Locator : Node_Id;
RCI_Cache : Entity_Id;
Calling_Stubs : Node_Id;
E_Calling_Stubs : Entity_Id;
begin
E_Calling_Stubs := RCI_Calling_Stubs_Table.Get (Called_Subprogram);
if E_Calling_Stubs = Empty then
RCI_Cache := RCI_Locator_Table.Get (RCI_Package);
if RCI_Cache = Empty then
RCI_Locator :=
RCI_Package_Locator
(Loc, Specification (Unit_Declaration_Node (RCI_Package)));
Prepend_To (Current_Sem_Unit_Declarations, RCI_Locator);
declare
Scop : Entity_Id := Cunit_Entity (Current_Sem_Unit);
begin
if Ekind (Scop) = E_Package_Body then
New_Scope (Spec_Entity (Scop));
elsif Ekind (Scop) = E_Subprogram_Body then
New_Scope
(Corresponding_Spec (Unit_Declaration_Node (Scop)));
else
New_Scope (Scop);
end if;
Analyze (RCI_Locator);
Pop_Scope;
end;
RCI_Cache := Defining_Unit_Name (RCI_Locator);
else
RCI_Locator := Parent (RCI_Cache);
end if;
Calling_Stubs := Build_Subprogram_Calling_Stubs
(Vis_Decl => Parent (Parent (Called_Subprogram)),
Subp_Id => Get_Subprogram_Id (Called_Subprogram),
Asynchronous => Nkind (N) = N_Procedure_Call_Statement
and then
Is_Asynchronous (Called_Subprogram),
Locator => RCI_Cache,
New_Name => New_Internal_Name ('S'));
Insert_After (RCI_Locator, Calling_Stubs);
Analyze (Calling_Stubs);
E_Calling_Stubs := Defining_Unit_Name (Specification (Calling_Stubs));
end if;
Rewrite (Name (N), New_Occurrence_Of (E_Calling_Stubs, Loc));
end Expand_All_Calls_Remote_Subprogram_Call;
procedure Expand_Calling_Stubs_Bodies (Unit_Node : in Node_Id) is
Spec : constant Node_Id := Specification (Unit_Node);
Decls : constant List_Id := Visible_Declarations (Spec);
begin
New_Scope (Scope_Of_Spec (Spec));
Add_Calling_Stubs_To_Declarations (Specification (Unit_Node),
Decls);
Pop_Scope;
end Expand_Calling_Stubs_Bodies;
procedure Expand_Receiving_Stubs_Bodies (Unit_Node : in Node_Id) is
Spec : Node_Id;
Decls : List_Id;
Temp : List_Id;
begin
if Nkind (Unit_Node) = N_Package_Declaration then
Spec := Specification (Unit_Node);
Decls := Visible_Declarations (Spec);
New_Scope (Scope_Of_Spec (Spec));
Add_Receiving_Stubs_To_Declarations (Spec, Decls);
else
Spec :=
Package_Specification_Of_Scope (Corresponding_Spec (Unit_Node));
Decls := Declarations (Unit_Node);
New_Scope (Scope_Of_Spec (Unit_Node));
Temp := New_List;
Add_Receiving_Stubs_To_Declarations (Spec, Temp);
Insert_List_Before (First (Decls), Temp);
end if;
Pop_Scope;
end Expand_Receiving_Stubs_Bodies;
function Get_Pkg_Name_String_Id (Decl_Node : Node_Id) return String_Id is
Unit_Name_Id : Unit_Name_Type := Get_Unit_Name (Decl_Node);
begin
Get_Unit_Name_String (Unit_Name_Id);
Name_Len := Name_Len - 7;
pragma Assert (Name_Buffer (Name_Len + 1) = ' ');
return Get_String_Id (Name_Buffer (1 .. Name_Len));
end Get_Pkg_Name_String_Id;
function Get_String_Id (Val : String) return String_Id is
begin
Start_String;
Store_String_Chars (Val);
return End_String;
end Get_String_Id;
function Hash (F : Entity_Id) return Hash_Index is
begin
return Hash_Index (Natural (F) mod Positive (Hash_Index'Last + 1));
end Hash;
function Input_With_Tag_Check
(Loc : Source_Ptr;
Var_Type : Entity_Id;
Stream : Entity_Id)
return Node_Id
is
begin
return
Make_Subprogram_Body (Loc,
Specification => Make_Function_Specification (Loc,
Defining_Unit_Name =>
Make_Defining_Identifier (Loc, New_Internal_Name ('S')),
Subtype_Mark => New_Occurrence_Of (Var_Type, Loc)),
Declarations => No_List,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc, New_List (
Make_Tag_Check (Loc,
Make_Return_Statement (Loc,
Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (Var_Type, Loc),
Attribute_Name => Name_Input,
Expressions =>
New_List (New_Occurrence_Of (Stream, Loc))))))));
end Input_With_Tag_Check;
function Is_RACW_Controlling_Formal
(Parameter : Node_Id;
Stub_Type : Entity_Id)
return Boolean
is
Typ : Entity_Id;
begin
if Ekind (Defining_Identifier (Parameter)) = E_Void then
return False;
end if;
if not Is_Controlling_Formal (Defining_Identifier (Parameter)) then
return False;
end if;
Typ := Parameter_Type (Parameter);
return (Nkind (Typ) = N_Access_Definition
and then Etype (Subtype_Mark (Typ)) = Stub_Type)
or else Etype (Typ) = Stub_Type;
end Is_RACW_Controlling_Formal;
function Make_Tag_Check (Loc : Source_Ptr; N : Node_Id) return Node_Id is
Occ : constant Entity_Id :=
Make_Defining_Identifier (Loc, New_Internal_Name ('E'));
begin
return Make_Block_Statement (Loc,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => New_List (N),
Exception_Handlers => New_List (
Make_Exception_Handler (Loc,
Choice_Parameter => Occ,
Exception_Choices =>
New_List (New_Occurrence_Of (RTE (RE_Tag_Error), Loc)),
Statements =>
New_List (Make_Procedure_Call_Statement (Loc,
New_Occurrence_Of
(RTE (RE_Raise_Program_Error_Unknown_Tag), Loc),
New_List (New_Occurrence_Of (Occ, Loc))))))));
end Make_Tag_Check;
function Need_Extra_Constrained (Parameter : Node_Id) return Boolean is
Etyp : constant Entity_Id := Etype (Parameter_Type (Parameter));
begin
return Out_Present (Parameter)
and then Has_Discriminants (Etyp)
and then not Is_Constrained (Etyp)
and then not Is_Indefinite_Subtype (Etyp);
end Need_Extra_Constrained;
function Pack_Entity_Into_Stream_Access
(Loc : Source_Ptr;
Stream : Entity_Id;
Object : Entity_Id;
Etyp : Entity_Id := Empty)
return Node_Id
is
Typ : Entity_Id;
begin
if Etyp /= Empty then
Typ := Etyp;
else
Typ := Etype (Object);
end if;
return
Pack_Node_Into_Stream_Access (Loc,
Stream => Stream,
Object => New_Occurrence_Of (Object, Loc),
Etyp => Typ);
end Pack_Entity_Into_Stream_Access;
function Pack_Node_Into_Stream
(Loc : Source_Ptr;
Stream : Entity_Id;
Object : Node_Id;
Etyp : Entity_Id)
return Node_Id
is
Write_Attribute : Name_Id := Name_Write;
begin
if not Is_Constrained (Etyp) then
Write_Attribute := Name_Output;
end if;
return
Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (Etyp, Loc),
Attribute_Name => Write_Attribute,
Expressions => New_List (
Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (Stream, Loc),
Attribute_Name => Name_Access),
Object));
end Pack_Node_Into_Stream;
function Pack_Node_Into_Stream_Access
(Loc : Source_Ptr;
Stream : Entity_Id;
Object : Node_Id;
Etyp : Entity_Id)
return Node_Id
is
Write_Attribute : Name_Id := Name_Write;
begin
if not Is_Constrained (Etyp) then
Write_Attribute := Name_Output;
end if;
return
Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (Etyp, Loc),
Attribute_Name => Write_Attribute,
Expressions => New_List (
New_Occurrence_Of (Stream, Loc),
Object));
end Pack_Node_Into_Stream_Access;
procedure RACW_Type_Is_Asynchronous (RACW_Type : in Entity_Id) is
N : constant Node_Id := Asynchronous_Flags_Table.Get (RACW_Type);
pragma Assert (N /= Empty);
begin
Replace (N, New_Occurrence_Of (Standard_True, Sloc (N)));
end RACW_Type_Is_Asynchronous;
function RCI_Package_Locator
(Loc : Source_Ptr;
Package_Spec : Node_Id)
return Node_Id
is
Inst : constant Node_Id :=
Make_Package_Instantiation (Loc,
Defining_Unit_Name =>
Make_Defining_Identifier (Loc, New_Internal_Name ('R')),
Name =>
New_Occurrence_Of (RTE (RE_RCI_Info), Loc),
Generic_Associations => New_List (
Make_Generic_Association (Loc,
Selector_Name =>
Make_Identifier (Loc, Name_RCI_Name),
Explicit_Generic_Actual_Parameter =>
Make_String_Literal (Loc,
Strval => Get_Pkg_Name_String_Id (Package_Spec)))));
begin
RCI_Locator_Table.Set (Defining_Unit_Name (Package_Spec),
Defining_Unit_Name (Inst));
return Inst;
end RCI_Package_Locator;
procedure Remote_Types_Tagged_Full_View_Encountered
(Full_View : in Entity_Id)
is
Stub_Elements : constant Stub_Structure :=
Stubs_Table.Get (Full_View);
begin
if Stub_Elements /= Empty_Stub_Structure then
Add_RACW_Primitive_Declarations_And_Bodies
(Full_View,
Parent (Declaration_Node (Stub_Elements.Object_RPC_Receiver)),
List_Containing (Declaration_Node (Full_View)));
end if;
end Remote_Types_Tagged_Full_View_Encountered;
function Scope_Of_Spec (Spec : Node_Id) return Entity_Id is
Unit_Name : Node_Id := Defining_Unit_Name (Spec);
begin
while Nkind (Unit_Name) /= N_Defining_Identifier loop
Unit_Name := Defining_Identifier (Unit_Name);
end loop;
return Unit_Name;
end Scope_Of_Spec;
end Exp_Dist;