diff options
Diffstat (limited to 'gcc/ada/exp_dist.adb')
| -rw-r--r-- | gcc/ada/exp_dist.adb | 3352 |
1 files changed, 2215 insertions, 1137 deletions
diff --git a/gcc/ada/exp_dist.adb b/gcc/ada/exp_dist.adb index effeee69b44..63c6d3cb21f 100644 --- a/gcc/ada/exp_dist.adb +++ b/gcc/ada/exp_dist.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2004 Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2005 Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -207,35 +207,11 @@ package body Exp_Dist is -- If Locator is not Empty, it will be used instead of RCI_Cache. If -- New_Name is given, then it will be used instead of the original name. - function Build_Subprogram_Receiving_Stubs - (Vis_Decl : Node_Id; - Asynchronous : Boolean; - Dynamically_Asynchronous : Boolean := False; - Stub_Type : Entity_Id := Empty; - RACW_Type : Entity_Id := Empty; - Parent_Primitive : Entity_Id := Empty) return Node_Id; - -- Build the receiving stub for a given subprogram. The subprogram - -- declaration is also built by this procedure, and the value returned - -- is a N_Subprogram_Body. If a parameter of type access to Stub_Type is - -- found in the specification, then its address is read from the stream - -- instead of the object itself and converted into an access to - -- class-wide type before doing the real call using any of the RACW type - -- pointing on the designated type. - - procedure Build_RPC_Receiver_Body - (RPC_Receiver : Entity_Id; - Stream : out Entity_Id; - Result : out Entity_Id; - Subp_Id : out Entity_Id; - Stmts : out List_Id; - Decl : out Node_Id); - -- Make a subprogram body for an RPC receiver, with the given - -- defining unit name. On return: - -- - Subp_Id is the Standard.String variable that contains - -- the identifier of the desired subprogram, - -- - Stmts is the place where the request dispatching - -- statements can occur, - -- - Decl is the subprogram body declaration. + function Build_RPC_Receiver_Specification + (RPC_Receiver : Entity_Id; + Request_Parameter : Entity_Id) return Node_Id; + -- Make a subprogram specification for an RPC receiver, with the given + -- defining unit name and formal parameter. function Build_Ordered_Parameters_List (Spec : Node_Id) return List_Id; -- Return an ordered parameter list: unconstrained parameters are put @@ -249,11 +225,6 @@ package body Exp_Dist is Decls : List_Id); -- Add calling stubs to the declarative part - procedure Add_Receiving_Stubs_To_Declarations - (Pkg_Spec : Node_Id; - Decls : List_Id); - -- Add receiving stubs to the declarative part - function Could_Be_Asynchronous (Spec : Node_Id) return Boolean; -- Return True if nothing prevents the program whose specification is -- given to be asynchronous (i.e. no out parameter). @@ -282,6 +253,13 @@ package body Exp_Dist is Etyp : Entity_Id) return Node_Id; -- Similar to above, with Stream instead of Stream'Access + function Make_Selected_Component + (Loc : Source_Ptr; + Prefix : Entity_Id; + Selector_Name : Name_Id) return Node_Id; + -- Return a selected_component whose prefix denotes the given entity, + -- and with the given Selector_Name. + function Scope_Of_Spec (Spec : Node_Id) return Entity_Id; -- Return the scope represented by a given spec @@ -426,7 +404,7 @@ package body Exp_Dist is function Input_With_Tag_Check (Loc : Source_Ptr; Var_Type : Entity_Id; - Stream : Entity_Id) return Node_Id; + Stream : Node_Id) return Node_Id; -- Return a function with the following form: -- function R return Var_Type is -- begin @@ -542,6 +520,42 @@ package body Exp_Dist is -- ancillary subprogram for Add_Stub_Type. If no RPC receiver declaration -- is generated, then RPC_Receiver_Decl is set to Empty. + procedure Specific_Build_RPC_Receiver_Body + (RPC_Receiver : Entity_Id; + Request : out Entity_Id; + Subp_Id : out Entity_Id; + Subp_Index : out Entity_Id; + Stmts : out List_Id; + Decl : out Node_Id); + -- Make a subprogram body for an RPC receiver, with the given + -- defining unit name. On return: + -- - Subp_Id is the subprogram identifier from the PCS. + -- - Subp_Index is the index in the list of subprograms + -- used for dispatching (a variable of type Subprogram_Id). + -- - Stmts is the place where the request dispatching + -- statements can occur, + -- - Decl is the subprogram body declaration. + + function Specific_Build_Subprogram_Receiving_Stubs + (Vis_Decl : Node_Id; + Asynchronous : Boolean; + Dynamically_Asynchronous : Boolean := False; + Stub_Type : Entity_Id := Empty; + RACW_Type : Entity_Id := Empty; + Parent_Primitive : Entity_Id := Empty) return Node_Id; + -- Build the receiving stub for a given subprogram. The subprogram + -- declaration is also built by this procedure, and the value returned + -- is a N_Subprogram_Body. If a parameter of type access to Stub_Type is + -- found in the specification, then its address is read from the stream + -- instead of the object itself and converted into an access to + -- class-wide type before doing the real call using any of the RACW type + -- pointing on the designated type. + + procedure Specific_Add_Receiving_Stubs_To_Declarations + (Pkg_Spec : Node_Id; + Decls : List_Id); + -- Add receiving stubs to the declarative part + package GARLIC_Support is -- Support for generating DSA code that uses the GARLIC PCS @@ -589,12 +603,25 @@ package body Exp_Dist is Stub_Type_Decl : out Node_Id; RPC_Receiver_Decl : out Node_Id); - function Build_RPC_Receiver_Specification - (RPC_Receiver : Entity_Id; - Stream_Parameter : Entity_Id; - Result_Parameter : Entity_Id) return Node_Id; - -- Make a subprogram specification for an RPC receiver, - -- with the given defining unit name and formal parameters. + function Build_Subprogram_Receiving_Stubs + (Vis_Decl : Node_Id; + Asynchronous : Boolean; + Dynamically_Asynchronous : Boolean := False; + Stub_Type : Entity_Id := Empty; + RACW_Type : Entity_Id := Empty; + Parent_Primitive : Entity_Id := Empty) return Node_Id; + + procedure Add_Receiving_Stubs_To_Declarations + (Pkg_Spec : Node_Id; + Decls : List_Id); + + procedure Build_RPC_Receiver_Body + (RPC_Receiver : Entity_Id; + Request : out Entity_Id; + Subp_Id : out Entity_Id; + Subp_Index : out Entity_Id; + Stmts : out List_Id; + Decl : out Node_Id); end GARLIC_Support; @@ -645,16 +672,32 @@ package body Exp_Dist is Stub_Type_Decl : out Node_Id; RPC_Receiver_Decl : out Node_Id); - function Build_RPC_Receiver_Specification - (RPC_Receiver : Entity_Id; - Request_Parameter : Entity_Id) return Node_Id; - -- Make a subprogram specification for an RPC receiver, - -- with the given defining unit name and formal parameters. + function Build_Subprogram_Receiving_Stubs + (Vis_Decl : Node_Id; + Asynchronous : Boolean; + Dynamically_Asynchronous : Boolean := False; + Stub_Type : Entity_Id := Empty; + RACW_Type : Entity_Id := Empty; + Parent_Primitive : Entity_Id := Empty) return Node_Id; - pragma Warnings (Off); - pragma Unreferenced (Build_RPC_Receiver_Specification); - -- XXX PolyORB support is not completely included yet - pragma Warnings (On); + procedure Add_Receiving_Stubs_To_Declarations + (Pkg_Spec : Node_Id; + Decls : List_Id); + + procedure Build_RPC_Receiver_Body + (RPC_Receiver : Entity_Id; + Request : out Entity_Id; + Subp_Id : out Entity_Id; + Subp_Index : out Entity_Id; + Stmts : out List_Id; + Decl : out Node_Id); + + procedure Reserve_NamingContext_Methods; + -- Mark the method names for interface NamingContext as already used in + -- the overload table, so no clashes occur with user code (with the + -- PolyORB PCS, RCIs Implement The NamingContext interface to allow + -- their methods to be accessed as objects, for the implementation of + -- remote access-to-subprogram types). package Helpers is @@ -671,7 +714,6 @@ package body Exp_Dist is -- the CORBA terminology, and hence the conversion subprograms -- are named To_Any and From_Any. - function Build_From_Any_Call (Typ : Entity_Id; N : Node_Id; @@ -798,6 +840,7 @@ package body Exp_Dist is -- do the correct dispatching. Overload_Counter_Table.Reset; + PolyORB_Support.Reserve_NamingContext_Methods; Current_Declaration := First (Visible_Declarations (Pkg_Spec)); @@ -1065,9 +1108,9 @@ package body Exp_Dist is RPC_Receiver : Entity_Id; RPC_Receiver_Statements : List_Id; RPC_Receiver_Case_Alternatives : constant List_Id := New_List; - RPC_Receiver_Stream : Entity_Id; - RPC_Receiver_Result : Entity_Id; + RPC_Receiver_Request : Entity_Id; RPC_Receiver_Subp_Id : Entity_Id; + RPC_Receiver_Subp_Index : Entity_Id; Subp_Str : String_Id; @@ -1095,11 +1138,11 @@ package body Exp_Dist is if not Is_RAS then RPC_Receiver := Make_Defining_Identifier (Loc, New_Internal_Name ('P')); - Build_RPC_Receiver_Body ( + Specific_Build_RPC_Receiver_Body ( RPC_Receiver => RPC_Receiver, - Stream => RPC_Receiver_Stream, - Result => RPC_Receiver_Result, + Request => RPC_Receiver_Request, Subp_Id => RPC_Receiver_Subp_Id, + Subp_Index => RPC_Receiver_Subp_Index, Stmts => RPC_Receiver_Statements, Decl => RPC_Receiver_Decl); end if; @@ -1167,7 +1210,8 @@ package body Exp_Dist is Defining_Unit_Name (Current_Primitive_Spec)), Asynchronous => Possibly_Asynchronous, Dynamically_Asynchronous => Possibly_Asynchronous, - Stub_Type => Stub_Elements.Stub_Type); + Stub_Type => Stub_Elements.Stub_Type, + RACW_Type => Stub_Elements.RACW_Type); Append_To (Decls, Current_Primitive_Body); -- Analyzing the body here would cause the Stub type to be @@ -1179,7 +1223,7 @@ package body Exp_Dist is if not Is_RAS then Current_Receiver_Body := - Build_Subprogram_Receiving_Stubs + Specific_Build_Subprogram_Receiving_Stubs (Vis_Decl => Current_Primitive_Decl, Asynchronous => Possibly_Asynchronous, Dynamically_Asynchronous => Possibly_Asynchronous, @@ -1204,8 +1248,7 @@ package body Exp_Dist is Name => New_Occurrence_Of (Current_Receiver, Loc), Parameter_Associations => New_List ( - New_Occurrence_Of (RPC_Receiver_Stream, Loc), - New_Occurrence_Of (RPC_Receiver_Result, Loc)))))); + New_Occurrence_Of (RPC_Receiver_Request, Loc)))))); end if; -- Increment the index of current primitive @@ -1228,9 +1271,11 @@ package body Exp_Dist is Append_To (RPC_Receiver_Statements, Make_Case_Statement (Loc, Expression => - New_Occurrence_Of (RPC_Receiver_Subp_Id, Loc), + New_Occurrence_Of (RPC_Receiver_Subp_Index, Loc), Alternatives => RPC_Receiver_Case_Alternatives)); + Append_To (Decls, RPC_Receiver_Decl); + -- The RPC receiver body should not be the completion of the -- declaration recorded in the stub structure, because then the -- occurrences of the formal parameters within the body should @@ -1239,7 +1284,6 @@ package body Exp_Dist is -- 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 => @@ -1370,12 +1414,9 @@ package body Exp_Dist is Unchecked_Convert_To (RACW_Type, New_Occurrence_Of (RAS_Parameter, Loc))); - RACW_Primitive_Name := - Make_Selected_Component (Loc, - Prefix => - New_Occurrence_Of (Scope (RACW_Type), Loc), - Selector_Name => - Make_Identifier (Loc, Name_Call)); + RACW_Primitive_Name := Make_Selected_Component (Loc, + Prefix => Scope (RACW_Type), + Selector_Name => Name_Call); end if; if Is_Function then @@ -1649,434 +1690,6 @@ package body Exp_Dist is Specific_Add_RAST_Features (Vis_Decl, RAS_Type, Decls); end Add_RAST_Features; - ----------------------------------------- - -- Add_Receiving_Stubs_To_Declarations -- - ----------------------------------------- - - procedure Add_Receiving_Stubs_To_Declarations - (Pkg_Spec : Node_Id; - Decls : List_Id) - is - Loc : constant Source_Ptr := Sloc (Pkg_Spec); - - Stream_Parameter : Node_Id; - Result_Parameter : Node_Id; - - Pkg_RPC_Receiver : constant Entity_Id := - Make_Defining_Identifier (Loc, - New_Internal_Name ('H')); - Pkg_RPC_Receiver_Statements : List_Id; - Pkg_RPC_Receiver_Cases : constant List_Id := New_List; - Pkg_RPC_Receiver_Body : Node_Id; - -- A Pkg_RPC_Receiver is built to decode the request - - Lookup_RAS_Info : constant Entity_Id := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('R')); - -- A remote subprogram is created to allow peers to look up - -- RAS information using subprogram ids. - - Subp_Id : Node_Id; - -- Subprogram_Id as read from the incoming stream - - Current_Declaration : Node_Id; - Current_Subprogram_Number : Int := First_RCI_Subprogram_Id; - Current_Stubs : Node_Id; - - Subp_Info_Array : constant Entity_Id := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('I')); - - Subp_Info_List : constant List_Id := New_List; - - Register_Pkg_Actuals : constant List_Id := New_List; - - Dummy_Register_Name : Name_Id; - Dummy_Register_Spec : Node_Id; - Dummy_Register_Decl : Node_Id; - Dummy_Register_Body : Node_Id; - - All_Calls_Remote_E : Entity_Id; - Proxy_Object_Addr : Entity_Id; - - procedure Append_Stubs_To - (RPC_Receiver_Cases : List_Id; - Declaration : Node_Id; - Stubs : Node_Id; - Subprogram_Number : Int); - -- Add one case to the specified RPC receiver case list - -- associating Subprogram_Number with the subprogram declared - -- by Declaration, for which we have receiving stubs in Stubs. - - --------------------- - -- Append_Stubs_To -- - --------------------- - - procedure Append_Stubs_To - (RPC_Receiver_Cases : List_Id; - Declaration : Node_Id; - Stubs : Node_Id; - Subprogram_Number : Int) - is - Actuals : constant List_Id := - New_List (New_Occurrence_Of (Stream_Parameter, Loc)); - begin - if Nkind (Specification (Declaration)) = N_Function_Specification - or else not - Is_Asynchronous (Defining_Entity (Specification (Declaration))) - then - -- An asynchronous procedure does not want an output parameter - -- since no result and no exception will ever be returned. - - Append_To (Actuals, - New_Occurrence_Of (Result_Parameter, Loc)); - end if; - - Append_To (RPC_Receiver_Cases, - Make_Case_Statement_Alternative (Loc, - Discrete_Choices => - New_List (Make_Integer_Literal (Loc, Subprogram_Number)), - Statements => - New_List ( - Make_Procedure_Call_Statement (Loc, - Name => - New_Occurrence_Of ( - Defining_Entity (Stubs), Loc), - Parameter_Associations => - Actuals)))); - end Append_Stubs_To; - - -- Start of processing for Add_Receiving_Stubs_To_Declarations - - begin - -- Building receiving stubs consist in several operations: - - -- - a package RPC receiver must be built. This subprogram - -- will get a Subprogram_Id from the incoming stream - -- and will dispatch the call to the right subprogram - - -- - a receiving stub for any subprogram visible in the package - -- spec. This stub will read all the parameters from the stream, - -- and put the result as well as the exception occurrence in the - -- output stream - - -- - a dummy package with an empty spec and a body made of an - -- elaboration part, whose job is to register the receiving - -- part of this RCI package on the name server. This is done - -- by calling System.Partition_Interface.Register_Receiving_Stub - - Build_RPC_Receiver_Body ( - RPC_Receiver => Pkg_RPC_Receiver, - Stream => Stream_Parameter, - Result => Result_Parameter, - Subp_Id => Subp_Id, - Stmts => Pkg_RPC_Receiver_Statements, - Decl => Pkg_RPC_Receiver_Body); - - -- A null subp_id denotes a call through a RAS, in which case the - -- next Uint_64 element in the stream is the address of the local - -- proxy object, from which we can retrieve the actual subprogram id. - - Append_To (Pkg_RPC_Receiver_Statements, - Make_Implicit_If_Statement (Pkg_Spec, - Condition => - Make_Op_Eq (Loc, - New_Occurrence_Of (Subp_Id, Loc), - Make_Integer_Literal (Loc, 0)), - Then_Statements => New_List ( - Make_Assignment_Statement (Loc, - Name => - New_Occurrence_Of (Subp_Id, Loc), - Expression => - Make_Selected_Component (Loc, - Prefix => - Unchecked_Convert_To (RTE (RE_RAS_Proxy_Type_Access), - OK_Convert_To (RTE (RE_Address), - Make_Attribute_Reference (Loc, - Prefix => - New_Occurrence_Of (RTE (RE_Unsigned_64), Loc), - Attribute_Name => - Name_Input, - Expressions => New_List ( - New_Occurrence_Of (Stream_Parameter, Loc))))), - Selector_Name => - Make_Identifier (Loc, Name_Subp_Id)))))); - - -- Build a subprogram for RAS information lookups - - Current_Declaration := - Make_Subprogram_Declaration (Loc, - Specification => - Make_Function_Specification (Loc, - Defining_Unit_Name => - Lookup_RAS_Info, - Parameter_Specifications => New_List ( - Make_Parameter_Specification (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, Name_Subp_Id), - In_Present => - True, - Parameter_Type => - New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc))), - Subtype_Mark => - New_Occurrence_Of (RTE (RE_Unsigned_64), Loc))); - Append_To (Decls, Current_Declaration); - Analyze (Current_Declaration); - - Current_Stubs := Build_Subprogram_Receiving_Stubs - (Vis_Decl => Current_Declaration, - Asynchronous => False); - Append_To (Decls, Current_Stubs); - Analyze (Current_Stubs); - - Append_Stubs_To (Pkg_RPC_Receiver_Cases, - Declaration => - Current_Declaration, - Stubs => - Current_Stubs, - Subprogram_Number => 1); - - -- For each subprogram, the receiving stub will be built and a - -- case statement will be made on the Subprogram_Id to dispatch - -- to the right subprogram. - - All_Calls_Remote_E := Boolean_Literals ( - Has_All_Calls_Remote (Defining_Entity (Pkg_Spec))); - - Overload_Counter_Table.Reset; - - Current_Declaration := First (Visible_Declarations (Pkg_Spec)); - while Present (Current_Declaration) loop - if Nkind (Current_Declaration) = N_Subprogram_Declaration - and then Comes_From_Source (Current_Declaration) - then - declare - Loc : constant Source_Ptr := - Sloc (Current_Declaration); - -- While specifically processing Current_Declaration, use its - -- Sloc as the location of all generated nodes. - - Subp_Def : constant Entity_Id := - Defining_Unit_Name - (Specification (Current_Declaration)); - - Subp_Val : String_Id; - - begin - pragma Assert (Current_Subprogram_Number = - Get_Subprogram_Id (Subp_Def)); - - -- Build receiving stub - - Current_Stubs := - Build_Subprogram_Receiving_Stubs - (Vis_Decl => Current_Declaration, - Asynchronous => - Nkind (Specification (Current_Declaration)) = - N_Procedure_Specification - and then Is_Asynchronous (Subp_Def)); - - Append_To (Decls, Current_Stubs); - Analyze (Current_Stubs); - - -- Build RAS proxy - - Add_RAS_Proxy_And_Analyze (Decls, - Vis_Decl => - Current_Declaration, - All_Calls_Remote_E => - All_Calls_Remote_E, - Proxy_Object_Addr => - Proxy_Object_Addr); - - -- Compute distribution identifier - - Assign_Subprogram_Identifier ( - Subp_Def, - Current_Subprogram_Number, - Subp_Val); - - -- Add subprogram descriptor (RCI_Subp_Info) to the - -- subprograms table for this receiver. The aggregate - -- below must be kept consistent with the declaration - -- of type RCI_Subp_Info in System.Partition_Interface. - - Append_To (Subp_Info_List, - Make_Component_Association (Loc, - Choices => New_List ( - Make_Integer_Literal (Loc, - Current_Subprogram_Number)), - Expression => - Make_Aggregate (Loc, - Component_Associations => New_List ( - Make_Component_Association (Loc, - Choices => New_List ( - Make_Identifier (Loc, Name_Addr)), - Expression => - New_Occurrence_Of (Proxy_Object_Addr, Loc)))))); - - Append_Stubs_To (Pkg_RPC_Receiver_Cases, - Declaration => - Current_Declaration, - Stubs => - Current_Stubs, - Subprogram_Number => - Current_Subprogram_Number); - end; - - Current_Subprogram_Number := Current_Subprogram_Number + 1; - end if; - - Next (Current_Declaration); - end loop; - - -- If we receive an invalid Subprogram_Id, it is best to do nothing - -- rather than raising an exception since we do not want someone - -- to crash a remote partition by sending invalid subprogram ids. - -- This is consistent with the other parts of the case statement - -- since even in presence of incorrect parameters in the stream, - -- every exception will be caught and (if the subprogram is not an - -- APC) put into the result stream and sent away. - - Append_To (Pkg_RPC_Receiver_Cases, - Make_Case_Statement_Alternative (Loc, - Discrete_Choices => - New_List (Make_Others_Choice (Loc)), - Statements => - New_List (Make_Null_Statement (Loc)))); - - Append_To (Pkg_RPC_Receiver_Statements, - Make_Case_Statement (Loc, - Expression => - New_Occurrence_Of (Subp_Id, Loc), - Alternatives => Pkg_RPC_Receiver_Cases)); - - Append_To (Decls, - Make_Object_Declaration (Loc, - Defining_Identifier => Subp_Info_Array, - Constant_Present => True, - Aliased_Present => True, - Object_Definition => - Make_Subtype_Indication (Loc, - Subtype_Mark => - New_Occurrence_Of (RTE (RE_RCI_Subp_Info_Array), Loc), - Constraint => - Make_Index_Or_Discriminant_Constraint (Loc, - New_List ( - Make_Range (Loc, - Low_Bound => Make_Integer_Literal (Loc, - First_RCI_Subprogram_Id), - High_Bound => - Make_Integer_Literal (Loc, - First_RCI_Subprogram_Id - + List_Length (Subp_Info_List) - 1))))), - Expression => - Make_Aggregate (Loc, - Component_Associations => Subp_Info_List))); - Analyze (Last (Decls)); - - Append_To (Decls, - Make_Subprogram_Body (Loc, - Specification => - Copy_Specification (Loc, Parent (Lookup_RAS_Info)), - Declarations => - No_List, - Handled_Statement_Sequence => - Make_Handled_Sequence_Of_Statements (Loc, - Statements => New_List ( - Make_Return_Statement (Loc, - Expression => OK_Convert_To (RTE (RE_Unsigned_64), - Make_Selected_Component (Loc, - Prefix => - Make_Indexed_Component (Loc, - Prefix => - New_Occurrence_Of (Subp_Info_Array, Loc), - Expressions => New_List ( - Convert_To (Standard_Integer, - Make_Identifier (Loc, Name_Subp_Id)))), - Selector_Name => - Make_Identifier (Loc, Name_Addr)))))))); - Analyze (Last (Decls)); - - Append_To (Decls, Pkg_RPC_Receiver_Body); - Analyze (Last (Decls)); - - -- Construction of the dummy package used to register the package - -- receiving stubs on the nameserver. - - Dummy_Register_Name := New_Internal_Name ('P'); - - Dummy_Register_Spec := - Make_Package_Specification (Loc, - Defining_Unit_Name => - Make_Defining_Identifier (Loc, Dummy_Register_Name), - Visible_Declarations => No_List, - End_Label => Empty); - - Dummy_Register_Decl := - Make_Package_Declaration (Loc, - Specification => Dummy_Register_Spec); - - Append_To (Decls, Dummy_Register_Decl); - Analyze (Dummy_Register_Decl); - - Get_Library_Unit_Name_String (Pkg_Spec); - Append_To (Register_Pkg_Actuals, - -- Name - Make_String_Literal (Loc, - Strval => String_From_Name_Buffer)); - - Append_To (Register_Pkg_Actuals, - -- Receiver - Make_Attribute_Reference (Loc, - Prefix => - New_Occurrence_Of (Pkg_RPC_Receiver, Loc), - Attribute_Name => - Name_Unrestricted_Access)); - - Append_To (Register_Pkg_Actuals, - -- Version - Make_Attribute_Reference (Loc, - Prefix => - New_Occurrence_Of (Defining_Entity (Pkg_Spec), Loc), - Attribute_Name => - Name_Version)); - - Append_To (Register_Pkg_Actuals, - -- Subp_Info - Make_Attribute_Reference (Loc, - Prefix => - New_Occurrence_Of (Subp_Info_Array, Loc), - Attribute_Name => - Name_Address)); - - Append_To (Register_Pkg_Actuals, - -- Subp_Info_Len - Make_Attribute_Reference (Loc, - Prefix => - New_Occurrence_Of (Subp_Info_Array, Loc), - Attribute_Name => - Name_Length)); - - Dummy_Register_Body := - Make_Package_Body (Loc, - Defining_Unit_Name => - Make_Defining_Identifier (Loc, Dummy_Register_Name), - Declarations => No_List, - - Handled_Statement_Sequence => - Make_Handled_Sequence_Of_Statements (Loc, - Statements => New_List ( - Make_Procedure_Call_Statement (Loc, - Name => - New_Occurrence_Of (RTE (RE_Register_Receiving_Stub), Loc), - - Parameter_Associations => Register_Pkg_Actuals)))); - - Append_To (Decls, Dummy_Register_Body); - Analyze (Dummy_Register_Body); - end Add_Receiving_Stubs_To_Declarations; - ------------------- -- Add_Stub_Type -- ------------------- @@ -2328,6 +1941,26 @@ package body Exp_Dist is Analyze (Reg); end Build_Passive_Partition_Stub; + -------------------------------------- + -- Build_RPC_Receiver_Specification -- + -------------------------------------- + + function Build_RPC_Receiver_Specification + (RPC_Receiver : Entity_Id; + Request_Parameter : Entity_Id) return Node_Id + is + Loc : constant Source_Ptr := Sloc (RPC_Receiver); + begin + return + Make_Procedure_Specification (Loc, + Defining_Unit_Name => RPC_Receiver, + Parameter_Specifications => New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => Request_Parameter, + Parameter_Type => + New_Occurrence_Of (RTE (RE_Request_Access), Loc)))); + end Build_RPC_Receiver_Specification; + ---------------------------------------- -- Build_Remote_Subprogram_Proxy_Type -- ---------------------------------------- @@ -2346,86 +1979,37 @@ package body Exp_Dist is Component_Items => New_List ( Make_Component_Declaration (Loc, - Make_Defining_Identifier (Loc, - Name_All_Calls_Remote), - Make_Component_Definition (Loc, - Subtype_Indication => - New_Occurrence_Of (Standard_Boolean, Loc)), - ACR_Expression), + Defining_Identifier => + Make_Defining_Identifier (Loc, + Name_All_Calls_Remote), + Component_Definition => + Make_Component_Definition (Loc, + Subtype_Indication => + New_Occurrence_Of (Standard_Boolean, Loc)), + Expression => + ACR_Expression), Make_Component_Declaration (Loc, - Make_Defining_Identifier (Loc, - Name_Receiver), - Make_Component_Definition (Loc, - Subtype_Indication => - New_Occurrence_Of (RTE (RE_Address), Loc)), - New_Occurrence_Of (RTE (RE_Null_Address), Loc)), + Defining_Identifier => + Make_Defining_Identifier (Loc, + Name_Receiver), + Component_Definition => + Make_Component_Definition (Loc, + Subtype_Indication => + New_Occurrence_Of (RTE (RE_Address), Loc)), + Expression => + New_Occurrence_Of (RTE (RE_Null_Address), Loc)), Make_Component_Declaration (Loc, - Make_Defining_Identifier (Loc, - Name_Subp_Id), - Make_Component_Definition (Loc, - Subtype_Indication => - New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc)))))); + Defining_Identifier => + Make_Defining_Identifier (Loc, + Name_Subp_Id), + Component_Definition => + Make_Component_Definition (Loc, + Subtype_Indication => + New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc)))))); end Build_Remote_Subprogram_Proxy_Type; - ----------------------------- - -- Build_RPC_Receiver_Body -- - ----------------------------- - - procedure Build_RPC_Receiver_Body - (RPC_Receiver : Entity_Id; - Stream : out Entity_Id; - Result : out Entity_Id; - Subp_Id : out Entity_Id; - Stmts : out List_Id; - Decl : out Node_Id) - is - Loc : constant Source_Ptr := Sloc (RPC_Receiver); - - RPC_Receiver_Spec : Node_Id; - RPC_Receiver_Decls : List_Id; - - begin - Stream := Make_Defining_Identifier (Loc, Name_S); - Result := Make_Defining_Identifier (Loc, Name_R); - - RPC_Receiver_Spec := - GARLIC_Support.Build_RPC_Receiver_Specification - (RPC_Receiver => RPC_Receiver, - Stream_Parameter => Stream, - Result_Parameter => Result); - - Subp_Id := Make_Defining_Identifier (Loc, New_Internal_Name ('P')); - - -- Subp_Id may not be a constant, because in the case of the RPC - -- receiver for an RCI package, when a call is received from a RAS - -- dereference, it will be assigned during subsequent processing. - - RPC_Receiver_Decls := New_List ( - Make_Object_Declaration (Loc, - Defining_Identifier => Subp_Id, - Object_Definition => - New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc), - Expression => - Make_Attribute_Reference (Loc, - Prefix => - New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc), - Attribute_Name => Name_Input, - Expressions => New_List ( - New_Occurrence_Of (Stream, Loc))))); - - Stmts := New_List; - - Decl := - Make_Subprogram_Body (Loc, - Specification => RPC_Receiver_Spec, - Declarations => RPC_Receiver_Decls, - Handled_Statement_Sequence => - Make_Handled_Sequence_Of_Statements (Loc, - Statements => Stmts)); - end Build_RPC_Receiver_Body; - ------------------------------------ -- Build_Subprogram_Calling_Stubs -- ------------------------------------ @@ -2541,12 +2125,9 @@ package body Exp_Dist is pragma Assert (No (Stub_Type) or else Present (Controlling_Parameter)); if Dynamically_Asynchronous then - Asynchronous_Expr := - Make_Selected_Component (Loc, - Prefix => - New_Occurrence_Of (Controlling_Parameter, Loc), - Selector_Name => - Make_Identifier (Loc, Name_Asynchronous)); + Asynchronous_Expr := Make_Selected_Component (Loc, + Prefix => Controlling_Parameter, + Selector_Name => Name_Asynchronous); end if; Specific_Build_General_Calling_Stubs @@ -2592,457 +2173,6 @@ package body Exp_Dist is return Make_Integer_Literal (Loc, Get_Subprogram_Id (E)); end Build_Subprogram_Id; - -------------------------------------- - -- Build_Subprogram_Receiving_Stubs -- - -------------------------------------- - - function Build_Subprogram_Receiving_Stubs - (Vis_Decl : Node_Id; - Asynchronous : Boolean; - Dynamically_Asynchronous : Boolean := False; - Stub_Type : Entity_Id := Empty; - RACW_Type : Entity_Id := Empty; - Parent_Primitive : Entity_Id := Empty) return Node_Id - is - Loc : constant Source_Ptr := Sloc (Vis_Decl); - - Stream_Parameter : Node_Id; - Result_Parameter : Node_Id; - -- See explanations of these in Build_Subprogram_Calling_Stubs - - Decls : constant List_Id := New_List; - -- All the parameters will get declared before calling the real - -- subprograms. Also the out parameters will be declared. - - Statements : constant List_Id := New_List; - - Extra_Formal_Statements : constant List_Id := New_List; - -- Statements concerning extra formal parameters - - After_Statements : constant List_Id := New_List; - -- Statements to be executed after the subprogram call - - Inner_Decls : List_Id := No_List; - -- In case of a function, the inner declarations are needed since - -- the result may be unconstrained. - - Excep_Handlers : List_Id := No_List; - Excep_Choice : Entity_Id; - Excep_Code : List_Id; - - Parameter_List : constant List_Id := New_List; - -- List of parameters to be passed to the subprogram - - Current_Parameter : Node_Id; - - Ordered_Parameters_List : constant List_Id := - Build_Ordered_Parameters_List - (Specification (Vis_Decl)); - - Subp_Spec : Node_Id; - -- Subprogram specification - - Called_Subprogram : Node_Id; - -- The subprogram to call - - Null_Raise_Statement : Node_Id; - - Dynamic_Async : Entity_Id; - - begin - if Present (RACW_Type) then - Called_Subprogram := - New_Occurrence_Of (Parent_Primitive, Loc); - else - Called_Subprogram := - New_Occurrence_Of ( - Defining_Unit_Name (Specification (Vis_Decl)), Loc); - end if; - - Stream_Parameter := - Make_Defining_Identifier (Loc, New_Internal_Name ('S')); - - if Dynamically_Asynchronous then - Dynamic_Async := - Make_Defining_Identifier (Loc, New_Internal_Name ('S')); - else - Dynamic_Async := Empty; - end if; - - if not Asynchronous or else Dynamically_Asynchronous then - Result_Parameter := - Make_Defining_Identifier (Loc, New_Internal_Name ('S')); - - -- The first statement after the subprogram call is a statement to - -- writes a Null_Occurrence into the result stream. - - Null_Raise_Statement := - Make_Attribute_Reference (Loc, - Prefix => - New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc), - Attribute_Name => Name_Write, - Expressions => New_List ( - New_Occurrence_Of (Result_Parameter, Loc), - New_Occurrence_Of (RTE (RE_Null_Occurrence), Loc))); - - if Dynamically_Asynchronous then - Null_Raise_Statement := - Make_Implicit_If_Statement (Vis_Decl, - Condition => - Make_Op_Not (Loc, New_Occurrence_Of (Dynamic_Async, Loc)), - Then_Statements => New_List (Null_Raise_Statement)); - end if; - - Append_To (After_Statements, Null_Raise_Statement); - - else - Result_Parameter := Empty; - end if; - - -- Loop through every parameter and get its value from the stream. If - -- the parameter is unconstrained, then the parameter is read using - -- 'Input at the point of declaration. - - Current_Parameter := First (Ordered_Parameters_List); - while Present (Current_Parameter) loop - declare - Etyp : Entity_Id; - RACW_Controlling : Boolean; - Constrained : Boolean; - Object : Entity_Id; - Expr : Node_Id := Empty; - - begin - Object := Make_Defining_Identifier (Loc, New_Internal_Name ('P')); - Set_Ekind (Object, E_Variable); - - RACW_Controlling := - Is_RACW_Controlling_Formal (Current_Parameter, Stub_Type); - - if RACW_Controlling then - - -- We have a controlling formal parameter. Read its address - -- rather than a real object. The address is in Unsigned_64 - -- form. - - Etyp := RTE (RE_Unsigned_64); - else - Etyp := Etype (Parameter_Type (Current_Parameter)); - end if; - - Constrained := - Is_Constrained (Etyp) or else Is_Elementary_Type (Etyp); - - if In_Present (Current_Parameter) - or else not Out_Present (Current_Parameter) - or else not Constrained - or else RACW_Controlling - then - -- If an input parameter is contrained, then its reading is - -- deferred until the beginning of the subprogram body. If - -- it is unconstrained, then an expression is built for - -- the object declaration and the variable is set using - -- 'Input instead of 'Read. - - if Constrained and then not RACW_Controlling then - Append_To (Statements, - Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (Etyp, Loc), - Attribute_Name => Name_Read, - Expressions => New_List ( - New_Occurrence_Of (Stream_Parameter, Loc), - New_Occurrence_Of (Object, Loc)))); - - else - Expr := Input_With_Tag_Check (Loc, - Var_Type => Etyp, - Stream => Stream_Parameter); - Append_To (Decls, Expr); - Expr := Make_Function_Call (Loc, - New_Occurrence_Of (Defining_Unit_Name - (Specification (Expr)), Loc)); - end if; - end if; - - -- If we do not have to output the current parameter, then - -- it can well be flagged as constant. This may allow further - -- optimizations done by the back end. - - Append_To (Decls, - Make_Object_Declaration (Loc, - Defining_Identifier => Object, - Constant_Present => - not Constrained and then not Out_Present (Current_Parameter), - Object_Definition => - New_Occurrence_Of (Etyp, Loc), - Expression => Expr)); - - -- An out parameter may be written back using a 'Write - -- attribute instead of a 'Output because it has been - -- constrained by the parameter given to the caller. Note that - -- out controlling arguments in the case of a RACW are not put - -- back in the stream because the pointer on them has not - -- changed. - - if Out_Present (Current_Parameter) - and then - Etype (Parameter_Type (Current_Parameter)) /= Stub_Type - then - Append_To (After_Statements, - Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (Etyp, Loc), - Attribute_Name => Name_Write, - Expressions => New_List ( - New_Occurrence_Of (Result_Parameter, Loc), - New_Occurrence_Of (Object, Loc)))); - end if; - - if - Is_RACW_Controlling_Formal (Current_Parameter, Stub_Type) - then - if Nkind (Parameter_Type (Current_Parameter)) /= - N_Access_Definition - then - Append_To (Parameter_List, - Make_Parameter_Association (Loc, - Selector_Name => - New_Occurrence_Of ( - Defining_Identifier (Current_Parameter), Loc), - Explicit_Actual_Parameter => - Make_Explicit_Dereference (Loc, - Unchecked_Convert_To (RACW_Type, - OK_Convert_To (RTE (RE_Address), - New_Occurrence_Of (Object, Loc)))))); - - else - Append_To (Parameter_List, - Make_Parameter_Association (Loc, - Selector_Name => - New_Occurrence_Of ( - Defining_Identifier (Current_Parameter), Loc), - Explicit_Actual_Parameter => - Unchecked_Convert_To (RACW_Type, - OK_Convert_To (RTE (RE_Address), - New_Occurrence_Of (Object, Loc))))); - end if; - - else - Append_To (Parameter_List, - Make_Parameter_Association (Loc, - Selector_Name => - New_Occurrence_Of ( - Defining_Identifier (Current_Parameter), Loc), - Explicit_Actual_Parameter => - New_Occurrence_Of (Object, Loc))); - end if; - - -- If the current parameter needs an extra formal, then read it - -- from the stream and set the corresponding semantic field in - -- the variable. If the kind of the parameter identifier is - -- E_Void, then this is a compiler generated parameter that - -- doesn't need an extra constrained status. - - -- The case of Extra_Accessibility should also be handled ??? - - if Nkind (Parameter_Type (Current_Parameter)) /= - N_Access_Definition - and then - Ekind (Defining_Identifier (Current_Parameter)) /= E_Void - and then - Present (Extra_Constrained - (Defining_Identifier (Current_Parameter))) - then - declare - Extra_Parameter : constant Entity_Id := - Extra_Constrained - (Defining_Identifier - (Current_Parameter)); - - Formal_Entity : constant Entity_Id := - Make_Defining_Identifier - (Loc, Chars (Extra_Parameter)); - - Formal_Type : constant Entity_Id := - Etype (Extra_Parameter); - - begin - Append_To (Decls, - Make_Object_Declaration (Loc, - Defining_Identifier => Formal_Entity, - Object_Definition => - New_Occurrence_Of (Formal_Type, Loc))); - - Append_To (Extra_Formal_Statements, - Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (Formal_Type, Loc), - Attribute_Name => Name_Read, - Expressions => New_List ( - New_Occurrence_Of (Stream_Parameter, Loc), - New_Occurrence_Of (Formal_Entity, Loc)))); - Set_Extra_Constrained (Object, Formal_Entity); - end; - end if; - end; - - Next (Current_Parameter); - end loop; - - -- Append the formal statements list at the end of regular statements - - Append_List_To (Statements, Extra_Formal_Statements); - - if Nkind (Specification (Vis_Decl)) = N_Function_Specification then - - -- The remote subprogram is a function. We build an inner block to - -- be able to hold a potentially unconstrained result in a variable. - - declare - Etyp : constant Entity_Id := - Etype (Subtype_Mark (Specification (Vis_Decl))); - Result : constant Node_Id := - Make_Defining_Identifier (Loc, New_Internal_Name ('R')); - - begin - Inner_Decls := New_List ( - Make_Object_Declaration (Loc, - Defining_Identifier => Result, - Constant_Present => True, - Object_Definition => New_Occurrence_Of (Etyp, Loc), - Expression => - Make_Function_Call (Loc, - Name => Called_Subprogram, - Parameter_Associations => Parameter_List))); - - Append_To (After_Statements, - Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (Etyp, Loc), - Attribute_Name => Name_Output, - Expressions => New_List ( - New_Occurrence_Of (Result_Parameter, Loc), - New_Occurrence_Of (Result, Loc)))); - end; - - Append_To (Statements, - Make_Block_Statement (Loc, - Declarations => Inner_Decls, - Handled_Statement_Sequence => - Make_Handled_Sequence_Of_Statements (Loc, - Statements => After_Statements))); - - else - -- The remote subprogram is a procedure. We do not need any inner - -- block in this case. - - if Dynamically_Asynchronous then - Append_To (Decls, - Make_Object_Declaration (Loc, - Defining_Identifier => Dynamic_Async, - Object_Definition => - New_Occurrence_Of (Standard_Boolean, Loc))); - - Append_To (Statements, - Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (Standard_Boolean, Loc), - Attribute_Name => Name_Read, - Expressions => New_List ( - New_Occurrence_Of (Stream_Parameter, Loc), - New_Occurrence_Of (Dynamic_Async, Loc)))); - end if; - - Append_To (Statements, - Make_Procedure_Call_Statement (Loc, - Name => Called_Subprogram, - Parameter_Associations => Parameter_List)); - - Append_List_To (Statements, After_Statements); - end if; - - if Asynchronous and then not Dynamically_Asynchronous then - - -- An asynchronous procedure does not want a Result parameter. Also - -- put an exception handler with an others clause that does nothing. - - Subp_Spec := - Make_Procedure_Specification (Loc, - Defining_Unit_Name => - Make_Defining_Identifier (Loc, New_Internal_Name ('F')), - Parameter_Specifications => New_List ( - Make_Parameter_Specification (Loc, - Defining_Identifier => Stream_Parameter, - Parameter_Type => - Make_Access_Definition (Loc, - Subtype_Mark => - New_Occurrence_Of (RTE (RE_Params_Stream_Type), Loc))))); - - Excep_Handlers := New_List ( - Make_Exception_Handler (Loc, - Exception_Choices => - New_List (Make_Others_Choice (Loc)), - Statements => New_List ( - Make_Null_Statement (Loc)))); - - else - -- In the other cases, if an exception is raised, then the - -- exception occurrence is copied into the output stream and - -- no other output parameter is written. - - Excep_Choice := - Make_Defining_Identifier (Loc, New_Internal_Name ('E')); - - Excep_Code := New_List ( - Make_Attribute_Reference (Loc, - Prefix => - New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc), - Attribute_Name => Name_Write, - Expressions => New_List ( - New_Occurrence_Of (Result_Parameter, Loc), - New_Occurrence_Of (Excep_Choice, Loc)))); - - if Dynamically_Asynchronous then - Excep_Code := New_List ( - Make_Implicit_If_Statement (Vis_Decl, - Condition => Make_Op_Not (Loc, - New_Occurrence_Of (Dynamic_Async, Loc)), - Then_Statements => Excep_Code)); - end if; - - Excep_Handlers := New_List ( - Make_Exception_Handler (Loc, - Choice_Parameter => Excep_Choice, - Exception_Choices => New_List (Make_Others_Choice (Loc)), - Statements => Excep_Code)); - - Subp_Spec := - Make_Procedure_Specification (Loc, - Defining_Unit_Name => - Make_Defining_Identifier (Loc, New_Internal_Name ('F')), - - Parameter_Specifications => New_List ( - Make_Parameter_Specification (Loc, - Defining_Identifier => Stream_Parameter, - Parameter_Type => - Make_Access_Definition (Loc, - Subtype_Mark => - New_Occurrence_Of (RTE (RE_Params_Stream_Type), Loc))), - - Make_Parameter_Specification (Loc, - Defining_Identifier => Result_Parameter, - Parameter_Type => - Make_Access_Definition (Loc, - Subtype_Mark => - New_Occurrence_Of (RTE (RE_Params_Stream_Type), Loc))))); - end if; - - return - Make_Subprogram_Body (Loc, - Specification => Subp_Spec, - Declarations => Decls, - Handled_Statement_Sequence => - Make_Handled_Sequence_Of_Statements (Loc, - Statements => Statements, - Exception_Handlers => Excep_Handlers)); - end Build_Subprogram_Receiving_Stubs; - ------------------------ -- Copy_Specification -- ------------------------ @@ -3124,6 +2254,20 @@ package body Exp_Dist is Expression => New_Copy_Tree (Expression (Current_Parameter)))); + -- For a regular formal parameter (that needs to be marshalled + -- in the context of remote calls), set the Etype now, because + -- marshalling processing might need it. + + if Is_Entity_Name (Current_Type) then + Set_Etype (New_Identifier, Entity (Current_Type)); + + -- Current_Type is an access definition, special processing + -- (not requiring etype) will occur for marshalling. + + else + null; + end if; + Next (Current_Parameter); end loop; end if; @@ -3300,7 +2444,7 @@ package body Exp_Dist is Spec := Specification (Unit_Node); Decls := Visible_Declarations (Spec); New_Scope (Scope_Of_Spec (Spec)); - Add_Receiving_Stubs_To_Declarations (Spec, Decls); + Specific_Add_Receiving_Stubs_To_Declarations (Spec, Decls); else Spec := @@ -3308,7 +2452,7 @@ package body Exp_Dist is Decls := Declarations (Unit_Node); New_Scope (Scope_Of_Spec (Unit_Node)); Temp := New_List; - Add_Receiving_Stubs_To_Declarations (Spec, Temp); + Specific_Add_Receiving_Stubs_To_Declarations (Spec, Temp); Insert_List_Before (First (Decls), Temp); end if; @@ -3547,30 +2691,30 @@ package body Exp_Dist is Make_Assignment_Statement (Loc, Name => Make_Selected_Component (Loc, - Prefix => New_Occurrence_Of (Stubbed_Result, Loc), - Selector_Name => Make_Identifier (Loc, Name_Origin)), + Prefix => Stubbed_Result, + Selector_Name => Name_Origin), Expression => New_Occurrence_Of (Source_Partition, Loc)), Make_Assignment_Statement (Loc, Name => Make_Selected_Component (Loc, - Prefix => New_Occurrence_Of (Stubbed_Result, Loc), - Selector_Name => Make_Identifier (Loc, Name_Receiver)), + Prefix => Stubbed_Result, + Selector_Name => Name_Receiver), Expression => New_Occurrence_Of (Source_Receiver, Loc)), Make_Assignment_Statement (Loc, Name => Make_Selected_Component (Loc, - Prefix => New_Occurrence_Of (Stubbed_Result, Loc), - Selector_Name => Make_Identifier (Loc, Name_Addr)), + Prefix => Stubbed_Result, + Selector_Name => Name_Addr), Expression => New_Occurrence_Of (Source_Address, Loc))); Append_To (Remote_Statements, Make_Assignment_Statement (Loc, Name => Make_Selected_Component (Loc, - Prefix => New_Occurrence_Of (Stubbed_Result, Loc), - Selector_Name => Make_Identifier (Loc, Name_Asynchronous)), + Prefix => Stubbed_Result, + Selector_Name => Name_Asynchronous), Expression => New_Occurrence_Of (Asynchronous_Flag, Loc))); @@ -3867,8 +3011,8 @@ package body Exp_Dist is Make_Assignment_Statement (Loc, Name => Make_Selected_Component (Loc, - Prefix => New_Occurrence_Of (Stub_Ptr, Loc), - Selector_Name => Make_Identifier (Loc, Field_Name)), + Prefix => Stub_Ptr, + Selector_Name => Field_Name), Expression => Value); end Set_Field; @@ -4059,6 +3203,384 @@ package body Exp_Dist is Add_RAS_Access_TSS (Vis_Decl); end Add_RAST_Features; + ----------------------------------------- + -- Add_Receiving_Stubs_To_Declarations -- + ----------------------------------------- + + procedure Add_Receiving_Stubs_To_Declarations + (Pkg_Spec : Node_Id; + Decls : List_Id) + is + Loc : constant Source_Ptr := Sloc (Pkg_Spec); + + Request_Parameter : Node_Id; + + Pkg_RPC_Receiver : constant Entity_Id := + Make_Defining_Identifier (Loc, + New_Internal_Name ('H')); + Pkg_RPC_Receiver_Statements : List_Id; + Pkg_RPC_Receiver_Cases : constant List_Id := New_List; + Pkg_RPC_Receiver_Body : Node_Id; + -- A Pkg_RPC_Receiver is built to decode the request + + Lookup_RAS_Info : constant Entity_Id := + Make_Defining_Identifier (Loc, + Chars => New_Internal_Name ('R')); + -- A remote subprogram is created to allow peers to look up + -- RAS information using subprogram ids. + + Subp_Id : Entity_Id; + Subp_Index : Entity_Id; + -- Subprogram_Id as read from the incoming stream + + Current_Declaration : Node_Id; + Current_Subprogram_Number : Int := First_RCI_Subprogram_Id; + Current_Stubs : Node_Id; + + Subp_Info_Array : constant Entity_Id := + Make_Defining_Identifier (Loc, + Chars => New_Internal_Name ('I')); + + Subp_Info_List : constant List_Id := New_List; + + Register_Pkg_Actuals : constant List_Id := New_List; + + All_Calls_Remote_E : Entity_Id; + Proxy_Object_Addr : Entity_Id; + + procedure Append_Stubs_To + (RPC_Receiver_Cases : List_Id; + Stubs : Node_Id; + Subprogram_Number : Int); + -- Add one case to the specified RPC receiver case list + -- associating Subprogram_Number with the subprogram declared + -- by Declaration, for which we have receiving stubs in Stubs. + + --------------------- + -- Append_Stubs_To -- + --------------------- + + procedure Append_Stubs_To + (RPC_Receiver_Cases : List_Id; + Stubs : Node_Id; + Subprogram_Number : Int) + is + begin + Append_To (RPC_Receiver_Cases, + Make_Case_Statement_Alternative (Loc, + Discrete_Choices => + New_List (Make_Integer_Literal (Loc, Subprogram_Number)), + Statements => + New_List ( + Make_Procedure_Call_Statement (Loc, + Name => + New_Occurrence_Of ( + Defining_Entity (Stubs), Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of (Request_Parameter, Loc)))))); + end Append_Stubs_To; + + -- Start of processing for Add_Receiving_Stubs_To_Declarations + + begin + -- Building receiving stubs consist in several operations: + + -- - a package RPC receiver must be built. This subprogram + -- will get a Subprogram_Id from the incoming stream + -- and will dispatch the call to the right subprogram + + -- - a receiving stub for any subprogram visible in the package + -- spec. This stub will read all the parameters from the stream, + -- and put the result as well as the exception occurrence in the + -- output stream + + -- - a dummy package with an empty spec and a body made of an + -- elaboration part, whose job is to register the receiving + -- part of this RCI package on the name server. This is done + -- by calling System.Partition_Interface.Register_Receiving_Stub + + Build_RPC_Receiver_Body ( + RPC_Receiver => Pkg_RPC_Receiver, + Request => Request_Parameter, + Subp_Id => Subp_Id, + Subp_Index => Subp_Index, + Stmts => Pkg_RPC_Receiver_Statements, + Decl => Pkg_RPC_Receiver_Body); + pragma Assert (Subp_Id = Subp_Index); + + -- A null subp_id denotes a call through a RAS, in which case the + -- next Uint_64 element in the stream is the address of the local + -- proxy object, from which we can retrieve the actual subprogram id. + + Append_To (Pkg_RPC_Receiver_Statements, + Make_Implicit_If_Statement (Pkg_Spec, + Condition => + Make_Op_Eq (Loc, + New_Occurrence_Of (Subp_Id, Loc), + Make_Integer_Literal (Loc, 0)), + Then_Statements => New_List ( + Make_Assignment_Statement (Loc, + Name => + New_Occurrence_Of (Subp_Id, Loc), + Expression => + Make_Selected_Component (Loc, + Prefix => + Unchecked_Convert_To (RTE (RE_RAS_Proxy_Type_Access), + OK_Convert_To (RTE (RE_Address), + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (RTE (RE_Unsigned_64), Loc), + Attribute_Name => + Name_Input, + Expressions => New_List ( + Make_Selected_Component (Loc, + Prefix => Request_Parameter, + Selector_Name => Name_Params))))), + Selector_Name => + Make_Identifier (Loc, Name_Subp_Id)))))); + + -- Build a subprogram for RAS information lookups + + Current_Declaration := + Make_Subprogram_Declaration (Loc, + Specification => + Make_Function_Specification (Loc, + Defining_Unit_Name => + Lookup_RAS_Info, + Parameter_Specifications => New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_Subp_Id), + In_Present => + True, + Parameter_Type => + New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc))), + Subtype_Mark => + New_Occurrence_Of (RTE (RE_Unsigned_64), Loc))); + Append_To (Decls, Current_Declaration); + Analyze (Current_Declaration); + + Current_Stubs := Build_Subprogram_Receiving_Stubs + (Vis_Decl => Current_Declaration, + Asynchronous => False); + Append_To (Decls, Current_Stubs); + Analyze (Current_Stubs); + + Append_Stubs_To (Pkg_RPC_Receiver_Cases, + Stubs => + Current_Stubs, + Subprogram_Number => 1); + + -- For each subprogram, the receiving stub will be built and a + -- case statement will be made on the Subprogram_Id to dispatch + -- to the right subprogram. + + All_Calls_Remote_E := Boolean_Literals ( + Has_All_Calls_Remote (Defining_Entity (Pkg_Spec))); + + Overload_Counter_Table.Reset; + + Current_Declaration := First (Visible_Declarations (Pkg_Spec)); + while Present (Current_Declaration) loop + if Nkind (Current_Declaration) = N_Subprogram_Declaration + and then Comes_From_Source (Current_Declaration) + then + declare + Loc : constant Source_Ptr := + Sloc (Current_Declaration); + -- While specifically processing Current_Declaration, use + -- its Sloc as the location of all generated nodes. + + Subp_Def : constant Entity_Id := + Defining_Unit_Name + (Specification (Current_Declaration)); + + Subp_Val : String_Id; + + begin + pragma Assert (Current_Subprogram_Number = + Get_Subprogram_Id (Subp_Def)); + + -- Build receiving stub + + Current_Stubs := + Build_Subprogram_Receiving_Stubs + (Vis_Decl => Current_Declaration, + Asynchronous => + Nkind (Specification (Current_Declaration)) = + N_Procedure_Specification + and then Is_Asynchronous (Subp_Def)); + + Append_To (Decls, Current_Stubs); + Analyze (Current_Stubs); + + -- Build RAS proxy + + Add_RAS_Proxy_And_Analyze (Decls, + Vis_Decl => + Current_Declaration, + All_Calls_Remote_E => + All_Calls_Remote_E, + Proxy_Object_Addr => + Proxy_Object_Addr); + + -- Compute distribution identifier + + Assign_Subprogram_Identifier ( + Subp_Def, + Current_Subprogram_Number, + Subp_Val); + + -- Add subprogram descriptor (RCI_Subp_Info) to the + -- subprograms table for this receiver. The aggregate + -- below must be kept consistent with the declaration + -- of type RCI_Subp_Info in System.Partition_Interface. + + Append_To (Subp_Info_List, + Make_Component_Association (Loc, + Choices => New_List ( + Make_Integer_Literal (Loc, + Current_Subprogram_Number)), + Expression => + Make_Aggregate (Loc, + Component_Associations => New_List ( + Make_Component_Association (Loc, + Choices => New_List ( + Make_Identifier (Loc, Name_Addr)), + Expression => + New_Occurrence_Of ( + Proxy_Object_Addr, Loc)))))); + + Append_Stubs_To (Pkg_RPC_Receiver_Cases, + Stubs => + Current_Stubs, + Subprogram_Number => + Current_Subprogram_Number); + end; + + Current_Subprogram_Number := Current_Subprogram_Number + 1; + end if; + + Next (Current_Declaration); + end loop; + + -- If we receive an invalid Subprogram_Id, it is best to do nothing + -- rather than raising an exception since we do not want someone + -- to crash a remote partition by sending invalid subprogram ids. + -- This is consistent with the other parts of the case statement + -- since even in presence of incorrect parameters in the stream, + -- every exception will be caught and (if the subprogram is not an + -- APC) put into the result stream and sent away. + + Append_To (Pkg_RPC_Receiver_Cases, + Make_Case_Statement_Alternative (Loc, + Discrete_Choices => + New_List (Make_Others_Choice (Loc)), + Statements => + New_List (Make_Null_Statement (Loc)))); + + Append_To (Pkg_RPC_Receiver_Statements, + Make_Case_Statement (Loc, + Expression => + New_Occurrence_Of (Subp_Id, Loc), + Alternatives => Pkg_RPC_Receiver_Cases)); + + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Subp_Info_Array, + Constant_Present => True, + Aliased_Present => True, + Object_Definition => + Make_Subtype_Indication (Loc, + Subtype_Mark => + New_Occurrence_Of (RTE (RE_RCI_Subp_Info_Array), Loc), + Constraint => + Make_Index_Or_Discriminant_Constraint (Loc, + New_List ( + Make_Range (Loc, + Low_Bound => Make_Integer_Literal (Loc, + First_RCI_Subprogram_Id), + High_Bound => + Make_Integer_Literal (Loc, + First_RCI_Subprogram_Id + + List_Length (Subp_Info_List) - 1))))), + Expression => + Make_Aggregate (Loc, + Component_Associations => Subp_Info_List))); + Analyze (Last (Decls)); + + Append_To (Decls, + Make_Subprogram_Body (Loc, + Specification => + Copy_Specification (Loc, Parent (Lookup_RAS_Info)), + Declarations => + No_List, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List ( + Make_Return_Statement (Loc, + Expression => OK_Convert_To (RTE (RE_Unsigned_64), + Make_Selected_Component (Loc, + Prefix => + Make_Indexed_Component (Loc, + Prefix => + New_Occurrence_Of (Subp_Info_Array, Loc), + Expressions => New_List ( + Convert_To (Standard_Integer, + Make_Identifier (Loc, Name_Subp_Id)))), + Selector_Name => + Make_Identifier (Loc, Name_Addr)))))))); + Analyze (Last (Decls)); + + Append_To (Decls, Pkg_RPC_Receiver_Body); + Analyze (Last (Decls)); + + Get_Library_Unit_Name_String (Pkg_Spec); + Append_To (Register_Pkg_Actuals, + -- Name + Make_String_Literal (Loc, + Strval => String_From_Name_Buffer)); + + Append_To (Register_Pkg_Actuals, + -- Receiver + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Pkg_RPC_Receiver, Loc), + Attribute_Name => + Name_Unrestricted_Access)); + + Append_To (Register_Pkg_Actuals, + -- Version + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Defining_Entity (Pkg_Spec), Loc), + Attribute_Name => + Name_Version)); + + Append_To (Register_Pkg_Actuals, + -- Subp_Info + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Subp_Info_Array, Loc), + Attribute_Name => + Name_Address)); + + Append_To (Register_Pkg_Actuals, + -- Subp_Info_Len + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Subp_Info_Array, Loc), + Attribute_Name => + Name_Length)); + + Append_To (Decls, + Make_Procedure_Call_Statement (Loc, + Name => + New_Occurrence_Of (RTE (RE_Register_Receiving_Stub), Loc), + Parameter_Associations => Register_Pkg_Actuals)); + Analyze (Last (Decls)); + end Add_Receiving_Stubs_To_Declarations; + --------------------------------- -- Build_General_Calling_Stubs -- --------------------------------- @@ -4230,10 +3752,8 @@ package body Exp_Dist is Object => Make_Selected_Component (Loc, Prefix => - New_Occurrence_Of ( - Defining_Identifier (Current_Parameter), Loc), - Selector_Name => - Make_Identifier (Loc, Name_Addr)), + Defining_Identifier (Current_Parameter), + Selector_Name => Name_Addr), Etyp => RTE (RE_Unsigned_64))); else @@ -4510,6 +4030,64 @@ package body Exp_Dist is end if; end Build_General_Calling_Stubs; + ----------------------------- + -- Build_RPC_Receiver_Body -- + ----------------------------- + + procedure Build_RPC_Receiver_Body + (RPC_Receiver : Entity_Id; + Request : out Entity_Id; + Subp_Id : out Entity_Id; + Subp_Index : out Entity_Id; + Stmts : out List_Id; + Decl : out Node_Id) + is + Loc : constant Source_Ptr := Sloc (RPC_Receiver); + + RPC_Receiver_Spec : Node_Id; + RPC_Receiver_Decls : List_Id; + + begin + Request := Make_Defining_Identifier (Loc, Name_R); + + RPC_Receiver_Spec := + Build_RPC_Receiver_Specification + (RPC_Receiver => RPC_Receiver, + Request_Parameter => Request); + + Subp_Id := Make_Defining_Identifier (Loc, New_Internal_Name ('P')); + Subp_Index := Subp_Id; + + -- Subp_Id may not be a constant, because in the case of the RPC + -- receiver for an RCI package, when a call is received from a RAS + -- dereference, it will be assigned during subsequent processing. + + RPC_Receiver_Decls := New_List ( + Make_Object_Declaration (Loc, + Defining_Identifier => Subp_Id, + Object_Definition => + New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc), + Expression => + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc), + Attribute_Name => Name_Input, + Expressions => New_List ( + Make_Selected_Component (Loc, + Prefix => Request, + Selector_Name => Name_Params))))); + + Stmts := New_List; + + Decl := + Make_Subprogram_Body (Loc, + Specification => RPC_Receiver_Spec, + Declarations => RPC_Receiver_Decls, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Stmts)); + end Build_RPC_Receiver_Body; + ----------------------- -- Build_Stub_Target -- ----------------------- @@ -4534,17 +4112,13 @@ package body Exp_Dist is Expression => Make_Selected_Component (Loc, - Prefix => - New_Occurrence_Of (Controlling_Parameter, Loc), - Selector_Name => - Make_Identifier (Loc, Name_Origin)))); + Prefix => Controlling_Parameter, + Selector_Name => Name_Origin))); Target_Info.RPC_Receiver := Make_Selected_Component (Loc, - Prefix => - New_Occurrence_Of (Controlling_Parameter, Loc), - Selector_Name => - Make_Identifier (Loc, Name_Receiver)); + Prefix => Controlling_Parameter, + Selector_Name => Name_Receiver); else Append_To (Decls, @@ -4640,53 +4214,463 @@ package body Exp_Dist is RPC_Receiver_Decl := Empty; else declare - RPC_Receiver_Stream : constant Entity_Id := - Make_Defining_Identifier (Loc, Name_S); - RPC_Receiver_Result : constant Entity_Id := - Make_Defining_Identifier (Loc, Name_R); + RPC_Receiver_Request : constant Entity_Id := + Make_Defining_Identifier (Loc, Name_R); begin RPC_Receiver_Decl := Make_Subprogram_Declaration (Loc, Build_RPC_Receiver_Specification ( - RPC_Receiver => Make_Defining_Identifier (Loc, - New_Internal_Name ('R')), - Stream_Parameter => RPC_Receiver_Stream, - Result_Parameter => RPC_Receiver_Result)); + RPC_Receiver => Make_Defining_Identifier (Loc, + New_Internal_Name ('R')), + Request_Parameter => RPC_Receiver_Request)); end; end if; end Build_Stub_Type; -------------------------------------- - -- Build_RPC_Receiver_Specification -- + -- Build_Subprogram_Receiving_Stubs -- -------------------------------------- - function Build_RPC_Receiver_Specification - (RPC_Receiver : Entity_Id; - Stream_Parameter : Entity_Id; - Result_Parameter : Entity_Id) return Node_Id + function Build_Subprogram_Receiving_Stubs + (Vis_Decl : Node_Id; + Asynchronous : Boolean; + Dynamically_Asynchronous : Boolean := False; + Stub_Type : Entity_Id := Empty; + RACW_Type : Entity_Id := Empty; + Parent_Primitive : Entity_Id := Empty) return Node_Id is - Loc : constant Source_Ptr := Sloc (RPC_Receiver); + Loc : constant Source_Ptr := Sloc (Vis_Decl); + + Request_Parameter : Node_Id; + -- ??? + + Decls : constant List_Id := New_List; + -- All the parameters will get declared before calling the real + -- subprograms. Also the out parameters will be declared. + + Statements : constant List_Id := New_List; + + Extra_Formal_Statements : constant List_Id := New_List; + -- Statements concerning extra formal parameters + + After_Statements : constant List_Id := New_List; + -- Statements to be executed after the subprogram call + + Inner_Decls : List_Id := No_List; + -- In case of a function, the inner declarations are needed since + -- the result may be unconstrained. + + Excep_Handlers : List_Id := No_List; + Excep_Choice : Entity_Id; + Excep_Code : List_Id; + + Parameter_List : constant List_Id := New_List; + -- List of parameters to be passed to the subprogram + + Current_Parameter : Node_Id; + + Ordered_Parameters_List : constant List_Id := + Build_Ordered_Parameters_List + (Specification (Vis_Decl)); + + Subp_Spec : Node_Id; + -- Subprogram specification + + Called_Subprogram : Node_Id; + -- The subprogram to call + + Null_Raise_Statement : Node_Id; + + Dynamic_Async : Entity_Id; begin - return + if Present (RACW_Type) then + Called_Subprogram := + New_Occurrence_Of (Parent_Primitive, Loc); + else + Called_Subprogram := + New_Occurrence_Of ( + Defining_Unit_Name (Specification (Vis_Decl)), Loc); + end if; + + Request_Parameter := + Make_Defining_Identifier (Loc, New_Internal_Name ('R')); + + if Dynamically_Asynchronous then + Dynamic_Async := + Make_Defining_Identifier (Loc, New_Internal_Name ('S')); + else + Dynamic_Async := Empty; + end if; + + if not Asynchronous or Dynamically_Asynchronous then + + -- The first statement after the subprogram call is a statement to + -- writes a Null_Occurrence into the result stream. + + Null_Raise_Statement := + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc), + Attribute_Name => Name_Write, + Expressions => New_List ( + Make_Selected_Component (Loc, + Prefix => Request_Parameter, + Selector_Name => Name_Result), + New_Occurrence_Of (RTE (RE_Null_Occurrence), Loc))); + + if Dynamically_Asynchronous then + Null_Raise_Statement := + Make_Implicit_If_Statement (Vis_Decl, + Condition => + Make_Op_Not (Loc, New_Occurrence_Of (Dynamic_Async, Loc)), + Then_Statements => New_List (Null_Raise_Statement)); + end if; + + Append_To (After_Statements, Null_Raise_Statement); + end if; + + -- Loop through every parameter and get its value from the stream. If + -- the parameter is unconstrained, then the parameter is read using + -- 'Input at the point of declaration. + + Current_Parameter := First (Ordered_Parameters_List); + while Present (Current_Parameter) loop + declare + Etyp : Entity_Id; + Constrained : Boolean; + + Object : constant Entity_Id := + Make_Defining_Identifier (Loc, + New_Internal_Name ('P')); + + Expr : Node_Id := Empty; + + Is_Controlling_Formal : constant Boolean := + Is_RACW_Controlling_Formal + (Current_Parameter, Stub_Type); + + begin + Set_Ekind (Object, E_Variable); + + if Is_Controlling_Formal then + + -- We have a controlling formal parameter. Read its address + -- rather than a real object. The address is in Unsigned_64 + -- form. + + Etyp := RTE (RE_Unsigned_64); + else + Etyp := Etype (Parameter_Type (Current_Parameter)); + end if; + + Constrained := + Is_Constrained (Etyp) or else Is_Elementary_Type (Etyp); + + if In_Present (Current_Parameter) + or else not Out_Present (Current_Parameter) + or else not Constrained + or else Is_Controlling_Formal + then + -- If an input parameter is contrained, then its reading is + -- deferred until the beginning of the subprogram body. If + -- it is unconstrained, then an expression is built for + -- the object declaration and the variable is set using + -- 'Input instead of 'Read. + + if Constrained and then not Is_Controlling_Formal then + Append_To (Statements, + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Etyp, Loc), + Attribute_Name => Name_Read, + Expressions => New_List ( + Make_Selected_Component (Loc, + Prefix => Request_Parameter, + Selector_Name => Name_Params), + New_Occurrence_Of (Object, Loc)))); + + else + Expr := Input_With_Tag_Check (Loc, + Var_Type => Etyp, + Stream => Make_Selected_Component (Loc, + Prefix => Request_Parameter, + Selector_Name => Name_Params)); + Append_To (Decls, Expr); + Expr := Make_Function_Call (Loc, + New_Occurrence_Of (Defining_Unit_Name + (Specification (Expr)), Loc)); + end if; + end if; + + -- If we do not have to output the current parameter, then it + -- can well be flagged as constant. This may allow further + -- optimizations done by the back end. + + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Object, + Constant_Present => not Constrained + and then not Out_Present (Current_Parameter), + Object_Definition => + New_Occurrence_Of (Etyp, Loc), + Expression => Expr)); + + -- An out parameter may be written back using a 'Write + -- attribute instead of a 'Output because it has been + -- constrained by the parameter given to the caller. Note that + -- out controlling arguments in the case of a RACW are not put + -- back in the stream because the pointer on them has not + -- changed. + + if Out_Present (Current_Parameter) + and then + Etype (Parameter_Type (Current_Parameter)) /= Stub_Type + then + Append_To (After_Statements, + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Etyp, Loc), + Attribute_Name => Name_Write, + Expressions => New_List ( + Make_Selected_Component (Loc, + Prefix => Request_Parameter, + Selector_Name => Name_Result), + New_Occurrence_Of (Object, Loc)))); + end if; + + -- For RACW controlling formals, the Etyp of Object is always + -- an RACW, even if the parameter is not of an anonymous access + -- type. In such case, we need to dereference it at call time. + + if Is_Controlling_Formal then + if Nkind (Parameter_Type (Current_Parameter)) /= + N_Access_Definition + then + Append_To (Parameter_List, + Make_Parameter_Association (Loc, + Selector_Name => + New_Occurrence_Of ( + Defining_Identifier (Current_Parameter), Loc), + Explicit_Actual_Parameter => + Make_Explicit_Dereference (Loc, + Unchecked_Convert_To (RACW_Type, + OK_Convert_To (RTE (RE_Address), + New_Occurrence_Of (Object, Loc)))))); + + else + Append_To (Parameter_List, + Make_Parameter_Association (Loc, + Selector_Name => + New_Occurrence_Of ( + Defining_Identifier (Current_Parameter), Loc), + Explicit_Actual_Parameter => + Unchecked_Convert_To (RACW_Type, + OK_Convert_To (RTE (RE_Address), + New_Occurrence_Of (Object, Loc))))); + end if; + + else + Append_To (Parameter_List, + Make_Parameter_Association (Loc, + Selector_Name => + New_Occurrence_Of ( + Defining_Identifier (Current_Parameter), Loc), + Explicit_Actual_Parameter => + New_Occurrence_Of (Object, Loc))); + end if; + + -- If the current parameter needs an extra formal, then read it + -- from the stream and set the corresponding semantic field in + -- the variable. If the kind of the parameter identifier is + -- E_Void, then this is a compiler generated parameter that + -- doesn't need an extra constrained status. + + -- The case of Extra_Accessibility should also be handled ??? + + if Nkind (Parameter_Type (Current_Parameter)) /= + N_Access_Definition + and then + Ekind (Defining_Identifier (Current_Parameter)) /= E_Void + and then + Present (Extra_Constrained + (Defining_Identifier (Current_Parameter))) + then + declare + Extra_Parameter : constant Entity_Id := + Extra_Constrained + (Defining_Identifier + (Current_Parameter)); + + Formal_Entity : constant Entity_Id := + Make_Defining_Identifier + (Loc, Chars (Extra_Parameter)); + + Formal_Type : constant Entity_Id := + Etype (Extra_Parameter); + + begin + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Formal_Entity, + Object_Definition => + New_Occurrence_Of (Formal_Type, Loc))); + + Append_To (Extra_Formal_Statements, + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of ( + Formal_Type, Loc), + Attribute_Name => Name_Read, + Expressions => New_List ( + Make_Selected_Component (Loc, + Prefix => Request_Parameter, + Selector_Name => Name_Params), + New_Occurrence_Of (Formal_Entity, Loc)))); + Set_Extra_Constrained (Object, Formal_Entity); + end; + end if; + end; + + Next (Current_Parameter); + end loop; + + -- Append the formal statements list at the end of regular statements + + Append_List_To (Statements, Extra_Formal_Statements); + + if Nkind (Specification (Vis_Decl)) = N_Function_Specification then + + -- The remote subprogram is a function. We build an inner block to + -- be able to hold a potentially unconstrained result in a + -- variable. + + declare + Etyp : constant Entity_Id := + Etype (Subtype_Mark (Specification (Vis_Decl))); + Result : constant Node_Id := + Make_Defining_Identifier (Loc, + New_Internal_Name ('R')); + begin + Inner_Decls := New_List ( + Make_Object_Declaration (Loc, + Defining_Identifier => Result, + Constant_Present => True, + Object_Definition => New_Occurrence_Of (Etyp, Loc), + Expression => + Make_Function_Call (Loc, + Name => Called_Subprogram, + Parameter_Associations => Parameter_List))); + + Append_To (After_Statements, + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Etyp, Loc), + Attribute_Name => Name_Output, + Expressions => New_List ( + Make_Selected_Component (Loc, + Prefix => Request_Parameter, + Selector_Name => Name_Result), + New_Occurrence_Of (Result, Loc)))); + end; + + Append_To (Statements, + Make_Block_Statement (Loc, + Declarations => Inner_Decls, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => After_Statements))); + + else + -- The remote subprogram is a procedure. We do not need any inner + -- block in this case. + + if Dynamically_Asynchronous then + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Dynamic_Async, + Object_Definition => + New_Occurrence_Of (Standard_Boolean, Loc))); + + Append_To (Statements, + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Standard_Boolean, Loc), + Attribute_Name => Name_Read, + Expressions => New_List ( + Make_Selected_Component (Loc, + Prefix => Request_Parameter, + Selector_Name => Name_Params), + New_Occurrence_Of (Dynamic_Async, Loc)))); + end if; + + Append_To (Statements, + Make_Procedure_Call_Statement (Loc, + Name => Called_Subprogram, + Parameter_Associations => Parameter_List)); + + Append_List_To (Statements, After_Statements); + end if; + + if Asynchronous and then not Dynamically_Asynchronous then + + -- For an asynchronous procedure, add a null exception handler + + Excep_Handlers := New_List ( + Make_Exception_Handler (Loc, + Exception_Choices => New_List (Make_Others_Choice (Loc)), + Statements => New_List (Make_Null_Statement (Loc)))); + + else + -- In the other cases, if an exception is raised, then the + -- exception occurrence is copied into the output stream and + -- no other output parameter is written. + + Excep_Choice := + Make_Defining_Identifier (Loc, New_Internal_Name ('E')); + + Excep_Code := New_List ( + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc), + Attribute_Name => Name_Write, + Expressions => New_List ( + Make_Selected_Component (Loc, + Prefix => Request_Parameter, + Selector_Name => Name_Result), + New_Occurrence_Of (Excep_Choice, Loc)))); + + if Dynamically_Asynchronous then + Excep_Code := New_List ( + Make_Implicit_If_Statement (Vis_Decl, + Condition => Make_Op_Not (Loc, + New_Occurrence_Of (Dynamic_Async, Loc)), + Then_Statements => Excep_Code)); + end if; + + Excep_Handlers := New_List ( + Make_Exception_Handler (Loc, + Choice_Parameter => Excep_Choice, + Exception_Choices => New_List (Make_Others_Choice (Loc)), + Statements => Excep_Code)); + + end if; + + Subp_Spec := Make_Procedure_Specification (Loc, - Defining_Unit_Name => RPC_Receiver, + Defining_Unit_Name => + Make_Defining_Identifier (Loc, New_Internal_Name ('F')), + Parameter_Specifications => New_List ( Make_Parameter_Specification (Loc, - Defining_Identifier => Stream_Parameter, + Defining_Identifier => Request_Parameter, Parameter_Type => - Make_Access_Definition (Loc, - Subtype_Mark => - New_Occurrence_Of (RTE (RE_Params_Stream_Type), Loc))), + New_Occurrence_Of (RTE (RE_Request_Access), 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 Build_RPC_Receiver_Specification; + return + Make_Subprogram_Body (Loc, + Specification => Subp_Spec, + Declarations => Decls, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Statements, + Exception_Handlers => Excep_Handlers)); + end Build_Subprogram_Receiving_Stubs; ------------ -- Result -- @@ -4708,6 +4692,21 @@ package body Exp_Dist is end GARLIC_Support; + ----------------------------- + -- Make_Selected_Component -- + ----------------------------- + + function Make_Selected_Component + (Loc : Source_Ptr; + Prefix : Entity_Id; + Selector_Name : Name_Id) return Node_Id + is + begin + return Make_Selected_Component (Loc, + Prefix => New_Occurrence_Of (Prefix, Loc), + Selector_Name => Make_Identifier (Loc, Selector_Name)); + end Make_Selected_Component; + ------------------ -- Get_PCS_Name -- ------------------ @@ -4816,7 +4815,7 @@ package body Exp_Dist is function Input_With_Tag_Check (Loc : Source_Ptr; Var_Type : Entity_Id; - Stream : Entity_Id) return Node_Id + Stream : Node_Id) return Node_Id is begin return @@ -4834,7 +4833,7 @@ package body Exp_Dist is Prefix => New_Occurrence_Of (Var_Type, Loc), Attribute_Name => Name_Input, Expressions => - New_List (New_Occurrence_Of (Stream, Loc)))))))); + New_List (Stream))))))); end Input_With_Tag_Check; -------------------------------- @@ -5238,8 +5237,8 @@ package body Exp_Dist is Stub_Statements := New_List ( Make_Assignment_Statement (Loc, Name => Make_Selected_Component (Loc, - Prefix => New_Occurrence_Of (Stubbed_Result, Loc), - Selector_Name => Make_Identifier (Loc, Name_Target)), + Prefix => Stubbed_Result, + Selector_Name => Name_Target), Expression => Make_Function_Call (Loc, Name => @@ -5252,13 +5251,13 @@ package body Exp_Dist is New_Occurrence_Of (RTE (RE_Inc_Usage), Loc), Parameter_Associations => New_List ( Make_Selected_Component (Loc, - Prefix => New_Occurrence_Of (Stubbed_Result, Loc), - Selector_Name => Make_Identifier (Loc, Name_Target)))), + Prefix => Stubbed_Result, + Selector_Name => Name_Target))), Make_Assignment_Statement (Loc, Name => Make_Selected_Component (Loc, - Prefix => New_Occurrence_Of (Stubbed_Result, Loc), - Selector_Name => Make_Identifier (Loc, Name_Asynchronous)), + Prefix => Stubbed_Result, + Selector_Name => Name_Asynchronous), Expression => New_Occurrence_Of (Asynchronous_Flag, Loc))); @@ -5618,11 +5617,9 @@ package body Exp_Dist is New_Occurrence_Of (Any, Loc), Make_Selected_Component (Loc, Prefix => - New_Occurrence_Of ( Defining_Identifier ( - Stub_Elements.RPC_Receiver_Decl), Loc), - Selector_Name => - Make_Identifier (Loc, Name_Obj_TypeCode)))), + Stub_Elements.RPC_Receiver_Decl), + Selector_Name => Name_Obj_TypeCode))), Make_Return_Statement (Loc, Expression => New_Occurrence_Of (Any, Loc))); @@ -5727,11 +5724,9 @@ package body Exp_Dist is Expression => Make_Selected_Component (Loc, Prefix => - New_Occurrence_Of ( Defining_Identifier ( - Stub_Elements.RPC_Receiver_Decl), Loc), - Selector_Name => - Make_Identifier (Loc, Name_Obj_TypeCode)))))); + Stub_Elements.RPC_Receiver_Decl), + Selector_Name => Name_Obj_TypeCode))))); Insert_After (Declaration_Node (RACW_Type), Func_Decl); Append_To (Declarations, Func_Body); @@ -5949,8 +5944,8 @@ package body Exp_Dist is Make_Assignment_Statement (Loc, Name => Make_Selected_Component (Loc, - Prefix => New_Occurrence_Of (Stub_Ptr, Loc), - Selector_Name => Make_Identifier (Loc, Field_Name)), + Prefix => Stub_Ptr, + Selector_Name => Field_Name), Expression => Value); end Set_Field; @@ -6113,8 +6108,8 @@ package body Exp_Dist is New_Occurrence_Of (RTE (RE_Inc_Usage), Loc), Parameter_Associations => New_List ( Make_Selected_Component (Loc, - Prefix => New_Occurrence_Of (Stub_Ptr, Loc), - Selector_Name => Make_Identifier (Loc, Name_Target)))), + Prefix => Stub_Ptr, + Selector_Name => Name_Target))), -- E.4.1(9) A remote call is asynchronous if it is a call to -- a procedure, or a call through a value of an access-to-procedure @@ -6280,10 +6275,8 @@ package body Exp_Dist is Chars => New_Internal_Name ('R')); RACW_Parameter : constant Node_Id := Make_Selected_Component (Loc, - Prefix => - New_Occurrence_Of (RAS_Parameter, Loc), - Selector_Name => - Make_Identifier (Loc, Name_Ras)); + Prefix => RAS_Parameter, + Selector_Name => Name_Ras); begin -- Object declarations @@ -6436,6 +6429,473 @@ package body Exp_Dist is Set_Renaming_TSS (RAS_Type, Fnam, Name_uTypeCode); end Add_RAS_TypeCode; + ----------------------------------------- + -- Add_Receiving_Stubs_To_Declarations -- + ----------------------------------------- + + procedure Add_Receiving_Stubs_To_Declarations + (Pkg_Spec : Node_Id; + Decls : List_Id) + is + Loc : constant Source_Ptr := Sloc (Pkg_Spec); + + Pkg_RPC_Receiver : constant Entity_Id := + Make_Defining_Identifier (Loc, + New_Internal_Name ('H')); + Pkg_RPC_Receiver_Object : Node_Id; + + Pkg_RPC_Receiver_Body : Node_Id; + Pkg_RPC_Receiver_Decls : List_Id; + Pkg_RPC_Receiver_Statements : List_Id; + Pkg_RPC_Receiver_Cases : constant List_Id := New_List; + -- A Pkg_RPC_Receiver is built to decode the request + + Request : Node_Id; + -- Request object received from neutral layer + + Subp_Id : Entity_Id; + -- Subprogram identifier as received from the neutral + -- distribution core. + + Subp_Index : Entity_Id; + -- Internal index as determined by matching either the + -- method name from the request structure, or the local + -- subprogram address (in case of a RAS). + + Is_Local : constant Entity_Id := + Make_Defining_Identifier (Loc, New_Internal_Name ('L')); + Local_Address : constant Entity_Id := + Make_Defining_Identifier (Loc, New_Internal_Name ('A')); + -- Address of a local subprogram designated by a + -- reference corresponding to a RAS. + + Dispatch_On_Address : constant List_Id := New_List; + Dispatch_On_Name : constant List_Id := New_List; + + Current_Declaration : Node_Id; + Current_Stubs : Node_Id; + Current_Subprogram_Number : Int := First_RCI_Subprogram_Id; + + Subp_Info_Array : constant Entity_Id := + Make_Defining_Identifier (Loc, + Chars => New_Internal_Name ('I')); + + Subp_Info_List : constant List_Id := New_List; + + Register_Pkg_Actuals : constant List_Id := New_List; + + All_Calls_Remote_E : Entity_Id; + + procedure Append_Stubs_To + (RPC_Receiver_Cases : List_Id; + Declaration : Node_Id; + Stubs : Node_Id; + Subp_Number : Int; + Subp_Dist_Name : Entity_Id; + Subp_Proxy_Addr : Entity_Id); + -- Add one case to the specified RPC receiver case list associating + -- Subprogram_Number with the subprogram declared by Declaration, for + -- which we have receiving stubs in Stubs. Subp_Number is an internal + -- subprogram index. Subp_Dist_Name is the string used to call the + -- subprogram by name, and Subp_Dist_Addr is the address of the proxy + -- object, used in the context of calls through remote + -- access-to-subprogram types. + + --------------------- + -- Append_Stubs_To -- + --------------------- + + procedure Append_Stubs_To + (RPC_Receiver_Cases : List_Id; + Declaration : Node_Id; + Stubs : Node_Id; + Subp_Number : Int; + Subp_Dist_Name : Entity_Id; + Subp_Proxy_Addr : Entity_Id) + is + Case_Stmts : List_Id; + begin + Case_Stmts := New_List ( + Make_Procedure_Call_Statement (Loc, + Name => + New_Occurrence_Of ( + Defining_Entity (Stubs), Loc), + Parameter_Associations => + New_List (New_Occurrence_Of (Request, Loc)))); + if Nkind (Specification (Declaration)) + = N_Function_Specification + or else not + Is_Asynchronous (Defining_Entity (Specification (Declaration))) + then + Append_To (Case_Stmts, Make_Return_Statement (Loc)); + end if; + + Append_To (RPC_Receiver_Cases, + Make_Case_Statement_Alternative (Loc, + Discrete_Choices => + New_List (Make_Integer_Literal (Loc, Subp_Number)), + Statements => + Case_Stmts)); + + Append_To (Dispatch_On_Name, + Make_Elsif_Part (Loc, + Condition => + Make_Function_Call (Loc, + Name => + New_Occurrence_Of (RTE (RE_Caseless_String_Eq), Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of (Subp_Id, Loc), + New_Occurrence_Of (Subp_Dist_Name, Loc))), + Then_Statements => New_List ( + Make_Assignment_Statement (Loc, + New_Occurrence_Of (Subp_Index, Loc), + Make_Integer_Literal (Loc, + Subp_Number))))); + + Append_To (Dispatch_On_Address, + Make_Elsif_Part (Loc, + Condition => + Make_Op_Eq (Loc, + Left_Opnd => + New_Occurrence_Of (Local_Address, Loc), + Right_Opnd => + New_Occurrence_Of (Subp_Proxy_Addr, Loc)), + Then_Statements => New_List ( + Make_Assignment_Statement (Loc, + New_Occurrence_Of (Subp_Index, Loc), + Make_Integer_Literal (Loc, + Subp_Number))))); + end Append_Stubs_To; + + -- Start of processing for Add_Receiving_Stubs_To_Declarations + + begin + -- Building receiving stubs consist in several operations: + + -- - a package RPC receiver must be built. This subprogram + -- will get a Subprogram_Id from the incoming stream + -- and will dispatch the call to the right subprogram + + -- - a receiving stub for any subprogram visible in the package + -- spec. This stub will read all the parameters from the stream, + -- and put the result as well as the exception occurrence in the + -- output stream + + -- - a dummy package with an empty spec and a body made of an + -- elaboration part, whose job is to register the receiving + -- part of this RCI package on the name server. This is done + -- by calling System.Partition_Interface.Register_Receiving_Stub + + Build_RPC_Receiver_Body ( + RPC_Receiver => Pkg_RPC_Receiver, + Request => Request, + Subp_Id => Subp_Id, + Subp_Index => Subp_Index, + Stmts => Pkg_RPC_Receiver_Statements, + Decl => Pkg_RPC_Receiver_Body); + Pkg_RPC_Receiver_Decls := Declarations (Pkg_RPC_Receiver_Body); + + -- Extract local address information from the target reference: + -- if non-null, that means that this is a reference that denotes + -- one particular operation, and hence that the operation name + -- must not be taken into account for dispatching. + + Append_To (Pkg_RPC_Receiver_Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => + Is_Local, + Object_Definition => + New_Occurrence_Of (Standard_Boolean, Loc))); + Append_To (Pkg_RPC_Receiver_Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => + Local_Address, + Object_Definition => + New_Occurrence_Of (RTE (RE_Address), Loc))); + Append_To (Pkg_RPC_Receiver_Statements, + Make_Procedure_Call_Statement (Loc, + Name => + New_Occurrence_Of (RTE (RE_Get_Local_Address), Loc), + Parameter_Associations => New_List ( + Make_Selected_Component (Loc, + Prefix => Request, + Selector_Name => Name_Target), + New_Occurrence_Of (Is_Local, Loc), + New_Occurrence_Of (Local_Address, Loc)))); + + -- Determine whether the reference that was used to make + -- the call was the base RCI reference (in which case + -- Local_Address is 0, and the method identifier from the + -- request must be used to determine which subprogram is + -- called) or a reference identifying one particular subprogram + -- (in which case Local_Address is the address of that + -- subprogram, and the method name from the request is + -- ignored). + -- In each case, cascaded elsifs are used to determine the + -- proper subprogram index. Using hash tables might be + -- more efficient. + + Append_To (Pkg_RPC_Receiver_Statements, + Make_Implicit_If_Statement (Pkg_Spec, + Condition => + Make_Op_Ne (Loc, + Left_Opnd => New_Occurrence_Of (Local_Address, Loc), + Right_Opnd => New_Occurrence_Of (RTE (RE_Null_Address), Loc)), + Then_Statements => New_List ( + Make_Implicit_If_Statement (Pkg_Spec, + Condition => + New_Occurrence_Of (Standard_False, Loc), + Then_Statements => New_List ( + Make_Null_Statement (Loc)), + Elsif_Parts => + Dispatch_On_Address)), + Else_Statements => New_List ( + Make_Implicit_If_Statement (Pkg_Spec, + Condition => + New_Occurrence_Of (Standard_False, Loc), + Then_Statements => New_List ( + Make_Null_Statement (Loc)), + Elsif_Parts => + Dispatch_On_Name)))); + + -- For each subprogram, the receiving stub will be built and a + -- case statement will be made on the Subprogram_Id to dispatch + -- to the right subprogram. + + All_Calls_Remote_E := Boolean_Literals ( + Has_All_Calls_Remote (Defining_Entity (Pkg_Spec))); + + Overload_Counter_Table.Reset; + Reserve_NamingContext_Methods; + + Current_Declaration := First (Visible_Declarations (Pkg_Spec)); + while Present (Current_Declaration) loop + if Nkind (Current_Declaration) = N_Subprogram_Declaration + and then Comes_From_Source (Current_Declaration) + then + declare + Loc : constant Source_Ptr := + Sloc (Current_Declaration); + -- While specifically processing Current_Declaration, use + -- its Sloc as the location of all generated nodes. + + Subp_Def : constant Entity_Id := + Defining_Unit_Name + (Specification (Current_Declaration)); + + Subp_Val : String_Id; + + Subp_Dist_Name : constant Entity_Id := + Make_Defining_Identifier (Loc, + New_External_Name ( + Related_Id => Chars (Subp_Def), + Suffix => 'D', + Suffix_Index => -1)); + + Proxy_Object_Addr : Entity_Id; + + begin + pragma Assert (Current_Subprogram_Number = + Get_Subprogram_Id (Subp_Def)); + + -- Build receiving stub + + Current_Stubs := + Build_Subprogram_Receiving_Stubs + (Vis_Decl => Current_Declaration, + Asynchronous => + Nkind (Specification (Current_Declaration)) = + N_Procedure_Specification + and then Is_Asynchronous (Subp_Def)); + + Append_To (Decls, Current_Stubs); + Analyze (Current_Stubs); + + -- Build RAS proxy + + Add_RAS_Proxy_And_Analyze (Decls, + Vis_Decl => + Current_Declaration, + All_Calls_Remote_E => + All_Calls_Remote_E, + Proxy_Object_Addr => + Proxy_Object_Addr); + + -- Compute distribution identifier + + Assign_Subprogram_Identifier ( + Subp_Def, + Current_Subprogram_Number, + Subp_Val); + + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Subp_Dist_Name, + Constant_Present => True, + Object_Definition => New_Occurrence_Of ( + Standard_String, Loc), + Expression => + Make_String_Literal (Loc, Subp_Val))); + Analyze (Last (Decls)); + + -- Add subprogram descriptor (RCI_Subp_Info) to the + -- subprograms table for this receiver. The aggregate + -- below must be kept consistent with the declaration + -- of type RCI_Subp_Info in System.Partition_Interface. + + Append_To (Subp_Info_List, + Make_Component_Association (Loc, + Choices => New_List ( + Make_Integer_Literal (Loc, + Current_Subprogram_Number)), + Expression => + Make_Aggregate (Loc, + Expressions => New_List ( + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of ( + Subp_Dist_Name, Loc), + Attribute_Name => Name_Address), + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of ( + Subp_Dist_Name, Loc), + Attribute_Name => Name_Length), + New_Occurrence_Of (Proxy_Object_Addr, Loc))))); + + Append_Stubs_To (Pkg_RPC_Receiver_Cases, + Declaration => Current_Declaration, + Stubs => Current_Stubs, + Subp_Number => Current_Subprogram_Number, + Subp_Dist_Name => Subp_Dist_Name, + Subp_Proxy_Addr => Proxy_Object_Addr); + end; + + Current_Subprogram_Number := Current_Subprogram_Number + 1; + end if; + + Next (Current_Declaration); + end loop; + + -- If we receive an invalid Subprogram_Id, it is best to do nothing + -- rather than raising an exception since we do not want someone + -- to crash a remote partition by sending invalid subprogram ids. + -- This is consistent with the other parts of the case statement + -- since even in presence of incorrect parameters in the stream, + -- every exception will be caught and (if the subprogram is not an + -- APC) put into the result stream and sent away. + + Append_To (Pkg_RPC_Receiver_Cases, + Make_Case_Statement_Alternative (Loc, + Discrete_Choices => + New_List (Make_Others_Choice (Loc)), + Statements => + New_List (Make_Null_Statement (Loc)))); + + Append_To (Pkg_RPC_Receiver_Statements, + Make_Case_Statement (Loc, + Expression => + New_Occurrence_Of (Subp_Index, Loc), + Alternatives => Pkg_RPC_Receiver_Cases)); + + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Subp_Info_Array, + Constant_Present => True, + Aliased_Present => True, + Object_Definition => + Make_Subtype_Indication (Loc, + Subtype_Mark => + New_Occurrence_Of (RTE (RE_RCI_Subp_Info_Array), Loc), + Constraint => + Make_Index_Or_Discriminant_Constraint (Loc, + New_List ( + Make_Range (Loc, + Low_Bound => Make_Integer_Literal (Loc, + First_RCI_Subprogram_Id), + High_Bound => + Make_Integer_Literal (Loc, + First_RCI_Subprogram_Id + + List_Length (Subp_Info_List) - 1))))), + Expression => + Make_Aggregate (Loc, + Component_Associations => Subp_Info_List))); + Analyze (Last (Decls)); + + Append_To (Decls, Pkg_RPC_Receiver_Body); + Analyze (Last (Decls)); + + Pkg_RPC_Receiver_Object := + Make_Object_Declaration (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, New_Internal_Name ('R')), + Aliased_Present => True, + Object_Definition => + New_Occurrence_Of (RTE (RE_Servant), Loc)); + Append_To (Decls, Pkg_RPC_Receiver_Object); + Analyze (Last (Decls)); + + Get_Library_Unit_Name_String (Pkg_Spec); + Append_To (Register_Pkg_Actuals, + -- Name + Make_String_Literal (Loc, + Strval => String_From_Name_Buffer)); + + Append_To (Register_Pkg_Actuals, + -- Version + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of + (Defining_Entity (Pkg_Spec), Loc), + Attribute_Name => + Name_Version)); + + Append_To (Register_Pkg_Actuals, + -- Handler + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Pkg_RPC_Receiver, Loc), + Attribute_Name => Name_Access)); + + Append_To (Register_Pkg_Actuals, + -- Receiver + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of ( + Defining_Identifier ( + Pkg_RPC_Receiver_Object), Loc), + Attribute_Name => + Name_Access)); + + Append_To (Register_Pkg_Actuals, + -- Subp_Info + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Subp_Info_Array, Loc), + Attribute_Name => + Name_Address)); + + Append_To (Register_Pkg_Actuals, + -- Subp_Info_Len + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Subp_Info_Array, Loc), + Attribute_Name => + Name_Length)); + + Append_To (Register_Pkg_Actuals, + -- Is_All_Calls_Remote + New_Occurrence_Of (All_Calls_Remote_E, Loc)); + + Append_To (Decls, + Make_Procedure_Call_Statement (Loc, + Name => + New_Occurrence_Of (RTE (RE_Register_Pkg_Receiving_Stub), Loc), + Parameter_Associations => Register_Pkg_Actuals)); + Analyze (Last (Decls)); + + end Add_Receiving_Stubs_To_Declarations; + --------------------------------- -- Build_General_Calling_Stubs -- --------------------------------- @@ -6461,7 +6921,7 @@ package body Exp_Dist is -- to the remote package Request : Node_Id; - -- The request object constructed by these stubs. + -- The request object constructed by these stubs Result : Node_Id; -- Name of the result named value (in non-APC cases) which get the @@ -6497,7 +6957,7 @@ package body Exp_Dist is -- in out or out parameter values). Etyp : Entity_Id; - -- The type of the formal parameter being processed. + -- The type of the formal parameter being processed Is_Controlling_Formal : Boolean; Is_First_Controlling_Formal : Boolean; @@ -6822,10 +7282,8 @@ package body Exp_Dist is PolyORB_Support.Helpers.Build_From_Any_Call ( Etype (Subtype_Mark (Spec)), Make_Selected_Component (Loc, - Prefix => - New_Occurrence_Of (Result, Loc), - Selector_Name => - Make_Identifier (Loc, Name_Argument)), + Prefix => Result, + Selector_Name => Name_Argument), Decls)))); end if; end if; @@ -6876,10 +7334,8 @@ package body Exp_Dist is New_Occurrence_Of (RTE (RE_Make_Ref), Loc), Parameter_Associations => New_List ( Make_Selected_Component (Loc, - Prefix => - New_Occurrence_Of (Controlling_Parameter, Loc), - Selector_Name => - Make_Identifier (Loc, Name_Target)))))); + Prefix => Controlling_Parameter, + Selector_Name => Name_Target))))); -- Controlling_Parameter has the same components -- as System.Partition_Interface.RACW_Stub_Type. @@ -6952,28 +7408,563 @@ package body Exp_Dist is New_Occurrence_Of (RTE (RE_Servant), Loc)); end Build_Stub_Type; + ----------------------------- + -- Build_RPC_Receiver_Body -- + ----------------------------- + + procedure Build_RPC_Receiver_Body + (RPC_Receiver : Entity_Id; + Request : out Entity_Id; + Subp_Id : out Entity_Id; + Subp_Index : out Entity_Id; + Stmts : out List_Id; + Decl : out Node_Id) + is + Loc : constant Source_Ptr := Sloc (RPC_Receiver); + + RPC_Receiver_Spec : Node_Id; + RPC_Receiver_Decls : List_Id; + + begin + Request := Make_Defining_Identifier (Loc, Name_R); + + RPC_Receiver_Spec := + Build_RPC_Receiver_Specification ( + RPC_Receiver => RPC_Receiver, + Request_Parameter => Request); + + Subp_Id := Make_Defining_Identifier (Loc, Name_P); + Subp_Index := Make_Defining_Identifier (Loc, Name_I); + + RPC_Receiver_Decls := New_List ( + Make_Object_Renaming_Declaration (Loc, + Defining_Identifier => Subp_Id, + Subtype_Mark => New_Occurrence_Of (Standard_String, Loc), + Name => + Make_Explicit_Dereference (Loc, + Prefix => + Make_Selected_Component (Loc, + Prefix => Request, + Selector_Name => Name_Operation))), + + Make_Object_Declaration (Loc, + Defining_Identifier => Subp_Index, + Object_Definition => + New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc), + Expression => + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc), + Attribute_Name => Name_Last))); + + Stmts := New_List; + + Decl := + Make_Subprogram_Body (Loc, + Specification => RPC_Receiver_Spec, + Declarations => RPC_Receiver_Decls, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Stmts)); + end Build_RPC_Receiver_Body; + -------------------------------------- - -- Build_RPC_Receiver_Specification -- + -- Build_Subprogram_Receiving_Stubs -- -------------------------------------- - function Build_RPC_Receiver_Specification - (RPC_Receiver : Entity_Id; - Request_Parameter : Entity_Id) return Node_Id + function Build_Subprogram_Receiving_Stubs + (Vis_Decl : Node_Id; + Asynchronous : Boolean; + Dynamically_Asynchronous : Boolean := False; + Stub_Type : Entity_Id := Empty; + RACW_Type : Entity_Id := Empty; + Parent_Primitive : Entity_Id := Empty) return Node_Id is - Loc : constant Source_Ptr := Sloc (RPC_Receiver); + Loc : constant Source_Ptr := Sloc (Vis_Decl); + + Request_Parameter : Node_Id; + -- ??? + + Outer_Decls : constant List_Id := New_List; + -- At the outermost level, an NVList and Any's are + -- declared for all parameters. The Dynamic_Async + -- flag also needs to be declared there to be visible + -- from the exception handling code. + + Outer_Statements : constant List_Id := New_List; + -- Statements that occur prior to the declaration of the actual + -- parameter variables. + + Decls : constant List_Id := New_List; + -- All the parameters will get declared before calling the real + -- subprograms. Also the out parameters will be declared. + -- At this level, parameters may be unconstrained. + + Statements : constant List_Id := New_List; + + Extra_Formal_Statements : constant List_Id := New_List; + -- Statements concerning extra formal parameters + + After_Statements : constant List_Id := New_List; + -- Statements to be executed after the subprogram call + + Inner_Decls : List_Id := No_List; + -- In case of a function, the inner declarations are needed since + -- the result may be unconstrained. + + Excep_Handlers : List_Id := No_List; + + Parameter_List : constant List_Id := New_List; + -- List of parameters to be passed to the subprogram + + First_Controlling_Formal_Seen : Boolean := False; + + Current_Parameter : Node_Id; + + Ordered_Parameters_List : constant List_Id := + Build_Ordered_Parameters_List + (Specification (Vis_Decl)); + + Arguments : Node_Id; + -- Name of the named values list used to retrieve parameters + + Subp_Spec : Node_Id; + -- Subprogram specification + + Called_Subprogram : Node_Id; + -- The subprogram to call begin - return + if Present (RACW_Type) then + Called_Subprogram := + New_Occurrence_Of (Parent_Primitive, Loc); + else + Called_Subprogram := + New_Occurrence_Of ( + Defining_Unit_Name (Specification (Vis_Decl)), Loc); + end if; + + Request_Parameter := + Make_Defining_Identifier (Loc, New_Internal_Name ('R')); + + Arguments := + Make_Defining_Identifier (Loc, New_Internal_Name ('A')); + Declare_Create_NVList (Loc, Arguments, Outer_Decls, Outer_Statements); + + -- Loop through every parameter and get its value from the stream. If + -- the parameter is unconstrained, then the parameter is read using + -- 'Input at the point of declaration. + + Current_Parameter := First (Ordered_Parameters_List); + while Present (Current_Parameter) loop + declare + Etyp : Entity_Id; + Constrained : Boolean; + Any : Entity_Id := Empty; + Object : constant Entity_Id := + Make_Defining_Identifier (Loc, + New_Internal_Name ('P')); + Expr : Node_Id := Empty; + + Is_Controlling_Formal : constant Boolean + := Is_RACW_Controlling_Formal (Current_Parameter, Stub_Type); + + Is_First_Controlling_Formal : Boolean := False; + begin + Set_Ekind (Object, E_Variable); + + if Is_Controlling_Formal then + + -- Controlling formals in distributed object primitive + -- operations are handled specially: + -- - the first controlling formal is used as the + -- target of the call; + -- - the remaining controlling formals are transmitted + -- as RACWs. + + Etyp := RACW_Type; + Is_First_Controlling_Formal := + not First_Controlling_Formal_Seen; + First_Controlling_Formal_Seen := True; + else + Etyp := Etype (Parameter_Type (Current_Parameter)); + end if; + + Constrained := + Is_Constrained (Etyp) + or else Is_Elementary_Type (Etyp); + + if not Is_First_Controlling_Formal then + Any := Make_Defining_Identifier (Loc, + New_Internal_Name ('A')); + Append_To (Outer_Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => + Any, + Object_Definition => + New_Occurrence_Of (RTE (RE_Any), Loc), + Expression => + Make_Function_Call (Loc, + Name => + New_Occurrence_Of (RTE (RE_Create_Any), Loc), + Parameter_Associations => New_List ( + PolyORB_Support.Helpers.Build_TypeCode_Call (Loc, + Etyp, Outer_Decls))))); + + Append_To (Outer_Statements, + Add_Parameter_To_NVList (Loc, + Parameter => Current_Parameter, + NVList => Arguments, + Constrained => Constrained, + Any => Any)); + end if; + + if Is_First_Controlling_Formal then + declare + Addr : constant Entity_Id := + Make_Defining_Identifier (Loc, + New_Internal_Name ('A')); + Is_Local : constant Entity_Id := + Make_Defining_Identifier (Loc, + New_Internal_Name ('L')); + begin + + -- Special case: obtain the first controlling + -- formal from the target of the remote call, + -- instead of the argument list. + + Append_To (Outer_Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => + Addr, + Object_Definition => + New_Occurrence_Of (RTE (RE_Address), Loc))); + Append_To (Outer_Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => + Is_Local, + Object_Definition => + New_Occurrence_Of (Standard_Boolean, Loc))); + Append_To (Outer_Statements, + Make_Procedure_Call_Statement (Loc, + Name => + New_Occurrence_Of ( + RTE (RE_Get_Local_Address), Loc), + Parameter_Associations => New_List ( + Make_Selected_Component (Loc, + Prefix => + New_Occurrence_Of ( + Request_Parameter, Loc), + Selector_Name => + Make_Identifier (Loc, Name_Target)), + New_Occurrence_Of (Is_Local, Loc), + New_Occurrence_Of (Addr, Loc)))); + + Expr := Unchecked_Convert_To (RACW_Type, + New_Occurrence_Of (Addr, Loc)); + end; + + elsif In_Present (Current_Parameter) + or else not Out_Present (Current_Parameter) + or else not Constrained + then + -- If an input parameter is contrained, then its reading is + -- deferred until the beginning of the subprogram body. If + -- it is unconstrained, then an expression is built for + -- the object declaration and the variable is set using + -- 'Input instead of 'Read. + + Expr := PolyORB_Support.Helpers.Build_From_Any_Call ( + Etyp, New_Occurrence_Of (Any, Loc), Decls); + + if Constrained then + + Append_To (Statements, + Make_Assignment_Statement (Loc, + Name => + New_Occurrence_Of (Object, Loc), + Expression => + Expr)); + Expr := Empty; + else + null; + -- Expr will be used to initialize (and constrain) + -- the parameter when it is declared. + end if; + + end if; + + -- If we do not have to output the current parameter, then + -- it can well be flagged as constant. This may allow further + -- optimizations done by the back end. + + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Object, + Constant_Present => not Constrained + and then not Out_Present (Current_Parameter), + Object_Definition => + New_Occurrence_Of (Etyp, Loc), + Expression => Expr)); + Set_Etype (Object, Etyp); + + -- An out parameter may be written back using a 'Write + -- attribute instead of a 'Output because it has been + -- constrained by the parameter given to the caller. Note that + -- out controlling arguments in the case of a RACW are not put + -- back in the stream because the pointer on them has not + -- changed. + + if Out_Present (Current_Parameter) + and then not Is_Controlling_Formal + then + Append_To (After_Statements, + Make_Procedure_Call_Statement (Loc, + Name => + New_Occurrence_Of (RTE (RE_Copy_Any_Value), Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of (Any, Loc), + PolyORB_Support.Helpers.Build_To_Any_Call ( + New_Occurrence_Of (Object, Loc), + Decls)))); + end if; + + -- For RACW controlling formals, the Etyp of Object is always + -- an RACW, even if the parameter is not of an anonymous access + -- type. In such case, we need to dereference it at call time. + + if Is_Controlling_Formal then + if Nkind (Parameter_Type (Current_Parameter)) /= + N_Access_Definition + then + Append_To (Parameter_List, + Make_Parameter_Association (Loc, + Selector_Name => + New_Occurrence_Of ( + Defining_Identifier (Current_Parameter), Loc), + Explicit_Actual_Parameter => + Make_Explicit_Dereference (Loc, + Unchecked_Convert_To (RACW_Type, + OK_Convert_To (RTE (RE_Address), + New_Occurrence_Of (Object, Loc)))))); + + else + Append_To (Parameter_List, + Make_Parameter_Association (Loc, + Selector_Name => + New_Occurrence_Of ( + Defining_Identifier (Current_Parameter), Loc), + Explicit_Actual_Parameter => + Unchecked_Convert_To (RACW_Type, + OK_Convert_To (RTE (RE_Address), + New_Occurrence_Of (Object, Loc))))); + end if; + + else + Append_To (Parameter_List, + Make_Parameter_Association (Loc, + Selector_Name => + New_Occurrence_Of ( + Defining_Identifier (Current_Parameter), Loc), + Explicit_Actual_Parameter => + New_Occurrence_Of (Object, Loc))); + end if; + + -- If the current parameter needs an extra formal, then read it + -- from the stream and set the corresponding semantic field in + -- the variable. If the kind of the parameter identifier is + -- E_Void, then this is a compiler generated parameter that + -- doesn't need an extra constrained status. + + -- The case of Extra_Accessibility should also be handled ??? + + if Nkind (Parameter_Type (Current_Parameter)) /= + N_Access_Definition + and then + Ekind (Defining_Identifier (Current_Parameter)) /= E_Void + and then + Present (Extra_Constrained + (Defining_Identifier (Current_Parameter))) + then + declare + Extra_Parameter : constant Entity_Id := + Extra_Constrained + (Defining_Identifier + (Current_Parameter)); + Extra_Any : constant Entity_Id := + Make_Defining_Identifier + (Loc, New_Internal_Name ('A')); + Formal_Entity : constant Entity_Id := + Make_Defining_Identifier + (Loc, Chars (Extra_Parameter)); + + Formal_Type : constant Entity_Id := + Etype (Extra_Parameter); + begin + Append_To (Outer_Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => + Extra_Any, + Object_Definition => + New_Occurrence_Of (RTE (RE_Any), Loc))); + + Append_To (Outer_Statements, + Add_Parameter_To_NVList (Loc, + Parameter => Extra_Parameter, + NVList => Arguments, + Constrained => True, + Any => Extra_Any)); + + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Formal_Entity, + Object_Definition => + New_Occurrence_Of (Formal_Type, Loc))); + + Append_To (Extra_Formal_Statements, + Make_Assignment_Statement (Loc, + Name => + New_Occurrence_Of (Extra_Parameter, Loc), + Expression => + PolyORB_Support.Helpers.Build_From_Any_Call ( + Etype (Extra_Parameter), + New_Occurrence_Of (Extra_Any, Loc), + Decls))); + Set_Extra_Constrained (Object, Formal_Entity); + + end; + end if; + end; + + Next (Current_Parameter); + end loop; + + Append_To (Outer_Statements, + Make_Procedure_Call_Statement (Loc, + Name => + New_Occurrence_Of (RTE (RE_Request_Arguments), Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of (Request_Parameter, Loc), + New_Occurrence_Of (Arguments, Loc)))); + + Append_List_To (Statements, Extra_Formal_Statements); + + if Nkind (Specification (Vis_Decl)) = N_Function_Specification then + + -- The remote subprogram is a function. We build an inner block to + -- be able to hold a potentially unconstrained result in a + -- variable. + + declare + Etyp : constant Entity_Id := + Etype (Subtype_Mark (Specification (Vis_Decl))); + Result : constant Node_Id := + Make_Defining_Identifier (Loc, + New_Internal_Name ('R')); + begin + Inner_Decls := New_List ( + Make_Object_Declaration (Loc, + Defining_Identifier => Result, + Constant_Present => True, + Object_Definition => New_Occurrence_Of (Etyp, Loc), + Expression => + Make_Function_Call (Loc, + Name => Called_Subprogram, + Parameter_Associations => Parameter_List))); + + Set_Etype (Result, Etyp); + Append_To (After_Statements, + Make_Procedure_Call_Statement (Loc, + Name => + New_Occurrence_Of (RTE (RE_Set_Result), Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of (Request_Parameter, Loc), + PolyORB_Support.Helpers.Build_To_Any_Call ( + New_Occurrence_Of (Result, Loc), + Decls)))); + -- A DSA function does not have out or inout arguments + end; + + Append_To (Statements, + Make_Block_Statement (Loc, + Declarations => Inner_Decls, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => After_Statements))); + + else + -- The remote subprogram is a procedure. We do not need any inner + -- block in this case. No specific processing is required here for + -- the dynamically asynchronous case: the indication of whether + -- call is asynchronous or not is managed by the Sync_Scope + -- attibute of the request, and is handled entirely in the + -- protocol layer. + + Append_To (After_Statements, + Make_Procedure_Call_Statement (Loc, + Name => + New_Occurrence_Of (RTE (RE_Request_Set_Out), Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of (Request_Parameter, Loc)))); + + Append_To (Statements, + Make_Procedure_Call_Statement (Loc, + Name => Called_Subprogram, + Parameter_Associations => Parameter_List)); + + Append_List_To (Statements, After_Statements); + end if; + + Subp_Spec := Make_Procedure_Specification (Loc, - Defining_Unit_Name => RPC_Receiver, + Defining_Unit_Name => + Make_Defining_Identifier (Loc, New_Internal_Name ('F')), + Parameter_Specifications => New_List ( Make_Parameter_Specification (Loc, Defining_Identifier => Request_Parameter, Parameter_Type => - New_Occurrence_Of ( - RTE (RE_Request_Access), Loc)))); - end Build_RPC_Receiver_Specification; + New_Occurrence_Of (RTE (RE_Request_Access), Loc)))); + + -- An exception raised during the execution of an incoming + -- remote subprogram call and that needs to be sent back + -- to the caller is propagated by the receiving stubs, and + -- will be handled by the caller (the distribution runtime). + + if Asynchronous and then not Dynamically_Asynchronous then + + -- For an asynchronous procedure, add a null exception handler + + Excep_Handlers := New_List ( + Make_Exception_Handler (Loc, + Exception_Choices => New_List (Make_Others_Choice (Loc)), + Statements => New_List (Make_Null_Statement (Loc)))); + + else + -- In the other cases, if an exception is raised, then the + -- exception occurrence is propagated. + + null; + end if; + + Append_To (Outer_Statements, + Make_Block_Statement (Loc, + Declarations => + Decls, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Statements))); + + return + Make_Subprogram_Body (Loc, + Specification => Subp_Spec, + Declarations => Outer_Decls, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Outer_Statements, + Exception_Handlers => Excep_Handlers)); + end Build_Subprogram_Receiving_Stubs; ------------- -- Helpers -- ------------- @@ -7402,11 +8393,9 @@ package body Exp_Dist is Make_Case_Statement (Loc, Expression => Make_Selected_Component (Loc, - Prefix => - New_Occurrence_Of (Rec, Loc), + Prefix => Rec, Selector_Name => - New_Occurrence_Of ( - Entity (Name (Field)), Loc)), + Chars (Name (Field))), Alternatives => Alt_List)); @@ -8116,7 +9105,7 @@ package body Exp_Dist is -- A regular component Field_Ref := Make_Selected_Component (Loc, - Prefix => New_Occurrence_Of (Rec, Loc), + Prefix => New_Occurrence_Of (Rec, Loc), Selector_Name => New_Occurrence_Of (Field, Loc)); Set_Etype (Field_Ref, Etype (Field)); @@ -8165,11 +9154,9 @@ package body Exp_Dist is is Nod : constant Node_Id := Make_Selected_Component (Loc, - Prefix => - New_Occurrence_Of (Rec, Loc), + Prefix => Rec, Selector_Name => - New_Occurrence_Of ( - Entity (Name (Field)), Loc)); + Chars (Name (Field))); begin Set_Etype (Nod, Name (Field)); return Nod; @@ -8305,10 +9292,8 @@ package body Exp_Dist is Expression => Build_To_Any_Call ( Make_Selected_Component (Loc, - Prefix => - New_Occurrence_Of (Expr_Parameter, Loc), - Selector_Name => - New_Occurrence_Of (Disc, Loc)), + Prefix => Expr_Parameter, + Selector_Name => Chars (Disc)), Decls))); Counter := Counter + 1; Next_Discriminant (Disc); @@ -9551,6 +10536,19 @@ package body Exp_Dist is end if; end Make_Stream_Procedure_Function_Name; end Helpers; + + ----------------------------------- + -- Reserve_NamingContext_Methods -- + ----------------------------------- + + procedure Reserve_NamingContext_Methods is + Str_Resolve : constant String := "resolve"; + begin + Name_Buffer (1 .. Str_Resolve'Length) := Str_Resolve; + Name_Len := Str_Resolve'Length; + Overload_Counter_Table.Set (Name_Find, 1); + end Reserve_NamingContext_Methods; + end PolyORB_Support; ------------------------------- @@ -9719,6 +10717,25 @@ package body Exp_Dist is end case; end Specific_Add_RAST_Features; + -------------------------------------------------- + -- Specific_Add_Receiving_Stubs_To_Declarations -- + -------------------------------------------------- + + procedure Specific_Add_Receiving_Stubs_To_Declarations + (Pkg_Spec : Node_Id; + Decls : List_Id) + is + begin + case Get_PCS_Name is + when Name_PolyORB_DSA => + PolyORB_Support.Add_Receiving_Stubs_To_Declarations ( + Pkg_Spec, Decls); + when others => + GARLIC_Support.Add_Receiving_Stubs_To_Declarations ( + Pkg_Spec, Decls); + end case; + end Specific_Add_Receiving_Stubs_To_Declarations; + ------------------------------------------ -- Specific_Build_General_Calling_Stubs -- ------------------------------------------ @@ -9771,6 +10788,39 @@ package body Exp_Dist is end case; end Specific_Build_General_Calling_Stubs; + -------------------------------------- + -- Specific_Build_RPC_Receiver_Body -- + -------------------------------------- + + procedure Specific_Build_RPC_Receiver_Body + (RPC_Receiver : Entity_Id; + Request : out Entity_Id; + Subp_Id : out Entity_Id; + Subp_Index : out Entity_Id; + Stmts : out List_Id; + Decl : out Node_Id) + is + begin + case Get_PCS_Name is + when Name_PolyORB_DSA => + PolyORB_Support.Build_RPC_Receiver_Body + (RPC_Receiver, + Request, + Subp_Id, + Subp_Index, + Stmts, + Decl); + when others => + GARLIC_Support.Build_RPC_Receiver_Body + (RPC_Receiver, + Request, + Subp_Id, + Subp_Index, + Stmts, + Decl); + end case; + end Specific_Build_RPC_Receiver_Body; + -------------------------------- -- Specific_Build_Stub_Target -- -------------------------------- @@ -9814,6 +10864,34 @@ package body Exp_Dist is end case; end Specific_Build_Stub_Type; + function Specific_Build_Subprogram_Receiving_Stubs + (Vis_Decl : Node_Id; + Asynchronous : Boolean; + Dynamically_Asynchronous : Boolean := False; + Stub_Type : Entity_Id := Empty; + RACW_Type : Entity_Id := Empty; + Parent_Primitive : Entity_Id := Empty) return Node_Id is + begin + case Get_PCS_Name is + when Name_PolyORB_DSA => + return PolyORB_Support.Build_Subprogram_Receiving_Stubs ( + Vis_Decl, + Asynchronous, + Dynamically_Asynchronous, + Stub_Type, + RACW_Type, + Parent_Primitive); + when others => + return GARLIC_Support.Build_Subprogram_Receiving_Stubs ( + Vis_Decl, + Asynchronous, + Dynamically_Asynchronous, + Stub_Type, + RACW_Type, + Parent_Primitive); + end case; + end Specific_Build_Subprogram_Receiving_Stubs; + -------------------------- -- Underlying_RACW_Type -- -------------------------- |