with Stringt; use Stringt;
with Tbuild; use Tbuild;
with Uintp; use Uintp;
-with Uname; use Uname;
package body Exp_Dist is
-- an RCI package can thus identify calls received through remote
-- access-to-subprogram dereferences by the fact that they have a
-- (primitive) subprogram id of 0, and 1 is used for the internal
- -- RAS information lookup operation.
+ -- RAS information lookup operation. (This is for the Garlic code
+ -- generation, where subprograms are identified by numbers; in the
+ -- PolyORB version, they are identified by name, with a numeric suffix
+ -- for homonyms.)
+
+ type Hash_Index is range 0 .. 50;
-----------------------
-- Local subprograms --
-----------------------
+ function Hash (F : Entity_Id) return Hash_Index;
+ -- DSA expansion associates stubs to distributed object types using
+ -- a hash table on entity ids.
+
+ function Hash (F : Name_Id) return Hash_Index;
+ -- The generation of subprogram identifiers requires an overload counter
+ -- to be associated with each remote subprogram names. These counters
+ -- are maintained in a hash table on name ids.
+
+ type Subprogram_Identifiers is record
+ Str_Identifier : String_Id;
+ Int_Identifier : Int;
+ end record;
+
+ package Subprogram_Identifier_Table is
+ new Simple_HTable (Header_Num => Hash_Index,
+ Element => Subprogram_Identifiers,
+ No_Element => (No_String, 0),
+ Key => Entity_Id,
+ Hash => Hash,
+ Equal => "=");
+ -- Mapping between a remote subprogram and the corresponding
+ -- subprogram identifiers.
+
+ package Overload_Counter_Table is
+ new Simple_HTable (Header_Num => Hash_Index,
+ Element => Int,
+ No_Element => 0,
+ Key => Name_Id,
+ Hash => Hash,
+ Equal => "=");
+ -- Mapping between a subprogram name and an integer that
+ -- counts the number of defining subprogram names with that
+ -- Name_Id encountered so far in a given context (an interface).
+
+ function Get_Subprogram_Ids (Def : Entity_Id) return Subprogram_Identifiers;
+ function Get_Subprogram_Id (Def : Entity_Id) return String_Id;
+ function Get_Subprogram_Id (Def : Entity_Id) return Int;
+ -- Given a subprogram defined in a RCI package, get its distribution
+ -- subprogram identifiers (the distribution identifiers are a unique
+ -- subprogram number, and the non-qualified subprogram name, in the
+ -- casing used for the subprogram declaration; if the name is overloaded,
+ -- a double underscore and a serial number are appended.
+ --
+ -- The integer identifier is used to perform remote calls with GARLIC;
+ -- the string identifier is used in the case of PolyORB.
+ --
+ -- Although the PolyORB DSA receiving stubs will make a caseless comparison
+ -- when receiving a call, the calling stubs will create requests with the
+ -- exact casing of the defining unit name of the called subprogram, so as
+ -- to allow calls to subprograms on distributed nodes that do distinguish
+ -- between casings.
+ --
+ -- NOTE: Another design would be to allow a representation clause on
+ -- subprogram specs: for Subp'Distribution_Identifier use "fooBar";
+
+ pragma Warnings (Off, Get_Subprogram_Id);
+ -- One homonym only is unreferenced (specific to the GARLIC version)
+
+ function Get_PCS_Name return PCS_Names;
+ -- Return the name of a literal of type
+ -- System.Partition_Interface.DSA_Implementation_Type
+ -- indicating what PCS is currently in use.
+
+ procedure Add_RAS_Dereference_TSS (N : Node_Id);
+ -- Add a subprogram body for RAS Dereference TSS
+
procedure Add_RAS_Proxy_And_Analyze
- (Decls : List_Id;
- Vis_Decl : Node_Id;
- All_Calls_Remote_E : Entity_Id;
+ (Decls : List_Id;
+ Vis_Decl : Node_Id;
+ All_Calls_Remote_E : Entity_Id;
Proxy_Object_Addr : out Entity_Id);
-- Add the proxy type necessary to call the subprogram declared
-- by Vis_Decl through a remote access to subprogram type.
-- ACR_Expression is use as the initialization value for
-- the All_Calls_Remote component.
- function Get_Subprogram_Id (E : Entity_Id) return Int;
- -- Given a subprogram defined in a RCI package, get its subprogram id
- -- which will be used for remote calls.
-
function Build_Get_Unique_RP_Call
(Loc : Source_Ptr;
Pointer : Entity_Id;
Stub_Type : Entity_Id) return List_Id;
- -- Build a call to Get_Unique_Remote_Pointer (Pointer),
- -- followed by a tag fixup (Get_Unique_Remote_Pointer may have
- -- changed Pointer'Tag to RACW_Stub_Type'Tag, while the desired
- -- tag is that of Stub_Type).
+ -- Build a call to Get_Unique_Remote_Pointer (Pointer), followed by a
+ -- tag fixup (Get_Unique_Remote_Pointer may have changed Pointer'Tag to
+ -- RACW_Stub_Type'Tag, while the desired tag is that of Stub_Type).
procedure Build_General_Calling_Stubs
(Decls : List_Id;
function Build_Subprogram_Calling_Stubs
(Vis_Decl : Node_Id;
- Subp_Id : Int;
+ Subp_Id : Node_Id;
Asynchronous : Boolean;
Dynamically_Asynchronous : Boolean := False;
Stub_Type : Entity_Id := Empty;
-- Make a subprogram specification for an RPC receiver,
-- with the given defining unit name and formal parameters.
+ 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_Ordered_Parameters_List (Spec : Node_Id) return List_Id;
-- Return an ordered parameter list: unconstrained parameters are put
-- at the beginning of the list and constrained ones are put after. If
Decls : List_Id);
-- Add receiving stubs to the declarative part
- procedure Add_RAS_Dereference_TSS (N : Node_Id);
- -- Add a subprogram body for RAS Dereference TSS
-
- procedure Add_RAS_Access_TSS (N : Node_Id);
- -- Add a subprogram body for RAS Access TSS
-
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).
- procedure Get_Pkg_Name_String (Decl_Node : Node_Id);
- -- Retrieve the fully expanded name of the library unit declared by decl
- -- into the name buffer.
-
function Pack_Entity_Into_Stream_Access
(Loc : Source_Ptr;
Stream : Node_Id;
function Scope_Of_Spec (Spec : Node_Id) return Entity_Id;
-- Return the scope represented by a given spec
+ procedure Set_Renaming_TSS
+ (Typ : Entity_Id;
+ Nam : Entity_Id;
+ TSS_Nam : Name_Id);
+ -- Create a renaming declaration of subprogram Nam,
+ -- and register it as a TSS for Typ with name TSS_Nam.
+
+ pragma Warnings (Off);
+ pragma Unreferenced (Set_Renaming_TSS);
+ -- This subprogram is for the PolyORB implementation
+ pragma Warnings (On);
+
function Need_Extra_Constrained (Parameter : Node_Id) return Boolean;
-- Return True if the current parameter needs an extra formal to reflect
-- its constrained status.
type Stub_Structure is record
Stub_Type : Entity_Id;
Stub_Type_Access : Entity_Id;
- Object_RPC_Receiver : Entity_Id;
- RPC_Receiver_Stream : Entity_Id;
- RPC_Receiver_Result : Entity_Id;
+ RPC_Receiver_Decl : Node_Id;
RACW_Type : Entity_Id;
end record;
-- This structure is necessary because of the two phases analysis of
-- designated type. RACW_Type is any of the RACW types pointing on this
-- designated type, it is used here to save an anonymous type creation
-- for each primitive operation.
+ --
+ -- For a RACW that implements a RAS, no object RPC receiver is generated.
+ -- Instead, RPC_Receiver_Decl is the declaration after which the
+ -- RPC receiver would have been inserted.
Empty_Stub_Structure : constant Stub_Structure :=
- (Empty, Empty, Empty, Empty, Empty, Empty);
-
- type Hash_Index is range 0 .. 50;
- function Hash (F : Entity_Id) return Hash_Index;
+ (Empty, Empty, Empty, Empty);
package Stubs_Table is
new Simple_HTable (Header_Num => Hash_Index,
Decls : List_Id;
Stub_Type : out Entity_Id;
Stub_Type_Access : out Entity_Id;
- Object_RPC_Receiver : out Entity_Id;
+ RPC_Receiver_Decl : out Node_Id;
Existing : out Boolean);
-- Add the declaration of the stub type, the access to stub type and the
-- object RPC receiver at the end of Decls. If these already exist,
-- Declare a boolean constant associated with RACW_Type whose value
-- indicates at run time whether a pragma Asynchronous applies to it.
- procedure Add_RACW_Read_Attribute
- (RACW_Type : Entity_Id;
- Stub_Type : Entity_Id;
- Stub_Type_Access : Entity_Id;
- Declarations : List_Id);
- -- Add Read attribute in Decls for the RACW type. The Read attribute
- -- is added right after the RACW_Type declaration while the body is
- -- inserted after Declarations.
-
- procedure Add_RACW_Write_Attribute
- (RACW_Type : Entity_Id;
- Stub_Type : Entity_Id;
- Stub_Type_Access : Entity_Id;
- Object_RPC_Receiver : Entity_Id;
- Declarations : List_Id);
- -- Same thing for the Write attribute
-
- procedure Add_RACW_Read_Write_Attributes
- (RACW_Type : Entity_Id;
- Stub_Type : Entity_Id;
- Stub_Type_Access : Entity_Id;
- Object_RPC_Receiver : Entity_Id;
- Declarations : List_Id);
- -- Add Read and Write attributes declarations and bodies for a given
- -- RACW type. The declarations are added just after the declaration
- -- of the RACW type itself, while the bodies are inserted at the end
- -- of Decls.
+ procedure Assign_Subprogram_Identifier
+ (Def : Entity_Id;
+ Spn : Int;
+ Id : out String_Id);
+ -- Determine the distribution subprogram identifier to
+ -- be used for remote subprogram Def, return it in Id and
+ -- store it in a hash table for later retrieval by
+ -- Get_Subprogram_Id. Spn is the subprogram number.
function RCI_Package_Locator
(Loc : Source_Ptr;
-- Exception_Message (E));
-- end R;
+ --------------------------------------------
+ -- Hooks for PCS-specific code generation --
+ --------------------------------------------
+
+ -- Part of the code generation circuitry for distribution needs to be
+ -- tailored for each implementation of the PCS. For each routine that
+ -- needs to be specialized, a Specific_<routine> wrapper is created,
+ -- which calls the corresponding <routine> in package
+ -- <pcs_implementation>_Support.
+
+ procedure Specific_Add_RACW_Features
+ (RACW_Type : Entity_Id;
+ Desig : Entity_Id;
+ Stub_Type : Entity_Id;
+ Stub_Type_Access : Entity_Id;
+ RPC_Receiver_Decl : Node_Id;
+ Declarations : List_Id);
+ -- Add declaration for TSSs for a given RACW type. The declarations are
+ -- added just after the declaration of the RACW type itself, while the
+ -- bodies are inserted at the end of Decls. Runtime-specific ancillary
+ -- subprogram for Add_RACW_Features.
+
+ procedure Specific_Add_RAST_Features
+ (Vis_Decl : Node_Id;
+ RAS_Type : Entity_Id;
+ Decls : List_Id);
+ -- Add declaration for TSSs for a given RAS type. The declarations are
+ -- added just after the declaration of the RAS type itself, while the
+ -- bodies are inserted at the end of Decls. PCS-specific ancillary
+ -- subprogram for Add_RAST_Features.
+
+ package GARLIC_Support is
+
+ -- Support for generating DSA code that uses the GARLIC PCS
+
+ procedure Add_RACW_Features
+ (RACW_Type : Entity_Id;
+ Stub_Type : Entity_Id;
+ Stub_Type_Access : Entity_Id;
+ RPC_Receiver_Decl : Node_Id;
+ Declarations : List_Id);
+
+ procedure Add_RAST_Features
+ (Vis_Decl : Node_Id;
+ RAS_Type : Entity_Id;
+ Decls : List_Id);
+
+ end GARLIC_Support;
+
+ package PolyORB_Support is
+
+ -- Support for generating DSA code that uses the PolyORB PCS
+
+ procedure Add_RACW_Features
+ (RACW_Type : Entity_Id;
+ Desig : Entity_Id;
+ Stub_Type : Entity_Id;
+ Stub_Type_Access : Entity_Id;
+ RPC_Receiver_Decl : Node_Id;
+ Declarations : List_Id);
+
+ procedure Add_RAST_Features
+ (Vis_Decl : Node_Id;
+ RAS_Type : Entity_Id;
+ Decls : List_Id);
+
+ end PolyORB_Support;
+
------------------------------------
-- Local variables and structures --
------------------------------------
RCI_Cache : Node_Id;
+ -- Needs comments ???
Output_From_Constrained : constant array (Boolean) of Name_Id :=
(False => Name_Output,
Loc : constant Source_Ptr := Sloc (Pkg_Spec);
RCI_Instantiation : Node_Id;
Subp_Stubs : Node_Id;
+ Subp_Str : String_Id;
begin
-- The first thing added is an instantiation of the generic package
- -- System.Partition_interface.RCI_Locator with the name of this
+ -- System.Partition_Interface.RCI_Locator with the name of this
-- remote package. This will act as an interface with the name server
-- to determine the Partition_ID and the RPC_Receiver for the
-- receiver of this package.
-- do use the same mechanism and will thus assign the same Id and
-- do the correct dispatching.
+ Overload_Counter_Table.Reset;
+
Current_Declaration := First (Visible_Declarations (Pkg_Spec));
- while Current_Declaration /= Empty loop
+
+ while Present (Current_Declaration) loop
if Nkind (Current_Declaration) = N_Subprogram_Declaration
and then Comes_From_Source (Current_Declaration)
then
- pragma Assert (Current_Subprogram_Number =
- Get_Subprogram_Id (Defining_Unit_Name (Specification (
- Current_Declaration))));
+ Assign_Subprogram_Identifier (
+ Defining_Unit_Name (Specification (Current_Declaration)),
+ Current_Subprogram_Number,
+ Subp_Str);
Subp_Stubs :=
Build_Subprogram_Calling_Stubs (
Vis_Decl => Current_Declaration,
- Subp_Id => Current_Subprogram_Number,
+ Subp_Id =>
+ Build_Subprogram_Id (Loc,
+ Defining_Unit_Name (Specification (Current_Declaration))),
Asynchronous =>
Nkind (Specification (Current_Declaration)) =
N_Procedure_Specification
Stub_Type : Entity_Id;
Stub_Type_Access : Entity_Id;
- Object_RPC_Receiver : Entity_Id;
+ RPC_Receiver_Decl : Node_Id;
Existing : Boolean;
begin
Decls => Decls,
Stub_Type => Stub_Type,
Stub_Type_Access => Stub_Type_Access,
- Object_RPC_Receiver => Object_RPC_Receiver,
+ RPC_Receiver_Decl => RPC_Receiver_Decl,
Existing => Existing);
Add_RACW_Asynchronous_Flag
(Declarations => Decls,
RACW_Type => RACW_Type);
- Add_RACW_Read_Write_Attributes
+ Specific_Add_RACW_Features
(RACW_Type => RACW_Type,
+ Desig => Desig,
Stub_Type => Stub_Type,
Stub_Type_Access => Stub_Type_Access,
- Object_RPC_Receiver => Object_RPC_Receiver,
+ RPC_Receiver_Decl => RPC_Receiver_Decl,
Declarations => Decls);
if not Same_Scope and then not Existing then
Add_RACW_Primitive_Declarations_And_Bodies
(Designated_Type => Desig,
- Insertion_Node =>
- Parent (Declaration_Node (Object_RPC_Receiver)),
+ Insertion_Node => RPC_Receiver_Decl,
Decls => Decls);
else
Stubs_Table.Get (Designated_Type);
pragma Assert (Stub_Elements /= Empty_Stub_Structure);
+ Is_RAS : constant Boolean :=
+ not Comes_From_Source (Stub_Elements.RACW_Type);
Current_Insertion_Node : Node_Id := Insertion_Node;
- RPC_Receiver_Declarations : List_Id;
+ 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_Subp_Id : Entity_Id;
+ Subp_Str : String_Id;
+
Current_Primitive_Elmt : Elmt_Id;
Current_Primitive : Entity_Id;
Current_Primitive_Body : Node_Id;
return;
end if;
+ if not Is_RAS then
+ RPC_Receiver := Make_Defining_Identifier (Loc,
+ New_Internal_Name ('P'));
+ Build_RPC_Receiver_Body (
+ RPC_Receiver => RPC_Receiver,
+ Stream => RPC_Receiver_Stream,
+ Result => RPC_Receiver_Result,
+ Subp_Id => RPC_Receiver_Subp_Id,
+ Stmts => RPC_Receiver_Statements,
+ Decl => RPC_Receiver_Decl);
+ end if;
+
-- Build callers, receivers for every primitive operations and a RPC
-- receiver for this type.
if Present (Primitive_Operations (Designated_Type)) then
+ Overload_Counter_Table.Reset;
+
Current_Primitive_Elmt :=
First_Elmt (Primitive_Operations (Designated_Type));
while Current_Primitive_Elmt /= No_Elmt loop
Nkind (Current_Primitive_Spec) = N_Procedure_Specification
and then Could_Be_Asynchronous (Current_Primitive_Spec);
+ Assign_Subprogram_Identifier (
+ Defining_Unit_Name (Current_Primitive_Spec),
+ Current_Primitive_Number,
+ Subp_Str);
+
Current_Primitive_Body :=
Build_Subprogram_Calling_Stubs
(Vis_Decl => Current_Primitive_Decl,
- Subp_Id => Current_Primitive_Number,
+ Subp_Id =>
+ Build_Subprogram_Id (Loc,
+ Defining_Unit_Name (Current_Primitive_Spec)),
Asynchronous => Possibly_Asynchronous,
Dynamically_Asynchronous => Possibly_Asynchronous,
Stub_Type => Stub_Elements.Stub_Type);
-- Build the receiver stubs
- Current_Receiver_Body :=
- Build_Subprogram_Receiving_Stubs
- (Vis_Decl => Current_Primitive_Decl,
- Asynchronous => Possibly_Asynchronous,
- Dynamically_Asynchronous => Possibly_Asynchronous,
- Stub_Type => Stub_Elements.Stub_Type,
- RACW_Type => Stub_Elements.RACW_Type,
- Parent_Primitive => Current_Primitive);
-
- Current_Receiver :=
- Defining_Unit_Name (Specification (Current_Receiver_Body));
-
- Append_To (Decls, Current_Receiver_Body);
-
- -- Add a case alternative to the receiver
-
- Append_To (RPC_Receiver_Case_Alternatives,
- Make_Case_Statement_Alternative (Loc,
- Discrete_Choices => New_List (
- Make_Integer_Literal (Loc, Current_Primitive_Number)),
-
- Statements => New_List (
- Make_Procedure_Call_Statement (Loc,
- Name =>
- New_Occurrence_Of (Current_Receiver, Loc),
- Parameter_Associations => New_List (
- New_Occurrence_Of
- (Stub_Elements.RPC_Receiver_Stream, Loc),
- New_Occurrence_Of
- (Stub_Elements.RPC_Receiver_Result, Loc))))));
+ if not Is_RAS then
+ Current_Receiver_Body :=
+ Build_Subprogram_Receiving_Stubs
+ (Vis_Decl => Current_Primitive_Decl,
+ Asynchronous => Possibly_Asynchronous,
+ Dynamically_Asynchronous => Possibly_Asynchronous,
+ Stub_Type => Stub_Elements.Stub_Type,
+ RACW_Type => Stub_Elements.RACW_Type,
+ Parent_Primitive => Current_Primitive);
+
+ Current_Receiver := Defining_Unit_Name (
+ Specification (Current_Receiver_Body));
+
+ Append_To (Decls, Current_Receiver_Body);
+
+ -- Add a case alternative to the receiver
+
+ Append_To (RPC_Receiver_Case_Alternatives,
+ Make_Case_Statement_Alternative (Loc,
+ Discrete_Choices => New_List (
+ Make_Integer_Literal (Loc, Current_Primitive_Number)),
+
+ Statements => New_List (
+ Make_Procedure_Call_Statement (Loc,
+ Name =>
+ New_Occurrence_Of (Current_Receiver, Loc),
+ Parameter_Associations => New_List (
+ New_Occurrence_Of (RPC_Receiver_Stream, Loc),
+ New_Occurrence_Of (RPC_Receiver_Result, Loc))))));
+ end if;
-- Increment the index of current primitive
-- Build the case statement and the heart of the subprogram
- Append_To (RPC_Receiver_Case_Alternatives,
- Make_Case_Statement_Alternative (Loc,
- Discrete_Choices => New_List (Make_Others_Choice (Loc)),
- Statements => New_List (Make_Null_Statement (Loc))));
-
- RPC_Receiver_Subp_Id :=
- Make_Defining_Identifier (Loc, New_Internal_Name ('S'));
-
- RPC_Receiver_Declarations := New_List (
- Make_Object_Declaration (Loc,
- Defining_Identifier => RPC_Receiver_Subp_Id,
- Object_Definition =>
- New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc)));
-
- RPC_Receiver_Statements := New_List (
- Make_Attribute_Reference (Loc,
- Prefix =>
- New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc),
- Attribute_Name =>
- Name_Read,
- Expressions => New_List (
- New_Occurrence_Of (Stub_Elements.RPC_Receiver_Stream, Loc),
- New_Occurrence_Of (RPC_Receiver_Subp_Id, Loc))));
-
- Append_To (RPC_Receiver_Statements,
- Make_Case_Statement (Loc,
- Expression =>
- New_Occurrence_Of (RPC_Receiver_Subp_Id, Loc),
- Alternatives => RPC_Receiver_Case_Alternatives));
-
- RPC_Receiver_Decl :=
- Make_Subprogram_Body (Loc,
- Specification =>
- Copy_Specification (Loc,
- Parent (Stub_Elements.Object_RPC_Receiver)),
- Declarations => RPC_Receiver_Declarations,
- Handled_Statement_Sequence =>
- Make_Handled_Sequence_Of_Statements (Loc,
- Statements => RPC_Receiver_Statements));
-
- Append_To (Decls, RPC_Receiver_Decl);
+ if not Is_RAS then
+ Append_To (RPC_Receiver_Case_Alternatives,
+ Make_Case_Statement_Alternative (Loc,
+ Discrete_Choices => New_List (Make_Others_Choice (Loc)),
+ Statements => New_List (Make_Null_Statement (Loc))));
+
+ Append_To (RPC_Receiver_Statements,
+ Make_Case_Statement (Loc,
+ Expression =>
+ New_Occurrence_Of (RPC_Receiver_Subp_Id, Loc),
+ Alternatives => RPC_Receiver_Case_Alternatives));
+
+ -- 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
+ -- refer to the entities from the declaration, not from the
+ -- completion, to which we do not have easy access. Instead, the
+ -- 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 =>
+ Copy_Specification (Loc,
+ Specification (Stub_Elements.RPC_Receiver_Decl)),
+ Name => New_Occurrence_Of (RPC_Receiver, Loc)));
+ end if;
-- Do not analyze RPC receiver at this stage since it will otherwise
-- reference subprograms that have not been analyzed yet. It will
end Add_RACW_Primitive_Declarations_And_Bodies;
-----------------------------
- -- Add_RACW_Read_Attribute --
+ -- Add_RAS_Dereference_TSS --
-----------------------------
- procedure Add_RACW_Read_Attribute
- (RACW_Type : Entity_Id;
- Stub_Type : Entity_Id;
- Stub_Type_Access : Entity_Id;
- Declarations : List_Id)
- is
- Loc : constant Source_Ptr := Sloc (RACW_Type);
-
- Proc_Decl : Node_Id;
- Attr_Decl : Node_Id;
+ procedure Add_RAS_Dereference_TSS (N : Node_Id) is
+ Loc : constant Source_Ptr := Sloc (N);
- Body_Node : Node_Id;
+ Type_Def : constant Node_Id := Type_Definition (N);
- Decls : List_Id;
- Statements : List_Id;
- Local_Statements : List_Id;
- Remote_Statements : List_Id;
- -- Various parts of the procedure
-
- Procedure_Name : constant Name_Id :=
- New_Internal_Name ('R');
- Source_Partition : constant Entity_Id :=
- Make_Defining_Identifier
- (Loc, New_Internal_Name ('P'));
- Source_Receiver : constant Entity_Id :=
- Make_Defining_Identifier
- (Loc, New_Internal_Name ('S'));
- Source_Address : constant Entity_Id :=
- Make_Defining_Identifier
- (Loc, New_Internal_Name ('P'));
- Local_Stub : constant Entity_Id :=
- Make_Defining_Identifier
- (Loc, New_Internal_Name ('L'));
- Stubbed_Result : constant Entity_Id :=
- Make_Defining_Identifier
- (Loc, New_Internal_Name ('S'));
- Asynchronous_Flag : constant Entity_Id :=
- Asynchronous_Flags_Table.Get (RACW_Type);
- pragma Assert (Present (Asynchronous_Flag));
+ RAS_Type : constant Entity_Id := Defining_Identifier (N);
+ Fat_Type : constant Entity_Id := Equivalent_Type (RAS_Type);
+ RACW_Type : constant Entity_Id := Underlying_RACW_Type (RAS_Type);
+ Desig : constant Entity_Id := Etype (Designated_Type (RACW_Type));
- function Stream_Parameter return Node_Id;
- function Result return Node_Id;
- -- Functions to create occurrences of the formal parameter names
+ Stub_Elements : constant Stub_Structure := Stubs_Table.Get (Desig);
+ pragma Assert (Stub_Elements /= Empty_Stub_Structure);
- ------------
- -- Result --
- ------------
+ RACW_Primitive_Name : Node_Id;
- function Result return Node_Id is
- begin
- return Make_Identifier (Loc, Name_V);
- end Result;
+ Proc : constant Entity_Id :=
+ Make_Defining_Identifier (Loc,
+ Chars => Make_TSS_Name (RAS_Type, TSS_RAS_Dereference));
- ----------------------
- -- Stream_Parameter --
- ----------------------
+ Proc_Spec : Node_Id;
+ Param_Specs : List_Id;
+ Param_Assoc : constant List_Id := New_List;
+ Stmts : constant List_Id := New_List;
- function Stream_Parameter return Node_Id is
- begin
- return Make_Identifier (Loc, Name_S);
- end Stream_Parameter;
+ RAS_Parameter : constant Entity_Id :=
+ Make_Defining_Identifier (Loc,
+ Chars => New_Internal_Name ('P'));
- -- Start of processing for Add_RACW_Read_Attribute
+ Is_Function : constant Boolean :=
+ Nkind (Type_Def) = N_Access_Function_Definition;
- begin
- -- Generate object declarations
+ Is_Degenerate : Boolean;
+ -- Set to True if the subprogram_specification for this RAS has
+ -- an anonymous access parameter (see Process_Remote_AST_Declaration).
- Decls := New_List (
- Make_Object_Declaration (Loc,
- Defining_Identifier => Source_Partition,
- Object_Definition =>
- New_Occurrence_Of (RTE (RE_Partition_ID), Loc)),
+ Spec : constant Node_Id := Type_Def;
- Make_Object_Declaration (Loc,
- Defining_Identifier => Source_Receiver,
- Object_Definition =>
- New_Occurrence_Of (RTE (RE_Unsigned_64), Loc)),
+ Current_Parameter : Node_Id;
- Make_Object_Declaration (Loc,
- Defining_Identifier => Source_Address,
- Object_Definition =>
- New_Occurrence_Of (RTE (RE_Unsigned_64), Loc)),
+ -- Start of processing for Add_RAS_Dereference_TSS
- Make_Object_Declaration (Loc,
- Defining_Identifier => Local_Stub,
- Aliased_Present => True,
- Object_Definition => New_Occurrence_Of (Stub_Type, Loc)),
+ begin
- Make_Object_Declaration (Loc,
- Defining_Identifier => Stubbed_Result,
- Object_Definition =>
- New_Occurrence_Of (Stub_Type_Access, Loc),
- Expression =>
- Make_Attribute_Reference (Loc,
- Prefix =>
- New_Occurrence_Of (Local_Stub, Loc),
- Attribute_Name =>
- Name_Unchecked_Access)));
+ -- The Dereference TSS for a remote access-to-subprogram type
+ -- has the form:
+ -- [function|procedure] ras_typeRD (RAS_Value, <RAS_Parameters>)
+ -- [return <>]
+ -- and is called whenever a value of a RAS type is dereferenced.
- -- Read the source Partition_ID and RPC_Receiver from incoming stream
+ -- First construct a list of parameter specifications:
- Statements := New_List (
- Make_Attribute_Reference (Loc,
- Prefix =>
- New_Occurrence_Of (RTE (RE_Partition_ID), Loc),
- Attribute_Name => Name_Read,
- Expressions => New_List (
- Stream_Parameter,
- New_Occurrence_Of (Source_Partition, Loc))),
+ -- The first formal is the RAS values
- Make_Attribute_Reference (Loc,
- Prefix =>
- New_Occurrence_Of (RTE (RE_Unsigned_64), Loc),
- Attribute_Name =>
- Name_Read,
- Expressions => New_List (
- Stream_Parameter,
- New_Occurrence_Of (Source_Receiver, Loc))),
+ Param_Specs := New_List (
+ Make_Parameter_Specification (Loc,
+ Defining_Identifier => RAS_Parameter,
+ In_Present => True,
+ Parameter_Type =>
+ New_Occurrence_Of (Fat_Type, Loc)));
- Make_Attribute_Reference (Loc,
- Prefix =>
- New_Occurrence_Of (RTE (RE_Unsigned_64), Loc),
- Attribute_Name =>
- Name_Read,
- Expressions => New_List (
- Stream_Parameter,
- New_Occurrence_Of (Source_Address, Loc))));
+ -- The following formals are copied from the type declaration
- -- Build_Get_Unique_RP_Call needs the type of Stubbed_Result
+ Is_Degenerate := False;
+ Current_Parameter := First (Parameter_Specifications (Type_Def));
+ Parameters : while Present (Current_Parameter) loop
+ if Nkind (Parameter_Type (Current_Parameter))
+ = N_Access_Definition
+ then
+ Is_Degenerate := True;
+ end if;
+ Append_To (Param_Specs,
+ Make_Parameter_Specification (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc,
+ Chars => Chars (Defining_Identifier (Current_Parameter))),
+ In_Present => In_Present (Current_Parameter),
+ Out_Present => Out_Present (Current_Parameter),
+ Parameter_Type =>
+ New_Copy_Tree (Parameter_Type (Current_Parameter)),
+ Expression =>
+ New_Copy_Tree (Expression (Current_Parameter))));
- Set_Etype (Stubbed_Result, Stub_Type_Access);
+ Append_To (Param_Assoc,
+ Make_Identifier (Loc,
+ Chars => Chars (Defining_Identifier (Current_Parameter))));
- -- If the Address is Null_Address, then return a null object
+ Next (Current_Parameter);
+ end loop Parameters;
- Append_To (Statements,
- Make_Implicit_If_Statement (RACW_Type,
- Condition =>
- Make_Op_Eq (Loc,
- Left_Opnd => New_Occurrence_Of (Source_Address, Loc),
- Right_Opnd => Make_Integer_Literal (Loc, Uint_0)),
- Then_Statements => New_List (
- Make_Assignment_Statement (Loc,
- Name => Result,
- Expression => Make_Null (Loc)),
- Make_Return_Statement (Loc))));
+ if Is_Degenerate then
+ Prepend_To (Param_Assoc, New_Occurrence_Of (RAS_Parameter, Loc));
- -- If the RACW denotes an object created on the current partition, then
- -- Local_Statements will be executed. The real object will be used.
+ -- Generate a dummy body. This code will never actually be executed,
+ -- because null is the only legal value for a degenerate RAS type.
+ -- For legality's sake (in order to avoid generating a function
+ -- that does not contain a return statement), we include a dummy
+ -- recursive call on the TSS itself.
- Local_Statements := New_List (
- Make_Assignment_Statement (Loc,
- Name => Result,
- Expression =>
- Unchecked_Convert_To (RACW_Type,
- OK_Convert_To (RTE (RE_Address),
- New_Occurrence_Of (Source_Address, Loc)))));
+ Append_To (Stmts,
+ Make_Raise_Program_Error (Loc, Reason => PE_Explicit_Raise));
+ RACW_Primitive_Name := New_Occurrence_Of (Proc, Loc);
- -- If the object is located on another partition, then a stub object
- -- will be created with all the information needed to rebuild the
- -- real object at the other end.
+ else
+ -- For a normal RAS type, we cast the RAS formal to the corresponding
+ -- tagged type, and perform a dispatching call to its Call
+ -- primitive operation.
- Remote_Statements := New_List (
+ Prepend_To (Param_Assoc,
+ Unchecked_Convert_To (RACW_Type,
+ New_Occurrence_Of (RAS_Parameter, Loc)));
- Make_Assignment_Statement (Loc,
- Name => Make_Selected_Component (Loc,
- Prefix => New_Occurrence_Of (Stubbed_Result, Loc),
- Selector_Name => Make_Identifier (Loc, Name_Origin)),
- Expression =>
- New_Occurrence_Of (Source_Partition, Loc)),
+ RACW_Primitive_Name :=
+ Make_Selected_Component (Loc,
+ Prefix =>
+ New_Occurrence_Of (Scope (RACW_Type), Loc),
+ Selector_Name =>
+ Make_Identifier (Loc, Name_Call));
+ end if;
- Make_Assignment_Statement (Loc,
- Name => Make_Selected_Component (Loc,
- Prefix => New_Occurrence_Of (Stubbed_Result, Loc),
- Selector_Name => Make_Identifier (Loc, Name_Receiver)),
- Expression =>
- New_Occurrence_Of (Source_Receiver, Loc)),
+ if Is_Function then
+ Append_To (Stmts,
+ Make_Return_Statement (Loc,
+ Expression =>
+ Make_Function_Call (Loc,
+ Name =>
+ RACW_Primitive_Name,
+ Parameter_Associations => Param_Assoc)));
- Make_Assignment_Statement (Loc,
- Name => Make_Selected_Component (Loc,
- Prefix => New_Occurrence_Of (Stubbed_Result, Loc),
- Selector_Name => Make_Identifier (Loc, Name_Addr)),
- Expression =>
- New_Occurrence_Of (Source_Address, Loc)));
+ else
+ Append_To (Stmts,
+ Make_Procedure_Call_Statement (Loc,
+ Name =>
+ RACW_Primitive_Name,
+ Parameter_Associations => Param_Assoc));
+ end if;
- Append_To (Remote_Statements,
- Make_Assignment_Statement (Loc,
- Name => Make_Selected_Component (Loc,
- Prefix => New_Occurrence_Of (Stubbed_Result, Loc),
- Selector_Name => Make_Identifier (Loc, Name_Asynchronous)),
- Expression =>
- New_Occurrence_Of (Asynchronous_Flag, Loc)));
-
- Append_List_To (Remote_Statements,
- Build_Get_Unique_RP_Call (Loc, Stubbed_Result, Stub_Type));
- -- ??? Issue with asynchronous calls here: the Asynchronous
- -- flag is set on the stub type if, and only if, the RACW type
- -- has a pragma Asynchronous. This is incorrect for RACWs that
- -- implement RAS types, because in that case the /designated
- -- subprogram/ (not the type) might be asynchronous, and
- -- that causes the stub to need to be asynchronous too.
- -- A solution is to transport a RAS as a struct containing
- -- a RACW and an asynchronous flag, and to properly alter
- -- the Asynchronous component in the stub type in the RAS's
- -- Input TSS.
-
- Append_To (Remote_Statements,
- Make_Assignment_Statement (Loc,
- Name => Result,
- Expression => Unchecked_Convert_To (RACW_Type,
- New_Occurrence_Of (Stubbed_Result, Loc))));
+ -- Build the complete subprogram
- -- Distinguish between the local and remote cases, and execute the
- -- appropriate piece of code.
+ if Is_Function then
+ Proc_Spec :=
+ Make_Function_Specification (Loc,
+ Defining_Unit_Name => Proc,
+ Parameter_Specifications => Param_Specs,
+ Subtype_Mark =>
+ New_Occurrence_Of (
+ Entity (Subtype_Mark (Spec)), Loc));
- Append_To (Statements,
- Make_Implicit_If_Statement (RACW_Type,
- Condition =>
- Make_Op_Eq (Loc,
- Left_Opnd =>
- Make_Function_Call (Loc,
- Name =>
- New_Occurrence_Of (RTE (RE_Get_Local_Partition_Id), Loc)),
- Right_Opnd => New_Occurrence_Of (Source_Partition, Loc)),
- Then_Statements => Local_Statements,
- Else_Statements => Remote_Statements));
-
- Build_Stream_Procedure
- (Loc, RACW_Type, Body_Node,
- Make_Defining_Identifier (Loc, Procedure_Name),
- Statements, Outp => True);
- Set_Declarations (Body_Node, Decls);
-
- Proc_Decl := Make_Subprogram_Declaration (Loc,
- Copy_Specification (Loc, Specification (Body_Node)));
-
- Attr_Decl :=
- Make_Attribute_Definition_Clause (Loc,
- Name => New_Occurrence_Of (RACW_Type, Loc),
- Chars => Name_Read,
- Expression =>
- New_Occurrence_Of (
- Defining_Unit_Name (Specification (Proc_Decl)), Loc));
+ Set_Ekind (Proc, E_Function);
+ Set_Etype (Proc,
+ New_Occurrence_Of (Entity (Subtype_Mark (Spec)), Loc));
- Insert_After (Declaration_Node (RACW_Type), Proc_Decl);
- Insert_After (Proc_Decl, Attr_Decl);
- Append_To (Declarations, Body_Node);
- end Add_RACW_Read_Attribute;
+ else
+ Proc_Spec :=
+ Make_Procedure_Specification (Loc,
+ Defining_Unit_Name => Proc,
+ Parameter_Specifications => Param_Specs);
- ------------------------------------
- -- Add_RACW_Read_Write_Attributes --
- ------------------------------------
+ Set_Ekind (Proc, E_Procedure);
+ Set_Etype (Proc, Standard_Void_Type);
+ end if;
- procedure Add_RACW_Read_Write_Attributes
- (RACW_Type : Entity_Id;
- Stub_Type : Entity_Id;
- Stub_Type_Access : Entity_Id;
- Object_RPC_Receiver : Entity_Id;
- Declarations : List_Id)
- is
- begin
- Add_RACW_Write_Attribute
- (RACW_Type => RACW_Type,
- Stub_Type => Stub_Type,
- Stub_Type_Access => Stub_Type_Access,
- Object_RPC_Receiver => Object_RPC_Receiver,
- Declarations => Declarations);
+ Discard_Node (
+ Make_Subprogram_Body (Loc,
+ Specification => Proc_Spec,
+ Declarations => New_List,
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements => Stmts)));
- Add_RACW_Read_Attribute
- (RACW_Type => RACW_Type,
- Stub_Type => Stub_Type,
- Stub_Type_Access => Stub_Type_Access,
- Declarations => Declarations);
- end Add_RACW_Read_Write_Attributes;
+ Set_TSS (Fat_Type, Proc);
+ end Add_RAS_Dereference_TSS;
- ------------------------------
- -- Add_RACW_Write_Attribute --
- ------------------------------
+ -------------------------------
+ -- Add_RAS_Proxy_And_Analyze --
+ -------------------------------
- procedure Add_RACW_Write_Attribute
- (RACW_Type : Entity_Id;
- Stub_Type : Entity_Id;
- Stub_Type_Access : Entity_Id;
- Object_RPC_Receiver : Entity_Id;
- Declarations : List_Id)
+ procedure Add_RAS_Proxy_And_Analyze
+ (Decls : List_Id;
+ Vis_Decl : Node_Id;
+ All_Calls_Remote_E : Entity_Id;
+ Proxy_Object_Addr : out Entity_Id)
is
- Loc : constant Source_Ptr := Sloc (RACW_Type);
-
- Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type);
-
- Body_Node : Node_Id;
- Proc_Decl : Node_Id;
- Attr_Decl : Node_Id;
+ Loc : constant Source_Ptr := Sloc (Vis_Decl);
- RPC_Receiver : Node_Id;
+ Subp_Name : constant Entity_Id :=
+ Defining_Unit_Name (Specification (Vis_Decl));
- Statements : List_Id;
- Local_Statements : List_Id;
- Remote_Statements : List_Id;
- Null_Statements : List_Id;
+ Pkg_Name : constant Entity_Id :=
+ Make_Defining_Identifier (Loc,
+ Chars =>
+ New_External_Name (Chars (Subp_Name), 'P', -1));
- Procedure_Name : constant Name_Id := New_Internal_Name ('R');
+ Proxy_Type : constant Entity_Id :=
+ Make_Defining_Identifier (Loc,
+ Chars =>
+ New_External_Name (
+ Related_Id => Chars (Subp_Name),
+ Suffix => 'P'));
- -- Functions to create occurrences of the formal
- -- parameter names.
+ Proxy_Type_Full_View : constant Entity_Id :=
+ Make_Defining_Identifier (Loc,
+ Chars (Proxy_Type));
- function Stream_Parameter return Node_Id;
- function Object return Node_Id;
+ Subp_Decl_Spec : constant Node_Id :=
+ Build_RAS_Primitive_Specification
+ (Subp_Spec => Specification (Vis_Decl),
+ Remote_Object_Type => Proxy_Type);
- function Stream_Parameter return Node_Id is
- begin
- return Make_Identifier (Loc, Name_S);
- end Stream_Parameter;
+ Subp_Body_Spec : constant Node_Id :=
+ Build_RAS_Primitive_Specification
+ (Subp_Spec => Specification (Vis_Decl),
+ Remote_Object_Type => Proxy_Type);
- function Object return Node_Id is
- begin
- return Make_Identifier (Loc, Name_V);
- end Object;
+ Vis_Decls : constant List_Id := New_List;
+ Pvt_Decls : constant List_Id := New_List;
+ Actuals : constant List_Id := New_List;
+ Formal : Node_Id;
+ Perform_Call : Node_Id;
begin
- -- Build the code fragment corresponding to the marshalling of a
- -- local object.
+ -- type subpP is tagged limited private;
+
+ Append_To (Vis_Decls,
+ Make_Private_Type_Declaration (Loc,
+ Defining_Identifier => Proxy_Type,
+ Tagged_Present => True,
+ Limited_Present => True));
- if Is_RAS then
+ -- [subprogram] Call
+ -- (Self : access subpP;
+ -- ...other-formals...)
+ -- [return T];
- -- For a RAS, the RPC receiver is that of the RCI unit,
- -- not that of the corresponding distributed object type.
- -- We retrieve its address from the local proxy object.
+ Append_To (Vis_Decls,
+ Make_Subprogram_Declaration (Loc,
+ Specification => Subp_Decl_Spec));
- RPC_Receiver := Make_Selected_Component (Loc,
- Prefix =>
- Unchecked_Convert_To (RTE (RE_RAS_Proxy_Type_Access), Object),
- Selector_Name =>
- Make_Identifier (Loc, Name_Receiver));
+ -- A : constant System.Address;
- else
- RPC_Receiver := Make_Attribute_Reference (Loc,
- Prefix =>
- New_Occurrence_Of (Object_RPC_Receiver, Loc),
- Attribute_Name =>
- Name_Address);
- end if;
+ Proxy_Object_Addr := Make_Defining_Identifier (Loc, Name_uA);
- Local_Statements := New_List (
+ Append_To (Vis_Decls,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier =>
+ Proxy_Object_Addr,
+ Constant_Present =>
+ True,
+ Object_Definition =>
+ New_Occurrence_Of (RTE (RE_Address), Loc)));
- Pack_Entity_Into_Stream_Access (Loc,
- Stream => Stream_Parameter,
- Object => RTE (RE_Get_Local_Partition_Id)),
+ -- private
- Pack_Node_Into_Stream_Access (Loc,
- Stream => Stream_Parameter,
- Object => OK_Convert_To (RTE (RE_Unsigned_64), RPC_Receiver),
- Etyp => RTE (RE_Unsigned_64)),
+ -- type subpP is tagged limited record
+ -- All_Calls_Remote : Boolean := [All_Calls_Remote?];
+ -- ...
+ -- end record;
- Pack_Node_Into_Stream_Access (Loc,
- Stream => Stream_Parameter,
- Object => OK_Convert_To (RTE (RE_Unsigned_64),
- Make_Attribute_Reference (Loc,
- Prefix =>
- Make_Explicit_Dereference (Loc,
- Prefix => Object),
- Attribute_Name => Name_Address)),
- Etyp => RTE (RE_Unsigned_64)));
+ Append_To (Pvt_Decls,
+ Make_Full_Type_Declaration (Loc,
+ Defining_Identifier =>
+ Proxy_Type_Full_View,
+ Type_Definition =>
+ Build_Remote_Subprogram_Proxy_Type (Loc,
+ New_Occurrence_Of (All_Calls_Remote_E, Loc))));
- -- Build the code fragment corresponding to the marshalling of
- -- a remote object.
+ -- Trick semantic analysis into swapping the public and
+ -- full view when freezing the public view.
- Remote_Statements := New_List (
+ Set_Comes_From_Source (Proxy_Type_Full_View, True);
- Pack_Node_Into_Stream_Access (Loc,
- Stream => Stream_Parameter,
- Object =>
- Make_Selected_Component (Loc,
- Prefix => Unchecked_Convert_To (Stub_Type_Access,
- Object),
- Selector_Name =>
- Make_Identifier (Loc, Name_Origin)),
- Etyp => RTE (RE_Partition_ID)),
+ -- procedure Call
+ -- (Self : access O;
+ -- ...other-formals...) is
+ -- begin
+ -- P (...other-formals...);
+ -- end Call;
- Pack_Node_Into_Stream_Access (Loc,
- Stream => Stream_Parameter,
- Object =>
- Make_Selected_Component (Loc,
- Prefix => Unchecked_Convert_To (Stub_Type_Access,
- Object),
- Selector_Name =>
- Make_Identifier (Loc, Name_Receiver)),
- Etyp => RTE (RE_Unsigned_64)),
+ -- function Call
+ -- (Self : access O;
+ -- ...other-formals...)
+ -- return T is
+ -- begin
+ -- return F (...other-formals...);
+ -- end Call;
- Pack_Node_Into_Stream_Access (Loc,
- Stream => Stream_Parameter,
- Object =>
- Make_Selected_Component (Loc,
- Prefix => Unchecked_Convert_To (Stub_Type_Access,
- Object),
- Selector_Name =>
- Make_Identifier (Loc, Name_Addr)),
- Etyp => RTE (RE_Unsigned_64)));
+ if Nkind (Subp_Decl_Spec) = N_Procedure_Specification then
+ Perform_Call :=
+ Make_Procedure_Call_Statement (Loc,
+ Name =>
+ New_Occurrence_Of (Subp_Name, Loc),
+ Parameter_Associations =>
+ Actuals);
+ else
+ Perform_Call :=
+ Make_Return_Statement (Loc,
+ Expression =>
+ Make_Function_Call (Loc,
+ Name =>
+ New_Occurrence_Of (Subp_Name, Loc),
+ Parameter_Associations =>
+ Actuals));
+ end if;
- -- Build the code fragment corresponding to the marshalling of a null
- -- object.
+ Formal := First (Parameter_Specifications (Subp_Decl_Spec));
+ pragma Assert (Present (Formal));
+ Next (Formal);
- Null_Statements := New_List (
+ while Present (Formal) loop
+ Append_To (Actuals, New_Occurrence_Of (
+ Defining_Identifier (Formal), Loc));
+ Next (Formal);
+ end loop;
- Pack_Entity_Into_Stream_Access (Loc,
- Stream => Stream_Parameter,
- Object => RTE (RE_Get_Local_Partition_Id)),
+ -- O : aliased subpP;
- Pack_Node_Into_Stream_Access (Loc,
- Stream => Stream_Parameter,
- Object => OK_Convert_To (RTE (RE_Unsigned_64),
- Make_Attribute_Reference (Loc,
- Prefix => New_Occurrence_Of (Object_RPC_Receiver, Loc),
- Attribute_Name => Name_Address)),
- Etyp => RTE (RE_Unsigned_64)),
+ Append_To (Pvt_Decls,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc,
+ Name_uO),
+ Aliased_Present =>
+ True,
+ Object_Definition =>
+ New_Occurrence_Of (Proxy_Type, Loc)));
- Pack_Node_Into_Stream_Access (Loc,
- Stream => Stream_Parameter,
- Object => Make_Integer_Literal (Loc, Uint_0),
- Etyp => RTE (RE_Unsigned_64)));
+ -- A : constant System.Address := O'Address;
- Statements := New_List (
- Make_Implicit_If_Statement (RACW_Type,
- Condition =>
- Make_Op_Eq (Loc,
- Left_Opnd => Object,
- Right_Opnd => Make_Null (Loc)),
- Then_Statements => Null_Statements,
- Elsif_Parts => New_List (
- Make_Elsif_Part (Loc,
- Condition =>
- Make_Op_Eq (Loc,
- Left_Opnd =>
- Make_Attribute_Reference (Loc,
- Prefix => Object,
- Attribute_Name => Name_Tag),
- Right_Opnd =>
- Make_Attribute_Reference (Loc,
- Prefix => New_Occurrence_Of (Stub_Type, Loc),
- Attribute_Name => Name_Tag)),
- Then_Statements => Remote_Statements)),
- Else_Statements => Local_Statements));
-
- Build_Stream_Procedure
- (Loc, RACW_Type, Body_Node,
- Make_Defining_Identifier (Loc, Procedure_Name),
- Statements, Outp => False);
-
- Proc_Decl := Make_Subprogram_Declaration (Loc,
- Copy_Specification (Loc, Specification (Body_Node)));
-
- Attr_Decl :=
- Make_Attribute_Definition_Clause (Loc,
- Name => New_Occurrence_Of (RACW_Type, Loc),
- Chars => Name_Write,
+ Append_To (Pvt_Decls,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc,
+ Chars (Proxy_Object_Addr)),
+ Constant_Present =>
+ True,
+ Object_Definition =>
+ New_Occurrence_Of (RTE (RE_Address), Loc),
Expression =>
- New_Occurrence_Of (
- Defining_Unit_Name (Specification (Proc_Decl)), Loc));
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Occurrence_Of (
+ Defining_Identifier (Last (Pvt_Decls)), Loc),
+ Attribute_Name =>
+ Name_Address)));
- Insert_After (Declaration_Node (RACW_Type), Proc_Decl);
- Insert_After (Proc_Decl, Attr_Decl);
- Append_To (Declarations, Body_Node);
- end Add_RACW_Write_Attribute;
+ Append_To (Decls,
+ Make_Package_Declaration (Loc,
+ Specification => Make_Package_Specification (Loc,
+ Defining_Unit_Name => Pkg_Name,
+ Visible_Declarations => Vis_Decls,
+ Private_Declarations => Pvt_Decls,
+ End_Label => Empty)));
+ Analyze (Last (Decls));
- ------------------------
- -- Add_RAS_Access_TSS --
- ------------------------
+ Append_To (Decls,
+ Make_Package_Body (Loc,
+ Defining_Unit_Name =>
+ Make_Defining_Identifier (Loc,
+ Chars (Pkg_Name)),
+ Declarations => New_List (
+ Make_Subprogram_Body (Loc,
+ Specification =>
+ Subp_Body_Spec,
+ Declarations => New_List,
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements => New_List (Perform_Call))))));
+ Analyze (Last (Decls));
+ end Add_RAS_Proxy_And_Analyze;
- procedure Add_RAS_Access_TSS (N : Node_Id) is
- Loc : constant Source_Ptr := Sloc (N);
+ -----------------------
+ -- Add_RAST_Features --
+ -----------------------
- Ras_Type : constant Entity_Id := Defining_Identifier (N);
- Fat_Type : constant Entity_Id := Equivalent_Type (Ras_Type);
- -- Ras_Type is the access to subprogram type while Fat_Type points to
- -- the record type corresponding to a remote access to subprogram type.
+ procedure Add_RAST_Features (Vis_Decl : Node_Id) is
+ RAS_Type : constant Entity_Id :=
+ Equivalent_Type (Defining_Identifier (Vis_Decl));
- RACW_Type : constant Entity_Id :=
- Underlying_RACW_Type (Ras_Type);
- Desig : constant Entity_Id :=
- Etype (Designated_Type (RACW_Type));
+ Spec : constant Node_Id :=
+ Specification (Unit (Enclosing_Lib_Unit_Node (Vis_Decl)));
+ Decls : List_Id := Private_Declarations (Spec);
- Stub_Elements : constant Stub_Structure :=
- Stubs_Table.Get (Desig);
- pragma Assert (Stub_Elements /= Empty_Stub_Structure);
+ begin
+ pragma Assert (No (TSS (RAS_Type, TSS_RAS_Access)));
- Proc : constant Entity_Id :=
- Make_Defining_Identifier (Loc,
- Chars => Make_TSS_Name (Ras_Type, TSS_RAS_Access));
- Proc_Spec : Node_Id;
+ if No (Decls) then
+ Decls := Visible_Declarations (Spec);
+ end if;
- -- Formal parameters
+ Add_RAS_Dereference_TSS (Vis_Decl);
+ Specific_Add_RAST_Features (Vis_Decl, RAS_Type, Decls);
+ end Add_RAST_Features;
- Package_Name : constant Entity_Id :=
- Make_Defining_Identifier (Loc,
- Chars => Name_P);
- -- Target package
+ -----------------------------------------
+ -- Add_Receiving_Stubs_To_Declarations --
+ -----------------------------------------
- Subp_Id : constant Entity_Id :=
- Make_Defining_Identifier (Loc,
- Chars => Name_S);
- -- Target subprogram
+ procedure Add_Receiving_Stubs_To_Declarations
+ (Pkg_Spec : Node_Id;
+ Decls : List_Id)
+ is
+ Loc : constant Source_Ptr := Sloc (Pkg_Spec);
- Asynch_P : constant Entity_Id :=
- Make_Defining_Identifier (Loc,
- Chars => Name_Asynchronous);
- -- Is the procedure to which the 'Access applies asynchronous?
+ Stream_Parameter : Node_Id;
+ Result_Parameter : Node_Id;
- All_Calls_Remote : constant Entity_Id :=
- Make_Defining_Identifier (Loc,
- Chars => Name_All_Calls_Remote);
- -- True if an All_Calls_Remote pragma applies to the RCI unit
- -- that contains the subprogram.
+ 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
- -- Common local variables
+ 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.
- Proc_Decls : List_Id;
- Proc_Statements : List_Id;
+ Subp_Id : Node_Id;
+ -- Subprogram_Id as read from the incoming stream
- Origin : constant Entity_Id :=
- Make_Defining_Identifier (Loc,
- Chars => New_Internal_Name ('P'));
+ Current_Declaration : Node_Id;
+ Current_Subprogram_Number : Int := First_RCI_Subprogram_Id;
+ Current_Stubs : Node_Id;
- -- Additional local variables for the local case
+ Subp_Info_Array : constant Entity_Id :=
+ Make_Defining_Identifier (Loc,
+ Chars => New_Internal_Name ('I'));
- Proxy_Addr : constant Entity_Id :=
- Make_Defining_Identifier (Loc,
- Chars => New_Internal_Name ('P'));
+ Subp_Info_List : constant List_Id := New_List;
- -- Additional local variables for the remote case
+ Register_Pkg_Actuals : constant List_Id := New_List;
- Local_Stub : constant Entity_Id :=
- Make_Defining_Identifier (Loc,
- Chars => New_Internal_Name ('L'));
+ Dummy_Register_Name : Name_Id;
+ Dummy_Register_Spec : Node_Id;
+ Dummy_Register_Decl : Node_Id;
+ Dummy_Register_Body : Node_Id;
- Stub_Ptr : constant Entity_Id :=
- Make_Defining_Identifier (Loc,
- Chars => New_Internal_Name ('S'));
+ All_Calls_Remote_E : Entity_Id;
+ Proxy_Object_Addr : Entity_Id;
- function Set_Field
- (Field_Name : Name_Id;
- Value : Node_Id) return Node_Id;
- -- Construct an assignment that sets the named component in the
- -- returned record
+ 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.
- ---------------
- -- Set_Field --
- ---------------
+ ---------------------
+ -- Append_Stubs_To --
+ ---------------------
- function Set_Field
- (Field_Name : Name_Id;
- Value : Node_Id) return Node_Id
+ 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
- return
- Make_Assignment_Statement (Loc,
- Name =>
- Make_Selected_Component (Loc,
- Prefix => New_Occurrence_Of (Stub_Ptr, Loc),
- Selector_Name => Make_Identifier (Loc, Field_Name)),
- Expression => Value);
- end Set_Field;
-
- -- Start of processing for Add_RAS_Access_TSS
-
- begin
- Proc_Decls := New_List (
+ 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.
- -- Common declarations
+ Append_To (Actuals,
+ New_Occurrence_Of (Result_Parameter, Loc));
+ end if;
- Make_Object_Declaration (Loc,
- Defining_Identifier => Origin,
- Constant_Present => True,
- Object_Definition =>
- New_Occurrence_Of (RTE (RE_Partition_ID), Loc),
- Expression =>
- Make_Function_Call (Loc,
- Name =>
- New_Occurrence_Of (RTE (RE_Get_Active_Partition_Id), Loc),
- Parameter_Associations => New_List (
- New_Occurrence_Of (Package_Name, Loc)))),
+ Append_To (RPC_Receiver_Cases,
+ Make_Case_Statement_Alternative (Loc,
+ Discrete_Choices =>
+ New_List (
+ Make_Integer_Literal (Loc, Subprogram_Number)),
- -- Declaration use only in the local case: proxy address
+ Statements =>
+ New_List (
+ Make_Procedure_Call_Statement (Loc,
+ Name =>
+ New_Occurrence_Of (
+ Defining_Entity (Stubs), Loc),
+ Parameter_Associations =>
+ Actuals))));
+ end Append_Stubs_To;
- Make_Object_Declaration (Loc,
- Defining_Identifier => Proxy_Addr,
- Object_Definition =>
- New_Occurrence_Of (RTE (RE_Unsigned_64), Loc)),
+ -- Start of processing for Add_Receiving_Stubs_To_Declarations
- -- Declarations used only in the remote case: stub object and
- -- stub pointer.
+ begin
+ -- Building receiving stubs consist in several operations:
- Make_Object_Declaration (Loc,
- Defining_Identifier => Local_Stub,
- Aliased_Present => True,
- Object_Definition =>
- New_Occurrence_Of (Stub_Elements.Stub_Type, Loc)),
+ -- - 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
- Make_Object_Declaration (Loc,
- Defining_Identifier =>
- Stub_Ptr,
- Object_Definition =>
- New_Occurrence_Of (Stub_Elements.Stub_Type_Access, Loc),
- Expression =>
- Make_Attribute_Reference (Loc,
- Prefix => New_Occurrence_Of (Local_Stub, Loc),
- Attribute_Name => Name_Unchecked_Access)));
+ -- - 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
- Set_Etype (Stub_Ptr, Stub_Elements.Stub_Type_Access);
- -- Build_Get_Unique_RP_Call needs this information
+ -- - 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
- -- Note: Here we assume that the Fat_Type is a record
- -- containing just a pointer to a proxy or stub object.
+ 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);
- Proc_Statements := New_List (
+ -- 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.
- -- Generate:
+ 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))))));
- -- Get_RAS_Info (Pkg, Subp, PA);
- -- if Origin = Local_Partition_Id and then not All_Calls_Remote then
- -- return Fat_Type!(PA);
- -- end if;
+ -- Build a subprogram for RAS information lookups
- Make_Procedure_Call_Statement (Loc,
- Name =>
- New_Occurrence_Of (RTE (RE_Get_RAS_Info), Loc),
- Parameter_Associations => New_List (
- New_Occurrence_Of (Package_Name, Loc),
- New_Occurrence_Of (Subp_Id, Loc),
- New_Occurrence_Of (Proxy_Addr, Loc))),
+ 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);
- Make_Implicit_If_Statement (N,
- Condition =>
- Make_And_Then (Loc,
- Left_Opnd =>
- Make_Op_Eq (Loc,
- Left_Opnd =>
- New_Occurrence_Of (Origin, Loc),
- Right_Opnd =>
- Make_Function_Call (Loc,
- New_Occurrence_Of (
- RTE (RE_Get_Local_Partition_Id), Loc))),
- Right_Opnd =>
- Make_Op_Not (Loc,
- New_Occurrence_Of (All_Calls_Remote, Loc))),
- Then_Statements => New_List (
- Make_Return_Statement (Loc,
- Unchecked_Convert_To (Fat_Type,
- OK_Convert_To (RTE (RE_Address),
- New_Occurrence_Of (Proxy_Addr, Loc)))))),
+ Current_Stubs := Build_Subprogram_Receiving_Stubs
+ (Vis_Decl => Current_Declaration,
+ Asynchronous => False);
+ Append_To (Decls, Current_Stubs);
+ Analyze (Current_Stubs);
- Set_Field (Name_Origin,
- New_Occurrence_Of (Origin, Loc)),
+ Append_Stubs_To (Pkg_RPC_Receiver_Cases,
+ Declaration =>
+ Current_Declaration,
+ Stubs =>
+ Current_Stubs,
+ Subprogram_Number => 1);
- Set_Field (Name_Receiver,
- Make_Function_Call (Loc,
- Name =>
- New_Occurrence_Of (RTE (RE_Get_RCI_Package_Receiver), Loc),
- Parameter_Associations => New_List (
- New_Occurrence_Of (Package_Name, Loc)))),
+ -- 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.
- Set_Field (Name_Addr, New_Occurrence_Of (Proxy_Addr, Loc)),
+ All_Calls_Remote_E := Boolean_Literals (
+ Has_All_Calls_Remote (Defining_Entity (Pkg_Spec)));
- -- 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
- -- type, to which a pragma Asynchronous applies.
+ Overload_Counter_Table.Reset;
- -- Parameter Asynch_P is true when the procedure is asynchronous;
- -- Expression Asynch_T is true when the type is asynchronous.
+ 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.
- Set_Field (Name_Asynchronous,
- Make_Or_Else (Loc,
- New_Occurrence_Of (Asynch_P, Loc),
- New_Occurrence_Of (Boolean_Literals (
- Is_Asynchronous (Ras_Type)), Loc))));
+ Subp_Def : constant Entity_Id :=
+ Defining_Unit_Name
+ (Specification (Current_Declaration));
- Append_List_To (Proc_Statements,
- Build_Get_Unique_RP_Call
- (Loc, Stub_Ptr, Stub_Elements.Stub_Type));
+ Subp_Val : String_Id;
- -- Return the newly created value
+ begin
+ pragma Assert (Current_Subprogram_Number =
+ Get_Subprogram_Id (Subp_Def));
- Append_To (Proc_Statements,
- Make_Return_Statement (Loc,
- Expression =>
- Unchecked_Convert_To (Fat_Type,
- New_Occurrence_Of (Stub_Ptr, Loc))));
+ -- Build receiving stub
- Proc_Spec :=
- Make_Function_Specification (Loc,
- Defining_Unit_Name => Proc,
- Parameter_Specifications => New_List (
- Make_Parameter_Specification (Loc,
- Defining_Identifier => Package_Name,
- Parameter_Type =>
- New_Occurrence_Of (Standard_String, Loc)),
+ 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;
- Make_Parameter_Specification (Loc,
- Defining_Identifier => Subp_Id,
- Parameter_Type =>
- New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc)),
+ Current_Subprogram_Number := Current_Subprogram_Number + 1;
+ end if;
- Make_Parameter_Specification (Loc,
- Defining_Identifier => Asynch_P,
- Parameter_Type =>
- New_Occurrence_Of (Standard_Boolean, Loc)),
+ Next (Current_Declaration);
+ end loop;
- Make_Parameter_Specification (Loc,
- Defining_Identifier => All_Calls_Remote,
- Parameter_Type =>
- New_Occurrence_Of (Standard_Boolean, Loc))),
+ -- 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.
- Subtype_Mark =>
- New_Occurrence_Of (Fat_Type, Loc));
+ 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))));
- -- Set the kind and return type of the function to prevent ambiguities
- -- between Ras_Type and Fat_Type in subsequent analysis.
+ Append_To (Pkg_RPC_Receiver_Statements,
+ Make_Case_Statement (Loc,
+ Expression =>
+ New_Occurrence_Of (Subp_Id, Loc),
+ Alternatives => Pkg_RPC_Receiver_Cases));
- Set_Ekind (Proc, E_Function);
- Set_Etype (Proc, New_Occurrence_Of (Fat_Type, Loc));
+ 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));
- Discard_Node (
+ Append_To (Decls,
Make_Subprogram_Body (Loc,
- Specification => Proc_Spec,
- Declarations => Proc_Decls,
+ Specification =>
+ Copy_Specification (Loc, Parent (Lookup_RAS_Info)),
+ Declarations =>
+ No_List,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
- Statements => Proc_Statements)));
-
- Set_TSS (Fat_Type, Proc);
- end Add_RAS_Access_TSS;
-
- -----------------------------
- -- Add_RAS_Dereference_TSS --
- -----------------------------
+ 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));
- -- This subprogram could use more comments ???
+ Append_To (Decls, Pkg_RPC_Receiver_Body);
+ Analyze (Pkg_RPC_Receiver_Body);
- procedure Add_RAS_Dereference_TSS (N : Node_Id) is
- Loc : constant Source_Ptr := Sloc (N);
+ -- Construction of the dummy package used to register the package
+ -- receiving stubs on the nameserver.
- Type_Def : constant Node_Id := Type_Definition (N);
+ Dummy_Register_Name := New_Internal_Name ('P');
- RAS_Type : constant Entity_Id := Defining_Identifier (N);
- Fat_Type : constant Entity_Id := Equivalent_Type (RAS_Type);
- RACW_Type : constant Entity_Id := Underlying_RACW_Type (RAS_Type);
- Desig : constant Entity_Id := Etype (Designated_Type (RACW_Type));
+ Dummy_Register_Spec :=
+ Make_Package_Specification (Loc,
+ Defining_Unit_Name =>
+ Make_Defining_Identifier (Loc, Dummy_Register_Name),
+ Visible_Declarations => No_List,
+ End_Label => Empty);
- Stub_Elements : constant Stub_Structure := Stubs_Table.Get (Desig);
- pragma Assert (Stub_Elements /= Empty_Stub_Structure);
+ Dummy_Register_Decl :=
+ Make_Package_Declaration (Loc,
+ Specification => Dummy_Register_Spec);
- RACW_Primitive_Name : Node_Id;
+ Append_To (Decls, Dummy_Register_Decl);
+ Analyze (Dummy_Register_Decl);
- Proc : constant Entity_Id :=
- Make_Defining_Identifier (Loc,
- Chars => Make_TSS_Name (RAS_Type, TSS_RAS_Dereference));
+ Get_Library_Unit_Name_String (Pkg_Spec);
+ Append_To (Register_Pkg_Actuals,
+ -- Name
+ Make_String_Literal (Loc,
+ Strval => String_From_Name_Buffer));
- Proc_Spec : Node_Id;
- Param_Specs : List_Id;
- Param_Assoc : constant List_Id := New_List;
- Stmts : constant List_Id := New_List;
+ Append_To (Register_Pkg_Actuals,
+ -- Receiver
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ New_Occurrence_Of (Pkg_RPC_Receiver, Loc),
+ Attribute_Name =>
+ Name_Unrestricted_Access));
- RAS_Parameter : constant Entity_Id :=
- Make_Defining_Identifier (Loc,
- Chars => New_Internal_Name ('P'));
+ Append_To (Register_Pkg_Actuals,
+ -- Version
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ New_Occurrence_Of (Defining_Entity (Pkg_Spec), Loc),
+ Attribute_Name =>
+ Name_Version));
- Is_Function : constant Boolean :=
- Nkind (Type_Def) = N_Access_Function_Definition;
+ Append_To (Register_Pkg_Actuals,
+ -- Subp_Info
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ New_Occurrence_Of (Subp_Info_Array, Loc),
+ Attribute_Name =>
+ Name_Address));
- Is_Degenerate : Boolean;
- -- Set to True if the subprogram_specification for this RAS has
- -- an anonymous access parameter (see Process_Remote_AST_Declaration).
+ Append_To (Register_Pkg_Actuals,
+ -- Subp_Info_Len
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ New_Occurrence_Of (Subp_Info_Array, Loc),
+ Attribute_Name =>
+ Name_Length));
- Spec : constant Node_Id := Type_Def;
+ Dummy_Register_Body :=
+ Make_Package_Body (Loc,
+ Defining_Unit_Name =>
+ Make_Defining_Identifier (Loc, Dummy_Register_Name),
+ Declarations => No_List,
- Current_Parameter : Node_Id;
+ 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),
- begin
- Param_Specs := New_List (
- Make_Parameter_Specification (Loc,
- Defining_Identifier => RAS_Parameter,
- In_Present => True,
- Parameter_Type =>
- New_Occurrence_Of (Fat_Type, Loc)));
+ Parameter_Associations => Register_Pkg_Actuals))));
- Is_Degenerate := False;
- Current_Parameter := First (Parameter_Specifications (Type_Def));
- Parameters : while Current_Parameter /= Empty loop
- if Nkind (Parameter_Type (Current_Parameter))
- = N_Access_Definition
- then
- Is_Degenerate := True;
- end if;
- Append_To (Param_Specs,
- Make_Parameter_Specification (Loc,
- Defining_Identifier =>
- Make_Defining_Identifier (Loc,
- Chars => Chars (Defining_Identifier (Current_Parameter))),
- In_Present => In_Present (Current_Parameter),
- Out_Present => Out_Present (Current_Parameter),
- Parameter_Type =>
- New_Copy_Tree (Parameter_Type (Current_Parameter)),
- Expression =>
- New_Copy_Tree (Expression (Current_Parameter))));
+ Append_To (Decls, Dummy_Register_Body);
+ Analyze (Dummy_Register_Body);
+ end Add_Receiving_Stubs_To_Declarations;
- Append_To (Param_Assoc,
- Make_Identifier (Loc,
- Chars => Chars (Defining_Identifier (Current_Parameter))));
+ -------------------
+ -- Add_Stub_Type --
+ -------------------
- Next (Current_Parameter);
- end loop Parameters;
+ procedure Add_Stub_Type
+ (Designated_Type : Entity_Id;
+ RACW_Type : Entity_Id;
+ Decls : List_Id;
+ Stub_Type : out Entity_Id;
+ Stub_Type_Access : out Entity_Id;
+ RPC_Receiver_Decl : out Node_Id;
+ Existing : out Boolean)
+ is
+ Loc : constant Source_Ptr := Sloc (RACW_Type);
- if Is_Degenerate then
- Prepend_To (Param_Assoc, New_Occurrence_Of (RAS_Parameter, Loc));
+ Stub_Elements : constant Stub_Structure :=
+ Stubs_Table.Get (Designated_Type);
- -- Generate a dummy body recursing on the Dereference TSS, since
- -- actually it will never be executed.
+ Stub_Type_Declaration : Node_Id;
+ Stub_Type_Access_Declaration : Node_Id;
- Append_To (Stmts,
- Make_Raise_Program_Error (Loc, Reason => PE_Explicit_Raise));
- RACW_Primitive_Name := New_Occurrence_Of (Proc, Loc);
+ Object_RPC_Receiver : Entity_Id;
+ RPC_Receiver_Stream : Entity_Id;
+ RPC_Receiver_Result : Entity_Id;
- else
- Prepend_To (Param_Assoc,
- Unchecked_Convert_To (RACW_Type,
- New_Occurrence_Of (RAS_Parameter, Loc)));
+ Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type);
- RACW_Primitive_Name :=
- Make_Selected_Component (Loc,
- Prefix =>
- New_Occurrence_Of (Scope (RACW_Type), Loc),
- Selector_Name =>
- Make_Identifier (Loc, Name_Call));
+ begin
+ if Stub_Elements /= Empty_Stub_Structure then
+ Stub_Type := Stub_Elements.Stub_Type;
+ Stub_Type_Access := Stub_Elements.Stub_Type_Access;
+ RPC_Receiver_Decl := Stub_Elements.RPC_Receiver_Decl;
+ Existing := True;
+ return;
end if;
- if Is_Function then
- Append_To (Stmts,
- Make_Return_Statement (Loc,
- Expression =>
- Make_Function_Call (Loc,
- Name =>
- RACW_Primitive_Name,
- Parameter_Associations => Param_Assoc)));
-
- else
- Append_To (Stmts,
- Make_Procedure_Call_Statement (Loc,
- Name =>
- RACW_Primitive_Name,
- Parameter_Associations => Param_Assoc));
- end if;
+ Existing := False;
+ Stub_Type :=
+ Make_Defining_Identifier (Loc, New_Internal_Name ('S'));
+ Stub_Type_Access :=
+ Make_Defining_Identifier (Loc, New_Internal_Name ('S'));
+ Object_RPC_Receiver :=
+ Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
+ RPC_Receiver_Stream :=
+ Make_Defining_Identifier (Loc, Name_S);
+ RPC_Receiver_Result :=
+ Make_Defining_Identifier (Loc, Name_R);
- -- Build the complete subprogram
+ -- The stub type definition below must match exactly the one in
+ -- s-parint.ads, since unchecked conversions will be used in
+ -- s-parint.adb to modify pointers passed to Get_Unique_Remote_Pointer.
- if Is_Function then
- Proc_Spec :=
- Make_Function_Specification (Loc,
- Defining_Unit_Name => Proc,
- Parameter_Specifications => Param_Specs,
- Subtype_Mark =>
- New_Occurrence_Of (
- Entity (Subtype_Mark (Spec)), Loc));
+ Stub_Type_Declaration :=
+ Make_Full_Type_Declaration (Loc,
+ Defining_Identifier => Stub_Type,
+ Type_Definition =>
+ Make_Record_Definition (Loc,
+ Tagged_Present => True,
+ Limited_Present => True,
+ Component_List =>
+ Make_Component_List (Loc,
+ Component_Items => New_List (
- Set_Ekind (Proc, E_Function);
- Set_Etype (Proc,
- New_Occurrence_Of (Entity (Subtype_Mark (Spec)), Loc));
+ Make_Component_Declaration (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc, Name_Origin),
+ Component_Definition =>
+ Make_Component_Definition (Loc,
+ Aliased_Present => False,
+ Subtype_Indication =>
+ New_Occurrence_Of (RTE (RE_Partition_ID), Loc))),
- else
- Proc_Spec :=
- Make_Procedure_Specification (Loc,
- Defining_Unit_Name => Proc,
- Parameter_Specifications => Param_Specs);
+ Make_Component_Declaration (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc, Name_Receiver),
+ Component_Definition =>
+ Make_Component_Definition (Loc,
+ Aliased_Present => False,
+ Subtype_Indication =>
+ New_Occurrence_Of (RTE (RE_Unsigned_64), Loc))),
- Set_Ekind (Proc, E_Procedure);
- Set_Etype (Proc, Standard_Void_Type);
- end if;
+ Make_Component_Declaration (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc, Name_Addr),
+ Component_Definition =>
+ Make_Component_Definition (Loc,
+ Aliased_Present => False,
+ Subtype_Indication =>
+ New_Occurrence_Of (RTE (RE_Unsigned_64), Loc))),
- Discard_Node (
- Make_Subprogram_Body (Loc,
- Specification => Proc_Spec,
- Declarations => New_List,
- Handled_Statement_Sequence =>
- Make_Handled_Sequence_Of_Statements (Loc,
- Statements => Stmts)));
+ 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)))))));
- Set_TSS (Fat_Type, Proc);
- end Add_RAS_Dereference_TSS;
+ Append_To (Decls, Stub_Type_Declaration);
+ Analyze (Stub_Type_Declaration);
- -------------------------------
- -- Add_RAS_Proxy_And_Analyze --
- -------------------------------
+ -- This is in no way a type derivation, but we fake it to make
+ -- sure that the dispatching table gets built with the corresponding
+ -- primitive operations at the right place.
- procedure Add_RAS_Proxy_And_Analyze
- (Decls : List_Id;
- Vis_Decl : Node_Id;
- All_Calls_Remote_E : Entity_Id;
- Proxy_Object_Addr : out Entity_Id)
- is
- Loc : constant Source_Ptr := Sloc (Vis_Decl);
+ Derive_Subprograms (Parent_Type => Designated_Type,
+ Derived_Type => Stub_Type);
- Subp_Name : constant Entity_Id :=
- Defining_Unit_Name (Specification (Vis_Decl));
+ Stub_Type_Access_Declaration :=
+ Make_Full_Type_Declaration (Loc,
+ Defining_Identifier => Stub_Type_Access,
+ Type_Definition =>
+ Make_Access_To_Object_Definition (Loc,
+ All_Present => True,
+ Subtype_Indication => New_Occurrence_Of (Stub_Type, Loc)));
- Pkg_Name : constant Entity_Id :=
- Make_Defining_Identifier (Loc,
- Chars =>
- New_External_Name (Chars (Subp_Name), 'P', -1));
+ Append_To (Decls, Stub_Type_Access_Declaration);
+ Analyze (Stub_Type_Access_Declaration);
- Proxy_Type : constant Entity_Id :=
- Make_Defining_Identifier (Loc,
- Chars =>
- New_External_Name (
- Related_Id => Chars (Subp_Name),
- Suffix => 'P'));
+ if not Is_RAS then
+ Append_To (Decls,
+ Make_Subprogram_Declaration (Loc,
+ Build_RPC_Receiver_Specification (
+ RPC_Receiver => Object_RPC_Receiver,
+ Stream_Parameter => RPC_Receiver_Stream,
+ Result_Parameter => RPC_Receiver_Result)));
+ end if;
- Proxy_Type_Full_View : constant Entity_Id :=
- Make_Defining_Identifier (Loc,
- Chars (Proxy_Type));
+ RPC_Receiver_Decl := Last (Decls);
+ Stubs_Table.Set (Designated_Type,
+ (Stub_Type => Stub_Type,
+ Stub_Type_Access => Stub_Type_Access,
+ RPC_Receiver_Decl => RPC_Receiver_Decl,
+ RACW_Type => RACW_Type));
+ end Add_Stub_Type;
- Subp_Decl_Spec : constant Node_Id :=
- Build_RAS_Primitive_Specification
- (Subp_Spec => Specification (Vis_Decl),
- Remote_Object_Type => Proxy_Type);
+ ----------------------------------
+ -- Assign_Subprogram_Identifier --
+ ----------------------------------
- Subp_Body_Spec : constant Node_Id :=
- Build_RAS_Primitive_Specification
- (Subp_Spec => Specification (Vis_Decl),
- Remote_Object_Type => Proxy_Type);
+ procedure Assign_Subprogram_Identifier
+ (Def : Entity_Id;
+ Spn : Int;
+ Id : out String_Id)
+ is
+ N : constant Name_Id := Chars (Def);
- Vis_Decls : constant List_Id := New_List;
- Pvt_Decls : constant List_Id := New_List;
- Actuals : constant List_Id := New_List;
- Formal : Node_Id;
- Perform_Call : Node_Id;
+ Overload_Order : constant Int :=
+ Overload_Counter_Table.Get (N) + 1;
begin
- -- type subpP is tagged limited private;
-
- Append_To (Vis_Decls,
- Make_Private_Type_Declaration (Loc,
- Defining_Identifier => Proxy_Type,
- Tagged_Present => True,
- Limited_Present => True));
+ Overload_Counter_Table.Set (N, Overload_Order);
- -- [subprogram] Call
- -- (Self : access subpP;
- -- ...other-formals...)
- -- [return T];
+ Get_Name_String (N);
- Append_To (Vis_Decls,
- Make_Subprogram_Declaration (Loc,
- Specification => Subp_Decl_Spec));
+ -- Homonym handling: as in Exp_Dbug, but much simpler,
+ -- because the only entities for which we have to generate
+ -- names here need only to be disambiguated within their
+ -- own scope.
- -- A : constant System.Address;
+ if Overload_Order > 1 then
+ Name_Buffer (Name_Len + 1 .. Name_Len + 2) := "__";
+ Name_Len := Name_Len + 2;
+ Add_Nat_To_Name_Buffer (Overload_Order);
+ end if;
- Proxy_Object_Addr := Make_Defining_Identifier (Loc, Name_uA);
+ Id := String_From_Name_Buffer;
+ Subprogram_Identifier_Table.Set (Def,
+ Subprogram_Identifiers'(Str_Identifier => Id, Int_Identifier => Spn));
+ end Assign_Subprogram_Identifier;
- Append_To (Vis_Decls,
- Make_Object_Declaration (Loc,
- Defining_Identifier =>
- Proxy_Object_Addr,
- Constant_Present =>
- True,
- Object_Definition =>
- New_Occurrence_Of (RTE (RE_Address), Loc)));
+ ---------------------------------
+ -- Build_General_Calling_Stubs --
+ ---------------------------------
- -- private
+ procedure Build_General_Calling_Stubs
+ (Decls : List_Id;
+ Statements : List_Id;
+ Target_Partition : Entity_Id;
+ RPC_Receiver : Node_Id;
+ Subprogram_Id : Node_Id;
+ Asynchronous : Node_Id := Empty;
+ Is_Known_Asynchronous : Boolean := False;
+ Is_Known_Non_Asynchronous : Boolean := False;
+ Is_Function : Boolean;
+ Spec : Node_Id;
+ Stub_Type : Entity_Id := Empty;
+ RACW_Type : Entity_Id := Empty;
+ Nod : Node_Id)
+ is
+ Loc : constant Source_Ptr := Sloc (Nod);
- -- type subpP is tagged limited record
- -- All_Calls_Remote : Boolean := [All_Calls_Remote?];
- -- ...
- -- end record;
+ Stream_Parameter : Node_Id;
+ -- Name of the stream used to transmit parameters to the remote package
- Append_To (Pvt_Decls,
- Make_Full_Type_Declaration (Loc,
- Defining_Identifier =>
- Proxy_Type_Full_View,
- Type_Definition =>
- Build_Remote_Subprogram_Proxy_Type (Loc,
- New_Occurrence_Of (All_Calls_Remote_E, Loc))));
+ Result_Parameter : Node_Id;
+ -- Name of the result parameter (in non-APC cases) which get the
+ -- result of the remote subprogram.
- -- Trick semantic analysis into swapping the public and
- -- full view when freezing the public view.
+ Exception_Return_Parameter : Node_Id;
+ -- Name of the parameter which will hold the exception sent by the
+ -- remote subprogram.
- Set_Comes_From_Source (Proxy_Type_Full_View, True);
+ Current_Parameter : Node_Id;
+ -- Current parameter being handled
- -- procedure Call
- -- (Self : access O;
- -- ...other-formals...) is
- -- begin
- -- P (...other-formals...);
- -- end Call;
+ Ordered_Parameters_List : constant List_Id :=
+ Build_Ordered_Parameters_List (Spec);
- -- function Call
- -- (Self : access O;
- -- ...other-formals...)
- -- return T is
- -- begin
- -- return F (...other-formals...);
- -- end Call;
+ Asynchronous_Statements : List_Id := No_List;
+ Non_Asynchronous_Statements : List_Id := No_List;
+ -- Statements specifics to the Asynchronous/Non-Asynchronous cases
- if Nkind (Subp_Decl_Spec) = N_Procedure_Specification then
- Perform_Call :=
- Make_Procedure_Call_Statement (Loc,
- Name =>
- New_Occurrence_Of (Subp_Name, Loc),
- Parameter_Associations =>
- Actuals);
- else
- Perform_Call :=
- Make_Return_Statement (Loc,
- Expression =>
- Make_Function_Call (Loc,
- Name =>
- New_Occurrence_Of (Subp_Name, Loc),
- Parameter_Associations =>
- Actuals));
- end if;
+ Extra_Formal_Statements : constant List_Id := New_List;
+ -- List of statements for extra formal parameters. It will appear after
+ -- the regular statements for writing out parameters.
- Formal := First (Parameter_Specifications (Subp_Decl_Spec));
- pragma Assert (Present (Formal));
- Next (Formal);
+ pragma Warnings (Off);
+ pragma Unreferenced (RACW_Type);
+ -- Used only for the PolyORB case
+ pragma Warnings (On);
- while Present (Formal) loop
- Append_To (Actuals, New_Occurrence_Of (
- Defining_Identifier (Formal), Loc));
- Next (Formal);
- end loop;
+ begin
+ -- The general form of a calling stub for a given subprogram is:
- -- O : aliased subpP;
+ -- procedure X (...) is
+ -- P : constant Partition_ID := RCI_Cache.Get_Active_Partition_ID;
+ -- Stream, Result : aliased System.RPC.Params_Stream_Type (0);
+ -- begin
+ -- Put_Package_RPC_Receiver_In_Stream; (the package RPC receiver
+ -- comes from RCI_Cache.Get_RCI_Package_Receiver)
+ -- Put_Subprogram_Id_In_Stream;
+ -- Put_Parameters_In_Stream;
+ -- Do_RPC (Stream, Result);
+ -- Read_Exception_Occurrence_From_Result; Raise_It;
+ -- Read_Out_Parameters_And_Function_Return_From_Stream;
+ -- end X;
- Append_To (Pvt_Decls,
- Make_Object_Declaration (Loc,
- Defining_Identifier =>
- Make_Defining_Identifier (Loc,
- Name_uO),
- Aliased_Present =>
- True,
- Object_Definition =>
- New_Occurrence_Of (Proxy_Type, Loc)));
+ -- There are some variations: Do_APC is called for an asynchronous
+ -- procedure and the part after the call is completely ommitted
+ -- as well as the declaration of Result. For a function call,
+ -- 'Input is always used to read the result even if it is constrained.
- -- A : constant System.Address := O'Address;
+ Stream_Parameter :=
+ Make_Defining_Identifier (Loc, New_Internal_Name ('S'));
- Append_To (Pvt_Decls,
+ Append_To (Decls,
Make_Object_Declaration (Loc,
- Defining_Identifier =>
- Make_Defining_Identifier (Loc,
- Chars (Proxy_Object_Addr)),
- Constant_Present =>
- True,
- Object_Definition =>
- New_Occurrence_Of (RTE (RE_Address), Loc),
- Expression =>
- Make_Attribute_Reference (Loc,
- Prefix => New_Occurrence_Of (
- Defining_Identifier (Last (Pvt_Decls)), Loc),
- Attribute_Name =>
- Name_Address)));
+ Defining_Identifier => Stream_Parameter,
+ Aliased_Present => True,
+ Object_Definition =>
+ Make_Subtype_Indication (Loc,
+ Subtype_Mark =>
+ New_Occurrence_Of (RTE (RE_Params_Stream_Type), Loc),
+ Constraint =>
+ Make_Index_Or_Discriminant_Constraint (Loc,
+ Constraints =>
+ New_List (Make_Integer_Literal (Loc, 0))))));
- Append_To (Decls,
- Make_Package_Declaration (Loc,
- Specification => Make_Package_Specification (Loc,
- Defining_Unit_Name => Pkg_Name,
- Visible_Declarations => Vis_Decls,
- Private_Declarations => Pvt_Decls,
- End_Label => Empty)));
- Analyze (Last (Decls));
+ if not Is_Known_Asynchronous then
+ Result_Parameter :=
+ Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
- Append_To (Decls,
- Make_Package_Body (Loc,
- Defining_Unit_Name =>
- Make_Defining_Identifier (Loc,
- Chars (Pkg_Name)),
- Declarations => New_List (
- Make_Subprogram_Body (Loc,
- Specification =>
- Subp_Body_Spec,
- Declarations => New_List,
- Handled_Statement_Sequence =>
- Make_Handled_Sequence_Of_Statements (Loc,
- Statements => New_List (Perform_Call))))));
- Analyze (Last (Decls));
- end Add_RAS_Proxy_And_Analyze;
+ Append_To (Decls,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Result_Parameter,
+ Aliased_Present => True,
+ Object_Definition =>
+ Make_Subtype_Indication (Loc,
+ Subtype_Mark =>
+ New_Occurrence_Of (RTE (RE_Params_Stream_Type), Loc),
+ Constraint =>
+ Make_Index_Or_Discriminant_Constraint (Loc,
+ Constraints =>
+ New_List (Make_Integer_Literal (Loc, 0))))));
- -----------------------
- -- Add_RAST_Features --
- -----------------------
+ Exception_Return_Parameter :=
+ Make_Defining_Identifier (Loc, New_Internal_Name ('E'));
- procedure Add_RAST_Features (Vis_Decl : Node_Id) is
- begin
- -- Do not add attributes more than once in any case. This should
- -- be replaced by an assert or this comment removed if we decide
- -- that this is normal to be called several times ???
+ Append_To (Decls,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Exception_Return_Parameter,
+ Object_Definition =>
+ New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc)));
- if Present (TSS (Equivalent_Type (Defining_Identifier (Vis_Decl)),
- TSS_RAS_Access))
- then
- return;
+ else
+ Result_Parameter := Empty;
+ Exception_Return_Parameter := Empty;
end if;
- Add_RAS_Dereference_TSS (Vis_Decl);
- Add_RAS_Access_TSS (Vis_Decl);
- end Add_RAST_Features;
+ -- Put first the RPC receiver corresponding to the remote package
- -----------------------------------------
- -- Add_Receiving_Stubs_To_Declarations --
- -----------------------------------------
+ Append_To (Statements,
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ New_Occurrence_Of (RTE (RE_Unsigned_64), Loc),
+ Attribute_Name => Name_Write,
+ Expressions => New_List (
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ New_Occurrence_Of (Stream_Parameter, Loc),
+ Attribute_Name =>
+ Name_Access),
+ RPC_Receiver)));
- procedure Add_Receiving_Stubs_To_Declarations
- (Pkg_Spec : Node_Id;
- Decls : List_Id)
- is
- Loc : constant Source_Ptr := Sloc (Pkg_Spec);
+ -- Then put the Subprogram_Id of the subprogram we want to call in
+ -- the stream.
- Stream_Parameter : Node_Id;
- Result_Parameter : Node_Id;
+ Append_To (Statements,
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc),
+ Attribute_Name =>
+ Name_Write,
+ Expressions => New_List (
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ New_Occurrence_Of (Stream_Parameter, Loc),
+ Attribute_Name => Name_Access),
+ Subprogram_Id)));
- Pkg_RPC_Receiver : Node_Id;
- Pkg_RPC_Receiver_Spec : Node_Id;
- Pkg_RPC_Receiver_Decls : List_Id;
- 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
+ Current_Parameter := First (Ordered_Parameters_List);
+ while Present (Current_Parameter) loop
+ declare
+ Typ : constant Node_Id :=
+ Parameter_Type (Current_Parameter);
+ Etyp : Entity_Id;
+ Constrained : Boolean;
+ Value : Node_Id;
+ Extra_Parameter : Entity_Id;
- Lookup_RAS_Info : constant Entity_Id :=
- Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
- -- A remote subprogram is created to allow peers to look up
- -- RAS information using subprogram ids.
+ begin
+ if Is_RACW_Controlling_Formal (Current_Parameter, Stub_Type) then
- Subp_Id : Node_Id;
- -- Subprogram_Id as read from the incoming stream
+ -- In the case of a controlling formal argument, we marshall
+ -- its addr field rather than the local stub.
- Current_Declaration : Node_Id;
- Current_Subprogram_Number : Int := First_RCI_Subprogram_Id;
- Current_Stubs : Node_Id;
+ Append_To (Statements,
+ Pack_Node_Into_Stream (Loc,
+ Stream => Stream_Parameter,
+ Object =>
+ Make_Selected_Component (Loc,
+ Prefix =>
+ New_Occurrence_Of (
+ Defining_Identifier (Current_Parameter), Loc),
+ Selector_Name =>
+ Make_Identifier (Loc, Name_Addr)),
+ Etyp => RTE (RE_Unsigned_64)));
- Subp_Info_Array : constant Entity_Id :=
- Make_Defining_Identifier (Loc, New_Internal_Name ('I'));
+ else
+ Value := New_Occurrence_Of
+ (Defining_Identifier (Current_Parameter), Loc);
- Subp_Info_List : constant List_Id := New_List;
+ -- Access type parameters are transmitted as in out
+ -- parameters. However, a dereference is needed so that
+ -- we marshall the designated object.
- Register_Pkg_Actuals : constant List_Id := New_List;
+ if Nkind (Typ) = N_Access_Definition then
+ Value := Make_Explicit_Dereference (Loc, Value);
+ Etyp := Etype (Subtype_Mark (Typ));
+ else
+ Etyp := Etype (Typ);
+ end if;
- Dummy_Register_Name : Name_Id;
- Dummy_Register_Spec : Node_Id;
- Dummy_Register_Decl : Node_Id;
- Dummy_Register_Body : Node_Id;
+ Constrained :=
+ Is_Constrained (Etyp) or else Is_Elementary_Type (Etyp);
- All_Calls_Remote_E : Entity_Id;
- Proxy_Object_Addr : Entity_Id;
+ -- Any parameter but unconstrained out parameters are
+ -- transmitted to the peer.
- 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.
+ if In_Present (Current_Parameter)
+ or else not Out_Present (Current_Parameter)
+ or else not Constrained
+ then
+ Append_To (Statements,
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ New_Occurrence_Of (Etyp, Loc),
+ Attribute_Name => Output_From_Constrained (Constrained),
+ Expressions => New_List (
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ New_Occurrence_Of (Stream_Parameter, Loc),
+ Attribute_Name => Name_Access),
+ Value)));
+ end if;
+ end if;
- ---------------------
- -- Append_Stubs_To --
- ---------------------
+ -- If the current parameter has a dynamic constrained status,
+ -- then this status is transmitted as well.
+ -- This should be done for accessibility as well ???
- 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.
+ if Nkind (Typ) /= N_Access_Definition
+ and then Need_Extra_Constrained (Current_Parameter)
+ then
+ -- In this block, we do not use the extra formal that has been
+ -- created because it does not exist at the time of expansion
+ -- when building calling stubs for remote access to subprogram
+ -- types. We create an extra variable of this type and push it
+ -- in the stream after the regular parameters.
- Append_To (Actuals,
- New_Occurrence_Of (Result_Parameter, Loc));
- end if;
+ Extra_Parameter := Make_Defining_Identifier
+ (Loc, New_Internal_Name ('P'));
- Append_To (RPC_Receiver_Cases,
- Make_Case_Statement_Alternative (Loc,
- Discrete_Choices =>
- New_List (
- Make_Integer_Literal (Loc, Subprogram_Number)),
+ Append_To (Decls,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Extra_Parameter,
+ Constant_Present => True,
+ Object_Definition =>
+ New_Occurrence_Of (Standard_Boolean, Loc),
+ Expression =>
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ New_Occurrence_Of (
+ Defining_Identifier (Current_Parameter), Loc),
+ Attribute_Name => Name_Constrained)));
- Statements =>
- New_List (
- Make_Procedure_Call_Statement (Loc,
- Name =>
- New_Occurrence_Of (
- Defining_Entity (Stubs), Loc),
- Parameter_Associations =>
- Actuals))));
- end Append_Stubs_To;
+ Append_To (Extra_Formal_Statements,
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ New_Occurrence_Of (Standard_Boolean, Loc),
+ Attribute_Name =>
+ Name_Write,
+ Expressions => New_List (
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ New_Occurrence_Of (Stream_Parameter, Loc),
+ Attribute_Name =>
+ Name_Access),
+ New_Occurrence_Of (Extra_Parameter, Loc))));
+ end if;
- -- Start of processing for Add_Receiving_Stubs_To_Declarations
+ Next (Current_Parameter);
+ end;
+ end loop;
- begin
- -- Building receiving stubs consist in several operations:
+ -- Append the formal statements list to the statements
- -- - 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
+ Append_List_To (Statements, Extra_Formal_Statements);
- -- - 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
+ if not Is_Known_Non_Asynchronous then
- -- - 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 the call to System.RPC.Do_APC
- Stream_Parameter :=
- Make_Defining_Identifier (Loc, New_Internal_Name ('S'));
- Result_Parameter :=
- Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
- Subp_Id :=
- Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
+ Asynchronous_Statements := New_List (
+ Make_Procedure_Call_Statement (Loc,
+ Name =>
+ New_Occurrence_Of (RTE (RE_Do_Apc), Loc),
+ Parameter_Associations => New_List (
+ New_Occurrence_Of (Target_Partition, Loc),
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ New_Occurrence_Of (Stream_Parameter, Loc),
+ Attribute_Name =>
+ Name_Access))));
+ else
+ Asynchronous_Statements := No_List;
+ end if;
- Pkg_RPC_Receiver :=
- Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
+ if not Is_Known_Asynchronous then
- -- The parameters of the package RPC receiver are made of two
- -- streams, an input one and an output one.
+ -- Build the call to System.RPC.Do_RPC
- Pkg_RPC_Receiver_Spec :=
- Build_RPC_Receiver_Specification
- (RPC_Receiver => Pkg_RPC_Receiver,
- Stream_Parameter => Stream_Parameter,
- Result_Parameter => Result_Parameter);
+ Non_Asynchronous_Statements := New_List (
+ Make_Procedure_Call_Statement (Loc,
+ Name =>
+ New_Occurrence_Of (RTE (RE_Do_Rpc), Loc),
+ Parameter_Associations => New_List (
+ New_Occurrence_Of (Target_Partition, Loc),
- Pkg_RPC_Receiver_Decls := New_List (
- Make_Object_Declaration (Loc,
- Defining_Identifier => Subp_Id,
- Object_Definition =>
- New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc)));
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ New_Occurrence_Of (Stream_Parameter, Loc),
+ Attribute_Name =>
+ Name_Access),
- Pkg_RPC_Receiver_Statements := New_List (
- Make_Attribute_Reference (Loc,
- Prefix =>
- New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc),
- Attribute_Name =>
- Name_Read,
- Expressions => New_List (
- New_Occurrence_Of (Stream_Parameter, Loc),
- New_Occurrence_Of (Subp_Id, Loc))));
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ New_Occurrence_Of (Result_Parameter, Loc),
+ Attribute_Name =>
+ Name_Access))));
- -- 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.
+ -- Read the exception occurrence from the result stream and
+ -- reraise it. It does no harm if this is a Null_Occurrence since
+ -- this does nothing.
- 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),
+ Append_To (Non_Asynchronous_Statements,
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc),
+
+ Attribute_Name =>
+ Name_Read,
+
+ Expressions => New_List (
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ New_Occurrence_Of (Result_Parameter, Loc),
+ Attribute_Name =>
+ Name_Access),
+ New_Occurrence_Of (Exception_Return_Parameter, Loc))));
+
+ Append_To (Non_Asynchronous_Statements,
+ Make_Procedure_Call_Statement (Loc,
+ Name =>
+ New_Occurrence_Of (RTE (RE_Reraise_Occurrence), Loc),
+ Parameter_Associations => New_List (
+ New_Occurrence_Of (Exception_Return_Parameter, Loc))));
+
+ if Is_Function then
+
+ -- If this is a function call, then read the value and return
+ -- it. The return value is written/read using 'Output/'Input.
+
+ Append_To (Non_Asynchronous_Statements,
+ Make_Tag_Check (Loc,
+ Make_Return_Statement (Loc,
+ Expression =>
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ New_Occurrence_Of (
+ Etype (Subtype_Mark (Spec)), Loc),
+
+ Attribute_Name => Name_Input,
+
+ Expressions => New_List (
Make_Attribute_Reference (Loc,
- Prefix =>
- New_Occurrence_Of (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))))));
+ Prefix =>
+ New_Occurrence_Of (Result_Parameter, Loc),
+ Attribute_Name => Name_Access))))));
- All_Calls_Remote_E := Boolean_Literals (
- Has_All_Calls_Remote (Defining_Entity (Pkg_Spec)));
+ else
+ -- Loop around parameters and assign out (or in out) parameters.
+ -- In the case of RACW, controlling arguments cannot possibly
+ -- have changed since they are remote, so we do not read them
+ -- from the stream.
- -- Build a subprogram for RAS information lookups
+ Current_Parameter := First (Ordered_Parameters_List);
+ while Present (Current_Parameter) loop
+ declare
+ Typ : constant Node_Id :=
+ Parameter_Type (Current_Parameter);
+ Etyp : Entity_Id;
+ Value : Node_Id;
- 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);
+ begin
+ Value :=
+ New_Occurrence_Of
+ (Defining_Identifier (Current_Parameter), Loc);
- Current_Stubs := Build_Subprogram_Receiving_Stubs
- (Vis_Decl => Current_Declaration,
- Asynchronous => False);
- Append_To (Decls, Current_Stubs);
- Analyze (Current_Stubs);
+ if Nkind (Typ) = N_Access_Definition then
+ Value := Make_Explicit_Dereference (Loc, Value);
+ Etyp := Etype (Subtype_Mark (Typ));
+ else
+ Etyp := Etype (Typ);
+ end if;
- Append_Stubs_To (Pkg_RPC_Receiver_Cases,
- Declaration =>
- Current_Declaration,
- Stubs =>
- Current_Stubs,
- Subprogram_Number => 1);
+ if (Out_Present (Current_Parameter)
+ or else Nkind (Typ) = N_Access_Definition)
+ and then Etyp /= Stub_Type
+ then
+ Append_To (Non_Asynchronous_Statements,
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ New_Occurrence_Of (Etyp, Loc),
- -- 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.
+ Attribute_Name => Name_Read,
- Current_Declaration := First (Visible_Declarations (Pkg_Spec));
- while Current_Declaration /= Empty loop
- if Nkind (Current_Declaration) = N_Subprogram_Declaration
- and then Comes_From_Source (Current_Declaration)
- then
- pragma Assert (Current_Subprogram_Number =
- Get_Subprogram_Id (Defining_Unit_Name (Specification (
- Current_Declaration))));
-
- -- 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
- (Defining_Unit_Name (Specification
- (Current_Declaration))));
-
- 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);
-
- -- 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);
- Current_Subprogram_Number := Current_Subprogram_Number + 1;
+ Expressions => New_List (
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ New_Occurrence_Of (Result_Parameter, Loc),
+ Attribute_Name =>
+ Name_Access),
+ Value)));
+ end if;
+ end;
+
+ Next (Current_Parameter);
+ end loop;
end if;
+ end if;
- Next (Current_Declaration);
- end loop;
+ if Is_Known_Asynchronous then
+ Append_List_To (Statements, Asynchronous_Statements);
- -- 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.
+ elsif Is_Known_Non_Asynchronous then
+ Append_List_To (Statements, Non_Asynchronous_Statements);
- 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))));
+ else
+ pragma Assert (Present (Asynchronous));
+ Prepend_To (Asynchronous_Statements,
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Occurrence_Of (Standard_Boolean, Loc),
+ Attribute_Name => Name_Write,
+ Expressions => New_List (
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Occurrence_Of (Stream_Parameter, Loc),
+ Attribute_Name => Name_Access),
+ New_Occurrence_Of (Standard_True, Loc))));
- Append_To (Pkg_RPC_Receiver_Statements,
- Make_Case_Statement (Loc,
- Expression =>
- New_Occurrence_Of (Subp_Id, Loc),
- Alternatives => Pkg_RPC_Receiver_Cases));
+ Prepend_To (Non_Asynchronous_Statements,
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Occurrence_Of (Standard_Boolean, Loc),
+ Attribute_Name => Name_Write,
+ Expressions => New_List (
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Occurrence_Of (Stream_Parameter, Loc),
+ Attribute_Name => Name_Access),
+ New_Occurrence_Of (Standard_False, Loc))));
- Append_To (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 (Statements,
+ Make_Implicit_If_Statement (Nod,
+ Condition => Asynchronous,
+ Then_Statements => Asynchronous_Statements,
+ Else_Statements => Non_Asynchronous_Statements));
+ end if;
+ end Build_General_Calling_Stubs;
- 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));
+ ------------------------------
+ -- Build_Get_Unique_RP_Call --
+ ------------------------------
- Pkg_RPC_Receiver_Body :=
- Make_Subprogram_Body (Loc,
- Specification => Pkg_RPC_Receiver_Spec,
- Declarations => Pkg_RPC_Receiver_Decls,
- Handled_Statement_Sequence =>
- Make_Handled_Sequence_Of_Statements (Loc,
- Statements => Pkg_RPC_Receiver_Statements));
+ function Build_Get_Unique_RP_Call
+ (Loc : Source_Ptr;
+ Pointer : Entity_Id;
+ Stub_Type : Entity_Id) return List_Id
+ is
+ begin
+ return New_List (
+ Make_Procedure_Call_Statement (Loc,
+ Name =>
+ New_Occurrence_Of (RTE (RE_Get_Unique_Remote_Pointer), Loc),
+ Parameter_Associations => New_List (
+ Unchecked_Convert_To (RTE (RE_RACW_Stub_Type_Access),
+ New_Occurrence_Of (Pointer, Loc)))),
- Append_To (Decls, Pkg_RPC_Receiver_Body);
- Analyze (Pkg_RPC_Receiver_Body);
+ Make_Assignment_Statement (Loc,
+ Name =>
+ Make_Selected_Component (Loc,
+ Prefix =>
+ New_Occurrence_Of (Pointer, Loc),
+ Selector_Name =>
+ New_Occurrence_Of (Tag_Component
+ (Designated_Type (Etype (Pointer))), Loc)),
+ Expression =>
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ New_Occurrence_Of (Stub_Type, Loc),
+ Attribute_Name =>
+ Name_Tag)));
- -- Construction of the dummy package used to register the package
- -- receiving stubs on the nameserver.
+ -- Note: The assignment to Pointer._Tag is safe here because
+ -- we carefully ensured that Stub_Type has exactly the same layout
+ -- as System.Partition_Interface.RACW_Stub_Type.
- Dummy_Register_Name := New_Internal_Name ('P');
+ end Build_Get_Unique_RP_Call;
- Dummy_Register_Spec :=
- Make_Package_Specification (Loc,
- Defining_Unit_Name =>
- Make_Defining_Identifier (Loc, Dummy_Register_Name),
- Visible_Declarations => No_List,
- End_Label => Empty);
+ -----------------------------------
+ -- Build_Ordered_Parameters_List --
+ -----------------------------------
- Dummy_Register_Decl :=
- Make_Package_Declaration (Loc,
- Specification => Dummy_Register_Spec);
+ function Build_Ordered_Parameters_List (Spec : Node_Id) return List_Id is
+ Constrained_List : List_Id;
+ Unconstrained_List : List_Id;
+ Current_Parameter : Node_Id;
- Append_To (Decls, Dummy_Register_Decl);
- Analyze (Dummy_Register_Decl);
+ First_Parameter : Node_Id;
+ For_RAS : Boolean := False;
- Get_Pkg_Name_String (Pkg_Spec);
- Append_To (Register_Pkg_Actuals,
- -- Name
- Make_String_Literal (Loc,
- Strval => String_From_Name_Buffer));
+ begin
+ if not Present (Parameter_Specifications (Spec)) then
+ return New_List;
+ end if;
- Append_To (Register_Pkg_Actuals,
- -- Receiver
- Make_Attribute_Reference (Loc,
- Prefix =>
- New_Occurrence_Of (Pkg_RPC_Receiver, Loc),
- Attribute_Name =>
- Name_Unrestricted_Access));
+ Constrained_List := New_List;
+ Unconstrained_List := New_List;
+ First_Parameter := First (Parameter_Specifications (Spec));
- Append_To (Register_Pkg_Actuals,
- -- Version
- Make_Attribute_Reference (Loc,
- Prefix =>
- New_Occurrence_Of (Defining_Entity (Pkg_Spec), Loc),
- Attribute_Name =>
- Name_Version));
+ if Nkind (Parameter_Type (First_Parameter)) = N_Access_Definition
+ and then Chars (Defining_Identifier (First_Parameter)) = Name_uS
+ then
+ For_RAS := True;
+ end if;
- Append_To (Register_Pkg_Actuals,
- -- Subp_Info
- Make_Attribute_Reference (Loc,
- Prefix =>
- New_Occurrence_Of (Subp_Info_Array, Loc),
- Attribute_Name =>
- Name_Address));
+ -- Loop through the parameters and add them to the right list
- Append_To (Register_Pkg_Actuals,
- -- Subp_Info_Len
- Make_Attribute_Reference (Loc,
- Prefix =>
- New_Occurrence_Of (Subp_Info_Array, Loc),
- Attribute_Name =>
- Name_Length));
+ Current_Parameter := First_Parameter;
+ while Present (Current_Parameter) loop
+ if (Nkind (Parameter_Type (Current_Parameter)) = N_Access_Definition
+ or else
+ Is_Constrained (Etype (Parameter_Type (Current_Parameter)))
+ or else
+ Is_Elementary_Type (Etype (Parameter_Type (Current_Parameter))))
+ and then not (For_RAS and then Current_Parameter = First_Parameter)
+ then
+ Append_To (Constrained_List, New_Copy (Current_Parameter));
+ else
+ Append_To (Unconstrained_List, New_Copy (Current_Parameter));
+ end if;
- Dummy_Register_Body :=
- Make_Package_Body (Loc,
- Defining_Unit_Name =>
- Make_Defining_Identifier (Loc, Dummy_Register_Name),
- Declarations => No_List,
+ Next (Current_Parameter);
+ end loop;
- 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),
+ -- Unconstrained parameters are returned first
- Parameter_Associations => Register_Pkg_Actuals))));
+ Append_List_To (Unconstrained_List, Constrained_List);
- Append_To (Decls, Dummy_Register_Body);
- Analyze (Dummy_Register_Body);
- end Add_Receiving_Stubs_To_Declarations;
+ return Unconstrained_List;
+ end Build_Ordered_Parameters_List;
- -------------------
- -- Add_Stub_Type --
- -------------------
+ ----------------------------------
+ -- Build_Passive_Partition_Stub --
+ ----------------------------------
- procedure Add_Stub_Type
- (Designated_Type : Entity_Id;
- RACW_Type : Entity_Id;
- Decls : List_Id;
- Stub_Type : out Entity_Id;
- Stub_Type_Access : out Entity_Id;
- Object_RPC_Receiver : out Entity_Id;
- Existing : out Boolean)
- is
- Loc : constant Source_Ptr := Sloc (RACW_Type);
+ procedure Build_Passive_Partition_Stub (U : Node_Id) is
+ Pkg_Spec : Node_Id;
+ Pkg_Name : String_Id;
+ L : List_Id;
+ Reg : Node_Id;
+ Loc : constant Source_Ptr := Sloc (U);
- Stub_Elements : constant Stub_Structure :=
- Stubs_Table.Get (Designated_Type);
+ begin
+ -- Verify that the implementation supports distribution, by accessing
+ -- a type defined in the proper version of system.rpc
- Stub_Type_Declaration : Node_Id;
- Stub_Type_Access_Declaration : Node_Id;
- Object_RPC_Receiver_Declaration : Node_Id;
+ declare
+ Dist_OK : Entity_Id;
+ pragma Warnings (Off, Dist_OK);
+ begin
+ Dist_OK := RTE (RE_Params_Stream_Type);
+ end;
- RPC_Receiver_Stream : Entity_Id;
- RPC_Receiver_Result : Entity_Id;
+ -- Use body if present, spec otherwise
- begin
- if Stub_Elements /= Empty_Stub_Structure then
- Stub_Type := Stub_Elements.Stub_Type;
- Stub_Type_Access := Stub_Elements.Stub_Type_Access;
- Object_RPC_Receiver := Stub_Elements.Object_RPC_Receiver;
- Existing := True;
- return;
+ if Nkind (U) = N_Package_Declaration then
+ Pkg_Spec := Specification (U);
+ L := Visible_Declarations (Pkg_Spec);
+ else
+ Pkg_Spec := Parent (Corresponding_Spec (U));
+ L := Declarations (U);
end if;
- Existing := False;
- Stub_Type :=
- Make_Defining_Identifier (Loc, New_Internal_Name ('S'));
- Stub_Type_Access :=
- Make_Defining_Identifier (Loc, New_Internal_Name ('S'));
- Object_RPC_Receiver :=
- Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
- RPC_Receiver_Stream :=
- Make_Defining_Identifier (Loc, New_Internal_Name ('S'));
- RPC_Receiver_Result :=
- Make_Defining_Identifier (Loc, New_Internal_Name ('S'));
- Stubs_Table.Set (Designated_Type,
- (Stub_Type => Stub_Type,
- Stub_Type_Access => Stub_Type_Access,
- Object_RPC_Receiver => Object_RPC_Receiver,
- RPC_Receiver_Stream => RPC_Receiver_Stream,
- RPC_Receiver_Result => RPC_Receiver_Result,
- RACW_Type => RACW_Type));
-
- -- The stub type definition below must match exactly the one in
- -- s-parint.ads, since unchecked conversions will be used in
- -- s-parint.adb to modify pointers passed to Get_Unique_Remote_Pointer.
-
- Stub_Type_Declaration :=
- Make_Full_Type_Declaration (Loc,
- Defining_Identifier => Stub_Type,
- Type_Definition =>
- Make_Record_Definition (Loc,
- Tagged_Present => True,
- Limited_Present => True,
- Component_List =>
- Make_Component_List (Loc,
- Component_Items => New_List (
+ Get_Library_Unit_Name_String (Pkg_Spec);
+ Pkg_Name := String_From_Name_Buffer;
+ Reg :=
+ Make_Procedure_Call_Statement (Loc,
+ Name =>
+ New_Occurrence_Of (RTE (RE_Register_Passive_Package), Loc),
+ Parameter_Associations => New_List (
+ Make_String_Literal (Loc, Pkg_Name),
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ New_Occurrence_Of (Defining_Entity (Pkg_Spec), Loc),
+ Attribute_Name =>
+ Name_Version)));
+ Append_To (L, Reg);
+ Analyze (Reg);
+ end Build_Passive_Partition_Stub;
- Make_Component_Declaration (Loc,
- Defining_Identifier =>
- Make_Defining_Identifier (Loc, Name_Origin),
- Component_Definition =>
- Make_Component_Definition (Loc,
- Aliased_Present => False,
- Subtype_Indication =>
- New_Occurrence_Of (RTE (RE_Partition_ID), Loc))),
+ ----------------------------------------
+ -- Build_Remote_Subprogram_Proxy_Type --
+ ----------------------------------------
- Make_Component_Declaration (Loc,
- Defining_Identifier =>
- Make_Defining_Identifier (Loc, Name_Receiver),
- Component_Definition =>
- Make_Component_Definition (Loc,
- Aliased_Present => False,
- Subtype_Indication =>
- New_Occurrence_Of (RTE (RE_Unsigned_64), Loc))),
+ function Build_Remote_Subprogram_Proxy_Type
+ (Loc : Source_Ptr;
+ ACR_Expression : Node_Id) return Node_Id
+ is
+ begin
+ return
+ Make_Record_Definition (Loc,
+ Tagged_Present => True,
+ Limited_Present => True,
+ Component_List =>
+ Make_Component_List (Loc,
- Make_Component_Declaration (Loc,
- Defining_Identifier =>
- Make_Defining_Identifier (Loc, Name_Addr),
- Component_Definition =>
- Make_Component_Definition (Loc,
- Aliased_Present => False,
- Subtype_Indication =>
- New_Occurrence_Of (RTE (RE_Unsigned_64), Loc))),
+ 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),
- 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)))))));
+ 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)),
- Append_To (Decls, Stub_Type_Declaration);
- Analyze (Stub_Type_Declaration);
+ 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))))));
+ end Build_Remote_Subprogram_Proxy_Type;
- -- This is in no way a type derivation, but we fake it to make
- -- sure that the dispatching table gets built with the corresponding
- -- primitive operations at the right place.
+ -----------------------------
+ -- Build_RPC_Receiver_Body --
+ -----------------------------
- Derive_Subprograms (Parent_Type => Designated_Type,
- Derived_Type => Stub_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)
+ is
+ Loc : constant Source_Ptr := Sloc (RPC_Receiver);
- Stub_Type_Access_Declaration :=
- Make_Full_Type_Declaration (Loc,
- Defining_Identifier => Stub_Type_Access,
- Type_Definition =>
- Make_Access_To_Object_Definition (Loc,
- All_Present => True,
- Subtype_Indication => New_Occurrence_Of (Stub_Type, Loc)));
+ 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);
- Append_To (Decls, Stub_Type_Access_Declaration);
- Analyze (Stub_Type_Access_Declaration);
+ RPC_Receiver_Spec :=
+ Build_RPC_Receiver_Specification
+ (RPC_Receiver => RPC_Receiver,
+ Stream_Parameter => Stream,
+ Result_Parameter => Result);
- Object_RPC_Receiver_Declaration :=
- Make_Subprogram_Declaration (Loc,
- Build_RPC_Receiver_Specification (
- RPC_Receiver => Object_RPC_Receiver,
- Stream_Parameter => RPC_Receiver_Stream,
- Result_Parameter => RPC_Receiver_Result));
+ Subp_Id :=
+ Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
- Append_To (Decls, Object_RPC_Receiver_Declaration);
- end Add_Stub_Type;
+ -- 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.
- ---------------------------------
- -- Build_General_Calling_Stubs --
- ---------------------------------
+ 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)))));
- procedure Build_General_Calling_Stubs
- (Decls : List_Id;
- Statements : List_Id;
- Target_Partition : Entity_Id;
- RPC_Receiver : Node_Id;
- Subprogram_Id : Node_Id;
- Asynchronous : Node_Id := Empty;
- Is_Known_Asynchronous : Boolean := False;
- Is_Known_Non_Asynchronous : Boolean := False;
- Is_Function : Boolean;
- Spec : Node_Id;
- Stub_Type : Entity_Id := Empty;
- RACW_Type : Entity_Id := Empty;
- Nod : Node_Id)
- is
- Loc : constant Source_Ptr := Sloc (Nod);
+ Stmts := New_List;
- Stream_Parameter : Node_Id;
- -- Name of the stream used to transmit parameters to the remote package
+ 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;
- Result_Parameter : Node_Id;
- -- Name of the result parameter (in non-APC cases) which get the
- -- result of the remote subprogram.
+ --------------------------------------
+ -- Build_RPC_Receiver_Specification --
+ --------------------------------------
- Exception_Return_Parameter : Node_Id;
- -- Name of the parameter which will hold the exception sent by the
- -- remote subprogram.
+ function Build_RPC_Receiver_Specification
+ (RPC_Receiver : Entity_Id;
+ Stream_Parameter : Entity_Id;
+ Result_Parameter : Entity_Id) return Node_Id
+ is
+ Loc : constant Source_Ptr := Sloc (RPC_Receiver);
- Current_Parameter : Node_Id;
- -- Current parameter being handled
+ 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))),
- Ordered_Parameters_List : constant List_Id :=
- Build_Ordered_Parameters_List (Spec);
+ 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;
- Asynchronous_Statements : List_Id := No_List;
- Non_Asynchronous_Statements : List_Id := No_List;
- -- Statements specifics to the Asynchronous/Non-Asynchronous cases
+ ------------------------------------
+ -- Build_Subprogram_Calling_Stubs --
+ ------------------------------------
- Extra_Formal_Statements : constant List_Id := New_List;
- -- List of statements for extra formal parameters. It will appear after
- -- the regular statements for writing out parameters.
+ function Build_Subprogram_Calling_Stubs
+ (Vis_Decl : Node_Id;
+ Subp_Id : Node_Id;
+ Asynchronous : Boolean;
+ Dynamically_Asynchronous : Boolean := False;
+ Stub_Type : Entity_Id := Empty;
+ RACW_Type : Entity_Id := Empty;
+ Locator : Entity_Id := Empty;
+ New_Name : Name_Id := No_Name) return Node_Id
+ is
+ Loc : constant Source_Ptr := Sloc (Vis_Decl);
- pragma Warnings (Off, RACW_Type);
- -- Unreferenced formal parameter.
+ Target_Partition : Node_Id;
+ -- Contains the name of the target partition
- begin
- -- The general form of a calling stub for a given subprogram is:
+ Decls : constant List_Id := New_List;
+ Statements : constant List_Id := New_List;
- -- procedure X (...) is
- -- P : constant Partition_ID := RCI_Cache.Get_Active_Partition_ID;
- -- Stream, Result : aliased System.RPC.Params_Stream_Type (0);
- -- begin
- -- Put_Package_RPC_Receiver_In_Stream; (the package RPC receiver
- -- comes from RCI_Cache.Get_RCI_Package_Receiver)
- -- Put_Subprogram_Id_In_Stream;
- -- Put_Parameters_In_Stream;
- -- Do_RPC (Stream, Result);
- -- Read_Exception_Occurrence_From_Result; Raise_It;
- -- Read_Out_Parameters_And_Function_Return_From_Stream;
- -- end X;
+ Subp_Spec : Node_Id;
+ -- The specification of the body
- -- There are some variations: Do_APC is called for an asynchronous
- -- procedure and the part after the call is completely ommitted
- -- as well as the declaration of Result. For a function call,
- -- 'Input is always used to read the result even if it is constrained.
+ Controlling_Parameter : Entity_Id := Empty;
+ RPC_Receiver : Node_Id;
- Stream_Parameter :=
- Make_Defining_Identifier (Loc, New_Internal_Name ('S'));
+ Asynchronous_Expr : Node_Id := Empty;
- Append_To (Decls,
- Make_Object_Declaration (Loc,
- Defining_Identifier => Stream_Parameter,
- Aliased_Present => True,
- Object_Definition =>
- Make_Subtype_Indication (Loc,
- Subtype_Mark =>
- New_Occurrence_Of (RTE (RE_Params_Stream_Type), Loc),
- Constraint =>
- Make_Index_Or_Discriminant_Constraint (Loc,
- Constraints =>
- New_List (Make_Integer_Literal (Loc, 0))))));
+ RCI_Locator : Entity_Id;
- if not Is_Known_Asynchronous then
- Result_Parameter :=
- Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
+ Spec_To_Use : Node_Id;
- Append_To (Decls,
- Make_Object_Declaration (Loc,
- Defining_Identifier => Result_Parameter,
- Aliased_Present => True,
- Object_Definition =>
- Make_Subtype_Indication (Loc,
- Subtype_Mark =>
- New_Occurrence_Of (RTE (RE_Params_Stream_Type), Loc),
- Constraint =>
- Make_Index_Or_Discriminant_Constraint (Loc,
- Constraints =>
- New_List (Make_Integer_Literal (Loc, 0))))));
-
- Exception_Return_Parameter :=
- Make_Defining_Identifier (Loc, New_Internal_Name ('E'));
-
- Append_To (Decls,
- Make_Object_Declaration (Loc,
- Defining_Identifier => Exception_Return_Parameter,
- Object_Definition =>
- New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc)));
-
- else
- Result_Parameter := Empty;
- Exception_Return_Parameter := Empty;
- end if;
+ procedure Insert_Partition_Check (Parameter : Node_Id);
+ -- Check that the parameter has been elaborated on the same partition
+ -- than the controlling parameter (E.4(19)).
- -- Put first the RPC receiver corresponding to the remote package
+ ----------------------------
+ -- Insert_Partition_Check --
+ ----------------------------
- Append_To (Statements,
- Make_Attribute_Reference (Loc,
- Prefix =>
- New_Occurrence_Of (RTE (RE_Unsigned_64), Loc),
- Attribute_Name => Name_Write,
- Expressions => New_List (
- Make_Attribute_Reference (Loc,
- Prefix =>
- New_Occurrence_Of (Stream_Parameter, Loc),
- Attribute_Name =>
- Name_Access),
- RPC_Receiver)));
+ procedure Insert_Partition_Check (Parameter : Node_Id) is
+ Parameter_Entity : constant Entity_Id :=
+ Defining_Identifier (Parameter);
- -- Then put the Subprogram_Id of the subprogram we want to call in
- -- the stream.
+ Condition : Node_Id;
- Append_To (Statements,
- Make_Attribute_Reference (Loc,
- Prefix =>
- New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc),
- Attribute_Name =>
- Name_Write,
- Expressions => New_List (
- Make_Attribute_Reference (Loc,
- Prefix =>
- New_Occurrence_Of (Stream_Parameter, Loc),
- Attribute_Name => Name_Access),
- Subprogram_Id)));
+ begin
+ -- The expression that will be built is of the form:
+ -- if not (Parameter in Stub_Type and then
+ -- Parameter.Origin = Controlling.Origin)
+ -- then
+ -- raise Constraint_Error;
+ -- end if;
- Current_Parameter := First (Ordered_Parameters_List);
- while Current_Parameter /= Empty loop
- declare
- Typ : constant Node_Id :=
- Parameter_Type (Current_Parameter);
- Etyp : Entity_Id;
- Constrained : Boolean;
- Value : Node_Id;
- Extra_Parameter : Entity_Id;
+ -- Condition contains the reversed condition. We do not check that
+ -- Parameter is in Stub_Type since such a check has been inserted
+ -- at the point of call already (a tag check since we have multiple
+ -- controlling operands).
- begin
- if Is_RACW_Controlling_Formal (Current_Parameter, Stub_Type) then
+ Condition :=
+ Make_Op_Eq (Loc,
+ Left_Opnd =>
+ Make_Selected_Component (Loc,
+ Prefix =>
+ New_Occurrence_Of (Parameter_Entity, Loc),
+ Selector_Name =>
+ Make_Identifier (Loc, Name_Origin)),
- -- In the case of a controlling formal argument, we marshall
- -- its addr field rather than the local stub.
+ Right_Opnd =>
+ Make_Selected_Component (Loc,
+ Prefix =>
+ New_Occurrence_Of (Controlling_Parameter, Loc),
+ Selector_Name =>
+ Make_Identifier (Loc, Name_Origin)));
- Append_To (Statements,
- Pack_Node_Into_Stream (Loc,
- Stream => Stream_Parameter,
- Object =>
- Make_Selected_Component (Loc,
- Prefix =>
- New_Occurrence_Of (
- Defining_Identifier (Current_Parameter), Loc),
- Selector_Name =>
- Make_Identifier (Loc, Name_Addr)),
- Etyp => RTE (RE_Unsigned_64)));
+ Append_To (Decls,
+ Make_Raise_Constraint_Error (Loc,
+ Condition =>
+ Make_Op_Not (Loc, Right_Opnd => Condition),
+ Reason => CE_Partition_Check_Failed));
+ end Insert_Partition_Check;
- else
- Value := New_Occurrence_Of
- (Defining_Identifier (Current_Parameter), Loc);
+ -- Start of processing for Build_Subprogram_Calling_Stubs
- -- Access type parameters are transmitted as in out
- -- parameters. However, a dereference is needed so that
- -- we marshall the designated object.
+ begin
+ Target_Partition :=
+ Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
- if Nkind (Typ) = N_Access_Definition then
- Value := Make_Explicit_Dereference (Loc, Value);
- Etyp := Etype (Subtype_Mark (Typ));
- else
- Etyp := Etype (Typ);
- end if;
+ Subp_Spec := Copy_Specification (Loc,
+ Spec => Specification (Vis_Decl),
+ New_Name => New_Name);
- Constrained :=
- Is_Constrained (Etyp) or else Is_Elementary_Type (Etyp);
+ if Locator = Empty then
+ RCI_Locator := RCI_Cache;
+ Spec_To_Use := Specification (Vis_Decl);
+ else
+ RCI_Locator := Locator;
+ Spec_To_Use := Subp_Spec;
+ end if;
- -- Any parameter but unconstrained out parameters are
- -- transmitted to the peer.
+ -- Find a controlling argument if we have a stub type. Also check
+ -- if this subprogram can be made asynchronous.
- if In_Present (Current_Parameter)
- or else not Out_Present (Current_Parameter)
- or else not Constrained
+ if Present (Stub_Type)
+ and then Present (Parameter_Specifications (Spec_To_Use))
+ then
+ declare
+ Current_Parameter : Node_Id :=
+ First (Parameter_Specifications
+ (Spec_To_Use));
+ begin
+ while Present (Current_Parameter) loop
+ if
+ Is_RACW_Controlling_Formal (Current_Parameter, Stub_Type)
then
- Append_To (Statements,
- Make_Attribute_Reference (Loc,
- Prefix =>
- New_Occurrence_Of (Etyp, Loc),
- Attribute_Name => Output_From_Constrained (Constrained),
- Expressions => New_List (
- Make_Attribute_Reference (Loc,
- Prefix =>
- New_Occurrence_Of (Stream_Parameter, Loc),
- Attribute_Name => Name_Access),
- Value)));
+ if Controlling_Parameter = Empty then
+ Controlling_Parameter :=
+ Defining_Identifier (Current_Parameter);
+ else
+ Insert_Partition_Check (Current_Parameter);
+ end if;
end if;
- end if;
-
- -- If the current parameter has a dynamic constrained status,
- -- then this status is transmitted as well.
- -- This should be done for accessibility as well ???
-
- if Nkind (Typ) /= N_Access_Definition
- and then Need_Extra_Constrained (Current_Parameter)
- then
- -- In this block, we do not use the extra formal that has been
- -- created because it does not exist at the time of expansion
- -- when building calling stubs for remote access to subprogram
- -- types. We create an extra variable of this type and push it
- -- in the stream after the regular parameters.
-
- Extra_Parameter := Make_Defining_Identifier
- (Loc, New_Internal_Name ('P'));
-
- Append_To (Decls,
- Make_Object_Declaration (Loc,
- Defining_Identifier => Extra_Parameter,
- Constant_Present => True,
- Object_Definition =>
- New_Occurrence_Of (Standard_Boolean, Loc),
- Expression =>
- Make_Attribute_Reference (Loc,
- Prefix =>
- New_Occurrence_Of (
- Defining_Identifier (Current_Parameter), Loc),
- Attribute_Name => Name_Constrained)));
-
- Append_To (Extra_Formal_Statements,
- Make_Attribute_Reference (Loc,
- Prefix =>
- New_Occurrence_Of (Standard_Boolean, Loc),
- Attribute_Name =>
- Name_Write,
- Expressions => New_List (
- Make_Attribute_Reference (Loc,
- Prefix =>
- New_Occurrence_Of (Stream_Parameter, Loc),
- Attribute_Name =>
- Name_Access),
- New_Occurrence_Of (Extra_Parameter, Loc))));
- end if;
- Next (Current_Parameter);
+ Next (Current_Parameter);
+ end loop;
end;
- end loop;
+ end if;
- -- Append the formal statements list to the statements
+ if Present (Stub_Type) then
+ pragma Assert (Present (Controlling_Parameter));
- Append_List_To (Statements, Extra_Formal_Statements);
+ Append_To (Decls,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Target_Partition,
+ Constant_Present => True,
+ Object_Definition =>
+ New_Occurrence_Of (RTE (RE_Partition_ID), Loc),
- if not Is_Known_Non_Asynchronous then
+ Expression =>
+ Make_Selected_Component (Loc,
+ Prefix =>
+ New_Occurrence_Of (Controlling_Parameter, Loc),
+ Selector_Name =>
+ Make_Identifier (Loc, Name_Origin))));
- -- Build the call to System.RPC.Do_APC
+ RPC_Receiver :=
+ Make_Selected_Component (Loc,
+ Prefix =>
+ New_Occurrence_Of (Controlling_Parameter, Loc),
+ Selector_Name =>
+ Make_Identifier (Loc, Name_Receiver));
- Asynchronous_Statements := New_List (
- Make_Procedure_Call_Statement (Loc,
- Name =>
- New_Occurrence_Of (RTE (RE_Do_Apc), Loc),
- Parameter_Associations => New_List (
- New_Occurrence_Of (Target_Partition, Loc),
- Make_Attribute_Reference (Loc,
- Prefix =>
- New_Occurrence_Of (Stream_Parameter, Loc),
- Attribute_Name =>
- Name_Access))));
else
- Asynchronous_Statements := No_List;
- end if;
-
- if not Is_Known_Asynchronous then
+ Append_To (Decls,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Target_Partition,
+ Constant_Present => True,
+ Object_Definition =>
+ New_Occurrence_Of (RTE (RE_Partition_ID), Loc),
- -- Build the call to System.RPC.Do_RPC
+ Expression =>
+ Make_Function_Call (Loc,
+ Name => Make_Selected_Component (Loc,
+ Prefix =>
+ Make_Identifier (Loc, Chars (RCI_Locator)),
+ Selector_Name =>
+ Make_Identifier (Loc, Name_Get_Active_Partition_ID)))));
- Non_Asynchronous_Statements := New_List (
- Make_Procedure_Call_Statement (Loc,
- Name =>
- New_Occurrence_Of (RTE (RE_Do_Rpc), Loc),
- Parameter_Associations => New_List (
- New_Occurrence_Of (Target_Partition, Loc),
+ RPC_Receiver :=
+ Make_Selected_Component (Loc,
+ Prefix =>
+ Make_Identifier (Loc, Chars (RCI_Locator)),
+ Selector_Name =>
+ Make_Identifier (Loc, Name_Get_RCI_Package_Receiver));
+ end if;
- Make_Attribute_Reference (Loc,
- Prefix =>
- New_Occurrence_Of (Stream_Parameter, Loc),
- Attribute_Name =>
- Name_Access),
+ if Dynamically_Asynchronous then
+ Asynchronous_Expr :=
+ Make_Selected_Component (Loc,
+ Prefix =>
+ New_Occurrence_Of (Controlling_Parameter, Loc),
+ Selector_Name =>
+ Make_Identifier (Loc, Name_Asynchronous));
+ end if;
- Make_Attribute_Reference (Loc,
- Prefix =>
- New_Occurrence_Of (Result_Parameter, Loc),
- Attribute_Name =>
- Name_Access))));
+ Build_General_Calling_Stubs
+ (Decls => Decls,
+ Statements => Statements,
+ Target_Partition => Target_Partition,
+ RPC_Receiver => RPC_Receiver,
+ Subprogram_Id => Subp_Id,
+ Asynchronous => Asynchronous_Expr,
+ Is_Known_Asynchronous => Asynchronous
+ and then not Dynamically_Asynchronous,
+ Is_Known_Non_Asynchronous
+ => not Asynchronous
+ and then not Dynamically_Asynchronous,
+ Is_Function => Nkind (Spec_To_Use) =
+ N_Function_Specification,
+ Spec => Spec_To_Use,
+ Stub_Type => Stub_Type,
+ RACW_Type => RACW_Type,
+ Nod => Vis_Decl);
- -- Read the exception occurrence from the result stream and
- -- reraise it. It does no harm if this is a Null_Occurrence since
- -- this does nothing.
+ RCI_Calling_Stubs_Table.Set
+ (Defining_Unit_Name (Specification (Vis_Decl)),
+ Defining_Unit_Name (Spec_To_Use));
- Append_To (Non_Asynchronous_Statements,
- Make_Attribute_Reference (Loc,
- Prefix =>
- New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc),
+ return
+ Make_Subprogram_Body (Loc,
+ Specification => Subp_Spec,
+ Declarations => Decls,
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc, Statements));
+ end Build_Subprogram_Calling_Stubs;
- Attribute_Name =>
- Name_Read,
+ -------------------------
+ -- Build_Subprogram_Id --
+ -------------------------
- Expressions => New_List (
- Make_Attribute_Reference (Loc,
- Prefix =>
- New_Occurrence_Of (Result_Parameter, Loc),
- Attribute_Name =>
- Name_Access),
- New_Occurrence_Of (Exception_Return_Parameter, Loc))));
+ function Build_Subprogram_Id
+ (Loc : Source_Ptr;
+ E : Entity_Id) return Node_Id
+ is
+ begin
+ return Make_Integer_Literal (Loc, Get_Subprogram_Id (E));
+ end Build_Subprogram_Id;
- Append_To (Non_Asynchronous_Statements,
- Make_Procedure_Call_Statement (Loc,
- Name =>
- New_Occurrence_Of (RTE (RE_Reraise_Occurrence), Loc),
- Parameter_Associations => New_List (
- New_Occurrence_Of (Exception_Return_Parameter, Loc))));
+ --------------------------------------
+ -- Build_Subprogram_Receiving_Stubs --
+ --------------------------------------
- if Is_Function then
+ 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);
- -- If this is a function call, then read the value and return
- -- it. The return value is written/read using 'Output/'Input.
+ Stream_Parameter : Node_Id;
+ Result_Parameter : Node_Id;
+ -- See explanations of these in Build_Subprogram_Calling_Stubs
- Append_To (Non_Asynchronous_Statements,
- Make_Tag_Check (Loc,
- Make_Return_Statement (Loc,
- Expression =>
- Make_Attribute_Reference (Loc,
- Prefix =>
- New_Occurrence_Of (
- Etype (Subtype_Mark (Spec)), Loc),
+ Decls : constant List_Id := New_List;
+ -- All the parameters will get declared before calling the real
+ -- subprograms. Also the out parameters will be declared.
- Attribute_Name => Name_Input,
+ Statements : constant List_Id := New_List;
- Expressions => New_List (
- Make_Attribute_Reference (Loc,
- Prefix =>
- New_Occurrence_Of (Result_Parameter, Loc),
- Attribute_Name => Name_Access))))));
+ Extra_Formal_Statements : constant List_Id := New_List;
+ -- Statements concerning extra formal parameters
- else
- -- Loop around parameters and assign out (or in out) parameters.
- -- In the case of RACW, controlling arguments cannot possibly
- -- have changed since they are remote, so we do not read them
- -- from the stream.
+ After_Statements : constant List_Id := New_List;
+ -- Statements to be executed after the subprogram call
- Current_Parameter := First (Ordered_Parameters_List);
- while Current_Parameter /= Empty loop
- declare
- Typ : constant Node_Id :=
- Parameter_Type (Current_Parameter);
- Etyp : Entity_Id;
- Value : Node_Id;
+ Inner_Decls : List_Id := No_List;
+ -- In case of a function, the inner declarations are needed since
+ -- the result may be unconstrained.
- begin
- Value :=
- New_Occurrence_Of
- (Defining_Identifier (Current_Parameter), Loc);
+ Excep_Handlers : List_Id := No_List;
+ Excep_Choice : Entity_Id;
+ Excep_Code : List_Id;
- if Nkind (Typ) = N_Access_Definition then
- Value := Make_Explicit_Dereference (Loc, Value);
- Etyp := Etype (Subtype_Mark (Typ));
- else
- Etyp := Etype (Typ);
- end if;
+ Parameter_List : constant List_Id := New_List;
+ -- List of parameters to be passed to the subprogram
- if (Out_Present (Current_Parameter)
- or else Nkind (Typ) = N_Access_Definition)
- and then Etyp /= Stub_Type
- then
- Append_To (Non_Asynchronous_Statements,
- Make_Attribute_Reference (Loc,
- Prefix =>
- New_Occurrence_Of (Etyp, Loc),
+ Current_Parameter : Node_Id;
- Attribute_Name => Name_Read,
+ Ordered_Parameters_List : constant List_Id :=
+ Build_Ordered_Parameters_List
+ (Specification (Vis_Decl));
- Expressions => New_List (
- Make_Attribute_Reference (Loc,
- Prefix =>
- New_Occurrence_Of (Result_Parameter, Loc),
- Attribute_Name =>
- Name_Access),
- Value)));
- end if;
- end;
+ Subp_Spec : Node_Id;
+ -- Subprogram specification
- Next (Current_Parameter);
- end loop;
- end if;
- end if;
+ Called_Subprogram : Node_Id;
+ -- The subprogram to call
- if Is_Known_Asynchronous then
- Append_List_To (Statements, Asynchronous_Statements);
+ Null_Raise_Statement : Node_Id;
- elsif Is_Known_Non_Asynchronous then
- Append_List_To (Statements, Non_Asynchronous_Statements);
+ Dynamic_Async : Entity_Id;
+ begin
+ if Present (RACW_Type) then
+ Called_Subprogram :=
+ New_Occurrence_Of (Parent_Primitive, Loc);
else
- pragma Assert (Asynchronous /= Empty);
- Prepend_To (Asynchronous_Statements,
- Make_Attribute_Reference (Loc,
- Prefix => New_Occurrence_Of (Standard_Boolean, Loc),
- Attribute_Name => Name_Write,
- Expressions => New_List (
- Make_Attribute_Reference (Loc,
- Prefix => New_Occurrence_Of (Stream_Parameter, Loc),
- Attribute_Name => Name_Access),
- New_Occurrence_Of (Standard_True, Loc))));
+ Called_Subprogram :=
+ New_Occurrence_Of (
+ Defining_Unit_Name (Specification (Vis_Decl)), Loc);
+ end if;
- Prepend_To (Non_Asynchronous_Statements,
- Make_Attribute_Reference (Loc,
- Prefix => New_Occurrence_Of (Standard_Boolean, Loc),
- Attribute_Name => Name_Write,
- Expressions => New_List (
- Make_Attribute_Reference (Loc,
- Prefix => New_Occurrence_Of (Stream_Parameter, Loc),
- Attribute_Name => Name_Access),
- New_Occurrence_Of (Standard_False, Loc))));
+ Stream_Parameter :=
+ Make_Defining_Identifier (Loc, New_Internal_Name ('S'));
- Append_To (Statements,
- Make_Implicit_If_Statement (Nod,
- Condition => Asynchronous,
- Then_Statements => Asynchronous_Statements,
- Else_Statements => Non_Asynchronous_Statements));
+ if Dynamically_Asynchronous then
+ Dynamic_Async :=
+ Make_Defining_Identifier (Loc, New_Internal_Name ('S'));
+ else
+ Dynamic_Async := Empty;
end if;
- end Build_General_Calling_Stubs;
- ------------------------------
- -- Build_Get_Unique_RP_Call --
- ------------------------------
+ if not Asynchronous or else Dynamically_Asynchronous then
+ Result_Parameter :=
+ Make_Defining_Identifier (Loc, New_Internal_Name ('S'));
- function Build_Get_Unique_RP_Call
- (Loc : Source_Ptr;
- Pointer : Entity_Id;
- Stub_Type : Entity_Id) return List_Id
- is
- begin
- return New_List (
- Make_Procedure_Call_Statement (Loc,
- Name =>
- New_Occurrence_Of (RTE (RE_Get_Unique_Remote_Pointer), Loc),
- Parameter_Associations => New_List (
- Unchecked_Convert_To (RTE (RE_RACW_Stub_Type_Access),
- New_Occurrence_Of (Pointer, Loc)))),
+ -- The first statement after the subprogram call is a statement to
+ -- writes a Null_Occurrence into the result stream.
- Make_Assignment_Statement (Loc,
- Name =>
- Make_Selected_Component (Loc,
- Prefix =>
- New_Occurrence_Of (Pointer, Loc),
- Selector_Name =>
- New_Occurrence_Of (Tag_Component
- (Designated_Type (Etype (Pointer))), Loc)),
- Expression =>
- Make_Attribute_Reference (Loc,
- Prefix =>
- New_Occurrence_Of (Stub_Type, Loc),
- Attribute_Name =>
- Name_Tag)));
+ 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)));
- -- Note: The assignment to Pointer._Tag is safe here because
- -- we carefully ensured that Stub_Type has exactly the same layout
- -- as System.Partition_Interface.RACW_Stub_Type.
+ 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;
- end Build_Get_Unique_RP_Call;
+ Append_To (After_Statements, Null_Raise_Statement);
- ----------------------------------------
- -- Build_Remote_Subprogram_Proxy_Type --
- ----------------------------------------
+ else
+ Result_Parameter := Empty;
+ end if;
- function Build_Remote_Subprogram_Proxy_Type
- (Loc : Source_Ptr;
- ACR_Expression : Node_Id) return Node_Id
- is
- begin
- return
- Make_Record_Definition (Loc,
- Tagged_Present => True,
- Limited_Present => True,
- Component_List =>
- Make_Component_List (Loc,
+ -- 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.
- 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),
+ 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;
- 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)),
+ begin
+ Object := Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
+ Set_Ekind (Object, E_Variable);
- 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))))));
- end Build_Remote_Subprogram_Proxy_Type;
+ RACW_Controlling :=
+ Is_RACW_Controlling_Formal (Current_Parameter, Stub_Type);
- -----------------------------------
- -- Build_Ordered_Parameters_List --
- -----------------------------------
+ if RACW_Controlling then
- function Build_Ordered_Parameters_List (Spec : Node_Id) return List_Id is
- Constrained_List : List_Id;
- Unconstrained_List : List_Id;
- Current_Parameter : Node_Id;
+ -- We have a controlling formal parameter. Read its address
+ -- rather than a real object. The address is in Unsigned_64
+ -- form.
- First_Parameter : Node_Id;
- For_RAS : Boolean := False;
+ Etyp := RTE (RE_Unsigned_64);
+ else
+ Etyp := Etype (Parameter_Type (Current_Parameter));
+ end if;
- begin
- if not Present (Parameter_Specifications (Spec)) then
- return New_List;
- end if;
+ Constrained :=
+ Is_Constrained (Etyp) or else Is_Elementary_Type (Etyp);
- Constrained_List := New_List;
- Unconstrained_List := New_List;
- First_Parameter := First (Parameter_Specifications (Spec));
+ 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 Nkind (Parameter_Type (First_Parameter)) = N_Access_Definition
- and then Chars (Defining_Identifier (First_Parameter)) = Name_uS
- then
- For_RAS := True;
- end if;
+ 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))));
- -- Loop through the parameters and add them to the right list
+ 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;
- Current_Parameter := First_Parameter;
- while Current_Parameter /= Empty loop
- if (Nkind (Parameter_Type (Current_Parameter)) = N_Access_Definition
- or else
- Is_Constrained (Etype (Parameter_Type (Current_Parameter)))
- or else
- Is_Elementary_Type (Etype (Parameter_Type (Current_Parameter))))
- and then not (For_RAS and then Current_Parameter = First_Parameter)
- then
- Append_To (Constrained_List, New_Copy (Current_Parameter));
- else
- Append_To (Unconstrained_List, New_Copy (Current_Parameter));
- end if;
+ -- 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.
- Next (Current_Parameter);
- end loop;
+ 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));
- -- Unconstrained parameters are returned first
+ -- 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.
- Append_List_To (Unconstrained_List, Constrained_List);
+ 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;
- return Unconstrained_List;
- end Build_Ordered_Parameters_List;
+ 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))))));
- ----------------------------------
- -- Build_Passive_Partition_Stub --
- ----------------------------------
+ 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;
- procedure Build_Passive_Partition_Stub (U : Node_Id) is
- Pkg_Spec : Node_Id;
- Pkg_Name : String_Id;
- L : List_Id;
- Reg : Node_Id;
- Loc : constant Source_Ptr := Sloc (U);
+ 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;
- begin
- -- Verify that the implementation supports distribution, by accessing
- -- a type defined in the proper version of system.rpc
+ -- 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.
- declare
- Dist_OK : Entity_Id;
- pragma Warnings (Off, Dist_OK);
- begin
- Dist_OK := RTE (RE_Params_Stream_Type);
- end;
+ -- The case of Extra_Accessibility should also be handled ???
- -- Use body if present, spec otherwise
+ 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));
- if Nkind (U) = N_Package_Declaration then
- Pkg_Spec := Specification (U);
- L := Visible_Declarations (Pkg_Spec);
- else
- Pkg_Spec := Parent (Corresponding_Spec (U));
- L := Declarations (U);
- end if;
+ Formal_Entity : constant Entity_Id :=
+ Make_Defining_Identifier
+ (Loc, Chars (Extra_Parameter));
- Get_Pkg_Name_String (Pkg_Spec);
- Pkg_Name := String_From_Name_Buffer;
- Reg :=
- Make_Procedure_Call_Statement (Loc,
- Name =>
- New_Occurrence_Of (RTE (RE_Register_Passive_Package), Loc),
- Parameter_Associations => New_List (
- Make_String_Literal (Loc, Pkg_Name),
- Make_Attribute_Reference (Loc,
- Prefix =>
- New_Occurrence_Of (Defining_Entity (Pkg_Spec), Loc),
- Attribute_Name =>
- Name_Version)));
- Append_To (L, Reg);
- Analyze (Reg);
- end Build_Passive_Partition_Stub;
+ Formal_Type : constant Entity_Id :=
+ Etype (Extra_Parameter);
- --------------------------------------
- -- Build_RPC_Receiver_Specification --
- --------------------------------------
+ begin
+ Append_To (Decls,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Formal_Entity,
+ Object_Definition =>
+ New_Occurrence_Of (Formal_Type, Loc)));
- function Build_RPC_Receiver_Specification
- (RPC_Receiver : Entity_Id;
- Stream_Parameter : Entity_Id;
- Result_Parameter : Entity_Id) return Node_Id
- is
- Loc : constant Source_Ptr := Sloc (RPC_Receiver);
+ 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;
- 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))),
+ Next (Current_Parameter);
+ end loop;
- 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;
+ -- Append the formal statements list at the end of regular statements
- ------------------------------------
- -- Build_Subprogram_Calling_Stubs --
- ------------------------------------
+ Append_List_To (Statements, Extra_Formal_Statements);
- function Build_Subprogram_Calling_Stubs
- (Vis_Decl : Node_Id;
- Subp_Id : Int;
- Asynchronous : Boolean;
- Dynamically_Asynchronous : Boolean := False;
- Stub_Type : Entity_Id := Empty;
- RACW_Type : Entity_Id := Empty;
- Locator : Entity_Id := Empty;
- New_Name : Name_Id := No_Name) return Node_Id
- is
- Loc : constant Source_Ptr := Sloc (Vis_Decl);
+ if Nkind (Specification (Vis_Decl)) = N_Function_Specification then
- Target_Partition : Node_Id;
- -- Contains the name of the target partition
+ -- The remote subprogram is a function. We build an inner block to
+ -- be able to hold a potentially unconstrained result in a variable.
- Decls : constant List_Id := New_List;
- Statements : constant List_Id := New_List;
+ declare
+ Etyp : constant Entity_Id :=
+ Etype (Subtype_Mark (Specification (Vis_Decl)));
+ Result : constant Node_Id :=
+ Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
- Subp_Spec : Node_Id;
- -- The specification of the body
+ 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)));
- Controlling_Parameter : Entity_Id := Empty;
- RPC_Receiver : Node_Id;
+ 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;
- Asynchronous_Expr : Node_Id := Empty;
+ Append_To (Statements,
+ Make_Block_Statement (Loc,
+ Declarations => Inner_Decls,
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements => After_Statements)));
- RCI_Locator : Entity_Id;
+ else
+ -- The remote subprogram is a procedure. We do not need any inner
+ -- block in this case.
- Spec_To_Use : Node_Id;
+ if Dynamically_Asynchronous then
+ Append_To (Decls,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Dynamic_Async,
+ Object_Definition =>
+ New_Occurrence_Of (Standard_Boolean, Loc)));
- procedure Insert_Partition_Check (Parameter : Node_Id);
- -- Check that the parameter has been elaborated on the same partition
- -- than the controlling parameter (E.4(19)).
+ 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;
- ----------------------------
- -- Insert_Partition_Check --
- ----------------------------
+ Append_To (Statements,
+ Make_Procedure_Call_Statement (Loc,
+ Name => Called_Subprogram,
+ Parameter_Associations => Parameter_List));
- procedure Insert_Partition_Check (Parameter : Node_Id) is
- Parameter_Entity : constant Entity_Id :=
- Defining_Identifier (Parameter);
- Condition : Node_Id;
+ Append_List_To (Statements, After_Statements);
+ end if;
- Designated_Object : Node_Id;
- pragma Warnings (Off, Designated_Object);
- -- Is it really right that this is unreferenced ???
+ if Asynchronous and then not Dynamically_Asynchronous then
- begin
- -- The expression that will be built is of the form:
- -- if not (Parameter in Stub_Type and then
- -- Parameter.Origin = Controlling.Origin)
- -- then
- -- raise Constraint_Error;
- -- end if;
+ -- An asynchronous procedure does not want a Result parameter. Also
+ -- put an exception handler with an others clause that does nothing.
- -- Condition contains the reversed condition. Also, Parameter is
- -- dereferenced if it is an access type. We do not check that
- -- Parameter is in Stub_Type since such a check has been inserted
- -- at the point of call already (a tag check since we have multiple
- -- controlling operands).
+ 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)))));
- if Nkind (Parameter_Type (Parameter)) = N_Access_Definition then
- Designated_Object :=
- Make_Explicit_Dereference (Loc,
- Prefix => New_Occurrence_Of (Parameter_Entity, Loc));
- else
- Designated_Object := New_Occurrence_Of (Parameter_Entity, Loc);
- end if;
+ Excep_Handlers := New_List (
+ Make_Exception_Handler (Loc,
+ Exception_Choices =>
+ New_List (Make_Others_Choice (Loc)),
+ Statements => New_List (
+ Make_Null_Statement (Loc))));
- Condition :=
- Make_Op_Eq (Loc,
- Left_Opnd =>
- Make_Selected_Component (Loc,
- Prefix =>
- New_Occurrence_Of (Parameter_Entity, Loc),
- Selector_Name =>
- Make_Identifier (Loc, Name_Origin)),
+ 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.
- Right_Opnd =>
- Make_Selected_Component (Loc,
- Prefix =>
- New_Occurrence_Of (Controlling_Parameter, Loc),
- Selector_Name =>
- Make_Identifier (Loc, Name_Origin)));
+ Excep_Choice :=
+ Make_Defining_Identifier (Loc, New_Internal_Name ('E'));
- Append_To (Decls,
- Make_Raise_Constraint_Error (Loc,
- Condition =>
- Make_Op_Not (Loc, Right_Opnd => Condition),
- Reason => CE_Partition_Check_Failed));
- end Insert_Partition_Check;
+ 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))));
- -- Start of processing for Build_Subprogram_Calling_Stubs
+ 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;
- begin
- Target_Partition :=
- Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
+ 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 := Copy_Specification (Loc,
- Spec => Specification (Vis_Decl),
- New_Name => New_Name);
+ Subp_Spec :=
+ Make_Procedure_Specification (Loc,
+ Defining_Unit_Name =>
+ Make_Defining_Identifier (Loc, New_Internal_Name ('F')),
- if Locator = Empty then
- RCI_Locator := RCI_Cache;
- Spec_To_Use := Specification (Vis_Decl);
- else
- RCI_Locator := Locator;
- Spec_To_Use := Subp_Spec;
+ 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;
- -- Find a controlling argument if we have a stub type. Also check
- -- if this subprogram can be made asynchronous.
+ 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;
- if Stub_Type /= Empty
- and then Present (Parameter_Specifications (Spec_To_Use))
- then
- declare
- Current_Parameter : Node_Id :=
- First (Parameter_Specifications
- (Spec_To_Use));
- begin
- while Current_Parameter /= Empty loop
+ ------------------------
+ -- Copy_Specification --
+ ------------------------
- if
- Is_RACW_Controlling_Formal (Current_Parameter, Stub_Type)
- then
- if Controlling_Parameter = Empty then
- Controlling_Parameter :=
- Defining_Identifier (Current_Parameter);
- else
- Insert_Partition_Check (Current_Parameter);
- end if;
- end if;
+ function Copy_Specification
+ (Loc : Source_Ptr;
+ Spec : Node_Id;
+ Object_Type : Entity_Id := Empty;
+ Stub_Type : Entity_Id := Empty;
+ New_Name : Name_Id := No_Name) return Node_Id
+ is
+ Parameters : List_Id := No_List;
+
+ Current_Parameter : Node_Id;
+ Current_Identifier : Entity_Id;
+ Current_Type : Node_Id;
+ Current_Etype : Entity_Id;
- Next (Current_Parameter);
- end loop;
- end;
+ Name_For_New_Spec : Name_Id;
+
+ New_Identifier : Entity_Id;
+
+ -- Comments needed in body below ???
+
+ begin
+ if New_Name = No_Name then
+ pragma Assert (Nkind (Spec) = N_Function_Specification
+ or else Nkind (Spec) = N_Procedure_Specification);
+
+ Name_For_New_Spec := Chars (Defining_Unit_Name (Spec));
+ else
+ Name_For_New_Spec := New_Name;
end if;
- if Stub_Type /= Empty then
- pragma Assert (Controlling_Parameter /= Empty);
+ if Present (Parameter_Specifications (Spec)) then
+ Parameters := New_List;
+ Current_Parameter := First (Parameter_Specifications (Spec));
+ while Present (Current_Parameter) loop
+ Current_Identifier := Defining_Identifier (Current_Parameter);
+ Current_Type := Parameter_Type (Current_Parameter);
- Append_To (Decls,
- Make_Object_Declaration (Loc,
- Defining_Identifier => Target_Partition,
- Constant_Present => True,
- Object_Definition =>
- New_Occurrence_Of (RTE (RE_Partition_ID), Loc),
+ if Nkind (Current_Type) = N_Access_Definition then
+ Current_Etype := Entity (Subtype_Mark (Current_Type));
- Expression =>
- Make_Selected_Component (Loc,
- Prefix =>
- New_Occurrence_Of (Controlling_Parameter, Loc),
- Selector_Name =>
- Make_Identifier (Loc, Name_Origin))));
+ if Present (Object_Type) then
+ pragma Assert (
+ Root_Type (Current_Etype) = Root_Type (Object_Type));
+ Current_Type :=
+ Make_Access_Definition (Loc,
+ Subtype_Mark => New_Occurrence_Of (Stub_Type, Loc));
+ else
+ Current_Type :=
+ Make_Access_Definition (Loc,
+ Subtype_Mark =>
+ New_Occurrence_Of (Current_Etype, Loc));
+ end if;
- RPC_Receiver :=
- Make_Selected_Component (Loc,
- Prefix =>
- New_Occurrence_Of (Controlling_Parameter, Loc),
- Selector_Name =>
- Make_Identifier (Loc, Name_Receiver));
+ else
+ Current_Etype := Entity (Current_Type);
- else
- Append_To (Decls,
- Make_Object_Declaration (Loc,
- Defining_Identifier => Target_Partition,
- Constant_Present => True,
- Object_Definition =>
- New_Occurrence_Of (RTE (RE_Partition_ID), Loc),
+ if Present (Object_Type)
+ and then Current_Etype = Object_Type
+ then
+ Current_Type := New_Occurrence_Of (Stub_Type, Loc);
+ else
+ Current_Type := New_Occurrence_Of (Current_Etype, Loc);
+ end if;
+ end if;
- Expression =>
- Make_Function_Call (Loc,
- Name => Make_Selected_Component (Loc,
- Prefix =>
- Make_Identifier (Loc, Chars (RCI_Locator)),
- Selector_Name =>
- Make_Identifier (Loc, Name_Get_Active_Partition_ID)))));
+ New_Identifier := Make_Defining_Identifier (Loc,
+ Chars (Current_Identifier));
- RPC_Receiver :=
- Make_Selected_Component (Loc,
- Prefix =>
- Make_Identifier (Loc, Chars (RCI_Locator)),
- Selector_Name =>
- Make_Identifier (Loc, Name_Get_RCI_Package_Receiver));
- end if;
+ Append_To (Parameters,
+ Make_Parameter_Specification (Loc,
+ Defining_Identifier => New_Identifier,
+ Parameter_Type => Current_Type,
+ In_Present => In_Present (Current_Parameter),
+ Out_Present => Out_Present (Current_Parameter),
+ Expression =>
+ New_Copy_Tree (Expression (Current_Parameter))));
- if Dynamically_Asynchronous then
- Asynchronous_Expr :=
- Make_Selected_Component (Loc,
- Prefix =>
- New_Occurrence_Of (Controlling_Parameter, Loc),
- Selector_Name =>
- Make_Identifier (Loc, Name_Asynchronous));
+ Next (Current_Parameter);
+ end loop;
end if;
- Build_General_Calling_Stubs
- (Decls => Decls,
- Statements => Statements,
- Target_Partition => Target_Partition,
- RPC_Receiver => RPC_Receiver,
- Subprogram_Id => Make_Integer_Literal (Loc, Subp_Id),
- Asynchronous => Asynchronous_Expr,
- Is_Known_Asynchronous => Asynchronous
- and then not Dynamically_Asynchronous,
- Is_Known_Non_Asynchronous
- => not Asynchronous
- and then not Dynamically_Asynchronous,
- Is_Function => Nkind (Spec_To_Use) =
- N_Function_Specification,
- Spec => Spec_To_Use,
- Stub_Type => Stub_Type,
- RACW_Type => RACW_Type,
- Nod => Vis_Decl);
+ case Nkind (Spec) is
- RCI_Calling_Stubs_Table.Set
- (Defining_Unit_Name (Specification (Vis_Decl)),
- Defining_Unit_Name (Spec_To_Use));
+ when N_Function_Specification | N_Access_Function_Definition =>
+ return
+ Make_Function_Specification (Loc,
+ Defining_Unit_Name =>
+ Make_Defining_Identifier (Loc,
+ Chars => Name_For_New_Spec),
+ Parameter_Specifications => Parameters,
+ Subtype_Mark =>
+ New_Occurrence_Of (Entity (Subtype_Mark (Spec)), Loc));
- return
- Make_Subprogram_Body (Loc,
- Specification => Subp_Spec,
- Declarations => Decls,
- Handled_Statement_Sequence =>
- Make_Handled_Sequence_Of_Statements (Loc, Statements));
- end Build_Subprogram_Calling_Stubs;
+ when N_Procedure_Specification | N_Access_Procedure_Definition =>
+ return
+ Make_Procedure_Specification (Loc,
+ Defining_Unit_Name =>
+ Make_Defining_Identifier (Loc,
+ Chars => Name_For_New_Spec),
+ Parameter_Specifications => Parameters);
- -------------------------
- -- Build_Subprogram_Id --
- -------------------------
+ when others =>
+ raise Program_Error;
+ end case;
+ end Copy_Specification;
- function Build_Subprogram_Id
- (Loc : Source_Ptr;
- E : Entity_Id) return Node_Id
- is
- begin
- return Make_Integer_Literal (Loc, Get_Subprogram_Id (E));
- end Build_Subprogram_Id;
+ ---------------------------
+ -- Could_Be_Asynchronous --
+ ---------------------------
- --------------------------------------
- -- Build_Subprogram_Receiving_Stubs --
- --------------------------------------
+ function Could_Be_Asynchronous (Spec : Node_Id) return Boolean is
+ Current_Parameter : 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 (Vis_Decl);
+ begin
+ if Present (Parameter_Specifications (Spec)) then
+ Current_Parameter := First (Parameter_Specifications (Spec));
+ while Present (Current_Parameter) loop
+ if Out_Present (Current_Parameter) then
+ return False;
+ end if;
- Stream_Parameter : Node_Id;
- Result_Parameter : Node_Id;
- -- See explanations of those in Build_Subprogram_Calling_Stubs
+ Next (Current_Parameter);
+ end loop;
+ end if;
- Decls : constant List_Id := New_List;
- -- All the parameters will get declared before calling the real
- -- subprograms. Also the out parameters will be declared.
+ return True;
+ end Could_Be_Asynchronous;
- Statements : constant List_Id := New_List;
+ ---------------------------------------------
+ -- Expand_All_Calls_Remote_Subprogram_Call --
+ ---------------------------------------------
- Extra_Formal_Statements : constant List_Id := New_List;
- -- Statements concerning extra formal parameters
+ procedure Expand_All_Calls_Remote_Subprogram_Call (N : Node_Id) is
+ Called_Subprogram : constant Entity_Id := Entity (Name (N));
+ RCI_Package : constant Entity_Id := Scope (Called_Subprogram);
+ Loc : constant Source_Ptr := Sloc (N);
+ RCI_Locator : Node_Id;
+ RCI_Cache : Entity_Id;
+ Calling_Stubs : Node_Id;
+ E_Calling_Stubs : Entity_Id;
- After_Statements : constant List_Id := New_List;
- -- Statements to be executed after the subprogram call
+ begin
+ E_Calling_Stubs := RCI_Calling_Stubs_Table.Get (Called_Subprogram);
- Inner_Decls : List_Id := No_List;
- -- In case of a function, the inner declarations are needed since
- -- the result may be unconstrained.
+ if E_Calling_Stubs = Empty then
+ RCI_Cache := RCI_Locator_Table.Get (RCI_Package);
- Excep_Handler : Node_Id;
- Excep_Choice : Entity_Id;
- Excep_Code : List_Id;
+ if RCI_Cache = Empty then
+ RCI_Locator :=
+ RCI_Package_Locator
+ (Loc, Specification (Unit_Declaration_Node (RCI_Package)));
+ Prepend_To (Current_Sem_Unit_Declarations, RCI_Locator);
- Parameter_List : constant List_Id := New_List;
- -- List of parameters to be passed to the subprogram
+ -- The RCI_Locator package is inserted at the top level in the
+ -- current unit, and must appear in the proper scope, so that it
+ -- is not prematurely removed by the GCC back-end.
- Current_Parameter : Node_Id;
+ declare
+ Scop : constant Entity_Id := Cunit_Entity (Current_Sem_Unit);
- Ordered_Parameters_List : constant List_Id :=
- Build_Ordered_Parameters_List
- (Specification (Vis_Decl));
+ begin
+ if Ekind (Scop) = E_Package_Body then
+ New_Scope (Spec_Entity (Scop));
- Subp_Spec : Node_Id;
- -- Subprogram specification
+ elsif Ekind (Scop) = E_Subprogram_Body then
+ New_Scope
+ (Corresponding_Spec (Unit_Declaration_Node (Scop)));
- Called_Subprogram : Node_Id;
- -- The subprogram to call
+ else
+ New_Scope (Scop);
+ end if;
- Null_Raise_Statement : Node_Id;
+ Analyze (RCI_Locator);
+ Pop_Scope;
+ end;
- Dynamic_Async : Entity_Id;
+ RCI_Cache := Defining_Unit_Name (RCI_Locator);
+
+ else
+ RCI_Locator := Parent (RCI_Cache);
+ end if;
- begin
- if RACW_Type /= Empty then
- Called_Subprogram :=
- New_Occurrence_Of (Parent_Primitive, Loc);
- else
- Called_Subprogram :=
- New_Occurrence_Of (
- Defining_Unit_Name (Specification (Vis_Decl)), Loc);
+ Calling_Stubs := Build_Subprogram_Calling_Stubs
+ (Vis_Decl => Parent (Parent (Called_Subprogram)),
+ Subp_Id =>
+ Build_Subprogram_Id (Loc, Called_Subprogram),
+ Asynchronous => Nkind (N) = N_Procedure_Call_Statement
+ and then
+ Is_Asynchronous (Called_Subprogram),
+ Locator => RCI_Cache,
+ New_Name => New_Internal_Name ('S'));
+ Insert_After (RCI_Locator, Calling_Stubs);
+ Analyze (Calling_Stubs);
+ E_Calling_Stubs := Defining_Unit_Name (Specification (Calling_Stubs));
end if;
- Stream_Parameter :=
- Make_Defining_Identifier (Loc, New_Internal_Name ('S'));
+ Rewrite (Name (N), New_Occurrence_Of (E_Calling_Stubs, Loc));
+ end Expand_All_Calls_Remote_Subprogram_Call;
- if Dynamically_Asynchronous then
- Dynamic_Async :=
- Make_Defining_Identifier (Loc, New_Internal_Name ('S'));
- else
- Dynamic_Async := Empty;
- end if;
+ ---------------------------------
+ -- Expand_Calling_Stubs_Bodies --
+ ---------------------------------
- if not Asynchronous or else Dynamically_Asynchronous then
- Result_Parameter :=
- Make_Defining_Identifier (Loc, New_Internal_Name ('S'));
+ procedure Expand_Calling_Stubs_Bodies (Unit_Node : Node_Id) is
+ Spec : constant Node_Id := Specification (Unit_Node);
+ Decls : constant List_Id := Visible_Declarations (Spec);
- -- The first statement after the subprogram call is a statement to
- -- writes a Null_Occurrence into the result stream.
+ begin
+ New_Scope (Scope_Of_Spec (Spec));
+ Add_Calling_Stubs_To_Declarations
+ (Specification (Unit_Node), Decls);
+ Pop_Scope;
+ end Expand_Calling_Stubs_Bodies;
- 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)));
+ -----------------------------------
+ -- Expand_Receiving_Stubs_Bodies --
+ -----------------------------------
- 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;
+ procedure Expand_Receiving_Stubs_Bodies (Unit_Node : Node_Id) is
+ Spec : Node_Id;
+ Decls : List_Id;
+ Temp : List_Id;
- Append_To (After_Statements, Null_Raise_Statement);
+ begin
+ if Nkind (Unit_Node) = N_Package_Declaration then
+ Spec := Specification (Unit_Node);
+ Decls := Visible_Declarations (Spec);
+ New_Scope (Scope_Of_Spec (Spec));
+ Add_Receiving_Stubs_To_Declarations (Spec, Decls);
else
- Result_Parameter := Empty;
+ Spec :=
+ Package_Specification_Of_Scope (Corresponding_Spec (Unit_Node));
+ Decls := Declarations (Unit_Node);
+ New_Scope (Scope_Of_Spec (Unit_Node));
+ Temp := New_List;
+ Add_Receiving_Stubs_To_Declarations (Spec, Temp);
+ Insert_List_Before (First (Decls), Temp);
end if;
- -- 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);
+ Pop_Scope;
+ end Expand_Receiving_Stubs_Bodies;
- while Current_Parameter /= Empty loop
+ --------------------
+ -- GARLIC_Support --
+ --------------------
- declare
- Etyp : Entity_Id;
- RACW_Controlling : Boolean;
- Constrained : Boolean;
- Object : Entity_Id;
- Expr : Node_Id := Empty;
+ package body GARLIC_Support is
- begin
- Object := Make_Defining_Identifier (Loc, New_Internal_Name ('P'));
- Set_Ekind (Object, E_Variable);
+ -- Local subprograms
- RACW_Controlling :=
- Is_RACW_Controlling_Formal (Current_Parameter, Stub_Type);
+ procedure Add_RACW_Read_Attribute
+ (RACW_Type : Entity_Id;
+ Stub_Type : Entity_Id;
+ Stub_Type_Access : Entity_Id;
+ Declarations : List_Id);
+ -- Add Read attribute in Decls for the RACW type. The Read attribute
+ -- is added right after the RACW_Type declaration while the body is
+ -- inserted after Declarations.
- if RACW_Controlling then
+ procedure Add_RACW_Write_Attribute
+ (RACW_Type : Entity_Id;
+ Stub_Type : Entity_Id;
+ Stub_Type_Access : Entity_Id;
+ RPC_Receiver : Node_Id;
+ Declarations : List_Id);
+ -- Same thing for the Write attribute
- -- We have a controlling formal parameter. Read its address
- -- rather than a real object. The address is in Unsigned_64
- -- form.
+ function Stream_Parameter return Node_Id;
+ function Result return Node_Id;
+ function Object return Node_Id renames Result;
+ -- Functions to create occurrences of the formal parameter names of
+ -- the 'Read and 'Write attributes.
+
+ Loc : Source_Ptr;
+ -- Shared source location used by Add_{Read,Write}_Read_Attribute
+ -- and their ancillary subroutines (set on entry by Add_RACW_Features).
+
+ procedure Add_RAS_Access_TSS (N : Node_Id);
+ -- Add a subprogram body for RAS Access TSS
+
+ -----------------------
+ -- Add_RACW_Features --
+ -----------------------
+
+ procedure Add_RACW_Features
+ (RACW_Type : Entity_Id;
+ Stub_Type : Entity_Id;
+ Stub_Type_Access : Entity_Id;
+ RPC_Receiver_Decl : Node_Id;
+ Declarations : List_Id)
+ is
+ RPC_Receiver : Node_Id;
+ Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type);
- Etyp := RTE (RE_Unsigned_64);
- else
- Etyp := Etype (Parameter_Type (Current_Parameter));
- end if;
+ begin
+ Loc := Sloc (RACW_Type);
- Constrained :=
- Is_Constrained (Etyp) or else Is_Elementary_Type (Etyp);
+ if Is_RAS then
- 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.
+ -- For a RAS, the RPC receiver is that of the RCI unit,
+ -- not that of the corresponding distributed object type.
+ -- We retrieve its address from the local proxy object.
- 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))));
+ RPC_Receiver := Make_Selected_Component (Loc,
+ Prefix =>
+ Unchecked_Convert_To (RTE (RE_RAS_Proxy_Type_Access), Object),
+ Selector_Name => Make_Identifier (Loc, Name_Receiver));
- else
- 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;
+ else
+ RPC_Receiver := Make_Attribute_Reference (Loc,
+ Prefix => New_Occurrence_Of (
+ Defining_Unit_Name (Specification (RPC_Receiver_Decl)), Loc),
+ Attribute_Name => Name_Address);
+ end if;
- -- 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.
+ Add_RACW_Write_Attribute (
+ RACW_Type,
+ Stub_Type,
+ Stub_Type_Access,
+ RPC_Receiver,
+ Declarations);
+
+ Add_RACW_Read_Attribute (
+ RACW_Type,
+ Stub_Type,
+ Stub_Type_Access,
+ Declarations);
+ end Add_RACW_Features;
+
+ -----------------------------
+ -- Add_RACW_Read_Attribute --
+ -----------------------------
+
+ procedure Add_RACW_Read_Attribute
+ (RACW_Type : Entity_Id;
+ Stub_Type : Entity_Id;
+ Stub_Type_Access : Entity_Id;
+ Declarations : List_Id)
+ is
+ Proc_Decl : Node_Id;
+ Attr_Decl : Node_Id;
+
+ Body_Node : Node_Id;
+
+ Decls : List_Id;
+ Statements : List_Id;
+ Local_Statements : List_Id;
+ Remote_Statements : List_Id;
+ -- Various parts of the procedure
+
+ Procedure_Name : constant Name_Id :=
+ New_Internal_Name ('R');
+ Source_Partition : constant Entity_Id :=
+ Make_Defining_Identifier
+ (Loc, New_Internal_Name ('P'));
+ Source_Receiver : constant Entity_Id :=
+ Make_Defining_Identifier
+ (Loc, New_Internal_Name ('S'));
+ Source_Address : constant Entity_Id :=
+ Make_Defining_Identifier
+ (Loc, New_Internal_Name ('P'));
+ Local_Stub : constant Entity_Id :=
+ Make_Defining_Identifier
+ (Loc, New_Internal_Name ('L'));
+ Stubbed_Result : constant Entity_Id :=
+ Make_Defining_Identifier
+ (Loc, New_Internal_Name ('S'));
+ Asynchronous_Flag : constant Entity_Id :=
+ Asynchronous_Flags_Table.Get (RACW_Type);
+ pragma Assert (Present (Asynchronous_Flag));
+
+ -- Start of processing for Add_RACW_Read_Attribute
- 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));
+ begin
+ -- Generate object declarations
- -- 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.
+ Decls := New_List (
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Source_Partition,
+ Object_Definition =>
+ New_Occurrence_Of (RTE (RE_Partition_ID), Loc)),
- 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;
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Source_Receiver,
+ Object_Definition =>
+ New_Occurrence_Of (RTE (RE_Unsigned_64), Loc)),
- 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))))));
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Source_Address,
+ Object_Definition =>
+ New_Occurrence_Of (RTE (RE_Unsigned_64), 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;
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Local_Stub,
+ Aliased_Present => True,
+ Object_Definition => New_Occurrence_Of (Stub_Type, Loc)),
- 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;
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Stubbed_Result,
+ Object_Definition =>
+ New_Occurrence_Of (Stub_Type_Access, Loc),
+ Expression =>
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ New_Occurrence_Of (Local_Stub, Loc),
+ Attribute_Name =>
+ Name_Unchecked_Access)));
- -- 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.
+ -- Read the source Partition_ID and RPC_Receiver from incoming stream
- -- The case of Extra_Accessibility should also be handled ???
+ Statements := New_List (
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ New_Occurrence_Of (RTE (RE_Partition_ID), Loc),
+ Attribute_Name => Name_Read,
+ Expressions => New_List (
+ Stream_Parameter,
+ New_Occurrence_Of (Source_Partition, Loc))),
- 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));
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ New_Occurrence_Of (RTE (RE_Unsigned_64), Loc),
+ Attribute_Name =>
+ Name_Read,
+ Expressions => New_List (
+ Stream_Parameter,
+ New_Occurrence_Of (Source_Receiver, Loc))),
- Formal_Entity : constant Entity_Id :=
- Make_Defining_Identifier
- (Loc, Chars (Extra_Parameter));
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ New_Occurrence_Of (RTE (RE_Unsigned_64), Loc),
+ Attribute_Name =>
+ Name_Read,
+ Expressions => New_List (
+ Stream_Parameter,
+ New_Occurrence_Of (Source_Address, Loc))));
- Formal_Type : constant Entity_Id :=
- Etype (Extra_Parameter);
+ -- Build_Get_Unique_RP_Call needs the type of Stubbed_Result
- begin
- Append_To (Decls,
- Make_Object_Declaration (Loc,
- Defining_Identifier => Formal_Entity,
- Object_Definition =>
- New_Occurrence_Of (Formal_Type, Loc)));
+ Set_Etype (Stubbed_Result, Stub_Type_Access);
- 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;
+ -- If the Address is Null_Address, then return a null object
- Next (Current_Parameter);
- end loop;
+ Append_To (Statements,
+ Make_Implicit_If_Statement (RACW_Type,
+ Condition =>
+ Make_Op_Eq (Loc,
+ Left_Opnd => New_Occurrence_Of (Source_Address, Loc),
+ Right_Opnd => Make_Integer_Literal (Loc, Uint_0)),
+ Then_Statements => New_List (
+ Make_Assignment_Statement (Loc,
+ Name => Result,
+ Expression => Make_Null (Loc)),
+ Make_Return_Statement (Loc))));
+
+ -- If the RACW denotes an object created on the current partition,
+ -- Local_Statements will be executed. The real object will be used.
+
+ Local_Statements := New_List (
+ Make_Assignment_Statement (Loc,
+ Name => Result,
+ Expression =>
+ Unchecked_Convert_To (RACW_Type,
+ OK_Convert_To (RTE (RE_Address),
+ New_Occurrence_Of (Source_Address, Loc)))));
- -- Append the formal statements list at the end of regular statements
+ -- If the object is located on another partition, then a stub object
+ -- will be created with all the information needed to rebuild the
+ -- real object at the other end.
- Append_List_To (Statements, Extra_Formal_Statements);
+ Remote_Statements := New_List (
- if Nkind (Specification (Vis_Decl)) = N_Function_Specification then
+ Make_Assignment_Statement (Loc,
+ Name => Make_Selected_Component (Loc,
+ Prefix => New_Occurrence_Of (Stubbed_Result, Loc),
+ Selector_Name => Make_Identifier (Loc, Name_Origin)),
+ Expression =>
+ New_Occurrence_Of (Source_Partition, Loc)),
- -- The remote subprogram is a function. We build an inner block to
- -- be able to hold a potentially unconstrained result in a variable.
+ Make_Assignment_Statement (Loc,
+ Name => Make_Selected_Component (Loc,
+ Prefix => New_Occurrence_Of (Stubbed_Result, Loc),
+ Selector_Name => Make_Identifier (Loc, Name_Receiver)),
+ Expression =>
+ New_Occurrence_Of (Source_Receiver, Loc)),
- declare
- Etyp : constant Entity_Id :=
- Etype (Subtype_Mark (Specification (Vis_Decl)));
- Result : constant Node_Id :=
- Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
+ Make_Assignment_Statement (Loc,
+ Name => Make_Selected_Component (Loc,
+ Prefix => New_Occurrence_Of (Stubbed_Result, Loc),
+ Selector_Name => Make_Identifier (Loc, Name_Addr)),
+ Expression =>
+ New_Occurrence_Of (Source_Address, Loc)));
- 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 (Remote_Statements,
+ Make_Assignment_Statement (Loc,
+ Name => Make_Selected_Component (Loc,
+ Prefix => New_Occurrence_Of (Stubbed_Result, Loc),
+ Selector_Name => Make_Identifier (Loc, Name_Asynchronous)),
+ Expression =>
+ New_Occurrence_Of (Asynchronous_Flag, Loc)));
+
+ Append_List_To (Remote_Statements,
+ Build_Get_Unique_RP_Call (Loc, Stubbed_Result, Stub_Type));
+ -- ??? Issue with asynchronous calls here: the Asynchronous
+ -- flag is set on the stub type if, and only if, the RACW type
+ -- has a pragma Asynchronous. This is incorrect for RACWs that
+ -- implement RAS types, because in that case the /designated
+ -- subprogram/ (not the type) might be asynchronous, and
+ -- that causes the stub to need to be asynchronous too.
+ -- A solution is to transport a RAS as a struct containing
+ -- a RACW and an asynchronous flag, and to properly alter
+ -- the Asynchronous component in the stub type in the RAS's
+ -- Input TSS.
+
+ Append_To (Remote_Statements,
+ Make_Assignment_Statement (Loc,
+ Name => Result,
+ Expression => Unchecked_Convert_To (RACW_Type,
+ New_Occurrence_Of (Stubbed_Result, Loc))));
- 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;
+ -- Distinguish between the local and remote cases, and execute the
+ -- appropriate piece of code.
Append_To (Statements,
- Make_Block_Statement (Loc,
- Declarations => Inner_Decls,
- Handled_Statement_Sequence =>
- Make_Handled_Sequence_Of_Statements (Loc,
- Statements => After_Statements)));
+ Make_Implicit_If_Statement (RACW_Type,
+ Condition =>
+ Make_Op_Eq (Loc,
+ Left_Opnd =>
+ Make_Function_Call (Loc,
+ Name => New_Occurrence_Of (
+ RTE (RE_Get_Local_Partition_Id), Loc)),
+ Right_Opnd => New_Occurrence_Of (Source_Partition, Loc)),
+ Then_Statements => Local_Statements,
+ Else_Statements => Remote_Statements));
+
+ Build_Stream_Procedure
+ (Loc, RACW_Type, Body_Node,
+ Make_Defining_Identifier (Loc, Procedure_Name),
+ Statements, Outp => True);
+ Set_Declarations (Body_Node, Decls);
+
+ Proc_Decl := Make_Subprogram_Declaration (Loc,
+ Copy_Specification (Loc, Specification (Body_Node)));
+
+ Attr_Decl :=
+ Make_Attribute_Definition_Clause (Loc,
+ Name => New_Occurrence_Of (RACW_Type, Loc),
+ Chars => Name_Read,
+ Expression =>
+ New_Occurrence_Of (
+ Defining_Unit_Name (Specification (Proc_Decl)), Loc));
+
+ Insert_After (Declaration_Node (RACW_Type), Proc_Decl);
+ Insert_After (Proc_Decl, Attr_Decl);
+ Append_To (Declarations, Body_Node);
+ end Add_RACW_Read_Attribute;
+
+ ------------------------------
+ -- Add_RACW_Write_Attribute --
+ ------------------------------
+
+ procedure Add_RACW_Write_Attribute
+ (RACW_Type : Entity_Id;
+ Stub_Type : Entity_Id;
+ Stub_Type_Access : Entity_Id;
+ RPC_Receiver : Node_Id;
+ Declarations : List_Id)
+ is
+ Body_Node : Node_Id;
+ Proc_Decl : Node_Id;
+ Attr_Decl : Node_Id;
- else
- -- The remote subprogram is a procedure. We do not need any inner
- -- block in this case.
+ Statements : List_Id;
+ Local_Statements : List_Id;
+ Remote_Statements : List_Id;
+ Null_Statements : List_Id;
- if Dynamically_Asynchronous then
- Append_To (Decls,
- Make_Object_Declaration (Loc,
- Defining_Identifier => Dynamic_Async,
- Object_Definition =>
- New_Occurrence_Of (Standard_Boolean, Loc)));
+ Procedure_Name : constant Name_Id := New_Internal_Name ('R');
- 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;
+ begin
+ -- Build the code fragment corresponding to the marshalling of a
+ -- local object.
- Append_To (Statements,
- Make_Procedure_Call_Statement (Loc,
- Name => Called_Subprogram,
- Parameter_Associations => Parameter_List));
+ Local_Statements := New_List (
- Append_List_To (Statements, After_Statements);
- end if;
+ Pack_Entity_Into_Stream_Access (Loc,
+ Stream => Stream_Parameter,
+ Object => RTE (RE_Get_Local_Partition_Id)),
- if Asynchronous and then not Dynamically_Asynchronous then
+ Pack_Node_Into_Stream_Access (Loc,
+ Stream => Stream_Parameter,
+ Object => OK_Convert_To (RTE (RE_Unsigned_64), RPC_Receiver),
+ Etyp => RTE (RE_Unsigned_64)),
- -- An asynchronous procedure does not want a Result
- -- parameter. Also, we put an exception handler with an others
- -- clause that does nothing.
+ Pack_Node_Into_Stream_Access (Loc,
+ Stream => Stream_Parameter,
+ Object => OK_Convert_To (RTE (RE_Unsigned_64),
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ Make_Explicit_Dereference (Loc,
+ Prefix => Object),
+ Attribute_Name => Name_Address)),
+ Etyp => RTE (RE_Unsigned_64)));
- 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)))));
+ -- Build the code fragment corresponding to the marshalling of
+ -- a remote object.
- Excep_Handler :=
- Make_Exception_Handler (Loc,
- Exception_Choices =>
- New_List (Make_Others_Choice (Loc)),
- Statements => New_List (
- Make_Null_Statement (Loc)));
+ Remote_Statements := New_List (
- 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.
+ Pack_Node_Into_Stream_Access (Loc,
+ Stream => Stream_Parameter,
+ Object =>
+ Make_Selected_Component (Loc,
+ Prefix => Unchecked_Convert_To (Stub_Type_Access,
+ Object),
+ Selector_Name =>
+ Make_Identifier (Loc, Name_Origin)),
+ Etyp => RTE (RE_Partition_ID)),
- Excep_Choice :=
- Make_Defining_Identifier (Loc, New_Internal_Name ('E'));
+ Pack_Node_Into_Stream_Access (Loc,
+ Stream => Stream_Parameter,
+ Object =>
+ Make_Selected_Component (Loc,
+ Prefix => Unchecked_Convert_To (Stub_Type_Access,
+ Object),
+ Selector_Name =>
+ Make_Identifier (Loc, Name_Receiver)),
+ Etyp => RTE (RE_Unsigned_64)),
- 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))));
+ Pack_Node_Into_Stream_Access (Loc,
+ Stream => Stream_Parameter,
+ Object =>
+ Make_Selected_Component (Loc,
+ Prefix => Unchecked_Convert_To (Stub_Type_Access,
+ Object),
+ Selector_Name =>
+ Make_Identifier (Loc, Name_Addr)),
+ Etyp => RTE (RE_Unsigned_64)));
- 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;
+ -- Build the code fragment corresponding to the marshalling of a null
+ -- object.
- Excep_Handler :=
- Make_Exception_Handler (Loc,
- Choice_Parameter => Excep_Choice,
- Exception_Choices => New_List (Make_Others_Choice (Loc)),
- Statements => Excep_Code);
+ Null_Statements := New_List (
- Subp_Spec :=
- Make_Procedure_Specification (Loc,
- Defining_Unit_Name =>
- Make_Defining_Identifier (Loc, New_Internal_Name ('F')),
+ Pack_Entity_Into_Stream_Access (Loc,
+ Stream => Stream_Parameter,
+ Object => RTE (RE_Get_Local_Partition_Id)),
- 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))),
+ Pack_Node_Into_Stream_Access (Loc,
+ Stream => Stream_Parameter,
+ Object => OK_Convert_To (RTE (RE_Unsigned_64), RPC_Receiver),
+ Etyp => RTE (RE_Unsigned_64)),
- 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;
+ Pack_Node_Into_Stream_Access (Loc,
+ Stream => Stream_Parameter,
+ Object => Make_Integer_Literal (Loc, Uint_0),
+ Etyp => RTE (RE_Unsigned_64)));
- return
- Make_Subprogram_Body (Loc,
- Specification => Subp_Spec,
- Declarations => Decls,
- Handled_Statement_Sequence =>
- Make_Handled_Sequence_Of_Statements (Loc,
- Statements => Statements,
- Exception_Handlers => New_List (Excep_Handler)));
- end Build_Subprogram_Receiving_Stubs;
+ Statements := New_List (
+ Make_Implicit_If_Statement (RACW_Type,
+ Condition =>
+ Make_Op_Eq (Loc,
+ Left_Opnd => Object,
+ Right_Opnd => Make_Null (Loc)),
+ Then_Statements => Null_Statements,
+ Elsif_Parts => New_List (
+ Make_Elsif_Part (Loc,
+ Condition =>
+ Make_Op_Eq (Loc,
+ Left_Opnd =>
+ Make_Attribute_Reference (Loc,
+ Prefix => Object,
+ Attribute_Name => Name_Tag),
+ Right_Opnd =>
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Occurrence_Of (Stub_Type, Loc),
+ Attribute_Name => Name_Tag)),
+ Then_Statements => Remote_Statements)),
+ Else_Statements => Local_Statements));
+
+ Build_Stream_Procedure
+ (Loc, RACW_Type, Body_Node,
+ Make_Defining_Identifier (Loc, Procedure_Name),
+ Statements, Outp => False);
+
+ Proc_Decl := Make_Subprogram_Declaration (Loc,
+ Copy_Specification (Loc, Specification (Body_Node)));
+
+ Attr_Decl :=
+ Make_Attribute_Definition_Clause (Loc,
+ Name => New_Occurrence_Of (RACW_Type, Loc),
+ Chars => Name_Write,
+ Expression =>
+ New_Occurrence_Of (
+ Defining_Unit_Name (Specification (Proc_Decl)), Loc));
- ------------------------
- -- Copy_Specification --
- ------------------------
+ Insert_After (Declaration_Node (RACW_Type), Proc_Decl);
+ Insert_After (Proc_Decl, Attr_Decl);
+ Append_To (Declarations, Body_Node);
+ end Add_RACW_Write_Attribute;
- 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;
+ ------------------------
+ -- Add_RAS_Access_TSS --
+ ------------------------
- Current_Parameter : Node_Id;
- Current_Identifier : Entity_Id;
- Current_Type : Node_Id;
- Current_Etype : Entity_Id;
+ procedure Add_RAS_Access_TSS (N : Node_Id) is
+ Loc : constant Source_Ptr := Sloc (N);
- Name_For_New_Spec : Name_Id;
+ Ras_Type : constant Entity_Id := Defining_Identifier (N);
+ Fat_Type : constant Entity_Id := Equivalent_Type (Ras_Type);
+ -- Ras_Type is the access to subprogram type while Fat_Type is the
+ -- corresponding record type.
- New_Identifier : Entity_Id;
+ RACW_Type : constant Entity_Id :=
+ Underlying_RACW_Type (Ras_Type);
+ Desig : constant Entity_Id :=
+ Etype (Designated_Type (RACW_Type));
- begin
- if New_Name = No_Name then
- pragma Assert (Nkind (Spec) = N_Function_Specification
- or else Nkind (Spec) = N_Procedure_Specification);
+ Stub_Elements : constant Stub_Structure :=
+ Stubs_Table.Get (Desig);
+ pragma Assert (Stub_Elements /= Empty_Stub_Structure);
- Name_For_New_Spec := Chars (Defining_Unit_Name (Spec));
- else
- Name_For_New_Spec := New_Name;
- end if;
+ Proc : constant Entity_Id :=
+ Make_Defining_Identifier (Loc,
+ Chars => Make_TSS_Name (Ras_Type, TSS_RAS_Access));
- if Present (Parameter_Specifications (Spec)) then
- Parameters := New_List;
- Current_Parameter := First (Parameter_Specifications (Spec));
- while Current_Parameter /= Empty loop
- Current_Identifier := Defining_Identifier (Current_Parameter);
- Current_Type := Parameter_Type (Current_Parameter);
+ Proc_Spec : Node_Id;
- if Nkind (Current_Type) = N_Access_Definition then
- Current_Etype := Entity (Subtype_Mark (Current_Type));
+ -- Formal parameters
- if Present (Object_Type) then
- pragma Assert (
- Root_Type (Current_Etype) = Root_Type (Object_Type));
- Current_Type :=
- Make_Access_Definition (Loc,
- Subtype_Mark => New_Occurrence_Of (Stub_Type, Loc));
- else
- Current_Type :=
- Make_Access_Definition (Loc,
- Subtype_Mark =>
- New_Occurrence_Of (Current_Etype, Loc));
- end if;
+ Package_Name : constant Entity_Id :=
+ Make_Defining_Identifier (Loc,
+ Chars => Name_P);
+ -- Target package
- else
- Current_Etype := Entity (Current_Type);
+ Subp_Id : constant Entity_Id :=
+ Make_Defining_Identifier (Loc,
+ Chars => Name_S);
+ -- Target subprogram
- if Object_Type /= Empty
- and then Current_Etype = Object_Type
- then
- Current_Type := New_Occurrence_Of (Stub_Type, Loc);
- else
- Current_Type := New_Occurrence_Of (Current_Etype, Loc);
- end if;
- end if;
+ Asynch_P : constant Entity_Id :=
+ Make_Defining_Identifier (Loc,
+ Chars => Name_Asynchronous);
+ -- Is the procedure to which the 'Access applies asynchronous?
- New_Identifier := Make_Defining_Identifier (Loc,
- Chars (Current_Identifier));
+ All_Calls_Remote : constant Entity_Id :=
+ Make_Defining_Identifier (Loc,
+ Chars => Name_All_Calls_Remote);
+ -- True if an All_Calls_Remote pragma applies to the RCI unit
+ -- that contains the subprogram.
- Append_To (Parameters,
- Make_Parameter_Specification (Loc,
- Defining_Identifier => New_Identifier,
- Parameter_Type => Current_Type,
- In_Present => In_Present (Current_Parameter),
- Out_Present => Out_Present (Current_Parameter),
- Expression =>
- New_Copy_Tree (Expression (Current_Parameter))));
+ -- Common local variables
- Next (Current_Parameter);
- end loop;
- end if;
+ Proc_Decls : List_Id;
+ Proc_Statements : List_Id;
- case Nkind (Spec) is
+ Origin : constant Entity_Id :=
+ Make_Defining_Identifier (Loc,
+ Chars => New_Internal_Name ('P'));
- when N_Function_Specification | N_Access_Function_Definition =>
- return
- Make_Function_Specification (Loc,
- Defining_Unit_Name =>
- Make_Defining_Identifier (Loc,
- Chars => Name_For_New_Spec),
- Parameter_Specifications => Parameters,
- Subtype_Mark =>
- New_Occurrence_Of (Entity (Subtype_Mark (Spec)), Loc));
+ -- Additional local variables for the local case
- when N_Procedure_Specification | N_Access_Procedure_Definition =>
+ Proxy_Addr : constant Entity_Id :=
+ Make_Defining_Identifier (Loc,
+ Chars => New_Internal_Name ('P'));
+
+ -- Additional local variables for the remote case
+
+ Local_Stub : constant Entity_Id :=
+ Make_Defining_Identifier (Loc,
+ Chars => New_Internal_Name ('L'));
+
+ Stub_Ptr : constant Entity_Id :=
+ Make_Defining_Identifier (Loc,
+ Chars => New_Internal_Name ('S'));
+
+ function Set_Field
+ (Field_Name : Name_Id;
+ Value : Node_Id) return Node_Id;
+ -- Construct an assignment that sets the named component in the
+ -- returned record
+
+ ---------------
+ -- Set_Field --
+ ---------------
+
+ function Set_Field
+ (Field_Name : Name_Id;
+ Value : Node_Id) return Node_Id
+ is
+ begin
return
- Make_Procedure_Specification (Loc,
- Defining_Unit_Name =>
- Make_Defining_Identifier (Loc,
- Chars => Name_For_New_Spec),
- Parameter_Specifications => Parameters);
+ Make_Assignment_Statement (Loc,
+ Name =>
+ Make_Selected_Component (Loc,
+ Prefix => New_Occurrence_Of (Stub_Ptr, Loc),
+ Selector_Name => Make_Identifier (Loc, Field_Name)),
+ Expression => Value);
+ end Set_Field;
- when others =>
- raise Program_Error;
- end case;
- end Copy_Specification;
+ -- Start of processing for Add_RAS_Access_TSS
- ---------------------------
- -- Could_Be_Asynchronous --
- ---------------------------
+ begin
+ Proc_Decls := New_List (
- function Could_Be_Asynchronous (Spec : Node_Id) return Boolean is
- Current_Parameter : Node_Id;
+ -- Common declarations
- begin
- if Present (Parameter_Specifications (Spec)) then
- Current_Parameter := First (Parameter_Specifications (Spec));
- while Current_Parameter /= Empty loop
- if Out_Present (Current_Parameter) then
- return False;
- end if;
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Origin,
+ Constant_Present => True,
+ Object_Definition =>
+ New_Occurrence_Of (RTE (RE_Partition_ID), Loc),
+ Expression =>
+ Make_Function_Call (Loc,
+ Name =>
+ New_Occurrence_Of (RTE (RE_Get_Active_Partition_Id), Loc),
+ Parameter_Associations => New_List (
+ New_Occurrence_Of (Package_Name, Loc)))),
- Next (Current_Parameter);
- end loop;
- end if;
+ -- Declaration use only in the local case: proxy address
- return True;
- end Could_Be_Asynchronous;
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Proxy_Addr,
+ Object_Definition =>
+ New_Occurrence_Of (RTE (RE_Unsigned_64), Loc)),
- ---------------------------------------------
- -- Expand_All_Calls_Remote_Subprogram_Call --
- ---------------------------------------------
+ -- Declarations used only in the remote case: stub object and
+ -- stub pointer.
- procedure Expand_All_Calls_Remote_Subprogram_Call (N : Node_Id) is
- Called_Subprogram : constant Entity_Id := Entity (Name (N));
- RCI_Package : constant Entity_Id := Scope (Called_Subprogram);
- Loc : constant Source_Ptr := Sloc (N);
- RCI_Locator : Node_Id;
- RCI_Cache : Entity_Id;
- Calling_Stubs : Node_Id;
- E_Calling_Stubs : Entity_Id;
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Local_Stub,
+ Aliased_Present => True,
+ Object_Definition =>
+ New_Occurrence_Of (Stub_Elements.Stub_Type, Loc)),
- begin
- E_Calling_Stubs := RCI_Calling_Stubs_Table.Get (Called_Subprogram);
+ Make_Object_Declaration (Loc,
+ Defining_Identifier =>
+ Stub_Ptr,
+ Object_Definition =>
+ New_Occurrence_Of (Stub_Elements.Stub_Type_Access, Loc),
+ Expression =>
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Occurrence_Of (Local_Stub, Loc),
+ Attribute_Name => Name_Unchecked_Access)));
- if E_Calling_Stubs = Empty then
- RCI_Cache := RCI_Locator_Table.Get (RCI_Package);
+ Set_Etype (Stub_Ptr, Stub_Elements.Stub_Type_Access);
+ -- Build_Get_Unique_RP_Call needs this information
- if RCI_Cache = Empty then
- RCI_Locator :=
- RCI_Package_Locator
- (Loc, Specification (Unit_Declaration_Node (RCI_Package)));
- Prepend_To (Current_Sem_Unit_Declarations, RCI_Locator);
+ -- Note: Here we assume that the Fat_Type is a record
+ -- containing just a pointer to a proxy or stub object.
- -- The RCI_Locator package is inserted at the top level in the
- -- current unit, and must appear in the proper scope, so that it
- -- is not prematurely removed by the GCC back-end.
+ Proc_Statements := New_List (
- declare
- Scop : constant Entity_Id := Cunit_Entity (Current_Sem_Unit);
+ -- Generate:
- begin
- if Ekind (Scop) = E_Package_Body then
- New_Scope (Spec_Entity (Scop));
+ -- Get_RAS_Info (Pkg, Subp, PA);
+ -- if Origin = Local_Partition_Id
+ -- and then not All_Calls_Remote
+ -- then
+ -- return Fat_Type!(PA);
+ -- end if;
- elsif Ekind (Scop) = E_Subprogram_Body then
- New_Scope
- (Corresponding_Spec (Unit_Declaration_Node (Scop)));
+ Make_Procedure_Call_Statement (Loc,
+ Name =>
+ New_Occurrence_Of (RTE (RE_Get_RAS_Info), Loc),
+ Parameter_Associations => New_List (
+ New_Occurrence_Of (Package_Name, Loc),
+ New_Occurrence_Of (Subp_Id, Loc),
+ New_Occurrence_Of (Proxy_Addr, Loc))),
+
+ Make_Implicit_If_Statement (N,
+ Condition =>
+ Make_And_Then (Loc,
+ Left_Opnd =>
+ Make_Op_Eq (Loc,
+ Left_Opnd =>
+ New_Occurrence_Of (Origin, Loc),
+ Right_Opnd =>
+ Make_Function_Call (Loc,
+ New_Occurrence_Of (
+ RTE (RE_Get_Local_Partition_Id), Loc))),
+ Right_Opnd =>
+ Make_Op_Not (Loc,
+ New_Occurrence_Of (All_Calls_Remote, Loc))),
+ Then_Statements => New_List (
+ Make_Return_Statement (Loc,
+ Unchecked_Convert_To (Fat_Type,
+ OK_Convert_To (RTE (RE_Address),
+ New_Occurrence_Of (Proxy_Addr, Loc)))))),
+
+ Set_Field (Name_Origin,
+ New_Occurrence_Of (Origin, Loc)),
+
+ Set_Field (Name_Receiver,
+ Make_Function_Call (Loc,
+ Name =>
+ New_Occurrence_Of (RTE (RE_Get_RCI_Package_Receiver), Loc),
+ Parameter_Associations => New_List (
+ New_Occurrence_Of (Package_Name, Loc)))),
+
+ Set_Field (Name_Addr, New_Occurrence_Of (Proxy_Addr, Loc)),
+
+ -- 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
+ -- type, to which a pragma Asynchronous applies.
+
+ -- Parameter Asynch_P is true when the procedure is asynchronous;
+ -- Expression Asynch_T is true when the type is asynchronous.
+
+ Set_Field (Name_Asynchronous,
+ Make_Or_Else (Loc,
+ New_Occurrence_Of (Asynch_P, Loc),
+ New_Occurrence_Of (Boolean_Literals (
+ Is_Asynchronous (Ras_Type)), Loc))));
+
+ Append_List_To (Proc_Statements,
+ Build_Get_Unique_RP_Call
+ (Loc, Stub_Ptr, Stub_Elements.Stub_Type));
+
+ -- Return the newly created value
+
+ Append_To (Proc_Statements,
+ Make_Return_Statement (Loc,
+ Expression =>
+ Unchecked_Convert_To (Fat_Type,
+ New_Occurrence_Of (Stub_Ptr, Loc))));
- else
- New_Scope (Scop);
- end if;
+ Proc_Spec :=
+ Make_Function_Specification (Loc,
+ Defining_Unit_Name => Proc,
+ Parameter_Specifications => New_List (
+ Make_Parameter_Specification (Loc,
+ Defining_Identifier => Package_Name,
+ Parameter_Type =>
+ New_Occurrence_Of (Standard_String, Loc)),
- Analyze (RCI_Locator);
- Pop_Scope;
- end;
+ Make_Parameter_Specification (Loc,
+ Defining_Identifier => Subp_Id,
+ Parameter_Type =>
+ New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc)),
- RCI_Cache := Defining_Unit_Name (RCI_Locator);
+ Make_Parameter_Specification (Loc,
+ Defining_Identifier => Asynch_P,
+ Parameter_Type =>
+ New_Occurrence_Of (Standard_Boolean, Loc)),
- else
- RCI_Locator := Parent (RCI_Cache);
- end if;
+ Make_Parameter_Specification (Loc,
+ Defining_Identifier => All_Calls_Remote,
+ Parameter_Type =>
+ New_Occurrence_Of (Standard_Boolean, Loc))),
- Calling_Stubs := Build_Subprogram_Calling_Stubs
- (Vis_Decl => Parent (Parent (Called_Subprogram)),
- Subp_Id => Get_Subprogram_Id (Called_Subprogram),
- Asynchronous => Nkind (N) = N_Procedure_Call_Statement
- and then
- Is_Asynchronous (Called_Subprogram),
- Locator => RCI_Cache,
- New_Name => New_Internal_Name ('S'));
- Insert_After (RCI_Locator, Calling_Stubs);
- Analyze (Calling_Stubs);
- E_Calling_Stubs := Defining_Unit_Name (Specification (Calling_Stubs));
- end if;
+ Subtype_Mark =>
+ New_Occurrence_Of (Fat_Type, Loc));
- Rewrite (Name (N), New_Occurrence_Of (E_Calling_Stubs, Loc));
- end Expand_All_Calls_Remote_Subprogram_Call;
+ -- Set the kind and return type of the function to prevent
+ -- ambiguities between Ras_Type and Fat_Type in subsequent analysis.
- ---------------------------------
- -- Expand_Calling_Stubs_Bodies --
- ---------------------------------
+ Set_Ekind (Proc, E_Function);
+ Set_Etype (Proc, Fat_Type);
- procedure Expand_Calling_Stubs_Bodies (Unit_Node : Node_Id) is
- Spec : constant Node_Id := Specification (Unit_Node);
- Decls : constant List_Id := Visible_Declarations (Spec);
+ Discard_Node (
+ Make_Subprogram_Body (Loc,
+ Specification => Proc_Spec,
+ Declarations => Proc_Decls,
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements => Proc_Statements)));
- begin
- New_Scope (Scope_Of_Spec (Spec));
- Add_Calling_Stubs_To_Declarations (Specification (Unit_Node),
- Decls);
- Pop_Scope;
- end Expand_Calling_Stubs_Bodies;
+ Set_TSS (Fat_Type, Proc);
+ end Add_RAS_Access_TSS;
- -----------------------------------
- -- Expand_Receiving_Stubs_Bodies --
- -----------------------------------
+ -----------------------
+ -- Add_RAST_Features --
+ -----------------------
- procedure Expand_Receiving_Stubs_Bodies (Unit_Node : Node_Id) is
- Spec : Node_Id;
- Decls : List_Id;
- Temp : List_Id;
+ procedure Add_RAST_Features
+ (Vis_Decl : Node_Id;
+ RAS_Type : Entity_Id;
+ Decls : List_Id)
+ is
+ pragma Warnings (Off);
+ pragma Unreferenced (RAS_Type, Decls);
+ pragma Warnings (On);
+ begin
+ Add_RAS_Access_TSS (Vis_Decl);
+ end Add_RAST_Features;
- begin
- if Nkind (Unit_Node) = N_Package_Declaration then
- Spec := Specification (Unit_Node);
- Decls := Visible_Declarations (Spec);
- New_Scope (Scope_Of_Spec (Spec));
- Add_Receiving_Stubs_To_Declarations (Spec, Decls);
+ ------------
+ -- Result --
+ ------------
- else
- Spec :=
- Package_Specification_Of_Scope (Corresponding_Spec (Unit_Node));
- Decls := Declarations (Unit_Node);
- New_Scope (Scope_Of_Spec (Unit_Node));
- Temp := New_List;
- Add_Receiving_Stubs_To_Declarations (Spec, Temp);
- Insert_List_Before (First (Decls), Temp);
- end if;
+ function Result return Node_Id is
+ begin
+ return Make_Identifier (Loc, Name_V);
+ end Result;
- Pop_Scope;
- end Expand_Receiving_Stubs_Bodies;
+ ----------------------
+ -- Stream_Parameter --
+ ----------------------
- -------------------------
- -- Get_Pkg_Name_string --
- -------------------------
+ function Stream_Parameter return Node_Id is
+ begin
+ return Make_Identifier (Loc, Name_S);
+ end Stream_Parameter;
+
+ end GARLIC_Support;
- procedure Get_Pkg_Name_String (Decl_Node : Node_Id) is
- Unit_Name_Id : constant Unit_Name_Type := Get_Unit_Name (Decl_Node);
+ ------------------
+ -- 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
- Get_Unit_Name_String (Unit_Name_Id);
+ return PCS_Name;
+ end Get_PCS_Name;
- -- Remove seven last character (" (spec)" or " (body)").
+ -----------------------
+ -- Get_Subprogram_Id --
+ -----------------------
- Name_Len := Name_Len - 7;
- pragma Assert (Name_Buffer (Name_Len + 1) = ' ');
- end Get_Pkg_Name_String;
+ 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 (E : Entity_Id) return Int is
+ 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;
- Result : Int := First_RCI_Subprogram_Id;
+ Current_Subp : Entity_Id;
+ Current_Subp_Str : String_Id;
+ Current_Subp_Number : Int := First_RCI_Subprogram_Id;
begin
- pragma Assert
- (Is_Remote_Call_Interface (Scope (E))
- and then
- (Nkind (Parent (E)) = N_Procedure_Specification
- or else
- Nkind (Parent (E)) = N_Function_Specification));
+ if Result.Str_Identifier = No_String then
- Current_Declaration :=
- First (Visible_Declarations
- (Package_Specification_Of_Scope (Scope (E))));
+ -- 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.
- while Current_Declaration /= Empty loop
- if Nkind (Current_Declaration) = N_Subprogram_Declaration
- and then Comes_From_Source (Current_Declaration)
- then
- if Defining_Unit_Name
- (Specification (Current_Declaration)) = E
+ pragma Assert
+ (Is_Remote_Call_Interface (Scope (Def))
+ and then
+ (Nkind (Parent (Def)) = N_Procedure_Specification
+ or else
+ Nkind (Parent (Def)) = N_Function_Specification));
+
+ Current_Declaration :=
+ First (Visible_Declarations
+ (Package_Specification_Of_Scope (Scope (Def))));
+ while Present (Current_Declaration) loop
+ if Nkind (Current_Declaration) = N_Subprogram_Declaration
+ and then Comes_From_Source (Current_Declaration)
then
- return Result;
- end if;
+ Current_Subp := Defining_Unit_Name (Specification (
+ Current_Declaration));
+ Assign_Subprogram_Identifier
+ (Current_Subp, Current_Subp_Number, Current_Subp_Str);
- Result := Result + 1;
- end if;
+ if Current_Subp = Def then
+ Result := (Current_Subp_Str, Current_Subp_Number);
+ end if;
- Next (Current_Declaration);
- end loop;
+ Current_Subp_Number := Current_Subp_Number + 1;
+ end if;
- -- Error if we do not find it
+ Next (Current_Declaration);
+ end loop;
+ end if;
- raise Program_Error;
- end Get_Subprogram_Id;
+ pragma Assert (Result.Str_Identifier /= No_String);
+ return Result;
+ end Get_Subprogram_Ids;
----------
-- Hash --
return Hash_Index (Natural (F) mod Positive (Hash_Index'Last + 1));
end Hash;
+ ----------
+ -- Hash --
+ ----------
+
+ function Hash (F : Name_Id) return Hash_Index is
+ begin
+ return Hash_Index (Natural (F) mod Positive (Hash_Index'Last + 1));
+ end Hash;
+
--------------------------
-- Input_With_Tag_Check --
--------------------------
function Input_With_Tag_Check
(Loc : Source_Ptr;
Var_Type : Entity_Id;
- Stream : Entity_Id)
- return Node_Id
+ Stream : Entity_Id) return Node_Id
is
begin
return
function Is_RACW_Controlling_Formal
(Parameter : Node_Id;
- Stub_Type : Entity_Id)
- return Boolean
+ Stub_Type : Entity_Id) return Boolean
is
Typ : Entity_Id;
function Need_Extra_Constrained (Parameter : Node_Id) return Boolean is
Etyp : constant Entity_Id := Etype (Parameter_Type (Parameter));
-
begin
return Out_Present (Parameter)
and then Has_Discriminants (Etyp)
Typ : Entity_Id;
begin
- if Etyp /= Empty then
+ if Present (Etyp) then
Typ := Etyp;
else
Typ := Etype (Object);
Object));
end Pack_Node_Into_Stream_Access;
+ ---------------------
+ -- PolyORB_Support --
+ ---------------------
+
+ package body PolyORB_Support is
+
+ pragma Warnings (Off);
+ -- Currently, this package contains empty placeholders
+ -- that do not reference their parameters.
+
+ -----------------------
+ -- Add_RACW_Features --
+ -----------------------
+
+ procedure Add_RACW_Features
+ (RACW_Type : Entity_Id;
+ Desig : Entity_Id;
+ Stub_Type : Entity_Id;
+ Stub_Type_Access : Entity_Id;
+ RPC_Receiver_Decl : Node_Id;
+ Declarations : List_Id)
+ is
+ begin
+ raise Program_Error;
+ end Add_RACW_Features;
+
+ -----------------------
+ -- Add_RAST_Features --
+ -----------------------
+
+ procedure Add_RAST_Features
+ (Vis_Decl : Node_Id;
+ RAS_Type : Entity_Id;
+ Decls : List_Id) is
+ begin
+ raise Program_Error;
+ end Add_RAST_Features;
+
+ pragma Warnings (On);
+
+ end PolyORB_Support;
+
-------------------------------
-- RACW_Type_Is_Asynchronous --
-------------------------------
procedure RACW_Type_Is_Asynchronous (RACW_Type : Entity_Id) is
Asynchronous_Flag : constant Entity_Id :=
- Asynchronous_Flags_Table.Get (RACW_Type);
+ Asynchronous_Flags_Table.Get (RACW_Type);
begin
Replace (Expression (Parent (Asynchronous_Flag)),
New_Occurrence_Of (Standard_True, Sloc (Asynchronous_Flag)));
(Loc : Source_Ptr;
Package_Spec : Node_Id) return Node_Id
is
- Inst : Node_Id;
+ Inst : Node_Id;
Pkg_Name : String_Id;
begin
- Get_Pkg_Name_String (Package_Spec);
+ Get_Library_Unit_Name_String (Package_Spec);
Pkg_Name := String_From_Name_Buffer;
Inst :=
Make_Package_Instantiation (Loc,
is
Stub_Elements : constant Stub_Structure :=
Stubs_Table.Get (Full_View);
-
begin
if Stub_Elements /= Empty_Stub_Structure then
Add_RACW_Primitive_Declarations_And_Bodies
(Full_View,
- Parent (Declaration_Node (Stub_Elements.Object_RPC_Receiver)),
+ Stub_Elements.RPC_Receiver_Decl,
List_Containing (Declaration_Node (Full_View)));
end if;
end Remote_Types_Tagged_Full_View_Encountered;
return Unit_Name;
end Scope_Of_Spec;
+ ----------------------
+ -- Set_Renaming_TSS --
+ ----------------------
+
+ procedure Set_Renaming_TSS
+ (Typ : Entity_Id;
+ Nam : Entity_Id;
+ TSS_Nam : Name_Id)
+ is
+ Loc : constant Source_Ptr := Sloc (Nam);
+ Spec : constant Node_Id := Parent (Nam);
+
+ TSS_Node : constant Node_Id :=
+ Make_Subprogram_Renaming_Declaration (Loc,
+ Specification =>
+ Copy_Specification (Loc,
+ Spec => Spec,
+ New_Name => TSS_Nam),
+ Name => New_Occurrence_Of (Nam, Loc));
+
+ Snam : constant Entity_Id :=
+ Defining_Unit_Name (Specification (TSS_Node));
+
+ begin
+ if Nkind (Spec) = N_Function_Specification then
+ Set_Ekind (Snam, E_Function);
+ Set_Etype (Snam, Entity (Subtype_Mark (Spec)));
+ else
+ Set_Ekind (Snam, E_Procedure);
+ Set_Etype (Snam, Standard_Void_Type);
+ end if;
+ Set_TSS (Typ, Snam);
+ end Set_Renaming_TSS;
+
+ --------------------------------
+ -- Specific_Add_RACW_Features --
+ --------------------------------
+
+ procedure Specific_Add_RACW_Features
+ (RACW_Type : Entity_Id;
+ Desig : Entity_Id;
+ Stub_Type : Entity_Id;
+ Stub_Type_Access : Entity_Id;
+ RPC_Receiver_Decl : Node_Id;
+ Declarations : List_Id)
+ is
+ begin
+ case Get_PCS_Name is
+ when Name_PolyORB_DSA =>
+ PolyORB_Support.Add_RACW_Features (
+ RACW_Type,
+ Desig,
+ Stub_Type,
+ Stub_Type_Access,
+ RPC_Receiver_Decl,
+ Declarations);
+
+ when others =>
+ GARLIC_Support.Add_RACW_Features (
+ RACW_Type,
+ Stub_Type,
+ Stub_Type_Access,
+ RPC_Receiver_Decl,
+ Declarations);
+ end case;
+ end Specific_Add_RACW_Features;
+
+ --------------------------------
+ -- Specific_Add_RAST_Features --
+ --------------------------------
+
+ procedure Specific_Add_RAST_Features
+ (Vis_Decl : Node_Id;
+ RAS_Type : Entity_Id;
+ Decls : List_Id)
+ is
+ begin
+ case Get_PCS_Name is
+ when Name_PolyORB_DSA =>
+ PolyORB_Support.Add_RAST_Features (
+ Vis_Decl, RAS_Type, Decls);
+ when others =>
+ GARLIC_Support.Add_RAST_Features (
+ Vis_Decl, RAS_Type, Decls);
+ end case;
+ end Specific_Add_RAST_Features;
+
--------------------------
-- Underlying_RACW_Type --
--------------------------
projects / platform / upstream / gcc.git / commitdiff