-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2004 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2005 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- If Locator is not Empty, it will be used instead of RCI_Cache. If
-- New_Name is given, then it will be used instead of the original name.
- 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;
- -- Build the receiving stub for a given subprogram. The subprogram
- -- declaration is also built by this procedure, and the value returned
- -- is a N_Subprogram_Body. If a parameter of type access to Stub_Type is
- -- found in the specification, then its address is read from the stream
- -- instead of the object itself and converted into an access to
- -- class-wide type before doing the real call using any of the RACW type
- -- pointing on the designated type.
-
- procedure Build_RPC_Receiver_Body
- (RPC_Receiver : Entity_Id;
- Stream : out Entity_Id;
- Result : out Entity_Id;
- Subp_Id : out Entity_Id;
- Stmts : out List_Id;
- Decl : out Node_Id);
- -- Make a subprogram body for an RPC receiver, with the given
- -- defining unit name. On return:
- -- - Subp_Id is the Standard.String variable that contains
- -- the identifier of the desired subprogram,
- -- - Stmts is the place where the request dispatching
- -- statements can occur,
- -- - Decl is the subprogram body declaration.
+ function Build_RPC_Receiver_Specification
+ (RPC_Receiver : Entity_Id;
+ Request_Parameter : Entity_Id) return Node_Id;
+ -- Make a subprogram specification for an RPC receiver, with the given
+ -- defining unit name and formal parameter.
function Build_Ordered_Parameters_List (Spec : Node_Id) return List_Id;
-- Return an ordered parameter list: unconstrained parameters are put
Decls : List_Id);
-- Add calling stubs to the declarative part
- procedure Add_Receiving_Stubs_To_Declarations
- (Pkg_Spec : Node_Id;
- Decls : List_Id);
- -- Add receiving stubs to the declarative part
-
function Could_Be_Asynchronous (Spec : Node_Id) return Boolean;
-- Return True if nothing prevents the program whose specification is
-- given to be asynchronous (i.e. no out parameter).
Etyp : Entity_Id) return Node_Id;
-- Similar to above, with Stream instead of Stream'Access
+ function Make_Selected_Component
+ (Loc : Source_Ptr;
+ Prefix : Entity_Id;
+ Selector_Name : Name_Id) return Node_Id;
+ -- Return a selected_component whose prefix denotes the given entity,
+ -- and with the given Selector_Name.
+
function Scope_Of_Spec (Spec : Node_Id) return Entity_Id;
-- Return the scope represented by a given spec
function Input_With_Tag_Check
(Loc : Source_Ptr;
Var_Type : Entity_Id;
- Stream : Entity_Id) return Node_Id;
+ Stream : Node_Id) return Node_Id;
-- Return a function with the following form:
-- function R return Var_Type is
-- begin
-- ancillary subprogram for Add_Stub_Type. If no RPC receiver declaration
-- is generated, then RPC_Receiver_Decl is set to Empty.
+ 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);
+ -- Make a subprogram body for an RPC receiver, with the given
+ -- defining unit name. On return:
+ -- - Subp_Id is the subprogram identifier from the PCS.
+ -- - Subp_Index is the index in the list of subprograms
+ -- used for dispatching (a variable of type Subprogram_Id).
+ -- - Stmts is the place where the request dispatching
+ -- statements can occur,
+ -- - Decl is the subprogram body declaration.
+
+ 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;
+ -- Build the receiving stub for a given subprogram. The subprogram
+ -- declaration is also built by this procedure, and the value returned
+ -- is a N_Subprogram_Body. If a parameter of type access to Stub_Type is
+ -- found in the specification, then its address is read from the stream
+ -- instead of the object itself and converted into an access to
+ -- class-wide type before doing the real call using any of the RACW type
+ -- pointing on the designated type.
+
+ procedure Specific_Add_Receiving_Stubs_To_Declarations
+ (Pkg_Spec : Node_Id;
+ Decls : List_Id);
+ -- Add receiving stubs to the declarative part
+
package GARLIC_Support is
-- Support for generating DSA code that uses the GARLIC PCS
Stub_Type_Decl : out Node_Id;
RPC_Receiver_Decl : out Node_Id);
- function Build_RPC_Receiver_Specification
- (RPC_Receiver : Entity_Id;
- Stream_Parameter : Entity_Id;
- Result_Parameter : Entity_Id) return Node_Id;
- -- Make a subprogram specification for an RPC receiver,
- -- with the given defining unit name and formal parameters.
+ 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_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;
Stub_Type_Decl : out Node_Id;
RPC_Receiver_Decl : out Node_Id);
- function Build_RPC_Receiver_Specification
- (RPC_Receiver : Entity_Id;
- Request_Parameter : Entity_Id) return Node_Id;
- -- Make a subprogram specification for an RPC receiver,
- -- with the given defining unit name and formal parameters.
+ 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_Receiving_Stubs_To_Declarations
+ (Pkg_Spec : Node_Id;
+ Decls : List_Id);
- pragma Warnings (Off);
- pragma Unreferenced (Build_RPC_Receiver_Specification);
- -- XXX PolyORB support is not completely included yet
- pragma Warnings (On);
+ 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;
+ -- Mark the method names for interface NamingContext as already used in
+ -- the overload table, so no clashes occur with user code (with the
+ -- PolyORB PCS, RCIs Implement The NamingContext interface to allow
+ -- their methods to be accessed as objects, for the implementation of
+ -- remote access-to-subprogram types).
package Helpers is
-- the CORBA terminology, and hence the conversion subprograms
-- are named To_Any and From_Any.
-
function Build_From_Any_Call
(Typ : Entity_Id;
N : Node_Id;
-- do the correct dispatching.
Overload_Counter_Table.Reset;
+ PolyORB_Support.Reserve_NamingContext_Methods;
Current_Declaration := First (Visible_Declarations (Pkg_Spec));
RPC_Receiver : Entity_Id;
RPC_Receiver_Statements : List_Id;
RPC_Receiver_Case_Alternatives : constant List_Id := New_List;
- RPC_Receiver_Stream : Entity_Id;
- RPC_Receiver_Result : Entity_Id;
+ RPC_Receiver_Request : Entity_Id;
RPC_Receiver_Subp_Id : Entity_Id;
+ RPC_Receiver_Subp_Index : Entity_Id;
Subp_Str : String_Id;
if not Is_RAS then
RPC_Receiver := Make_Defining_Identifier (Loc,
New_Internal_Name ('P'));
- Build_RPC_Receiver_Body (
+ Specific_Build_RPC_Receiver_Body (
RPC_Receiver => RPC_Receiver,
- Stream => RPC_Receiver_Stream,
- Result => RPC_Receiver_Result,
+ Request => RPC_Receiver_Request,
Subp_Id => RPC_Receiver_Subp_Id,
+ Subp_Index => RPC_Receiver_Subp_Index,
Stmts => RPC_Receiver_Statements,
Decl => RPC_Receiver_Decl);
end if;
Defining_Unit_Name (Current_Primitive_Spec)),
Asynchronous => Possibly_Asynchronous,
Dynamically_Asynchronous => Possibly_Asynchronous,
- Stub_Type => Stub_Elements.Stub_Type);
+ Stub_Type => Stub_Elements.Stub_Type,
+ RACW_Type => Stub_Elements.RACW_Type);
Append_To (Decls, Current_Primitive_Body);
-- Analyzing the body here would cause the Stub type to be
if not Is_RAS then
Current_Receiver_Body :=
- Build_Subprogram_Receiving_Stubs
+ Specific_Build_Subprogram_Receiving_Stubs
(Vis_Decl => Current_Primitive_Decl,
Asynchronous => Possibly_Asynchronous,
Dynamically_Asynchronous => Possibly_Asynchronous,
Name =>
New_Occurrence_Of (Current_Receiver, Loc),
Parameter_Associations => New_List (
- New_Occurrence_Of (RPC_Receiver_Stream, Loc),
- New_Occurrence_Of (RPC_Receiver_Result, Loc))))));
+ New_Occurrence_Of (RPC_Receiver_Request, Loc))))));
end if;
-- Increment the index of current primitive
Append_To (RPC_Receiver_Statements,
Make_Case_Statement (Loc,
Expression =>
- New_Occurrence_Of (RPC_Receiver_Subp_Id, Loc),
+ New_Occurrence_Of (RPC_Receiver_Subp_Index, Loc),
Alternatives => RPC_Receiver_Case_Alternatives));
+ Append_To (Decls, RPC_Receiver_Decl);
+
-- The RPC receiver body should not be the completion of the
-- declaration recorded in the stub structure, because then the
-- occurrences of the formal parameters within the body should
-- RPC receiver body acts as its own declaration, and the RPC
-- receiver declaration is completed by a renaming-as-body.
- Append_To (Decls, RPC_Receiver_Decl);
Append_To (Decls,
Make_Subprogram_Renaming_Declaration (Loc,
Specification =>
Unchecked_Convert_To (RACW_Type,
New_Occurrence_Of (RAS_Parameter, Loc)));
- RACW_Primitive_Name :=
- Make_Selected_Component (Loc,
- Prefix =>
- New_Occurrence_Of (Scope (RACW_Type), Loc),
- Selector_Name =>
- Make_Identifier (Loc, Name_Call));
+ RACW_Primitive_Name := Make_Selected_Component (Loc,
+ Prefix => Scope (RACW_Type),
+ Selector_Name => Name_Call);
end if;
if Is_Function then
Specific_Add_RAST_Features (Vis_Decl, RAS_Type, Decls);
end Add_RAST_Features;
- -----------------------------------------
- -- Add_Receiving_Stubs_To_Declarations --
- -----------------------------------------
-
- procedure Add_Receiving_Stubs_To_Declarations
- (Pkg_Spec : Node_Id;
- Decls : List_Id)
- is
- Loc : constant Source_Ptr := Sloc (Pkg_Spec);
-
- Stream_Parameter : Node_Id;
- Result_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;
- -- A Pkg_RPC_Receiver is built to decode the request
-
- Lookup_RAS_Info : constant Entity_Id :=
- Make_Defining_Identifier (Loc,
- Chars => New_Internal_Name ('R'));
- -- A remote subprogram is created to allow peers to look up
- -- RAS information using subprogram ids.
-
- Subp_Id : Node_Id;
- -- Subprogram_Id as read from the incoming stream
-
- 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;
-
- Dummy_Register_Name : Name_Id;
- Dummy_Register_Spec : Node_Id;
- Dummy_Register_Decl : Node_Id;
- Dummy_Register_Body : Node_Id;
-
- All_Calls_Remote_E : Entity_Id;
- Proxy_Object_Addr : Entity_Id;
-
- procedure Append_Stubs_To
- (RPC_Receiver_Cases : List_Id;
- Declaration : Node_Id;
- Stubs : Node_Id;
- Subprogram_Number : Int);
- -- Add one case to the specified RPC receiver case list
- -- associating Subprogram_Number with the subprogram declared
- -- by Declaration, for which we have receiving stubs in Stubs.
-
- ---------------------
- -- Append_Stubs_To --
- ---------------------
-
- procedure Append_Stubs_To
- (RPC_Receiver_Cases : List_Id;
- Declaration : Node_Id;
- Stubs : Node_Id;
- Subprogram_Number : Int)
- is
- Actuals : constant List_Id :=
- New_List (New_Occurrence_Of (Stream_Parameter, Loc));
- begin
- if Nkind (Specification (Declaration)) = N_Function_Specification
- or else not
- Is_Asynchronous (Defining_Entity (Specification (Declaration)))
- then
- -- An asynchronous procedure does not want an output parameter
- -- since no result and no exception will ever be returned.
-
- Append_To (Actuals,
- New_Occurrence_Of (Result_Parameter, Loc));
- end if;
-
- 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 =>
- Actuals))));
- end Append_Stubs_To;
-
- -- Start of processing for Add_Receiving_Stubs_To_Declarations
-
- begin
- -- Building receiving stubs consist in several operations:
-
- -- - a package RPC receiver must be built. This subprogram
- -- will get a Subprogram_Id from the incoming stream
- -- and will dispatch the call to the right subprogram
-
- -- - a receiving stub for any subprogram visible in the package
- -- spec. This stub will read all the parameters from the stream,
- -- and put the result as well as the exception occurrence in the
- -- output stream
-
- -- - a dummy package with an empty spec and a body made of an
- -- elaboration part, whose job is to register the receiving
- -- part of this RCI package on the name server. This is done
- -- by calling System.Partition_Interface.Register_Receiving_Stub
-
- Build_RPC_Receiver_Body (
- RPC_Receiver => Pkg_RPC_Receiver,
- Stream => Stream_Parameter,
- Result => Result_Parameter,
- Subp_Id => Subp_Id,
- Stmts => Pkg_RPC_Receiver_Statements,
- Decl => Pkg_RPC_Receiver_Body);
-
- -- A null subp_id denotes a call through a RAS, in which case the
- -- next Uint_64 element in the stream is the address of the local
- -- proxy object, from which we can retrieve the actual subprogram id.
-
- 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 (
- New_Occurrence_Of (Stream_Parameter, Loc))))),
- Selector_Name =>
- Make_Identifier (Loc, Name_Subp_Id))))));
-
- -- Build a subprogram for RAS information lookups
-
- 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,
- Declaration =>
- Current_Declaration,
- Stubs =>
- Current_Stubs,
- Subprogram_Number => 1);
-
- -- For each subprogram, the receiving stub will be built and a
- -- case statement will be made on the Subprogram_Id to dispatch
- -- to the right subprogram.
-
- 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);
- -- While specifically processing Current_Declaration, use its
- -- Sloc as the location of all generated nodes.
-
- 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));
-
- -- Build receiving stub
-
- 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);
-
- -- Build RAS proxy
-
- Add_RAS_Proxy_And_Analyze (Decls,
- Vis_Decl =>
- Current_Declaration,
- All_Calls_Remote_E =>
- All_Calls_Remote_E,
- Proxy_Object_Addr =>
- Proxy_Object_Addr);
-
- -- Compute distribution identifier
-
- Assign_Subprogram_Identifier (
- Subp_Def,
- Current_Subprogram_Number,
- Subp_Val);
-
- -- Add subprogram descriptor (RCI_Subp_Info) to the
- -- subprograms table for this receiver. The aggregate
- -- below must be kept consistent with the declaration
- -- of type RCI_Subp_Info in System.Partition_Interface.
-
- 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,
- Declaration =>
- Current_Declaration,
- Stubs =>
- Current_Stubs,
- Subprogram_Number =>
- Current_Subprogram_Number);
- end;
-
- Current_Subprogram_Number := Current_Subprogram_Number + 1;
- end if;
-
- Next (Current_Declaration);
- end loop;
-
- -- If we receive an invalid Subprogram_Id, it is best to do nothing
- -- rather than raising an exception since we do not want someone
- -- to crash a remote partition by sending invalid subprogram ids.
- -- This is consistent with the other parts of the case statement
- -- since even in presence of incorrect parameters in the stream,
- -- every exception will be caught and (if the subprogram is not an
- -- APC) put into the result stream and sent away.
-
- 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));
-
- -- Construction of the dummy package used to register the package
- -- receiving stubs on the nameserver.
-
- Dummy_Register_Name := New_Internal_Name ('P');
-
- Dummy_Register_Spec :=
- Make_Package_Specification (Loc,
- Defining_Unit_Name =>
- Make_Defining_Identifier (Loc, Dummy_Register_Name),
- Visible_Declarations => No_List,
- End_Label => Empty);
-
- Dummy_Register_Decl :=
- Make_Package_Declaration (Loc,
- Specification => Dummy_Register_Spec);
-
- Append_To (Decls, Dummy_Register_Decl);
- Analyze (Dummy_Register_Decl);
-
- Get_Library_Unit_Name_String (Pkg_Spec);
- Append_To (Register_Pkg_Actuals,
- -- Name
- Make_String_Literal (Loc,
- Strval => String_From_Name_Buffer));
-
- Append_To (Register_Pkg_Actuals,
- -- Receiver
- Make_Attribute_Reference (Loc,
- Prefix =>
- New_Occurrence_Of (Pkg_RPC_Receiver, Loc),
- Attribute_Name =>
- Name_Unrestricted_Access));
-
- Append_To (Register_Pkg_Actuals,
- -- Version
- Make_Attribute_Reference (Loc,
- Prefix =>
- New_Occurrence_Of (Defining_Entity (Pkg_Spec), Loc),
- Attribute_Name =>
- Name_Version));
-
- Append_To (Register_Pkg_Actuals,
- -- Subp_Info
- Make_Attribute_Reference (Loc,
- Prefix =>
- New_Occurrence_Of (Subp_Info_Array, Loc),
- Attribute_Name =>
- Name_Address));
-
- Append_To (Register_Pkg_Actuals,
- -- Subp_Info_Len
- Make_Attribute_Reference (Loc,
- Prefix =>
- New_Occurrence_Of (Subp_Info_Array, Loc),
- Attribute_Name =>
- Name_Length));
-
- Dummy_Register_Body :=
- Make_Package_Body (Loc,
- Defining_Unit_Name =>
- Make_Defining_Identifier (Loc, Dummy_Register_Name),
- Declarations => No_List,
-
- Handled_Statement_Sequence =>
- Make_Handled_Sequence_Of_Statements (Loc,
- Statements => New_List (
- Make_Procedure_Call_Statement (Loc,
- Name =>
- New_Occurrence_Of (RTE (RE_Register_Receiving_Stub), Loc),
-
- Parameter_Associations => Register_Pkg_Actuals))));
-
- Append_To (Decls, Dummy_Register_Body);
- Analyze (Dummy_Register_Body);
- end Add_Receiving_Stubs_To_Declarations;
-
-------------------
-- Add_Stub_Type --
-------------------
Analyze (Reg);
end Build_Passive_Partition_Stub;
+ --------------------------------------
+ -- Build_RPC_Receiver_Specification --
+ --------------------------------------
+
+ 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;
+
----------------------------------------
-- Build_Remote_Subprogram_Proxy_Type --
----------------------------------------
Component_Items => New_List (
Make_Component_Declaration (Loc,
- Make_Defining_Identifier (Loc,
- Name_All_Calls_Remote),
- Make_Component_Definition (Loc,
- Subtype_Indication =>
- New_Occurrence_Of (Standard_Boolean, Loc)),
- ACR_Expression),
+ 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,
- Make_Defining_Identifier (Loc,
- Name_Receiver),
- Make_Component_Definition (Loc,
- Subtype_Indication =>
- New_Occurrence_Of (RTE (RE_Address), Loc)),
- New_Occurrence_Of (RTE (RE_Null_Address), 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,
- Make_Defining_Identifier (Loc,
- Name_Subp_Id),
- Make_Component_Definition (Loc,
- Subtype_Indication =>
- New_Occurrence_Of (RTE (RE_Subprogram_Id), 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;
- -----------------------------
- -- Build_RPC_Receiver_Body --
- -----------------------------
-
- procedure Build_RPC_Receiver_Body
- (RPC_Receiver : Entity_Id;
- Stream : out Entity_Id;
- Result : out Entity_Id;
- Subp_Id : 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
- Stream := Make_Defining_Identifier (Loc, Name_S);
- Result := Make_Defining_Identifier (Loc, Name_R);
-
- RPC_Receiver_Spec :=
- GARLIC_Support.Build_RPC_Receiver_Specification
- (RPC_Receiver => RPC_Receiver,
- Stream_Parameter => Stream,
- Result_Parameter => Result);
-
- Subp_Id := Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
-
- -- Subp_Id may not be a constant, because in the case of the RPC
- -- receiver for an RCI package, when a call is received from a RAS
- -- dereference, it will be assigned during subsequent processing.
-
- 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 (
- New_Occurrence_Of (Stream, Loc)))));
-
- 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;
-
------------------------------------
-- Build_Subprogram_Calling_Stubs --
------------------------------------
pragma Assert (No (Stub_Type) or else Present (Controlling_Parameter));
if Dynamically_Asynchronous then
- Asynchronous_Expr :=
- Make_Selected_Component (Loc,
- Prefix =>
- New_Occurrence_Of (Controlling_Parameter, Loc),
- Selector_Name =>
- Make_Identifier (Loc, Name_Asynchronous));
+ Asynchronous_Expr := Make_Selected_Component (Loc,
+ Prefix => Controlling_Parameter,
+ Selector_Name => Name_Asynchronous);
end if;
Specific_Build_General_Calling_Stubs
return Make_Integer_Literal (Loc, Get_Subprogram_Id (E));
end Build_Subprogram_Id;
- --------------------------------------
- -- Build_Subprogram_Receiving_Stubs --
- --------------------------------------
+ ------------------------
+ -- Copy_Specification --
+ ------------------------
- function Build_Subprogram_Receiving_Stubs
- (Vis_Decl : Node_Id;
- Asynchronous : Boolean;
- Dynamically_Asynchronous : Boolean := False;
- Stub_Type : Entity_Id := Empty;
- RACW_Type : Entity_Id := Empty;
- Parent_Primitive : Entity_Id := Empty) return Node_Id
+ function 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
- Loc : constant Source_Ptr := Sloc (Vis_Decl);
-
- Stream_Parameter : Node_Id;
- Result_Parameter : Node_Id;
- -- See explanations of these in Build_Subprogram_Calling_Stubs
-
- Decls : constant List_Id := New_List;
- -- All the parameters will get declared before calling the real
- -- subprograms. Also the out parameters will be declared.
-
- Statements : constant List_Id := New_List;
-
- Extra_Formal_Statements : constant List_Id := New_List;
- -- Statements concerning extra formal parameters
-
- After_Statements : constant List_Id := New_List;
- -- Statements to be executed after the subprogram call
-
- Inner_Decls : List_Id := No_List;
- -- In case of a function, the inner declarations are needed since
- -- the result may be unconstrained.
-
- Excep_Handlers : List_Id := No_List;
- Excep_Choice : Entity_Id;
- Excep_Code : List_Id;
-
- Parameter_List : constant List_Id := New_List;
- -- List of parameters to be passed to the subprogram
-
- Current_Parameter : Node_Id;
-
- Ordered_Parameters_List : constant List_Id :=
- Build_Ordered_Parameters_List
- (Specification (Vis_Decl));
-
- Subp_Spec : Node_Id;
- -- Subprogram specification
-
- Called_Subprogram : Node_Id;
- -- The subprogram to call
-
- 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;
-
- Stream_Parameter :=
- Make_Defining_Identifier (Loc, New_Internal_Name ('S'));
-
- if Dynamically_Asynchronous then
- Dynamic_Async :=
- Make_Defining_Identifier (Loc, New_Internal_Name ('S'));
- else
- Dynamic_Async := Empty;
- end if;
-
- if not Asynchronous or else Dynamically_Asynchronous then
- Result_Parameter :=
- Make_Defining_Identifier (Loc, New_Internal_Name ('S'));
-
- -- The first statement after the subprogram call is a statement to
- -- writes a Null_Occurrence into the result stream.
-
- Null_Raise_Statement :=
- Make_Attribute_Reference (Loc,
- Prefix =>
- New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc),
- Attribute_Name => Name_Write,
- Expressions => New_List (
- New_Occurrence_Of (Result_Parameter, Loc),
- New_Occurrence_Of (RTE (RE_Null_Occurrence), Loc)));
-
- if Dynamically_Asynchronous then
- Null_Raise_Statement :=
- Make_Implicit_If_Statement (Vis_Decl,
- Condition =>
- Make_Op_Not (Loc, New_Occurrence_Of (Dynamic_Async, Loc)),
- Then_Statements => New_List (Null_Raise_Statement));
- end if;
-
- Append_To (After_Statements, Null_Raise_Statement);
-
- else
- Result_Parameter := Empty;
- end if;
-
- -- Loop through every parameter and get its value from the stream. If
- -- the parameter is unconstrained, then the parameter is read using
- -- 'Input at the point of declaration.
-
- Current_Parameter := First (Ordered_Parameters_List);
- while Present (Current_Parameter) loop
- declare
- Etyp : Entity_Id;
- RACW_Controlling : Boolean;
- Constrained : Boolean;
- Object : Entity_Id;
- Expr : Node_Id := Empty;
-
- begin
- Object := Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
- Set_Ekind (Object, E_Variable);
-
- RACW_Controlling :=
- Is_RACW_Controlling_Formal (Current_Parameter, Stub_Type);
-
- if RACW_Controlling then
-
- -- We have a controlling formal parameter. Read its address
- -- rather than a real object. The address is in Unsigned_64
- -- form.
-
- 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 RACW_Controlling
- then
- -- If an input parameter is contrained, then its reading is
- -- deferred until the beginning of the subprogram body. If
- -- it is unconstrained, then an expression is built for
- -- the object declaration and the variable is set using
- -- 'Input instead of 'Read.
-
- if Constrained and then not RACW_Controlling then
- Append_To (Statements,
- Make_Attribute_Reference (Loc,
- Prefix => New_Occurrence_Of (Etyp, Loc),
- Attribute_Name => Name_Read,
- Expressions => New_List (
- New_Occurrence_Of (Stream_Parameter, Loc),
- New_Occurrence_Of (Object, Loc))));
-
- else
- Expr := Input_With_Tag_Check (Loc,
- Var_Type => Etyp,
- Stream => Stream_Parameter);
- Append_To (Decls, Expr);
- Expr := Make_Function_Call (Loc,
- New_Occurrence_Of (Defining_Unit_Name
- (Specification (Expr)), Loc));
- end if;
- end if;
-
- -- If we do not have to output the current parameter, then
- -- it can well be flagged as constant. This may allow further
- -- optimizations done by the back end.
-
- 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));
-
- -- An out parameter may be written back using a 'Write
- -- attribute instead of a 'Output because it has been
- -- constrained by the parameter given to the caller. Note that
- -- out controlling arguments in the case of a RACW are not put
- -- back in the stream because the pointer on them has not
- -- changed.
-
- if Out_Present (Current_Parameter)
- and then
- Etype (Parameter_Type (Current_Parameter)) /= Stub_Type
- then
- Append_To (After_Statements,
- Make_Attribute_Reference (Loc,
- Prefix => New_Occurrence_Of (Etyp, Loc),
- Attribute_Name => Name_Write,
- Expressions => New_List (
- New_Occurrence_Of (Result_Parameter, Loc),
- New_Occurrence_Of (Object, Loc))));
- end if;
-
- if
- Is_RACW_Controlling_Formal (Current_Parameter, Stub_Type)
- then
- if Nkind (Parameter_Type (Current_Parameter)) /=
- N_Access_Definition
- then
- Append_To (Parameter_List,
- Make_Parameter_Association (Loc,
- Selector_Name =>
- New_Occurrence_Of (
- Defining_Identifier (Current_Parameter), Loc),
- Explicit_Actual_Parameter =>
- Make_Explicit_Dereference (Loc,
- Unchecked_Convert_To (RACW_Type,
- OK_Convert_To (RTE (RE_Address),
- New_Occurrence_Of (Object, Loc))))));
-
- else
- Append_To (Parameter_List,
- Make_Parameter_Association (Loc,
- Selector_Name =>
- New_Occurrence_Of (
- Defining_Identifier (Current_Parameter), Loc),
- Explicit_Actual_Parameter =>
- Unchecked_Convert_To (RACW_Type,
- OK_Convert_To (RTE (RE_Address),
- New_Occurrence_Of (Object, Loc)))));
- end if;
-
- else
- Append_To (Parameter_List,
- Make_Parameter_Association (Loc,
- Selector_Name =>
- New_Occurrence_Of (
- Defining_Identifier (Current_Parameter), Loc),
- Explicit_Actual_Parameter =>
- New_Occurrence_Of (Object, Loc)));
- end if;
-
- -- If the current parameter needs an extra formal, then read it
- -- from the stream and set the corresponding semantic field in
- -- the variable. If the kind of the parameter identifier is
- -- E_Void, then this is a compiler generated parameter that
- -- doesn't need an extra constrained status.
-
- -- The case of Extra_Accessibility should also be handled ???
-
- if Nkind (Parameter_Type (Current_Parameter)) /=
- N_Access_Definition
- and then
- Ekind (Defining_Identifier (Current_Parameter)) /= E_Void
- and then
- Present (Extra_Constrained
- (Defining_Identifier (Current_Parameter)))
- then
- declare
- Extra_Parameter : constant Entity_Id :=
- Extra_Constrained
- (Defining_Identifier
- (Current_Parameter));
-
- Formal_Entity : constant Entity_Id :=
- Make_Defining_Identifier
- (Loc, Chars (Extra_Parameter));
-
- Formal_Type : constant Entity_Id :=
- Etype (Extra_Parameter);
-
- begin
- Append_To (Decls,
- Make_Object_Declaration (Loc,
- Defining_Identifier => Formal_Entity,
- Object_Definition =>
- New_Occurrence_Of (Formal_Type, Loc)));
-
- Append_To (Extra_Formal_Statements,
- Make_Attribute_Reference (Loc,
- Prefix => New_Occurrence_Of (Formal_Type, Loc),
- Attribute_Name => Name_Read,
- Expressions => New_List (
- New_Occurrence_Of (Stream_Parameter, Loc),
- New_Occurrence_Of (Formal_Entity, Loc))));
- Set_Extra_Constrained (Object, Formal_Entity);
- end;
- end if;
- end;
-
- Next (Current_Parameter);
- end loop;
-
- -- Append the formal statements list at the end of regular statements
-
- Append_List_To (Statements, Extra_Formal_Statements);
-
- if Nkind (Specification (Vis_Decl)) = N_Function_Specification then
-
- -- The remote subprogram is a function. We build an inner block to
- -- be able to hold a potentially unconstrained result in a variable.
-
- declare
- Etyp : constant Entity_Id :=
- Etype (Subtype_Mark (Specification (Vis_Decl)));
- Result : constant Node_Id :=
- Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
-
- begin
- Inner_Decls := New_List (
- Make_Object_Declaration (Loc,
- Defining_Identifier => Result,
- Constant_Present => True,
- Object_Definition => New_Occurrence_Of (Etyp, Loc),
- Expression =>
- Make_Function_Call (Loc,
- Name => Called_Subprogram,
- Parameter_Associations => Parameter_List)));
-
- Append_To (After_Statements,
- Make_Attribute_Reference (Loc,
- Prefix => New_Occurrence_Of (Etyp, Loc),
- Attribute_Name => Name_Output,
- Expressions => New_List (
- New_Occurrence_Of (Result_Parameter, Loc),
- New_Occurrence_Of (Result, Loc))));
- end;
-
- Append_To (Statements,
- Make_Block_Statement (Loc,
- Declarations => Inner_Decls,
- Handled_Statement_Sequence =>
- Make_Handled_Sequence_Of_Statements (Loc,
- Statements => After_Statements)));
-
- else
- -- The remote subprogram is a procedure. We do not need any inner
- -- block in this case.
-
- if Dynamically_Asynchronous then
- Append_To (Decls,
- Make_Object_Declaration (Loc,
- Defining_Identifier => Dynamic_Async,
- Object_Definition =>
- New_Occurrence_Of (Standard_Boolean, Loc)));
-
- Append_To (Statements,
- Make_Attribute_Reference (Loc,
- Prefix => New_Occurrence_Of (Standard_Boolean, Loc),
- Attribute_Name => Name_Read,
- Expressions => New_List (
- New_Occurrence_Of (Stream_Parameter, Loc),
- New_Occurrence_Of (Dynamic_Async, Loc))));
- end if;
-
- Append_To (Statements,
- Make_Procedure_Call_Statement (Loc,
- Name => Called_Subprogram,
- Parameter_Associations => Parameter_List));
-
- Append_List_To (Statements, After_Statements);
- end if;
-
- if Asynchronous and then not Dynamically_Asynchronous then
-
- -- An asynchronous procedure does not want a Result parameter. Also
- -- put an exception handler with an others clause that does nothing.
-
- Subp_Spec :=
- Make_Procedure_Specification (Loc,
- Defining_Unit_Name =>
- Make_Defining_Identifier (Loc, New_Internal_Name ('F')),
- Parameter_Specifications => New_List (
- Make_Parameter_Specification (Loc,
- Defining_Identifier => Stream_Parameter,
- Parameter_Type =>
- Make_Access_Definition (Loc,
- Subtype_Mark =>
- New_Occurrence_Of (RTE (RE_Params_Stream_Type), Loc)))));
-
- Excep_Handlers := New_List (
- Make_Exception_Handler (Loc,
- Exception_Choices =>
- New_List (Make_Others_Choice (Loc)),
- Statements => New_List (
- Make_Null_Statement (Loc))));
-
- else
- -- In the other cases, if an exception is raised, then the
- -- exception occurrence is copied into the output stream and
- -- no other output parameter is written.
-
- Excep_Choice :=
- Make_Defining_Identifier (Loc, New_Internal_Name ('E'));
-
- Excep_Code := New_List (
- Make_Attribute_Reference (Loc,
- Prefix =>
- New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc),
- Attribute_Name => Name_Write,
- Expressions => New_List (
- New_Occurrence_Of (Result_Parameter, Loc),
- New_Occurrence_Of (Excep_Choice, Loc))));
-
- if Dynamically_Asynchronous then
- Excep_Code := New_List (
- Make_Implicit_If_Statement (Vis_Decl,
- Condition => Make_Op_Not (Loc,
- New_Occurrence_Of (Dynamic_Async, Loc)),
- Then_Statements => Excep_Code));
- end if;
-
- Excep_Handlers := New_List (
- Make_Exception_Handler (Loc,
- Choice_Parameter => Excep_Choice,
- Exception_Choices => New_List (Make_Others_Choice (Loc)),
- Statements => Excep_Code));
-
- Subp_Spec :=
- Make_Procedure_Specification (Loc,
- Defining_Unit_Name =>
- Make_Defining_Identifier (Loc, New_Internal_Name ('F')),
-
- Parameter_Specifications => New_List (
- Make_Parameter_Specification (Loc,
- Defining_Identifier => Stream_Parameter,
- Parameter_Type =>
- Make_Access_Definition (Loc,
- Subtype_Mark =>
- New_Occurrence_Of (RTE (RE_Params_Stream_Type), Loc))),
-
- Make_Parameter_Specification (Loc,
- Defining_Identifier => Result_Parameter,
- Parameter_Type =>
- Make_Access_Definition (Loc,
- Subtype_Mark =>
- New_Occurrence_Of (RTE (RE_Params_Stream_Type), Loc)))));
- end if;
-
- return
- Make_Subprogram_Body (Loc,
- Specification => Subp_Spec,
- Declarations => Decls,
- Handled_Statement_Sequence =>
- Make_Handled_Sequence_Of_Statements (Loc,
- Statements => Statements,
- Exception_Handlers => Excep_Handlers));
- end Build_Subprogram_Receiving_Stubs;
-
- ------------------------
- -- Copy_Specification --
- ------------------------
-
- 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;
+ Parameters : List_Id := No_List;
Current_Parameter : Node_Id;
Current_Identifier : Entity_Id;
Expression =>
New_Copy_Tree (Expression (Current_Parameter))));
+ -- For a regular formal parameter (that needs to be marshalled
+ -- in the context of remote calls), set the Etype now, because
+ -- marshalling processing might need it.
+
+ if Is_Entity_Name (Current_Type) then
+ Set_Etype (New_Identifier, Entity (Current_Type));
+
+ -- Current_Type is an access definition, special processing
+ -- (not requiring etype) will occur for marshalling.
+
+ else
+ null;
+ end if;
+
Next (Current_Parameter);
end loop;
end if;
Spec := Specification (Unit_Node);
Decls := Visible_Declarations (Spec);
New_Scope (Scope_Of_Spec (Spec));
- Add_Receiving_Stubs_To_Declarations (Spec, Decls);
+ Specific_Add_Receiving_Stubs_To_Declarations (Spec, Decls);
else
Spec :=
Decls := Declarations (Unit_Node);
New_Scope (Scope_Of_Spec (Unit_Node));
Temp := New_List;
- Add_Receiving_Stubs_To_Declarations (Spec, Temp);
+ Specific_Add_Receiving_Stubs_To_Declarations (Spec, Temp);
Insert_List_Before (First (Decls), Temp);
end if;
Make_Assignment_Statement (Loc,
Name => Make_Selected_Component (Loc,
- Prefix => New_Occurrence_Of (Stubbed_Result, Loc),
- Selector_Name => Make_Identifier (Loc, Name_Origin)),
+ Prefix => Stubbed_Result,
+ Selector_Name => Name_Origin),
Expression =>
New_Occurrence_Of (Source_Partition, Loc)),
Make_Assignment_Statement (Loc,
Name => Make_Selected_Component (Loc,
- Prefix => New_Occurrence_Of (Stubbed_Result, Loc),
- Selector_Name => Make_Identifier (Loc, Name_Receiver)),
+ Prefix => Stubbed_Result,
+ Selector_Name => Name_Receiver),
Expression =>
New_Occurrence_Of (Source_Receiver, Loc)),
Make_Assignment_Statement (Loc,
Name => Make_Selected_Component (Loc,
- Prefix => New_Occurrence_Of (Stubbed_Result, Loc),
- Selector_Name => Make_Identifier (Loc, Name_Addr)),
+ 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 => New_Occurrence_Of (Stubbed_Result, Loc),
- Selector_Name => Make_Identifier (Loc, Name_Asynchronous)),
+ Prefix => Stubbed_Result,
+ Selector_Name => Name_Asynchronous),
Expression =>
New_Occurrence_Of (Asynchronous_Flag, Loc)));
Make_Assignment_Statement (Loc,
Name =>
Make_Selected_Component (Loc,
- Prefix => New_Occurrence_Of (Stub_Ptr, Loc),
- Selector_Name => Make_Identifier (Loc, Field_Name)),
+ Prefix => Stub_Ptr,
+ Selector_Name => Field_Name),
Expression => Value);
end Set_Field;
Add_RAS_Access_TSS (Vis_Decl);
end Add_RAST_Features;
- ---------------------------------
- -- Build_General_Calling_Stubs --
- ---------------------------------
+ -----------------------------------------
+ -- 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)
+ 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;
+ -- A Pkg_RPC_Receiver is built to decode the request
+
+ Lookup_RAS_Info : constant Entity_Id :=
+ Make_Defining_Identifier (Loc,
+ Chars => New_Internal_Name ('R'));
+ -- A remote subprogram is created to allow peers to look up
+ -- RAS information using subprogram ids.
+
+ Subp_Id : Entity_Id;
+ Subp_Index : Entity_Id;
+ -- Subprogram_Id as read from the incoming stream
+
+ 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);
+ -- Add one case to the specified RPC receiver case list
+ -- associating Subprogram_Number with the subprogram declared
+ -- by Declaration, for which we have receiving stubs in Stubs.
+
+ ---------------------
+ -- Append_Stubs_To --
+ ---------------------
+
+ 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;
+
+ -- Start of processing for Add_Receiving_Stubs_To_Declarations
+
+ begin
+ -- Building receiving stubs consist in several operations:
+
+ -- - a package RPC receiver must be built. This subprogram
+ -- will get a Subprogram_Id from the incoming stream
+ -- and will dispatch the call to the right subprogram
+
+ -- - a receiving stub for any subprogram visible in the package
+ -- spec. This stub will read all the parameters from the stream,
+ -- and put the result as well as the exception occurrence in the
+ -- output stream
+
+ -- - a dummy package with an empty spec and a body made of an
+ -- elaboration part, whose job is to register the receiving
+ -- part of this RCI package on the name server. This is done
+ -- by calling System.Partition_Interface.Register_Receiving_Stub
+
+ 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);
+
+ -- A null subp_id denotes a call through a RAS, in which case the
+ -- next Uint_64 element in the stream is the address of the local
+ -- proxy object, from which we can retrieve the actual subprogram id.
+
+ 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))))));
+
+ -- Build a subprogram for RAS information lookups
+
+ 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);
+
+ -- For each subprogram, the receiving stub will be built and a
+ -- case statement will be made on the Subprogram_Id to dispatch
+ -- to the right subprogram.
+
+ 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);
+ -- While specifically processing Current_Declaration, use
+ -- its Sloc as the location of all generated nodes.
+
+ 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));
+
+ -- Build receiving stub
+
+ 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);
+
+ -- Build RAS proxy
+
+ Add_RAS_Proxy_And_Analyze (Decls,
+ Vis_Decl =>
+ Current_Declaration,
+ All_Calls_Remote_E =>
+ All_Calls_Remote_E,
+ Proxy_Object_Addr =>
+ Proxy_Object_Addr);
+
+ -- Compute distribution identifier
+
+ Assign_Subprogram_Identifier (
+ Subp_Def,
+ Current_Subprogram_Number,
+ Subp_Val);
+
+ -- Add subprogram descriptor (RCI_Subp_Info) to the
+ -- subprograms table for this receiver. The aggregate
+ -- below must be kept consistent with the declaration
+ -- of type RCI_Subp_Info in System.Partition_Interface.
+
+ 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;
+
+ -- If we receive an invalid Subprogram_Id, it is best to do nothing
+ -- rather than raising an exception since we do not want someone
+ -- to crash a remote partition by sending invalid subprogram ids.
+ -- This is consistent with the other parts of the case statement
+ -- since even in presence of incorrect parameters in the stream,
+ -- every exception will be caught and (if the subprogram is not an
+ -- APC) put into the result stream and sent away.
+
+ 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,
+ -- Name
+ Make_String_Literal (Loc,
+ Strval => String_From_Name_Buffer));
+
+ Append_To (Register_Pkg_Actuals,
+ -- Receiver
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ New_Occurrence_Of (Pkg_RPC_Receiver, Loc),
+ Attribute_Name =>
+ Name_Unrestricted_Access));
+
+ Append_To (Register_Pkg_Actuals,
+ -- Version
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ New_Occurrence_Of (Defining_Entity (Pkg_Spec), Loc),
+ Attribute_Name =>
+ Name_Version));
+
+ Append_To (Register_Pkg_Actuals,
+ -- Subp_Info
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ New_Occurrence_Of (Subp_Info_Array, Loc),
+ Attribute_Name =>
+ Name_Address));
+
+ Append_To (Register_Pkg_Actuals,
+ -- Subp_Info_Len
+ 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;
+
+ ---------------------------------
+ -- Build_General_Calling_Stubs --
+ ---------------------------------
+
+ 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);
Object =>
Make_Selected_Component (Loc,
Prefix =>
- New_Occurrence_Of (
- Defining_Identifier (Current_Parameter), Loc),
- Selector_Name =>
- Make_Identifier (Loc, Name_Addr)),
+ Defining_Identifier (Current_Parameter),
+ Selector_Name => Name_Addr),
Etyp => RTE (RE_Unsigned_64)));
else
end if;
end Build_General_Calling_Stubs;
+ -----------------------------
+ -- Build_RPC_Receiver_Body --
+ -----------------------------
+
+ 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;
+
+ -- Subp_Id may not be a constant, because in the case of the RPC
+ -- receiver for an RCI package, when a call is received from a RAS
+ -- dereference, it will be assigned during subsequent processing.
+
+ 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;
+
-----------------------
-- Build_Stub_Target --
-----------------------
Expression =>
Make_Selected_Component (Loc,
- Prefix =>
- New_Occurrence_Of (Controlling_Parameter, Loc),
- Selector_Name =>
- Make_Identifier (Loc, Name_Origin))));
+ Prefix => Controlling_Parameter,
+ Selector_Name => Name_Origin)));
Target_Info.RPC_Receiver :=
Make_Selected_Component (Loc,
- Prefix =>
- New_Occurrence_Of (Controlling_Parameter, Loc),
- Selector_Name =>
- Make_Identifier (Loc, Name_Receiver));
+ Prefix => Controlling_Parameter,
+ Selector_Name => Name_Receiver);
else
Append_To (Decls,
RPC_Receiver_Decl := Empty;
else
declare
- RPC_Receiver_Stream : constant Entity_Id :=
- Make_Defining_Identifier (Loc, Name_S);
- RPC_Receiver_Result : constant Entity_Id :=
- Make_Defining_Identifier (Loc, Name_R);
+ 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')),
- Stream_Parameter => RPC_Receiver_Stream,
- Result_Parameter => RPC_Receiver_Result));
+ RPC_Receiver => Make_Defining_Identifier (Loc,
+ New_Internal_Name ('R')),
+ Request_Parameter => RPC_Receiver_Request));
end;
end if;
end Build_Stub_Type;
--------------------------------------
- -- Build_RPC_Receiver_Specification --
+ -- Build_Subprogram_Receiving_Stubs --
--------------------------------------
- function Build_RPC_Receiver_Specification
- (RPC_Receiver : Entity_Id;
- Stream_Parameter : Entity_Id;
- Result_Parameter : Entity_Id) return Node_Id
+ function Build_Subprogram_Receiving_Stubs
+ (Vis_Decl : Node_Id;
+ Asynchronous : Boolean;
+ Dynamically_Asynchronous : Boolean := False;
+ Stub_Type : Entity_Id := Empty;
+ RACW_Type : Entity_Id := Empty;
+ Parent_Primitive : Entity_Id := Empty) return Node_Id
is
- Loc : constant Source_Ptr := Sloc (RPC_Receiver);
+ Loc : constant Source_Ptr := Sloc (Vis_Decl);
- begin
- return
- Make_Procedure_Specification (Loc,
- Defining_Unit_Name => RPC_Receiver,
- Parameter_Specifications => New_List (
- Make_Parameter_Specification (Loc,
- Defining_Identifier => Stream_Parameter,
- Parameter_Type =>
- Make_Access_Definition (Loc,
- Subtype_Mark =>
- New_Occurrence_Of (RTE (RE_Params_Stream_Type), Loc))),
+ Request_Parameter : Node_Id;
+ -- ???
- Make_Parameter_Specification (Loc,
- Defining_Identifier => Result_Parameter,
- Parameter_Type =>
- Make_Access_Definition (Loc,
- Subtype_Mark =>
- New_Occurrence_Of
- (RTE (RE_Params_Stream_Type), Loc)))));
- end Build_RPC_Receiver_Specification;
+ Decls : constant List_Id := New_List;
+ -- All the parameters will get declared before calling the real
+ -- subprograms. Also the out parameters will be declared.
- ------------
- -- Result --
- ------------
+ Statements : constant List_Id := New_List;
- function Result return Node_Id is
- begin
- return Make_Identifier (Loc, Name_V);
- end Result;
+ Extra_Formal_Statements : constant List_Id := New_List;
+ -- Statements concerning extra formal parameters
- ----------------------
- -- Stream_Parameter --
- ----------------------
+ After_Statements : constant List_Id := New_List;
+ -- Statements to be executed after the subprogram call
- function Stream_Parameter return Node_Id is
- begin
- return Make_Identifier (Loc, Name_S);
- end Stream_Parameter;
+ Inner_Decls : List_Id := No_List;
+ -- In case of a function, the inner declarations are needed since
+ -- the result may be unconstrained.
- end GARLIC_Support;
+ Excep_Handlers : List_Id := No_List;
+ Excep_Choice : Entity_Id;
+ Excep_Code : List_Id;
- ------------------
- -- Get_PCS_Name --
- ------------------
+ Parameter_List : constant List_Id := New_List;
+ -- List of parameters to be passed to the subprogram
- 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;
+ Current_Parameter : Node_Id;
- -----------------------
- -- Get_Subprogram_Id --
- -----------------------
+ Ordered_Parameters_List : constant List_Id :=
+ Build_Ordered_Parameters_List
+ (Specification (Vis_Decl));
- function Get_Subprogram_Id (Def : Entity_Id) return String_Id is
- begin
- return Get_Subprogram_Ids (Def).Str_Identifier;
- end Get_Subprogram_Id;
+ Subp_Spec : Node_Id;
+ -- Subprogram specification
- -----------------------
- -- Get_Subprogram_Id --
- -----------------------
+ Called_Subprogram : Node_Id;
+ -- The subprogram to call
- function Get_Subprogram_Id (Def : Entity_Id) return Int is
- begin
- return Get_Subprogram_Ids (Def).Int_Identifier;
- end Get_Subprogram_Id;
+ Null_Raise_Statement : Node_Id;
- ------------------------
- -- Get_Subprogram_Ids --
- ------------------------
+ Dynamic_Async : Entity_Id;
- function Get_Subprogram_Ids
- (Def : Entity_Id) return Subprogram_Identifiers
- is
- Result : Subprogram_Identifiers :=
- Subprogram_Identifier_Table.Get (Def);
+ 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;
- Current_Declaration : Node_Id;
- Current_Subp : Entity_Id;
- Current_Subp_Str : String_Id;
- Current_Subp_Number : Int := First_RCI_Subprogram_Id;
+ Request_Parameter :=
+ Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
- begin
- if Result.Str_Identifier = No_String then
+ if Dynamically_Asynchronous then
+ Dynamic_Async :=
+ Make_Defining_Identifier (Loc, New_Internal_Name ('S'));
+ else
+ Dynamic_Async := Empty;
+ end if;
- -- We are looking up this subprogram's identifier outside of the
- -- context of generating calling or receiving stubs. Hence we are
- -- processing an 'Access attribute_reference for an RCI subprogram,
- -- for the purpose of obtaining a RAS value.
+ if not Asynchronous or Dynamically_Asynchronous then
- pragma Assert
- (Is_Remote_Call_Interface (Scope (Def))
- and then
- (Nkind (Parent (Def)) = N_Procedure_Specification
+ -- The first statement after the subprogram call is a statement to
+ -- writes a Null_Occurrence into the result stream.
+
+ 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;
+
+ -- Loop through every parameter and get its value from the stream. If
+ -- the parameter is unconstrained, then the parameter is read using
+ -- 'Input at the point of declaration.
+
+ 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
+
+ -- We have a controlling formal parameter. Read its address
+ -- rather than a real object. The address is in Unsigned_64
+ -- form.
+
+ 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 an input parameter is contrained, then its reading is
+ -- deferred until the beginning of the subprogram body. If
+ -- it is unconstrained, then an expression is built for
+ -- the object declaration and the variable is set using
+ -- 'Input instead of 'Read.
+
+ 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;
+
+ -- If we do not have to output the current parameter, then it
+ -- can well be flagged as constant. This may allow further
+ -- optimizations done by the back end.
+
+ 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));
+
+ -- An out parameter may be written back using a 'Write
+ -- attribute instead of a 'Output because it has been
+ -- constrained by the parameter given to the caller. Note that
+ -- out controlling arguments in the case of a RACW are not put
+ -- back in the stream because the pointer on them has not
+ -- changed.
+
+ 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;
+
+ -- For RACW controlling formals, the Etyp of Object is always
+ -- an RACW, even if the parameter is not of an anonymous access
+ -- type. In such case, we need to dereference it at call time.
+
+ 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 the current parameter needs an extra formal, then read it
+ -- from the stream and set the corresponding semantic field in
+ -- the variable. If the kind of the parameter identifier is
+ -- E_Void, then this is a compiler generated parameter that
+ -- doesn't need an extra constrained status.
+
+ -- The case of Extra_Accessibility should also be handled ???
+
+ 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 the formal statements list at the end of regular statements
+
+ Append_List_To (Statements, Extra_Formal_Statements);
+
+ if Nkind (Specification (Vis_Decl)) = N_Function_Specification then
+
+ -- The remote subprogram is a function. We build an inner block to
+ -- be able to hold a potentially unconstrained result in a
+ -- variable.
+
+ 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
+ -- The remote subprogram is a procedure. We do not need any inner
+ -- block in this case.
+
+ 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
+
+ -- For an asynchronous procedure, add a null exception handler
+
+ Excep_Handlers := New_List (
+ Make_Exception_Handler (Loc,
+ Exception_Choices => New_List (Make_Others_Choice (Loc)),
+ Statements => New_List (Make_Null_Statement (Loc))));
+
+ else
+ -- In the other cases, if an exception is raised, then the
+ -- exception occurrence is copied into the output stream and
+ -- no other output parameter is written.
+
+ 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;
+
+ ------------
+ -- Result --
+ ------------
+
+ function Result return Node_Id is
+ begin
+ return Make_Identifier (Loc, Name_V);
+ end Result;
+
+ ----------------------
+ -- Stream_Parameter --
+ ----------------------
+
+ function Stream_Parameter return Node_Id is
+ begin
+ return Make_Identifier (Loc, Name_S);
+ end Stream_Parameter;
+
+ end GARLIC_Support;
+
+ -----------------------------
+ -- Make_Selected_Component --
+ -----------------------------
+
+ 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;
+
+ ------------------
+ -- Get_PCS_Name --
+ ------------------
+
+ 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;
+
+ -----------------------
+ -- Get_Subprogram_Id --
+ -----------------------
+
+ function Get_Subprogram_Id (Def : Entity_Id) return String_Id is
+ begin
+ return Get_Subprogram_Ids (Def).Str_Identifier;
+ end Get_Subprogram_Id;
+
+ -----------------------
+ -- 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;
+
+ ------------------------
+ -- Get_Subprogram_Ids --
+ ------------------------
+
+ 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
+
+ -- We are looking up this subprogram's identifier outside of the
+ -- context of generating calling or receiving stubs. Hence we are
+ -- processing an 'Access attribute_reference for an RCI subprogram,
+ -- for the purpose of obtaining a RAS value.
+
+ pragma Assert
+ (Is_Remote_Call_Interface (Scope (Def))
+ and then
+ (Nkind (Parent (Def)) = N_Procedure_Specification
or else
Nkind (Parent (Def)) = N_Function_Specification));
function Input_With_Tag_Check
(Loc : Source_Ptr;
Var_Type : Entity_Id;
- Stream : Entity_Id) return Node_Id
+ Stream : Node_Id) return Node_Id
is
begin
return
Prefix => New_Occurrence_Of (Var_Type, Loc),
Attribute_Name => Name_Input,
Expressions =>
- New_List (New_Occurrence_Of (Stream, Loc))))))));
+ New_List (Stream)))))));
end Input_With_Tag_Check;
--------------------------------
Stub_Statements := New_List (
Make_Assignment_Statement (Loc,
Name => Make_Selected_Component (Loc,
- Prefix => New_Occurrence_Of (Stubbed_Result, Loc),
- Selector_Name => Make_Identifier (Loc, Name_Target)),
+ Prefix => Stubbed_Result,
+ Selector_Name => Name_Target),
Expression =>
Make_Function_Call (Loc,
Name =>
New_Occurrence_Of (RTE (RE_Inc_Usage), Loc),
Parameter_Associations => New_List (
Make_Selected_Component (Loc,
- Prefix => New_Occurrence_Of (Stubbed_Result, Loc),
- Selector_Name => Make_Identifier (Loc, Name_Target)))),
+ Prefix => Stubbed_Result,
+ Selector_Name => Name_Target))),
Make_Assignment_Statement (Loc,
Name => Make_Selected_Component (Loc,
- Prefix => New_Occurrence_Of (Stubbed_Result, Loc),
- Selector_Name => Make_Identifier (Loc, Name_Asynchronous)),
+ Prefix => Stubbed_Result,
+ Selector_Name => Name_Asynchronous),
Expression =>
New_Occurrence_Of (Asynchronous_Flag, Loc)));
New_Occurrence_Of (Any, Loc),
Make_Selected_Component (Loc,
Prefix =>
- New_Occurrence_Of (
Defining_Identifier (
- Stub_Elements.RPC_Receiver_Decl), Loc),
- Selector_Name =>
- Make_Identifier (Loc, Name_Obj_TypeCode)))),
+ Stub_Elements.RPC_Receiver_Decl),
+ Selector_Name => Name_Obj_TypeCode))),
Make_Return_Statement (Loc,
Expression =>
New_Occurrence_Of (Any, Loc)));
Expression =>
Make_Selected_Component (Loc,
Prefix =>
- New_Occurrence_Of (
Defining_Identifier (
- Stub_Elements.RPC_Receiver_Decl), Loc),
- Selector_Name =>
- Make_Identifier (Loc, Name_Obj_TypeCode))))));
+ Stub_Elements.RPC_Receiver_Decl),
+ Selector_Name => Name_Obj_TypeCode)))));
Insert_After (Declaration_Node (RACW_Type), Func_Decl);
Append_To (Declarations, Func_Body);
Make_Assignment_Statement (Loc,
Name =>
Make_Selected_Component (Loc,
- Prefix => New_Occurrence_Of (Stub_Ptr, Loc),
- Selector_Name => Make_Identifier (Loc, Field_Name)),
+ Prefix => Stub_Ptr,
+ Selector_Name => Field_Name),
Expression => Value);
end Set_Field;
New_Occurrence_Of (RTE (RE_Inc_Usage), Loc),
Parameter_Associations => New_List (
Make_Selected_Component (Loc,
- Prefix => New_Occurrence_Of (Stub_Ptr, Loc),
- Selector_Name => Make_Identifier (Loc, Name_Target)))),
+ Prefix => Stub_Ptr,
+ Selector_Name => Name_Target))),
-- E.4.1(9) A remote call is asynchronous if it is a call to
-- a procedure, or a call through a value of an access-to-procedure
Chars => New_Internal_Name ('R'));
RACW_Parameter : constant Node_Id :=
Make_Selected_Component (Loc,
- Prefix =>
- New_Occurrence_Of (RAS_Parameter, Loc),
- Selector_Name =>
- Make_Identifier (Loc, Name_Ras));
+ Prefix => RAS_Parameter,
+ Selector_Name => Name_Ras);
begin
-- Object declarations
Set_Renaming_TSS (RAS_Type, Fnam, Name_uTypeCode);
end Add_RAS_TypeCode;
- ---------------------------------
- -- Build_General_Calling_Stubs --
- ---------------------------------
+ -----------------------------------------
+ -- Add_Receiving_Stubs_To_Declarations --
+ -----------------------------------------
+
+ 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;
+ -- A Pkg_RPC_Receiver is built to decode the request
+
+ Request : Node_Id;
+ -- Request object received from neutral layer
+
+ Subp_Id : Entity_Id;
+ -- Subprogram identifier as received from the neutral
+ -- distribution core.
+
+ Subp_Index : Entity_Id;
+ -- Internal index as determined by matching either the
+ -- method name from the request structure, or the local
+ -- subprogram address (in case of a RAS).
+
+ 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'));
+ -- Address of a local subprogram designated by a
+ -- reference corresponding to a RAS.
+
+ 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);
+ -- Add one case to the specified RPC receiver case list associating
+ -- Subprogram_Number with the subprogram declared by Declaration, for
+ -- which we have receiving stubs in Stubs. Subp_Number is an internal
+ -- subprogram index. Subp_Dist_Name is the string used to call the
+ -- subprogram by name, and Subp_Dist_Addr is the address of the proxy
+ -- object, used in the context of calls through remote
+ -- access-to-subprogram types.
+
+ ---------------------
+ -- Append_Stubs_To --
+ ---------------------
+
+ 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;
+
+ -- Start of processing for Add_Receiving_Stubs_To_Declarations
+
+ begin
+ -- Building receiving stubs consist in several operations:
+
+ -- - a package RPC receiver must be built. This subprogram
+ -- will get a Subprogram_Id from the incoming stream
+ -- and will dispatch the call to the right subprogram
+
+ -- - a receiving stub for any subprogram visible in the package
+ -- spec. This stub will read all the parameters from the stream,
+ -- and put the result as well as the exception occurrence in the
+ -- output stream
+
+ -- - a dummy package with an empty spec and a body made of an
+ -- elaboration part, whose job is to register the receiving
+ -- part of this RCI package on the name server. This is done
+ -- by calling System.Partition_Interface.Register_Receiving_Stub
+
+ 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);
+
+ -- Extract local address information from the target reference:
+ -- if non-null, that means that this is a reference that denotes
+ -- one particular operation, and hence that the operation name
+ -- must not be taken into account for dispatching.
+
+ 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))));
+
+ -- Determine whether the reference that was used to make
+ -- the call was the base RCI reference (in which case
+ -- Local_Address is 0, and the method identifier from the
+ -- request must be used to determine which subprogram is
+ -- called) or a reference identifying one particular subprogram
+ -- (in which case Local_Address is the address of that
+ -- subprogram, and the method name from the request is
+ -- ignored).
+ -- In each case, cascaded elsifs are used to determine the
+ -- proper subprogram index. Using hash tables might be
+ -- more efficient.
+
+ 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))));
+
+ -- For each subprogram, the receiving stub will be built and a
+ -- case statement will be made on the Subprogram_Id to dispatch
+ -- to the right subprogram.
+
+ 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);
+ -- While specifically processing Current_Declaration, use
+ -- its Sloc as the location of all generated nodes.
+
+ 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));
+
+ -- Build receiving stub
+
+ 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);
+
+ -- Build RAS proxy
+
+ Add_RAS_Proxy_And_Analyze (Decls,
+ Vis_Decl =>
+ Current_Declaration,
+ All_Calls_Remote_E =>
+ All_Calls_Remote_E,
+ Proxy_Object_Addr =>
+ Proxy_Object_Addr);
+
+ -- Compute distribution identifier
+
+ 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));
+
+ -- Add subprogram descriptor (RCI_Subp_Info) to the
+ -- subprograms table for this receiver. The aggregate
+ -- below must be kept consistent with the declaration
+ -- of type RCI_Subp_Info in System.Partition_Interface.
+
+ 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;
+
+ -- If we receive an invalid Subprogram_Id, it is best to do nothing
+ -- rather than raising an exception since we do not want someone
+ -- to crash a remote partition by sending invalid subprogram ids.
+ -- This is consistent with the other parts of the case statement
+ -- since even in presence of incorrect parameters in the stream,
+ -- every exception will be caught and (if the subprogram is not an
+ -- APC) put into the result stream and sent away.
+
+ 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,
+ -- Name
+ Make_String_Literal (Loc,
+ Strval => String_From_Name_Buffer));
+
+ Append_To (Register_Pkg_Actuals,
+ -- Version
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ New_Occurrence_Of
+ (Defining_Entity (Pkg_Spec), Loc),
+ Attribute_Name =>
+ Name_Version));
+
+ Append_To (Register_Pkg_Actuals,
+ -- Handler
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ New_Occurrence_Of (Pkg_RPC_Receiver, Loc),
+ Attribute_Name => Name_Access));
+
+ Append_To (Register_Pkg_Actuals,
+ -- Receiver
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ New_Occurrence_Of (
+ Defining_Identifier (
+ Pkg_RPC_Receiver_Object), Loc),
+ Attribute_Name =>
+ Name_Access));
+
+ Append_To (Register_Pkg_Actuals,
+ -- Subp_Info
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ New_Occurrence_Of (Subp_Info_Array, Loc),
+ Attribute_Name =>
+ Name_Address));
+
+ Append_To (Register_Pkg_Actuals,
+ -- Subp_Info_Len
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ New_Occurrence_Of (Subp_Info_Array, Loc),
+ Attribute_Name =>
+ Name_Length));
+
+ Append_To (Register_Pkg_Actuals,
+ -- Is_All_Calls_Remote
+ 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;
+
+ ---------------------------------
+ -- Build_General_Calling_Stubs --
+ ---------------------------------
procedure Build_General_Calling_Stubs
(Decls : List_Id;
-- to the remote package
Request : Node_Id;
- -- The request object constructed by these stubs.
+ -- The request object constructed by these stubs
Result : Node_Id;
-- Name of the result named value (in non-APC cases) which get the
-- in out or out parameter values).
Etyp : Entity_Id;
- -- The type of the formal parameter being processed.
+ -- The type of the formal parameter being processed
Is_Controlling_Formal : Boolean;
Is_First_Controlling_Formal : Boolean;
Next (Current_Parameter);
end loop;
- -- Append the formal statements list to the statements
-
- Append_List_To (Statements, Extra_Formal_Statements);
-
- Append_To (Statements,
+ -- Append the formal statements list to the statements
+
+ 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);
+ -- The expression node Asynchronous will be used to build
+ -- an 'if' statement at the end of Build_General_Calling_Stubs:
+ -- we need to make a copy here.
+ 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
+
+ -- Reraise an exception occurrence from the completed request.
+ -- If the exception occurrence is empty, this is a no-op.
+
+ 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
+
+ -- If this is a function call, then read the value and
+ -- return it.
+
+ 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;
+
+ -----------------------
+ -- Build_Stub_Target --
+ -----------------------
+
+ 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)))));
+ -- Controlling_Parameter has the same components
+ -- as System.Partition_Interface.RACW_Stub_Type.
+
+ 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;
+
+ ---------------------
+ -- Build_Stub_Type --
+ ---------------------
+
+ 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;
+
+ -----------------------------
+ -- Build_RPC_Receiver_Body --
+ -----------------------------
+
+ 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;
+
+ --------------------------------------
+ -- Build_Subprogram_Receiving_Stubs --
+ --------------------------------------
+
+ function Build_Subprogram_Receiving_Stubs
+ (Vis_Decl : Node_Id;
+ Asynchronous : Boolean;
+ Dynamically_Asynchronous : Boolean := False;
+ Stub_Type : Entity_Id := Empty;
+ RACW_Type : Entity_Id := Empty;
+ Parent_Primitive : Entity_Id := Empty) return Node_Id
+ is
+ Loc : constant Source_Ptr := Sloc (Vis_Decl);
+
+ Request_Parameter : Node_Id;
+ -- ???
+
+ Outer_Decls : constant List_Id := New_List;
+ -- At the outermost level, an NVList and Any's are
+ -- declared for all parameters. The Dynamic_Async
+ -- flag also needs to be declared there to be visible
+ -- from the exception handling code.
+
+ Outer_Statements : constant List_Id := New_List;
+ -- Statements that occur prior to the declaration of the actual
+ -- parameter variables.
+
+ Decls : constant List_Id := New_List;
+ -- All the parameters will get declared before calling the real
+ -- subprograms. Also the out parameters will be declared.
+ -- At this level, parameters may be unconstrained.
+
+ Statements : constant List_Id := New_List;
+
+ Extra_Formal_Statements : constant List_Id := New_List;
+ -- Statements concerning extra formal parameters
+
+ After_Statements : constant List_Id := New_List;
+ -- Statements to be executed after the subprogram call
+
+ Inner_Decls : List_Id := No_List;
+ -- In case of a function, the inner declarations are needed since
+ -- the result may be unconstrained.
+
+ Excep_Handlers : List_Id := No_List;
+
+ Parameter_List : constant List_Id := New_List;
+ -- List of parameters to be passed to the subprogram
+
+ 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;
+ -- Name of the named values list used to retrieve parameters
+
+ Subp_Spec : Node_Id;
+ -- Subprogram specification
+
+ Called_Subprogram : Node_Id;
+ -- The subprogram to call
+
+ 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);
+
+ -- Loop through every parameter and get its value from the stream. If
+ -- the parameter is unconstrained, then the parameter is read using
+ -- 'Input at the point of declaration.
+
+ 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
+
+ -- Controlling formals in distributed object primitive
+ -- operations are handled specially:
+ -- - the first controlling formal is used as the
+ -- target of the call;
+ -- - the remaining controlling formals are transmitted
+ -- as RACWs.
+
+ 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
+
+ -- Special case: obtain the first controlling
+ -- formal from the target of the remote call,
+ -- instead of the argument list.
+
+ 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
+ -- If an input parameter is contrained, then its reading is
+ -- deferred until the beginning of the subprogram body. If
+ -- it is unconstrained, then an expression is built for
+ -- the object declaration and the variable is set using
+ -- 'Input instead of 'Read.
+
+ 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;
+ -- Expr will be used to initialize (and constrain)
+ -- the parameter when it is declared.
+ end if;
+
+ end if;
+
+ -- If we do not have to output the current parameter, then
+ -- it can well be flagged as constant. This may allow further
+ -- optimizations done by the back end.
+
+ 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);
+
+ -- An out parameter may be written back using a 'Write
+ -- attribute instead of a 'Output because it has been
+ -- constrained by the parameter given to the caller. Note that
+ -- out controlling arguments in the case of a RACW are not put
+ -- back in the stream because the pointer on them has not
+ -- changed.
+
+ 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;
+
+ -- For RACW controlling formals, the Etyp of Object is always
+ -- an RACW, even if the parameter is not of an anonymous access
+ -- type. In such case, we need to dereference it at call time.
+
+ 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 the current parameter needs an extra formal, then read it
+ -- from the stream and set the corresponding semantic field in
+ -- the variable. If the kind of the parameter identifier is
+ -- E_Void, then this is a compiler generated parameter that
+ -- doesn't need an extra constrained status.
+
+ -- The case of Extra_Accessibility should also be handled ???
+
+ 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_Create), Loc),
+ New_Occurrence_Of (RTE (RE_Request_Arguments), 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))));
+ New_Occurrence_Of (Request_Parameter, Loc),
+ New_Occurrence_Of (Arguments, Loc))));
- Append_To (Parameter_Associations (Last (Statements)),
- New_Occurrence_Of (Request, Loc));
+ Append_List_To (Statements, Extra_Formal_Statements);
- 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);
- -- The expression node Asynchronous will be used to build
- -- an 'if' statement at the end of Build_General_Calling_Stubs:
- -- we need to make a copy here.
- end if;
+ if Nkind (Specification (Vis_Decl)) = N_Function_Specification then
- 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)));
+ -- The remote subprogram is a function. We build an inner block to
+ -- be able to hold a potentially unconstrained result in a
+ -- variable.
- 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))));
+ 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)));
- Non_Asynchronous_Statements := New_List (Make_Null_Statement (Loc));
- Asynchronous_Statements := New_List (Make_Null_Statement (Loc));
+ 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))));
+ -- A DSA function does not have out or inout arguments
+ end;
- if not Is_Known_Asynchronous then
+ Append_To (Statements,
+ Make_Block_Statement (Loc,
+ Declarations => Inner_Decls,
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements => After_Statements)));
- -- Reraise an exception occurrence from the completed request.
- -- If the exception occurrence is empty, this is a no-op.
+ else
+ -- The remote subprogram is a procedure. We do not need any inner
+ -- block in this case. No specific processing is required here for
+ -- the dynamically asynchronous case: the indication of whether
+ -- call is asynchronous or not is managed by the Sync_Scope
+ -- attibute of the request, and is handled entirely in the
+ -- protocol layer.
- Append_To (Non_Asynchronous_Statements,
+ Append_To (After_Statements,
Make_Procedure_Call_Statement (Loc,
- Name =>
- New_Occurrence_Of (RTE (RE_Request_Raise_Occurrence), Loc),
+ Name =>
+ New_Occurrence_Of (RTE (RE_Request_Set_Out), Loc),
Parameter_Associations => New_List (
- New_Occurrence_Of (Request, Loc))));
-
- if Is_Function then
+ New_Occurrence_Of (Request_Parameter, Loc))));
- -- If this is a function call, then read the value and
- -- return it.
+ Append_To (Statements,
+ Make_Procedure_Call_Statement (Loc,
+ Name => Called_Subprogram,
+ Parameter_Associations => Parameter_List));
- 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 =>
- New_Occurrence_Of (Result, Loc),
- Selector_Name =>
- Make_Identifier (Loc, Name_Argument)),
- Decls))));
- end if;
+ Append_List_To (Statements, After_Statements);
end if;
- Append_List_To (Non_Asynchronous_Statements,
- After_Statements);
-
- if Is_Known_Asynchronous then
- Append_List_To (Statements, Asynchronous_Statements);
+ Subp_Spec :=
+ Make_Procedure_Specification (Loc,
+ Defining_Unit_Name =>
+ Make_Defining_Identifier (Loc, New_Internal_Name ('F')),
- elsif Is_Known_Non_Asynchronous then
- Append_List_To (Statements, Non_Asynchronous_Statements);
+ Parameter_Specifications => New_List (
+ Make_Parameter_Specification (Loc,
+ Defining_Identifier => Request_Parameter,
+ Parameter_Type =>
+ New_Occurrence_Of (RTE (RE_Request_Access), Loc))));
- 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;
+ -- An exception raised during the execution of an incoming
+ -- remote subprogram call and that needs to be sent back
+ -- to the caller is propagated by the receiving stubs, and
+ -- will be handled by the caller (the distribution runtime).
- -----------------------
- -- Build_Stub_Target --
- -----------------------
+ if Asynchronous and then not Dynamically_Asynchronous then
- 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 =>
- New_Occurrence_Of (Controlling_Parameter, Loc),
- Selector_Name =>
- Make_Identifier (Loc, Name_Target))))));
- -- Controlling_Parameter has the same components
- -- as System.Partition_Interface.RACW_Stub_Type.
+ -- For an asynchronous procedure, add a null exception handler
- Target_Info.Object := New_Occurrence_Of (Target_Reference, Loc);
+ Excep_Handlers := New_List (
+ Make_Exception_Handler (Loc,
+ Exception_Choices => New_List (Make_Others_Choice (Loc)),
+ Statements => New_List (Make_Null_Statement (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;
-
- ---------------------
- -- Build_Stub_Type --
- ---------------------
-
- 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;
+ -- In the other cases, if an exception is raised, then the
+ -- exception occurrence is propagated.
- --------------------------------------
- -- Build_RPC_Receiver_Specification --
- --------------------------------------
+ null;
+ end if;
- function Build_RPC_Receiver_Specification
- (RPC_Receiver : Entity_Id;
- Request_Parameter : Entity_Id) return Node_Id
- is
- Loc : constant Source_Ptr := Sloc (RPC_Receiver);
+ Append_To (Outer_Statements,
+ Make_Block_Statement (Loc,
+ Declarations =>
+ Decls,
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements => Statements)));
- 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;
-
+ 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;
-------------
-- Helpers --
-------------
Make_Case_Statement (Loc,
Expression =>
Make_Selected_Component (Loc,
- Prefix =>
- New_Occurrence_Of (Rec, Loc),
+ Prefix => Rec,
Selector_Name =>
- New_Occurrence_Of (
- Entity (Name (Field)), Loc)),
+ Chars (Name (Field))),
Alternatives =>
Alt_List));
-- A regular component
Field_Ref := Make_Selected_Component (Loc,
- Prefix => New_Occurrence_Of (Rec, Loc),
+ Prefix => New_Occurrence_Of (Rec, Loc),
Selector_Name => New_Occurrence_Of (Field, Loc));
Set_Etype (Field_Ref, Etype (Field));
is
Nod : constant Node_Id :=
Make_Selected_Component (Loc,
- Prefix =>
- New_Occurrence_Of (Rec, Loc),
+ Prefix => Rec,
Selector_Name =>
- New_Occurrence_Of (
- Entity (Name (Field)), Loc));
+ Chars (Name (Field)));
begin
Set_Etype (Nod, Name (Field));
return Nod;
Expression =>
Build_To_Any_Call (
Make_Selected_Component (Loc,
- Prefix =>
- New_Occurrence_Of (Expr_Parameter, Loc),
- Selector_Name =>
- New_Occurrence_Of (Disc, Loc)),
+ Prefix => Expr_Parameter,
+ Selector_Name => Chars (Disc)),
Decls)));
Counter := Counter + 1;
Next_Discriminant (Disc);
end if;
end Make_Stream_Procedure_Function_Name;
end Helpers;
+
+ -----------------------------------
+ -- Reserve_NamingContext_Methods --
+ -----------------------------------
+
+ 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;
-------------------------------
end case;
end Specific_Add_RAST_Features;
+ --------------------------------------------------
+ -- Specific_Add_Receiving_Stubs_To_Declarations --
+ --------------------------------------------------
+
+ 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;
+
------------------------------------------
-- Specific_Build_General_Calling_Stubs --
------------------------------------------
end case;
end Specific_Build_General_Calling_Stubs;
+ --------------------------------------
+ -- Specific_Build_RPC_Receiver_Body --
+ --------------------------------------
+
+ 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;
+
--------------------------------
-- Specific_Build_Stub_Target --
--------------------------------
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;
+
--------------------------
-- Underlying_RACW_Type --
--------------------------
OSDN Git Service
