with Atree; use Atree;
with Einfo; use Einfo;
with Elists; use Elists;
with Exp_Strm; use Exp_Strm;
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_Eval; use Sem_Eval;
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 Ttypes; use Ttypes;
with Uintp; use Uintp;
package body Exp_Dist is
First_RCI_Subprogram_Id : constant := 2;
type Hash_Index is range 0 .. 50;
function Hash (F : Entity_Id) return Hash_Index;
function Hash (F : Name_Id) return Hash_Index;
type Subprogram_Identifiers is record
Str_Identifier : String_Id;
Int_Identifier : Int;
end record;
package Subprogram_Identifier_Table is
new Simple_HTable (Header_Num => Hash_Index,
Element => Subprogram_Identifiers,
No_Element => (No_String, 0),
Key => Entity_Id,
Hash => Hash,
Equal => "=");
package Overload_Counter_Table is
new Simple_HTable (Header_Num => Hash_Index,
Element => Int,
No_Element => 0,
Key => Name_Id,
Hash => Hash,
Equal => "=");
function Get_Subprogram_Ids (Def : Entity_Id) return Subprogram_Identifiers;
function Get_Subprogram_Id (Def : Entity_Id) return String_Id;
function Get_Subprogram_Id (Def : Entity_Id) return Int;
pragma Warnings (Off, Get_Subprogram_Id);
function Get_PCS_Name return PCS_Names;
procedure Add_RAS_Dereference_TSS (N : Node_Id);
procedure Add_RAS_Proxy_And_Analyze
(Decls : List_Id;
Vis_Decl : Node_Id;
All_Calls_Remote_E : Entity_Id;
Proxy_Object_Addr : out Entity_Id);
function Build_Remote_Subprogram_Proxy_Type
(Loc : Source_Ptr;
ACR_Expression : Node_Id) return Node_Id;
function Build_Get_Unique_RP_Call
(Loc : Source_Ptr;
Pointer : Entity_Id;
Stub_Type : Entity_Id) return List_Id;
function Build_Subprogram_Calling_Stubs
(Vis_Decl : Node_Id;
Subp_Id : Node_Id;
Asynchronous : Boolean;
Dynamically_Asynchronous : Boolean := False;
Stub_Type : Entity_Id := Empty;
RACW_Type : Entity_Id := Empty;
Locator : Entity_Id := Empty;
New_Name : Name_Id := No_Name) return Node_Id;
function Build_RPC_Receiver_Specification
(RPC_Receiver : Entity_Id;
Request_Parameter : Entity_Id) return Node_Id;
function Build_Ordered_Parameters_List (Spec : Node_Id) return List_Id;
procedure Add_Calling_Stubs_To_Declarations
(Pkg_Spec : Node_Id;
Decls : List_Id);
function Could_Be_Asynchronous (Spec : Node_Id) return Boolean;
function Pack_Entity_Into_Stream_Access
(Loc : Source_Ptr;
Stream : Node_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 : Node_Id;
Object : Node_Id;
Etyp : Entity_Id) return Node_Id;
function Make_Selected_Component
(Loc : Source_Ptr;
Prefix : Entity_Id;
Selector_Name : Name_Id) return Node_Id;
function Scope_Of_Spec (Spec : Node_Id) return Entity_Id;
procedure Set_Renaming_TSS
(Typ : Entity_Id;
Nam : Entity_Id;
TSS_Nam : Name_Id);
function Need_Extra_Constrained (Parameter : Node_Id) return Boolean;
function Is_RACW_Controlling_Formal
(Parameter : Node_Id; Stub_Type : Entity_Id) return Boolean;
procedure Declare_Create_NVList
(Loc : Source_Ptr;
NVList : Entity_Id;
Decls : List_Id;
Stmts : List_Id);
function Add_Parameter_To_NVList
(Loc : Source_Ptr;
NVList : Entity_Id;
Parameter : Entity_Id;
Constrained : Boolean;
RACW_Ctrl : Boolean := False;
Any : Entity_Id) return Node_Id;
type Stub_Structure is record
Stub_Type : Entity_Id;
Stub_Type_Access : Entity_Id;
RPC_Receiver_Decl : Node_Id;
RACW_Type : Entity_Id;
end record;
Empty_Stub_Structure : constant Stub_Structure :=
(Empty, Empty, Empty, Empty);
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 => Entity_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 : Entity_Id;
RACW_Type : Entity_Id;
Decls : List_Id;
Stub_Type : out Entity_Id;
Stub_Type_Access : out Entity_Id;
RPC_Receiver_Decl : out Node_Id;
Existing : out Boolean);
procedure Add_RACW_Asynchronous_Flag
(Declarations : List_Id;
RACW_Type : Entity_Id);
procedure Assign_Subprogram_Identifier
(Def : Entity_Id;
Spn : Int;
Id : out String_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 : Node_Id) return Node_Id;
procedure Specific_Add_RACW_Features
(RACW_Type : Entity_Id;
Desig : Entity_Id;
Stub_Type : Entity_Id;
Stub_Type_Access : Entity_Id;
RPC_Receiver_Decl : Node_Id;
Declarations : List_Id);
procedure Specific_Add_RAST_Features
(Vis_Decl : Node_Id;
RAS_Type : Entity_Id;
Decls : List_Id);
type RPC_Target (PCS_Kind : PCS_Names) is record
case PCS_Kind is
when Name_PolyORB_DSA =>
Object : Node_Id;
when others =>
Partition : Entity_Id;
RPC_Receiver : Node_Id;
end case;
end record;
procedure Specific_Build_General_Calling_Stubs
(Decls : List_Id;
Statements : List_Id;
Target : RPC_Target;
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;
Stub_Type : Entity_Id := Empty;
RACW_Type : Entity_Id := Empty;
Nod : Node_Id);
function Specific_Build_Stub_Target
(Loc : Source_Ptr;
Decls : List_Id;
RCI_Locator : Entity_Id;
Controlling_Parameter : Entity_Id) return RPC_Target;
procedure Specific_Build_Stub_Type
(RACW_Type : Entity_Id;
Stub_Type : Entity_Id;
Stub_Type_Decl : out Node_Id;
RPC_Receiver_Decl : out Node_Id);
procedure Specific_Build_RPC_Receiver_Body
(RPC_Receiver : Entity_Id;
Request : out Entity_Id;
Subp_Id : out Entity_Id;
Subp_Index : out Entity_Id;
Stmts : out List_Id;
Decl : out Node_Id);
function Specific_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;
procedure Specific_Add_Obj_RPC_Receiver_Completion
(Loc : Source_Ptr;
Decls : List_Id;
RPC_Receiver : Entity_Id;
Stub_Elements : Stub_Structure);
procedure Specific_Add_Receiving_Stubs_To_Declarations
(Pkg_Spec : Node_Id;
Decls : List_Id);
package GARLIC_Support is
procedure Add_RACW_Features
(RACW_Type : Entity_Id;
Stub_Type : Entity_Id;
Stub_Type_Access : Entity_Id;
RPC_Receiver_Decl : Node_Id;
Declarations : List_Id);
procedure Add_RAST_Features
(Vis_Decl : Node_Id;
RAS_Type : Entity_Id;
Decls : List_Id);
procedure Build_General_Calling_Stubs
(Decls : List_Id;
Statements : List_Id;
Target_Partition : Entity_Id; Target_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;
Stub_Type : Entity_Id := Empty;
RACW_Type : Entity_Id := Empty;
Nod : Node_Id);
function Build_Stub_Target
(Loc : Source_Ptr;
Decls : List_Id;
RCI_Locator : Entity_Id;
Controlling_Parameter : Entity_Id) return RPC_Target;
procedure Build_Stub_Type
(RACW_Type : Entity_Id;
Stub_Type : Entity_Id;
Stub_Type_Decl : out Node_Id;
RPC_Receiver_Decl : out 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;
procedure Add_Obj_RPC_Receiver_Completion
(Loc : Source_Ptr;
Decls : List_Id;
RPC_Receiver : Entity_Id;
Stub_Elements : Stub_Structure);
procedure Add_Receiving_Stubs_To_Declarations
(Pkg_Spec : Node_Id;
Decls : List_Id);
procedure Build_RPC_Receiver_Body
(RPC_Receiver : Entity_Id;
Request : out Entity_Id;
Subp_Id : out Entity_Id;
Subp_Index : out Entity_Id;
Stmts : out List_Id;
Decl : out Node_Id);
end GARLIC_Support;
package PolyORB_Support is
procedure Add_RACW_Features
(RACW_Type : Entity_Id;
Desig : Entity_Id;
Stub_Type : Entity_Id;
Stub_Type_Access : Entity_Id;
RPC_Receiver_Decl : Node_Id;
Declarations : List_Id);
procedure Add_RAST_Features
(Vis_Decl : Node_Id;
RAS_Type : Entity_Id;
Decls : List_Id);
procedure Build_General_Calling_Stubs
(Decls : List_Id;
Statements : List_Id;
Target_Object : 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;
Stub_Type : Entity_Id := Empty;
RACW_Type : Entity_Id := Empty;
Nod : Node_Id);
function Build_Stub_Target
(Loc : Source_Ptr;
Decls : List_Id;
RCI_Locator : Entity_Id;
Controlling_Parameter : Entity_Id) return RPC_Target;
procedure Build_Stub_Type
(RACW_Type : Entity_Id;
Stub_Type : Entity_Id;
Stub_Type_Decl : out Node_Id;
RPC_Receiver_Decl : out 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;
procedure Add_Obj_RPC_Receiver_Completion
(Loc : Source_Ptr;
Decls : List_Id;
RPC_Receiver : Entity_Id;
Stub_Elements : Stub_Structure);
procedure Add_Receiving_Stubs_To_Declarations
(Pkg_Spec : Node_Id;
Decls : List_Id);
procedure Build_RPC_Receiver_Body
(RPC_Receiver : Entity_Id;
Request : out Entity_Id;
Subp_Id : out Entity_Id;
Subp_Index : out Entity_Id;
Stmts : out List_Id;
Decl : out Node_Id);
procedure Reserve_NamingContext_Methods;
package Helpers is
function Build_From_Any_Call
(Typ : Entity_Id;
N : Node_Id;
Decls : List_Id) return Node_Id;
procedure Build_From_Any_Function
(Loc : Source_Ptr;
Typ : Entity_Id;
Decl : out Node_Id;
Fnam : out Entity_Id);
function Build_To_Any_Call
(N : Node_Id;
Decls : List_Id) return Node_Id;
procedure Build_To_Any_Function
(Loc : Source_Ptr;
Typ : Entity_Id;
Decl : out Node_Id;
Fnam : out Entity_Id);
function Build_TypeCode_Call
(Loc : Source_Ptr;
Typ : Entity_Id;
Decls : List_Id) return Node_Id;
procedure Build_TypeCode_Function
(Loc : Source_Ptr;
Typ : Entity_Id;
Decl : out Node_Id;
Fnam : out Entity_Id);
procedure Build_Name_And_Repository_Id
(E : Entity_Id;
Name_Str : out String_Id;
Repo_Id_Str : out String_Id);
end Helpers;
end PolyORB_Support;
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 : Node_Id;
Decls : List_Id)
is
Current_Subprogram_Number : Int := First_RCI_Subprogram_Id;
Current_Declaration : Node_Id;
Loc : constant Source_Ptr := Sloc (Pkg_Spec);
RCI_Instantiation : Node_Id;
Subp_Stubs : Node_Id;
Subp_Str : String_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);
Overload_Counter_Table.Reset;
PolyORB_Support.Reserve_NamingContext_Methods;
Current_Declaration := First (Visible_Declarations (Pkg_Spec));
while Present (Current_Declaration) loop
if Nkind (Current_Declaration) = N_Subprogram_Declaration
and then Comes_From_Source (Current_Declaration)
then
Assign_Subprogram_Identifier (
Defining_Unit_Name (Specification (Current_Declaration)),
Current_Subprogram_Number,
Subp_Str);
Subp_Stubs :=
Build_Subprogram_Calling_Stubs (
Vis_Decl => Current_Declaration,
Subp_Id =>
Build_Subprogram_Id (Loc,
Defining_Unit_Name (Specification (Current_Declaration))),
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;
function Add_Parameter_To_NVList
(Loc : Source_Ptr;
NVList : Entity_Id;
Parameter : Entity_Id;
Constrained : Boolean;
RACW_Ctrl : Boolean := False;
Any : Entity_Id) return Node_Id
is
Parameter_Name_String : String_Id;
Parameter_Mode : Node_Id;
function Parameter_Passing_Mode
(Loc : Source_Ptr;
Parameter : Entity_Id;
Constrained : Boolean) return Node_Id;
function Parameter_Passing_Mode
(Loc : Source_Ptr;
Parameter : Entity_Id;
Constrained : Boolean) return Node_Id
is
Lib_RE : RE_Id;
begin
if Out_Present (Parameter) then
if In_Present (Parameter)
or else not Constrained
then
Lib_RE := RE_Mode_Inout;
else
Lib_RE := RE_Mode_Out;
end if;
else
Lib_RE := RE_Mode_In;
end if;
return New_Occurrence_Of (RTE (Lib_RE), Loc);
end Parameter_Passing_Mode;
begin
if Nkind (Parameter) = N_Defining_Identifier then
Get_Name_String (Chars (Parameter));
else
Get_Name_String (Chars (Defining_Identifier
(Parameter)));
end if;
Parameter_Name_String := String_From_Name_Buffer;
if RACW_Ctrl then
Parameter_Mode := New_Occurrence_Of
(RTE (RE_Mode_In), Loc);
else
Parameter_Mode := Parameter_Passing_Mode (Loc,
Parameter, Constrained);
end if;
return
Make_Procedure_Call_Statement (Loc,
Name =>
New_Occurrence_Of
(RTE (RE_NVList_Add_Item), Loc),
Parameter_Associations => New_List (
New_Occurrence_Of (NVList, Loc),
Make_Function_Call (Loc,
Name =>
New_Occurrence_Of
(RTE (RE_To_PolyORB_String), Loc),
Parameter_Associations => New_List (
Make_String_Literal (Loc,
Strval => Parameter_Name_String))),
New_Occurrence_Of (Any, Loc),
Parameter_Mode));
end Add_Parameter_To_NVList;
procedure Add_RACW_Asynchronous_Flag
(Declarations : List_Id;
RACW_Type : Entity_Id)
is
Loc : constant Source_Ptr := Sloc (RACW_Type);
Asynchronous_Flag : constant Entity_Id :=
Make_Defining_Identifier (Loc,
New_External_Name (Chars (RACW_Type), 'A'));
begin
Append_To (Declarations,
Make_Object_Declaration (Loc,
Defining_Identifier => Asynchronous_Flag,
Constant_Present => True,
Object_Definition => New_Occurrence_Of (Standard_Boolean, Loc),
Expression => New_Occurrence_Of (Standard_False, Loc)));
Asynchronous_Flags_Table.Set (RACW_Type, Asynchronous_Flag);
end Add_RACW_Asynchronous_Flag;
procedure Add_RACW_Features (RACW_Type : 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;
RPC_Receiver_Decl : Node_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,
RPC_Receiver_Decl => RPC_Receiver_Decl,
Existing => Existing);
Add_RACW_Asynchronous_Flag
(Declarations => Decls,
RACW_Type => RACW_Type);
Specific_Add_RACW_Features
(RACW_Type => RACW_Type,
Desig => Desig,
Stub_Type => Stub_Type,
Stub_Type_Access => Stub_Type_Access,
RPC_Receiver_Decl => RPC_Receiver_Decl,
Declarations => Decls);
if not Same_Scope and then not Existing then
Add_RACW_Primitive_Declarations_And_Bodies
(Designated_Type => Desig,
Insertion_Node => RPC_Receiver_Decl,
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 : Entity_Id;
Insertion_Node : Node_Id;
Decls : 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);
Is_RAS : constant Boolean :=
not Comes_From_Source (Stub_Elements.RACW_Type);
Current_Insertion_Node : Node_Id := Insertion_Node;
RPC_Receiver : Entity_Id;
RPC_Receiver_Statements : List_Id;
RPC_Receiver_Case_Alternatives : constant List_Id := New_List;
RPC_Receiver_Elsif_Parts : List_Id;
RPC_Receiver_Request : Entity_Id;
RPC_Receiver_Subp_Id : Entity_Id;
RPC_Receiver_Subp_Index : Entity_Id;
Subp_Str : String_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 not Is_RAS then
RPC_Receiver := Make_Defining_Identifier (Loc,
New_Internal_Name ('P'));
Specific_Build_RPC_Receiver_Body (
RPC_Receiver => RPC_Receiver,
Request => RPC_Receiver_Request,
Subp_Id => RPC_Receiver_Subp_Id,
Subp_Index => RPC_Receiver_Subp_Index,
Stmts => RPC_Receiver_Statements,
Decl => RPC_Receiver_Decl);
if Get_PCS_Name = Name_PolyORB_DSA then
RPC_Receiver_Elsif_Parts := New_List;
Append_To (RPC_Receiver_Statements,
Make_Implicit_If_Statement (Designated_Type,
Condition => New_Occurrence_Of (Standard_False, Loc),
Then_Statements => New_List,
Elsif_Parts => RPC_Receiver_Elsif_Parts));
end if;
end if;
if Present (Primitive_Operations (Designated_Type)) then
Overload_Counter_Table.Reset;
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_uAlignment
and then not Is_TSS (Current_Primitive, TSS_Deep_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);
Assign_Subprogram_Identifier (
Defining_Unit_Name (Current_Primitive_Spec),
Current_Primitive_Number,
Subp_Str);
Current_Primitive_Body :=
Build_Subprogram_Calling_Stubs
(Vis_Decl => Current_Primitive_Decl,
Subp_Id =>
Build_Subprogram_Id (Loc,
Defining_Unit_Name (Current_Primitive_Spec)),
Asynchronous => Possibly_Asynchronous,
Dynamically_Asynchronous => Possibly_Asynchronous,
Stub_Type => Stub_Elements.Stub_Type,
RACW_Type => Stub_Elements.RACW_Type);
Append_To (Decls, Current_Primitive_Body);
if not Is_RAS then
Current_Receiver_Body :=
Specific_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);
if Get_PCS_Name = Name_PolyORB_DSA then
Append_To (RPC_Receiver_Elsif_Parts,
Make_Elsif_Part (Loc,
Condition =>
Make_Function_Call (Loc,
Name =>
New_Occurrence_Of (
RTE (RE_Caseless_String_Eq), Loc),
Parameter_Associations => New_List (
New_Occurrence_Of (RPC_Receiver_Subp_Id, Loc),
Make_String_Literal (Loc, Subp_Str))),
Then_Statements => New_List (
Make_Assignment_Statement (Loc,
Name => New_Occurrence_Of (
RPC_Receiver_Subp_Index, Loc),
Expression =>
Make_Integer_Literal (Loc,
Current_Primitive_Number)))));
end if;
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 (RPC_Receiver_Request, Loc))))));
end if;
Current_Primitive_Number := Current_Primitive_Number + 1;
end if;
Next_Elmt (Current_Primitive_Elmt);
end loop;
end if;
if not Is_RAS then
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))));
Append_To (RPC_Receiver_Statements,
Make_Case_Statement (Loc,
Expression =>
New_Occurrence_Of (RPC_Receiver_Subp_Index, Loc),
Alternatives => RPC_Receiver_Case_Alternatives));
Append_To (Decls, RPC_Receiver_Decl);
Specific_Add_Obj_RPC_Receiver_Completion (Loc,
Decls, RPC_Receiver, Stub_Elements);
end if;
end Add_RACW_Primitive_Declarations_And_Bodies;
procedure Add_RAS_Dereference_TSS (N : 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);
RACW_Type : constant Entity_Id := Underlying_RACW_Type (RAS_Type);
Desig : constant Entity_Id := Etype (Designated_Type (RACW_Type));
Stub_Elements : constant Stub_Structure := Stubs_Table.Get (Desig);
pragma Assert (Stub_Elements /= Empty_Stub_Structure);
RACW_Primitive_Name : Node_Id;
Proc : constant Entity_Id :=
Make_Defining_Identifier (Loc,
Chars => Make_TSS_Name (RAS_Type, TSS_RAS_Dereference));
Proc_Spec : Node_Id;
Param_Specs : List_Id;
Param_Assoc : constant List_Id := New_List;
Stmts : constant List_Id := New_List;
RAS_Parameter : constant Entity_Id :=
Make_Defining_Identifier (Loc,
Chars => New_Internal_Name ('P'));
Is_Function : constant Boolean :=
Nkind (Type_Def) = N_Access_Function_Definition;
Is_Degenerate : Boolean;
Spec : constant Node_Id := Type_Def;
Current_Parameter : Node_Id;
begin
Param_Specs := New_List (
Make_Parameter_Specification (Loc,
Defining_Identifier => RAS_Parameter,
In_Present => True,
Parameter_Type =>
New_Occurrence_Of (Fat_Type, Loc)));
Is_Degenerate := False;
Current_Parameter := First (Parameter_Specifications (Type_Def));
Parameters : while Present (Current_Parameter) loop
if Nkind (Parameter_Type (Current_Parameter))
= N_Access_Definition
then
Is_Degenerate := True;
end if;
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_Copy_Tree (Parameter_Type (Current_Parameter)),
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 Parameters;
if Is_Degenerate then
Prepend_To (Param_Assoc, New_Occurrence_Of (RAS_Parameter, Loc));
Append_To (Stmts,
Make_Raise_Program_Error (Loc, Reason => PE_Explicit_Raise));
RACW_Primitive_Name := New_Occurrence_Of (Proc, Loc);
else
Prepend_To (Param_Assoc,
Unchecked_Convert_To (RACW_Type,
New_Occurrence_Of (RAS_Parameter, Loc)));
RACW_Primitive_Name := Make_Selected_Component (Loc,
Prefix => Scope (RACW_Type),
Selector_Name => Name_Call);
end if;
if Is_Function then
Append_To (Stmts,
Make_Return_Statement (Loc,
Expression =>
Make_Function_Call (Loc,
Name =>
RACW_Primitive_Name,
Parameter_Associations => Param_Assoc)));
else
Append_To (Stmts,
Make_Procedure_Call_Statement (Loc,
Name =>
RACW_Primitive_Name,
Parameter_Associations => Param_Assoc));
end if;
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;
Discard_Node (
Make_Subprogram_Body (Loc,
Specification => Proc_Spec,
Declarations => New_List,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => Stmts)));
Set_TSS (Fat_Type, Proc);
end Add_RAS_Dereference_TSS;
procedure Add_RAS_Proxy_And_Analyze
(Decls : List_Id;
Vis_Decl : Node_Id;
All_Calls_Remote_E : Entity_Id;
Proxy_Object_Addr : out Entity_Id)
is
Loc : constant Source_Ptr := Sloc (Vis_Decl);
Subp_Name : constant Entity_Id :=
Defining_Unit_Name (Specification (Vis_Decl));
Pkg_Name : constant Entity_Id :=
Make_Defining_Identifier (Loc,
Chars =>
New_External_Name (Chars (Subp_Name), 'P', -1));
Proxy_Type : constant Entity_Id :=
Make_Defining_Identifier (Loc,
Chars =>
New_External_Name (
Related_Id => Chars (Subp_Name),
Suffix => 'P'));
Proxy_Type_Full_View : constant Entity_Id :=
Make_Defining_Identifier (Loc,
Chars (Proxy_Type));
Subp_Decl_Spec : constant Node_Id :=
Build_RAS_Primitive_Specification
(Subp_Spec => Specification (Vis_Decl),
Remote_Object_Type => Proxy_Type);
Subp_Body_Spec : constant Node_Id :=
Build_RAS_Primitive_Specification
(Subp_Spec => Specification (Vis_Decl),
Remote_Object_Type => Proxy_Type);
Vis_Decls : constant List_Id := New_List;
Pvt_Decls : constant List_Id := New_List;
Actuals : constant List_Id := New_List;
Formal : Node_Id;
Perform_Call : Node_Id;
begin
Append_To (Vis_Decls,
Make_Private_Type_Declaration (Loc,
Defining_Identifier => Proxy_Type,
Tagged_Present => True,
Limited_Present => True));
Append_To (Vis_Decls,
Make_Subprogram_Declaration (Loc,
Specification => Subp_Decl_Spec));
Proxy_Object_Addr := Make_Defining_Identifier (Loc, Name_uA);
Append_To (Vis_Decls,
Make_Object_Declaration (Loc,
Defining_Identifier =>
Proxy_Object_Addr,
Constant_Present =>
True,
Object_Definition =>
New_Occurrence_Of (RTE (RE_Address), Loc)));
Append_To (Pvt_Decls,
Make_Full_Type_Declaration (Loc,
Defining_Identifier =>
Proxy_Type_Full_View,
Type_Definition =>
Build_Remote_Subprogram_Proxy_Type (Loc,
New_Occurrence_Of (All_Calls_Remote_E, Loc))));
Set_Comes_From_Source (Proxy_Type_Full_View, True);
if Nkind (Subp_Decl_Spec) = N_Procedure_Specification then
Perform_Call :=
Make_Procedure_Call_Statement (Loc,
Name =>
New_Occurrence_Of (Subp_Name, Loc),
Parameter_Associations =>
Actuals);
else
Perform_Call :=
Make_Return_Statement (Loc,
Expression =>
Make_Function_Call (Loc,
Name =>
New_Occurrence_Of (Subp_Name, Loc),
Parameter_Associations =>
Actuals));
end if;
Formal := First (Parameter_Specifications (Subp_Decl_Spec));
pragma Assert (Present (Formal));
loop
Next (Formal);
exit when No (Formal);
Append_To (Actuals,
New_Occurrence_Of (Defining_Identifier (Formal), Loc));
end loop;
Append_To (Pvt_Decls,
Make_Object_Declaration (Loc,
Defining_Identifier =>
Make_Defining_Identifier (Loc,
Name_uO),
Aliased_Present =>
True,
Object_Definition =>
New_Occurrence_Of (Proxy_Type, Loc)));
Append_To (Pvt_Decls,
Make_Object_Declaration (Loc,
Defining_Identifier =>
Make_Defining_Identifier (Loc,
Chars (Proxy_Object_Addr)),
Constant_Present =>
True,
Object_Definition =>
New_Occurrence_Of (RTE (RE_Address), Loc),
Expression =>
Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (
Defining_Identifier (Last (Pvt_Decls)), Loc),
Attribute_Name =>
Name_Address)));
Append_To (Decls,
Make_Package_Declaration (Loc,
Specification => Make_Package_Specification (Loc,
Defining_Unit_Name => Pkg_Name,
Visible_Declarations => Vis_Decls,
Private_Declarations => Pvt_Decls,
End_Label => Empty)));
Analyze (Last (Decls));
Append_To (Decls,
Make_Package_Body (Loc,
Defining_Unit_Name =>
Make_Defining_Identifier (Loc,
Chars (Pkg_Name)),
Declarations => New_List (
Make_Subprogram_Body (Loc,
Specification =>
Subp_Body_Spec,
Declarations => New_List,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => New_List (Perform_Call))))));
Analyze (Last (Decls));
end Add_RAS_Proxy_And_Analyze;
procedure Add_RAST_Features (Vis_Decl : Node_Id) is
RAS_Type : constant Entity_Id :=
Equivalent_Type (Defining_Identifier (Vis_Decl));
Spec : constant Node_Id :=
Specification (Unit (Enclosing_Lib_Unit_Node (Vis_Decl)));
Decls : List_Id := Private_Declarations (Spec);
begin
pragma Assert (No (TSS (RAS_Type, TSS_RAS_Access)));
if No (Decls) then
Decls := Visible_Declarations (Spec);
end if;
Add_RAS_Dereference_TSS (Vis_Decl);
Specific_Add_RAST_Features (Vis_Decl, RAS_Type, Decls);
end Add_RAST_Features;
procedure Add_Stub_Type
(Designated_Type : Entity_Id;
RACW_Type : Entity_Id;
Decls : List_Id;
Stub_Type : out Entity_Id;
Stub_Type_Access : out Entity_Id;
RPC_Receiver_Decl : out Node_Id;
Existing : out Boolean)
is
Loc : constant Source_Ptr := Sloc (RACW_Type);
Stub_Elements : constant Stub_Structure :=
Stubs_Table.Get (Designated_Type);
Stub_Type_Decl : Node_Id;
Stub_Type_Access_Decl : Node_Id;
begin
if Stub_Elements /= Empty_Stub_Structure then
Stub_Type := Stub_Elements.Stub_Type;
Stub_Type_Access := Stub_Elements.Stub_Type_Access;
RPC_Receiver_Decl := Stub_Elements.RPC_Receiver_Decl;
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_External_Name (
Related_Id => Chars (Stub_Type),
Suffix => 'A'));
Specific_Build_Stub_Type (
RACW_Type, Stub_Type,
Stub_Type_Decl, RPC_Receiver_Decl);
Stub_Type_Access_Decl :=
Make_Full_Type_Declaration (Loc,
Defining_Identifier => Stub_Type_Access,
Type_Definition =>
Make_Access_To_Object_Definition (Loc,
All_Present => True,
Subtype_Indication => New_Occurrence_Of (Stub_Type, Loc)));
Append_To (Decls, Stub_Type_Decl);
Analyze (Last (Decls));
Append_To (Decls, Stub_Type_Access_Decl);
Analyze (Last (Decls));
Derive_Subprograms (Parent_Type => Designated_Type,
Derived_Type => Stub_Type);
if Present (RPC_Receiver_Decl) then
Append_To (Decls, RPC_Receiver_Decl);
else
RPC_Receiver_Decl := Last (Decls);
end if;
Stubs_Table.Set (Designated_Type,
(Stub_Type => Stub_Type,
Stub_Type_Access => Stub_Type_Access,
RPC_Receiver_Decl => RPC_Receiver_Decl,
RACW_Type => RACW_Type));
end Add_Stub_Type;
procedure Assign_Subprogram_Identifier
(Def : Entity_Id;
Spn : Int;
Id : out String_Id)
is
N : constant Name_Id := Chars (Def);
Overload_Order : constant Int :=
Overload_Counter_Table.Get (N) + 1;
begin
Overload_Counter_Table.Set (N, Overload_Order);
Get_Name_String (N);
if Overload_Order > 1 then
Name_Buffer (Name_Len + 1 .. Name_Len + 2) := "__";
Name_Len := Name_Len + 2;
Add_Nat_To_Name_Buffer (Overload_Order);
end if;
Id := String_From_Name_Buffer;
Subprogram_Identifier_Table.Set (Def,
Subprogram_Identifiers'(Str_Identifier => Id, Int_Identifier => Spn));
end Assign_Subprogram_Identifier;
function Build_Get_Unique_RP_Call
(Loc : Source_Ptr;
Pointer : Entity_Id;
Stub_Type : Entity_Id) return List_Id
is
begin
return New_List (
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 (Pointer, Loc)))),
Make_Assignment_Statement (Loc,
Name =>
Make_Selected_Component (Loc,
Prefix =>
New_Occurrence_Of (Pointer, Loc),
Selector_Name =>
New_Occurrence_Of (Tag_Component
(Designated_Type (Etype (Pointer))), Loc)),
Expression =>
Make_Attribute_Reference (Loc,
Prefix =>
New_Occurrence_Of (Stub_Type, Loc),
Attribute_Name =>
Name_Tag)));
end Build_Get_Unique_RP_Call;
function Build_Ordered_Parameters_List (Spec : Node_Id) return List_Id is
Constrained_List : List_Id;
Unconstrained_List : List_Id;
Current_Parameter : Node_Id;
First_Parameter : Node_Id;
For_RAS : Boolean := False;
begin
if not Present (Parameter_Specifications (Spec)) then
return New_List;
end if;
Constrained_List := New_List;
Unconstrained_List := New_List;
First_Parameter := First (Parameter_Specifications (Spec));
if Nkind (Parameter_Type (First_Parameter)) = N_Access_Definition
and then Chars (Defining_Identifier (First_Parameter)) = Name_uS
then
For_RAS := True;
end if;
Current_Parameter := First_Parameter;
while Present (Current_Parameter) 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))))
and then not (For_RAS and then Current_Parameter = First_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;
Pkg_Name : String_Id;
L : List_Id;
Reg : Node_Id;
Loc : constant Source_Ptr := Sloc (U);
begin
declare
Dist_OK : Entity_Id;
pragma Warnings (Off, Dist_OK);
begin
Dist_OK := RTE (RE_Params_Stream_Type);
end;
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;
Get_Library_Unit_Name_String (Pkg_Spec);
Pkg_Name := String_From_Name_Buffer;
Reg :=
Make_Procedure_Call_Statement (Loc,
Name =>
New_Occurrence_Of (RTE (RE_Register_Passive_Package), Loc),
Parameter_Associations => New_List (
Make_String_Literal (Loc, Pkg_Name),
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_RPC_Receiver_Specification
(RPC_Receiver : Entity_Id;
Request_Parameter : Entity_Id) return Node_Id
is
Loc : constant Source_Ptr := Sloc (RPC_Receiver);
begin
return
Make_Procedure_Specification (Loc,
Defining_Unit_Name => RPC_Receiver,
Parameter_Specifications => New_List (
Make_Parameter_Specification (Loc,
Defining_Identifier => Request_Parameter,
Parameter_Type =>
New_Occurrence_Of (RTE (RE_Request_Access), Loc))));
end Build_RPC_Receiver_Specification;
function Build_Remote_Subprogram_Proxy_Type
(Loc : Source_Ptr;
ACR_Expression : Node_Id) return Node_Id
is
begin
return
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_All_Calls_Remote),
Component_Definition =>
Make_Component_Definition (Loc,
Subtype_Indication =>
New_Occurrence_Of (Standard_Boolean, Loc)),
Expression =>
ACR_Expression),
Make_Component_Declaration (Loc,
Defining_Identifier =>
Make_Defining_Identifier (Loc,
Name_Receiver),
Component_Definition =>
Make_Component_Definition (Loc,
Subtype_Indication =>
New_Occurrence_Of (RTE (RE_Address), Loc)),
Expression =>
New_Occurrence_Of (RTE (RE_Null_Address), Loc)),
Make_Component_Declaration (Loc,
Defining_Identifier =>
Make_Defining_Identifier (Loc,
Name_Subp_Id),
Component_Definition =>
Make_Component_Definition (Loc,
Subtype_Indication =>
New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc))))));
end Build_Remote_Subprogram_Proxy_Type;
function Build_Subprogram_Calling_Stubs
(Vis_Decl : Node_Id;
Subp_Id : Node_Id;
Asynchronous : Boolean;
Dynamically_Asynchronous : Boolean := False;
Stub_Type : Entity_Id := Empty;
RACW_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);
Decls : constant List_Id := New_List;
Statements : constant List_Id := New_List;
Subp_Spec : Node_Id;
Controlling_Parameter : Entity_Id := Empty;
Asynchronous_Expr : Node_Id := Empty;
RCI_Locator : Entity_Id;
Spec_To_Use : Node_Id;
procedure Insert_Partition_Check (Parameter : Node_Id);
procedure Insert_Partition_Check (Parameter : Node_Id) is
Parameter_Entity : constant Entity_Id :=
Defining_Identifier (Parameter);
begin
Append_To (Decls,
Make_Raise_Constraint_Error (Loc,
Condition =>
Make_Op_Not (Loc,
Right_Opnd =>
Make_Function_Call (Loc,
Name =>
New_Occurrence_Of (RTE (RE_Same_Partition), Loc),
Parameter_Associations =>
New_List (
Unchecked_Convert_To (RTE (RE_RACW_Stub_Type_Access),
New_Occurrence_Of (Parameter_Entity, Loc)),
Unchecked_Convert_To (RTE (RE_RACW_Stub_Type_Access),
New_Occurrence_Of (Controlling_Parameter, Loc))))),
Reason => CE_Partition_Check_Failed));
end Insert_Partition_Check;
begin
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 Present (Stub_Type)
and then Present (Parameter_Specifications (Spec_To_Use))
then
declare
Current_Parameter : Node_Id :=
First (Parameter_Specifications
(Spec_To_Use));
begin
while Present (Current_Parameter) 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;
pragma Assert (No (Stub_Type) or else Present (Controlling_Parameter));
if Dynamically_Asynchronous then
Asynchronous_Expr := Make_Selected_Component (Loc,
Prefix => Controlling_Parameter,
Selector_Name => Name_Asynchronous);
end if;
Specific_Build_General_Calling_Stubs
(Decls => Decls,
Statements => Statements,
Target => Specific_Build_Stub_Target (Loc,
Decls, RCI_Locator, Controlling_Parameter),
Subprogram_Id => 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,
Stub_Type => Stub_Type,
RACW_Type => RACW_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_Id
(Loc : Source_Ptr;
E : Entity_Id) return Node_Id
is
begin
case Get_PCS_Name is
when Name_PolyORB_DSA =>
return Make_String_Literal (Loc, Get_Subprogram_Id (E));
when others =>
return Make_Integer_Literal (Loc, Get_Subprogram_Id (E));
end case;
end Build_Subprogram_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
is
Parameters : List_Id := No_List;
Current_Parameter : Node_Id;
Current_Identifier : Entity_Id;
Current_Type : Node_Id;
Current_Etype : Entity_Id;
Name_For_New_Spec : Name_Id;
New_Identifier : Entity_Id;
begin
if New_Name = No_Name then
pragma Assert (Nkind (Spec) = N_Function_Specification
or else Nkind (Spec) = N_Procedure_Specification);
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 Present (Current_Parameter) loop
Current_Identifier := Defining_Identifier (Current_Parameter);
Current_Type := Parameter_Type (Current_Parameter);
if Nkind (Current_Type) = N_Access_Definition then
Current_Etype := Entity (Subtype_Mark (Current_Type));
if Present (Object_Type) then
pragma Assert (
Root_Type (Current_Etype) = Root_Type (Object_Type));
Current_Type :=
Make_Access_Definition (Loc,
Subtype_Mark => New_Occurrence_Of (Stub_Type, Loc));
else
Current_Type :=
Make_Access_Definition (Loc,
Subtype_Mark =>
New_Occurrence_Of (Current_Etype, Loc));
end if;
else
Current_Etype := Entity (Current_Type);
if Present (Object_Type)
and then Current_Etype = Object_Type
then
Current_Type := New_Occurrence_Of (Stub_Type, Loc);
else
Current_Type := New_Occurrence_Of (Current_Etype, Loc);
end if;
end if;
New_Identifier := Make_Defining_Identifier (Loc,
Chars (Current_Identifier));
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))));
if Is_Entity_Name (Current_Type) then
Set_Etype (New_Identifier, Entity (Current_Type));
else
null;
end if;
Next (Current_Parameter);
end loop;
end if;
case Nkind (Spec) is
when N_Function_Specification | N_Access_Function_Definition =>
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 (Entity (Subtype_Mark (Spec)), Loc));
when N_Procedure_Specification | N_Access_Procedure_Definition =>
return
Make_Procedure_Specification (Loc,
Defining_Unit_Name =>
Make_Defining_Identifier (Loc,
Chars => Name_For_New_Spec),
Parameter_Specifications => Parameters);
when others =>
raise Program_Error;
end case;
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 Present (Current_Parameter) 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 Declare_Create_NVList
(Loc : Source_Ptr;
NVList : Entity_Id;
Decls : List_Id;
Stmts : List_Id)
is
begin
Append_To (Decls,
Make_Object_Declaration (Loc,
Defining_Identifier => NVList,
Aliased_Present => False,
Object_Definition =>
New_Occurrence_Of (RTE (RE_NVList_Ref), Loc)));
Append_To (Stmts,
Make_Procedure_Call_Statement (Loc,
Name =>
New_Occurrence_Of (RTE (RE_NVList_Create), Loc),
Parameter_Associations => New_List (
New_Occurrence_Of (NVList, Loc))));
end Declare_Create_NVList;
procedure Expand_All_Calls_Remote_Subprogram_Call (N : 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 : constant 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 =>
Build_Subprogram_Id (Loc, 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 : 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 : 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 := Private_Declarations (Spec);
if No (Decls) then
Decls := Visible_Declarations (Spec);
end if;
New_Scope (Scope_Of_Spec (Spec));
Specific_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;
Specific_Add_Receiving_Stubs_To_Declarations (Spec, Temp);
Insert_List_Before (First (Decls), Temp);
end if;
Pop_Scope;
end Expand_Receiving_Stubs_Bodies;
package body GARLIC_Support is
procedure Add_RACW_Read_Attribute
(RACW_Type : Entity_Id;
Stub_Type : Entity_Id;
Stub_Type_Access : Entity_Id;
Declarations : List_Id);
procedure Add_RACW_Write_Attribute
(RACW_Type : Entity_Id;
Stub_Type : Entity_Id;
Stub_Type_Access : Entity_Id;
RPC_Receiver : Node_Id;
Declarations : List_Id);
function Stream_Parameter return Node_Id;
function Result return Node_Id;
function Object return Node_Id renames Result;
Loc : Source_Ptr;
procedure Add_RAS_Access_TSS (N : Node_Id);
procedure Add_Obj_RPC_Receiver_Completion
(Loc : Source_Ptr;
Decls : List_Id;
RPC_Receiver : Entity_Id;
Stub_Elements : Stub_Structure) is
begin
Append_To (Decls,
Make_Subprogram_Renaming_Declaration (Loc,
Specification =>
Copy_Specification (Loc,
Specification (Stub_Elements.RPC_Receiver_Decl)),
Name => New_Occurrence_Of (RPC_Receiver, Loc)));
end Add_Obj_RPC_Receiver_Completion;
procedure Add_RACW_Features
(RACW_Type : Entity_Id;
Stub_Type : Entity_Id;
Stub_Type_Access : Entity_Id;
RPC_Receiver_Decl : Node_Id;
Declarations : List_Id)
is
RPC_Receiver : Node_Id;
Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type);
begin
Loc := Sloc (RACW_Type);
if Is_RAS then
RPC_Receiver := Make_Selected_Component (Loc,
Prefix =>
Unchecked_Convert_To (RTE (RE_RAS_Proxy_Type_Access), Object),
Selector_Name => Make_Identifier (Loc, Name_Receiver));
else
RPC_Receiver := Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (
Defining_Unit_Name (Specification (RPC_Receiver_Decl)), Loc),
Attribute_Name => Name_Address);
end if;
Add_RACW_Write_Attribute (
RACW_Type,
Stub_Type,
Stub_Type_Access,
RPC_Receiver,
Declarations);
Add_RACW_Read_Attribute (
RACW_Type,
Stub_Type,
Stub_Type_Access,
Declarations);
end Add_RACW_Features;
procedure Add_RACW_Read_Attribute
(RACW_Type : Entity_Id;
Stub_Type : Entity_Id;
Stub_Type_Access : Entity_Id;
Declarations : List_Id)
is
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'));
Local_Stub : constant Entity_Id :=
Make_Defining_Identifier
(Loc, New_Internal_Name ('L'));
Stubbed_Result : constant Entity_Id :=
Make_Defining_Identifier
(Loc, New_Internal_Name ('S'));
Asynchronous_Flag : constant Entity_Id :=
Asynchronous_Flags_Table.Get (RACW_Type);
pragma Assert (Present (Asynchronous_Flag));
begin
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 => Local_Stub,
Aliased_Present => True,
Object_Definition => New_Occurrence_Of (Stub_Type, Loc)),
Make_Object_Declaration (Loc,
Defining_Identifier => Stubbed_Result,
Object_Definition =>
New_Occurrence_Of (Stub_Type_Access, Loc),
Expression =>
Make_Attribute_Reference (Loc,
Prefix =>
New_Occurrence_Of (Local_Stub, Loc),
Attribute_Name =>
Name_Unchecked_Access)));
Statements := New_List (
Make_Attribute_Reference (Loc,
Prefix =>
New_Occurrence_Of (RTE (RE_Partition_ID), Loc),
Attribute_Name => Name_Read,
Expressions => New_List (
Stream_Parameter,
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 (
Stream_Parameter,
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 (
Stream_Parameter,
New_Occurrence_Of (Source_Address, Loc))));
Set_Etype (Stubbed_Result, Stub_Type_Access);
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 => Result,
Expression => Make_Null (Loc)),
Make_Return_Statement (Loc))));
Local_Statements := New_List (
Make_Assignment_Statement (Loc,
Name => Result,
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 => Make_Selected_Component (Loc,
Prefix => Stubbed_Result,
Selector_Name => Name_Origin),
Expression =>
New_Occurrence_Of (Source_Partition, Loc)),
Make_Assignment_Statement (Loc,
Name => Make_Selected_Component (Loc,
Prefix => Stubbed_Result,
Selector_Name => Name_Receiver),
Expression =>
New_Occurrence_Of (Source_Receiver, Loc)),
Make_Assignment_Statement (Loc,
Name => Make_Selected_Component (Loc,
Prefix => Stubbed_Result,
Selector_Name => Name_Addr),
Expression =>
New_Occurrence_Of (Source_Address, Loc)));
Append_To (Remote_Statements,
Make_Assignment_Statement (Loc,
Name => Make_Selected_Component (Loc,
Prefix => Stubbed_Result,
Selector_Name => Name_Asynchronous),
Expression =>
New_Occurrence_Of (Asynchronous_Flag, Loc)));
Append_List_To (Remote_Statements,
Build_Get_Unique_RP_Call (Loc, Stubbed_Result, Stub_Type));
Append_To (Remote_Statements,
Make_Assignment_Statement (Loc,
Name => Result,
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));
Build_Stream_Procedure
(Loc, RACW_Type, Body_Node,
Make_Defining_Identifier (Loc, Procedure_Name),
Statements, Outp => True);
Set_Declarations (Body_Node, Decls);
Proc_Decl := Make_Subprogram_Declaration (Loc,
Copy_Specification (Loc, Specification (Body_Node)));
Attr_Decl :=
Make_Attribute_Definition_Clause (Loc,
Name => New_Occurrence_Of (RACW_Type, Loc),
Chars => Name_Read,
Expression =>
New_Occurrence_Of (
Defining_Unit_Name (Specification (Proc_Decl)), 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_Write_Attribute
(RACW_Type : Entity_Id;
Stub_Type : Entity_Id;
Stub_Type_Access : Entity_Id;
RPC_Receiver : Node_Id;
Declarations : List_Id)
is
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');
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), RPC_Receiver),
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 => Object),
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,
Object),
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,
Object),
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,
Object),
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), RPC_Receiver),
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 => Object,
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 => Object,
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));
Build_Stream_Procedure
(Loc, RACW_Type, Body_Node,
Make_Defining_Identifier (Loc, Procedure_Name),
Statements, Outp => False);
Proc_Decl := Make_Subprogram_Declaration (Loc,
Copy_Specification (Loc, Specification (Body_Node)));
Attr_Decl :=
Make_Attribute_Definition_Clause (Loc,
Name => New_Occurrence_Of (RACW_Type, Loc),
Chars => Name_Write,
Expression =>
New_Occurrence_Of (
Defining_Unit_Name (Specification (Proc_Decl)), Loc));
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_TSS (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
Ras_Type : constant Entity_Id := Defining_Identifier (N);
Fat_Type : constant Entity_Id := Equivalent_Type (Ras_Type);
RACW_Type : constant Entity_Id :=
Underlying_RACW_Type (Ras_Type);
Desig : constant Entity_Id :=
Etype (Designated_Type (RACW_Type));
Stub_Elements : constant Stub_Structure :=
Stubs_Table.Get (Desig);
pragma Assert (Stub_Elements /= Empty_Stub_Structure);
Proc : constant Entity_Id :=
Make_Defining_Identifier (Loc,
Chars => Make_TSS_Name (Ras_Type, TSS_RAS_Access));
Proc_Spec : Node_Id;
Package_Name : constant Entity_Id :=
Make_Defining_Identifier (Loc,
Chars => Name_P);
Subp_Id : constant Entity_Id :=
Make_Defining_Identifier (Loc,
Chars => Name_S);
Asynch_P : constant Entity_Id :=
Make_Defining_Identifier (Loc,
Chars => Name_Asynchronous);
All_Calls_Remote : constant Entity_Id :=
Make_Defining_Identifier (Loc,
Chars => Name_All_Calls_Remote);
Proc_Decls : List_Id;
Proc_Statements : List_Id;
Origin : constant Entity_Id :=
Make_Defining_Identifier (Loc,
Chars => New_Internal_Name ('P'));
Proxy_Addr : constant Entity_Id :=
Make_Defining_Identifier (Loc,
Chars => New_Internal_Name ('P'));
Local_Stub : constant Entity_Id :=
Make_Defining_Identifier (Loc,
Chars => New_Internal_Name ('L'));
Stub_Ptr : constant Entity_Id :=
Make_Defining_Identifier (Loc,
Chars => New_Internal_Name ('S'));
function Set_Field
(Field_Name : Name_Id;
Value : Node_Id) return Node_Id;
function Set_Field
(Field_Name : Name_Id;
Value : Node_Id) return Node_Id
is
begin
return
Make_Assignment_Statement (Loc,
Name =>
Make_Selected_Component (Loc,
Prefix => Stub_Ptr,
Selector_Name => Field_Name),
Expression => Value);
end Set_Field;
begin
Proc_Decls := New_List (
Make_Object_Declaration (Loc,
Defining_Identifier => Origin,
Constant_Present => True,
Object_Definition =>
New_Occurrence_Of (RTE (RE_Partition_ID), Loc),
Expression =>
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)))),
Make_Object_Declaration (Loc,
Defining_Identifier => Proxy_Addr,
Object_Definition =>
New_Occurrence_Of (RTE (RE_Unsigned_64), Loc)),
Make_Object_Declaration (Loc,
Defining_Identifier => Local_Stub,
Aliased_Present => True,
Object_Definition =>
New_Occurrence_Of (Stub_Elements.Stub_Type, Loc)),
Make_Object_Declaration (Loc,
Defining_Identifier =>
Stub_Ptr,
Object_Definition =>
New_Occurrence_Of (Stub_Elements.Stub_Type_Access, Loc),
Expression =>
Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (Local_Stub, Loc),
Attribute_Name => Name_Unchecked_Access)));
Set_Etype (Stub_Ptr, Stub_Elements.Stub_Type_Access);
Proc_Statements := New_List (
Make_Procedure_Call_Statement (Loc,
Name =>
New_Occurrence_Of (RTE (RE_Get_RAS_Info), Loc),
Parameter_Associations => New_List (
New_Occurrence_Of (Package_Name, Loc),
New_Occurrence_Of (Subp_Id, Loc),
New_Occurrence_Of (Proxy_Addr, Loc))),
Make_Implicit_If_Statement (N,
Condition =>
Make_And_Then (Loc,
Left_Opnd =>
Make_Op_Eq (Loc,
Left_Opnd =>
New_Occurrence_Of (Origin, Loc),
Right_Opnd =>
Make_Function_Call (Loc,
New_Occurrence_Of (
RTE (RE_Get_Local_Partition_Id), Loc))),
Right_Opnd =>
Make_Op_Not (Loc,
New_Occurrence_Of (All_Calls_Remote, Loc))),
Then_Statements => New_List (
Make_Return_Statement (Loc,
Unchecked_Convert_To (Fat_Type,
OK_Convert_To (RTE (RE_Address),
New_Occurrence_Of (Proxy_Addr, Loc)))))),
Set_Field (Name_Origin,
New_Occurrence_Of (Origin, 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_Addr, New_Occurrence_Of (Proxy_Addr, Loc)),
Set_Field (Name_Asynchronous,
Make_Or_Else (Loc,
New_Occurrence_Of (Asynch_P, Loc),
New_Occurrence_Of (Boolean_Literals (
Is_Asynchronous (Ras_Type)), Loc))));
Append_List_To (Proc_Statements,
Build_Get_Unique_RP_Call
(Loc, Stub_Ptr, Stub_Elements.Stub_Type));
Append_To (Proc_Statements,
Make_Return_Statement (Loc,
Expression =>
Unchecked_Convert_To (Fat_Type,
New_Occurrence_Of (Stub_Ptr, Loc))));
Proc_Spec :=
Make_Function_Specification (Loc,
Defining_Unit_Name => Proc,
Parameter_Specifications => New_List (
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 (RTE (RE_Subprogram_Id), Loc)),
Make_Parameter_Specification (Loc,
Defining_Identifier => Asynch_P,
Parameter_Type =>
New_Occurrence_Of (Standard_Boolean, Loc)),
Make_Parameter_Specification (Loc,
Defining_Identifier => All_Calls_Remote,
Parameter_Type =>
New_Occurrence_Of (Standard_Boolean, Loc))),
Subtype_Mark =>
New_Occurrence_Of (Fat_Type, Loc));
Set_Ekind (Proc, E_Function);
Set_Etype (Proc, Fat_Type);
Discard_Node (
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_TSS;
procedure Add_RAST_Features
(Vis_Decl : Node_Id;
RAS_Type : Entity_Id;
Decls : List_Id)
is
pragma Warnings (Off);
pragma Unreferenced (RAS_Type, Decls);
pragma Warnings (On);
begin
Add_RAS_Access_TSS (Vis_Decl);
end Add_RAST_Features;
procedure Add_Receiving_Stubs_To_Declarations
(Pkg_Spec : Node_Id;
Decls : List_Id)
is
Loc : constant Source_Ptr := Sloc (Pkg_Spec);
Request_Parameter : Node_Id;
Pkg_RPC_Receiver : constant Entity_Id :=
Make_Defining_Identifier (Loc,
New_Internal_Name ('H'));
Pkg_RPC_Receiver_Statements : List_Id;
Pkg_RPC_Receiver_Cases : constant List_Id := New_List;
Pkg_RPC_Receiver_Body : Node_Id;
Lookup_RAS_Info : constant Entity_Id :=
Make_Defining_Identifier (Loc,
Chars => New_Internal_Name ('R'));
Subp_Id : Entity_Id;
Subp_Index : Entity_Id;
Current_Declaration : Node_Id;
Current_Subprogram_Number : Int := First_RCI_Subprogram_Id;
Current_Stubs : Node_Id;
Subp_Info_Array : constant Entity_Id :=
Make_Defining_Identifier (Loc,
Chars => New_Internal_Name ('I'));
Subp_Info_List : constant List_Id := New_List;
Register_Pkg_Actuals : constant List_Id := New_List;
All_Calls_Remote_E : Entity_Id;
Proxy_Object_Addr : Entity_Id;
procedure Append_Stubs_To
(RPC_Receiver_Cases : List_Id;
Stubs : Node_Id;
Subprogram_Number : Int);
procedure Append_Stubs_To
(RPC_Receiver_Cases : List_Id;
Stubs : Node_Id;
Subprogram_Number : Int)
is
begin
Append_To (RPC_Receiver_Cases,
Make_Case_Statement_Alternative (Loc,
Discrete_Choices =>
New_List (Make_Integer_Literal (Loc, Subprogram_Number)),
Statements =>
New_List (
Make_Procedure_Call_Statement (Loc,
Name =>
New_Occurrence_Of (
Defining_Entity (Stubs), Loc),
Parameter_Associations => New_List (
New_Occurrence_Of (Request_Parameter, Loc))))));
end Append_Stubs_To;
begin
Build_RPC_Receiver_Body (
RPC_Receiver => Pkg_RPC_Receiver,
Request => Request_Parameter,
Subp_Id => Subp_Id,
Subp_Index => Subp_Index,
Stmts => Pkg_RPC_Receiver_Statements,
Decl => Pkg_RPC_Receiver_Body);
pragma Assert (Subp_Id = Subp_Index);
Append_To (Pkg_RPC_Receiver_Statements,
Make_Implicit_If_Statement (Pkg_Spec,
Condition =>
Make_Op_Eq (Loc,
New_Occurrence_Of (Subp_Id, Loc),
Make_Integer_Literal (Loc, 0)),
Then_Statements => New_List (
Make_Assignment_Statement (Loc,
Name =>
New_Occurrence_Of (Subp_Id, Loc),
Expression =>
Make_Selected_Component (Loc,
Prefix =>
Unchecked_Convert_To (RTE (RE_RAS_Proxy_Type_Access),
OK_Convert_To (RTE (RE_Address),
Make_Attribute_Reference (Loc,
Prefix =>
New_Occurrence_Of (RTE (RE_Unsigned_64), Loc),
Attribute_Name =>
Name_Input,
Expressions => New_List (
Make_Selected_Component (Loc,
Prefix => Request_Parameter,
Selector_Name => Name_Params))))),
Selector_Name =>
Make_Identifier (Loc, Name_Subp_Id))))));
Current_Declaration :=
Make_Subprogram_Declaration (Loc,
Specification =>
Make_Function_Specification (Loc,
Defining_Unit_Name =>
Lookup_RAS_Info,
Parameter_Specifications => New_List (
Make_Parameter_Specification (Loc,
Defining_Identifier =>
Make_Defining_Identifier (Loc, Name_Subp_Id),
In_Present =>
True,
Parameter_Type =>
New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc))),
Subtype_Mark =>
New_Occurrence_Of (RTE (RE_Unsigned_64), Loc)));
Append_To (Decls, Current_Declaration);
Analyze (Current_Declaration);
Current_Stubs := Build_Subprogram_Receiving_Stubs
(Vis_Decl => Current_Declaration,
Asynchronous => False);
Append_To (Decls, Current_Stubs);
Analyze (Current_Stubs);
Append_Stubs_To (Pkg_RPC_Receiver_Cases,
Stubs =>
Current_Stubs,
Subprogram_Number => 1);
All_Calls_Remote_E := Boolean_Literals (
Has_All_Calls_Remote (Defining_Entity (Pkg_Spec)));
Overload_Counter_Table.Reset;
Current_Declaration := First (Visible_Declarations (Pkg_Spec));
while Present (Current_Declaration) loop
if Nkind (Current_Declaration) = N_Subprogram_Declaration
and then Comes_From_Source (Current_Declaration)
then
declare
Loc : constant Source_Ptr :=
Sloc (Current_Declaration);
Subp_Def : constant Entity_Id :=
Defining_Unit_Name
(Specification (Current_Declaration));
Subp_Val : String_Id;
begin
pragma Assert (Current_Subprogram_Number =
Get_Subprogram_Id (Subp_Def));
Current_Stubs :=
Build_Subprogram_Receiving_Stubs
(Vis_Decl => Current_Declaration,
Asynchronous =>
Nkind (Specification (Current_Declaration)) =
N_Procedure_Specification
and then Is_Asynchronous (Subp_Def));
Append_To (Decls, Current_Stubs);
Analyze (Current_Stubs);
Add_RAS_Proxy_And_Analyze (Decls,
Vis_Decl =>
Current_Declaration,
All_Calls_Remote_E =>
All_Calls_Remote_E,
Proxy_Object_Addr =>
Proxy_Object_Addr);
Assign_Subprogram_Identifier (
Subp_Def,
Current_Subprogram_Number,
Subp_Val);
Append_To (Subp_Info_List,
Make_Component_Association (Loc,
Choices => New_List (
Make_Integer_Literal (Loc,
Current_Subprogram_Number)),
Expression =>
Make_Aggregate (Loc,
Component_Associations => New_List (
Make_Component_Association (Loc,
Choices => New_List (
Make_Identifier (Loc, Name_Addr)),
Expression =>
New_Occurrence_Of (
Proxy_Object_Addr, Loc))))));
Append_Stubs_To (Pkg_RPC_Receiver_Cases,
Stubs =>
Current_Stubs,
Subprogram_Number =>
Current_Subprogram_Number);
end;
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));
Append_To (Decls,
Make_Object_Declaration (Loc,
Defining_Identifier => Subp_Info_Array,
Constant_Present => True,
Aliased_Present => True,
Object_Definition =>
Make_Subtype_Indication (Loc,
Subtype_Mark =>
New_Occurrence_Of (RTE (RE_RCI_Subp_Info_Array), Loc),
Constraint =>
Make_Index_Or_Discriminant_Constraint (Loc,
New_List (
Make_Range (Loc,
Low_Bound => Make_Integer_Literal (Loc,
First_RCI_Subprogram_Id),
High_Bound =>
Make_Integer_Literal (Loc,
First_RCI_Subprogram_Id
+ List_Length (Subp_Info_List) - 1))))),
Expression =>
Make_Aggregate (Loc,
Component_Associations => Subp_Info_List)));
Analyze (Last (Decls));
Append_To (Decls,
Make_Subprogram_Body (Loc,
Specification =>
Copy_Specification (Loc, Parent (Lookup_RAS_Info)),
Declarations =>
No_List,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => New_List (
Make_Return_Statement (Loc,
Expression => OK_Convert_To (RTE (RE_Unsigned_64),
Make_Selected_Component (Loc,
Prefix =>
Make_Indexed_Component (Loc,
Prefix =>
New_Occurrence_Of (Subp_Info_Array, Loc),
Expressions => New_List (
Convert_To (Standard_Integer,
Make_Identifier (Loc, Name_Subp_Id)))),
Selector_Name =>
Make_Identifier (Loc, Name_Addr))))))));
Analyze (Last (Decls));
Append_To (Decls, Pkg_RPC_Receiver_Body);
Analyze (Last (Decls));
Get_Library_Unit_Name_String (Pkg_Spec);
Append_To (Register_Pkg_Actuals,
Make_String_Literal (Loc,
Strval => String_From_Name_Buffer));
Append_To (Register_Pkg_Actuals,
Make_Attribute_Reference (Loc,
Prefix =>
New_Occurrence_Of (Pkg_RPC_Receiver, Loc),
Attribute_Name =>
Name_Unrestricted_Access));
Append_To (Register_Pkg_Actuals,
Make_Attribute_Reference (Loc,
Prefix =>
New_Occurrence_Of (Defining_Entity (Pkg_Spec), Loc),
Attribute_Name =>
Name_Version));
Append_To (Register_Pkg_Actuals,
Make_Attribute_Reference (Loc,
Prefix =>
New_Occurrence_Of (Subp_Info_Array, Loc),
Attribute_Name =>
Name_Address));
Append_To (Register_Pkg_Actuals,
Make_Attribute_Reference (Loc,
Prefix =>
New_Occurrence_Of (Subp_Info_Array, Loc),
Attribute_Name =>
Name_Length));
Append_To (Decls,
Make_Procedure_Call_Statement (Loc,
Name =>
New_Occurrence_Of (RTE (RE_Register_Receiving_Stub), Loc),
Parameter_Associations => Register_Pkg_Actuals));
Analyze (Last (Decls));
end Add_Receiving_Stubs_To_Declarations;
procedure Build_General_Calling_Stubs
(Decls : List_Id;
Statements : List_Id;
Target_Partition : Entity_Id;
Target_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;
Stub_Type : Entity_Id := Empty;
RACW_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;
pragma Warnings (Off);
pragma Unreferenced (RACW_Type);
pragma Warnings (On);
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),
Target_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 Present (Current_Parameter) loop
declare
Typ : constant Node_Id :=
Parameter_Type (Current_Parameter);
Etyp : Entity_Id;
Constrained : Boolean;
Value : Node_Id;
Extra_Parameter : Entity_Id;
begin
if Is_RACW_Controlling_Formal
(Current_Parameter, Stub_Type)
then
Append_To (Statements,
Pack_Node_Into_Stream (Loc,
Stream => Stream_Parameter,
Object =>
Make_Selected_Component (Loc,
Prefix =>
Defining_Identifier (Current_Parameter),
Selector_Name => Name_Addr),
Etyp => RTE (RE_Unsigned_64)));
else
Value := New_Occurrence_Of
(Defining_Identifier (Current_Parameter), Loc);
if Nkind (Typ) = N_Access_Definition then
Value := Make_Explicit_Dereference (Loc, Value);
Etyp := Etype (Subtype_Mark (Typ));
else
Etyp := Etype (Typ);
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
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),
Value)));
end if;
end if;
if Nkind (Typ) /= N_Access_Definition
and then Need_Extra_Constrained (Current_Parameter)
then
Extra_Parameter := Make_Defining_Identifier
(Loc, New_Internal_Name ('P'));
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 if;
Next (Current_Parameter);
end;
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 Present (Current_Parameter) loop
declare
Typ : constant Node_Id :=
Parameter_Type (Current_Parameter);
Etyp : Entity_Id;
Value : Node_Id;
begin
Value :=
New_Occurrence_Of
(Defining_Identifier (Current_Parameter), Loc);
if Nkind (Typ) = N_Access_Definition then
Value := Make_Explicit_Dereference (Loc, Value);
Etyp := Etype (Subtype_Mark (Typ));
else
Etyp := Etype (Typ);
end if;
if (Out_Present (Current_Parameter)
or else Nkind (Typ) = N_Access_Definition)
and then Etyp /= Stub_Type
then
Append_To (Non_Asynchronous_Statements,
Make_Attribute_Reference (Loc,
Prefix =>
New_Occurrence_Of (Etyp, Loc),
Attribute_Name => Name_Read,
Expressions => New_List (
Make_Attribute_Reference (Loc,
Prefix =>
New_Occurrence_Of (Result_Parameter, Loc),
Attribute_Name =>
Name_Access),
Value)));
end if;
end;
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 (Present (Asynchronous));
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;
procedure Build_RPC_Receiver_Body
(RPC_Receiver : Entity_Id;
Request : out Entity_Id;
Subp_Id : out Entity_Id;
Subp_Index : out Entity_Id;
Stmts : out List_Id;
Decl : out Node_Id)
is
Loc : constant Source_Ptr := Sloc (RPC_Receiver);
RPC_Receiver_Spec : Node_Id;
RPC_Receiver_Decls : List_Id;
begin
Request := Make_Defining_Identifier (Loc, Name_R);
RPC_Receiver_Spec :=
Build_RPC_Receiver_Specification
(RPC_Receiver => RPC_Receiver,
Request_Parameter => Request);
Subp_Id := Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
Subp_Index := Subp_Id;
RPC_Receiver_Decls := New_List (
Make_Object_Declaration (Loc,
Defining_Identifier => Subp_Id,
Object_Definition =>
New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc),
Expression =>
Make_Attribute_Reference (Loc,
Prefix =>
New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc),
Attribute_Name => Name_Input,
Expressions => New_List (
Make_Selected_Component (Loc,
Prefix => Request,
Selector_Name => Name_Params)))));
Stmts := New_List;
Decl :=
Make_Subprogram_Body (Loc,
Specification => RPC_Receiver_Spec,
Declarations => RPC_Receiver_Decls,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => Stmts));
end Build_RPC_Receiver_Body;
function Build_Stub_Target
(Loc : Source_Ptr;
Decls : List_Id;
RCI_Locator : Entity_Id;
Controlling_Parameter : Entity_Id) return RPC_Target
is
Target_Info : RPC_Target (PCS_Kind => Name_GARLIC_DSA);
begin
Target_Info.Partition :=
Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
if Present (Controlling_Parameter) then
Append_To (Decls,
Make_Object_Declaration (Loc,
Defining_Identifier => Target_Info.Partition,
Constant_Present => True,
Object_Definition =>
New_Occurrence_Of (RTE (RE_Partition_ID), Loc),
Expression =>
Make_Selected_Component (Loc,
Prefix => Controlling_Parameter,
Selector_Name => Name_Origin)));
Target_Info.RPC_Receiver :=
Make_Selected_Component (Loc,
Prefix => Controlling_Parameter,
Selector_Name => Name_Receiver);
else
Append_To (Decls,
Make_Object_Declaration (Loc,
Defining_Identifier => Target_Info.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)))));
Target_Info.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;
return Target_Info;
end Build_Stub_Target;
procedure Build_Stub_Type
(RACW_Type : Entity_Id;
Stub_Type : Entity_Id;
Stub_Type_Decl : out Node_Id;
RPC_Receiver_Decl : out Node_Id)
is
Loc : constant Source_Ptr := Sloc (Stub_Type);
Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type);
begin
Stub_Type_Decl :=
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),
Component_Definition =>
Make_Component_Definition (Loc,
Aliased_Present => False,
Subtype_Indication =>
New_Occurrence_Of (
RTE (RE_Partition_ID), Loc))),
Make_Component_Declaration (Loc,
Defining_Identifier =>
Make_Defining_Identifier (Loc, Name_Receiver),
Component_Definition =>
Make_Component_Definition (Loc,
Aliased_Present => False,
Subtype_Indication =>
New_Occurrence_Of (RTE (RE_Unsigned_64), Loc))),
Make_Component_Declaration (Loc,
Defining_Identifier =>
Make_Defining_Identifier (Loc, Name_Addr),
Component_Definition =>
Make_Component_Definition (Loc,
Aliased_Present => False,
Subtype_Indication =>
New_Occurrence_Of (RTE (RE_Unsigned_64), Loc))),
Make_Component_Declaration (Loc,
Defining_Identifier =>
Make_Defining_Identifier (Loc, Name_Asynchronous),
Component_Definition =>
Make_Component_Definition (Loc,
Aliased_Present => False,
Subtype_Indication =>
New_Occurrence_Of (
Standard_Boolean, Loc)))))));
if Is_RAS then
RPC_Receiver_Decl := Empty;
else
declare
RPC_Receiver_Request : constant Entity_Id :=
Make_Defining_Identifier (Loc, Name_R);
begin
RPC_Receiver_Decl :=
Make_Subprogram_Declaration (Loc,
Build_RPC_Receiver_Specification (
RPC_Receiver => Make_Defining_Identifier (Loc,
New_Internal_Name ('R')),
Request_Parameter => RPC_Receiver_Request));
end;
end if;
end Build_Stub_Type;
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);
Request_Parameter : Node_Id;
Decls : constant List_Id := New_List;
Statements : constant List_Id := New_List;
Extra_Formal_Statements : constant List_Id := New_List;
After_Statements : constant List_Id := New_List;
Inner_Decls : List_Id := No_List;
Excep_Handlers : List_Id := No_List;
Excep_Choice : Entity_Id;
Excep_Code : List_Id;
Parameter_List : constant 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 Present (RACW_Type) then
Called_Subprogram :=
New_Occurrence_Of (Parent_Primitive, Loc);
else
Called_Subprogram :=
New_Occurrence_Of (
Defining_Unit_Name (Specification (Vis_Decl)), Loc);
end if;
Request_Parameter :=
Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
if Dynamically_Asynchronous then
Dynamic_Async :=
Make_Defining_Identifier (Loc, New_Internal_Name ('S'));
else
Dynamic_Async := Empty;
end if;
if not Asynchronous or Dynamically_Asynchronous then
Null_Raise_Statement :=
Make_Attribute_Reference (Loc,
Prefix =>
New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc),
Attribute_Name => Name_Write,
Expressions => New_List (
Make_Selected_Component (Loc,
Prefix => Request_Parameter,
Selector_Name => Name_Result),
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);
end if;
Current_Parameter := First (Ordered_Parameters_List);
while Present (Current_Parameter) loop
declare
Etyp : Entity_Id;
Constrained : Boolean;
Object : constant Entity_Id :=
Make_Defining_Identifier (Loc,
New_Internal_Name ('P'));
Expr : Node_Id := Empty;
Is_Controlling_Formal : constant Boolean :=
Is_RACW_Controlling_Formal
(Current_Parameter, Stub_Type);
begin
Set_Ekind (Object, E_Variable);
if Is_Controlling_Formal 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
or else Is_Controlling_Formal
then
if Constrained and then not Is_Controlling_Formal then
Append_To (Statements,
Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (Etyp, Loc),
Attribute_Name => Name_Read,
Expressions => New_List (
Make_Selected_Component (Loc,
Prefix => Request_Parameter,
Selector_Name => Name_Params),
New_Occurrence_Of (Object, Loc))));
else
Expr := Input_With_Tag_Check (Loc,
Var_Type => Etyp,
Stream => Make_Selected_Component (Loc,
Prefix => Request_Parameter,
Selector_Name => Name_Params));
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 (
Make_Selected_Component (Loc,
Prefix => Request_Parameter,
Selector_Name => Name_Result),
New_Occurrence_Of (Object, Loc))));
end if;
if Is_Controlling_Formal 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 (
Make_Selected_Component (Loc,
Prefix => Request_Parameter,
Selector_Name => Name_Params),
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 (
Make_Selected_Component (Loc,
Prefix => Request_Parameter,
Selector_Name => Name_Result),
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 (
Make_Selected_Component (Loc,
Prefix => Request_Parameter,
Selector_Name => Name_Params),
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
Excep_Handlers := New_List (
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 (
Make_Selected_Component (Loc,
Prefix => Request_Parameter,
Selector_Name => Name_Result),
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_Handlers := New_List (
Make_Exception_Handler (Loc,
Choice_Parameter => Excep_Choice,
Exception_Choices => New_List (Make_Others_Choice (Loc)),
Statements => Excep_Code));
end if;
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 => Request_Parameter,
Parameter_Type =>
New_Occurrence_Of (RTE (RE_Request_Access), Loc))));
return
Make_Subprogram_Body (Loc,
Specification => Subp_Spec,
Declarations => Decls,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => Statements,
Exception_Handlers => Excep_Handlers));
end Build_Subprogram_Receiving_Stubs;
function Result return Node_Id is
begin
return Make_Identifier (Loc, Name_V);
end Result;
function Stream_Parameter return Node_Id is
begin
return Make_Identifier (Loc, Name_S);
end Stream_Parameter;
end GARLIC_Support;
function Make_Selected_Component
(Loc : Source_Ptr;
Prefix : Entity_Id;
Selector_Name : Name_Id) return Node_Id
is
begin
return Make_Selected_Component (Loc,
Prefix => New_Occurrence_Of (Prefix, Loc),
Selector_Name => Make_Identifier (Loc, Selector_Name));
end Make_Selected_Component;
function Get_PCS_Name return PCS_Names is
PCS_Name : constant PCS_Names :=
Chars (Entity (Expression
(Parent (RTE (RE_DSA_Implementation)))));
begin
return PCS_Name;
end Get_PCS_Name;
function Get_Subprogram_Id (Def : Entity_Id) return String_Id is
begin
return Get_Subprogram_Ids (Def).Str_Identifier;
end Get_Subprogram_Id;
function Get_Subprogram_Id (Def : Entity_Id) return Int is
begin
return Get_Subprogram_Ids (Def).Int_Identifier;
end Get_Subprogram_Id;
function Get_Subprogram_Ids
(Def : Entity_Id) return Subprogram_Identifiers
is
Result : Subprogram_Identifiers :=
Subprogram_Identifier_Table.Get (Def);
Current_Declaration : Node_Id;
Current_Subp : Entity_Id;
Current_Subp_Str : String_Id;
Current_Subp_Number : Int := First_RCI_Subprogram_Id;
begin
if Result.Str_Identifier = No_String then
pragma Assert
(Is_Remote_Call_Interface (Scope (Def))
and then
(Nkind (Parent (Def)) = N_Procedure_Specification
or else
Nkind (Parent (Def)) = N_Function_Specification));
Current_Declaration :=
First (Visible_Declarations
(Package_Specification_Of_Scope (Scope (Def))));
while Present (Current_Declaration) loop
if Nkind (Current_Declaration) = N_Subprogram_Declaration
and then Comes_From_Source (Current_Declaration)
then
Current_Subp := Defining_Unit_Name (Specification (
Current_Declaration));
Assign_Subprogram_Identifier
(Current_Subp, Current_Subp_Number, Current_Subp_Str);
if Current_Subp = Def then
Result := (Current_Subp_Str, Current_Subp_Number);
end if;
Current_Subp_Number := Current_Subp_Number + 1;
end if;
Next (Current_Declaration);
end loop;
end if;
pragma Assert (Result.Str_Identifier /= No_String);
return Result;
end Get_Subprogram_Ids;
function Hash (F : Entity_Id) return Hash_Index is
begin
return Hash_Index (Natural (F) mod Positive (Hash_Index'Last + 1));
end Hash;
function Hash (F : Name_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 : Node_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 (Stream)))))));
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 : Node_Id;
Object : Entity_Id;
Etyp : Entity_Id := Empty) return Node_Id
is
Typ : Entity_Id;
begin
if Present (Etyp) 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 : Node_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 (
Stream,
Object));
end Pack_Node_Into_Stream_Access;
package body PolyORB_Support is
procedure Add_RACW_Read_Attribute
(RACW_Type : Entity_Id;
Stub_Type : Entity_Id;
Stub_Type_Access : Entity_Id;
Declarations : List_Id);
procedure Add_RACW_Write_Attribute
(RACW_Type : Entity_Id;
Stub_Type : Entity_Id;
Stub_Type_Access : Entity_Id;
Declarations : List_Id);
procedure Add_RACW_From_Any
(RACW_Type : Entity_Id;
Stub_Type : Entity_Id;
Stub_Type_Access : Entity_Id;
Declarations : List_Id);
procedure Add_RACW_To_Any
(Designated_Type : Entity_Id;
RACW_Type : Entity_Id;
Stub_Type : Entity_Id;
Stub_Type_Access : Entity_Id;
Declarations : List_Id);
procedure Add_RACW_TypeCode
(Designated_Type : Entity_Id;
RACW_Type : Entity_Id;
Declarations : List_Id);
procedure Add_RAS_From_Any
(RAS_Type : Entity_Id;
Declarations : List_Id);
procedure Add_RAS_To_Any
(RAS_Type : Entity_Id;
Declarations : List_Id);
procedure Add_RAS_TypeCode
(RAS_Type : Entity_Id;
Declarations : List_Id);
procedure Add_RAS_Access_TSS (N : Node_Id);
procedure Add_Obj_RPC_Receiver_Completion
(Loc : Source_Ptr;
Decls : List_Id;
RPC_Receiver : Entity_Id;
Stub_Elements : Stub_Structure)
is
Desig : constant Entity_Id :=
Etype (Designated_Type (Stub_Elements.RACW_Type));
begin
Append_To (Decls,
Make_Procedure_Call_Statement (Loc,
Name =>
New_Occurrence_Of (
RTE (RE_Register_Obj_Receiving_Stub), Loc),
Parameter_Associations => New_List (
Make_String_Literal (Loc,
Full_Qualified_Name (Desig)),
Make_Attribute_Reference (Loc,
Prefix =>
New_Occurrence_Of (
Defining_Unit_Name (Parent (RPC_Receiver)), Loc),
Attribute_Name =>
Name_Access),
Make_Attribute_Reference (Loc,
Prefix =>
New_Occurrence_Of (
Defining_Identifier (
Stub_Elements.RPC_Receiver_Decl), Loc),
Attribute_Name =>
Name_Access))));
end Add_Obj_RPC_Receiver_Completion;
procedure Add_RACW_Features
(RACW_Type : Entity_Id;
Desig : Entity_Id;
Stub_Type : Entity_Id;
Stub_Type_Access : Entity_Id;
RPC_Receiver_Decl : Node_Id;
Declarations : List_Id)
is
pragma Warnings (Off);
pragma Unreferenced (RPC_Receiver_Decl);
pragma Warnings (On);
begin
Add_RACW_From_Any
(RACW_Type => RACW_Type,
Stub_Type => Stub_Type,
Stub_Type_Access => Stub_Type_Access,
Declarations => Declarations);
Add_RACW_To_Any
(Designated_Type => Desig,
RACW_Type => RACW_Type,
Stub_Type => Stub_Type,
Stub_Type_Access => Stub_Type_Access,
Declarations => Declarations);
Add_RACW_Write_Attribute
(RACW_Type => RACW_Type,
Stub_Type => Stub_Type,
Stub_Type_Access => Stub_Type_Access,
Declarations => Declarations);
Add_RACW_Read_Attribute
(RACW_Type => RACW_Type,
Stub_Type => Stub_Type,
Stub_Type_Access => Stub_Type_Access,
Declarations => Declarations);
Add_RACW_TypeCode
(Designated_Type => Desig,
RACW_Type => RACW_Type,
Declarations => Declarations);
end Add_RACW_Features;
procedure Add_RACW_From_Any
(RACW_Type : Entity_Id;
Stub_Type : Entity_Id;
Stub_Type_Access : Entity_Id;
Declarations : List_Id)
is
Loc : constant Source_Ptr := Sloc (RACW_Type);
Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type);
Fnam : constant Entity_Id :=
Make_Defining_Identifier (Loc, New_Internal_Name ('F'));
Func_Spec : Node_Id;
Func_Decl : Node_Id;
Func_Body : Node_Id;
Decls : List_Id;
Statements : List_Id;
Stub_Statements : List_Id;
Local_Statements : List_Id;
Any_Parameter : constant Entity_Id :=
Make_Defining_Identifier (Loc, Name_A);
Reference : constant Entity_Id :=
Make_Defining_Identifier
(Loc, New_Internal_Name ('R'));
Is_Local : constant Entity_Id :=
Make_Defining_Identifier
(Loc, New_Internal_Name ('L'));
Addr : constant Entity_Id :=
Make_Defining_Identifier
(Loc, New_Internal_Name ('A'));
Local_Stub : constant Entity_Id :=
Make_Defining_Identifier
(Loc, New_Internal_Name ('L'));
Stubbed_Result : constant Entity_Id :=
Make_Defining_Identifier
(Loc, New_Internal_Name ('S'));
Stub_Condition : Node_Id;
Asynchronous_Flag : constant Entity_Id :=
Asynchronous_Flags_Table.Get (RACW_Type);
begin
Decls := New_List (
Make_Object_Declaration (Loc,
Defining_Identifier =>
Reference,
Object_Definition =>
New_Occurrence_Of (RTE (RE_Object_Ref), Loc),
Expression =>
Make_Function_Call (Loc,
Name =>
New_Occurrence_Of (RTE (RE_FA_ObjRef), Loc),
Parameter_Associations => New_List (
New_Occurrence_Of (Any_Parameter, Loc)))),
Make_Object_Declaration (Loc,
Defining_Identifier => Local_Stub,
Aliased_Present => True,
Object_Definition => New_Occurrence_Of (Stub_Type, Loc)),
Make_Object_Declaration (Loc,
Defining_Identifier => Stubbed_Result,
Object_Definition =>
New_Occurrence_Of (Stub_Type_Access, Loc),
Expression =>
Make_Attribute_Reference (Loc,
Prefix =>
New_Occurrence_Of (Local_Stub, Loc),
Attribute_Name =>
Name_Unchecked_Access)),
Make_Object_Declaration (Loc,
Defining_Identifier => Is_Local,
Object_Definition =>
New_Occurrence_Of (Standard_Boolean, Loc)),
Make_Object_Declaration (Loc,
Defining_Identifier => Addr,
Object_Definition =>
New_Occurrence_Of (RTE (RE_Address), Loc)));
Set_Etype (Stubbed_Result, Stub_Type_Access);
Statements := New_List (
Make_Implicit_If_Statement (RACW_Type,
Condition =>
Make_Function_Call (Loc,
Name =>
New_Occurrence_Of (RTE (RE_Is_Nil), Loc),
Parameter_Associations => New_List (
New_Occurrence_Of (Reference, Loc))),
Then_Statements => New_List (
Make_Return_Statement (Loc,
Expression =>
Make_Null (Loc)))));
Append_To (Statements,
Make_Procedure_Call_Statement (Loc,
Name =>
New_Occurrence_Of (RTE (RE_Get_Local_Address), Loc),
Parameter_Associations => New_List (
New_Occurrence_Of (Reference, Loc),
New_Occurrence_Of (Is_Local, Loc),
New_Occurrence_Of (Addr, Loc))));
Stub_Statements := New_List (
Make_Assignment_Statement (Loc,
Name => Make_Selected_Component (Loc,
Prefix => Stubbed_Result,
Selector_Name => Name_Target),
Expression =>
Make_Function_Call (Loc,
Name =>
New_Occurrence_Of (RTE (RE_Entity_Of), Loc),
Parameter_Associations => New_List (
New_Occurrence_Of (Reference, Loc)))),
Make_Procedure_Call_Statement (Loc,
Name =>
New_Occurrence_Of (RTE (RE_Inc_Usage), Loc),
Parameter_Associations => New_List (
Make_Selected_Component (Loc,
Prefix => Stubbed_Result,
Selector_Name => Name_Target))),
Make_Assignment_Statement (Loc,
Name => Make_Selected_Component (Loc,
Prefix => Stubbed_Result,
Selector_Name => Name_Asynchronous),
Expression =>
New_Occurrence_Of (Asynchronous_Flag, Loc)));
Append_List_To (Stub_Statements,
Build_Get_Unique_RP_Call (Loc, Stubbed_Result, Stub_Type));
Stub_Condition := New_Occurrence_Of (Is_Local, Loc);
if Is_RAS then
Stub_Condition := Make_And_Then (Loc,
Left_Opnd =>
Stub_Condition,
Right_Opnd =>
Make_Selected_Component (Loc,
Prefix =>
Unchecked_Convert_To (
RTE (RE_RAS_Proxy_Type_Access),
New_Occurrence_Of (Addr, Loc)),
Selector_Name =>
Make_Identifier (Loc,
Name_All_Calls_Remote)));
end if;
Local_Statements := New_List (
Make_Return_Statement (Loc,
Expression =>
Unchecked_Convert_To (RACW_Type,
New_Occurrence_Of (Addr, Loc))));
Append_To (Statements,
Make_Implicit_If_Statement (RACW_Type,
Condition =>
Stub_Condition,
Then_Statements => Local_Statements,
Else_Statements => Stub_Statements));
Append_To (Statements,
Make_Return_Statement (Loc,
Expression => Unchecked_Convert_To (RACW_Type,
New_Occurrence_Of (Stubbed_Result, Loc))));
Func_Spec :=
Make_Function_Specification (Loc,
Defining_Unit_Name =>
Fnam,
Parameter_Specifications => New_List (
Make_Parameter_Specification (Loc,
Defining_Identifier =>
Any_Parameter,
Parameter_Type =>
New_Occurrence_Of (RTE (RE_Any), Loc))),
Subtype_Mark => New_Occurrence_Of (RACW_Type, Loc));
Func_Decl := Make_Subprogram_Declaration (Loc, Func_Spec);
Func_Body :=
Make_Subprogram_Body (Loc,
Specification =>
Copy_Specification (Loc, Func_Spec),
Declarations => Decls,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => Statements));
Insert_After (Declaration_Node (RACW_Type), Func_Decl);
Append_To (Declarations, Func_Body);
Set_Renaming_TSS (RACW_Type, Fnam, Name_uFrom_Any);
end Add_RACW_From_Any;
procedure Add_RACW_Read_Attribute
(RACW_Type : Entity_Id;
Stub_Type : Entity_Id;
Stub_Type_Access : Entity_Id;
Declarations : List_Id)
is
pragma Warnings (Off);
pragma Unreferenced (Stub_Type, Stub_Type_Access);
pragma Warnings (On);
Loc : constant Source_Ptr := Sloc (RACW_Type);
Proc_Decl : Node_Id;
Attr_Decl : Node_Id;
Body_Node : Node_Id;
Decls : List_Id;
Statements : List_Id;
Procedure_Name : constant Name_Id :=
New_Internal_Name ('R');
Source_Ref : constant Entity_Id :=
Make_Defining_Identifier
(Loc, New_Internal_Name ('R'));
Asynchronous_Flag : constant Entity_Id :=
Asynchronous_Flags_Table.Get (RACW_Type);
pragma Assert (Present (Asynchronous_Flag));
function Stream_Parameter return Node_Id;
function Result return Node_Id;
function Result return Node_Id is
begin
return Make_Identifier (Loc, Name_V);
end Result;
function Stream_Parameter return Node_Id is
begin
return Make_Identifier (Loc, Name_S);
end Stream_Parameter;
begin
Decls := New_List (
Make_Object_Declaration (Loc,
Defining_Identifier => Source_Ref,
Object_Definition =>
New_Occurrence_Of (RTE (RE_Object_Ref), Loc)));
Statements := New_List (
Make_Attribute_Reference (Loc,
Prefix =>
New_Occurrence_Of (RTE (RE_Object_Ref), Loc),
Attribute_Name => Name_Read,
Expressions => New_List (
Stream_Parameter,
New_Occurrence_Of (Source_Ref, Loc))),
Make_Assignment_Statement (Loc,
Name =>
Result,
Expression =>
PolyORB_Support.Helpers.Build_From_Any_Call (
RACW_Type,
Make_Function_Call (Loc,
Name =>
New_Occurrence_Of (RTE (RE_TA_ObjRef), Loc),
Parameter_Associations => New_List (
New_Occurrence_Of (Source_Ref, Loc))),
Decls)));
Build_Stream_Procedure
(Loc, RACW_Type, Body_Node,
Make_Defining_Identifier (Loc, Procedure_Name),
Statements, Outp => True);
Set_Declarations (Body_Node, Decls);
Proc_Decl := Make_Subprogram_Declaration (Loc,
Copy_Specification (Loc, Specification (Body_Node)));
Attr_Decl :=
Make_Attribute_Definition_Clause (Loc,
Name => New_Occurrence_Of (RACW_Type, Loc),
Chars => Name_Read,
Expression =>
New_Occurrence_Of (
Defining_Unit_Name (Specification (Proc_Decl)), 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_To_Any
(Designated_Type : Entity_Id;
RACW_Type : Entity_Id;
Stub_Type : Entity_Id;
Stub_Type_Access : Entity_Id;
Declarations : List_Id)
is
Loc : constant Source_Ptr := Sloc (RACW_Type);
Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type);
Fnam : Entity_Id;
Stub_Elements : constant Stub_Structure :=
Stubs_Table.Get (Designated_Type);
pragma Assert (Stub_Elements /= Empty_Stub_Structure);
Func_Spec : Node_Id;
Func_Decl : Node_Id;
Func_Body : Node_Id;
Decls : List_Id;
Statements : List_Id;
Null_Statements : List_Id;
Local_Statements : List_Id := No_List;
Stub_Statements : List_Id;
If_Node : Node_Id;
RACW_Parameter : constant Entity_Id
:= Make_Defining_Identifier (Loc, Name_R);
Reference : constant Entity_Id :=
Make_Defining_Identifier
(Loc, New_Internal_Name ('R'));
Any : constant Entity_Id :=
Make_Defining_Identifier
(Loc, New_Internal_Name ('A'));
begin
Decls := New_List (
Make_Object_Declaration (Loc,
Defining_Identifier =>
Reference,
Object_Definition =>
New_Occurrence_Of (RTE (RE_Object_Ref), Loc)),
Make_Object_Declaration (Loc,
Defining_Identifier =>
Any,
Object_Definition =>
New_Occurrence_Of (RTE (RE_Any), Loc)));
Null_Statements := New_List (Make_Null_Statement (Loc));
if Is_RAS then
Local_Statements := New_List (
Make_Procedure_Call_Statement (Loc,
Name =>
New_Occurrence_Of (RTE (RE_Set_Ref), Loc),
Parameter_Associations => New_List (
New_Occurrence_Of (Reference, Loc),
Make_Selected_Component (Loc,
Prefix =>
Unchecked_Convert_To (RTE (RE_RAS_Proxy_Type_Access),
New_Occurrence_Of (RACW_Parameter, Loc)),
Selector_Name => Make_Identifier (Loc, Name_Target)))));
else
Local_Statements := New_List (
Make_Procedure_Call_Statement (Loc,
Name =>
New_Occurrence_Of (RTE (RE_Get_Reference), Loc),
Parameter_Associations => New_List (
Unchecked_Convert_To (
RTE (RE_Address),
New_Occurrence_Of (RACW_Parameter, Loc)),
Make_String_Literal (Loc,
Full_Qualified_Name (Designated_Type)),
Make_Attribute_Reference (Loc,
Prefix =>
New_Occurrence_Of (
Defining_Identifier (
Stub_Elements.RPC_Receiver_Decl), Loc),
Attribute_Name =>
Name_Access),
New_Occurrence_Of (Reference, Loc))));
end if;
Stub_Statements := New_List (
Make_Procedure_Call_Statement (Loc,
Name =>
New_Occurrence_Of (RTE (RE_Set_Ref), Loc),
Parameter_Associations => New_List (
New_Occurrence_Of (Reference, Loc),
Make_Selected_Component (Loc,
Prefix => Unchecked_Convert_To (Stub_Type_Access,
New_Occurrence_Of (RACW_Parameter, Loc)),
Selector_Name =>
Make_Identifier (Loc, Name_Target)))));
If_Node :=
Make_Implicit_If_Statement (RACW_Type,
Condition =>
Make_Op_Eq (Loc,
Left_Opnd => New_Occurrence_Of (RACW_Parameter, Loc),
Right_Opnd => Make_Null (Loc)),
Then_Statements => Null_Statements,
Elsif_Parts => New_List (
Make_Elsif_Part (Loc,
Condition =>
Make_Op_Ne (Loc,
Left_Opnd =>
Make_Attribute_Reference (Loc,
Prefix =>
New_Occurrence_Of (RACW_Parameter, Loc),
Attribute_Name => Name_Tag),
Right_Opnd =>
Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (Stub_Type, Loc),
Attribute_Name => Name_Tag)),
Then_Statements => Local_Statements)),
Else_Statements => Stub_Statements);
Statements := New_List (
If_Node,
Make_Assignment_Statement (Loc,
Name =>
New_Occurrence_Of (Any, Loc),
Expression =>
Make_Function_Call (Loc,
Name => New_Occurrence_Of (RTE (RE_TA_ObjRef), Loc),
Parameter_Associations => New_List (
New_Occurrence_Of (Reference, Loc)))),
Make_Procedure_Call_Statement (Loc,
Name =>
New_Occurrence_Of (RTE (RE_Set_TC), Loc),
Parameter_Associations => New_List (
New_Occurrence_Of (Any, Loc),
Make_Selected_Component (Loc,
Prefix =>
Defining_Identifier (
Stub_Elements.RPC_Receiver_Decl),
Selector_Name => Name_Obj_TypeCode))),
Make_Return_Statement (Loc,
Expression =>
New_Occurrence_Of (Any, Loc)));
Fnam := Make_Defining_Identifier (
Loc, New_Internal_Name ('T'));
Func_Spec :=
Make_Function_Specification (Loc,
Defining_Unit_Name =>
Fnam,
Parameter_Specifications => New_List (
Make_Parameter_Specification (Loc,
Defining_Identifier =>
RACW_Parameter,
Parameter_Type =>
New_Occurrence_Of (RACW_Type, Loc))),
Subtype_Mark => New_Occurrence_Of (RTE (RE_Any), Loc));
Func_Decl := Make_Subprogram_Declaration (Loc, Func_Spec);
Func_Body :=
Make_Subprogram_Body (Loc,
Specification =>
Copy_Specification (Loc, Func_Spec),
Declarations => Decls,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => Statements));
Insert_After (Declaration_Node (RACW_Type), Func_Decl);
Append_To (Declarations, Func_Body);
Set_Renaming_TSS (RACW_Type, Fnam, Name_uTo_Any);
end Add_RACW_To_Any;
procedure Add_RACW_TypeCode
(Designated_Type : Entity_Id;
RACW_Type : Entity_Id;
Declarations : List_Id)
is
Loc : constant Source_Ptr := Sloc (RACW_Type);
Fnam : Entity_Id;
Stub_Elements : constant Stub_Structure :=
Stubs_Table.Get (Designated_Type);
pragma Assert (Stub_Elements /= Empty_Stub_Structure);
Func_Spec : Node_Id;
Func_Decl : Node_Id;
Func_Body : Node_Id;
RACW_Parameter : constant Entity_Id :=
Make_Defining_Identifier (Loc, Name_R);
begin
Fnam :=
Make_Defining_Identifier (Loc,
Chars => New_Internal_Name ('T'));
Func_Spec :=
Make_Function_Specification (Loc,
Defining_Unit_Name =>
Fnam,
Parameter_Specifications => New_List (
Make_Parameter_Specification (Loc,
Defining_Identifier =>
RACW_Parameter,
Parameter_Type =>
Make_Access_Definition (Loc,
Subtype_Mark =>
New_Occurrence_Of (RACW_Type, Loc)))),
Subtype_Mark => New_Occurrence_Of (RTE (RE_TypeCode), Loc));
Func_Decl := Make_Subprogram_Declaration (Loc, Func_Spec);
Func_Body :=
Make_Subprogram_Body (Loc,
Specification =>
Copy_Specification (Loc, Func_Spec),
Declarations => Empty_List,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => New_List (
Make_Return_Statement (Loc,
Expression =>
Make_Selected_Component (Loc,
Prefix =>
Defining_Identifier (
Stub_Elements.RPC_Receiver_Decl),
Selector_Name => Name_Obj_TypeCode)))));
Insert_After (Declaration_Node (RACW_Type), Func_Decl);
Append_To (Declarations, Func_Body);
Set_Renaming_TSS (RACW_Type, Fnam, Name_uTypeCode);
end Add_RACW_TypeCode;
procedure Add_RACW_Write_Attribute
(RACW_Type : Entity_Id;
Stub_Type : Entity_Id;
Stub_Type_Access : Entity_Id;
Declarations : List_Id)
is
Loc : constant Source_Ptr := Sloc (RACW_Type);
pragma Warnings (Off);
pragma Unreferenced (
Stub_Type,
Stub_Type_Access);
Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type);
pragma Unreferenced (Is_RAS);
pragma Warnings (On);
Body_Node : Node_Id;
Proc_Decl : Node_Id;
Attr_Decl : Node_Id;
Statements : List_Id;
Procedure_Name : constant Name_Id := New_Internal_Name ('R');
function Stream_Parameter return Node_Id;
function Object return Node_Id;
function Object return Node_Id is
Object_Ref : constant Node_Id :=
Make_Identifier (Loc, Name_V);
begin
Set_Etype (Object_Ref, RACW_Type);
return Object_Ref;
end Object;
function Stream_Parameter return Node_Id is
begin
return Make_Identifier (Loc, Name_S);
end Stream_Parameter;
begin
Statements := New_List (
Pack_Node_Into_Stream_Access (Loc,
Stream => Stream_Parameter,
Object =>
Make_Function_Call (Loc,
Name =>
New_Occurrence_Of (RTE (RE_FA_ObjRef), Loc),
Parameter_Associations => New_List (
PolyORB_Support.Helpers.Build_To_Any_Call
(Object, Declarations))),
Etyp => RTE (RE_Object_Ref)));
Build_Stream_Procedure
(Loc, RACW_Type, Body_Node,
Make_Defining_Identifier (Loc, Procedure_Name),
Statements, Outp => False);
Proc_Decl :=
Make_Subprogram_Declaration (Loc,
Copy_Specification (Loc, Specification (Body_Node)));
Attr_Decl :=
Make_Attribute_Definition_Clause (Loc,
Name => New_Occurrence_Of (RACW_Type, Loc),
Chars => Name_Write,
Expression =>
New_Occurrence_Of (
Defining_Unit_Name (Specification (Proc_Decl)), Loc));
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_RAST_Features
(Vis_Decl : Node_Id;
RAS_Type : Entity_Id;
Decls : List_Id)
is
begin
Add_RAS_Access_TSS (Vis_Decl);
Add_RAS_From_Any (RAS_Type, Decls);
Add_RAS_TypeCode (RAS_Type, Decls);
Add_RAS_To_Any (RAS_Type, Decls);
end Add_RAST_Features;
procedure Add_RAS_Access_TSS (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
Ras_Type : constant Entity_Id := Defining_Identifier (N);
Fat_Type : constant Entity_Id := Equivalent_Type (Ras_Type);
RACW_Type : constant Entity_Id :=
Underlying_RACW_Type (Ras_Type);
Desig : constant Entity_Id :=
Etype (Designated_Type (RACW_Type));
Stub_Elements : constant Stub_Structure :=
Stubs_Table.Get (Desig);
pragma Assert (Stub_Elements /= Empty_Stub_Structure);
Proc : constant Entity_Id :=
Make_Defining_Identifier (Loc,
Chars => Make_TSS_Name (Ras_Type, TSS_RAS_Access));
Proc_Spec : Node_Id;
Package_Name : constant Entity_Id :=
Make_Defining_Identifier (Loc,
Chars => Name_P);
Subp_Id : constant Entity_Id :=
Make_Defining_Identifier (Loc,
Chars => Name_S);
Asynch_P : constant Entity_Id :=
Make_Defining_Identifier (Loc,
Chars => Name_Asynchronous);
All_Calls_Remote : constant Entity_Id :=
Make_Defining_Identifier (Loc,
Chars => Name_All_Calls_Remote);
Proc_Decls : List_Id;
Proc_Statements : List_Id;
Subp_Ref : constant Entity_Id :=
Make_Defining_Identifier (Loc, Name_R);
Is_Local : constant Entity_Id :=
Make_Defining_Identifier (Loc, Name_L);
Local_Addr : constant Entity_Id :=
Make_Defining_Identifier (Loc, Name_A);
Local_Stub : constant Entity_Id :=
Make_Defining_Identifier (Loc,
Chars => New_Internal_Name ('L'));
Stub_Ptr : constant Entity_Id :=
Make_Defining_Identifier (Loc,
Chars => New_Internal_Name ('S'));
function Set_Field
(Field_Name : Name_Id;
Value : Node_Id) return Node_Id;
function Set_Field
(Field_Name : Name_Id;
Value : Node_Id) return Node_Id
is
begin
return
Make_Assignment_Statement (Loc,
Name =>
Make_Selected_Component (Loc,
Prefix => Stub_Ptr,
Selector_Name => Field_Name),
Expression => Value);
end Set_Field;
begin
Proc_Decls := New_List (
Make_Object_Declaration (Loc,
Defining_Identifier => Subp_Ref,
Object_Definition =>
New_Occurrence_Of (RTE (RE_Object_Ref), Loc)),
Make_Object_Declaration (Loc,
Defining_Identifier => Is_Local,
Object_Definition =>
New_Occurrence_Of (Standard_Boolean, Loc)),
Make_Object_Declaration (Loc,
Defining_Identifier => Local_Addr,
Object_Definition =>
New_Occurrence_Of (RTE (RE_Address), Loc)),
Make_Object_Declaration (Loc,
Defining_Identifier => Local_Stub,
Aliased_Present => True,
Object_Definition =>
New_Occurrence_Of (Stub_Elements.Stub_Type, Loc)),
Make_Object_Declaration (Loc,
Defining_Identifier =>
Stub_Ptr,
Object_Definition =>
New_Occurrence_Of (Stub_Elements.Stub_Type_Access, Loc),
Expression =>
Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (Local_Stub, Loc),
Attribute_Name => Name_Unchecked_Access)));
Set_Etype (Stub_Ptr, Stub_Elements.Stub_Type_Access);
Proc_Statements := New_List (
Make_Procedure_Call_Statement (Loc,
Name =>
New_Occurrence_Of (RTE (RE_Get_RAS_Info), Loc),
Parameter_Associations => New_List (
New_Occurrence_Of (Package_Name, Loc),
New_Occurrence_Of (Subp_Id, Loc),
New_Occurrence_Of (Subp_Ref, Loc))),
Make_Procedure_Call_Statement (Loc,
Name =>
New_Occurrence_Of (RTE (RE_Get_Local_Address), Loc),
Parameter_Associations => New_List (
New_Occurrence_Of (Subp_Ref, Loc),
New_Occurrence_Of (Is_Local, Loc),
New_Occurrence_Of (Local_Addr, Loc))));
Append_To (Proc_Statements,
Make_Implicit_If_Statement (N,
Condition =>
New_Occurrence_Of (Is_Local, Loc),
Then_Statements => New_List (
Make_Implicit_If_Statement (N,
Condition =>
Make_Op_Eq (Loc,
Make_Selected_Component (Loc,
Prefix =>
Unchecked_Convert_To (
RTE (RE_RAS_Proxy_Type_Access),
New_Occurrence_Of (Local_Addr, Loc)),
Selector_Name =>
Make_Identifier (Loc, Name_Target)),
Make_Null (Loc)),
Then_Statements => New_List (
Make_Assignment_Statement (Loc,
Name =>
Make_Selected_Component (Loc,
Prefix =>
Unchecked_Convert_To (
RTE (RE_RAS_Proxy_Type_Access),
New_Occurrence_Of (Local_Addr, Loc)),
Selector_Name =>
Make_Identifier (Loc, Name_Target)),
Expression =>
Make_Function_Call (Loc,
Name =>
New_Occurrence_Of (RTE (RE_Entity_Of), Loc),
Parameter_Associations => New_List (
New_Occurrence_Of (Subp_Ref, Loc)))),
Make_Procedure_Call_Statement (Loc,
Name =>
New_Occurrence_Of (RTE (RE_Inc_Usage), Loc),
Parameter_Associations => New_List (
Make_Selected_Component (Loc,
Prefix =>
Unchecked_Convert_To (
RTE (RE_RAS_Proxy_Type_Access),
New_Occurrence_Of (Local_Addr, Loc)),
Selector_Name => Make_Identifier (Loc,
Name_Target)))))),
Make_Implicit_If_Statement (N,
Condition =>
Make_Op_Not (Loc,
New_Occurrence_Of (All_Calls_Remote, Loc)),
Then_Statements => New_List (
Make_Return_Statement (Loc,
Unchecked_Convert_To (Fat_Type,
New_Occurrence_Of (Local_Addr, Loc))))))));
Append_List_To (Proc_Statements, New_List (
Set_Field (Name_Target,
Make_Function_Call (Loc,
Name =>
New_Occurrence_Of (RTE (RE_Entity_Of), Loc),
Parameter_Associations => New_List (
New_Occurrence_Of (Subp_Ref, Loc)))),
Make_Procedure_Call_Statement (Loc,
Name =>
New_Occurrence_Of (RTE (RE_Inc_Usage), Loc),
Parameter_Associations => New_List (
Make_Selected_Component (Loc,
Prefix => Stub_Ptr,
Selector_Name => Name_Target))),
Set_Field (Name_Asynchronous,
Make_Or_Else (Loc,
New_Occurrence_Of (Asynch_P, Loc),
New_Occurrence_Of (Boolean_Literals (
Is_Asynchronous (Ras_Type)), Loc)))));
Append_List_To (Proc_Statements,
Build_Get_Unique_RP_Call (Loc,
Stub_Ptr, Stub_Elements.Stub_Type));
Append_To (Proc_Statements,
Make_Return_Statement (Loc,
Expression =>
Unchecked_Convert_To (Fat_Type,
New_Occurrence_Of (Stub_Ptr, Loc))));
Proc_Spec :=
Make_Function_Specification (Loc,
Defining_Unit_Name => Proc,
Parameter_Specifications => New_List (
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_String, Loc)),
Make_Parameter_Specification (Loc,
Defining_Identifier => Asynch_P,
Parameter_Type =>
New_Occurrence_Of (Standard_Boolean, Loc)),
Make_Parameter_Specification (Loc,
Defining_Identifier => All_Calls_Remote,
Parameter_Type =>
New_Occurrence_Of (Standard_Boolean, Loc))),
Subtype_Mark =>
New_Occurrence_Of (Fat_Type, Loc));
Set_Ekind (Proc, E_Function);
Set_Etype (Proc, Fat_Type);
Discard_Node (
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_TSS;
procedure Add_RAS_From_Any
(RAS_Type : Entity_Id;
Declarations : List_Id)
is
Loc : constant Source_Ptr := Sloc (RAS_Type);
Fnam : constant Entity_Id :=
Make_Defining_Identifier (Loc, New_Internal_Name ('F'));
Func_Spec : Node_Id;
Func_Decl : Node_Id;
Func_Body : Node_Id;
Statements : List_Id;
Any_Parameter : constant Entity_Id :=
Make_Defining_Identifier (Loc, Name_A);
begin
Statements := New_List (
Make_Return_Statement (Loc,
Expression =>
Make_Aggregate (Loc,
Component_Associations => New_List (
Make_Component_Association (Loc,
Choices => New_List (
Make_Identifier (Loc, Name_Ras)),
Expression =>
PolyORB_Support.Helpers.Build_From_Any_Call (
Underlying_RACW_Type (RAS_Type),
New_Occurrence_Of (Any_Parameter, Loc),
No_List))))));
Func_Spec :=
Make_Function_Specification (Loc,
Defining_Unit_Name =>
Fnam,
Parameter_Specifications => New_List (
Make_Parameter_Specification (Loc,
Defining_Identifier =>
Any_Parameter,
Parameter_Type =>
New_Occurrence_Of (RTE (RE_Any), Loc))),
Subtype_Mark => New_Occurrence_Of (RAS_Type, Loc));
Func_Decl := Make_Subprogram_Declaration (Loc, Func_Spec);
Func_Body :=
Make_Subprogram_Body (Loc,
Specification =>
Copy_Specification (Loc, Func_Spec),
Declarations => No_List,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => Statements));
Insert_After (Declaration_Node (RAS_Type), Func_Decl);
Append_To (Declarations, Func_Body);
Set_Renaming_TSS (RAS_Type, Fnam, Name_uFrom_Any);
end Add_RAS_From_Any;
procedure Add_RAS_To_Any
(RAS_Type : Entity_Id;
Declarations : List_Id)
is
Loc : constant Source_Ptr := Sloc (RAS_Type);
Fnam : Entity_Id;
Decls : List_Id;
Statements : List_Id;
Func_Spec : Node_Id;
Func_Decl : Node_Id;
Func_Body : Node_Id;
Any : constant Entity_Id :=
Make_Defining_Identifier (Loc,
Chars => New_Internal_Name ('A'));
RAS_Parameter : constant Entity_Id :=
Make_Defining_Identifier (Loc,
Chars => New_Internal_Name ('R'));
RACW_Parameter : constant Node_Id :=
Make_Selected_Component (Loc,
Prefix => RAS_Parameter,
Selector_Name => Name_Ras);
begin
Set_Etype (RACW_Parameter, Underlying_RACW_Type (RAS_Type));
Decls := New_List (
Make_Object_Declaration (Loc,
Defining_Identifier =>
Any,
Object_Definition =>
New_Occurrence_Of (RTE (RE_Any), Loc),
Expression =>
PolyORB_Support.Helpers.Build_To_Any_Call
(RACW_Parameter, No_List)));
Statements := New_List (
Make_Procedure_Call_Statement (Loc,
Name =>
New_Occurrence_Of (RTE (RE_Set_TC), Loc),
Parameter_Associations => New_List (
New_Occurrence_Of (Any, Loc),
PolyORB_Support.Helpers.Build_TypeCode_Call (Loc,
RAS_Type, Decls))),
Make_Return_Statement (Loc,
Expression =>
New_Occurrence_Of (Any, Loc)));
Fnam := Make_Defining_Identifier (
Loc, New_Internal_Name ('T'));
Func_Spec :=
Make_Function_Specification (Loc,
Defining_Unit_Name =>
Fnam,
Parameter_Specifications => New_List (
Make_Parameter_Specification (Loc,
Defining_Identifier =>
RAS_Parameter,
Parameter_Type =>
New_Occurrence_Of (RAS_Type, Loc))),
Subtype_Mark => New_Occurrence_Of (RTE (RE_Any), Loc));
Func_Decl := Make_Subprogram_Declaration (Loc, Func_Spec);
Func_Body :=
Make_Subprogram_Body (Loc,
Specification =>
Copy_Specification (Loc, Func_Spec),
Declarations => Decls,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => Statements));
Insert_After (Declaration_Node (RAS_Type), Func_Decl);
Append_To (Declarations, Func_Body);
Set_Renaming_TSS (RAS_Type, Fnam, Name_uTo_Any);
end Add_RAS_To_Any;
procedure Add_RAS_TypeCode
(RAS_Type : Entity_Id;
Declarations : List_Id)
is
Loc : constant Source_Ptr := Sloc (RAS_Type);
Fnam : Entity_Id;
Func_Spec : Node_Id;
Func_Decl : Node_Id;
Func_Body : Node_Id;
Decls : constant List_Id := New_List;
Name_String, Repo_Id_String : String_Id;
RAS_Parameter : constant Entity_Id :=
Make_Defining_Identifier (Loc, Name_R);
begin
Fnam :=
Make_Defining_Identifier (Loc,
Chars => New_Internal_Name ('T'));
Func_Spec :=
Make_Function_Specification (Loc,
Defining_Unit_Name =>
Fnam,
Parameter_Specifications => New_List (
Make_Parameter_Specification (Loc,
Defining_Identifier =>
RAS_Parameter,
Parameter_Type =>
Make_Access_Definition (Loc,
Subtype_Mark => New_Occurrence_Of (RAS_Type, Loc)))),
Subtype_Mark => New_Occurrence_Of (RTE (RE_TypeCode), Loc));
Func_Decl := Make_Subprogram_Declaration (Loc, Func_Spec);
PolyORB_Support.Helpers.Build_Name_And_Repository_Id
(RAS_Type, Name_Str => Name_String, Repo_Id_Str => Repo_Id_String);
Func_Body :=
Make_Subprogram_Body (Loc,
Specification =>
Copy_Specification (Loc, Func_Spec),
Declarations => Decls,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => New_List (
Make_Return_Statement (Loc,
Expression =>
Make_Function_Call (Loc,
Name =>
New_Occurrence_Of (RTE (RE_TC_Build), Loc),
Parameter_Associations => New_List (
New_Occurrence_Of (RTE (RE_TC_Object), Loc),
Make_Aggregate (Loc,
Expressions =>
New_List (
Make_Function_Call (Loc,
Name => New_Occurrence_Of (
RTE (RE_TA_String), Loc),
Parameter_Associations => New_List (
Make_String_Literal (Loc, Name_String))),
Make_Function_Call (Loc,
Name => New_Occurrence_Of (
RTE (RE_TA_String), Loc),
Parameter_Associations => New_List (
Make_String_Literal (Loc,
Repo_Id_String)))))))))));
Insert_After (Declaration_Node (RAS_Type), Func_Decl);
Append_To (Declarations, Func_Body);
Set_Renaming_TSS (RAS_Type, Fnam, Name_uTypeCode);
end Add_RAS_TypeCode;
procedure Add_Receiving_Stubs_To_Declarations
(Pkg_Spec : Node_Id;
Decls : List_Id)
is
Loc : constant Source_Ptr := Sloc (Pkg_Spec);
Pkg_RPC_Receiver : constant Entity_Id :=
Make_Defining_Identifier (Loc,
New_Internal_Name ('H'));
Pkg_RPC_Receiver_Object : Node_Id;
Pkg_RPC_Receiver_Body : Node_Id;
Pkg_RPC_Receiver_Decls : List_Id;
Pkg_RPC_Receiver_Statements : List_Id;
Pkg_RPC_Receiver_Cases : constant List_Id := New_List;
Request : Node_Id;
Subp_Id : Entity_Id;
Subp_Index : Entity_Id;
Is_Local : constant Entity_Id :=
Make_Defining_Identifier (Loc, New_Internal_Name ('L'));
Local_Address : constant Entity_Id :=
Make_Defining_Identifier (Loc, New_Internal_Name ('A'));
Dispatch_On_Address : constant List_Id := New_List;
Dispatch_On_Name : constant List_Id := New_List;
Current_Declaration : Node_Id;
Current_Stubs : Node_Id;
Current_Subprogram_Number : Int := First_RCI_Subprogram_Id;
Subp_Info_Array : constant Entity_Id :=
Make_Defining_Identifier (Loc,
Chars => New_Internal_Name ('I'));
Subp_Info_List : constant List_Id := New_List;
Register_Pkg_Actuals : constant List_Id := New_List;
All_Calls_Remote_E : Entity_Id;
procedure Append_Stubs_To
(RPC_Receiver_Cases : List_Id;
Declaration : Node_Id;
Stubs : Node_Id;
Subp_Number : Int;
Subp_Dist_Name : Entity_Id;
Subp_Proxy_Addr : Entity_Id);
procedure Append_Stubs_To
(RPC_Receiver_Cases : List_Id;
Declaration : Node_Id;
Stubs : Node_Id;
Subp_Number : Int;
Subp_Dist_Name : Entity_Id;
Subp_Proxy_Addr : Entity_Id)
is
Case_Stmts : List_Id;
begin
Case_Stmts := New_List (
Make_Procedure_Call_Statement (Loc,
Name =>
New_Occurrence_Of (
Defining_Entity (Stubs), Loc),
Parameter_Associations =>
New_List (New_Occurrence_Of (Request, Loc))));
if Nkind (Specification (Declaration))
= N_Function_Specification
or else not
Is_Asynchronous (Defining_Entity (Specification (Declaration)))
then
Append_To (Case_Stmts, Make_Return_Statement (Loc));
end if;
Append_To (RPC_Receiver_Cases,
Make_Case_Statement_Alternative (Loc,
Discrete_Choices =>
New_List (Make_Integer_Literal (Loc, Subp_Number)),
Statements =>
Case_Stmts));
Append_To (Dispatch_On_Name,
Make_Elsif_Part (Loc,
Condition =>
Make_Function_Call (Loc,
Name =>
New_Occurrence_Of (RTE (RE_Caseless_String_Eq), Loc),
Parameter_Associations => New_List (
New_Occurrence_Of (Subp_Id, Loc),
New_Occurrence_Of (Subp_Dist_Name, Loc))),
Then_Statements => New_List (
Make_Assignment_Statement (Loc,
New_Occurrence_Of (Subp_Index, Loc),
Make_Integer_Literal (Loc,
Subp_Number)))));
Append_To (Dispatch_On_Address,
Make_Elsif_Part (Loc,
Condition =>
Make_Op_Eq (Loc,
Left_Opnd =>
New_Occurrence_Of (Local_Address, Loc),
Right_Opnd =>
New_Occurrence_Of (Subp_Proxy_Addr, Loc)),
Then_Statements => New_List (
Make_Assignment_Statement (Loc,
New_Occurrence_Of (Subp_Index, Loc),
Make_Integer_Literal (Loc,
Subp_Number)))));
end Append_Stubs_To;
begin
Build_RPC_Receiver_Body (
RPC_Receiver => Pkg_RPC_Receiver,
Request => Request,
Subp_Id => Subp_Id,
Subp_Index => Subp_Index,
Stmts => Pkg_RPC_Receiver_Statements,
Decl => Pkg_RPC_Receiver_Body);
Pkg_RPC_Receiver_Decls := Declarations (Pkg_RPC_Receiver_Body);
Append_To (Pkg_RPC_Receiver_Decls,
Make_Object_Declaration (Loc,
Defining_Identifier =>
Is_Local,
Object_Definition =>
New_Occurrence_Of (Standard_Boolean, Loc)));
Append_To (Pkg_RPC_Receiver_Decls,
Make_Object_Declaration (Loc,
Defining_Identifier =>
Local_Address,
Object_Definition =>
New_Occurrence_Of (RTE (RE_Address), Loc)));
Append_To (Pkg_RPC_Receiver_Statements,
Make_Procedure_Call_Statement (Loc,
Name =>
New_Occurrence_Of (RTE (RE_Get_Local_Address), Loc),
Parameter_Associations => New_List (
Make_Selected_Component (Loc,
Prefix => Request,
Selector_Name => Name_Target),
New_Occurrence_Of (Is_Local, Loc),
New_Occurrence_Of (Local_Address, Loc))));
Append_To (Pkg_RPC_Receiver_Statements,
Make_Implicit_If_Statement (Pkg_Spec,
Condition =>
Make_Op_Ne (Loc,
Left_Opnd => New_Occurrence_Of (Local_Address, Loc),
Right_Opnd => New_Occurrence_Of (RTE (RE_Null_Address), Loc)),
Then_Statements => New_List (
Make_Implicit_If_Statement (Pkg_Spec,
Condition =>
New_Occurrence_Of (Standard_False, Loc),
Then_Statements => New_List (
Make_Null_Statement (Loc)),
Elsif_Parts =>
Dispatch_On_Address)),
Else_Statements => New_List (
Make_Implicit_If_Statement (Pkg_Spec,
Condition =>
New_Occurrence_Of (Standard_False, Loc),
Then_Statements => New_List (
Make_Null_Statement (Loc)),
Elsif_Parts =>
Dispatch_On_Name))));
All_Calls_Remote_E := Boolean_Literals (
Has_All_Calls_Remote (Defining_Entity (Pkg_Spec)));
Overload_Counter_Table.Reset;
Reserve_NamingContext_Methods;
Current_Declaration := First (Visible_Declarations (Pkg_Spec));
while Present (Current_Declaration) loop
if Nkind (Current_Declaration) = N_Subprogram_Declaration
and then Comes_From_Source (Current_Declaration)
then
declare
Loc : constant Source_Ptr :=
Sloc (Current_Declaration);
Subp_Def : constant Entity_Id :=
Defining_Unit_Name
(Specification (Current_Declaration));
Subp_Val : String_Id;
Subp_Dist_Name : constant Entity_Id :=
Make_Defining_Identifier (Loc,
New_External_Name (
Related_Id => Chars (Subp_Def),
Suffix => 'D',
Suffix_Index => -1));
Proxy_Object_Addr : Entity_Id;
begin
pragma Assert (Current_Subprogram_Number =
Get_Subprogram_Id (Subp_Def));
Current_Stubs :=
Build_Subprogram_Receiving_Stubs
(Vis_Decl => Current_Declaration,
Asynchronous =>
Nkind (Specification (Current_Declaration)) =
N_Procedure_Specification
and then Is_Asynchronous (Subp_Def));
Append_To (Decls, Current_Stubs);
Analyze (Current_Stubs);
Add_RAS_Proxy_And_Analyze (Decls,
Vis_Decl =>
Current_Declaration,
All_Calls_Remote_E =>
All_Calls_Remote_E,
Proxy_Object_Addr =>
Proxy_Object_Addr);
Assign_Subprogram_Identifier (
Subp_Def,
Current_Subprogram_Number,
Subp_Val);
Append_To (Decls,
Make_Object_Declaration (Loc,
Defining_Identifier => Subp_Dist_Name,
Constant_Present => True,
Object_Definition => New_Occurrence_Of (
Standard_String, Loc),
Expression =>
Make_String_Literal (Loc, Subp_Val)));
Analyze (Last (Decls));
Append_To (Subp_Info_List,
Make_Component_Association (Loc,
Choices => New_List (
Make_Integer_Literal (Loc,
Current_Subprogram_Number)),
Expression =>
Make_Aggregate (Loc,
Expressions => New_List (
Make_Attribute_Reference (Loc,
Prefix =>
New_Occurrence_Of (
Subp_Dist_Name, Loc),
Attribute_Name => Name_Address),
Make_Attribute_Reference (Loc,
Prefix =>
New_Occurrence_Of (
Subp_Dist_Name, Loc),
Attribute_Name => Name_Length),
New_Occurrence_Of (Proxy_Object_Addr, Loc)))));
Append_Stubs_To (Pkg_RPC_Receiver_Cases,
Declaration => Current_Declaration,
Stubs => Current_Stubs,
Subp_Number => Current_Subprogram_Number,
Subp_Dist_Name => Subp_Dist_Name,
Subp_Proxy_Addr => Proxy_Object_Addr);
end;
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_Index, Loc),
Alternatives => Pkg_RPC_Receiver_Cases));
Append_To (Decls,
Make_Object_Declaration (Loc,
Defining_Identifier => Subp_Info_Array,
Constant_Present => True,
Aliased_Present => True,
Object_Definition =>
Make_Subtype_Indication (Loc,
Subtype_Mark =>
New_Occurrence_Of (RTE (RE_RCI_Subp_Info_Array), Loc),
Constraint =>
Make_Index_Or_Discriminant_Constraint (Loc,
New_List (
Make_Range (Loc,
Low_Bound => Make_Integer_Literal (Loc,
First_RCI_Subprogram_Id),
High_Bound =>
Make_Integer_Literal (Loc,
First_RCI_Subprogram_Id
+ List_Length (Subp_Info_List) - 1))))),
Expression =>
Make_Aggregate (Loc,
Component_Associations => Subp_Info_List)));
Analyze (Last (Decls));
Append_To (Decls, Pkg_RPC_Receiver_Body);
Analyze (Last (Decls));
Pkg_RPC_Receiver_Object :=
Make_Object_Declaration (Loc,
Defining_Identifier =>
Make_Defining_Identifier (Loc, New_Internal_Name ('R')),
Aliased_Present => True,
Object_Definition =>
New_Occurrence_Of (RTE (RE_Servant), Loc));
Append_To (Decls, Pkg_RPC_Receiver_Object);
Analyze (Last (Decls));
Get_Library_Unit_Name_String (Pkg_Spec);
Append_To (Register_Pkg_Actuals,
Make_String_Literal (Loc,
Strval => String_From_Name_Buffer));
Append_To (Register_Pkg_Actuals,
Make_Attribute_Reference (Loc,
Prefix =>
New_Occurrence_Of
(Defining_Entity (Pkg_Spec), Loc),
Attribute_Name =>
Name_Version));
Append_To (Register_Pkg_Actuals,
Make_Attribute_Reference (Loc,
Prefix =>
New_Occurrence_Of (Pkg_RPC_Receiver, Loc),
Attribute_Name => Name_Access));
Append_To (Register_Pkg_Actuals,
Make_Attribute_Reference (Loc,
Prefix =>
New_Occurrence_Of (
Defining_Identifier (
Pkg_RPC_Receiver_Object), Loc),
Attribute_Name =>
Name_Access));
Append_To (Register_Pkg_Actuals,
Make_Attribute_Reference (Loc,
Prefix =>
New_Occurrence_Of (Subp_Info_Array, Loc),
Attribute_Name =>
Name_Address));
Append_To (Register_Pkg_Actuals,
Make_Attribute_Reference (Loc,
Prefix =>
New_Occurrence_Of (Subp_Info_Array, Loc),
Attribute_Name =>
Name_Length));
Append_To (Register_Pkg_Actuals,
New_Occurrence_Of (All_Calls_Remote_E, Loc));
Append_To (Decls,
Make_Procedure_Call_Statement (Loc,
Name =>
New_Occurrence_Of (RTE (RE_Register_Pkg_Receiving_Stub), Loc),
Parameter_Associations => Register_Pkg_Actuals));
Analyze (Last (Decls));
end Add_Receiving_Stubs_To_Declarations;
procedure Build_General_Calling_Stubs
(Decls : List_Id;
Statements : List_Id;
Target_Object : 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;
Stub_Type : Entity_Id := Empty;
RACW_Type : Entity_Id := Empty;
Nod : Node_Id)
is
Loc : constant Source_Ptr := Sloc (Nod);
Arguments : Node_Id;
Request : Node_Id;
Result : Node_Id;
Result_TC : Node_Id;
Exception_Return_Parameter : Node_Id;
Current_Parameter : Node_Id;
Ordered_Parameters_List : constant List_Id :=
Build_Ordered_Parameters_List (Spec);
Asynchronous_P : Node_Id;
Asynchronous_Statements : List_Id := No_List;
Non_Asynchronous_Statements : List_Id := No_List;
Extra_Formal_Statements : constant List_Id := New_List;
After_Statements : constant List_Id := New_List;
Etyp : Entity_Id;
Is_Controlling_Formal : Boolean;
Is_First_Controlling_Formal : Boolean;
First_Controlling_Formal_Seen : Boolean := False;
begin
Request :=
Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
Append_To (Decls,
Make_Object_Declaration (Loc,
Defining_Identifier => Request,
Aliased_Present => False,
Object_Definition =>
New_Occurrence_Of (RTE (RE_Request_Access), Loc)));
Result :=
Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
if Is_Function then
Result_TC := PolyORB_Support.Helpers.Build_TypeCode_Call (Loc,
Etype (Subtype_Mark (Spec)), Decls);
else
Result_TC := New_Occurrence_Of (RTE (RE_TC_Void), Loc);
end if;
Append_To (Decls,
Make_Object_Declaration (Loc,
Defining_Identifier => Result,
Aliased_Present => False,
Object_Definition =>
New_Occurrence_Of (RTE (RE_NamedValue), Loc),
Expression =>
Make_Aggregate (Loc,
Component_Associations => New_List (
Make_Component_Association (Loc,
Choices => New_List (
Make_Identifier (Loc, Name_Name)),
Expression =>
New_Occurrence_Of (RTE (RE_Result_Name), Loc)),
Make_Component_Association (Loc,
Choices => New_List (
Make_Identifier (Loc, Name_Argument)),
Expression =>
Make_Function_Call (Loc,
Name =>
New_Occurrence_Of (RTE (RE_Create_Any), Loc),
Parameter_Associations => New_List (
Result_TC))),
Make_Component_Association (Loc,
Choices => New_List (
Make_Identifier (Loc, Name_Arg_Modes)),
Expression =>
Make_Integer_Literal (Loc, 0))))));
if not Is_Known_Asynchronous then
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
Exception_Return_Parameter := Empty;
end if;
Arguments :=
Make_Defining_Identifier (Loc, New_Internal_Name ('A'));
Declare_Create_NVList (Loc, Arguments, Decls, Statements);
Current_Parameter := First (Ordered_Parameters_List);
while Present (Current_Parameter) loop
if Is_RACW_Controlling_Formal (Current_Parameter, Stub_Type) then
Is_Controlling_Formal := True;
Is_First_Controlling_Formal :=
not First_Controlling_Formal_Seen;
First_Controlling_Formal_Seen := True;
else
Is_Controlling_Formal := False;
Is_First_Controlling_Formal := False;
end if;
if Is_Controlling_Formal then
Etyp := RACW_Type;
else
Etyp := Etype (Parameter_Type (Current_Parameter));
end if;
if not Is_First_Controlling_Formal then
declare
Constrained : constant Boolean :=
Is_Constrained (Etyp)
or else Is_Elementary_Type (Etyp);
Any : constant Entity_Id :=
Make_Defining_Identifier (Loc,
New_Internal_Name ('A'));
Actual_Parameter : Node_Id :=
New_Occurrence_Of (
Defining_Identifier (
Current_Parameter), Loc);
Expr : Node_Id;
begin
if Is_Controlling_Formal then
if Nkind (Parameter_Type (Current_Parameter))
= N_Access_Definition
then
Actual_Parameter := OK_Convert_To
(Etyp, Actual_Parameter);
else
Actual_Parameter := OK_Convert_To (Etyp,
Make_Attribute_Reference (Loc,
Prefix =>
Actual_Parameter,
Attribute_Name =>
Name_Unrestricted_Access));
end if;
end if;
if In_Present (Current_Parameter)
or else not Out_Present (Current_Parameter)
or else not Constrained
or else Is_Controlling_Formal
then
Expr := PolyORB_Support.Helpers.Build_To_Any_Call (
Actual_Parameter, Decls);
else
Expr := Make_Function_Call (Loc,
Name =>
New_Occurrence_Of (RTE (RE_Create_Any), Loc),
Parameter_Associations => New_List (
PolyORB_Support.Helpers.Build_TypeCode_Call (Loc,
Etyp, Decls)));
end if;
Append_To (Decls,
Make_Object_Declaration (Loc,
Defining_Identifier =>
Any,
Aliased_Present => False,
Object_Definition =>
New_Occurrence_Of (RTE (RE_Any), Loc),
Expression =>
Expr));
Append_To (Statements,
Add_Parameter_To_NVList (Loc,
Parameter => Current_Parameter,
NVList => Arguments,
Constrained => Constrained,
Any => Any));
if Out_Present (Current_Parameter)
and then not Is_Controlling_Formal
then
Append_To (After_Statements,
Make_Assignment_Statement (Loc,
Name =>
New_Occurrence_Of (
Defining_Identifier (Current_Parameter), Loc),
Expression =>
PolyORB_Support.Helpers.Build_From_Any_Call (
Etype (Parameter_Type (Current_Parameter)),
New_Occurrence_Of (Any, Loc),
Decls)));
end if;
end;
end if;
if Nkind (Parameter_Type (Current_Parameter))
/= N_Access_Definition
and then Need_Extra_Constrained (Current_Parameter)
then
declare
Extra_Any_Parameter : constant Entity_Id :=
Make_Defining_Identifier
(Loc, New_Internal_Name ('P'));
begin
Append_To (Decls,
Make_Object_Declaration (Loc,
Defining_Identifier =>
Extra_Any_Parameter,
Aliased_Present => False,
Object_Definition =>
New_Occurrence_Of (RTE (RE_Any), Loc),
Expression =>
PolyORB_Support.Helpers.Build_To_Any_Call (
Make_Attribute_Reference (Loc,
Prefix =>
New_Occurrence_Of (
Defining_Identifier (Current_Parameter), Loc),
Attribute_Name => Name_Constrained),
Decls)));
Append_To (Extra_Formal_Statements,
Add_Parameter_To_NVList (Loc,
Parameter => Extra_Any_Parameter,
NVList => Arguments,
Constrained => True,
Any => Extra_Any_Parameter));
end;
end if;
Next (Current_Parameter);
end loop;
Append_List_To (Statements, Extra_Formal_Statements);
Append_To (Statements,
Make_Procedure_Call_Statement (Loc,
Name =>
New_Occurrence_Of (RTE (RE_Request_Create), Loc),
Parameter_Associations => New_List (
Target_Object,
Subprogram_Id,
New_Occurrence_Of (Arguments, Loc),
New_Occurrence_Of (Result, Loc),
New_Occurrence_Of (RTE (RE_Nil_Exc_List), Loc))));
Append_To (Parameter_Associations (Last (Statements)),
New_Occurrence_Of (Request, Loc));
pragma Assert (
not (Is_Known_Non_Asynchronous and Is_Known_Asynchronous));
if Is_Known_Non_Asynchronous or Is_Known_Asynchronous then
Asynchronous_P := New_Occurrence_Of (
Boolean_Literals (Is_Known_Asynchronous), Loc);
else
pragma Assert (Present (Asynchronous));
Asynchronous_P := New_Copy_Tree (Asynchronous);
end if;
Append_To (Parameter_Associations (Last (Statements)),
Make_Indexed_Component (Loc,
Prefix =>
New_Occurrence_Of (
RTE (RE_Asynchronous_P_To_Sync_Scope), Loc),
Expressions => New_List (Asynchronous_P)));
Append_To (Statements,
Make_Procedure_Call_Statement (Loc,
Name =>
New_Occurrence_Of (RTE (RE_Request_Invoke), Loc),
Parameter_Associations => New_List (
New_Occurrence_Of (Request, Loc))));
Non_Asynchronous_Statements := New_List (Make_Null_Statement (Loc));
Asynchronous_Statements := New_List (Make_Null_Statement (Loc));
if not Is_Known_Asynchronous then
Append_To (Non_Asynchronous_Statements,
Make_Procedure_Call_Statement (Loc,
Name =>
New_Occurrence_Of (RTE (RE_Request_Raise_Occurrence), Loc),
Parameter_Associations => New_List (
New_Occurrence_Of (Request, Loc))));
if Is_Function then
Append_To (Non_Asynchronous_Statements,
Make_Tag_Check (Loc,
Make_Return_Statement (Loc,
PolyORB_Support.Helpers.Build_From_Any_Call (
Etype (Subtype_Mark (Spec)),
Make_Selected_Component (Loc,
Prefix => Result,
Selector_Name => Name_Argument),
Decls))));
end if;
end if;
Append_List_To (Non_Asynchronous_Statements,
After_Statements);
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 (Present (Asynchronous));
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_Stub_Target
(Loc : Source_Ptr;
Decls : List_Id;
RCI_Locator : Entity_Id;
Controlling_Parameter : Entity_Id) return RPC_Target
is
Target_Info : RPC_Target (PCS_Kind => Name_PolyORB_DSA);
Target_Reference : constant Entity_Id :=
Make_Defining_Identifier (Loc,
New_Internal_Name ('T'));
begin
if Present (Controlling_Parameter) then
Append_To (Decls,
Make_Object_Declaration (Loc,
Defining_Identifier => Target_Reference,
Object_Definition =>
New_Occurrence_Of (RTE (RE_Object_Ref), Loc),
Expression =>
Make_Function_Call (Loc,
Name =>
New_Occurrence_Of (RTE (RE_Make_Ref), Loc),
Parameter_Associations => New_List (
Make_Selected_Component (Loc,
Prefix => Controlling_Parameter,
Selector_Name => Name_Target)))));
Target_Info.Object := New_Occurrence_Of (Target_Reference, Loc);
else
Target_Info.Object :=
Make_Selected_Component (Loc,
Prefix =>
Make_Identifier (Loc, Chars (RCI_Locator)),
Selector_Name =>
Make_Identifier (Loc, Name_Get_RCI_Package_Ref));
end if;
return Target_Info;
end Build_Stub_Target;
procedure Build_Stub_Type
(RACW_Type : Entity_Id;
Stub_Type : Entity_Id;
Stub_Type_Decl : out Node_Id;
RPC_Receiver_Decl : out Node_Id)
is
Loc : constant Source_Ptr := Sloc (Stub_Type);
pragma Warnings (Off);
pragma Unreferenced (RACW_Type);
pragma Warnings (On);
begin
Stub_Type_Decl :=
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_Target),
Component_Definition =>
Make_Component_Definition (Loc,
Aliased_Present =>
False,
Subtype_Indication =>
New_Occurrence_Of (RTE (RE_Entity_Ptr), Loc))),
Make_Component_Declaration (Loc,
Defining_Identifier =>
Make_Defining_Identifier (Loc, Name_Asynchronous),
Component_Definition =>
Make_Component_Definition (Loc,
Aliased_Present => False,
Subtype_Indication =>
New_Occurrence_Of (
Standard_Boolean, Loc)))))));
RPC_Receiver_Decl :=
Make_Object_Declaration (Loc,
Defining_Identifier => Make_Defining_Identifier (Loc,
New_Internal_Name ('R')),
Aliased_Present => True,
Object_Definition =>
New_Occurrence_Of (RTE (RE_Servant), Loc));
end Build_Stub_Type;
procedure Build_RPC_Receiver_Body
(RPC_Receiver : Entity_Id;
Request : out Entity_Id;
Subp_Id : out Entity_Id;
Subp_Index : out Entity_Id;
Stmts : out List_Id;
Decl : out Node_Id)
is
Loc : constant Source_Ptr := Sloc (RPC_Receiver);
RPC_Receiver_Spec : Node_Id;
RPC_Receiver_Decls : List_Id;
begin
Request := Make_Defining_Identifier (Loc, Name_R);
RPC_Receiver_Spec :=
Build_RPC_Receiver_Specification (
RPC_Receiver => RPC_Receiver,
Request_Parameter => Request);
Subp_Id := Make_Defining_Identifier (Loc, Name_P);
Subp_Index := Make_Defining_Identifier (Loc, Name_I);
RPC_Receiver_Decls := New_List (
Make_Object_Renaming_Declaration (Loc,
Defining_Identifier => Subp_Id,
Subtype_Mark => New_Occurrence_Of (Standard_String, Loc),
Name =>
Make_Explicit_Dereference (Loc,
Prefix =>
Make_Selected_Component (Loc,
Prefix => Request,
Selector_Name => Name_Operation))),
Make_Object_Declaration (Loc,
Defining_Identifier => Subp_Index,
Object_Definition =>
New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc),
Expression =>
Make_Attribute_Reference (Loc,
Prefix =>
New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc),
Attribute_Name => Name_Last)));
Stmts := New_List;
Decl :=
Make_Subprogram_Body (Loc,
Specification => RPC_Receiver_Spec,
Declarations => RPC_Receiver_Decls,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => Stmts));
end Build_RPC_Receiver_Body;
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);
Request_Parameter : Node_Id;
Outer_Decls : constant List_Id := New_List;
Outer_Statements : constant List_Id := New_List;
Decls : constant List_Id := New_List;
Statements : constant List_Id := New_List;
Extra_Formal_Statements : constant List_Id := New_List;
After_Statements : constant List_Id := New_List;
Inner_Decls : List_Id := No_List;
Excep_Handlers : List_Id := No_List;
Parameter_List : constant List_Id := New_List;
First_Controlling_Formal_Seen : Boolean := False;
Current_Parameter : Node_Id;
Ordered_Parameters_List : constant List_Id :=
Build_Ordered_Parameters_List
(Specification (Vis_Decl));
Arguments : Node_Id;
Subp_Spec : Node_Id;
Called_Subprogram : Node_Id;
begin
if Present (RACW_Type) then
Called_Subprogram :=
New_Occurrence_Of (Parent_Primitive, Loc);
else
Called_Subprogram :=
New_Occurrence_Of (
Defining_Unit_Name (Specification (Vis_Decl)), Loc);
end if;
Request_Parameter :=
Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
Arguments :=
Make_Defining_Identifier (Loc, New_Internal_Name ('A'));
Declare_Create_NVList (Loc, Arguments, Outer_Decls, Outer_Statements);
Current_Parameter := First (Ordered_Parameters_List);
while Present (Current_Parameter) loop
declare
Etyp : Entity_Id;
Constrained : Boolean;
Any : Entity_Id := Empty;
Object : constant Entity_Id :=
Make_Defining_Identifier (Loc,
New_Internal_Name ('P'));
Expr : Node_Id := Empty;
Is_Controlling_Formal : constant Boolean
:= Is_RACW_Controlling_Formal (Current_Parameter, Stub_Type);
Is_First_Controlling_Formal : Boolean := False;
begin
Set_Ekind (Object, E_Variable);
if Is_Controlling_Formal then
Etyp := RACW_Type;
Is_First_Controlling_Formal :=
not First_Controlling_Formal_Seen;
First_Controlling_Formal_Seen := True;
else
Etyp := Etype (Parameter_Type (Current_Parameter));
end if;
Constrained :=
Is_Constrained (Etyp)
or else Is_Elementary_Type (Etyp);
if not Is_First_Controlling_Formal then
Any := Make_Defining_Identifier (Loc,
New_Internal_Name ('A'));
Append_To (Outer_Decls,
Make_Object_Declaration (Loc,
Defining_Identifier =>
Any,
Object_Definition =>
New_Occurrence_Of (RTE (RE_Any), Loc),
Expression =>
Make_Function_Call (Loc,
Name =>
New_Occurrence_Of (RTE (RE_Create_Any), Loc),
Parameter_Associations => New_List (
PolyORB_Support.Helpers.Build_TypeCode_Call (Loc,
Etyp, Outer_Decls)))));
Append_To (Outer_Statements,
Add_Parameter_To_NVList (Loc,
Parameter => Current_Parameter,
NVList => Arguments,
Constrained => Constrained,
Any => Any));
end if;
if Is_First_Controlling_Formal then
declare
Addr : constant Entity_Id :=
Make_Defining_Identifier (Loc,
New_Internal_Name ('A'));
Is_Local : constant Entity_Id :=
Make_Defining_Identifier (Loc,
New_Internal_Name ('L'));
begin
Append_To (Outer_Decls,
Make_Object_Declaration (Loc,
Defining_Identifier =>
Addr,
Object_Definition =>
New_Occurrence_Of (RTE (RE_Address), Loc)));
Append_To (Outer_Decls,
Make_Object_Declaration (Loc,
Defining_Identifier =>
Is_Local,
Object_Definition =>
New_Occurrence_Of (Standard_Boolean, Loc)));
Append_To (Outer_Statements,
Make_Procedure_Call_Statement (Loc,
Name =>
New_Occurrence_Of (
RTE (RE_Get_Local_Address), Loc),
Parameter_Associations => New_List (
Make_Selected_Component (Loc,
Prefix =>
New_Occurrence_Of (
Request_Parameter, Loc),
Selector_Name =>
Make_Identifier (Loc, Name_Target)),
New_Occurrence_Of (Is_Local, Loc),
New_Occurrence_Of (Addr, Loc))));
Expr := Unchecked_Convert_To (RACW_Type,
New_Occurrence_Of (Addr, Loc));
end;
elsif In_Present (Current_Parameter)
or else not Out_Present (Current_Parameter)
or else not Constrained
then
Expr := PolyORB_Support.Helpers.Build_From_Any_Call (
Etyp, New_Occurrence_Of (Any, Loc), Decls);
if Constrained then
Append_To (Statements,
Make_Assignment_Statement (Loc,
Name =>
New_Occurrence_Of (Object, Loc),
Expression =>
Expr));
Expr := Empty;
else
null;
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));
Set_Etype (Object, Etyp);
if Out_Present (Current_Parameter)
and then not Is_Controlling_Formal
then
Append_To (After_Statements,
Make_Procedure_Call_Statement (Loc,
Name =>
New_Occurrence_Of (RTE (RE_Copy_Any_Value), Loc),
Parameter_Associations => New_List (
New_Occurrence_Of (Any, Loc),
PolyORB_Support.Helpers.Build_To_Any_Call (
New_Occurrence_Of (Object, Loc),
Decls))));
end if;
if Is_Controlling_Formal 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));
Extra_Any : constant Entity_Id :=
Make_Defining_Identifier
(Loc, New_Internal_Name ('A'));
Formal_Entity : constant Entity_Id :=
Make_Defining_Identifier
(Loc, Chars (Extra_Parameter));
Formal_Type : constant Entity_Id :=
Etype (Extra_Parameter);
begin
Append_To (Outer_Decls,
Make_Object_Declaration (Loc,
Defining_Identifier =>
Extra_Any,
Object_Definition =>
New_Occurrence_Of (RTE (RE_Any), Loc)));
Append_To (Outer_Statements,
Add_Parameter_To_NVList (Loc,
Parameter => Extra_Parameter,
NVList => Arguments,
Constrained => True,
Any => Extra_Any));
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_Assignment_Statement (Loc,
Name =>
New_Occurrence_Of (Extra_Parameter, Loc),
Expression =>
PolyORB_Support.Helpers.Build_From_Any_Call (
Etype (Extra_Parameter),
New_Occurrence_Of (Extra_Any, Loc),
Decls)));
Set_Extra_Constrained (Object, Formal_Entity);
end;
end if;
end;
Next (Current_Parameter);
end loop;
Append_To (Outer_Statements,
Make_Procedure_Call_Statement (Loc,
Name =>
New_Occurrence_Of (RTE (RE_Request_Arguments), Loc),
Parameter_Associations => New_List (
New_Occurrence_Of (Request_Parameter, Loc),
New_Occurrence_Of (Arguments, Loc))));
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)));
Set_Etype (Result, Etyp);
Append_To (After_Statements,
Make_Procedure_Call_Statement (Loc,
Name =>
New_Occurrence_Of (RTE (RE_Set_Result), Loc),
Parameter_Associations => New_List (
New_Occurrence_Of (Request_Parameter, Loc),
PolyORB_Support.Helpers.Build_To_Any_Call (
New_Occurrence_Of (Result, Loc),
Decls))));
end;
Append_To (Statements,
Make_Block_Statement (Loc,
Declarations => Inner_Decls,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => After_Statements)));
else
Append_To (After_Statements,
Make_Procedure_Call_Statement (Loc,
Name =>
New_Occurrence_Of (RTE (RE_Request_Set_Out), Loc),
Parameter_Associations => New_List (
New_Occurrence_Of (Request_Parameter, Loc))));
Append_To (Statements,
Make_Procedure_Call_Statement (Loc,
Name => Called_Subprogram,
Parameter_Associations => Parameter_List));
Append_List_To (Statements, After_Statements);
end if;
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 => Request_Parameter,
Parameter_Type =>
New_Occurrence_Of (RTE (RE_Request_Access), Loc))));
if Asynchronous and then not Dynamically_Asynchronous then
Excep_Handlers := New_List (
Make_Exception_Handler (Loc,
Exception_Choices => New_List (Make_Others_Choice (Loc)),
Statements => New_List (Make_Null_Statement (Loc))));
else
null;
end if;
Append_To (Outer_Statements,
Make_Block_Statement (Loc,
Declarations =>
Decls,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => Statements)));
return
Make_Subprogram_Body (Loc,
Specification => Subp_Spec,
Declarations => Outer_Decls,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => Outer_Statements,
Exception_Handlers => Excep_Handlers));
end Build_Subprogram_Receiving_Stubs;
package body Helpers is
function Find_Inherited_TSS
(Typ : Entity_Id;
Nam : Name_Id) return Entity_Id;
function Find_Numeric_Representation
(Typ : Entity_Id) return Entity_Id;
function Make_Stream_Procedure_Function_Name
(Loc : Source_Ptr;
Typ : Entity_Id;
Nam : Name_Id) return Entity_Id;
function Build_Get_Aggregate_Element
(Loc : Source_Ptr;
Any : Entity_Id;
TC : Node_Id;
Idx : Node_Id) return Node_Id;
generic
Subprogram : Entity_Id;
Arry : Entity_Id;
Indices : List_Id;
with procedure Add_Process_Element
(Stmts : List_Id;
Any : Entity_Id;
Counter : Entity_Id;
Datum : Node_Id);
procedure Append_Array_Traversal
(Stmts : List_Id;
Any : Entity_Id;
Counter : Entity_Id := Empty;
Depth : Pos := 1);
generic
Rec : Entity_Id;
with procedure Add_Process_Element
(Stmts : List_Id;
Container : Node_Or_Entity_Id;
Counter : in out Int;
Rec : Entity_Id;
Field : Node_Id);
procedure Append_Record_Traversal
(Stmts : List_Id;
Clist : Node_Id;
Container : Node_Or_Entity_Id;
Counter : in out Int);
procedure Append_Record_Traversal
(Stmts : List_Id;
Clist : Node_Id;
Container : Node_Or_Entity_Id;
Counter : in out Int)
is
CI : constant List_Id := Component_Items (Clist);
VP : constant Node_Id := Variant_Part (Clist);
Item : Node_Id := First (CI);
Def : Entity_Id;
begin
while Present (Item) loop
Def := Defining_Identifier (Item);
if not Is_Internal_Name (Chars (Def)) then
Add_Process_Element
(Stmts, Container, Counter, Rec, Def);
end if;
Next (Item);
end loop;
if Present (VP) then
Add_Process_Element (Stmts, Container, Counter, Rec, VP);
end if;
end Append_Record_Traversal;
function Build_From_Any_Call
(Typ : Entity_Id;
N : Node_Id;
Decls : List_Id) return Node_Id
is
Loc : constant Source_Ptr := Sloc (N);
U_Type : Entity_Id := Underlying_Type (Typ);
Fnam : Entity_Id := Empty;
Lib_RE : RE_Id := RE_Null;
begin
Fnam := Find_Inherited_TSS (U_Type, Name_uFrom_Any);
if Sloc (U_Type) <= Standard_Location then
U_Type := Base_Type (U_Type);
end if;
if Present (Fnam) then
null;
elsif U_Type = Standard_Boolean then
Lib_RE := RE_FA_B;
elsif U_Type = Standard_Character then
Lib_RE := RE_FA_C;
elsif U_Type = Standard_Wide_Character then
Lib_RE := RE_FA_WC;
elsif U_Type = Standard_Wide_Wide_Character then
Lib_RE := RE_FA_WWC;
elsif U_Type = Standard_Short_Float then
Lib_RE := RE_FA_SF;
elsif U_Type = Standard_Float then
Lib_RE := RE_FA_F;
elsif U_Type = Standard_Long_Float then
Lib_RE := RE_FA_LF;
elsif U_Type = Standard_Long_Long_Float then
Lib_RE := RE_FA_LLF;
elsif U_Type = Etype (Standard_Short_Short_Integer) then
Lib_RE := RE_FA_SSI;
elsif U_Type = Etype (Standard_Short_Integer) then
Lib_RE := RE_FA_SI;
elsif U_Type = Etype (Standard_Integer) then
Lib_RE := RE_FA_I;
elsif U_Type = Etype (Standard_Long_Integer) then
Lib_RE := RE_FA_LI;
elsif U_Type = Etype (Standard_Long_Long_Integer) then
Lib_RE := RE_FA_LLI;
elsif U_Type = RTE (RE_Short_Short_Unsigned) then
Lib_RE := RE_FA_SSU;
elsif U_Type = RTE (RE_Short_Unsigned) then
Lib_RE := RE_FA_SU;
elsif U_Type = RTE (RE_Unsigned) then
Lib_RE := RE_FA_U;
elsif U_Type = RTE (RE_Long_Unsigned) then
Lib_RE := RE_FA_LU;
elsif U_Type = RTE (RE_Long_Long_Unsigned) then
Lib_RE := RE_FA_LLU;
elsif U_Type = Standard_String then
Lib_RE := RE_FA_String;
else
declare
Decl : Entity_Id;
begin
Build_From_Any_Function (Loc, U_Type, Decl, Fnam);
Append_To (Decls, Decl);
end;
end if;
if Lib_RE /= RE_Null then
pragma Assert (No (Fnam));
Fnam := RTE (Lib_RE);
end if;
return
Make_Function_Call (Loc,
Name => New_Occurrence_Of (Fnam, Loc),
Parameter_Associations => New_List (N));
end Build_From_Any_Call;
procedure Build_From_Any_Function
(Loc : Source_Ptr;
Typ : Entity_Id;
Decl : out Node_Id;
Fnam : out Entity_Id)
is
Spec : Node_Id;
Decls : constant List_Id := New_List;
Stms : constant List_Id := New_List;
Any_Parameter : constant Entity_Id
:= Make_Defining_Identifier (Loc, New_Internal_Name ('A'));
begin
Fnam := Make_Stream_Procedure_Function_Name (Loc,
Typ, Name_uFrom_Any);
Spec :=
Make_Function_Specification (Loc,
Defining_Unit_Name => Fnam,
Parameter_Specifications => New_List (
Make_Parameter_Specification (Loc,
Defining_Identifier =>
Any_Parameter,
Parameter_Type =>
New_Occurrence_Of (RTE (RE_Any), Loc))),
Subtype_Mark => New_Occurrence_Of (Typ, Loc));
pragma Assert
(not (Is_Remote_Access_To_Class_Wide_Type (Typ)));
if Is_Derived_Type (Typ)
and then not Is_Tagged_Type (Typ)
then
Append_To (Stms,
Make_Return_Statement (Loc,
Expression =>
OK_Convert_To (
Typ,
Build_From_Any_Call (
Root_Type (Typ),
New_Occurrence_Of (Any_Parameter, Loc),
Decls))));
elsif Is_Record_Type (Typ)
and then not Is_Derived_Type (Typ)
and then not Is_Tagged_Type (Typ)
then
if Nkind (Declaration_Node (Typ)) = N_Subtype_Declaration then
Append_To (Stms,
Make_Return_Statement (Loc,
Expression =>
OK_Convert_To (
Typ,
Build_From_Any_Call (
Etype (Typ),
New_Occurrence_Of (Any_Parameter, Loc),
Decls))));
else
declare
Disc : Entity_Id := Empty;
Discriminant_Associations : List_Id;
Rdef : constant Node_Id :=
Type_Definition (Declaration_Node (Typ));
Component_Counter : Int := 0;
Res : constant Entity_Id :=
Make_Defining_Identifier (Loc,
New_Internal_Name ('R'));
Res_Definition : Node_Id := New_Occurrence_Of (Typ, Loc);
procedure FA_Rec_Add_Process_Element
(Stmts : List_Id;
Any : Entity_Id;
Counter : in out Int;
Rec : Entity_Id;
Field : Node_Id);
procedure FA_Append_Record_Traversal is
new Append_Record_Traversal
(Rec => Res,
Add_Process_Element => FA_Rec_Add_Process_Element);
procedure FA_Rec_Add_Process_Element
(Stmts : List_Id;
Any : Entity_Id;
Counter : in out Int;
Rec : Entity_Id;
Field : Node_Id)
is
begin
if Nkind (Field) = N_Defining_Identifier then
Append_To (Stmts,
Make_Assignment_Statement (Loc,
Name => Make_Selected_Component (Loc,
Prefix =>
New_Occurrence_Of (Rec, Loc),
Selector_Name =>
New_Occurrence_Of (Field, Loc)),
Expression =>
Build_From_Any_Call (Etype (Field),
Build_Get_Aggregate_Element (Loc,
Any => Any,
Tc => Build_TypeCode_Call (Loc,
Etype (Field), Decls),
Idx => Make_Integer_Literal (Loc,
Counter)),
Decls)));
else
declare
Variant : Node_Id;
Struct_Counter : Int := 0;
Block_Decls : constant List_Id := New_List;
Block_Stmts : constant List_Id := New_List;
VP_Stmts : List_Id;
Alt_List : constant List_Id := New_List;
Choice_List : List_Id;
Struct_Any : constant Entity_Id :=
Make_Defining_Identifier (Loc,
New_Internal_Name ('S'));
begin
Append_To (Decls,
Make_Object_Declaration (Loc,
Defining_Identifier =>
Struct_Any,
Constant_Present =>
True,
Object_Definition =>
New_Occurrence_Of (RTE (RE_Any), Loc),
Expression =>
Make_Function_Call (Loc,
Name => New_Occurrence_Of (
RTE (RE_Extract_Union_Value), Loc),
Parameter_Associations => New_List (
Build_Get_Aggregate_Element (Loc,
Any => Any,
Tc => Make_Function_Call (Loc,
Name => New_Occurrence_Of (
RTE (RE_Any_Member_Type), Loc),
Parameter_Associations =>
New_List (
New_Occurrence_Of (Any, Loc),
Make_Integer_Literal (Loc,
Counter))),
Idx => Make_Integer_Literal (Loc,
Counter))))));
Append_To (Stmts,
Make_Block_Statement (Loc,
Declarations =>
Block_Decls,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => Block_Stmts)));
Append_To (Block_Stmts,
Make_Case_Statement (Loc,
Expression =>
Make_Selected_Component (Loc,
Prefix => Rec,
Selector_Name =>
Chars (Name (Field))),
Alternatives =>
Alt_List));
Variant := First_Non_Pragma (Variants (Field));
while Present (Variant) loop
Choice_List := New_Copy_List_Tree
(Discrete_Choices (Variant));
VP_Stmts := New_List;
FA_Append_Record_Traversal (
Stmts => VP_Stmts,
Clist => Component_List (Variant),
Container => Struct_Any,
Counter => Struct_Counter);
Append_To (Alt_List,
Make_Case_Statement_Alternative (Loc,
Discrete_Choices => Choice_List,
Statements =>
VP_Stmts));
Next_Non_Pragma (Variant);
end loop;
end;
end if;
Counter := Counter + 1;
end FA_Rec_Add_Process_Element;
begin
if Has_Discriminants (Typ) then
Disc := First_Discriminant (Typ);
Discriminant_Associations := New_List;
while Present (Disc) loop
declare
Disc_Var_Name : constant Entity_Id :=
Make_Defining_Identifier (Loc, Chars (Disc));
Disc_Type : constant Entity_Id :=
Etype (Disc);
begin
Append_To (Decls,
Make_Object_Declaration (Loc,
Defining_Identifier =>
Disc_Var_Name,
Constant_Present => True,
Object_Definition =>
New_Occurrence_Of (Disc_Type, Loc),
Expression =>
Build_From_Any_Call (Etype (Disc),
Build_Get_Aggregate_Element (Loc,
Any => Any_Parameter,
Tc => Build_TypeCode_Call
(Loc, Etype (Disc), Decls),
Idx => Make_Integer_Literal
(Loc, Component_Counter)),
Decls)));
Component_Counter := Component_Counter + 1;
Append_To (Discriminant_Associations,
Make_Discriminant_Association (Loc,
Selector_Names => New_List (
New_Occurrence_Of (Disc, Loc)),
Expression =>
New_Occurrence_Of (Disc_Var_Name, Loc)));
end;
Next_Discriminant (Disc);
end loop;
Res_Definition := Make_Subtype_Indication (Loc,
Subtype_Mark => Res_Definition,
Constraint =>
Make_Index_Or_Discriminant_Constraint (Loc,
Discriminant_Associations));
end if;
Append_To (Decls,
Make_Object_Declaration (Loc,
Defining_Identifier =>
Res,
Object_Definition =>
Res_Definition));
FA_Append_Record_Traversal (Stms,
Clist => Component_List (Rdef),
Container => Any_Parameter,
Counter => Component_Counter);
Append_To (Stms,
Make_Return_Statement (Loc,
Expression => New_Occurrence_Of (Res, Loc)));
end;
end if;
elsif Is_Array_Type (Typ) then
declare
Constrained : constant Boolean := Is_Constrained (Typ);
procedure FA_Ary_Add_Process_Element
(Stmts : List_Id;
Any : Entity_Id;
Counter : Entity_Id;
Datum : Node_Id);
procedure FA_Ary_Add_Process_Element
(Stmts : List_Id;
Any : Entity_Id;
Counter : Entity_Id;
Datum : Node_Id)
is
Assignment : constant Node_Id :=
Make_Assignment_Statement (Loc,
Name => Datum,
Expression => Empty);
Element_Any : constant Node_Id :=
Build_Get_Aggregate_Element (Loc,
Any => Any,
Tc => Build_TypeCode_Call (Loc,
Etype (Datum), Decls),
Idx => New_Occurrence_Of (Counter, Loc));
begin
Prepend_To (Stmts,
Make_Assignment_Statement (Loc,
Name =>
New_Occurrence_Of (Counter, Loc),
Expression =>
Make_Op_Add (Loc,
Left_Opnd =>
New_Occurrence_Of (Counter, Loc),
Right_Opnd =>
Make_Integer_Literal (Loc, 1))));
if Nkind (Datum) /= N_Attribute_Reference then
if Etype (Datum) /= RTE (RE_Any) then
Set_Expression (Assignment,
Build_From_Any_Call (
Component_Type (Typ),
Element_Any,
Decls));
else
Set_Expression (Assignment, Element_Any);
end if;
Prepend_To (Stmts, Assignment);
end if;
end FA_Ary_Add_Process_Element;
Counter : constant Entity_Id :=
Make_Defining_Identifier (Loc, Name_J);
Initial_Counter_Value : Int := 0;
Component_TC : constant Entity_Id :=
Make_Defining_Identifier (Loc, Name_T);
Res : constant Entity_Id :=
Make_Defining_Identifier (Loc, Name_R);
procedure Append_From_Any_Array_Iterator is
new Append_Array_Traversal (
Subprogram => Fnam,
Arry => Res,
Indices => New_List,
Add_Process_Element => FA_Ary_Add_Process_Element);
Res_Subtype_Indication : Node_Id :=
New_Occurrence_Of (Typ, Loc);
begin
if not Constrained then
declare
Ndim : constant Int := Number_Dimensions (Typ);
Lnam : Name_Id;
Hnam : Name_Id;
Indx : Node_Id := First_Index (Typ);
Indt : Entity_Id;
Ranges : constant List_Id := New_List;
begin
for J in 1 .. Ndim loop
Lnam := New_External_Name ('L', J);
Hnam := New_External_Name ('H', J);
Indt := Etype (Indx);
Append_To (Decls,
Make_Object_Declaration (Loc,
Defining_Identifier =>
Make_Defining_Identifier (Loc, Lnam),
Constant_Present =>
True,
Object_Definition =>
New_Occurrence_Of (Indt, Loc),
Expression =>
Build_From_Any_Call (
Indt,
Build_Get_Aggregate_Element (Loc,
Any => Any_Parameter,
Tc => Build_TypeCode_Call (Loc,
Indt, Decls),
Idx => Make_Integer_Literal (Loc, J - 1)),
Decls)));
Append_To (Decls,
Make_Object_Declaration (Loc,
Defining_Identifier =>
Make_Defining_Identifier (Loc, Hnam),
Constant_Present =>
True,
Object_Definition =>
New_Occurrence_Of (Indt, Loc),
Expression => Make_Attribute_Reference (Loc,
Prefix =>
New_Occurrence_Of (Indt, Loc),
Attribute_Name => Name_Val,
Expressions => New_List (
Make_Op_Subtract (Loc,
Left_Opnd =>
Make_Op_Add (Loc,
Left_Opnd =>
Make_Attribute_Reference (Loc,
Prefix =>
New_Occurrence_Of (Indt, Loc),
Attribute_Name =>
Name_Pos,
Expressions => New_List (
Make_Identifier (Loc, Lnam))),
Right_Opnd =>
Make_Function_Call (Loc,
Name => New_Occurrence_Of (RTE (
RE_Get_Nested_Sequence_Length),
Loc),
Parameter_Associations =>
New_List (
New_Occurrence_Of (
Any_Parameter, Loc),
Make_Integer_Literal (Loc,
J)))),
Right_Opnd =>
Make_Integer_Literal (Loc, 1))))));
Append_To (Ranges,
Make_Range (Loc,
Low_Bound => Make_Identifier (Loc, Lnam),
High_Bound => Make_Identifier (Loc, Hnam)));
Next_Index (Indx);
end loop;
Initial_Counter_Value := Ndim;
Res_Subtype_Indication := Make_Subtype_Indication (Loc,
Subtype_Mark =>
Res_Subtype_Indication,
Constraint =>
Make_Index_Or_Discriminant_Constraint (Loc,
Constraints => Ranges));
end;
end if;
Append_To (Decls,
Make_Object_Declaration (Loc,
Defining_Identifier => Res,
Object_Definition => Res_Subtype_Indication));
Set_Etype (Res, Typ);
Append_To (Decls,
Make_Object_Declaration (Loc,
Defining_Identifier => Counter,
Object_Definition =>
New_Occurrence_Of (RTE (RE_Long_Unsigned), Loc),
Expression =>
Make_Integer_Literal (Loc, Initial_Counter_Value)));
Append_To (Decls,
Make_Object_Declaration (Loc,
Defining_Identifier => Component_TC,
Constant_Present => True,
Object_Definition =>
New_Occurrence_Of (RTE (RE_TypeCode), Loc),
Expression =>
Build_TypeCode_Call (Loc,
Component_Type (Typ), Decls)));
Append_From_Any_Array_Iterator (Stms,
Any_Parameter, Counter);
Append_To (Stms,
Make_Return_Statement (Loc,
Expression => New_Occurrence_Of (Res, Loc)));
end;
elsif Is_Integer_Type (Typ) or else Is_Unsigned_Type (Typ) then
Append_To (Stms,
Make_Return_Statement (Loc,
Expression =>
Unchecked_Convert_To (
Typ,
Build_From_Any_Call (
Find_Numeric_Representation (Typ),
New_Occurrence_Of (Any_Parameter, Loc),
Decls))));
else
declare
Strm : constant Entity_Id :=
Make_Defining_Identifier (Loc,
Chars => New_Internal_Name ('S'));
Res : constant Entity_Id :=
Make_Defining_Identifier (Loc,
Chars => New_Internal_Name ('R'));
begin
Append_To (Decls,
Make_Object_Declaration (Loc,
Defining_Identifier =>
Strm,
Aliased_Present =>
True,
Object_Definition =>
New_Occurrence_Of (RTE (RE_Buffer_Stream_Type), Loc)));
Append_To (Stms,
Make_Procedure_Call_Statement (Loc,
Name =>
New_Occurrence_Of (RTE (RE_Any_To_BS), Loc),
Parameter_Associations => New_List (
New_Occurrence_Of (Any_Parameter, Loc),
New_Occurrence_Of (Strm, Loc))));
Append_To (Stms, Make_Block_Statement (Loc,
Declarations => New_List (
Make_Object_Declaration (Loc,
Defining_Identifier => Res,
Constant_Present => True,
Object_Definition =>
New_Occurrence_Of (Typ, Loc),
Expression =>
Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (Typ, Loc),
Attribute_Name => Name_Input,
Expressions => New_List (
Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (Strm, Loc),
Attribute_Name => Name_Access))))),
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => New_List (
Make_Procedure_Call_Statement (Loc,
Name =>
New_Occurrence_Of (RTE (RE_Release_Buffer), Loc),
Parameter_Associations =>
New_List (
New_Occurrence_Of (Strm, Loc))),
Make_Return_Statement (Loc,
Expression => New_Occurrence_Of (Res, Loc))))));
end;
end if;
Decl :=
Make_Subprogram_Body (Loc,
Specification => Spec,
Declarations => Decls,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => Stms));
end Build_From_Any_Function;
function Build_Get_Aggregate_Element
(Loc : Source_Ptr;
Any : Entity_Id;
TC : Node_Id;
Idx : Node_Id) return Node_Id
is
begin
return Make_Function_Call (Loc,
Name =>
New_Occurrence_Of (
RTE (RE_Get_Aggregate_Element), Loc),
Parameter_Associations => New_List (
New_Occurrence_Of (Any, Loc),
TC,
Idx));
end Build_Get_Aggregate_Element;
procedure Build_Name_And_Repository_Id
(E : Entity_Id;
Name_Str : out String_Id;
Repo_Id_Str : out String_Id)
is
begin
Start_String;
Store_String_Chars ("DSA:");
Get_Library_Unit_Name_String (Scope (E));
Store_String_Chars (
Name_Buffer (Name_Buffer'First
.. Name_Buffer'First + Name_Len - 1));
Store_String_Char ('.');
Get_Name_String (Chars (E));
Store_String_Chars (
Name_Buffer (Name_Buffer'First
.. Name_Buffer'First + Name_Len - 1));
Store_String_Chars (":1.0");
Repo_Id_Str := End_String;
Name_Str := String_From_Name_Buffer;
end Build_Name_And_Repository_Id;
function Build_To_Any_Call
(N : Node_Id;
Decls : List_Id) return Node_Id
is
Loc : constant Source_Ptr := Sloc (N);
Typ : Entity_Id := Etype (N);
U_Type : Entity_Id;
Fnam : Entity_Id := Empty;
Lib_RE : RE_Id := RE_Null;
begin
if No (Typ) and then Nkind (N) = N_Selected_Component then
Typ := Etype (Selector_Name (N));
end if;
pragma Assert (Present (Typ));
U_Type := Underlying_Type (Typ);
Fnam := Find_Inherited_TSS (U_Type, Name_uTo_Any);
if Sloc (U_Type) <= Standard_Location then
U_Type := Base_Type (U_Type);
end if;
if Present (Fnam) then
null;
elsif U_Type = Standard_Boolean then
Lib_RE := RE_TA_B;
elsif U_Type = Standard_Character then
Lib_RE := RE_TA_C;
elsif U_Type = Standard_Wide_Character then
Lib_RE := RE_TA_WC;
elsif U_Type = Standard_Wide_Wide_Character then
Lib_RE := RE_TA_WWC;
elsif U_Type = Standard_Short_Float then
Lib_RE := RE_TA_SF;
elsif U_Type = Standard_Float then
Lib_RE := RE_TA_F;
elsif U_Type = Standard_Long_Float then
Lib_RE := RE_TA_LF;
elsif U_Type = Standard_Long_Long_Float then
Lib_RE := RE_TA_LLF;
elsif U_Type = Etype (Standard_Short_Short_Integer) then
Lib_RE := RE_TA_SSI;
elsif U_Type = Etype (Standard_Short_Integer) then
Lib_RE := RE_TA_SI;
elsif U_Type = Etype (Standard_Integer) then
Lib_RE := RE_TA_I;
elsif U_Type = Etype (Standard_Long_Integer) then
Lib_RE := RE_TA_LI;
elsif U_Type = Etype (Standard_Long_Long_Integer) then
Lib_RE := RE_TA_LLI;
elsif U_Type = RTE (RE_Short_Short_Unsigned) then
Lib_RE := RE_TA_SSU;
elsif U_Type = RTE (RE_Short_Unsigned) then
Lib_RE := RE_TA_SU;
elsif U_Type = RTE (RE_Unsigned) then
Lib_RE := RE_TA_U;
elsif U_Type = RTE (RE_Long_Unsigned) then
Lib_RE := RE_TA_LU;
elsif U_Type = RTE (RE_Long_Long_Unsigned) then
Lib_RE := RE_TA_LLU;
elsif U_Type = Standard_String then
Lib_RE := RE_TA_String;
elsif U_Type = Underlying_Type (RTE (RE_TypeCode)) then
Lib_RE := RE_TA_TC;
else
declare
Decl : Entity_Id;
begin
Build_To_Any_Function (Loc, U_Type, Decl, Fnam);
Append_To (Decls, Decl);
end;
end if;
if Lib_RE /= RE_Null then
pragma Assert (No (Fnam));
Fnam := RTE (Lib_RE);
end if;
return
Make_Function_Call (Loc,
Name => New_Occurrence_Of (Fnam, Loc),
Parameter_Associations => New_List (N));
end Build_To_Any_Call;
procedure Build_To_Any_Function
(Loc : Source_Ptr;
Typ : Entity_Id;
Decl : out Node_Id;
Fnam : out Entity_Id)
is
Spec : Node_Id;
Decls : constant List_Id := New_List;
Stms : constant List_Id := New_List;
Expr_Parameter : constant Entity_Id :=
Make_Defining_Identifier (Loc, Name_E);
Any : constant Entity_Id :=
Make_Defining_Identifier (Loc, Name_A);
Any_Decl : Node_Id;
Result_TC : Node_Id := Build_TypeCode_Call (Loc, Typ, Decls);
begin
Fnam := Make_Stream_Procedure_Function_Name (Loc,
Typ, Name_uTo_Any);
Spec :=
Make_Function_Specification (Loc,
Defining_Unit_Name => Fnam,
Parameter_Specifications => New_List (
Make_Parameter_Specification (Loc,
Defining_Identifier =>
Expr_Parameter,
Parameter_Type =>
New_Occurrence_Of (Typ, Loc))),
Subtype_Mark => New_Occurrence_Of (RTE (RE_Any), Loc));
Set_Etype (Expr_Parameter, Typ);
Any_Decl :=
Make_Object_Declaration (Loc,
Defining_Identifier =>
Any,
Object_Definition =>
New_Occurrence_Of (RTE (RE_Any), Loc));
if Is_Derived_Type (Typ) and then not Is_Tagged_Type (Typ) then
declare
Rt_Type : constant Entity_Id
:= Root_Type (Typ);
Expr : constant Node_Id
:= OK_Convert_To (
Rt_Type,
New_Occurrence_Of (Expr_Parameter, Loc));
begin
Set_Expression (Any_Decl, Build_To_Any_Call (Expr, Decls));
end;
elsif Is_Record_Type (Typ) and then not Is_Tagged_Type (Typ) then
if Nkind (Declaration_Node (Typ)) = N_Subtype_Declaration then
declare
Rt_Type : constant Entity_Id
:= Etype (Typ);
Expr : constant Node_Id
:= OK_Convert_To (
Rt_Type,
New_Occurrence_Of (Expr_Parameter, Loc));
begin
Set_Expression (Any_Decl,
Build_To_Any_Call (Expr, Decls));
end;
else
declare
Disc : Entity_Id := Empty;
Rdef : constant Node_Id :=
Type_Definition (Declaration_Node (Typ));
Counter : Int := 0;
Elements : constant List_Id := New_List;
procedure TA_Rec_Add_Process_Element
(Stmts : List_Id;
Container : Node_Or_Entity_Id;
Counter : in out Int;
Rec : Entity_Id;
Field : Node_Id);
procedure TA_Append_Record_Traversal is
new Append_Record_Traversal
(Rec => Expr_Parameter,
Add_Process_Element => TA_Rec_Add_Process_Element);
procedure TA_Rec_Add_Process_Element
(Stmts : List_Id;
Container : Node_Or_Entity_Id;
Counter : in out Int;
Rec : Entity_Id;
Field : Node_Id)
is
Field_Ref : Node_Id;
begin
if Nkind (Field) = N_Defining_Identifier then
Field_Ref := Make_Selected_Component (Loc,
Prefix => New_Occurrence_Of (Rec, Loc),
Selector_Name => New_Occurrence_Of (Field, Loc));
Set_Etype (Field_Ref, Etype (Field));
Append_To (Stmts,
Make_Procedure_Call_Statement (Loc,
Name =>
New_Occurrence_Of (
RTE (RE_Add_Aggregate_Element), Loc),
Parameter_Associations => New_List (
New_Occurrence_Of (Any, Loc),
Build_To_Any_Call (Field_Ref, Decls))));
else
declare
Variant : Node_Id;
Struct_Counter : Int := 0;
Block_Decls : constant List_Id := New_List;
Block_Stmts : constant List_Id := New_List;
VP_Stmts : List_Id;
Alt_List : constant List_Id := New_List;
Choice_List : List_Id;
Union_Any : constant Entity_Id :=
Make_Defining_Identifier (Loc,
New_Internal_Name ('U'));
Struct_Any : constant Entity_Id :=
Make_Defining_Identifier (Loc,
New_Internal_Name ('S'));
function Make_Discriminant_Reference
return Node_Id;
function Make_Discriminant_Reference
return Node_Id
is
Nod : constant Node_Id :=
Make_Selected_Component (Loc,
Prefix => Rec,
Selector_Name =>
Chars (Name (Field)));
begin
Set_Etype (Nod, Name (Field));
return Nod;
end Make_Discriminant_Reference;
begin
Append_To (Stmts,
Make_Block_Statement (Loc,
Declarations =>
Block_Decls,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => Block_Stmts)));
Append_To (Block_Decls,
Make_Object_Declaration (Loc,
Defining_Identifier => Union_Any,
Object_Definition =>
New_Occurrence_Of (RTE (RE_Any), Loc),
Expression =>
Make_Function_Call (Loc,
Name => New_Occurrence_Of (
RTE (RE_Create_Any), Loc),
Parameter_Associations => New_List (
Make_Function_Call (Loc,
Name =>
New_Occurrence_Of (
RTE (RE_Any_Member_Type), Loc),
Parameter_Associations => New_List (
New_Occurrence_Of (Container, Loc),
Make_Integer_Literal (Loc,
Counter)))))));
Append_To (Block_Decls,
Make_Object_Declaration (Loc,
Defining_Identifier => Struct_Any,
Object_Definition =>
New_Occurrence_Of (RTE (RE_Any), Loc),
Expression =>
Make_Function_Call (Loc,
Name => New_Occurrence_Of (
RTE (RE_Create_Any), Loc),
Parameter_Associations => New_List (
Make_Function_Call (Loc,
Name =>
New_Occurrence_Of (
RTE (RE_Any_Member_Type), Loc),
Parameter_Associations => New_List (
New_Occurrence_Of (Union_Any, Loc),
Make_Integer_Literal (Loc,
Uint_0)))))));
Append_To (Block_Stmts,
Make_Case_Statement (Loc,
Expression =>
Make_Discriminant_Reference,
Alternatives =>
Alt_List));
Variant := First_Non_Pragma (Variants (Field));
while Present (Variant) loop
Choice_List := New_Copy_List_Tree
(Discrete_Choices (Variant));
VP_Stmts := New_List;
TA_Append_Record_Traversal (
Stmts => VP_Stmts,
Clist => Component_List (Variant),
Container => Struct_Any,
Counter => Struct_Counter);
Append_To (VP_Stmts,
Make_Procedure_Call_Statement (Loc,
Name =>
New_Occurrence_Of (
RTE (RE_Add_Aggregate_Element), Loc),
Parameter_Associations => New_List (
New_Occurrence_Of (Union_Any, Loc),
Build_To_Any_Call (
Make_Discriminant_Reference,
Block_Decls))));
Append_To (VP_Stmts,
Make_Procedure_Call_Statement (Loc,
Name =>
New_Occurrence_Of (
RTE (RE_Add_Aggregate_Element), Loc),
Parameter_Associations => New_List (
New_Occurrence_Of (Union_Any, Loc),
New_Occurrence_Of (Struct_Any, Loc))));
Append_To (VP_Stmts,
Make_Procedure_Call_Statement (Loc,
Name =>
New_Occurrence_Of (
RTE (RE_Add_Aggregate_Element), Loc),
Parameter_Associations => New_List (
New_Occurrence_Of (Container, Loc),
Make_Function_Call (Loc,
Name => New_Occurrence_Of (
RTE (RE_Any_Aggregate_Build), Loc),
Parameter_Associations => New_List (
New_Occurrence_Of (
Union_Any, Loc))))));
Append_To (Alt_List,
Make_Case_Statement_Alternative (Loc,
Discrete_Choices => Choice_List,
Statements =>
VP_Stmts));
Next_Non_Pragma (Variant);
end loop;
end;
end if;
end TA_Rec_Add_Process_Element;
begin
if Has_Discriminants (Typ) then
Disc := First_Discriminant (Typ);
while Present (Disc) loop
Append_To (Elements,
Make_Component_Association (Loc,
Choices => New_List (
Make_Integer_Literal (Loc, Counter)),
Expression =>
Build_To_Any_Call (
Make_Selected_Component (Loc,
Prefix => Expr_Parameter,
Selector_Name => Chars (Disc)),
Decls)));
Counter := Counter + 1;
Next_Discriminant (Disc);
end loop;
else
declare
Dummy_Any : constant Entity_Id :=
Make_Defining_Identifier (Loc,
Chars => New_Internal_Name ('A'));
begin
Append_To (Decls,
Make_Object_Declaration (Loc,
Defining_Identifier => Dummy_Any,
Object_Definition =>
New_Occurrence_Of (RTE (RE_Any), Loc)));
Append_To (Elements,
Make_Component_Association (Loc,
Choices => New_List (
Make_Range (Loc,
Low_Bound =>
Make_Integer_Literal (Loc, 1),
High_Bound =>
Make_Integer_Literal (Loc, 0))),
Expression =>
New_Occurrence_Of (Dummy_Any, Loc)));
end;
end if;
Set_Expression (Any_Decl,
Make_Function_Call (Loc,
Name => New_Occurrence_Of (
RTE (RE_Any_Aggregate_Build), Loc),
Parameter_Associations => New_List (
Result_TC,
Make_Aggregate (Loc,
Component_Associations => Elements))));
Result_TC := Empty;
TA_Append_Record_Traversal (Stms,
Clist => Component_List (Rdef),
Container => Any,
Counter => Counter);
end;
end if;
elsif Is_Array_Type (Typ) then
declare
Constrained : constant Boolean := Is_Constrained (Typ);
procedure TA_Ary_Add_Process_Element
(Stmts : List_Id;
Any : Entity_Id;
Counter : Entity_Id;
Datum : Node_Id);
procedure TA_Ary_Add_Process_Element
(Stmts : List_Id;
Any : Entity_Id;
Counter : Entity_Id;
Datum : Node_Id)
is
pragma Warnings (Off);
pragma Unreferenced (Counter);
pragma Warnings (On);
Element_Any : Node_Id;
begin
if Etype (Datum) = RTE (RE_Any) then
Element_Any := Datum;
else
Element_Any := Build_To_Any_Call (Datum, Decls);
end if;
Append_To (Stmts,
Make_Procedure_Call_Statement (Loc,
Name => New_Occurrence_Of (
RTE (RE_Add_Aggregate_Element), Loc),
Parameter_Associations => New_List (
New_Occurrence_Of (Any, Loc),
Element_Any)));
end TA_Ary_Add_Process_Element;
procedure Append_To_Any_Array_Iterator is
new Append_Array_Traversal (
Subprogram => Fnam,
Arry => Expr_Parameter,
Indices => New_List,
Add_Process_Element => TA_Ary_Add_Process_Element);
Index : Node_Id;
begin
Set_Expression (Any_Decl,
Make_Function_Call (Loc,
Name =>
New_Occurrence_Of (RTE (RE_Create_Any), Loc),
Parameter_Associations => New_List (Result_TC)));
Result_TC := Empty;
if not Constrained then
Index := First_Index (Typ);
for J in 1 .. Number_Dimensions (Typ) loop
Append_To (Stms,
Make_Procedure_Call_Statement (Loc,
Name =>
New_Occurrence_Of (
RTE (RE_Add_Aggregate_Element), Loc),
Parameter_Associations => New_List (
New_Occurrence_Of (Any, Loc),
Build_To_Any_Call (
OK_Convert_To (Etype (Index),
Make_Attribute_Reference (Loc,
Prefix =>
New_Occurrence_Of (Expr_Parameter, Loc),
Attribute_Name => Name_First,
Expressions => New_List (
Make_Integer_Literal (Loc, J)))),
Decls))));
Next_Index (Index);
end loop;
end if;
Append_To_Any_Array_Iterator (Stms, Any);
end;
elsif Is_Integer_Type (Typ) or else Is_Unsigned_Type (Typ) then
Set_Expression (Any_Decl,
Build_To_Any_Call (
OK_Convert_To (
Find_Numeric_Representation (Typ),
New_Occurrence_Of (Expr_Parameter, Loc)),
Decls));
else
declare
Strm : constant Entity_Id := Make_Defining_Identifier (Loc,
New_Internal_Name ('S'));
begin
Append_To (Decls,
Make_Object_Declaration (Loc,
Defining_Identifier =>
Strm,
Aliased_Present =>
True,
Object_Definition =>
New_Occurrence_Of (RTE (RE_Buffer_Stream_Type), Loc)));
Append_To (Stms,
Make_Procedure_Call_Statement (Loc,
Name =>
New_Occurrence_Of (RTE (RE_Allocate_Buffer), Loc),
Parameter_Associations => New_List (
New_Occurrence_Of (Strm, Loc))));
Append_To (Stms,
Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (Typ, Loc),
Attribute_Name => Name_Output,
Expressions => New_List (
Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (Strm, Loc),
Attribute_Name => Name_Access),
New_Occurrence_Of (Expr_Parameter, Loc))));
Append_To (Stms,
Make_Procedure_Call_Statement (Loc,
Name =>
New_Occurrence_Of (RTE (RE_BS_To_Any), Loc),
Parameter_Associations => New_List (
New_Occurrence_Of (Strm, Loc),
New_Occurrence_Of (Any, Loc))));
Append_To (Stms,
Make_Procedure_Call_Statement (Loc,
Name =>
New_Occurrence_Of (RTE (RE_Release_Buffer), Loc),
Parameter_Associations => New_List (
New_Occurrence_Of (Strm, Loc))));
end;
end if;
Append_To (Decls, Any_Decl);
if Present (Result_TC) then
Append_To (Stms,
Make_Procedure_Call_Statement (Loc,
Name => New_Occurrence_Of (RTE (RE_Set_TC), Loc),
Parameter_Associations => New_List (
New_Occurrence_Of (Any, Loc),
Result_TC)));
end if;
Append_To (Stms,
Make_Return_Statement (Loc,
Expression => New_Occurrence_Of (Any, Loc)));
Decl :=
Make_Subprogram_Body (Loc,
Specification => Spec,
Declarations => Decls,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => Stms));
end Build_To_Any_Function;
function Build_TypeCode_Call
(Loc : Source_Ptr;
Typ : Entity_Id;
Decls : List_Id) return Node_Id
is
U_Type : Entity_Id := Underlying_Type (Typ);
Fnam : Entity_Id := Empty;
Tnam : Entity_Id := Empty;
Pnam : Entity_Id := Empty;
Args : List_Id := Empty_List;
Lib_RE : RE_Id := RE_Null;
Expr : Node_Id;
begin
if Typ = RTE (RE_Any) then
Fnam := RTE (RE_TC_Any);
else
Fnam := Find_Inherited_TSS (U_Type, Name_uTypeCode);
if Present (Fnam) then
Tnam :=
Make_Defining_Identifier (Loc, New_Internal_Name ('T'));
Pnam :=
Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
Append_To (Decls,
Make_Full_Type_Declaration (Loc,
Defining_Identifier => Tnam,
Type_Definition =>
Make_Access_To_Object_Definition (Loc,
Subtype_Indication =>
New_Occurrence_Of (U_Type, Loc))));
Append_To (Decls,
Make_Object_Declaration (Loc,
Defining_Identifier => Pnam,
Constant_Present => True,
Object_Definition => New_Occurrence_Of (Tnam, Loc),
Expression => Make_Null (Loc)));
Args := New_List (New_Occurrence_Of (Pnam, Loc));
end if;
end if;
if No (Fnam) then
if Sloc (U_Type) <= Standard_Location then
U_Type := Base_Type (U_Type);
end if;
if Is_Itype (U_Type) then
return Build_TypeCode_Call
(Loc, Associated_Node_For_Itype (U_Type), Decls);
end if;
if U_Type = Standard_Boolean then
Lib_RE := RE_TC_B;
elsif U_Type = Standard_Character then
Lib_RE := RE_TC_C;
elsif U_Type = Standard_Wide_Character then
Lib_RE := RE_TC_WC;
elsif U_Type = Standard_Wide_Wide_Character then
Lib_RE := RE_TC_WWC;
elsif U_Type = Standard_Short_Float then
Lib_RE := RE_TC_SF;
elsif U_Type = Standard_Float then
Lib_RE := RE_TC_F;
elsif U_Type = Standard_Long_Float then
Lib_RE := RE_TC_LF;
elsif U_Type = Standard_Long_Long_Float then
Lib_RE := RE_TC_LLF;
elsif U_Type = Etype (Standard_Short_Short_Integer) then
Lib_RE := RE_TC_SSI;
elsif U_Type = Etype (Standard_Short_Integer) then
Lib_RE := RE_TC_SI;
elsif U_Type = Etype (Standard_Integer) then
Lib_RE := RE_TC_I;
elsif U_Type = Etype (Standard_Long_Integer) then
Lib_RE := RE_TC_LI;
elsif U_Type = Etype (Standard_Long_Long_Integer) then
Lib_RE := RE_TC_LLI;
elsif U_Type = RTE (RE_Short_Short_Unsigned) then
Lib_RE := RE_TC_SSU;
elsif U_Type = RTE (RE_Short_Unsigned) then
Lib_RE := RE_TC_SU;
elsif U_Type = RTE (RE_Unsigned) then
Lib_RE := RE_TC_U;
elsif U_Type = RTE (RE_Long_Unsigned) then
Lib_RE := RE_TC_LU;
elsif U_Type = RTE (RE_Long_Long_Unsigned) then
Lib_RE := RE_TC_LLU;
elsif U_Type = Standard_String then
Lib_RE := RE_TC_String;
else
declare
Decl : Entity_Id;
begin
Build_TypeCode_Function (Loc, U_Type, Decl, Fnam);
Append_To (Decls, Decl);
end;
end if;
if Lib_RE /= RE_Null then
Fnam := RTE (Lib_RE);
end if;
end if;
Expr :=
Make_Function_Call (Loc,
Name => New_Occurrence_Of (Fnam, Loc),
Parameter_Associations => Args);
Set_Etype (Expr, RTE (RE_TypeCode));
return Expr;
end Build_TypeCode_Call;
procedure Build_TypeCode_Function
(Loc : Source_Ptr;
Typ : Entity_Id;
Decl : out Node_Id;
Fnam : out Entity_Id)
is
Spec : Node_Id;
Decls : constant List_Id := New_List;
Stms : constant List_Id := New_List;
TCNam : constant Entity_Id :=
Make_Stream_Procedure_Function_Name (Loc,
Typ, Name_uTypeCode);
Parameters : List_Id;
procedure Add_String_Parameter
(S : String_Id;
Parameter_List : List_Id);
procedure Add_TypeCode_Parameter
(TC_Node : Node_Id;
Parameter_List : List_Id);
procedure Add_Long_Parameter
(Expr_Node : Node_Id;
Parameter_List : List_Id);
procedure Initialize_Parameter_List
(Name_String : String_Id;
Repo_Id_String : String_Id;
Parameter_List : out List_Id);
function Make_Constructed_TypeCode
(Kind : Entity_Id;
Parameters : List_Id) return Node_Id;
procedure Return_Constructed_TypeCode (Kind : Entity_Id);
procedure Return_Alias_TypeCode (Base_TypeCode : Node_Id);
procedure Add_String_Parameter
(S : String_Id;
Parameter_List : List_Id)
is
begin
Append_To (Parameter_List,
Make_Function_Call (Loc,
Name =>
New_Occurrence_Of (RTE (RE_TA_String), Loc),
Parameter_Associations => New_List (
Make_String_Literal (Loc, S))));
end Add_String_Parameter;
procedure Add_TypeCode_Parameter
(TC_Node : Node_Id;
Parameter_List : List_Id)
is
begin
Append_To (Parameter_List,
Make_Function_Call (Loc,
Name =>
New_Occurrence_Of (RTE (RE_TA_TC), Loc),
Parameter_Associations => New_List (
TC_Node)));
end Add_TypeCode_Parameter;
procedure Add_Long_Parameter
(Expr_Node : Node_Id;
Parameter_List : List_Id)
is
begin
Append_To (Parameter_List,
Make_Function_Call (Loc,
Name =>
New_Occurrence_Of (RTE (RE_TA_LI), Loc),
Parameter_Associations => New_List (Expr_Node)));
end Add_Long_Parameter;
procedure Initialize_Parameter_List
(Name_String : String_Id;
Repo_Id_String : String_Id;
Parameter_List : out List_Id)
is
begin
Parameter_List := New_List;
Add_String_Parameter (Name_String, Parameter_List);
Add_String_Parameter (Repo_Id_String, Parameter_List);
end Initialize_Parameter_List;
procedure Return_Alias_TypeCode
(Base_TypeCode : Node_Id)
is
begin
Add_TypeCode_Parameter (Base_TypeCode, Parameters);
Return_Constructed_TypeCode (RTE (RE_TC_Alias));
end Return_Alias_TypeCode;
function Make_Constructed_TypeCode
(Kind : Entity_Id;
Parameters : List_Id) return Node_Id
is
Constructed_TC : constant Node_Id :=
Make_Function_Call (Loc,
Name =>
New_Occurrence_Of (RTE (RE_TC_Build), Loc),
Parameter_Associations => New_List (
New_Occurrence_Of (Kind, Loc),
Make_Aggregate (Loc,
Expressions => Parameters)));
begin
Set_Etype (Constructed_TC, RTE (RE_TypeCode));
return Constructed_TC;
end Make_Constructed_TypeCode;
procedure Return_Constructed_TypeCode (Kind : Entity_Id) is
begin
Append_To (Stms,
Make_Return_Statement (Loc,
Expression =>
Make_Constructed_TypeCode (Kind, Parameters)));
end Return_Constructed_TypeCode;
procedure TC_Rec_Add_Process_Element
(Params : List_Id;
Any : Entity_Id;
Counter : in out Int;
Rec : Entity_Id;
Field : Node_Id);
procedure TC_Append_Record_Traversal is
new Append_Record_Traversal (
Rec => Empty,
Add_Process_Element => TC_Rec_Add_Process_Element);
procedure TC_Rec_Add_Process_Element
(Params : List_Id;
Any : Entity_Id;
Counter : in out Int;
Rec : Entity_Id;
Field : Node_Id)
is
pragma Warnings (Off);
pragma Unreferenced (Any, Counter, Rec);
pragma Warnings (On);
begin
if Nkind (Field) = N_Defining_Identifier then
Add_TypeCode_Parameter (
Build_TypeCode_Call (Loc, Etype (Field), Decls), Params);
Get_Name_String (Chars (Field));
Add_String_Parameter (String_From_Name_Buffer, Params);
else
declare
Discriminant_Type : constant Entity_Id :=
Etype (Name (Field));
Is_Enum : constant Boolean :=
Is_Enumeration_Type (Discriminant_Type);
Union_TC_Params : List_Id;
U_Name : constant Name_Id :=
New_External_Name (Chars (Typ), 'U', -1);
Name_Str : String_Id;
Struct_TC_Params : List_Id;
Variant : Node_Id;
Choice : Node_Id;
Default : constant Node_Id :=
Make_Integer_Literal (Loc, -1);
Dummy_Counter : Int := 0;
procedure Add_Params_For_Variant_Components;
procedure Add_Params_For_Variant_Components
is
S_Name : constant Name_Id :=
New_External_Name (U_Name, 'S', -1);
begin
Get_Name_String (S_Name);
Name_Str := String_From_Name_Buffer;
Initialize_Parameter_List
(Name_Str, Name_Str, Struct_TC_Params);
TC_Append_Record_Traversal (Struct_TC_Params,
Component_List (Variant),
Empty,
Dummy_Counter);
Add_TypeCode_Parameter
(Make_Constructed_TypeCode
(RTE (RE_TC_Struct), Struct_TC_Params),
Union_TC_Params);
Add_String_Parameter (Name_Str, Union_TC_Params);
end Add_Params_For_Variant_Components;
begin
Get_Name_String (U_Name);
Name_Str := String_From_Name_Buffer;
Initialize_Parameter_List
(Name_Str, Name_Str, Union_TC_Params);
Add_String_Parameter (Name_Str, Params);
Add_TypeCode_Parameter
(Make_Constructed_TypeCode
(RTE (RE_TC_Union), Union_TC_Params),
Parameters);
Add_TypeCode_Parameter
(Discriminant_Type, Union_TC_Params);
Add_Long_Parameter (Default, Union_TC_Params);
Variant := First_Non_Pragma (Variants (Field));
while Present (Variant) loop
Choice := First (Discrete_Choices (Variant));
while Present (Choice) loop
case Nkind (Choice) is
when N_Range =>
declare
L : constant Uint :=
Expr_Value (Low_Bound (Choice));
H : constant Uint :=
Expr_Value (High_Bound (Choice));
J : Uint := L;
Expr : Node_Id;
begin
while J <= H loop
if Is_Enum then
Expr := New_Occurrence_Of (
Get_Enum_Lit_From_Pos (
Discriminant_Type, J, Loc), Loc);
else
Expr :=
Make_Integer_Literal (Loc, J);
end if;
Append_To (Union_TC_Params,
Build_To_Any_Call (Expr, Decls));
Add_Params_For_Variant_Components;
J := J + Uint_1;
end loop;
end;
when N_Others_Choice =>
Add_Long_Parameter (
Make_Integer_Literal (Loc, 0),
Union_TC_Params);
Add_Params_For_Variant_Components;
when others =>
Append_To (Union_TC_Params,
Build_To_Any_Call (Choice, Decls));
Add_Params_For_Variant_Components;
end case;
end loop;
Next_Non_Pragma (Variant);
end loop;
end;
end if;
end TC_Rec_Add_Process_Element;
Type_Name_Str : String_Id;
Type_Repo_Id_Str : String_Id;
begin
pragma Assert (not Is_Itype (Typ));
Fnam := TCNam;
Spec :=
Make_Function_Specification (Loc,
Defining_Unit_Name => Fnam,
Parameter_Specifications => Empty_List,
Subtype_Mark => New_Occurrence_Of (RTE (RE_TypeCode), Loc));
Build_Name_And_Repository_Id (Typ,
Name_Str => Type_Name_Str, Repo_Id_Str => Type_Repo_Id_Str);
Initialize_Parameter_List
(Type_Name_Str, Type_Repo_Id_Str, Parameters);
if Is_Derived_Type (Typ)
and then not Is_Tagged_Type (Typ)
then
declare
D_Node : constant Node_Id := Declaration_Node (Typ);
Parent_Type : Entity_Id := Etype (Typ);
begin
if Is_Enumeration_Type (Typ)
and then Nkind (D_Node) = N_Subtype_Declaration
and then Nkind (Original_Node (D_Node))
/= N_Subtype_Declaration
then
Parent_Type := Etype (Parent_Type);
end if;
Return_Alias_TypeCode (
Build_TypeCode_Call (Loc, Parent_Type, Decls));
end;
elsif Is_Integer_Type (Typ)
or else Is_Unsigned_Type (Typ)
then
Return_Alias_TypeCode (
Build_TypeCode_Call (Loc,
Find_Numeric_Representation (Typ), Decls));
elsif Is_Record_Type (Typ)
and then not Is_Tagged_Type (Typ)
then
if Nkind (Declaration_Node (Typ)) = N_Subtype_Declaration then
Return_Alias_TypeCode (
Build_TypeCode_Call (Loc, Etype (Typ), Decls));
else
declare
Disc : Entity_Id := Empty;
Rdef : constant Node_Id :=
Type_Definition (Declaration_Node (Typ));
Dummy_Counter : Int := 0;
begin
if Has_Discriminants (Typ) then
Disc := First_Discriminant (Typ);
end if;
while Present (Disc) loop
Add_TypeCode_Parameter (
Build_TypeCode_Call (Loc, Etype (Disc), Decls),
Parameters);
Get_Name_String (Chars (Disc));
Add_String_Parameter (
String_From_Name_Buffer,
Parameters);
Next_Discriminant (Disc);
end loop;
TC_Append_Record_Traversal
(Parameters, Component_List (Rdef),
Empty, Dummy_Counter);
Return_Constructed_TypeCode (RTE (RE_TC_Struct));
end;
end if;
elsif Is_Array_Type (Typ) then
declare
Ndim : constant Pos := Number_Dimensions (Typ);
Inner_TypeCode : Node_Id;
Constrained : constant Boolean := Is_Constrained (Typ);
Indx : Node_Id := First_Index (Typ);
begin
Inner_TypeCode := Build_TypeCode_Call (Loc,
Component_Type (Typ),
Decls);
for J in 1 .. Ndim loop
if Constrained then
Inner_TypeCode := Make_Constructed_TypeCode
(RTE (RE_TC_Array), New_List (
Build_To_Any_Call (
OK_Convert_To (RTE (RE_Long_Unsigned),
Make_Attribute_Reference (Loc,
Prefix =>
New_Occurrence_Of (Typ, Loc),
Attribute_Name =>
Name_Length,
Expressions => New_List (
Make_Integer_Literal (Loc,
Ndim - J + 1)))),
Decls),
Build_To_Any_Call (Inner_TypeCode, Decls)));
else
Add_TypeCode_Parameter
(Build_TypeCode_Call (Loc, Etype (Indx), Decls),
Parameters);
Get_Name_String (New_External_Name ('L', J));
Add_String_Parameter (
String_From_Name_Buffer,
Parameters);
Next_Index (Indx);
Inner_TypeCode := Make_Constructed_TypeCode
(RTE (RE_TC_Sequence), New_List (
Build_To_Any_Call (
OK_Convert_To (RTE (RE_Long_Unsigned),
Make_Integer_Literal (Loc, 0)),
Decls),
Build_To_Any_Call (Inner_TypeCode, Decls)));
end if;
end loop;
if Constrained then
Return_Alias_TypeCode (Inner_TypeCode);
else
Add_TypeCode_Parameter (Inner_TypeCode, Parameters);
Start_String;
Store_String_Char ('V');
Add_String_Parameter (End_String, Parameters);
Return_Constructed_TypeCode (RTE (RE_TC_Struct));
end if;
end;
else
Return_Alias_TypeCode
(New_Occurrence_Of (RTE (RE_TC_Opaque), Loc));
end if;
Decl :=
Make_Subprogram_Body (Loc,
Specification => Spec,
Declarations => Decls,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => Stms));
end Build_TypeCode_Function;
function Find_Inherited_TSS
(Typ : Entity_Id;
Nam : Name_Id) return Entity_Id
is
P_Type : Entity_Id := Typ;
Proc : Entity_Id;
begin
Proc := TSS (Base_Type (Typ), Nam);
if Present (Proc) then
return Proc;
end if;
if Is_Derived_Type (P_Type) then
if Is_Tagged_Type (P_Type) then
return Find_Prim_Op (P_Type, Nam);
else
while Is_Derived_Type (P_Type) loop
Proc := TSS (Base_Type (Etype (Typ)), Nam);
if Present (Proc) then
return Proc;
else
P_Type := Base_Type (Etype (P_Type));
end if;
end loop;
end if;
end if;
return TSS (Base_Type (Underlying_Type (Typ)), Nam);
end Find_Inherited_TSS;
function Find_Numeric_Representation (Typ : Entity_Id)
return Entity_Id
is
FST : constant Entity_Id := First_Subtype (Typ);
P_Size : constant Uint := Esize (FST);
begin
if Is_Unsigned_Type (Typ) then
if P_Size <= Standard_Short_Short_Integer_Size then
return RTE (RE_Short_Short_Unsigned);
elsif P_Size <= Standard_Short_Integer_Size then
return RTE (RE_Short_Unsigned);
elsif P_Size <= Standard_Integer_Size then
return RTE (RE_Unsigned);
elsif P_Size <= Standard_Long_Integer_Size then
return RTE (RE_Long_Unsigned);
else
return RTE (RE_Long_Long_Unsigned);
end if;
elsif Is_Integer_Type (Typ) then
if P_Size <= Standard_Short_Short_Integer_Size then
return Standard_Short_Short_Integer;
elsif P_Size <= Standard_Short_Integer_Size then
return Standard_Short_Integer;
elsif P_Size <= Standard_Integer_Size then
return Standard_Integer;
elsif P_Size <= Standard_Long_Integer_Size then
return Standard_Long_Integer;
else
return Standard_Long_Long_Integer;
end if;
elsif Is_Floating_Point_Type (Typ) then
if P_Size <= Standard_Short_Float_Size then
return Standard_Short_Float;
elsif P_Size <= Standard_Float_Size then
return Standard_Float;
elsif P_Size <= Standard_Long_Float_Size then
return Standard_Long_Float;
else
return Standard_Long_Long_Float;
end if;
else
raise Program_Error;
end if;
end Find_Numeric_Representation;
procedure Append_Array_Traversal
(Stmts : List_Id;
Any : Entity_Id;
Counter : Entity_Id := Empty;
Depth : Pos := 1)
is
Loc : constant Source_Ptr := Sloc (Subprogram);
Typ : constant Entity_Id := Etype (Arry);
Constrained : constant Boolean := Is_Constrained (Typ);
Ndim : constant Pos := Number_Dimensions (Typ);
Inner_Any, Inner_Counter : Entity_Id;
Loop_Stm : Node_Id;
Inner_Stmts : constant List_Id := New_List;
begin
if Depth > Ndim then
declare
Element_Expr : constant Node_Id :=
Make_Indexed_Component (Loc,
New_Occurrence_Of (Arry, Loc),
Indices);
begin
Set_Etype (Element_Expr, Component_Type (Typ));
Add_Process_Element (Stmts,
Any => Any,
Counter => Counter,
Datum => Element_Expr);
end;
return;
end if;
Append_To (Indices,
Make_Identifier (Loc, New_External_Name ('L', Depth)));
if Constrained then
Inner_Any := Any;
Inner_Counter := Counter;
else
Inner_Any := Make_Defining_Identifier (Loc,
New_External_Name ('A', Depth));
Set_Etype (Inner_Any, RTE (RE_Any));
if Present (Counter) then
Inner_Counter := Make_Defining_Identifier (Loc,
New_External_Name ('J', Depth));
else
Inner_Counter := Empty;
end if;
end if;
Append_Array_Traversal (Inner_Stmts,
Any => Inner_Any,
Counter => Inner_Counter,
Depth => Depth + 1);
Loop_Stm :=
Make_Implicit_Loop_Statement (Subprogram,
Iteration_Scheme =>
Make_Iteration_Scheme (Loc,
Loop_Parameter_Specification =>
Make_Loop_Parameter_Specification (Loc,
Defining_Identifier =>
Make_Defining_Identifier (Loc,
Chars => New_External_Name ('L', Depth)),
Discrete_Subtype_Definition =>
Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (Arry, Loc),
Attribute_Name => Name_Range,
Expressions => New_List (
Make_Integer_Literal (Loc, Depth))))),
Statements => Inner_Stmts);
if Constrained then
Append_To (Stmts, Loop_Stm);
return;
end if;
declare
Decls : constant List_Id := New_List;
Dimen_Stmts : constant List_Id := New_List;
Length_Node : Node_Id;
Inner_Any_TypeCode : constant Entity_Id :=
Make_Defining_Identifier (Loc,
New_External_Name ('T', Depth));
Inner_Any_TypeCode_Expr : Node_Id;
begin
if Depth = 1 then
Inner_Any_TypeCode_Expr :=
Make_Function_Call (Loc,
Name =>
New_Occurrence_Of (RTE (RE_Any_Member_Type), Loc),
Parameter_Associations => New_List (
New_Occurrence_Of (Any, Loc),
Make_Integer_Literal (Loc, Ndim)));
else
Inner_Any_TypeCode_Expr :=
Make_Function_Call (Loc,
Name =>
New_Occurrence_Of (RTE (RE_Content_Type), Loc),
Parameter_Associations => New_List (
Make_Identifier (Loc,
New_External_Name ('T', Depth - 1))));
end if;
Append_To (Decls,
Make_Object_Declaration (Loc,
Defining_Identifier => Inner_Any_TypeCode,
Constant_Present => True,
Object_Definition => New_Occurrence_Of (
RTE (RE_TypeCode), Loc),
Expression => Inner_Any_TypeCode_Expr));
Append_To (Decls,
Make_Object_Declaration (Loc,
Defining_Identifier => Inner_Any,
Object_Definition =>
New_Occurrence_Of (RTE (RE_Any), Loc),
Expression =>
Make_Function_Call (Loc,
Name =>
New_Occurrence_Of (
RTE (RE_Create_Any), Loc),
Parameter_Associations => New_List (
New_Occurrence_Of (Inner_Any_TypeCode, Loc)))));
if Present (Inner_Counter) then
Append_To (Decls,
Make_Object_Declaration (Loc,
Defining_Identifier => Inner_Counter,
Object_Definition =>
New_Occurrence_Of (RTE (RE_Long_Unsigned), Loc),
Expression =>
Make_Integer_Literal (Loc, 0)));
end if;
Length_Node := Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (Arry, Loc),
Attribute_Name => Name_Length,
Expressions =>
New_List (Make_Integer_Literal (Loc, Depth)));
Set_Etype (Length_Node, RTE (RE_Long_Unsigned));
Add_Process_Element (Dimen_Stmts,
Datum => Length_Node,
Any => Inner_Any,
Counter => Inner_Counter);
Append_To (Dimen_Stmts, Loop_Stm);
Add_Process_Element (Dimen_Stmts,
Any => Any,
Counter => Counter,
Datum => New_Occurrence_Of (Inner_Any, Loc));
Append_To (Stmts,
Make_Block_Statement (Loc,
Declarations =>
Decls,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => Dimen_Stmts)));
end;
end Append_Array_Traversal;
function Make_Stream_Procedure_Function_Name
(Loc : Source_Ptr;
Typ : Entity_Id;
Nam : Name_Id) return Entity_Id
is
begin
if Is_Tagged_Type (Typ) then
return Make_Defining_Identifier (Loc, Nam);
else
return Make_Defining_Identifier (Loc,
Chars =>
New_External_Name (Nam, ' ', Increment_Serial_Number));
end if;
end Make_Stream_Procedure_Function_Name;
end Helpers;
procedure Reserve_NamingContext_Methods is
Str_Resolve : constant String := "resolve";
begin
Name_Buffer (1 .. Str_Resolve'Length) := Str_Resolve;
Name_Len := Str_Resolve'Length;
Overload_Counter_Table.Set (Name_Find, 1);
end Reserve_NamingContext_Methods;
end PolyORB_Support;
procedure RACW_Type_Is_Asynchronous (RACW_Type : Entity_Id) is
Asynchronous_Flag : constant Entity_Id :=
Asynchronous_Flags_Table.Get (RACW_Type);
begin
Replace (Expression (Parent (Asynchronous_Flag)),
New_Occurrence_Of (Standard_True, Sloc (Asynchronous_Flag)));
end RACW_Type_Is_Asynchronous;
function RCI_Package_Locator
(Loc : Source_Ptr;
Package_Spec : Node_Id) return Node_Id
is
Inst : Node_Id;
Pkg_Name : String_Id;
begin
Get_Library_Unit_Name_String (Package_Spec);
Pkg_Name := String_From_Name_Buffer;
Inst :=
Make_Package_Instantiation (Loc,
Defining_Unit_Name =>
Make_Defining_Identifier (Loc, New_Internal_Name ('R')),
Name =>
New_Occurrence_Of (RTE (RE_RCI_Locator), 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 => Pkg_Name))));
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 : 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,
Stub_Elements.RPC_Receiver_Decl,
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;
procedure Set_Renaming_TSS
(Typ : Entity_Id;
Nam : Entity_Id;
TSS_Nam : Name_Id)
is
Loc : constant Source_Ptr := Sloc (Nam);
Spec : constant Node_Id := Parent (Nam);
TSS_Node : constant Node_Id :=
Make_Subprogram_Renaming_Declaration (Loc,
Specification =>
Copy_Specification (Loc,
Spec => Spec,
New_Name => TSS_Nam),
Name => New_Occurrence_Of (Nam, Loc));
Snam : constant Entity_Id :=
Defining_Unit_Name (Specification (TSS_Node));
begin
if Nkind (Spec) = N_Function_Specification then
Set_Ekind (Snam, E_Function);
Set_Etype (Snam, Entity (Subtype_Mark (Spec)));
else
Set_Ekind (Snam, E_Procedure);
Set_Etype (Snam, Standard_Void_Type);
end if;
Set_TSS (Typ, Snam);
end Set_Renaming_TSS;
procedure Specific_Add_Obj_RPC_Receiver_Completion
(Loc : Source_Ptr;
Decls : List_Id;
RPC_Receiver : Entity_Id;
Stub_Elements : Stub_Structure) is
begin
case Get_PCS_Name is
when Name_PolyORB_DSA =>
PolyORB_Support.Add_Obj_RPC_Receiver_Completion (Loc,
Decls, RPC_Receiver, Stub_Elements);
when others =>
GARLIC_Support.Add_Obj_RPC_Receiver_Completion (Loc,
Decls, RPC_Receiver, Stub_Elements);
end case;
end Specific_Add_Obj_RPC_Receiver_Completion;
procedure Specific_Add_RACW_Features
(RACW_Type : Entity_Id;
Desig : Entity_Id;
Stub_Type : Entity_Id;
Stub_Type_Access : Entity_Id;
RPC_Receiver_Decl : Node_Id;
Declarations : List_Id) is
begin
case Get_PCS_Name is
when Name_PolyORB_DSA =>
PolyORB_Support.Add_RACW_Features (
RACW_Type,
Desig,
Stub_Type,
Stub_Type_Access,
RPC_Receiver_Decl,
Declarations);
when others =>
GARLIC_Support.Add_RACW_Features (
RACW_Type,
Stub_Type,
Stub_Type_Access,
RPC_Receiver_Decl,
Declarations);
end case;
end Specific_Add_RACW_Features;
procedure Specific_Add_RAST_Features
(Vis_Decl : Node_Id;
RAS_Type : Entity_Id;
Decls : List_Id)
is
begin
case Get_PCS_Name is
when Name_PolyORB_DSA =>
PolyORB_Support.Add_RAST_Features (
Vis_Decl, RAS_Type, Decls);
when others =>
GARLIC_Support.Add_RAST_Features (
Vis_Decl, RAS_Type, Decls);
end case;
end Specific_Add_RAST_Features;
procedure Specific_Add_Receiving_Stubs_To_Declarations
(Pkg_Spec : Node_Id;
Decls : List_Id)
is
begin
case Get_PCS_Name is
when Name_PolyORB_DSA =>
PolyORB_Support.Add_Receiving_Stubs_To_Declarations (
Pkg_Spec, Decls);
when others =>
GARLIC_Support.Add_Receiving_Stubs_To_Declarations (
Pkg_Spec, Decls);
end case;
end Specific_Add_Receiving_Stubs_To_Declarations;
procedure Specific_Build_General_Calling_Stubs
(Decls : List_Id;
Statements : List_Id;
Target : RPC_Target;
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;
Stub_Type : Entity_Id := Empty;
RACW_Type : Entity_Id := Empty;
Nod : Node_Id)
is
begin
case Get_PCS_Name is
when Name_PolyORB_DSA =>
PolyORB_Support.Build_General_Calling_Stubs (
Decls,
Statements,
Target.Object,
Subprogram_Id,
Asynchronous,
Is_Known_Asynchronous,
Is_Known_Non_Asynchronous,
Is_Function,
Spec,
Stub_Type,
RACW_Type,
Nod);
when others =>
GARLIC_Support.Build_General_Calling_Stubs (
Decls,
Statements,
Target.Partition,
Target.RPC_Receiver,
Subprogram_Id,
Asynchronous,
Is_Known_Asynchronous,
Is_Known_Non_Asynchronous,
Is_Function,
Spec,
Stub_Type,
RACW_Type,
Nod);
end case;
end Specific_Build_General_Calling_Stubs;
procedure Specific_Build_RPC_Receiver_Body
(RPC_Receiver : Entity_Id;
Request : out Entity_Id;
Subp_Id : out Entity_Id;
Subp_Index : out Entity_Id;
Stmts : out List_Id;
Decl : out Node_Id)
is
begin
case Get_PCS_Name is
when Name_PolyORB_DSA =>
PolyORB_Support.Build_RPC_Receiver_Body
(RPC_Receiver,
Request,
Subp_Id,
Subp_Index,
Stmts,
Decl);
when others =>
GARLIC_Support.Build_RPC_Receiver_Body
(RPC_Receiver,
Request,
Subp_Id,
Subp_Index,
Stmts,
Decl);
end case;
end Specific_Build_RPC_Receiver_Body;
function Specific_Build_Stub_Target
(Loc : Source_Ptr;
Decls : List_Id;
RCI_Locator : Entity_Id;
Controlling_Parameter : Entity_Id) return RPC_Target is
begin
case Get_PCS_Name is
when Name_PolyORB_DSA =>
return PolyORB_Support.Build_Stub_Target (Loc,
Decls, RCI_Locator, Controlling_Parameter);
when others =>
return GARLIC_Support.Build_Stub_Target (Loc,
Decls, RCI_Locator, Controlling_Parameter);
end case;
end Specific_Build_Stub_Target;
procedure Specific_Build_Stub_Type
(RACW_Type : Entity_Id;
Stub_Type : Entity_Id;
Stub_Type_Decl : out Node_Id;
RPC_Receiver_Decl : out Node_Id)
is
begin
case Get_PCS_Name is
when Name_PolyORB_DSA =>
PolyORB_Support.Build_Stub_Type (
RACW_Type, Stub_Type,
Stub_Type_Decl, RPC_Receiver_Decl);
when others =>
GARLIC_Support.Build_Stub_Type (
RACW_Type, Stub_Type,
Stub_Type_Decl, RPC_Receiver_Decl);
end case;
end Specific_Build_Stub_Type;
function Specific_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
begin
case Get_PCS_Name is
when Name_PolyORB_DSA =>
return PolyORB_Support.Build_Subprogram_Receiving_Stubs (
Vis_Decl,
Asynchronous,
Dynamically_Asynchronous,
Stub_Type,
RACW_Type,
Parent_Primitive);
when others =>
return GARLIC_Support.Build_Subprogram_Receiving_Stubs (
Vis_Decl,
Asynchronous,
Dynamically_Asynchronous,
Stub_Type,
RACW_Type,
Parent_Primitive);
end case;
end Specific_Build_Subprogram_Receiving_Stubs;
function Underlying_RACW_Type (RAS_Typ : Entity_Id) return Entity_Id is
Record_Type : Entity_Id;
begin
if Ekind (RAS_Typ) = E_Record_Type then
Record_Type := RAS_Typ;
else
pragma Assert (Present (Equivalent_Type (RAS_Typ)));
Record_Type := Equivalent_Type (RAS_Typ);
end if;
return
Etype (Subtype_Indication (
Component_Definition (
First (Component_Items (Component_List (
Type_Definition (Declaration_Node (Record_Type))))))));
end Underlying_RACW_Type;
end Exp_Dist;