From 1735e55db99c4dac8a4c93f6f637bce55cb3008a Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Fri, 19 Nov 2004 11:56:15 +0100 Subject: [PATCH] exp_dist.adb (Build_RPC_Receiver_Body): New subprogram. * exp_dist.adb (Build_RPC_Receiver_Body): New subprogram. This procedures factors the common processing for building an RPC receiver for an RCI package or an RACW type. Stylistic cleanup: change '/= Empty' to 'Present ()'; move body of Build_Remote_Subprogram_Proxy_Type into proper alphabetical order. (Get_PCS_Name): New subprogram. Returns the name of the PCS currently in use. (Specific_Add_RACW_Features): New subprogram. PCS-specific part of Add_RACW_Features. (Specific_Add_RAST_Features): New subprogram. PCS-specific part of Add_RAST_Features. (Assign_Subprogram_Identifier): New subprogram. Provision for assigning distribution subprogram identifiers that are either subprogram numbers or strings. (Get_Subprogram_Ids): New subprogram. Retrieve both the numeric and string distribution identifiers assigned to a given subprogram. (Get_Subprogram_Id): Reimplement in terms of Get_Subprogram_Ids. (Add_RAS_Dereference_TSS): Add comments. (Build_General_Calling_Stubs): Note that the RACW_Type formal parameter is not referenced yet because it will be used by the PolyORB DSA implementation. (Insert_Partition_Check): Remove fossile code. (First_RCI_Subprogram_Id): Document this constant. (Add_RAS_Access_TSS): Correct the setting of the Etype of the RAS_Access TSS. (Get_Pkg_Name_String): Remove subprogram. Usage occurrences are replaced with calls to Get_Library_Unit_Name_String. Previously there were several instances of the same code in different locations in the compiler; this checkin completes the replacement of all of these instances with calls to a common subprogram. Minor reformatting. * sem_dist.adb: Remove comment noting that RPC receiver generation should be disabled for RACWs that implement RASs. (Process_Partition_Id): Use new subprogram Get_Library_Unit_Name_String. * sem_util.ads, sem_util.adb (Has_Stream): New function (Get_Library_Unit_Name_String): New subprogram to retrieve the fully qualified name of a library unit into the name buffer. (Note_Possible_Modification): Generate a reference only if the context comes from source. * snames.ads (PCS_Names): New subtype corresponding to names of supported implementations of the Partition Communication Subsystem (PCS) (i.e. the runtime library support modules for the distributed systems annex). From-SVN: r90903 --- gcc/ada/exp_dist.adb | 6279 +++++++++++++++++++++++++++----------------------- gcc/ada/sem_dist.adb | 18 +- gcc/ada/sem_util.adb | 62 +- gcc/ada/sem_util.ads | 12 + gcc/ada/snames.ads | 5 + 5 files changed, 3442 insertions(+), 2934 deletions(-) diff --git a/gcc/ada/exp_dist.adb b/gcc/ada/exp_dist.adb index ece8106..cb00cc5 100644 --- a/gcc/ada/exp_dist.adb +++ b/gcc/ada/exp_dist.adb @@ -48,7 +48,6 @@ with Stand; use Stand; with Stringt; use Stringt; with Tbuild; use Tbuild; with Uintp; use Uintp; -with Uname; use Uname; package body Exp_Dist is @@ -81,16 +80,88 @@ package body Exp_Dist is -- an RCI package can thus identify calls received through remote -- access-to-subprogram dereferences by the fact that they have a -- (primitive) subprogram id of 0, and 1 is used for the internal - -- RAS information lookup operation. + -- RAS information lookup operation. (This is for the Garlic code + -- generation, where subprograms are identified by numbers; in the + -- PolyORB version, they are identified by name, with a numeric suffix + -- for homonyms.) + + type Hash_Index is range 0 .. 50; ----------------------- -- Local subprograms -- ----------------------- + function Hash (F : Entity_Id) return Hash_Index; + -- DSA expansion associates stubs to distributed object types using + -- a hash table on entity ids. + + function Hash (F : Name_Id) return Hash_Index; + -- The generation of subprogram identifiers requires an overload counter + -- to be associated with each remote subprogram names. These counters + -- are maintained in a hash table on name ids. + + type Subprogram_Identifiers is record + Str_Identifier : String_Id; + Int_Identifier : Int; + end record; + + package Subprogram_Identifier_Table is + new Simple_HTable (Header_Num => Hash_Index, + Element => Subprogram_Identifiers, + No_Element => (No_String, 0), + Key => Entity_Id, + Hash => Hash, + Equal => "="); + -- Mapping between a remote subprogram and the corresponding + -- subprogram identifiers. + + package Overload_Counter_Table is + new Simple_HTable (Header_Num => Hash_Index, + Element => Int, + No_Element => 0, + Key => Name_Id, + Hash => Hash, + Equal => "="); + -- Mapping between a subprogram name and an integer that + -- counts the number of defining subprogram names with that + -- Name_Id encountered so far in a given context (an interface). + + function Get_Subprogram_Ids (Def : Entity_Id) return Subprogram_Identifiers; + function Get_Subprogram_Id (Def : Entity_Id) return String_Id; + function Get_Subprogram_Id (Def : Entity_Id) return Int; + -- Given a subprogram defined in a RCI package, get its distribution + -- subprogram identifiers (the distribution identifiers are a unique + -- subprogram number, and the non-qualified subprogram name, in the + -- casing used for the subprogram declaration; if the name is overloaded, + -- a double underscore and a serial number are appended. + -- + -- The integer identifier is used to perform remote calls with GARLIC; + -- the string identifier is used in the case of PolyORB. + -- + -- Although the PolyORB DSA receiving stubs will make a caseless comparison + -- when receiving a call, the calling stubs will create requests with the + -- exact casing of the defining unit name of the called subprogram, so as + -- to allow calls to subprograms on distributed nodes that do distinguish + -- between casings. + -- + -- NOTE: Another design would be to allow a representation clause on + -- subprogram specs: for Subp'Distribution_Identifier use "fooBar"; + + pragma Warnings (Off, Get_Subprogram_Id); + -- One homonym only is unreferenced (specific to the GARLIC version) + + function Get_PCS_Name return PCS_Names; + -- Return the name of a literal of type + -- System.Partition_Interface.DSA_Implementation_Type + -- indicating what PCS is currently in use. + + procedure Add_RAS_Dereference_TSS (N : Node_Id); + -- Add a subprogram body for RAS Dereference TSS + procedure Add_RAS_Proxy_And_Analyze - (Decls : List_Id; - Vis_Decl : Node_Id; - All_Calls_Remote_E : Entity_Id; + (Decls : List_Id; + Vis_Decl : Node_Id; + All_Calls_Remote_E : Entity_Id; Proxy_Object_Addr : out Entity_Id); -- Add the proxy type necessary to call the subprogram declared -- by Vis_Decl through a remote access to subprogram type. @@ -107,18 +178,13 @@ package body Exp_Dist is -- ACR_Expression is use as the initialization value for -- the All_Calls_Remote component. - function Get_Subprogram_Id (E : Entity_Id) return Int; - -- Given a subprogram defined in a RCI package, get its subprogram id - -- which will be used for remote calls. - function Build_Get_Unique_RP_Call (Loc : Source_Ptr; Pointer : Entity_Id; Stub_Type : Entity_Id) return List_Id; - -- Build a call to Get_Unique_Remote_Pointer (Pointer), - -- followed by a tag fixup (Get_Unique_Remote_Pointer may have - -- changed Pointer'Tag to RACW_Stub_Type'Tag, while the desired - -- tag is that of Stub_Type). + -- Build a call to Get_Unique_Remote_Pointer (Pointer), followed by a + -- tag fixup (Get_Unique_Remote_Pointer may have changed Pointer'Tag to + -- RACW_Stub_Type'Tag, while the desired tag is that of Stub_Type). procedure Build_General_Calling_Stubs (Decls : List_Id; @@ -156,7 +222,7 @@ package body Exp_Dist is function Build_Subprogram_Calling_Stubs (Vis_Decl : Node_Id; - Subp_Id : Int; + Subp_Id : Node_Id; Asynchronous : Boolean; Dynamically_Asynchronous : Boolean := False; Stub_Type : Entity_Id := Empty; @@ -195,6 +261,21 @@ package body Exp_Dist is -- Make a subprogram specification for an RPC receiver, -- with the given defining unit name and formal parameters. + procedure Build_RPC_Receiver_Body + (RPC_Receiver : Entity_Id; + Stream : out Entity_Id; + Result : out Entity_Id; + Subp_Id : out Entity_Id; + Stmts : out List_Id; + Decl : out Node_Id); + -- Make a subprogram body for an RPC receiver, with the given + -- defining unit name. On return: + -- - Subp_Id is the Standard.String variable that contains + -- the identifier of the desired subprogram, + -- - Stmts is the place where the request dispatching + -- statements can occur, + -- - Decl is the subprogram body declaration. + function Build_Ordered_Parameters_List (Spec : Node_Id) return List_Id; -- Return an ordered parameter list: unconstrained parameters are put -- at the beginning of the list and constrained ones are put after. If @@ -212,20 +293,10 @@ package body Exp_Dist is Decls : List_Id); -- Add receiving stubs to the declarative part - procedure Add_RAS_Dereference_TSS (N : Node_Id); - -- Add a subprogram body for RAS Dereference TSS - - procedure Add_RAS_Access_TSS (N : Node_Id); - -- Add a subprogram body for RAS Access TSS - function Could_Be_Asynchronous (Spec : Node_Id) return Boolean; -- Return True if nothing prevents the program whose specification is -- given to be asynchronous (i.e. no out parameter). - procedure Get_Pkg_Name_String (Decl_Node : Node_Id); - -- Retrieve the fully expanded name of the library unit declared by decl - -- into the name buffer. - function Pack_Entity_Into_Stream_Access (Loc : Source_Ptr; Stream : Node_Id; @@ -253,6 +324,18 @@ package body Exp_Dist is function Scope_Of_Spec (Spec : Node_Id) return Entity_Id; -- Return the scope represented by a given spec + procedure Set_Renaming_TSS + (Typ : Entity_Id; + Nam : Entity_Id; + TSS_Nam : Name_Id); + -- Create a renaming declaration of subprogram Nam, + -- and register it as a TSS for Typ with name TSS_Nam. + + pragma Warnings (Off); + pragma Unreferenced (Set_Renaming_TSS); + -- This subprogram is for the PolyORB implementation + pragma Warnings (On); + function Need_Extra_Constrained (Parameter : Node_Id) return Boolean; -- Return True if the current parameter needs an extra formal to reflect -- its constrained status. @@ -265,9 +348,7 @@ package body Exp_Dist is type Stub_Structure is record Stub_Type : Entity_Id; Stub_Type_Access : Entity_Id; - Object_RPC_Receiver : Entity_Id; - RPC_Receiver_Stream : Entity_Id; - RPC_Receiver_Result : Entity_Id; + RPC_Receiver_Decl : Node_Id; RACW_Type : Entity_Id; end record; -- This structure is necessary because of the two phases analysis of @@ -275,12 +356,13 @@ package body Exp_Dist is -- designated type. RACW_Type is any of the RACW types pointing on this -- designated type, it is used here to save an anonymous type creation -- for each primitive operation. + -- + -- For a RACW that implements a RAS, no object RPC receiver is generated. + -- Instead, RPC_Receiver_Decl is the declaration after which the + -- RPC receiver would have been inserted. Empty_Stub_Structure : constant Stub_Structure := - (Empty, Empty, Empty, Empty, Empty, Empty); - - type Hash_Index is range 0 .. 50; - function Hash (F : Entity_Id) return Hash_Index; + (Empty, Empty, Empty, Empty); package Stubs_Table is new Simple_HTable (Header_Num => Hash_Index, @@ -326,7 +408,7 @@ package body Exp_Dist is Decls : List_Id; Stub_Type : out Entity_Id; Stub_Type_Access : out Entity_Id; - Object_RPC_Receiver : out Entity_Id; + RPC_Receiver_Decl : out Node_Id; Existing : out Boolean); -- Add the declaration of the stub type, the access to stub type and the -- object RPC receiver at the end of Decls. If these already exist, @@ -339,33 +421,14 @@ package body Exp_Dist is -- Declare a boolean constant associated with RACW_Type whose value -- indicates at run time whether a pragma Asynchronous applies to it. - procedure Add_RACW_Read_Attribute - (RACW_Type : Entity_Id; - Stub_Type : Entity_Id; - Stub_Type_Access : Entity_Id; - Declarations : List_Id); - -- Add Read attribute in Decls for the RACW type. The Read attribute - -- is added right after the RACW_Type declaration while the body is - -- inserted after Declarations. - - procedure Add_RACW_Write_Attribute - (RACW_Type : Entity_Id; - Stub_Type : Entity_Id; - Stub_Type_Access : Entity_Id; - Object_RPC_Receiver : Entity_Id; - Declarations : List_Id); - -- Same thing for the Write attribute - - procedure Add_RACW_Read_Write_Attributes - (RACW_Type : Entity_Id; - Stub_Type : Entity_Id; - Stub_Type_Access : Entity_Id; - Object_RPC_Receiver : Entity_Id; - Declarations : List_Id); - -- Add Read and Write attributes declarations and bodies for a given - -- RACW type. The declarations are added just after the declaration - -- of the RACW type itself, while the bodies are inserted at the end - -- of Decls. + procedure Assign_Subprogram_Identifier + (Def : Entity_Id; + Spn : Int; + Id : out String_Id); + -- Determine the distribution subprogram identifier to + -- be used for remote subprogram Def, return it in Id and + -- store it in a hash table for later retrieval by + -- Get_Subprogram_Id. Spn is the subprogram number. function RCI_Package_Locator (Loc : Source_Ptr; @@ -397,11 +460,80 @@ package body Exp_Dist is -- Exception_Message (E)); -- end R; + -------------------------------------------- + -- Hooks for PCS-specific code generation -- + -------------------------------------------- + + -- Part of the code generation circuitry for distribution needs to be + -- tailored for each implementation of the PCS. For each routine that + -- needs to be specialized, a Specific_ wrapper is created, + -- which calls the corresponding in package + -- _Support. + + procedure Specific_Add_RACW_Features + (RACW_Type : Entity_Id; + Desig : Entity_Id; + Stub_Type : Entity_Id; + Stub_Type_Access : Entity_Id; + RPC_Receiver_Decl : Node_Id; + Declarations : List_Id); + -- Add declaration for TSSs for a given RACW type. The declarations are + -- added just after the declaration of the RACW type itself, while the + -- bodies are inserted at the end of Decls. Runtime-specific ancillary + -- subprogram for Add_RACW_Features. + + procedure Specific_Add_RAST_Features + (Vis_Decl : Node_Id; + RAS_Type : Entity_Id; + Decls : List_Id); + -- Add declaration for TSSs for a given RAS type. The declarations are + -- added just after the declaration of the RAS type itself, while the + -- bodies are inserted at the end of Decls. PCS-specific ancillary + -- subprogram for Add_RAST_Features. + + package GARLIC_Support is + + -- Support for generating DSA code that uses the GARLIC PCS + + procedure Add_RACW_Features + (RACW_Type : Entity_Id; + Stub_Type : Entity_Id; + Stub_Type_Access : Entity_Id; + RPC_Receiver_Decl : Node_Id; + Declarations : List_Id); + + procedure Add_RAST_Features + (Vis_Decl : Node_Id; + RAS_Type : Entity_Id; + Decls : List_Id); + + end GARLIC_Support; + + package PolyORB_Support is + + -- Support for generating DSA code that uses the PolyORB PCS + + procedure Add_RACW_Features + (RACW_Type : Entity_Id; + Desig : Entity_Id; + Stub_Type : Entity_Id; + Stub_Type_Access : Entity_Id; + RPC_Receiver_Decl : Node_Id; + Declarations : List_Id); + + procedure Add_RAST_Features + (Vis_Decl : Node_Id; + RAS_Type : Entity_Id; + Decls : List_Id); + + end PolyORB_Support; + ------------------------------------ -- Local variables and structures -- ------------------------------------ RCI_Cache : Node_Id; + -- Needs comments ??? Output_From_Constrained : constant array (Boolean) of Name_Id := (False => Name_Output, @@ -427,10 +559,11 @@ package body Exp_Dist is Loc : constant Source_Ptr := Sloc (Pkg_Spec); RCI_Instantiation : Node_Id; Subp_Stubs : Node_Id; + Subp_Str : String_Id; begin -- The first thing added is an instantiation of the generic package - -- System.Partition_interface.RCI_Locator with the name of this + -- System.Partition_Interface.RCI_Locator with the name of this -- remote package. This will act as an interface with the name server -- to determine the Partition_ID and the RPC_Receiver for the -- receiver of this package. @@ -447,19 +580,25 @@ package body Exp_Dist is -- do use the same mechanism and will thus assign the same Id and -- do the correct dispatching. + Overload_Counter_Table.Reset; + Current_Declaration := First (Visible_Declarations (Pkg_Spec)); - while Current_Declaration /= Empty loop + + while Present (Current_Declaration) loop if Nkind (Current_Declaration) = N_Subprogram_Declaration and then Comes_From_Source (Current_Declaration) then - pragma Assert (Current_Subprogram_Number = - Get_Subprogram_Id (Defining_Unit_Name (Specification ( - Current_Declaration)))); + Assign_Subprogram_Identifier ( + Defining_Unit_Name (Specification (Current_Declaration)), + Current_Subprogram_Number, + Subp_Str); Subp_Stubs := Build_Subprogram_Calling_Stubs ( Vis_Decl => Current_Declaration, - Subp_Id => Current_Subprogram_Number, + Subp_Id => + Build_Subprogram_Id (Loc, + Defining_Unit_Name (Specification (Current_Declaration))), Asynchronous => Nkind (Specification (Current_Declaration)) = N_Procedure_Specification @@ -521,7 +660,7 @@ package body Exp_Dist is Stub_Type : Entity_Id; Stub_Type_Access : Entity_Id; - Object_RPC_Receiver : Entity_Id; + RPC_Receiver_Decl : Node_Id; Existing : Boolean; begin @@ -559,18 +698,19 @@ package body Exp_Dist is Decls => Decls, Stub_Type => Stub_Type, Stub_Type_Access => Stub_Type_Access, - Object_RPC_Receiver => Object_RPC_Receiver, + RPC_Receiver_Decl => RPC_Receiver_Decl, Existing => Existing); Add_RACW_Asynchronous_Flag (Declarations => Decls, RACW_Type => RACW_Type); - Add_RACW_Read_Write_Attributes + Specific_Add_RACW_Features (RACW_Type => RACW_Type, + Desig => Desig, Stub_Type => Stub_Type, Stub_Type_Access => Stub_Type_Access, - Object_RPC_Receiver => Object_RPC_Receiver, + RPC_Receiver_Decl => RPC_Receiver_Decl, Declarations => Decls); if not Same_Scope and then not Existing then @@ -581,8 +721,7 @@ package body Exp_Dist is Add_RACW_Primitive_Declarations_And_Bodies (Designated_Type => Desig, - Insertion_Node => - Parent (Declaration_Node (Object_RPC_Receiver)), + Insertion_Node => RPC_Receiver_Decl, Decls => Decls); else @@ -608,14 +747,20 @@ package body Exp_Dist is Stubs_Table.Get (Designated_Type); pragma Assert (Stub_Elements /= Empty_Stub_Structure); + Is_RAS : constant Boolean := + not Comes_From_Source (Stub_Elements.RACW_Type); Current_Insertion_Node : Node_Id := Insertion_Node; - RPC_Receiver_Declarations : List_Id; + RPC_Receiver : Entity_Id; RPC_Receiver_Statements : List_Id; RPC_Receiver_Case_Alternatives : constant List_Id := New_List; + RPC_Receiver_Stream : Entity_Id; + RPC_Receiver_Result : Entity_Id; RPC_Receiver_Subp_Id : Entity_Id; + Subp_Str : String_Id; + Current_Primitive_Elmt : Elmt_Id; Current_Primitive : Entity_Id; Current_Primitive_Body : Node_Id; @@ -637,11 +782,25 @@ package body Exp_Dist is return; end if; + if not Is_RAS then + RPC_Receiver := Make_Defining_Identifier (Loc, + New_Internal_Name ('P')); + Build_RPC_Receiver_Body ( + RPC_Receiver => RPC_Receiver, + Stream => RPC_Receiver_Stream, + Result => RPC_Receiver_Result, + Subp_Id => RPC_Receiver_Subp_Id, + Stmts => RPC_Receiver_Statements, + Decl => RPC_Receiver_Decl); + end if; + -- Build callers, receivers for every primitive operations and a RPC -- receiver for this type. if Present (Primitive_Operations (Designated_Type)) then + Overload_Counter_Table.Reset; + Current_Primitive_Elmt := First_Elmt (Primitive_Operations (Designated_Type)); while Current_Primitive_Elmt /= No_Elmt loop @@ -686,10 +845,17 @@ package body Exp_Dist is Nkind (Current_Primitive_Spec) = N_Procedure_Specification and then Could_Be_Asynchronous (Current_Primitive_Spec); + Assign_Subprogram_Identifier ( + Defining_Unit_Name (Current_Primitive_Spec), + Current_Primitive_Number, + Subp_Str); + Current_Primitive_Body := Build_Subprogram_Calling_Stubs (Vis_Decl => Current_Primitive_Decl, - Subp_Id => Current_Primitive_Number, + Subp_Id => + Build_Subprogram_Id (Loc, + Defining_Unit_Name (Current_Primitive_Spec)), Asynchronous => Possibly_Asynchronous, Dynamically_Asynchronous => Possibly_Asynchronous, Stub_Type => Stub_Elements.Stub_Type); @@ -702,36 +868,36 @@ package body Exp_Dist is -- Build the receiver stubs - Current_Receiver_Body := - Build_Subprogram_Receiving_Stubs - (Vis_Decl => Current_Primitive_Decl, - Asynchronous => Possibly_Asynchronous, - Dynamically_Asynchronous => Possibly_Asynchronous, - Stub_Type => Stub_Elements.Stub_Type, - RACW_Type => Stub_Elements.RACW_Type, - Parent_Primitive => Current_Primitive); - - Current_Receiver := - Defining_Unit_Name (Specification (Current_Receiver_Body)); - - Append_To (Decls, Current_Receiver_Body); - - -- Add a case alternative to the receiver - - Append_To (RPC_Receiver_Case_Alternatives, - Make_Case_Statement_Alternative (Loc, - Discrete_Choices => New_List ( - Make_Integer_Literal (Loc, Current_Primitive_Number)), - - Statements => New_List ( - Make_Procedure_Call_Statement (Loc, - Name => - New_Occurrence_Of (Current_Receiver, Loc), - Parameter_Associations => New_List ( - New_Occurrence_Of - (Stub_Elements.RPC_Receiver_Stream, Loc), - New_Occurrence_Of - (Stub_Elements.RPC_Receiver_Result, Loc)))))); + if not Is_RAS then + Current_Receiver_Body := + Build_Subprogram_Receiving_Stubs + (Vis_Decl => Current_Primitive_Decl, + Asynchronous => Possibly_Asynchronous, + Dynamically_Asynchronous => Possibly_Asynchronous, + Stub_Type => Stub_Elements.Stub_Type, + RACW_Type => Stub_Elements.RACW_Type, + Parent_Primitive => Current_Primitive); + + Current_Receiver := Defining_Unit_Name ( + Specification (Current_Receiver_Body)); + + Append_To (Decls, Current_Receiver_Body); + + -- Add a case alternative to the receiver + + Append_To (RPC_Receiver_Case_Alternatives, + Make_Case_Statement_Alternative (Loc, + Discrete_Choices => New_List ( + Make_Integer_Literal (Loc, Current_Primitive_Number)), + + Statements => New_List ( + Make_Procedure_Call_Statement (Loc, + Name => + New_Occurrence_Of (Current_Receiver, Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of (RPC_Receiver_Stream, Loc), + New_Occurrence_Of (RPC_Receiver_Result, Loc)))))); + end if; -- Increment the index of current primitive @@ -744,47 +910,34 @@ package body Exp_Dist is -- Build the case statement and the heart of the subprogram - Append_To (RPC_Receiver_Case_Alternatives, - Make_Case_Statement_Alternative (Loc, - Discrete_Choices => New_List (Make_Others_Choice (Loc)), - Statements => New_List (Make_Null_Statement (Loc)))); - - RPC_Receiver_Subp_Id := - Make_Defining_Identifier (Loc, New_Internal_Name ('S')); - - RPC_Receiver_Declarations := New_List ( - Make_Object_Declaration (Loc, - Defining_Identifier => RPC_Receiver_Subp_Id, - Object_Definition => - New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc))); - - RPC_Receiver_Statements := New_List ( - Make_Attribute_Reference (Loc, - Prefix => - New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc), - Attribute_Name => - Name_Read, - Expressions => New_List ( - New_Occurrence_Of (Stub_Elements.RPC_Receiver_Stream, Loc), - New_Occurrence_Of (RPC_Receiver_Subp_Id, Loc)))); - - Append_To (RPC_Receiver_Statements, - Make_Case_Statement (Loc, - Expression => - New_Occurrence_Of (RPC_Receiver_Subp_Id, Loc), - Alternatives => RPC_Receiver_Case_Alternatives)); - - RPC_Receiver_Decl := - Make_Subprogram_Body (Loc, - Specification => - Copy_Specification (Loc, - Parent (Stub_Elements.Object_RPC_Receiver)), - Declarations => RPC_Receiver_Declarations, - Handled_Statement_Sequence => - Make_Handled_Sequence_Of_Statements (Loc, - Statements => RPC_Receiver_Statements)); - - Append_To (Decls, RPC_Receiver_Decl); + if not Is_RAS then + Append_To (RPC_Receiver_Case_Alternatives, + Make_Case_Statement_Alternative (Loc, + Discrete_Choices => New_List (Make_Others_Choice (Loc)), + Statements => New_List (Make_Null_Statement (Loc)))); + + Append_To (RPC_Receiver_Statements, + Make_Case_Statement (Loc, + Expression => + New_Occurrence_Of (RPC_Receiver_Subp_Id, Loc), + Alternatives => RPC_Receiver_Case_Alternatives)); + + -- The RPC receiver body should not be the completion of the + -- declaration recorded in the stub structure, because then the + -- occurrences of the formal parameters within the body should + -- refer to the entities from the declaration, not from the + -- completion, to which we do not have easy access. Instead, the + -- RPC receiver body acts as its own declaration, and the RPC + -- receiver declaration is completed by a renaming-as-body. + + Append_To (Decls, RPC_Receiver_Decl); + Append_To (Decls, + Make_Subprogram_Renaming_Declaration (Loc, + Specification => + Copy_Specification (Loc, + Specification (Stub_Elements.RPC_Receiver_Decl)), + Name => New_Occurrence_Of (RPC_Receiver, Loc))); + end if; -- Do not analyze RPC receiver at this stage since it will otherwise -- reference subprograms that have not been analyzed yet. It will @@ -793,3345 +946,3501 @@ package body Exp_Dist is end Add_RACW_Primitive_Declarations_And_Bodies; ----------------------------- - -- Add_RACW_Read_Attribute -- + -- Add_RAS_Dereference_TSS -- ----------------------------- - procedure Add_RACW_Read_Attribute - (RACW_Type : Entity_Id; - Stub_Type : Entity_Id; - Stub_Type_Access : Entity_Id; - Declarations : List_Id) - is - Loc : constant Source_Ptr := Sloc (RACW_Type); - - Proc_Decl : Node_Id; - Attr_Decl : Node_Id; + procedure Add_RAS_Dereference_TSS (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); - Body_Node : Node_Id; + Type_Def : constant Node_Id := Type_Definition (N); - Decls : List_Id; - Statements : List_Id; - Local_Statements : List_Id; - Remote_Statements : List_Id; - -- Various parts of the procedure - - Procedure_Name : constant Name_Id := - New_Internal_Name ('R'); - Source_Partition : constant Entity_Id := - Make_Defining_Identifier - (Loc, New_Internal_Name ('P')); - Source_Receiver : constant Entity_Id := - Make_Defining_Identifier - (Loc, New_Internal_Name ('S')); - Source_Address : constant Entity_Id := - Make_Defining_Identifier - (Loc, New_Internal_Name ('P')); - Local_Stub : constant Entity_Id := - Make_Defining_Identifier - (Loc, New_Internal_Name ('L')); - Stubbed_Result : constant Entity_Id := - Make_Defining_Identifier - (Loc, New_Internal_Name ('S')); - Asynchronous_Flag : constant Entity_Id := - Asynchronous_Flags_Table.Get (RACW_Type); - pragma Assert (Present (Asynchronous_Flag)); + RAS_Type : constant Entity_Id := Defining_Identifier (N); + Fat_Type : constant Entity_Id := Equivalent_Type (RAS_Type); + RACW_Type : constant Entity_Id := Underlying_RACW_Type (RAS_Type); + Desig : constant Entity_Id := Etype (Designated_Type (RACW_Type)); - function Stream_Parameter return Node_Id; - function Result return Node_Id; - -- Functions to create occurrences of the formal parameter names + Stub_Elements : constant Stub_Structure := Stubs_Table.Get (Desig); + pragma Assert (Stub_Elements /= Empty_Stub_Structure); - ------------ - -- Result -- - ------------ + RACW_Primitive_Name : Node_Id; - function Result return Node_Id is - begin - return Make_Identifier (Loc, Name_V); - end Result; + Proc : constant Entity_Id := + Make_Defining_Identifier (Loc, + Chars => Make_TSS_Name (RAS_Type, TSS_RAS_Dereference)); - ---------------------- - -- Stream_Parameter -- - ---------------------- + Proc_Spec : Node_Id; + Param_Specs : List_Id; + Param_Assoc : constant List_Id := New_List; + Stmts : constant List_Id := New_List; - function Stream_Parameter return Node_Id is - begin - return Make_Identifier (Loc, Name_S); - end Stream_Parameter; + RAS_Parameter : constant Entity_Id := + Make_Defining_Identifier (Loc, + Chars => New_Internal_Name ('P')); - -- Start of processing for Add_RACW_Read_Attribute + Is_Function : constant Boolean := + Nkind (Type_Def) = N_Access_Function_Definition; - begin - -- Generate object declarations + Is_Degenerate : Boolean; + -- Set to True if the subprogram_specification for this RAS has + -- an anonymous access parameter (see Process_Remote_AST_Declaration). - Decls := New_List ( - Make_Object_Declaration (Loc, - Defining_Identifier => Source_Partition, - Object_Definition => - New_Occurrence_Of (RTE (RE_Partition_ID), Loc)), + Spec : constant Node_Id := Type_Def; - Make_Object_Declaration (Loc, - Defining_Identifier => Source_Receiver, - Object_Definition => - New_Occurrence_Of (RTE (RE_Unsigned_64), Loc)), + Current_Parameter : Node_Id; - Make_Object_Declaration (Loc, - Defining_Identifier => Source_Address, - Object_Definition => - New_Occurrence_Of (RTE (RE_Unsigned_64), Loc)), + -- Start of processing for Add_RAS_Dereference_TSS - Make_Object_Declaration (Loc, - Defining_Identifier => Local_Stub, - Aliased_Present => True, - Object_Definition => New_Occurrence_Of (Stub_Type, Loc)), + begin - Make_Object_Declaration (Loc, - Defining_Identifier => Stubbed_Result, - Object_Definition => - New_Occurrence_Of (Stub_Type_Access, Loc), - Expression => - Make_Attribute_Reference (Loc, - Prefix => - New_Occurrence_Of (Local_Stub, Loc), - Attribute_Name => - Name_Unchecked_Access))); + -- The Dereference TSS for a remote access-to-subprogram type + -- has the form: + -- [function|procedure] ras_typeRD (RAS_Value, ) + -- [return <>] + -- and is called whenever a value of a RAS type is dereferenced. - -- Read the source Partition_ID and RPC_Receiver from incoming stream + -- First construct a list of parameter specifications: - Statements := New_List ( - Make_Attribute_Reference (Loc, - Prefix => - New_Occurrence_Of (RTE (RE_Partition_ID), Loc), - Attribute_Name => Name_Read, - Expressions => New_List ( - Stream_Parameter, - New_Occurrence_Of (Source_Partition, Loc))), + -- The first formal is the RAS values - Make_Attribute_Reference (Loc, - Prefix => - New_Occurrence_Of (RTE (RE_Unsigned_64), Loc), - Attribute_Name => - Name_Read, - Expressions => New_List ( - Stream_Parameter, - New_Occurrence_Of (Source_Receiver, Loc))), + Param_Specs := New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => RAS_Parameter, + In_Present => True, + Parameter_Type => + New_Occurrence_Of (Fat_Type, Loc))); - Make_Attribute_Reference (Loc, - Prefix => - New_Occurrence_Of (RTE (RE_Unsigned_64), Loc), - Attribute_Name => - Name_Read, - Expressions => New_List ( - Stream_Parameter, - New_Occurrence_Of (Source_Address, Loc)))); + -- The following formals are copied from the type declaration - -- Build_Get_Unique_RP_Call needs the type of Stubbed_Result + Is_Degenerate := False; + Current_Parameter := First (Parameter_Specifications (Type_Def)); + Parameters : while Present (Current_Parameter) loop + if Nkind (Parameter_Type (Current_Parameter)) + = N_Access_Definition + then + Is_Degenerate := True; + end if; + Append_To (Param_Specs, + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, + Chars => Chars (Defining_Identifier (Current_Parameter))), + In_Present => In_Present (Current_Parameter), + Out_Present => Out_Present (Current_Parameter), + Parameter_Type => + New_Copy_Tree (Parameter_Type (Current_Parameter)), + Expression => + New_Copy_Tree (Expression (Current_Parameter)))); - Set_Etype (Stubbed_Result, Stub_Type_Access); + Append_To (Param_Assoc, + Make_Identifier (Loc, + Chars => Chars (Defining_Identifier (Current_Parameter)))); - -- If the Address is Null_Address, then return a null object + Next (Current_Parameter); + end loop Parameters; - Append_To (Statements, - Make_Implicit_If_Statement (RACW_Type, - Condition => - Make_Op_Eq (Loc, - Left_Opnd => New_Occurrence_Of (Source_Address, Loc), - Right_Opnd => Make_Integer_Literal (Loc, Uint_0)), - Then_Statements => New_List ( - Make_Assignment_Statement (Loc, - Name => Result, - Expression => Make_Null (Loc)), - Make_Return_Statement (Loc)))); + if Is_Degenerate then + Prepend_To (Param_Assoc, New_Occurrence_Of (RAS_Parameter, Loc)); - -- If the RACW denotes an object created on the current partition, then - -- Local_Statements will be executed. The real object will be used. + -- Generate a dummy body. This code will never actually be executed, + -- because null is the only legal value for a degenerate RAS type. + -- For legality's sake (in order to avoid generating a function + -- that does not contain a return statement), we include a dummy + -- recursive call on the TSS itself. - Local_Statements := New_List ( - Make_Assignment_Statement (Loc, - Name => Result, - Expression => - Unchecked_Convert_To (RACW_Type, - OK_Convert_To (RTE (RE_Address), - New_Occurrence_Of (Source_Address, Loc))))); + Append_To (Stmts, + Make_Raise_Program_Error (Loc, Reason => PE_Explicit_Raise)); + RACW_Primitive_Name := New_Occurrence_Of (Proc, Loc); - -- If the object is located on another partition, then a stub object - -- will be created with all the information needed to rebuild the - -- real object at the other end. + else + -- For a normal RAS type, we cast the RAS formal to the corresponding + -- tagged type, and perform a dispatching call to its Call + -- primitive operation. - Remote_Statements := New_List ( + Prepend_To (Param_Assoc, + Unchecked_Convert_To (RACW_Type, + New_Occurrence_Of (RAS_Parameter, Loc))); - Make_Assignment_Statement (Loc, - Name => Make_Selected_Component (Loc, - Prefix => New_Occurrence_Of (Stubbed_Result, Loc), - Selector_Name => Make_Identifier (Loc, Name_Origin)), - Expression => - New_Occurrence_Of (Source_Partition, Loc)), + RACW_Primitive_Name := + Make_Selected_Component (Loc, + Prefix => + New_Occurrence_Of (Scope (RACW_Type), Loc), + Selector_Name => + Make_Identifier (Loc, Name_Call)); + end if; - Make_Assignment_Statement (Loc, - Name => Make_Selected_Component (Loc, - Prefix => New_Occurrence_Of (Stubbed_Result, Loc), - Selector_Name => Make_Identifier (Loc, Name_Receiver)), - Expression => - New_Occurrence_Of (Source_Receiver, Loc)), + if Is_Function then + Append_To (Stmts, + Make_Return_Statement (Loc, + Expression => + Make_Function_Call (Loc, + Name => + RACW_Primitive_Name, + Parameter_Associations => Param_Assoc))); - Make_Assignment_Statement (Loc, - Name => Make_Selected_Component (Loc, - Prefix => New_Occurrence_Of (Stubbed_Result, Loc), - Selector_Name => Make_Identifier (Loc, Name_Addr)), - Expression => - New_Occurrence_Of (Source_Address, Loc))); + else + Append_To (Stmts, + Make_Procedure_Call_Statement (Loc, + Name => + RACW_Primitive_Name, + Parameter_Associations => Param_Assoc)); + end if; - Append_To (Remote_Statements, - Make_Assignment_Statement (Loc, - Name => Make_Selected_Component (Loc, - Prefix => New_Occurrence_Of (Stubbed_Result, Loc), - Selector_Name => Make_Identifier (Loc, Name_Asynchronous)), - Expression => - New_Occurrence_Of (Asynchronous_Flag, Loc))); - - Append_List_To (Remote_Statements, - Build_Get_Unique_RP_Call (Loc, Stubbed_Result, Stub_Type)); - -- ??? Issue with asynchronous calls here: the Asynchronous - -- flag is set on the stub type if, and only if, the RACW type - -- has a pragma Asynchronous. This is incorrect for RACWs that - -- implement RAS types, because in that case the /designated - -- subprogram/ (not the type) might be asynchronous, and - -- that causes the stub to need to be asynchronous too. - -- A solution is to transport a RAS as a struct containing - -- a RACW and an asynchronous flag, and to properly alter - -- the Asynchronous component in the stub type in the RAS's - -- Input TSS. - - Append_To (Remote_Statements, - Make_Assignment_Statement (Loc, - Name => Result, - Expression => Unchecked_Convert_To (RACW_Type, - New_Occurrence_Of (Stubbed_Result, Loc)))); + -- Build the complete subprogram - -- Distinguish between the local and remote cases, and execute the - -- appropriate piece of code. + if Is_Function then + Proc_Spec := + Make_Function_Specification (Loc, + Defining_Unit_Name => Proc, + Parameter_Specifications => Param_Specs, + Subtype_Mark => + New_Occurrence_Of ( + Entity (Subtype_Mark (Spec)), Loc)); - Append_To (Statements, - Make_Implicit_If_Statement (RACW_Type, - Condition => - Make_Op_Eq (Loc, - Left_Opnd => - Make_Function_Call (Loc, - Name => - New_Occurrence_Of (RTE (RE_Get_Local_Partition_Id), Loc)), - Right_Opnd => New_Occurrence_Of (Source_Partition, Loc)), - Then_Statements => Local_Statements, - Else_Statements => Remote_Statements)); - - Build_Stream_Procedure - (Loc, RACW_Type, Body_Node, - Make_Defining_Identifier (Loc, Procedure_Name), - Statements, Outp => True); - Set_Declarations (Body_Node, Decls); - - Proc_Decl := Make_Subprogram_Declaration (Loc, - Copy_Specification (Loc, Specification (Body_Node))); - - Attr_Decl := - Make_Attribute_Definition_Clause (Loc, - Name => New_Occurrence_Of (RACW_Type, Loc), - Chars => Name_Read, - Expression => - New_Occurrence_Of ( - Defining_Unit_Name (Specification (Proc_Decl)), Loc)); + Set_Ekind (Proc, E_Function); + Set_Etype (Proc, + New_Occurrence_Of (Entity (Subtype_Mark (Spec)), Loc)); - Insert_After (Declaration_Node (RACW_Type), Proc_Decl); - Insert_After (Proc_Decl, Attr_Decl); - Append_To (Declarations, Body_Node); - end Add_RACW_Read_Attribute; + else + Proc_Spec := + Make_Procedure_Specification (Loc, + Defining_Unit_Name => Proc, + Parameter_Specifications => Param_Specs); - ------------------------------------ - -- Add_RACW_Read_Write_Attributes -- - ------------------------------------ + Set_Ekind (Proc, E_Procedure); + Set_Etype (Proc, Standard_Void_Type); + end if; - procedure Add_RACW_Read_Write_Attributes - (RACW_Type : Entity_Id; - Stub_Type : Entity_Id; - Stub_Type_Access : Entity_Id; - Object_RPC_Receiver : Entity_Id; - Declarations : List_Id) - is - begin - Add_RACW_Write_Attribute - (RACW_Type => RACW_Type, - Stub_Type => Stub_Type, - Stub_Type_Access => Stub_Type_Access, - Object_RPC_Receiver => Object_RPC_Receiver, - Declarations => Declarations); + Discard_Node ( + Make_Subprogram_Body (Loc, + Specification => Proc_Spec, + Declarations => New_List, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Stmts))); - Add_RACW_Read_Attribute - (RACW_Type => RACW_Type, - Stub_Type => Stub_Type, - Stub_Type_Access => Stub_Type_Access, - Declarations => Declarations); - end Add_RACW_Read_Write_Attributes; + Set_TSS (Fat_Type, Proc); + end Add_RAS_Dereference_TSS; - ------------------------------ - -- Add_RACW_Write_Attribute -- - ------------------------------ + ------------------------------- + -- Add_RAS_Proxy_And_Analyze -- + ------------------------------- - procedure Add_RACW_Write_Attribute - (RACW_Type : Entity_Id; - Stub_Type : Entity_Id; - Stub_Type_Access : Entity_Id; - Object_RPC_Receiver : Entity_Id; - Declarations : List_Id) + procedure Add_RAS_Proxy_And_Analyze + (Decls : List_Id; + Vis_Decl : Node_Id; + All_Calls_Remote_E : Entity_Id; + Proxy_Object_Addr : out Entity_Id) is - Loc : constant Source_Ptr := Sloc (RACW_Type); - - Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type); - - Body_Node : Node_Id; - Proc_Decl : Node_Id; - Attr_Decl : Node_Id; + Loc : constant Source_Ptr := Sloc (Vis_Decl); - RPC_Receiver : Node_Id; + Subp_Name : constant Entity_Id := + Defining_Unit_Name (Specification (Vis_Decl)); - Statements : List_Id; - Local_Statements : List_Id; - Remote_Statements : List_Id; - Null_Statements : List_Id; + Pkg_Name : constant Entity_Id := + Make_Defining_Identifier (Loc, + Chars => + New_External_Name (Chars (Subp_Name), 'P', -1)); - Procedure_Name : constant Name_Id := New_Internal_Name ('R'); + Proxy_Type : constant Entity_Id := + Make_Defining_Identifier (Loc, + Chars => + New_External_Name ( + Related_Id => Chars (Subp_Name), + Suffix => 'P')); - -- Functions to create occurrences of the formal - -- parameter names. + Proxy_Type_Full_View : constant Entity_Id := + Make_Defining_Identifier (Loc, + Chars (Proxy_Type)); - function Stream_Parameter return Node_Id; - function Object return Node_Id; + Subp_Decl_Spec : constant Node_Id := + Build_RAS_Primitive_Specification + (Subp_Spec => Specification (Vis_Decl), + Remote_Object_Type => Proxy_Type); - function Stream_Parameter return Node_Id is - begin - return Make_Identifier (Loc, Name_S); - end Stream_Parameter; + Subp_Body_Spec : constant Node_Id := + Build_RAS_Primitive_Specification + (Subp_Spec => Specification (Vis_Decl), + Remote_Object_Type => Proxy_Type); - function Object return Node_Id is - begin - return Make_Identifier (Loc, Name_V); - end Object; + Vis_Decls : constant List_Id := New_List; + Pvt_Decls : constant List_Id := New_List; + Actuals : constant List_Id := New_List; + Formal : Node_Id; + Perform_Call : Node_Id; begin - -- Build the code fragment corresponding to the marshalling of a - -- local object. + -- type subpP is tagged limited private; + + Append_To (Vis_Decls, + Make_Private_Type_Declaration (Loc, + Defining_Identifier => Proxy_Type, + Tagged_Present => True, + Limited_Present => True)); - if Is_RAS then + -- [subprogram] Call + -- (Self : access subpP; + -- ...other-formals...) + -- [return T]; - -- For a RAS, the RPC receiver is that of the RCI unit, - -- not that of the corresponding distributed object type. - -- We retrieve its address from the local proxy object. + Append_To (Vis_Decls, + Make_Subprogram_Declaration (Loc, + Specification => Subp_Decl_Spec)); - RPC_Receiver := Make_Selected_Component (Loc, - Prefix => - Unchecked_Convert_To (RTE (RE_RAS_Proxy_Type_Access), Object), - Selector_Name => - Make_Identifier (Loc, Name_Receiver)); + -- A : constant System.Address; - else - RPC_Receiver := Make_Attribute_Reference (Loc, - Prefix => - New_Occurrence_Of (Object_RPC_Receiver, Loc), - Attribute_Name => - Name_Address); - end if; + Proxy_Object_Addr := Make_Defining_Identifier (Loc, Name_uA); - Local_Statements := New_List ( + Append_To (Vis_Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => + Proxy_Object_Addr, + Constant_Present => + True, + Object_Definition => + New_Occurrence_Of (RTE (RE_Address), Loc))); - Pack_Entity_Into_Stream_Access (Loc, - Stream => Stream_Parameter, - Object => RTE (RE_Get_Local_Partition_Id)), + -- private - Pack_Node_Into_Stream_Access (Loc, - Stream => Stream_Parameter, - Object => OK_Convert_To (RTE (RE_Unsigned_64), RPC_Receiver), - Etyp => RTE (RE_Unsigned_64)), + -- type subpP is tagged limited record + -- All_Calls_Remote : Boolean := [All_Calls_Remote?]; + -- ... + -- end record; - Pack_Node_Into_Stream_Access (Loc, - Stream => Stream_Parameter, - Object => OK_Convert_To (RTE (RE_Unsigned_64), - Make_Attribute_Reference (Loc, - Prefix => - Make_Explicit_Dereference (Loc, - Prefix => Object), - Attribute_Name => Name_Address)), - Etyp => RTE (RE_Unsigned_64))); + Append_To (Pvt_Decls, + Make_Full_Type_Declaration (Loc, + Defining_Identifier => + Proxy_Type_Full_View, + Type_Definition => + Build_Remote_Subprogram_Proxy_Type (Loc, + New_Occurrence_Of (All_Calls_Remote_E, Loc)))); - -- Build the code fragment corresponding to the marshalling of - -- a remote object. + -- Trick semantic analysis into swapping the public and + -- full view when freezing the public view. - Remote_Statements := New_List ( + Set_Comes_From_Source (Proxy_Type_Full_View, True); - Pack_Node_Into_Stream_Access (Loc, - Stream => Stream_Parameter, - Object => - Make_Selected_Component (Loc, - Prefix => Unchecked_Convert_To (Stub_Type_Access, - Object), - Selector_Name => - Make_Identifier (Loc, Name_Origin)), - Etyp => RTE (RE_Partition_ID)), + -- procedure Call + -- (Self : access O; + -- ...other-formals...) is + -- begin + -- P (...other-formals...); + -- end Call; - Pack_Node_Into_Stream_Access (Loc, - Stream => Stream_Parameter, - Object => - Make_Selected_Component (Loc, - Prefix => Unchecked_Convert_To (Stub_Type_Access, - Object), - Selector_Name => - Make_Identifier (Loc, Name_Receiver)), - Etyp => RTE (RE_Unsigned_64)), + -- function Call + -- (Self : access O; + -- ...other-formals...) + -- return T is + -- begin + -- return F (...other-formals...); + -- end Call; - Pack_Node_Into_Stream_Access (Loc, - Stream => Stream_Parameter, - Object => - Make_Selected_Component (Loc, - Prefix => Unchecked_Convert_To (Stub_Type_Access, - Object), - Selector_Name => - Make_Identifier (Loc, Name_Addr)), - Etyp => RTE (RE_Unsigned_64))); + if Nkind (Subp_Decl_Spec) = N_Procedure_Specification then + Perform_Call := + Make_Procedure_Call_Statement (Loc, + Name => + New_Occurrence_Of (Subp_Name, Loc), + Parameter_Associations => + Actuals); + else + Perform_Call := + Make_Return_Statement (Loc, + Expression => + Make_Function_Call (Loc, + Name => + New_Occurrence_Of (Subp_Name, Loc), + Parameter_Associations => + Actuals)); + end if; - -- Build the code fragment corresponding to the marshalling of a null - -- object. + Formal := First (Parameter_Specifications (Subp_Decl_Spec)); + pragma Assert (Present (Formal)); + Next (Formal); - Null_Statements := New_List ( + while Present (Formal) loop + Append_To (Actuals, New_Occurrence_Of ( + Defining_Identifier (Formal), Loc)); + Next (Formal); + end loop; - Pack_Entity_Into_Stream_Access (Loc, - Stream => Stream_Parameter, - Object => RTE (RE_Get_Local_Partition_Id)), + -- O : aliased subpP; - Pack_Node_Into_Stream_Access (Loc, - Stream => Stream_Parameter, - Object => OK_Convert_To (RTE (RE_Unsigned_64), - Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (Object_RPC_Receiver, Loc), - Attribute_Name => Name_Address)), - Etyp => RTE (RE_Unsigned_64)), + Append_To (Pvt_Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, + Name_uO), + Aliased_Present => + True, + Object_Definition => + New_Occurrence_Of (Proxy_Type, Loc))); - Pack_Node_Into_Stream_Access (Loc, - Stream => Stream_Parameter, - Object => Make_Integer_Literal (Loc, Uint_0), - Etyp => RTE (RE_Unsigned_64))); + -- A : constant System.Address := O'Address; - Statements := New_List ( - Make_Implicit_If_Statement (RACW_Type, - Condition => - Make_Op_Eq (Loc, - Left_Opnd => Object, - Right_Opnd => Make_Null (Loc)), - Then_Statements => Null_Statements, - Elsif_Parts => New_List ( - Make_Elsif_Part (Loc, - Condition => - Make_Op_Eq (Loc, - Left_Opnd => - Make_Attribute_Reference (Loc, - Prefix => Object, - Attribute_Name => Name_Tag), - Right_Opnd => - Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (Stub_Type, Loc), - Attribute_Name => Name_Tag)), - Then_Statements => Remote_Statements)), - Else_Statements => Local_Statements)); - - Build_Stream_Procedure - (Loc, RACW_Type, Body_Node, - Make_Defining_Identifier (Loc, Procedure_Name), - Statements, Outp => False); - - Proc_Decl := Make_Subprogram_Declaration (Loc, - Copy_Specification (Loc, Specification (Body_Node))); - - Attr_Decl := - Make_Attribute_Definition_Clause (Loc, - Name => New_Occurrence_Of (RACW_Type, Loc), - Chars => Name_Write, + Append_To (Pvt_Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, + Chars (Proxy_Object_Addr)), + Constant_Present => + True, + Object_Definition => + New_Occurrence_Of (RTE (RE_Address), Loc), Expression => - New_Occurrence_Of ( - Defining_Unit_Name (Specification (Proc_Decl)), Loc)); + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of ( + Defining_Identifier (Last (Pvt_Decls)), Loc), + Attribute_Name => + Name_Address))); - Insert_After (Declaration_Node (RACW_Type), Proc_Decl); - Insert_After (Proc_Decl, Attr_Decl); - Append_To (Declarations, Body_Node); - end Add_RACW_Write_Attribute; + Append_To (Decls, + Make_Package_Declaration (Loc, + Specification => Make_Package_Specification (Loc, + Defining_Unit_Name => Pkg_Name, + Visible_Declarations => Vis_Decls, + Private_Declarations => Pvt_Decls, + End_Label => Empty))); + Analyze (Last (Decls)); - ------------------------ - -- Add_RAS_Access_TSS -- - ------------------------ + Append_To (Decls, + Make_Package_Body (Loc, + Defining_Unit_Name => + Make_Defining_Identifier (Loc, + Chars (Pkg_Name)), + Declarations => New_List ( + Make_Subprogram_Body (Loc, + Specification => + Subp_Body_Spec, + Declarations => New_List, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List (Perform_Call)))))); + Analyze (Last (Decls)); + end Add_RAS_Proxy_And_Analyze; - procedure Add_RAS_Access_TSS (N : Node_Id) is - Loc : constant Source_Ptr := Sloc (N); + ----------------------- + -- Add_RAST_Features -- + ----------------------- - Ras_Type : constant Entity_Id := Defining_Identifier (N); - Fat_Type : constant Entity_Id := Equivalent_Type (Ras_Type); - -- Ras_Type is the access to subprogram type while Fat_Type points to - -- the record type corresponding to a remote access to subprogram type. + procedure Add_RAST_Features (Vis_Decl : Node_Id) is + RAS_Type : constant Entity_Id := + Equivalent_Type (Defining_Identifier (Vis_Decl)); - RACW_Type : constant Entity_Id := - Underlying_RACW_Type (Ras_Type); - Desig : constant Entity_Id := - Etype (Designated_Type (RACW_Type)); + Spec : constant Node_Id := + Specification (Unit (Enclosing_Lib_Unit_Node (Vis_Decl))); + Decls : List_Id := Private_Declarations (Spec); - Stub_Elements : constant Stub_Structure := - Stubs_Table.Get (Desig); - pragma Assert (Stub_Elements /= Empty_Stub_Structure); + begin + pragma Assert (No (TSS (RAS_Type, TSS_RAS_Access))); - Proc : constant Entity_Id := - Make_Defining_Identifier (Loc, - Chars => Make_TSS_Name (Ras_Type, TSS_RAS_Access)); - Proc_Spec : Node_Id; + if No (Decls) then + Decls := Visible_Declarations (Spec); + end if; - -- Formal parameters + Add_RAS_Dereference_TSS (Vis_Decl); + Specific_Add_RAST_Features (Vis_Decl, RAS_Type, Decls); + end Add_RAST_Features; - Package_Name : constant Entity_Id := - Make_Defining_Identifier (Loc, - Chars => Name_P); - -- Target package + ----------------------------------------- + -- Add_Receiving_Stubs_To_Declarations -- + ----------------------------------------- - Subp_Id : constant Entity_Id := - Make_Defining_Identifier (Loc, - Chars => Name_S); - -- Target subprogram + procedure Add_Receiving_Stubs_To_Declarations + (Pkg_Spec : Node_Id; + Decls : List_Id) + is + Loc : constant Source_Ptr := Sloc (Pkg_Spec); - Asynch_P : constant Entity_Id := - Make_Defining_Identifier (Loc, - Chars => Name_Asynchronous); - -- Is the procedure to which the 'Access applies asynchronous? + Stream_Parameter : Node_Id; + Result_Parameter : Node_Id; - All_Calls_Remote : constant Entity_Id := - Make_Defining_Identifier (Loc, - Chars => Name_All_Calls_Remote); - -- True if an All_Calls_Remote pragma applies to the RCI unit - -- that contains the subprogram. + Pkg_RPC_Receiver : constant Entity_Id := + Make_Defining_Identifier (Loc, + New_Internal_Name ('H')); + Pkg_RPC_Receiver_Statements : List_Id; + Pkg_RPC_Receiver_Cases : constant List_Id := New_List; + Pkg_RPC_Receiver_Body : Node_Id; + -- A Pkg_RPC_Receiver is built to decode the request - -- Common local variables + Lookup_RAS_Info : constant Entity_Id := + Make_Defining_Identifier (Loc, + Chars => New_Internal_Name ('R')); + -- A remote subprogram is created to allow peers to look up + -- RAS information using subprogram ids. - Proc_Decls : List_Id; - Proc_Statements : List_Id; + Subp_Id : Node_Id; + -- Subprogram_Id as read from the incoming stream - Origin : constant Entity_Id := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('P')); + Current_Declaration : Node_Id; + Current_Subprogram_Number : Int := First_RCI_Subprogram_Id; + Current_Stubs : Node_Id; - -- Additional local variables for the local case + Subp_Info_Array : constant Entity_Id := + Make_Defining_Identifier (Loc, + Chars => New_Internal_Name ('I')); - Proxy_Addr : constant Entity_Id := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('P')); + Subp_Info_List : constant List_Id := New_List; - -- Additional local variables for the remote case + Register_Pkg_Actuals : constant List_Id := New_List; - Local_Stub : constant Entity_Id := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('L')); + Dummy_Register_Name : Name_Id; + Dummy_Register_Spec : Node_Id; + Dummy_Register_Decl : Node_Id; + Dummy_Register_Body : Node_Id; - Stub_Ptr : constant Entity_Id := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('S')); + All_Calls_Remote_E : Entity_Id; + Proxy_Object_Addr : Entity_Id; - function Set_Field - (Field_Name : Name_Id; - Value : Node_Id) return Node_Id; - -- Construct an assignment that sets the named component in the - -- returned record + procedure Append_Stubs_To + (RPC_Receiver_Cases : List_Id; + Declaration : Node_Id; + Stubs : Node_Id; + Subprogram_Number : Int); + -- Add one case to the specified RPC receiver case list + -- associating Subprogram_Number with the subprogram declared + -- by Declaration, for which we have receiving stubs in Stubs. - --------------- - -- Set_Field -- - --------------- + --------------------- + -- Append_Stubs_To -- + --------------------- - function Set_Field - (Field_Name : Name_Id; - Value : Node_Id) return Node_Id + procedure Append_Stubs_To + (RPC_Receiver_Cases : List_Id; + Declaration : Node_Id; + Stubs : Node_Id; + Subprogram_Number : Int) is + Actuals : constant List_Id := + New_List (New_Occurrence_Of (Stream_Parameter, Loc)); begin - return - Make_Assignment_Statement (Loc, - Name => - Make_Selected_Component (Loc, - Prefix => New_Occurrence_Of (Stub_Ptr, Loc), - Selector_Name => Make_Identifier (Loc, Field_Name)), - Expression => Value); - end Set_Field; - - -- Start of processing for Add_RAS_Access_TSS - - begin - Proc_Decls := New_List ( + if Nkind (Specification (Declaration)) = N_Function_Specification + or else not + Is_Asynchronous (Defining_Entity (Specification (Declaration))) + then + -- An asynchronous procedure does not want an output parameter + -- since no result and no exception will ever be returned. - -- Common declarations + Append_To (Actuals, + New_Occurrence_Of (Result_Parameter, Loc)); + end if; - Make_Object_Declaration (Loc, - Defining_Identifier => Origin, - Constant_Present => True, - Object_Definition => - New_Occurrence_Of (RTE (RE_Partition_ID), Loc), - Expression => - Make_Function_Call (Loc, - Name => - New_Occurrence_Of (RTE (RE_Get_Active_Partition_Id), Loc), - Parameter_Associations => New_List ( - New_Occurrence_Of (Package_Name, Loc)))), + Append_To (RPC_Receiver_Cases, + Make_Case_Statement_Alternative (Loc, + Discrete_Choices => + New_List ( + Make_Integer_Literal (Loc, Subprogram_Number)), - -- Declaration use only in the local case: proxy address + Statements => + New_List ( + Make_Procedure_Call_Statement (Loc, + Name => + New_Occurrence_Of ( + Defining_Entity (Stubs), Loc), + Parameter_Associations => + Actuals)))); + end Append_Stubs_To; - Make_Object_Declaration (Loc, - Defining_Identifier => Proxy_Addr, - Object_Definition => - New_Occurrence_Of (RTE (RE_Unsigned_64), Loc)), + -- Start of processing for Add_Receiving_Stubs_To_Declarations - -- Declarations used only in the remote case: stub object and - -- stub pointer. + begin + -- Building receiving stubs consist in several operations: - Make_Object_Declaration (Loc, - Defining_Identifier => Local_Stub, - Aliased_Present => True, - Object_Definition => - New_Occurrence_Of (Stub_Elements.Stub_Type, Loc)), + -- - a package RPC receiver must be built. This subprogram + -- will get a Subprogram_Id from the incoming stream + -- and will dispatch the call to the right subprogram - Make_Object_Declaration (Loc, - Defining_Identifier => - Stub_Ptr, - Object_Definition => - New_Occurrence_Of (Stub_Elements.Stub_Type_Access, Loc), - Expression => - Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (Local_Stub, Loc), - Attribute_Name => Name_Unchecked_Access))); + -- - a receiving stub for any subprogram visible in the package + -- spec. This stub will read all the parameters from the stream, + -- and put the result as well as the exception occurrence in the + -- output stream - Set_Etype (Stub_Ptr, Stub_Elements.Stub_Type_Access); - -- Build_Get_Unique_RP_Call needs this information + -- - a dummy package with an empty spec and a body made of an + -- elaboration part, whose job is to register the receiving + -- part of this RCI package on the name server. This is done + -- by calling System.Partition_Interface.Register_Receiving_Stub - -- Note: Here we assume that the Fat_Type is a record - -- containing just a pointer to a proxy or stub object. + Build_RPC_Receiver_Body ( + RPC_Receiver => Pkg_RPC_Receiver, + Stream => Stream_Parameter, + Result => Result_Parameter, + Subp_Id => Subp_Id, + Stmts => Pkg_RPC_Receiver_Statements, + Decl => Pkg_RPC_Receiver_Body); - Proc_Statements := New_List ( + -- A null subp_id denotes a call through a RAS, in which case the + -- next Uint_64 element in the stream is the address of the local + -- proxy object, from which we can retrieve the actual subprogram id. - -- Generate: + Append_To (Pkg_RPC_Receiver_Statements, + Make_Implicit_If_Statement (Pkg_Spec, + Condition => + Make_Op_Eq (Loc, + New_Occurrence_Of (Subp_Id, Loc), + Make_Integer_Literal (Loc, 0)), + Then_Statements => New_List ( + Make_Assignment_Statement (Loc, + Name => + New_Occurrence_Of (Subp_Id, Loc), + Expression => + Make_Selected_Component (Loc, + Prefix => + Unchecked_Convert_To (RTE (RE_RAS_Proxy_Type_Access), + OK_Convert_To (RTE (RE_Address), + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (RTE (RE_Unsigned_64), Loc), + Attribute_Name => + Name_Input, + Expressions => New_List ( + New_Occurrence_Of (Stream_Parameter, Loc))))), + Selector_Name => + Make_Identifier (Loc, Name_Subp_Id)))))); - -- Get_RAS_Info (Pkg, Subp, PA); - -- if Origin = Local_Partition_Id and then not All_Calls_Remote then - -- return Fat_Type!(PA); - -- end if; + -- Build a subprogram for RAS information lookups - Make_Procedure_Call_Statement (Loc, - Name => - New_Occurrence_Of (RTE (RE_Get_RAS_Info), Loc), - Parameter_Associations => New_List ( - New_Occurrence_Of (Package_Name, Loc), - New_Occurrence_Of (Subp_Id, Loc), - New_Occurrence_Of (Proxy_Addr, Loc))), + Current_Declaration := + Make_Subprogram_Declaration (Loc, + Specification => + Make_Function_Specification (Loc, + Defining_Unit_Name => + Lookup_RAS_Info, + Parameter_Specifications => New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_Subp_Id), + In_Present => + True, + Parameter_Type => + New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc))), + Subtype_Mark => + New_Occurrence_Of (RTE (RE_Unsigned_64), Loc))); + Append_To (Decls, Current_Declaration); + Analyze (Current_Declaration); - Make_Implicit_If_Statement (N, - Condition => - Make_And_Then (Loc, - Left_Opnd => - Make_Op_Eq (Loc, - Left_Opnd => - New_Occurrence_Of (Origin, Loc), - Right_Opnd => - Make_Function_Call (Loc, - New_Occurrence_Of ( - RTE (RE_Get_Local_Partition_Id), Loc))), - Right_Opnd => - Make_Op_Not (Loc, - New_Occurrence_Of (All_Calls_Remote, Loc))), - Then_Statements => New_List ( - Make_Return_Statement (Loc, - Unchecked_Convert_To (Fat_Type, - OK_Convert_To (RTE (RE_Address), - New_Occurrence_Of (Proxy_Addr, Loc)))))), + Current_Stubs := Build_Subprogram_Receiving_Stubs + (Vis_Decl => Current_Declaration, + Asynchronous => False); + Append_To (Decls, Current_Stubs); + Analyze (Current_Stubs); - Set_Field (Name_Origin, - New_Occurrence_Of (Origin, Loc)), + Append_Stubs_To (Pkg_RPC_Receiver_Cases, + Declaration => + Current_Declaration, + Stubs => + Current_Stubs, + Subprogram_Number => 1); - Set_Field (Name_Receiver, - Make_Function_Call (Loc, - Name => - New_Occurrence_Of (RTE (RE_Get_RCI_Package_Receiver), Loc), - Parameter_Associations => New_List ( - New_Occurrence_Of (Package_Name, Loc)))), + -- For each subprogram, the receiving stub will be built and a + -- case statement will be made on the Subprogram_Id to dispatch + -- to the right subprogram. - Set_Field (Name_Addr, New_Occurrence_Of (Proxy_Addr, Loc)), + All_Calls_Remote_E := Boolean_Literals ( + Has_All_Calls_Remote (Defining_Entity (Pkg_Spec))); - -- E.4.1(9) A remote call is asynchronous if it is a call to - -- a procedure, or a call through a value of an access-to-procedure - -- type, to which a pragma Asynchronous applies. + Overload_Counter_Table.Reset; - -- Parameter Asynch_P is true when the procedure is asynchronous; - -- Expression Asynch_T is true when the type is asynchronous. + Current_Declaration := First (Visible_Declarations (Pkg_Spec)); + while Present (Current_Declaration) loop + if Nkind (Current_Declaration) = N_Subprogram_Declaration + and then Comes_From_Source (Current_Declaration) + then + declare + Loc : constant Source_Ptr := + Sloc (Current_Declaration); + -- While specifically processing Current_Declaration, use its + -- Sloc as the location of all generated nodes. - Set_Field (Name_Asynchronous, - Make_Or_Else (Loc, - New_Occurrence_Of (Asynch_P, Loc), - New_Occurrence_Of (Boolean_Literals ( - Is_Asynchronous (Ras_Type)), Loc)))); + Subp_Def : constant Entity_Id := + Defining_Unit_Name + (Specification (Current_Declaration)); - Append_List_To (Proc_Statements, - Build_Get_Unique_RP_Call - (Loc, Stub_Ptr, Stub_Elements.Stub_Type)); + Subp_Val : String_Id; - -- Return the newly created value + begin + pragma Assert (Current_Subprogram_Number = + Get_Subprogram_Id (Subp_Def)); - Append_To (Proc_Statements, - Make_Return_Statement (Loc, - Expression => - Unchecked_Convert_To (Fat_Type, - New_Occurrence_Of (Stub_Ptr, Loc)))); + -- Build receiving stub - Proc_Spec := - Make_Function_Specification (Loc, - Defining_Unit_Name => Proc, - Parameter_Specifications => New_List ( - Make_Parameter_Specification (Loc, - Defining_Identifier => Package_Name, - Parameter_Type => - New_Occurrence_Of (Standard_String, Loc)), + Current_Stubs := + Build_Subprogram_Receiving_Stubs + (Vis_Decl => Current_Declaration, + Asynchronous => + Nkind (Specification (Current_Declaration)) = + N_Procedure_Specification + and then Is_Asynchronous (Subp_Def)); + + Append_To (Decls, Current_Stubs); + Analyze (Current_Stubs); + + -- Build RAS proxy + + Add_RAS_Proxy_And_Analyze (Decls, + Vis_Decl => + Current_Declaration, + All_Calls_Remote_E => + All_Calls_Remote_E, + Proxy_Object_Addr => + Proxy_Object_Addr); + + -- Compute distribution identifier + + Assign_Subprogram_Identifier ( + Subp_Def, + Current_Subprogram_Number, + Subp_Val); + + -- Add subprogram descriptor (RCI_Subp_Info) to the + -- subprograms table for this receiver. The aggregate + -- below must be kept consistent with the declaration + -- of type RCI_Subp_Info in System.Partition_Interface. + + Append_To (Subp_Info_List, + Make_Component_Association (Loc, + Choices => New_List ( + Make_Integer_Literal (Loc, + Current_Subprogram_Number)), + Expression => + Make_Aggregate (Loc, + Component_Associations => New_List ( + Make_Component_Association (Loc, + Choices => New_List ( + Make_Identifier (Loc, Name_Addr)), + Expression => + New_Occurrence_Of (Proxy_Object_Addr, Loc)))))); + + Append_Stubs_To (Pkg_RPC_Receiver_Cases, + Declaration => + Current_Declaration, + Stubs => + Current_Stubs, + Subprogram_Number => + Current_Subprogram_Number); + end; - Make_Parameter_Specification (Loc, - Defining_Identifier => Subp_Id, - Parameter_Type => - New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc)), + Current_Subprogram_Number := Current_Subprogram_Number + 1; + end if; - Make_Parameter_Specification (Loc, - Defining_Identifier => Asynch_P, - Parameter_Type => - New_Occurrence_Of (Standard_Boolean, Loc)), + Next (Current_Declaration); + end loop; - Make_Parameter_Specification (Loc, - Defining_Identifier => All_Calls_Remote, - Parameter_Type => - New_Occurrence_Of (Standard_Boolean, Loc))), + -- If we receive an invalid Subprogram_Id, it is best to do nothing + -- rather than raising an exception since we do not want someone + -- to crash a remote partition by sending invalid subprogram ids. + -- This is consistent with the other parts of the case statement + -- since even in presence of incorrect parameters in the stream, + -- every exception will be caught and (if the subprogram is not an + -- APC) put into the result stream and sent away. - Subtype_Mark => - New_Occurrence_Of (Fat_Type, Loc)); + Append_To (Pkg_RPC_Receiver_Cases, + Make_Case_Statement_Alternative (Loc, + Discrete_Choices => + New_List (Make_Others_Choice (Loc)), + Statements => + New_List (Make_Null_Statement (Loc)))); - -- Set the kind and return type of the function to prevent ambiguities - -- between Ras_Type and Fat_Type in subsequent analysis. + Append_To (Pkg_RPC_Receiver_Statements, + Make_Case_Statement (Loc, + Expression => + New_Occurrence_Of (Subp_Id, Loc), + Alternatives => Pkg_RPC_Receiver_Cases)); - Set_Ekind (Proc, E_Function); - Set_Etype (Proc, New_Occurrence_Of (Fat_Type, Loc)); + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Subp_Info_Array, + Constant_Present => True, + Aliased_Present => True, + Object_Definition => + Make_Subtype_Indication (Loc, + Subtype_Mark => + New_Occurrence_Of (RTE (RE_RCI_Subp_Info_Array), Loc), + Constraint => + Make_Index_Or_Discriminant_Constraint (Loc, + New_List ( + Make_Range (Loc, + Low_Bound => Make_Integer_Literal (Loc, + First_RCI_Subprogram_Id), + High_Bound => + Make_Integer_Literal (Loc, + First_RCI_Subprogram_Id + + List_Length (Subp_Info_List) - 1))))), + Expression => + Make_Aggregate (Loc, + Component_Associations => Subp_Info_List))); + Analyze (Last (Decls)); - Discard_Node ( + Append_To (Decls, Make_Subprogram_Body (Loc, - Specification => Proc_Spec, - Declarations => Proc_Decls, + Specification => + Copy_Specification (Loc, Parent (Lookup_RAS_Info)), + Declarations => + No_List, Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, - Statements => Proc_Statements))); - - Set_TSS (Fat_Type, Proc); - end Add_RAS_Access_TSS; - - ----------------------------- - -- Add_RAS_Dereference_TSS -- - ----------------------------- + Statements => New_List ( + Make_Return_Statement (Loc, + Expression => OK_Convert_To (RTE (RE_Unsigned_64), + Make_Selected_Component (Loc, + Prefix => + Make_Indexed_Component (Loc, + Prefix => + New_Occurrence_Of (Subp_Info_Array, Loc), + Expressions => New_List ( + Convert_To (Standard_Integer, + Make_Identifier (Loc, Name_Subp_Id)))), + Selector_Name => + Make_Identifier (Loc, Name_Addr)))))))); + Analyze (Last (Decls)); - -- This subprogram could use more comments ??? + Append_To (Decls, Pkg_RPC_Receiver_Body); + Analyze (Pkg_RPC_Receiver_Body); - procedure Add_RAS_Dereference_TSS (N : Node_Id) is - Loc : constant Source_Ptr := Sloc (N); + -- Construction of the dummy package used to register the package + -- receiving stubs on the nameserver. - Type_Def : constant Node_Id := Type_Definition (N); + Dummy_Register_Name := New_Internal_Name ('P'); - RAS_Type : constant Entity_Id := Defining_Identifier (N); - Fat_Type : constant Entity_Id := Equivalent_Type (RAS_Type); - RACW_Type : constant Entity_Id := Underlying_RACW_Type (RAS_Type); - Desig : constant Entity_Id := Etype (Designated_Type (RACW_Type)); + Dummy_Register_Spec := + Make_Package_Specification (Loc, + Defining_Unit_Name => + Make_Defining_Identifier (Loc, Dummy_Register_Name), + Visible_Declarations => No_List, + End_Label => Empty); - Stub_Elements : constant Stub_Structure := Stubs_Table.Get (Desig); - pragma Assert (Stub_Elements /= Empty_Stub_Structure); + Dummy_Register_Decl := + Make_Package_Declaration (Loc, + Specification => Dummy_Register_Spec); - RACW_Primitive_Name : Node_Id; + Append_To (Decls, Dummy_Register_Decl); + Analyze (Dummy_Register_Decl); - Proc : constant Entity_Id := - Make_Defining_Identifier (Loc, - Chars => Make_TSS_Name (RAS_Type, TSS_RAS_Dereference)); + Get_Library_Unit_Name_String (Pkg_Spec); + Append_To (Register_Pkg_Actuals, + -- Name + Make_String_Literal (Loc, + Strval => String_From_Name_Buffer)); - Proc_Spec : Node_Id; - Param_Specs : List_Id; - Param_Assoc : constant List_Id := New_List; - Stmts : constant List_Id := New_List; + Append_To (Register_Pkg_Actuals, + -- Receiver + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Pkg_RPC_Receiver, Loc), + Attribute_Name => + Name_Unrestricted_Access)); - RAS_Parameter : constant Entity_Id := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('P')); + Append_To (Register_Pkg_Actuals, + -- Version + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Defining_Entity (Pkg_Spec), Loc), + Attribute_Name => + Name_Version)); - Is_Function : constant Boolean := - Nkind (Type_Def) = N_Access_Function_Definition; + Append_To (Register_Pkg_Actuals, + -- Subp_Info + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Subp_Info_Array, Loc), + Attribute_Name => + Name_Address)); - Is_Degenerate : Boolean; - -- Set to True if the subprogram_specification for this RAS has - -- an anonymous access parameter (see Process_Remote_AST_Declaration). + Append_To (Register_Pkg_Actuals, + -- Subp_Info_Len + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Subp_Info_Array, Loc), + Attribute_Name => + Name_Length)); - Spec : constant Node_Id := Type_Def; + Dummy_Register_Body := + Make_Package_Body (Loc, + Defining_Unit_Name => + Make_Defining_Identifier (Loc, Dummy_Register_Name), + Declarations => No_List, - Current_Parameter : Node_Id; + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List ( + Make_Procedure_Call_Statement (Loc, + Name => + New_Occurrence_Of (RTE (RE_Register_Receiving_Stub), Loc), - begin - Param_Specs := New_List ( - Make_Parameter_Specification (Loc, - Defining_Identifier => RAS_Parameter, - In_Present => True, - Parameter_Type => - New_Occurrence_Of (Fat_Type, Loc))); + Parameter_Associations => Register_Pkg_Actuals)))); - Is_Degenerate := False; - Current_Parameter := First (Parameter_Specifications (Type_Def)); - Parameters : while Current_Parameter /= Empty loop - if Nkind (Parameter_Type (Current_Parameter)) - = N_Access_Definition - then - Is_Degenerate := True; - end if; - Append_To (Param_Specs, - Make_Parameter_Specification (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, - Chars => Chars (Defining_Identifier (Current_Parameter))), - In_Present => In_Present (Current_Parameter), - Out_Present => Out_Present (Current_Parameter), - Parameter_Type => - New_Copy_Tree (Parameter_Type (Current_Parameter)), - Expression => - New_Copy_Tree (Expression (Current_Parameter)))); + Append_To (Decls, Dummy_Register_Body); + Analyze (Dummy_Register_Body); + end Add_Receiving_Stubs_To_Declarations; - Append_To (Param_Assoc, - Make_Identifier (Loc, - Chars => Chars (Defining_Identifier (Current_Parameter)))); + ------------------- + -- Add_Stub_Type -- + ------------------- - Next (Current_Parameter); - end loop Parameters; + procedure Add_Stub_Type + (Designated_Type : Entity_Id; + RACW_Type : Entity_Id; + Decls : List_Id; + Stub_Type : out Entity_Id; + Stub_Type_Access : out Entity_Id; + RPC_Receiver_Decl : out Node_Id; + Existing : out Boolean) + is + Loc : constant Source_Ptr := Sloc (RACW_Type); - if Is_Degenerate then - Prepend_To (Param_Assoc, New_Occurrence_Of (RAS_Parameter, Loc)); + Stub_Elements : constant Stub_Structure := + Stubs_Table.Get (Designated_Type); - -- Generate a dummy body recursing on the Dereference TSS, since - -- actually it will never be executed. + Stub_Type_Declaration : Node_Id; + Stub_Type_Access_Declaration : Node_Id; - Append_To (Stmts, - Make_Raise_Program_Error (Loc, Reason => PE_Explicit_Raise)); - RACW_Primitive_Name := New_Occurrence_Of (Proc, Loc); + Object_RPC_Receiver : Entity_Id; + RPC_Receiver_Stream : Entity_Id; + RPC_Receiver_Result : Entity_Id; - else - Prepend_To (Param_Assoc, - Unchecked_Convert_To (RACW_Type, - New_Occurrence_Of (RAS_Parameter, Loc))); + Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type); - RACW_Primitive_Name := - Make_Selected_Component (Loc, - Prefix => - New_Occurrence_Of (Scope (RACW_Type), Loc), - Selector_Name => - Make_Identifier (Loc, Name_Call)); + begin + if Stub_Elements /= Empty_Stub_Structure then + Stub_Type := Stub_Elements.Stub_Type; + Stub_Type_Access := Stub_Elements.Stub_Type_Access; + RPC_Receiver_Decl := Stub_Elements.RPC_Receiver_Decl; + Existing := True; + return; end if; - if Is_Function then - Append_To (Stmts, - Make_Return_Statement (Loc, - Expression => - Make_Function_Call (Loc, - Name => - RACW_Primitive_Name, - Parameter_Associations => Param_Assoc))); - - else - Append_To (Stmts, - Make_Procedure_Call_Statement (Loc, - Name => - RACW_Primitive_Name, - Parameter_Associations => Param_Assoc)); - end if; + Existing := False; + Stub_Type := + Make_Defining_Identifier (Loc, New_Internal_Name ('S')); + Stub_Type_Access := + Make_Defining_Identifier (Loc, New_Internal_Name ('S')); + Object_RPC_Receiver := + Make_Defining_Identifier (Loc, New_Internal_Name ('P')); + RPC_Receiver_Stream := + Make_Defining_Identifier (Loc, Name_S); + RPC_Receiver_Result := + Make_Defining_Identifier (Loc, Name_R); - -- Build the complete subprogram + -- The stub type definition below must match exactly the one in + -- s-parint.ads, since unchecked conversions will be used in + -- s-parint.adb to modify pointers passed to Get_Unique_Remote_Pointer. - if Is_Function then - Proc_Spec := - Make_Function_Specification (Loc, - Defining_Unit_Name => Proc, - Parameter_Specifications => Param_Specs, - Subtype_Mark => - New_Occurrence_Of ( - Entity (Subtype_Mark (Spec)), Loc)); + Stub_Type_Declaration := + Make_Full_Type_Declaration (Loc, + Defining_Identifier => Stub_Type, + Type_Definition => + Make_Record_Definition (Loc, + Tagged_Present => True, + Limited_Present => True, + Component_List => + Make_Component_List (Loc, + Component_Items => New_List ( - Set_Ekind (Proc, E_Function); - Set_Etype (Proc, - New_Occurrence_Of (Entity (Subtype_Mark (Spec)), Loc)); + Make_Component_Declaration (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_Origin), + Component_Definition => + Make_Component_Definition (Loc, + Aliased_Present => False, + Subtype_Indication => + New_Occurrence_Of (RTE (RE_Partition_ID), Loc))), - else - Proc_Spec := - Make_Procedure_Specification (Loc, - Defining_Unit_Name => Proc, - Parameter_Specifications => Param_Specs); + Make_Component_Declaration (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_Receiver), + Component_Definition => + Make_Component_Definition (Loc, + Aliased_Present => False, + Subtype_Indication => + New_Occurrence_Of (RTE (RE_Unsigned_64), Loc))), - Set_Ekind (Proc, E_Procedure); - Set_Etype (Proc, Standard_Void_Type); - end if; + Make_Component_Declaration (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_Addr), + Component_Definition => + Make_Component_Definition (Loc, + Aliased_Present => False, + Subtype_Indication => + New_Occurrence_Of (RTE (RE_Unsigned_64), Loc))), - Discard_Node ( - Make_Subprogram_Body (Loc, - Specification => Proc_Spec, - Declarations => New_List, - Handled_Statement_Sequence => - Make_Handled_Sequence_Of_Statements (Loc, - Statements => Stmts))); + Make_Component_Declaration (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_Asynchronous), + Component_Definition => + Make_Component_Definition (Loc, + Aliased_Present => False, + Subtype_Indication => + New_Occurrence_Of (Standard_Boolean, Loc))))))); - Set_TSS (Fat_Type, Proc); - end Add_RAS_Dereference_TSS; + Append_To (Decls, Stub_Type_Declaration); + Analyze (Stub_Type_Declaration); - ------------------------------- - -- Add_RAS_Proxy_And_Analyze -- - ------------------------------- + -- This is in no way a type derivation, but we fake it to make + -- sure that the dispatching table gets built with the corresponding + -- primitive operations at the right place. - procedure Add_RAS_Proxy_And_Analyze - (Decls : List_Id; - Vis_Decl : Node_Id; - All_Calls_Remote_E : Entity_Id; - Proxy_Object_Addr : out Entity_Id) - is - Loc : constant Source_Ptr := Sloc (Vis_Decl); + Derive_Subprograms (Parent_Type => Designated_Type, + Derived_Type => Stub_Type); - Subp_Name : constant Entity_Id := - Defining_Unit_Name (Specification (Vis_Decl)); + Stub_Type_Access_Declaration := + Make_Full_Type_Declaration (Loc, + Defining_Identifier => Stub_Type_Access, + Type_Definition => + Make_Access_To_Object_Definition (Loc, + All_Present => True, + Subtype_Indication => New_Occurrence_Of (Stub_Type, Loc))); - Pkg_Name : constant Entity_Id := - Make_Defining_Identifier (Loc, - Chars => - New_External_Name (Chars (Subp_Name), 'P', -1)); + Append_To (Decls, Stub_Type_Access_Declaration); + Analyze (Stub_Type_Access_Declaration); - Proxy_Type : constant Entity_Id := - Make_Defining_Identifier (Loc, - Chars => - New_External_Name ( - Related_Id => Chars (Subp_Name), - Suffix => 'P')); + if not Is_RAS then + Append_To (Decls, + Make_Subprogram_Declaration (Loc, + Build_RPC_Receiver_Specification ( + RPC_Receiver => Object_RPC_Receiver, + Stream_Parameter => RPC_Receiver_Stream, + Result_Parameter => RPC_Receiver_Result))); + end if; - Proxy_Type_Full_View : constant Entity_Id := - Make_Defining_Identifier (Loc, - Chars (Proxy_Type)); + RPC_Receiver_Decl := Last (Decls); + Stubs_Table.Set (Designated_Type, + (Stub_Type => Stub_Type, + Stub_Type_Access => Stub_Type_Access, + RPC_Receiver_Decl => RPC_Receiver_Decl, + RACW_Type => RACW_Type)); + end Add_Stub_Type; - Subp_Decl_Spec : constant Node_Id := - Build_RAS_Primitive_Specification - (Subp_Spec => Specification (Vis_Decl), - Remote_Object_Type => Proxy_Type); + ---------------------------------- + -- Assign_Subprogram_Identifier -- + ---------------------------------- - Subp_Body_Spec : constant Node_Id := - Build_RAS_Primitive_Specification - (Subp_Spec => Specification (Vis_Decl), - Remote_Object_Type => Proxy_Type); + procedure Assign_Subprogram_Identifier + (Def : Entity_Id; + Spn : Int; + Id : out String_Id) + is + N : constant Name_Id := Chars (Def); - Vis_Decls : constant List_Id := New_List; - Pvt_Decls : constant List_Id := New_List; - Actuals : constant List_Id := New_List; - Formal : Node_Id; - Perform_Call : Node_Id; + Overload_Order : constant Int := + Overload_Counter_Table.Get (N) + 1; begin - -- type subpP is tagged limited private; - - Append_To (Vis_Decls, - Make_Private_Type_Declaration (Loc, - Defining_Identifier => Proxy_Type, - Tagged_Present => True, - Limited_Present => True)); + Overload_Counter_Table.Set (N, Overload_Order); - -- [subprogram] Call - -- (Self : access subpP; - -- ...other-formals...) - -- [return T]; + Get_Name_String (N); - Append_To (Vis_Decls, - Make_Subprogram_Declaration (Loc, - Specification => Subp_Decl_Spec)); + -- Homonym handling: as in Exp_Dbug, but much simpler, + -- because the only entities for which we have to generate + -- names here need only to be disambiguated within their + -- own scope. - -- A : constant System.Address; + if Overload_Order > 1 then + Name_Buffer (Name_Len + 1 .. Name_Len + 2) := "__"; + Name_Len := Name_Len + 2; + Add_Nat_To_Name_Buffer (Overload_Order); + end if; - Proxy_Object_Addr := Make_Defining_Identifier (Loc, Name_uA); + Id := String_From_Name_Buffer; + Subprogram_Identifier_Table.Set (Def, + Subprogram_Identifiers'(Str_Identifier => Id, Int_Identifier => Spn)); + end Assign_Subprogram_Identifier; - Append_To (Vis_Decls, - Make_Object_Declaration (Loc, - Defining_Identifier => - Proxy_Object_Addr, - Constant_Present => - True, - Object_Definition => - New_Occurrence_Of (RTE (RE_Address), Loc))); + --------------------------------- + -- Build_General_Calling_Stubs -- + --------------------------------- - -- private + procedure Build_General_Calling_Stubs + (Decls : List_Id; + Statements : List_Id; + Target_Partition : Entity_Id; + RPC_Receiver : Node_Id; + Subprogram_Id : Node_Id; + Asynchronous : Node_Id := Empty; + Is_Known_Asynchronous : Boolean := False; + Is_Known_Non_Asynchronous : Boolean := False; + Is_Function : Boolean; + Spec : Node_Id; + Stub_Type : Entity_Id := Empty; + RACW_Type : Entity_Id := Empty; + Nod : Node_Id) + is + Loc : constant Source_Ptr := Sloc (Nod); - -- type subpP is tagged limited record - -- All_Calls_Remote : Boolean := [All_Calls_Remote?]; - -- ... - -- end record; + Stream_Parameter : Node_Id; + -- Name of the stream used to transmit parameters to the remote package - Append_To (Pvt_Decls, - Make_Full_Type_Declaration (Loc, - Defining_Identifier => - Proxy_Type_Full_View, - Type_Definition => - Build_Remote_Subprogram_Proxy_Type (Loc, - New_Occurrence_Of (All_Calls_Remote_E, Loc)))); + Result_Parameter : Node_Id; + -- Name of the result parameter (in non-APC cases) which get the + -- result of the remote subprogram. - -- Trick semantic analysis into swapping the public and - -- full view when freezing the public view. + Exception_Return_Parameter : Node_Id; + -- Name of the parameter which will hold the exception sent by the + -- remote subprogram. - Set_Comes_From_Source (Proxy_Type_Full_View, True); + Current_Parameter : Node_Id; + -- Current parameter being handled - -- procedure Call - -- (Self : access O; - -- ...other-formals...) is - -- begin - -- P (...other-formals...); - -- end Call; + Ordered_Parameters_List : constant List_Id := + Build_Ordered_Parameters_List (Spec); - -- function Call - -- (Self : access O; - -- ...other-formals...) - -- return T is - -- begin - -- return F (...other-formals...); - -- end Call; + Asynchronous_Statements : List_Id := No_List; + Non_Asynchronous_Statements : List_Id := No_List; + -- Statements specifics to the Asynchronous/Non-Asynchronous cases - if Nkind (Subp_Decl_Spec) = N_Procedure_Specification then - Perform_Call := - Make_Procedure_Call_Statement (Loc, - Name => - New_Occurrence_Of (Subp_Name, Loc), - Parameter_Associations => - Actuals); - else - Perform_Call := - Make_Return_Statement (Loc, - Expression => - Make_Function_Call (Loc, - Name => - New_Occurrence_Of (Subp_Name, Loc), - Parameter_Associations => - Actuals)); - end if; + Extra_Formal_Statements : constant List_Id := New_List; + -- List of statements for extra formal parameters. It will appear after + -- the regular statements for writing out parameters. - Formal := First (Parameter_Specifications (Subp_Decl_Spec)); - pragma Assert (Present (Formal)); - Next (Formal); + pragma Warnings (Off); + pragma Unreferenced (RACW_Type); + -- Used only for the PolyORB case + pragma Warnings (On); - while Present (Formal) loop - Append_To (Actuals, New_Occurrence_Of ( - Defining_Identifier (Formal), Loc)); - Next (Formal); - end loop; + begin + -- The general form of a calling stub for a given subprogram is: - -- O : aliased subpP; + -- procedure X (...) is + -- P : constant Partition_ID := RCI_Cache.Get_Active_Partition_ID; + -- Stream, Result : aliased System.RPC.Params_Stream_Type (0); + -- begin + -- Put_Package_RPC_Receiver_In_Stream; (the package RPC receiver + -- comes from RCI_Cache.Get_RCI_Package_Receiver) + -- Put_Subprogram_Id_In_Stream; + -- Put_Parameters_In_Stream; + -- Do_RPC (Stream, Result); + -- Read_Exception_Occurrence_From_Result; Raise_It; + -- Read_Out_Parameters_And_Function_Return_From_Stream; + -- end X; - Append_To (Pvt_Decls, - Make_Object_Declaration (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, - Name_uO), - Aliased_Present => - True, - Object_Definition => - New_Occurrence_Of (Proxy_Type, Loc))); + -- There are some variations: Do_APC is called for an asynchronous + -- procedure and the part after the call is completely ommitted + -- as well as the declaration of Result. For a function call, + -- 'Input is always used to read the result even if it is constrained. - -- A : constant System.Address := O'Address; + Stream_Parameter := + Make_Defining_Identifier (Loc, New_Internal_Name ('S')); - Append_To (Pvt_Decls, + Append_To (Decls, Make_Object_Declaration (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, - Chars (Proxy_Object_Addr)), - Constant_Present => - True, - Object_Definition => - New_Occurrence_Of (RTE (RE_Address), Loc), - Expression => - Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of ( - Defining_Identifier (Last (Pvt_Decls)), Loc), - Attribute_Name => - Name_Address))); + Defining_Identifier => Stream_Parameter, + Aliased_Present => True, + Object_Definition => + Make_Subtype_Indication (Loc, + Subtype_Mark => + New_Occurrence_Of (RTE (RE_Params_Stream_Type), Loc), + Constraint => + Make_Index_Or_Discriminant_Constraint (Loc, + Constraints => + New_List (Make_Integer_Literal (Loc, 0)))))); - Append_To (Decls, - Make_Package_Declaration (Loc, - Specification => Make_Package_Specification (Loc, - Defining_Unit_Name => Pkg_Name, - Visible_Declarations => Vis_Decls, - Private_Declarations => Pvt_Decls, - End_Label => Empty))); - Analyze (Last (Decls)); + if not Is_Known_Asynchronous then + Result_Parameter := + Make_Defining_Identifier (Loc, New_Internal_Name ('R')); - Append_To (Decls, - Make_Package_Body (Loc, - Defining_Unit_Name => - Make_Defining_Identifier (Loc, - Chars (Pkg_Name)), - Declarations => New_List ( - Make_Subprogram_Body (Loc, - Specification => - Subp_Body_Spec, - Declarations => New_List, - Handled_Statement_Sequence => - Make_Handled_Sequence_Of_Statements (Loc, - Statements => New_List (Perform_Call)))))); - Analyze (Last (Decls)); - end Add_RAS_Proxy_And_Analyze; + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Result_Parameter, + Aliased_Present => True, + Object_Definition => + Make_Subtype_Indication (Loc, + Subtype_Mark => + New_Occurrence_Of (RTE (RE_Params_Stream_Type), Loc), + Constraint => + Make_Index_Or_Discriminant_Constraint (Loc, + Constraints => + New_List (Make_Integer_Literal (Loc, 0)))))); - ----------------------- - -- Add_RAST_Features -- - ----------------------- + Exception_Return_Parameter := + Make_Defining_Identifier (Loc, New_Internal_Name ('E')); - procedure Add_RAST_Features (Vis_Decl : Node_Id) is - begin - -- Do not add attributes more than once in any case. This should - -- be replaced by an assert or this comment removed if we decide - -- that this is normal to be called several times ??? + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Exception_Return_Parameter, + Object_Definition => + New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc))); - if Present (TSS (Equivalent_Type (Defining_Identifier (Vis_Decl)), - TSS_RAS_Access)) - then - return; + else + Result_Parameter := Empty; + Exception_Return_Parameter := Empty; end if; - Add_RAS_Dereference_TSS (Vis_Decl); - Add_RAS_Access_TSS (Vis_Decl); - end Add_RAST_Features; + -- Put first the RPC receiver corresponding to the remote package - ----------------------------------------- - -- Add_Receiving_Stubs_To_Declarations -- - ----------------------------------------- + Append_To (Statements, + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (RTE (RE_Unsigned_64), Loc), + Attribute_Name => Name_Write, + Expressions => New_List ( + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Stream_Parameter, Loc), + Attribute_Name => + Name_Access), + RPC_Receiver))); - procedure Add_Receiving_Stubs_To_Declarations - (Pkg_Spec : Node_Id; - Decls : List_Id) - is - Loc : constant Source_Ptr := Sloc (Pkg_Spec); + -- Then put the Subprogram_Id of the subprogram we want to call in + -- the stream. - Stream_Parameter : Node_Id; - Result_Parameter : Node_Id; + Append_To (Statements, + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc), + Attribute_Name => + Name_Write, + Expressions => New_List ( + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Stream_Parameter, Loc), + Attribute_Name => Name_Access), + Subprogram_Id))); - Pkg_RPC_Receiver : Node_Id; - Pkg_RPC_Receiver_Spec : Node_Id; - Pkg_RPC_Receiver_Decls : List_Id; - Pkg_RPC_Receiver_Statements : List_Id; - Pkg_RPC_Receiver_Cases : constant List_Id := New_List; - Pkg_RPC_Receiver_Body : Node_Id; - -- A Pkg_RPC_Receiver is built to decode the request + Current_Parameter := First (Ordered_Parameters_List); + while Present (Current_Parameter) loop + declare + Typ : constant Node_Id := + Parameter_Type (Current_Parameter); + Etyp : Entity_Id; + Constrained : Boolean; + Value : Node_Id; + Extra_Parameter : Entity_Id; - Lookup_RAS_Info : constant Entity_Id := - Make_Defining_Identifier (Loc, New_Internal_Name ('R')); - -- A remote subprogram is created to allow peers to look up - -- RAS information using subprogram ids. + begin + if Is_RACW_Controlling_Formal (Current_Parameter, Stub_Type) then - Subp_Id : Node_Id; - -- Subprogram_Id as read from the incoming stream + -- In the case of a controlling formal argument, we marshall + -- its addr field rather than the local stub. - Current_Declaration : Node_Id; - Current_Subprogram_Number : Int := First_RCI_Subprogram_Id; - Current_Stubs : Node_Id; + Append_To (Statements, + Pack_Node_Into_Stream (Loc, + Stream => Stream_Parameter, + Object => + Make_Selected_Component (Loc, + Prefix => + New_Occurrence_Of ( + Defining_Identifier (Current_Parameter), Loc), + Selector_Name => + Make_Identifier (Loc, Name_Addr)), + Etyp => RTE (RE_Unsigned_64))); - Subp_Info_Array : constant Entity_Id := - Make_Defining_Identifier (Loc, New_Internal_Name ('I')); + else + Value := New_Occurrence_Of + (Defining_Identifier (Current_Parameter), Loc); - Subp_Info_List : constant List_Id := New_List; + -- Access type parameters are transmitted as in out + -- parameters. However, a dereference is needed so that + -- we marshall the designated object. - Register_Pkg_Actuals : constant List_Id := New_List; + if Nkind (Typ) = N_Access_Definition then + Value := Make_Explicit_Dereference (Loc, Value); + Etyp := Etype (Subtype_Mark (Typ)); + else + Etyp := Etype (Typ); + end if; - Dummy_Register_Name : Name_Id; - Dummy_Register_Spec : Node_Id; - Dummy_Register_Decl : Node_Id; - Dummy_Register_Body : Node_Id; + Constrained := + Is_Constrained (Etyp) or else Is_Elementary_Type (Etyp); - All_Calls_Remote_E : Entity_Id; - Proxy_Object_Addr : Entity_Id; + -- Any parameter but unconstrained out parameters are + -- transmitted to the peer. - procedure Append_Stubs_To - (RPC_Receiver_Cases : List_Id; - Declaration : Node_Id; - Stubs : Node_Id; - Subprogram_Number : Int); - -- Add one case to the specified RPC receiver case list - -- associating Subprogram_Number with the subprogram declared - -- by Declaration, for which we have receiving stubs in Stubs. + if In_Present (Current_Parameter) + or else not Out_Present (Current_Parameter) + or else not Constrained + then + Append_To (Statements, + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Etyp, Loc), + Attribute_Name => Output_From_Constrained (Constrained), + Expressions => New_List ( + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Stream_Parameter, Loc), + Attribute_Name => Name_Access), + Value))); + end if; + end if; - --------------------- - -- Append_Stubs_To -- - --------------------- + -- If the current parameter has a dynamic constrained status, + -- then this status is transmitted as well. + -- This should be done for accessibility as well ??? - procedure Append_Stubs_To - (RPC_Receiver_Cases : List_Id; - Declaration : Node_Id; - Stubs : Node_Id; - Subprogram_Number : Int) - is - Actuals : constant List_Id := - New_List (New_Occurrence_Of (Stream_Parameter, Loc)); - begin - if Nkind (Specification (Declaration)) = N_Function_Specification - or else not - Is_Asynchronous (Defining_Entity (Specification (Declaration))) - then - -- An asynchronous procedure does not want an output parameter - -- since no result and no exception will ever be returned. + if Nkind (Typ) /= N_Access_Definition + and then Need_Extra_Constrained (Current_Parameter) + then + -- In this block, we do not use the extra formal that has been + -- created because it does not exist at the time of expansion + -- when building calling stubs for remote access to subprogram + -- types. We create an extra variable of this type and push it + -- in the stream after the regular parameters. - Append_To (Actuals, - New_Occurrence_Of (Result_Parameter, Loc)); - end if; + Extra_Parameter := Make_Defining_Identifier + (Loc, New_Internal_Name ('P')); - Append_To (RPC_Receiver_Cases, - Make_Case_Statement_Alternative (Loc, - Discrete_Choices => - New_List ( - Make_Integer_Literal (Loc, Subprogram_Number)), + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Extra_Parameter, + Constant_Present => True, + Object_Definition => + New_Occurrence_Of (Standard_Boolean, Loc), + Expression => + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of ( + Defining_Identifier (Current_Parameter), Loc), + Attribute_Name => Name_Constrained))); - Statements => - New_List ( - Make_Procedure_Call_Statement (Loc, - Name => - New_Occurrence_Of ( - Defining_Entity (Stubs), Loc), - Parameter_Associations => - Actuals)))); - end Append_Stubs_To; + Append_To (Extra_Formal_Statements, + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Standard_Boolean, Loc), + Attribute_Name => + Name_Write, + Expressions => New_List ( + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Stream_Parameter, Loc), + Attribute_Name => + Name_Access), + New_Occurrence_Of (Extra_Parameter, Loc)))); + end if; - -- Start of processing for Add_Receiving_Stubs_To_Declarations + Next (Current_Parameter); + end; + end loop; - begin - -- Building receiving stubs consist in several operations: + -- Append the formal statements list to the statements - -- - a package RPC receiver must be built. This subprogram - -- will get a Subprogram_Id from the incoming stream - -- and will dispatch the call to the right subprogram + Append_List_To (Statements, Extra_Formal_Statements); - -- - a receiving stub for any subprogram visible in the package - -- spec. This stub will read all the parameters from the stream, - -- and put the result as well as the exception occurrence in the - -- output stream + if not Is_Known_Non_Asynchronous then - -- - a dummy package with an empty spec and a body made of an - -- elaboration part, whose job is to register the receiving - -- part of this RCI package on the name server. This is done - -- by calling System.Partition_Interface.Register_Receiving_Stub + -- Build the call to System.RPC.Do_APC - Stream_Parameter := - Make_Defining_Identifier (Loc, New_Internal_Name ('S')); - Result_Parameter := - Make_Defining_Identifier (Loc, New_Internal_Name ('R')); - Subp_Id := - Make_Defining_Identifier (Loc, New_Internal_Name ('P')); + Asynchronous_Statements := New_List ( + Make_Procedure_Call_Statement (Loc, + Name => + New_Occurrence_Of (RTE (RE_Do_Apc), Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of (Target_Partition, Loc), + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Stream_Parameter, Loc), + Attribute_Name => + Name_Access)))); + else + Asynchronous_Statements := No_List; + end if; - Pkg_RPC_Receiver := - Make_Defining_Identifier (Loc, New_Internal_Name ('P')); + if not Is_Known_Asynchronous then - -- The parameters of the package RPC receiver are made of two - -- streams, an input one and an output one. + -- Build the call to System.RPC.Do_RPC - Pkg_RPC_Receiver_Spec := - Build_RPC_Receiver_Specification - (RPC_Receiver => Pkg_RPC_Receiver, - Stream_Parameter => Stream_Parameter, - Result_Parameter => Result_Parameter); + Non_Asynchronous_Statements := New_List ( + Make_Procedure_Call_Statement (Loc, + Name => + New_Occurrence_Of (RTE (RE_Do_Rpc), Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of (Target_Partition, Loc), - Pkg_RPC_Receiver_Decls := New_List ( - Make_Object_Declaration (Loc, - Defining_Identifier => Subp_Id, - Object_Definition => - New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc))); + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Stream_Parameter, Loc), + Attribute_Name => + Name_Access), - Pkg_RPC_Receiver_Statements := New_List ( - Make_Attribute_Reference (Loc, - Prefix => - New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc), - Attribute_Name => - Name_Read, - Expressions => New_List ( - New_Occurrence_Of (Stream_Parameter, Loc), - New_Occurrence_Of (Subp_Id, Loc)))); + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Result_Parameter, Loc), + Attribute_Name => + Name_Access)))); - -- A null subp_id denotes a call through a RAS, in which case the - -- next Uint_64 element in the stream is the address of the local - -- proxy object, from which we can retrieve the actual subprogram id. + -- Read the exception occurrence from the result stream and + -- reraise it. It does no harm if this is a Null_Occurrence since + -- this does nothing. - Append_To (Pkg_RPC_Receiver_Statements, - Make_Implicit_If_Statement (Pkg_Spec, - Condition => - Make_Op_Eq (Loc, - New_Occurrence_Of (Subp_Id, Loc), - Make_Integer_Literal (Loc, 0)), - Then_Statements => New_List ( - Make_Assignment_Statement (Loc, - Name => - New_Occurrence_Of (Subp_Id, Loc), - Expression => - Make_Selected_Component (Loc, - Prefix => - Unchecked_Convert_To (RTE (RE_RAS_Proxy_Type_Access), - OK_Convert_To (RTE (RE_Address), + Append_To (Non_Asynchronous_Statements, + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc), + + Attribute_Name => + Name_Read, + + Expressions => New_List ( + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Result_Parameter, Loc), + Attribute_Name => + Name_Access), + New_Occurrence_Of (Exception_Return_Parameter, Loc)))); + + Append_To (Non_Asynchronous_Statements, + Make_Procedure_Call_Statement (Loc, + Name => + New_Occurrence_Of (RTE (RE_Reraise_Occurrence), Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of (Exception_Return_Parameter, Loc)))); + + if Is_Function then + + -- If this is a function call, then read the value and return + -- it. The return value is written/read using 'Output/'Input. + + Append_To (Non_Asynchronous_Statements, + Make_Tag_Check (Loc, + Make_Return_Statement (Loc, + Expression => + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of ( + Etype (Subtype_Mark (Spec)), Loc), + + Attribute_Name => Name_Input, + + Expressions => New_List ( Make_Attribute_Reference (Loc, - Prefix => - New_Occurrence_Of (RTE (RE_Unsigned_64), Loc), - Attribute_Name => - Name_Input, - Expressions => New_List ( - New_Occurrence_Of (Stream_Parameter, Loc))))), - Selector_Name => - Make_Identifier (Loc, Name_Subp_Id)))))); + Prefix => + New_Occurrence_Of (Result_Parameter, Loc), + Attribute_Name => Name_Access)))))); - All_Calls_Remote_E := Boolean_Literals ( - Has_All_Calls_Remote (Defining_Entity (Pkg_Spec))); + else + -- Loop around parameters and assign out (or in out) parameters. + -- In the case of RACW, controlling arguments cannot possibly + -- have changed since they are remote, so we do not read them + -- from the stream. - -- Build a subprogram for RAS information lookups + Current_Parameter := First (Ordered_Parameters_List); + while Present (Current_Parameter) loop + declare + Typ : constant Node_Id := + Parameter_Type (Current_Parameter); + Etyp : Entity_Id; + Value : Node_Id; - Current_Declaration := - Make_Subprogram_Declaration (Loc, - Specification => - Make_Function_Specification (Loc, - Defining_Unit_Name => - Lookup_RAS_Info, - Parameter_Specifications => New_List ( - Make_Parameter_Specification (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, Name_Subp_Id), - In_Present => - True, - Parameter_Type => - New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc))), - Subtype_Mark => - New_Occurrence_Of (RTE (RE_Unsigned_64), Loc))); - Append_To (Decls, Current_Declaration); - Analyze (Current_Declaration); + begin + Value := + New_Occurrence_Of + (Defining_Identifier (Current_Parameter), Loc); - Current_Stubs := Build_Subprogram_Receiving_Stubs - (Vis_Decl => Current_Declaration, - Asynchronous => False); - Append_To (Decls, Current_Stubs); - Analyze (Current_Stubs); + if Nkind (Typ) = N_Access_Definition then + Value := Make_Explicit_Dereference (Loc, Value); + Etyp := Etype (Subtype_Mark (Typ)); + else + Etyp := Etype (Typ); + end if; - Append_Stubs_To (Pkg_RPC_Receiver_Cases, - Declaration => - Current_Declaration, - Stubs => - Current_Stubs, - Subprogram_Number => 1); + if (Out_Present (Current_Parameter) + or else Nkind (Typ) = N_Access_Definition) + and then Etyp /= Stub_Type + then + Append_To (Non_Asynchronous_Statements, + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Etyp, Loc), - -- For each subprogram, the receiving stub will be built and a - -- case statement will be made on the Subprogram_Id to dispatch - -- to the right subprogram. + Attribute_Name => Name_Read, - Current_Declaration := First (Visible_Declarations (Pkg_Spec)); - while Current_Declaration /= Empty loop - if Nkind (Current_Declaration) = N_Subprogram_Declaration - and then Comes_From_Source (Current_Declaration) - then - pragma Assert (Current_Subprogram_Number = - Get_Subprogram_Id (Defining_Unit_Name (Specification ( - Current_Declaration)))); - - -- Build receiving stub - - Current_Stubs := - Build_Subprogram_Receiving_Stubs - (Vis_Decl => Current_Declaration, - Asynchronous => - Nkind (Specification (Current_Declaration)) = - N_Procedure_Specification - and then Is_Asynchronous - (Defining_Unit_Name (Specification - (Current_Declaration)))); - - Append_To (Decls, Current_Stubs); - Analyze (Current_Stubs); - - -- Build RAS proxy - - Add_RAS_Proxy_And_Analyze (Decls, - Vis_Decl => - Current_Declaration, - All_Calls_Remote_E => - All_Calls_Remote_E, - Proxy_Object_Addr => - Proxy_Object_Addr); - - -- Add subprogram descriptor (RCI_Subp_Info) to the - -- subprograms table for this receiver. The aggregate - -- below must be kept consistent with the declaration - -- of type RCI_Subp_Info in System.Partition_Interface. - - Append_To (Subp_Info_List, - Make_Component_Association (Loc, - Choices => New_List ( - Make_Integer_Literal (Loc, - Current_Subprogram_Number)), - Expression => - Make_Aggregate (Loc, - Component_Associations => New_List ( - Make_Component_Association (Loc, - Choices => New_List ( - Make_Identifier (Loc, Name_Addr)), - Expression => - New_Occurrence_Of (Proxy_Object_Addr, Loc)))))); - - Append_Stubs_To (Pkg_RPC_Receiver_Cases, - Declaration => - Current_Declaration, - Stubs => - Current_Stubs, - Subprogram_Number => - Current_Subprogram_Number); - Current_Subprogram_Number := Current_Subprogram_Number + 1; + Expressions => New_List ( + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Result_Parameter, Loc), + Attribute_Name => + Name_Access), + Value))); + end if; + end; + + Next (Current_Parameter); + end loop; end if; + end if; - Next (Current_Declaration); - end loop; + if Is_Known_Asynchronous then + Append_List_To (Statements, Asynchronous_Statements); - -- If we receive an invalid Subprogram_Id, it is best to do nothing - -- rather than raising an exception since we do not want someone - -- to crash a remote partition by sending invalid subprogram ids. - -- This is consistent with the other parts of the case statement - -- since even in presence of incorrect parameters in the stream, - -- every exception will be caught and (if the subprogram is not an - -- APC) put into the result stream and sent away. + elsif Is_Known_Non_Asynchronous then + Append_List_To (Statements, Non_Asynchronous_Statements); - Append_To (Pkg_RPC_Receiver_Cases, - Make_Case_Statement_Alternative (Loc, - Discrete_Choices => - New_List (Make_Others_Choice (Loc)), - Statements => - New_List (Make_Null_Statement (Loc)))); + else + pragma Assert (Present (Asynchronous)); + Prepend_To (Asynchronous_Statements, + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Standard_Boolean, Loc), + Attribute_Name => Name_Write, + Expressions => New_List ( + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Stream_Parameter, Loc), + Attribute_Name => Name_Access), + New_Occurrence_Of (Standard_True, Loc)))); - Append_To (Pkg_RPC_Receiver_Statements, - Make_Case_Statement (Loc, - Expression => - New_Occurrence_Of (Subp_Id, Loc), - Alternatives => Pkg_RPC_Receiver_Cases)); + Prepend_To (Non_Asynchronous_Statements, + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Standard_Boolean, Loc), + Attribute_Name => Name_Write, + Expressions => New_List ( + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Stream_Parameter, Loc), + Attribute_Name => Name_Access), + New_Occurrence_Of (Standard_False, Loc)))); - Append_To (Decls, - Make_Object_Declaration (Loc, - Defining_Identifier => Subp_Info_Array, - Constant_Present => True, - Aliased_Present => True, - Object_Definition => - Make_Subtype_Indication (Loc, - Subtype_Mark => - New_Occurrence_Of (RTE (RE_RCI_Subp_Info_Array), Loc), - Constraint => - Make_Index_Or_Discriminant_Constraint (Loc, - New_List ( - Make_Range (Loc, - Low_Bound => Make_Integer_Literal (Loc, - First_RCI_Subprogram_Id), - High_Bound => - Make_Integer_Literal (Loc, - First_RCI_Subprogram_Id - + List_Length (Subp_Info_List) - 1))))), - Expression => - Make_Aggregate (Loc, - Component_Associations => Subp_Info_List))); - Analyze (Last (Decls)); + Append_To (Statements, + Make_Implicit_If_Statement (Nod, + Condition => Asynchronous, + Then_Statements => Asynchronous_Statements, + Else_Statements => Non_Asynchronous_Statements)); + end if; + end Build_General_Calling_Stubs; - Append_To (Decls, - Make_Subprogram_Body (Loc, - Specification => - Copy_Specification (Loc, Parent (Lookup_RAS_Info)), - Declarations => - No_List, - Handled_Statement_Sequence => - Make_Handled_Sequence_Of_Statements (Loc, - Statements => New_List ( - Make_Return_Statement (Loc, - Expression => OK_Convert_To (RTE (RE_Unsigned_64), - Make_Selected_Component (Loc, - Prefix => - Make_Indexed_Component (Loc, - Prefix => - New_Occurrence_Of (Subp_Info_Array, Loc), - Expressions => New_List ( - Convert_To (Standard_Integer, - Make_Identifier (Loc, Name_Subp_Id)))), - Selector_Name => - Make_Identifier (Loc, Name_Addr)))))))); - Analyze (Last (Decls)); + ------------------------------ + -- Build_Get_Unique_RP_Call -- + ------------------------------ - Pkg_RPC_Receiver_Body := - Make_Subprogram_Body (Loc, - Specification => Pkg_RPC_Receiver_Spec, - Declarations => Pkg_RPC_Receiver_Decls, - Handled_Statement_Sequence => - Make_Handled_Sequence_Of_Statements (Loc, - Statements => Pkg_RPC_Receiver_Statements)); + function Build_Get_Unique_RP_Call + (Loc : Source_Ptr; + Pointer : Entity_Id; + Stub_Type : Entity_Id) return List_Id + is + begin + return New_List ( + Make_Procedure_Call_Statement (Loc, + Name => + New_Occurrence_Of (RTE (RE_Get_Unique_Remote_Pointer), Loc), + Parameter_Associations => New_List ( + Unchecked_Convert_To (RTE (RE_RACW_Stub_Type_Access), + New_Occurrence_Of (Pointer, Loc)))), - Append_To (Decls, Pkg_RPC_Receiver_Body); - Analyze (Pkg_RPC_Receiver_Body); + Make_Assignment_Statement (Loc, + Name => + Make_Selected_Component (Loc, + Prefix => + New_Occurrence_Of (Pointer, Loc), + Selector_Name => + New_Occurrence_Of (Tag_Component + (Designated_Type (Etype (Pointer))), Loc)), + Expression => + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Stub_Type, Loc), + Attribute_Name => + Name_Tag))); - -- Construction of the dummy package used to register the package - -- receiving stubs on the nameserver. + -- Note: The assignment to Pointer._Tag is safe here because + -- we carefully ensured that Stub_Type has exactly the same layout + -- as System.Partition_Interface.RACW_Stub_Type. - Dummy_Register_Name := New_Internal_Name ('P'); + end Build_Get_Unique_RP_Call; - Dummy_Register_Spec := - Make_Package_Specification (Loc, - Defining_Unit_Name => - Make_Defining_Identifier (Loc, Dummy_Register_Name), - Visible_Declarations => No_List, - End_Label => Empty); + ----------------------------------- + -- Build_Ordered_Parameters_List -- + ----------------------------------- - Dummy_Register_Decl := - Make_Package_Declaration (Loc, - Specification => Dummy_Register_Spec); + function Build_Ordered_Parameters_List (Spec : Node_Id) return List_Id is + Constrained_List : List_Id; + Unconstrained_List : List_Id; + Current_Parameter : Node_Id; - Append_To (Decls, Dummy_Register_Decl); - Analyze (Dummy_Register_Decl); + First_Parameter : Node_Id; + For_RAS : Boolean := False; - Get_Pkg_Name_String (Pkg_Spec); - Append_To (Register_Pkg_Actuals, - -- Name - Make_String_Literal (Loc, - Strval => String_From_Name_Buffer)); + begin + if not Present (Parameter_Specifications (Spec)) then + return New_List; + end if; - Append_To (Register_Pkg_Actuals, - -- Receiver - Make_Attribute_Reference (Loc, - Prefix => - New_Occurrence_Of (Pkg_RPC_Receiver, Loc), - Attribute_Name => - Name_Unrestricted_Access)); + Constrained_List := New_List; + Unconstrained_List := New_List; + First_Parameter := First (Parameter_Specifications (Spec)); - Append_To (Register_Pkg_Actuals, - -- Version - Make_Attribute_Reference (Loc, - Prefix => - New_Occurrence_Of (Defining_Entity (Pkg_Spec), Loc), - Attribute_Name => - Name_Version)); + if Nkind (Parameter_Type (First_Parameter)) = N_Access_Definition + and then Chars (Defining_Identifier (First_Parameter)) = Name_uS + then + For_RAS := True; + end if; - Append_To (Register_Pkg_Actuals, - -- Subp_Info - Make_Attribute_Reference (Loc, - Prefix => - New_Occurrence_Of (Subp_Info_Array, Loc), - Attribute_Name => - Name_Address)); + -- Loop through the parameters and add them to the right list - Append_To (Register_Pkg_Actuals, - -- Subp_Info_Len - Make_Attribute_Reference (Loc, - Prefix => - New_Occurrence_Of (Subp_Info_Array, Loc), - Attribute_Name => - Name_Length)); + Current_Parameter := First_Parameter; + while Present (Current_Parameter) loop + if (Nkind (Parameter_Type (Current_Parameter)) = N_Access_Definition + or else + Is_Constrained (Etype (Parameter_Type (Current_Parameter))) + or else + Is_Elementary_Type (Etype (Parameter_Type (Current_Parameter)))) + and then not (For_RAS and then Current_Parameter = First_Parameter) + then + Append_To (Constrained_List, New_Copy (Current_Parameter)); + else + Append_To (Unconstrained_List, New_Copy (Current_Parameter)); + end if; - Dummy_Register_Body := - Make_Package_Body (Loc, - Defining_Unit_Name => - Make_Defining_Identifier (Loc, Dummy_Register_Name), - Declarations => No_List, + Next (Current_Parameter); + end loop; - Handled_Statement_Sequence => - Make_Handled_Sequence_Of_Statements (Loc, - Statements => New_List ( - Make_Procedure_Call_Statement (Loc, - Name => - New_Occurrence_Of (RTE (RE_Register_Receiving_Stub), Loc), + -- Unconstrained parameters are returned first - Parameter_Associations => Register_Pkg_Actuals)))); + Append_List_To (Unconstrained_List, Constrained_List); - Append_To (Decls, Dummy_Register_Body); - Analyze (Dummy_Register_Body); - end Add_Receiving_Stubs_To_Declarations; + return Unconstrained_List; + end Build_Ordered_Parameters_List; - ------------------- - -- Add_Stub_Type -- - ------------------- + ---------------------------------- + -- Build_Passive_Partition_Stub -- + ---------------------------------- - procedure Add_Stub_Type - (Designated_Type : Entity_Id; - RACW_Type : Entity_Id; - Decls : List_Id; - Stub_Type : out Entity_Id; - Stub_Type_Access : out Entity_Id; - Object_RPC_Receiver : out Entity_Id; - Existing : out Boolean) - is - Loc : constant Source_Ptr := Sloc (RACW_Type); + procedure Build_Passive_Partition_Stub (U : Node_Id) is + Pkg_Spec : Node_Id; + Pkg_Name : String_Id; + L : List_Id; + Reg : Node_Id; + Loc : constant Source_Ptr := Sloc (U); - Stub_Elements : constant Stub_Structure := - Stubs_Table.Get (Designated_Type); + begin + -- Verify that the implementation supports distribution, by accessing + -- a type defined in the proper version of system.rpc - Stub_Type_Declaration : Node_Id; - Stub_Type_Access_Declaration : Node_Id; - Object_RPC_Receiver_Declaration : Node_Id; + declare + Dist_OK : Entity_Id; + pragma Warnings (Off, Dist_OK); + begin + Dist_OK := RTE (RE_Params_Stream_Type); + end; - RPC_Receiver_Stream : Entity_Id; - RPC_Receiver_Result : Entity_Id; + -- Use body if present, spec otherwise - begin - if Stub_Elements /= Empty_Stub_Structure then - Stub_Type := Stub_Elements.Stub_Type; - Stub_Type_Access := Stub_Elements.Stub_Type_Access; - Object_RPC_Receiver := Stub_Elements.Object_RPC_Receiver; - Existing := True; - return; + if Nkind (U) = N_Package_Declaration then + Pkg_Spec := Specification (U); + L := Visible_Declarations (Pkg_Spec); + else + Pkg_Spec := Parent (Corresponding_Spec (U)); + L := Declarations (U); end if; - Existing := False; - Stub_Type := - Make_Defining_Identifier (Loc, New_Internal_Name ('S')); - Stub_Type_Access := - Make_Defining_Identifier (Loc, New_Internal_Name ('S')); - Object_RPC_Receiver := - Make_Defining_Identifier (Loc, New_Internal_Name ('P')); - RPC_Receiver_Stream := - Make_Defining_Identifier (Loc, New_Internal_Name ('S')); - RPC_Receiver_Result := - Make_Defining_Identifier (Loc, New_Internal_Name ('S')); - Stubs_Table.Set (Designated_Type, - (Stub_Type => Stub_Type, - Stub_Type_Access => Stub_Type_Access, - Object_RPC_Receiver => Object_RPC_Receiver, - RPC_Receiver_Stream => RPC_Receiver_Stream, - RPC_Receiver_Result => RPC_Receiver_Result, - RACW_Type => RACW_Type)); - - -- The stub type definition below must match exactly the one in - -- s-parint.ads, since unchecked conversions will be used in - -- s-parint.adb to modify pointers passed to Get_Unique_Remote_Pointer. - - Stub_Type_Declaration := - Make_Full_Type_Declaration (Loc, - Defining_Identifier => Stub_Type, - Type_Definition => - Make_Record_Definition (Loc, - Tagged_Present => True, - Limited_Present => True, - Component_List => - Make_Component_List (Loc, - Component_Items => New_List ( + Get_Library_Unit_Name_String (Pkg_Spec); + Pkg_Name := String_From_Name_Buffer; + Reg := + Make_Procedure_Call_Statement (Loc, + Name => + New_Occurrence_Of (RTE (RE_Register_Passive_Package), Loc), + Parameter_Associations => New_List ( + Make_String_Literal (Loc, Pkg_Name), + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Defining_Entity (Pkg_Spec), Loc), + Attribute_Name => + Name_Version))); + Append_To (L, Reg); + Analyze (Reg); + end Build_Passive_Partition_Stub; - Make_Component_Declaration (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, Name_Origin), - Component_Definition => - Make_Component_Definition (Loc, - Aliased_Present => False, - Subtype_Indication => - New_Occurrence_Of (RTE (RE_Partition_ID), Loc))), + ---------------------------------------- + -- Build_Remote_Subprogram_Proxy_Type -- + ---------------------------------------- - Make_Component_Declaration (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, Name_Receiver), - Component_Definition => - Make_Component_Definition (Loc, - Aliased_Present => False, - Subtype_Indication => - New_Occurrence_Of (RTE (RE_Unsigned_64), Loc))), + function Build_Remote_Subprogram_Proxy_Type + (Loc : Source_Ptr; + ACR_Expression : Node_Id) return Node_Id + is + begin + return + Make_Record_Definition (Loc, + Tagged_Present => True, + Limited_Present => True, + Component_List => + Make_Component_List (Loc, - Make_Component_Declaration (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, Name_Addr), - Component_Definition => - Make_Component_Definition (Loc, - Aliased_Present => False, - Subtype_Indication => - New_Occurrence_Of (RTE (RE_Unsigned_64), Loc))), + Component_Items => New_List ( + Make_Component_Declaration (Loc, + Make_Defining_Identifier (Loc, + Name_All_Calls_Remote), + Make_Component_Definition (Loc, + Subtype_Indication => + New_Occurrence_Of (Standard_Boolean, Loc)), + ACR_Expression), - Make_Component_Declaration (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, Name_Asynchronous), - Component_Definition => - Make_Component_Definition (Loc, - Aliased_Present => False, - Subtype_Indication => - New_Occurrence_Of (Standard_Boolean, Loc))))))); + Make_Component_Declaration (Loc, + Make_Defining_Identifier (Loc, + Name_Receiver), + Make_Component_Definition (Loc, + Subtype_Indication => + New_Occurrence_Of (RTE (RE_Address), Loc)), + New_Occurrence_Of (RTE (RE_Null_Address), Loc)), - Append_To (Decls, Stub_Type_Declaration); - Analyze (Stub_Type_Declaration); + Make_Component_Declaration (Loc, + Make_Defining_Identifier (Loc, + Name_Subp_Id), + Make_Component_Definition (Loc, + Subtype_Indication => + New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc)))))); + end Build_Remote_Subprogram_Proxy_Type; - -- This is in no way a type derivation, but we fake it to make - -- sure that the dispatching table gets built with the corresponding - -- primitive operations at the right place. + ----------------------------- + -- Build_RPC_Receiver_Body -- + ----------------------------- - Derive_Subprograms (Parent_Type => Designated_Type, - Derived_Type => Stub_Type); + procedure Build_RPC_Receiver_Body + (RPC_Receiver : Entity_Id; + Stream : out Entity_Id; + Result : out Entity_Id; + Subp_Id : out Entity_Id; + Stmts : out List_Id; + Decl : out Node_Id) + is + Loc : constant Source_Ptr := Sloc (RPC_Receiver); - Stub_Type_Access_Declaration := - Make_Full_Type_Declaration (Loc, - Defining_Identifier => Stub_Type_Access, - Type_Definition => - Make_Access_To_Object_Definition (Loc, - All_Present => True, - Subtype_Indication => New_Occurrence_Of (Stub_Type, Loc))); + RPC_Receiver_Spec : Node_Id; + RPC_Receiver_Decls : List_Id; + begin + Stream := + Make_Defining_Identifier (Loc, Name_S); + Result := + Make_Defining_Identifier (Loc, Name_R); - Append_To (Decls, Stub_Type_Access_Declaration); - Analyze (Stub_Type_Access_Declaration); + RPC_Receiver_Spec := + Build_RPC_Receiver_Specification + (RPC_Receiver => RPC_Receiver, + Stream_Parameter => Stream, + Result_Parameter => Result); - Object_RPC_Receiver_Declaration := - Make_Subprogram_Declaration (Loc, - Build_RPC_Receiver_Specification ( - RPC_Receiver => Object_RPC_Receiver, - Stream_Parameter => RPC_Receiver_Stream, - Result_Parameter => RPC_Receiver_Result)); + Subp_Id := + Make_Defining_Identifier (Loc, New_Internal_Name ('P')); - Append_To (Decls, Object_RPC_Receiver_Declaration); - end Add_Stub_Type; + -- Subp_Id may not be a constant, because in the case of the RPC + -- receiver for an RCI package, when a call is received from a RAS + -- dereference, it will be assigned during subsequent processing. - --------------------------------- - -- Build_General_Calling_Stubs -- - --------------------------------- + RPC_Receiver_Decls := New_List ( + Make_Object_Declaration (Loc, + Defining_Identifier => Subp_Id, + Object_Definition => + New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc), + Expression => + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc), + Attribute_Name => Name_Input, + Expressions => New_List ( + New_Occurrence_Of (Stream, Loc))))); - procedure Build_General_Calling_Stubs - (Decls : List_Id; - Statements : List_Id; - Target_Partition : Entity_Id; - RPC_Receiver : Node_Id; - Subprogram_Id : Node_Id; - Asynchronous : Node_Id := Empty; - Is_Known_Asynchronous : Boolean := False; - Is_Known_Non_Asynchronous : Boolean := False; - Is_Function : Boolean; - Spec : Node_Id; - Stub_Type : Entity_Id := Empty; - RACW_Type : Entity_Id := Empty; - Nod : Node_Id) - is - Loc : constant Source_Ptr := Sloc (Nod); + Stmts := New_List; - Stream_Parameter : Node_Id; - -- Name of the stream used to transmit parameters to the remote package + Decl := + Make_Subprogram_Body (Loc, + Specification => RPC_Receiver_Spec, + Declarations => RPC_Receiver_Decls, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Stmts)); + end Build_RPC_Receiver_Body; - Result_Parameter : Node_Id; - -- Name of the result parameter (in non-APC cases) which get the - -- result of the remote subprogram. + -------------------------------------- + -- Build_RPC_Receiver_Specification -- + -------------------------------------- - Exception_Return_Parameter : Node_Id; - -- Name of the parameter which will hold the exception sent by the - -- remote subprogram. + function Build_RPC_Receiver_Specification + (RPC_Receiver : Entity_Id; + Stream_Parameter : Entity_Id; + Result_Parameter : Entity_Id) return Node_Id + is + Loc : constant Source_Ptr := Sloc (RPC_Receiver); - Current_Parameter : Node_Id; - -- Current parameter being handled + begin + return + Make_Procedure_Specification (Loc, + Defining_Unit_Name => RPC_Receiver, + Parameter_Specifications => New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => Stream_Parameter, + Parameter_Type => + Make_Access_Definition (Loc, + Subtype_Mark => + New_Occurrence_Of (RTE (RE_Params_Stream_Type), Loc))), - Ordered_Parameters_List : constant List_Id := - Build_Ordered_Parameters_List (Spec); + Make_Parameter_Specification (Loc, + Defining_Identifier => Result_Parameter, + Parameter_Type => + Make_Access_Definition (Loc, + Subtype_Mark => + New_Occurrence_Of + (RTE (RE_Params_Stream_Type), Loc))))); + end Build_RPC_Receiver_Specification; - Asynchronous_Statements : List_Id := No_List; - Non_Asynchronous_Statements : List_Id := No_List; - -- Statements specifics to the Asynchronous/Non-Asynchronous cases + ------------------------------------ + -- Build_Subprogram_Calling_Stubs -- + ------------------------------------ - Extra_Formal_Statements : constant List_Id := New_List; - -- List of statements for extra formal parameters. It will appear after - -- the regular statements for writing out parameters. + function Build_Subprogram_Calling_Stubs + (Vis_Decl : Node_Id; + Subp_Id : Node_Id; + Asynchronous : Boolean; + Dynamically_Asynchronous : Boolean := False; + Stub_Type : Entity_Id := Empty; + RACW_Type : Entity_Id := Empty; + Locator : Entity_Id := Empty; + New_Name : Name_Id := No_Name) return Node_Id + is + Loc : constant Source_Ptr := Sloc (Vis_Decl); - pragma Warnings (Off, RACW_Type); - -- Unreferenced formal parameter. + Target_Partition : Node_Id; + -- Contains the name of the target partition - begin - -- The general form of a calling stub for a given subprogram is: + Decls : constant List_Id := New_List; + Statements : constant List_Id := New_List; - -- procedure X (...) is - -- P : constant Partition_ID := RCI_Cache.Get_Active_Partition_ID; - -- Stream, Result : aliased System.RPC.Params_Stream_Type (0); - -- begin - -- Put_Package_RPC_Receiver_In_Stream; (the package RPC receiver - -- comes from RCI_Cache.Get_RCI_Package_Receiver) - -- Put_Subprogram_Id_In_Stream; - -- Put_Parameters_In_Stream; - -- Do_RPC (Stream, Result); - -- Read_Exception_Occurrence_From_Result; Raise_It; - -- Read_Out_Parameters_And_Function_Return_From_Stream; - -- end X; + Subp_Spec : Node_Id; + -- The specification of the body - -- There are some variations: Do_APC is called for an asynchronous - -- procedure and the part after the call is completely ommitted - -- as well as the declaration of Result. For a function call, - -- 'Input is always used to read the result even if it is constrained. + Controlling_Parameter : Entity_Id := Empty; + RPC_Receiver : Node_Id; - Stream_Parameter := - Make_Defining_Identifier (Loc, New_Internal_Name ('S')); + Asynchronous_Expr : Node_Id := Empty; - Append_To (Decls, - Make_Object_Declaration (Loc, - Defining_Identifier => Stream_Parameter, - Aliased_Present => True, - Object_Definition => - Make_Subtype_Indication (Loc, - Subtype_Mark => - New_Occurrence_Of (RTE (RE_Params_Stream_Type), Loc), - Constraint => - Make_Index_Or_Discriminant_Constraint (Loc, - Constraints => - New_List (Make_Integer_Literal (Loc, 0)))))); + RCI_Locator : Entity_Id; - if not Is_Known_Asynchronous then - Result_Parameter := - Make_Defining_Identifier (Loc, New_Internal_Name ('R')); + Spec_To_Use : Node_Id; - Append_To (Decls, - Make_Object_Declaration (Loc, - Defining_Identifier => Result_Parameter, - Aliased_Present => True, - Object_Definition => - Make_Subtype_Indication (Loc, - Subtype_Mark => - New_Occurrence_Of (RTE (RE_Params_Stream_Type), Loc), - Constraint => - Make_Index_Or_Discriminant_Constraint (Loc, - Constraints => - New_List (Make_Integer_Literal (Loc, 0)))))); - - Exception_Return_Parameter := - Make_Defining_Identifier (Loc, New_Internal_Name ('E')); - - Append_To (Decls, - Make_Object_Declaration (Loc, - Defining_Identifier => Exception_Return_Parameter, - Object_Definition => - New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc))); - - else - Result_Parameter := Empty; - Exception_Return_Parameter := Empty; - end if; + procedure Insert_Partition_Check (Parameter : Node_Id); + -- Check that the parameter has been elaborated on the same partition + -- than the controlling parameter (E.4(19)). - -- Put first the RPC receiver corresponding to the remote package + ---------------------------- + -- Insert_Partition_Check -- + ---------------------------- - Append_To (Statements, - Make_Attribute_Reference (Loc, - Prefix => - New_Occurrence_Of (RTE (RE_Unsigned_64), Loc), - Attribute_Name => Name_Write, - Expressions => New_List ( - Make_Attribute_Reference (Loc, - Prefix => - New_Occurrence_Of (Stream_Parameter, Loc), - Attribute_Name => - Name_Access), - RPC_Receiver))); + procedure Insert_Partition_Check (Parameter : Node_Id) is + Parameter_Entity : constant Entity_Id := + Defining_Identifier (Parameter); - -- Then put the Subprogram_Id of the subprogram we want to call in - -- the stream. + Condition : Node_Id; - Append_To (Statements, - Make_Attribute_Reference (Loc, - Prefix => - New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc), - Attribute_Name => - Name_Write, - Expressions => New_List ( - Make_Attribute_Reference (Loc, - Prefix => - New_Occurrence_Of (Stream_Parameter, Loc), - Attribute_Name => Name_Access), - Subprogram_Id))); + begin + -- The expression that will be built is of the form: + -- if not (Parameter in Stub_Type and then + -- Parameter.Origin = Controlling.Origin) + -- then + -- raise Constraint_Error; + -- end if; - Current_Parameter := First (Ordered_Parameters_List); - while Current_Parameter /= Empty loop - declare - Typ : constant Node_Id := - Parameter_Type (Current_Parameter); - Etyp : Entity_Id; - Constrained : Boolean; - Value : Node_Id; - Extra_Parameter : Entity_Id; + -- Condition contains the reversed condition. We do not check that + -- Parameter is in Stub_Type since such a check has been inserted + -- at the point of call already (a tag check since we have multiple + -- controlling operands). - begin - if Is_RACW_Controlling_Formal (Current_Parameter, Stub_Type) then + Condition := + Make_Op_Eq (Loc, + Left_Opnd => + Make_Selected_Component (Loc, + Prefix => + New_Occurrence_Of (Parameter_Entity, Loc), + Selector_Name => + Make_Identifier (Loc, Name_Origin)), - -- In the case of a controlling formal argument, we marshall - -- its addr field rather than the local stub. + Right_Opnd => + Make_Selected_Component (Loc, + Prefix => + New_Occurrence_Of (Controlling_Parameter, Loc), + Selector_Name => + Make_Identifier (Loc, Name_Origin))); - Append_To (Statements, - Pack_Node_Into_Stream (Loc, - Stream => Stream_Parameter, - Object => - Make_Selected_Component (Loc, - Prefix => - New_Occurrence_Of ( - Defining_Identifier (Current_Parameter), Loc), - Selector_Name => - Make_Identifier (Loc, Name_Addr)), - Etyp => RTE (RE_Unsigned_64))); + Append_To (Decls, + Make_Raise_Constraint_Error (Loc, + Condition => + Make_Op_Not (Loc, Right_Opnd => Condition), + Reason => CE_Partition_Check_Failed)); + end Insert_Partition_Check; - else - Value := New_Occurrence_Of - (Defining_Identifier (Current_Parameter), Loc); + -- Start of processing for Build_Subprogram_Calling_Stubs - -- Access type parameters are transmitted as in out - -- parameters. However, a dereference is needed so that - -- we marshall the designated object. + begin + Target_Partition := + Make_Defining_Identifier (Loc, New_Internal_Name ('P')); - if Nkind (Typ) = N_Access_Definition then - Value := Make_Explicit_Dereference (Loc, Value); - Etyp := Etype (Subtype_Mark (Typ)); - else - Etyp := Etype (Typ); - end if; + Subp_Spec := Copy_Specification (Loc, + Spec => Specification (Vis_Decl), + New_Name => New_Name); - Constrained := - Is_Constrained (Etyp) or else Is_Elementary_Type (Etyp); + if Locator = Empty then + RCI_Locator := RCI_Cache; + Spec_To_Use := Specification (Vis_Decl); + else + RCI_Locator := Locator; + Spec_To_Use := Subp_Spec; + end if; - -- Any parameter but unconstrained out parameters are - -- transmitted to the peer. + -- Find a controlling argument if we have a stub type. Also check + -- if this subprogram can be made asynchronous. - if In_Present (Current_Parameter) - or else not Out_Present (Current_Parameter) - or else not Constrained + if Present (Stub_Type) + and then Present (Parameter_Specifications (Spec_To_Use)) + then + declare + Current_Parameter : Node_Id := + First (Parameter_Specifications + (Spec_To_Use)); + begin + while Present (Current_Parameter) loop + if + Is_RACW_Controlling_Formal (Current_Parameter, Stub_Type) then - Append_To (Statements, - Make_Attribute_Reference (Loc, - Prefix => - New_Occurrence_Of (Etyp, Loc), - Attribute_Name => Output_From_Constrained (Constrained), - Expressions => New_List ( - Make_Attribute_Reference (Loc, - Prefix => - New_Occurrence_Of (Stream_Parameter, Loc), - Attribute_Name => Name_Access), - Value))); + if Controlling_Parameter = Empty then + Controlling_Parameter := + Defining_Identifier (Current_Parameter); + else + Insert_Partition_Check (Current_Parameter); + end if; end if; - end if; - - -- If the current parameter has a dynamic constrained status, - -- then this status is transmitted as well. - -- This should be done for accessibility as well ??? - - if Nkind (Typ) /= N_Access_Definition - and then Need_Extra_Constrained (Current_Parameter) - then - -- In this block, we do not use the extra formal that has been - -- created because it does not exist at the time of expansion - -- when building calling stubs for remote access to subprogram - -- types. We create an extra variable of this type and push it - -- in the stream after the regular parameters. - - Extra_Parameter := Make_Defining_Identifier - (Loc, New_Internal_Name ('P')); - - Append_To (Decls, - Make_Object_Declaration (Loc, - Defining_Identifier => Extra_Parameter, - Constant_Present => True, - Object_Definition => - New_Occurrence_Of (Standard_Boolean, Loc), - Expression => - Make_Attribute_Reference (Loc, - Prefix => - New_Occurrence_Of ( - Defining_Identifier (Current_Parameter), Loc), - Attribute_Name => Name_Constrained))); - - Append_To (Extra_Formal_Statements, - Make_Attribute_Reference (Loc, - Prefix => - New_Occurrence_Of (Standard_Boolean, Loc), - Attribute_Name => - Name_Write, - Expressions => New_List ( - Make_Attribute_Reference (Loc, - Prefix => - New_Occurrence_Of (Stream_Parameter, Loc), - Attribute_Name => - Name_Access), - New_Occurrence_Of (Extra_Parameter, Loc)))); - end if; - Next (Current_Parameter); + Next (Current_Parameter); + end loop; end; - end loop; + end if; - -- Append the formal statements list to the statements + if Present (Stub_Type) then + pragma Assert (Present (Controlling_Parameter)); - Append_List_To (Statements, Extra_Formal_Statements); + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Target_Partition, + Constant_Present => True, + Object_Definition => + New_Occurrence_Of (RTE (RE_Partition_ID), Loc), - if not Is_Known_Non_Asynchronous then + Expression => + Make_Selected_Component (Loc, + Prefix => + New_Occurrence_Of (Controlling_Parameter, Loc), + Selector_Name => + Make_Identifier (Loc, Name_Origin)))); - -- Build the call to System.RPC.Do_APC + RPC_Receiver := + Make_Selected_Component (Loc, + Prefix => + New_Occurrence_Of (Controlling_Parameter, Loc), + Selector_Name => + Make_Identifier (Loc, Name_Receiver)); - Asynchronous_Statements := New_List ( - Make_Procedure_Call_Statement (Loc, - Name => - New_Occurrence_Of (RTE (RE_Do_Apc), Loc), - Parameter_Associations => New_List ( - New_Occurrence_Of (Target_Partition, Loc), - Make_Attribute_Reference (Loc, - Prefix => - New_Occurrence_Of (Stream_Parameter, Loc), - Attribute_Name => - Name_Access)))); else - Asynchronous_Statements := No_List; - end if; - - if not Is_Known_Asynchronous then + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Target_Partition, + Constant_Present => True, + Object_Definition => + New_Occurrence_Of (RTE (RE_Partition_ID), Loc), - -- Build the call to System.RPC.Do_RPC + Expression => + Make_Function_Call (Loc, + Name => Make_Selected_Component (Loc, + Prefix => + Make_Identifier (Loc, Chars (RCI_Locator)), + Selector_Name => + Make_Identifier (Loc, Name_Get_Active_Partition_ID))))); - Non_Asynchronous_Statements := New_List ( - Make_Procedure_Call_Statement (Loc, - Name => - New_Occurrence_Of (RTE (RE_Do_Rpc), Loc), - Parameter_Associations => New_List ( - New_Occurrence_Of (Target_Partition, Loc), + RPC_Receiver := + Make_Selected_Component (Loc, + Prefix => + Make_Identifier (Loc, Chars (RCI_Locator)), + Selector_Name => + Make_Identifier (Loc, Name_Get_RCI_Package_Receiver)); + end if; - Make_Attribute_Reference (Loc, - Prefix => - New_Occurrence_Of (Stream_Parameter, Loc), - Attribute_Name => - Name_Access), + if Dynamically_Asynchronous then + Asynchronous_Expr := + Make_Selected_Component (Loc, + Prefix => + New_Occurrence_Of (Controlling_Parameter, Loc), + Selector_Name => + Make_Identifier (Loc, Name_Asynchronous)); + end if; - Make_Attribute_Reference (Loc, - Prefix => - New_Occurrence_Of (Result_Parameter, Loc), - Attribute_Name => - Name_Access)))); + Build_General_Calling_Stubs + (Decls => Decls, + Statements => Statements, + Target_Partition => Target_Partition, + RPC_Receiver => RPC_Receiver, + Subprogram_Id => Subp_Id, + Asynchronous => Asynchronous_Expr, + Is_Known_Asynchronous => Asynchronous + and then not Dynamically_Asynchronous, + Is_Known_Non_Asynchronous + => not Asynchronous + and then not Dynamically_Asynchronous, + Is_Function => Nkind (Spec_To_Use) = + N_Function_Specification, + Spec => Spec_To_Use, + Stub_Type => Stub_Type, + RACW_Type => RACW_Type, + Nod => Vis_Decl); - -- Read the exception occurrence from the result stream and - -- reraise it. It does no harm if this is a Null_Occurrence since - -- this does nothing. + RCI_Calling_Stubs_Table.Set + (Defining_Unit_Name (Specification (Vis_Decl)), + Defining_Unit_Name (Spec_To_Use)); - Append_To (Non_Asynchronous_Statements, - Make_Attribute_Reference (Loc, - Prefix => - New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc), + return + Make_Subprogram_Body (Loc, + Specification => Subp_Spec, + Declarations => Decls, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, Statements)); + end Build_Subprogram_Calling_Stubs; - Attribute_Name => - Name_Read, + ------------------------- + -- Build_Subprogram_Id -- + ------------------------- - Expressions => New_List ( - Make_Attribute_Reference (Loc, - Prefix => - New_Occurrence_Of (Result_Parameter, Loc), - Attribute_Name => - Name_Access), - New_Occurrence_Of (Exception_Return_Parameter, Loc)))); + function Build_Subprogram_Id + (Loc : Source_Ptr; + E : Entity_Id) return Node_Id + is + begin + return Make_Integer_Literal (Loc, Get_Subprogram_Id (E)); + end Build_Subprogram_Id; - Append_To (Non_Asynchronous_Statements, - Make_Procedure_Call_Statement (Loc, - Name => - New_Occurrence_Of (RTE (RE_Reraise_Occurrence), Loc), - Parameter_Associations => New_List ( - New_Occurrence_Of (Exception_Return_Parameter, Loc)))); + -------------------------------------- + -- Build_Subprogram_Receiving_Stubs -- + -------------------------------------- - if Is_Function then + function Build_Subprogram_Receiving_Stubs + (Vis_Decl : Node_Id; + Asynchronous : Boolean; + Dynamically_Asynchronous : Boolean := False; + Stub_Type : Entity_Id := Empty; + RACW_Type : Entity_Id := Empty; + Parent_Primitive : Entity_Id := Empty) return Node_Id + is + Loc : constant Source_Ptr := Sloc (Vis_Decl); - -- If this is a function call, then read the value and return - -- it. The return value is written/read using 'Output/'Input. + Stream_Parameter : Node_Id; + Result_Parameter : Node_Id; + -- See explanations of these in Build_Subprogram_Calling_Stubs - Append_To (Non_Asynchronous_Statements, - Make_Tag_Check (Loc, - Make_Return_Statement (Loc, - Expression => - Make_Attribute_Reference (Loc, - Prefix => - New_Occurrence_Of ( - Etype (Subtype_Mark (Spec)), Loc), + Decls : constant List_Id := New_List; + -- All the parameters will get declared before calling the real + -- subprograms. Also the out parameters will be declared. - Attribute_Name => Name_Input, + Statements : constant List_Id := New_List; - Expressions => New_List ( - Make_Attribute_Reference (Loc, - Prefix => - New_Occurrence_Of (Result_Parameter, Loc), - Attribute_Name => Name_Access)))))); + Extra_Formal_Statements : constant List_Id := New_List; + -- Statements concerning extra formal parameters - else - -- Loop around parameters and assign out (or in out) parameters. - -- In the case of RACW, controlling arguments cannot possibly - -- have changed since they are remote, so we do not read them - -- from the stream. + After_Statements : constant List_Id := New_List; + -- Statements to be executed after the subprogram call - Current_Parameter := First (Ordered_Parameters_List); - while Current_Parameter /= Empty loop - declare - Typ : constant Node_Id := - Parameter_Type (Current_Parameter); - Etyp : Entity_Id; - Value : Node_Id; + Inner_Decls : List_Id := No_List; + -- In case of a function, the inner declarations are needed since + -- the result may be unconstrained. - begin - Value := - New_Occurrence_Of - (Defining_Identifier (Current_Parameter), Loc); + Excep_Handlers : List_Id := No_List; + Excep_Choice : Entity_Id; + Excep_Code : List_Id; - if Nkind (Typ) = N_Access_Definition then - Value := Make_Explicit_Dereference (Loc, Value); - Etyp := Etype (Subtype_Mark (Typ)); - else - Etyp := Etype (Typ); - end if; + Parameter_List : constant List_Id := New_List; + -- List of parameters to be passed to the subprogram - if (Out_Present (Current_Parameter) - or else Nkind (Typ) = N_Access_Definition) - and then Etyp /= Stub_Type - then - Append_To (Non_Asynchronous_Statements, - Make_Attribute_Reference (Loc, - Prefix => - New_Occurrence_Of (Etyp, Loc), + Current_Parameter : Node_Id; - Attribute_Name => Name_Read, + Ordered_Parameters_List : constant List_Id := + Build_Ordered_Parameters_List + (Specification (Vis_Decl)); - Expressions => New_List ( - Make_Attribute_Reference (Loc, - Prefix => - New_Occurrence_Of (Result_Parameter, Loc), - Attribute_Name => - Name_Access), - Value))); - end if; - end; + Subp_Spec : Node_Id; + -- Subprogram specification - Next (Current_Parameter); - end loop; - end if; - end if; + Called_Subprogram : Node_Id; + -- The subprogram to call - if Is_Known_Asynchronous then - Append_List_To (Statements, Asynchronous_Statements); + Null_Raise_Statement : Node_Id; - elsif Is_Known_Non_Asynchronous then - Append_List_To (Statements, Non_Asynchronous_Statements); + Dynamic_Async : Entity_Id; + begin + if Present (RACW_Type) then + Called_Subprogram := + New_Occurrence_Of (Parent_Primitive, Loc); else - pragma Assert (Asynchronous /= Empty); - Prepend_To (Asynchronous_Statements, - Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (Standard_Boolean, Loc), - Attribute_Name => Name_Write, - Expressions => New_List ( - Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (Stream_Parameter, Loc), - Attribute_Name => Name_Access), - New_Occurrence_Of (Standard_True, Loc)))); + Called_Subprogram := + New_Occurrence_Of ( + Defining_Unit_Name (Specification (Vis_Decl)), Loc); + end if; - Prepend_To (Non_Asynchronous_Statements, - Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (Standard_Boolean, Loc), - Attribute_Name => Name_Write, - Expressions => New_List ( - Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (Stream_Parameter, Loc), - Attribute_Name => Name_Access), - New_Occurrence_Of (Standard_False, Loc)))); + Stream_Parameter := + Make_Defining_Identifier (Loc, New_Internal_Name ('S')); - Append_To (Statements, - Make_Implicit_If_Statement (Nod, - Condition => Asynchronous, - Then_Statements => Asynchronous_Statements, - Else_Statements => Non_Asynchronous_Statements)); + if Dynamically_Asynchronous then + Dynamic_Async := + Make_Defining_Identifier (Loc, New_Internal_Name ('S')); + else + Dynamic_Async := Empty; end if; - end Build_General_Calling_Stubs; - ------------------------------ - -- Build_Get_Unique_RP_Call -- - ------------------------------ + if not Asynchronous or else Dynamically_Asynchronous then + Result_Parameter := + Make_Defining_Identifier (Loc, New_Internal_Name ('S')); - function Build_Get_Unique_RP_Call - (Loc : Source_Ptr; - Pointer : Entity_Id; - Stub_Type : Entity_Id) return List_Id - is - begin - return New_List ( - Make_Procedure_Call_Statement (Loc, - Name => - New_Occurrence_Of (RTE (RE_Get_Unique_Remote_Pointer), Loc), - Parameter_Associations => New_List ( - Unchecked_Convert_To (RTE (RE_RACW_Stub_Type_Access), - New_Occurrence_Of (Pointer, Loc)))), + -- The first statement after the subprogram call is a statement to + -- writes a Null_Occurrence into the result stream. - Make_Assignment_Statement (Loc, - Name => - Make_Selected_Component (Loc, - Prefix => - New_Occurrence_Of (Pointer, Loc), - Selector_Name => - New_Occurrence_Of (Tag_Component - (Designated_Type (Etype (Pointer))), Loc)), - Expression => - Make_Attribute_Reference (Loc, - Prefix => - New_Occurrence_Of (Stub_Type, Loc), - Attribute_Name => - Name_Tag))); + Null_Raise_Statement := + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc), + Attribute_Name => Name_Write, + Expressions => New_List ( + New_Occurrence_Of (Result_Parameter, Loc), + New_Occurrence_Of (RTE (RE_Null_Occurrence), Loc))); - -- Note: The assignment to Pointer._Tag is safe here because - -- we carefully ensured that Stub_Type has exactly the same layout - -- as System.Partition_Interface.RACW_Stub_Type. + if Dynamically_Asynchronous then + Null_Raise_Statement := + Make_Implicit_If_Statement (Vis_Decl, + Condition => + Make_Op_Not (Loc, New_Occurrence_Of (Dynamic_Async, Loc)), + Then_Statements => New_List (Null_Raise_Statement)); + end if; - end Build_Get_Unique_RP_Call; + Append_To (After_Statements, Null_Raise_Statement); - ---------------------------------------- - -- Build_Remote_Subprogram_Proxy_Type -- - ---------------------------------------- + else + Result_Parameter := Empty; + end if; - function Build_Remote_Subprogram_Proxy_Type - (Loc : Source_Ptr; - ACR_Expression : Node_Id) return Node_Id - is - begin - return - Make_Record_Definition (Loc, - Tagged_Present => True, - Limited_Present => True, - Component_List => - Make_Component_List (Loc, + -- Loop through every parameter and get its value from the stream. If + -- the parameter is unconstrained, then the parameter is read using + -- 'Input at the point of declaration. - Component_Items => New_List ( - Make_Component_Declaration (Loc, - Make_Defining_Identifier (Loc, - Name_All_Calls_Remote), - Make_Component_Definition (Loc, - Subtype_Indication => - New_Occurrence_Of (Standard_Boolean, Loc)), - ACR_Expression), + Current_Parameter := First (Ordered_Parameters_List); + while Present (Current_Parameter) loop + declare + Etyp : Entity_Id; + RACW_Controlling : Boolean; + Constrained : Boolean; + Object : Entity_Id; + Expr : Node_Id := Empty; - Make_Component_Declaration (Loc, - Make_Defining_Identifier (Loc, - Name_Receiver), - Make_Component_Definition (Loc, - Subtype_Indication => - New_Occurrence_Of (RTE (RE_Address), Loc)), - New_Occurrence_Of (RTE (RE_Null_Address), Loc)), + begin + Object := Make_Defining_Identifier (Loc, New_Internal_Name ('P')); + Set_Ekind (Object, E_Variable); - Make_Component_Declaration (Loc, - Make_Defining_Identifier (Loc, - Name_Subp_Id), - Make_Component_Definition (Loc, - Subtype_Indication => - New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc)))))); - end Build_Remote_Subprogram_Proxy_Type; + RACW_Controlling := + Is_RACW_Controlling_Formal (Current_Parameter, Stub_Type); - ----------------------------------- - -- Build_Ordered_Parameters_List -- - ----------------------------------- + if RACW_Controlling then - function Build_Ordered_Parameters_List (Spec : Node_Id) return List_Id is - Constrained_List : List_Id; - Unconstrained_List : List_Id; - Current_Parameter : Node_Id; + -- We have a controlling formal parameter. Read its address + -- rather than a real object. The address is in Unsigned_64 + -- form. - First_Parameter : Node_Id; - For_RAS : Boolean := False; + Etyp := RTE (RE_Unsigned_64); + else + Etyp := Etype (Parameter_Type (Current_Parameter)); + end if; - begin - if not Present (Parameter_Specifications (Spec)) then - return New_List; - end if; + Constrained := + Is_Constrained (Etyp) or else Is_Elementary_Type (Etyp); - Constrained_List := New_List; - Unconstrained_List := New_List; - First_Parameter := First (Parameter_Specifications (Spec)); + if In_Present (Current_Parameter) + or else not Out_Present (Current_Parameter) + or else not Constrained + or else RACW_Controlling + then + -- If an input parameter is contrained, then its reading is + -- deferred until the beginning of the subprogram body. If + -- it is unconstrained, then an expression is built for + -- the object declaration and the variable is set using + -- 'Input instead of 'Read. - if Nkind (Parameter_Type (First_Parameter)) = N_Access_Definition - and then Chars (Defining_Identifier (First_Parameter)) = Name_uS - then - For_RAS := True; - end if; + if Constrained and then not RACW_Controlling then + Append_To (Statements, + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Etyp, Loc), + Attribute_Name => Name_Read, + Expressions => New_List ( + New_Occurrence_Of (Stream_Parameter, Loc), + New_Occurrence_Of (Object, Loc)))); - -- Loop through the parameters and add them to the right list + else + Expr := Input_With_Tag_Check (Loc, + Var_Type => Etyp, + Stream => Stream_Parameter); + Append_To (Decls, Expr); + Expr := Make_Function_Call (Loc, + New_Occurrence_Of (Defining_Unit_Name + (Specification (Expr)), Loc)); + end if; + end if; - Current_Parameter := First_Parameter; - while Current_Parameter /= Empty loop - if (Nkind (Parameter_Type (Current_Parameter)) = N_Access_Definition - or else - Is_Constrained (Etype (Parameter_Type (Current_Parameter))) - or else - Is_Elementary_Type (Etype (Parameter_Type (Current_Parameter)))) - and then not (For_RAS and then Current_Parameter = First_Parameter) - then - Append_To (Constrained_List, New_Copy (Current_Parameter)); - else - Append_To (Unconstrained_List, New_Copy (Current_Parameter)); - end if; + -- If we do not have to output the current parameter, then + -- it can well be flagged as constant. This may allow further + -- optimizations done by the back end. - Next (Current_Parameter); - end loop; + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Object, + Constant_Present => + not Constrained and then not Out_Present (Current_Parameter), + Object_Definition => + New_Occurrence_Of (Etyp, Loc), + Expression => Expr)); - -- Unconstrained parameters are returned first + -- An out parameter may be written back using a 'Write + -- attribute instead of a 'Output because it has been + -- constrained by the parameter given to the caller. Note that + -- out controlling arguments in the case of a RACW are not put + -- back in the stream because the pointer on them has not + -- changed. - Append_List_To (Unconstrained_List, Constrained_List); + if Out_Present (Current_Parameter) + and then + Etype (Parameter_Type (Current_Parameter)) /= Stub_Type + then + Append_To (After_Statements, + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Etyp, Loc), + Attribute_Name => Name_Write, + Expressions => New_List ( + New_Occurrence_Of (Result_Parameter, Loc), + New_Occurrence_Of (Object, Loc)))); + end if; - return Unconstrained_List; - end Build_Ordered_Parameters_List; + if + Is_RACW_Controlling_Formal (Current_Parameter, Stub_Type) + then + if Nkind (Parameter_Type (Current_Parameter)) /= + N_Access_Definition + then + Append_To (Parameter_List, + Make_Parameter_Association (Loc, + Selector_Name => + New_Occurrence_Of ( + Defining_Identifier (Current_Parameter), Loc), + Explicit_Actual_Parameter => + Make_Explicit_Dereference (Loc, + Unchecked_Convert_To (RACW_Type, + OK_Convert_To (RTE (RE_Address), + New_Occurrence_Of (Object, Loc)))))); - ---------------------------------- - -- Build_Passive_Partition_Stub -- - ---------------------------------- + else + Append_To (Parameter_List, + Make_Parameter_Association (Loc, + Selector_Name => + New_Occurrence_Of ( + Defining_Identifier (Current_Parameter), Loc), + Explicit_Actual_Parameter => + Unchecked_Convert_To (RACW_Type, + OK_Convert_To (RTE (RE_Address), + New_Occurrence_Of (Object, Loc))))); + end if; - procedure Build_Passive_Partition_Stub (U : Node_Id) is - Pkg_Spec : Node_Id; - Pkg_Name : String_Id; - L : List_Id; - Reg : Node_Id; - Loc : constant Source_Ptr := Sloc (U); + else + Append_To (Parameter_List, + Make_Parameter_Association (Loc, + Selector_Name => + New_Occurrence_Of ( + Defining_Identifier (Current_Parameter), Loc), + Explicit_Actual_Parameter => + New_Occurrence_Of (Object, Loc))); + end if; - begin - -- Verify that the implementation supports distribution, by accessing - -- a type defined in the proper version of system.rpc + -- If the current parameter needs an extra formal, then read it + -- from the stream and set the corresponding semantic field in + -- the variable. If the kind of the parameter identifier is + -- E_Void, then this is a compiler generated parameter that + -- doesn't need an extra constrained status. - declare - Dist_OK : Entity_Id; - pragma Warnings (Off, Dist_OK); - begin - Dist_OK := RTE (RE_Params_Stream_Type); - end; + -- The case of Extra_Accessibility should also be handled ??? - -- Use body if present, spec otherwise + if Nkind (Parameter_Type (Current_Parameter)) /= + N_Access_Definition + and then + Ekind (Defining_Identifier (Current_Parameter)) /= E_Void + and then + Present (Extra_Constrained + (Defining_Identifier (Current_Parameter))) + then + declare + Extra_Parameter : constant Entity_Id := + Extra_Constrained + (Defining_Identifier + (Current_Parameter)); - if Nkind (U) = N_Package_Declaration then - Pkg_Spec := Specification (U); - L := Visible_Declarations (Pkg_Spec); - else - Pkg_Spec := Parent (Corresponding_Spec (U)); - L := Declarations (U); - end if; + Formal_Entity : constant Entity_Id := + Make_Defining_Identifier + (Loc, Chars (Extra_Parameter)); - Get_Pkg_Name_String (Pkg_Spec); - Pkg_Name := String_From_Name_Buffer; - Reg := - Make_Procedure_Call_Statement (Loc, - Name => - New_Occurrence_Of (RTE (RE_Register_Passive_Package), Loc), - Parameter_Associations => New_List ( - Make_String_Literal (Loc, Pkg_Name), - Make_Attribute_Reference (Loc, - Prefix => - New_Occurrence_Of (Defining_Entity (Pkg_Spec), Loc), - Attribute_Name => - Name_Version))); - Append_To (L, Reg); - Analyze (Reg); - end Build_Passive_Partition_Stub; + Formal_Type : constant Entity_Id := + Etype (Extra_Parameter); - -------------------------------------- - -- Build_RPC_Receiver_Specification -- - -------------------------------------- + begin + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Formal_Entity, + Object_Definition => + New_Occurrence_Of (Formal_Type, Loc))); - function Build_RPC_Receiver_Specification - (RPC_Receiver : Entity_Id; - Stream_Parameter : Entity_Id; - Result_Parameter : Entity_Id) return Node_Id - is - Loc : constant Source_Ptr := Sloc (RPC_Receiver); + Append_To (Extra_Formal_Statements, + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Formal_Type, Loc), + Attribute_Name => Name_Read, + Expressions => New_List ( + New_Occurrence_Of (Stream_Parameter, Loc), + New_Occurrence_Of (Formal_Entity, Loc)))); + Set_Extra_Constrained (Object, Formal_Entity); + end; + end if; + end; - begin - return - Make_Procedure_Specification (Loc, - Defining_Unit_Name => RPC_Receiver, - Parameter_Specifications => New_List ( - Make_Parameter_Specification (Loc, - Defining_Identifier => Stream_Parameter, - Parameter_Type => - Make_Access_Definition (Loc, - Subtype_Mark => - New_Occurrence_Of (RTE (RE_Params_Stream_Type), Loc))), + Next (Current_Parameter); + end loop; - Make_Parameter_Specification (Loc, - Defining_Identifier => Result_Parameter, - Parameter_Type => - Make_Access_Definition (Loc, - Subtype_Mark => - New_Occurrence_Of - (RTE (RE_Params_Stream_Type), Loc))))); - end Build_RPC_Receiver_Specification; + -- Append the formal statements list at the end of regular statements - ------------------------------------ - -- Build_Subprogram_Calling_Stubs -- - ------------------------------------ + Append_List_To (Statements, Extra_Formal_Statements); - function Build_Subprogram_Calling_Stubs - (Vis_Decl : Node_Id; - Subp_Id : Int; - Asynchronous : Boolean; - Dynamically_Asynchronous : Boolean := False; - Stub_Type : Entity_Id := Empty; - RACW_Type : Entity_Id := Empty; - Locator : Entity_Id := Empty; - New_Name : Name_Id := No_Name) return Node_Id - is - Loc : constant Source_Ptr := Sloc (Vis_Decl); + if Nkind (Specification (Vis_Decl)) = N_Function_Specification then - Target_Partition : Node_Id; - -- Contains the name of the target partition + -- The remote subprogram is a function. We build an inner block to + -- be able to hold a potentially unconstrained result in a variable. - Decls : constant List_Id := New_List; - Statements : constant List_Id := New_List; + declare + Etyp : constant Entity_Id := + Etype (Subtype_Mark (Specification (Vis_Decl))); + Result : constant Node_Id := + Make_Defining_Identifier (Loc, New_Internal_Name ('R')); - Subp_Spec : Node_Id; - -- The specification of the body + begin + Inner_Decls := New_List ( + Make_Object_Declaration (Loc, + Defining_Identifier => Result, + Constant_Present => True, + Object_Definition => New_Occurrence_Of (Etyp, Loc), + Expression => + Make_Function_Call (Loc, + Name => Called_Subprogram, + Parameter_Associations => Parameter_List))); - Controlling_Parameter : Entity_Id := Empty; - RPC_Receiver : Node_Id; + Append_To (After_Statements, + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Etyp, Loc), + Attribute_Name => Name_Output, + Expressions => New_List ( + New_Occurrence_Of (Result_Parameter, Loc), + New_Occurrence_Of (Result, Loc)))); + end; - Asynchronous_Expr : Node_Id := Empty; + Append_To (Statements, + Make_Block_Statement (Loc, + Declarations => Inner_Decls, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => After_Statements))); - RCI_Locator : Entity_Id; + else + -- The remote subprogram is a procedure. We do not need any inner + -- block in this case. - Spec_To_Use : Node_Id; + if Dynamically_Asynchronous then + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Dynamic_Async, + Object_Definition => + New_Occurrence_Of (Standard_Boolean, Loc))); - procedure Insert_Partition_Check (Parameter : Node_Id); - -- Check that the parameter has been elaborated on the same partition - -- than the controlling parameter (E.4(19)). + Append_To (Statements, + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Standard_Boolean, Loc), + Attribute_Name => Name_Read, + Expressions => New_List ( + New_Occurrence_Of (Stream_Parameter, Loc), + New_Occurrence_Of (Dynamic_Async, Loc)))); + end if; - ---------------------------- - -- Insert_Partition_Check -- - ---------------------------- + Append_To (Statements, + Make_Procedure_Call_Statement (Loc, + Name => Called_Subprogram, + Parameter_Associations => Parameter_List)); - procedure Insert_Partition_Check (Parameter : Node_Id) is - Parameter_Entity : constant Entity_Id := - Defining_Identifier (Parameter); - Condition : Node_Id; + Append_List_To (Statements, After_Statements); + end if; - Designated_Object : Node_Id; - pragma Warnings (Off, Designated_Object); - -- Is it really right that this is unreferenced ??? + if Asynchronous and then not Dynamically_Asynchronous then - begin - -- The expression that will be built is of the form: - -- if not (Parameter in Stub_Type and then - -- Parameter.Origin = Controlling.Origin) - -- then - -- raise Constraint_Error; - -- end if; + -- An asynchronous procedure does not want a Result parameter. Also + -- put an exception handler with an others clause that does nothing. - -- Condition contains the reversed condition. Also, Parameter is - -- dereferenced if it is an access type. We do not check that - -- Parameter is in Stub_Type since such a check has been inserted - -- at the point of call already (a tag check since we have multiple - -- controlling operands). + Subp_Spec := + Make_Procedure_Specification (Loc, + Defining_Unit_Name => + Make_Defining_Identifier (Loc, New_Internal_Name ('F')), + Parameter_Specifications => New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => Stream_Parameter, + Parameter_Type => + Make_Access_Definition (Loc, + Subtype_Mark => + New_Occurrence_Of (RTE (RE_Params_Stream_Type), Loc))))); - if Nkind (Parameter_Type (Parameter)) = N_Access_Definition then - Designated_Object := - Make_Explicit_Dereference (Loc, - Prefix => New_Occurrence_Of (Parameter_Entity, Loc)); - else - Designated_Object := New_Occurrence_Of (Parameter_Entity, Loc); - end if; + Excep_Handlers := New_List ( + Make_Exception_Handler (Loc, + Exception_Choices => + New_List (Make_Others_Choice (Loc)), + Statements => New_List ( + Make_Null_Statement (Loc)))); - Condition := - Make_Op_Eq (Loc, - Left_Opnd => - Make_Selected_Component (Loc, - Prefix => - New_Occurrence_Of (Parameter_Entity, Loc), - Selector_Name => - Make_Identifier (Loc, Name_Origin)), + else + -- In the other cases, if an exception is raised, then the + -- exception occurrence is copied into the output stream and + -- no other output parameter is written. - Right_Opnd => - Make_Selected_Component (Loc, - Prefix => - New_Occurrence_Of (Controlling_Parameter, Loc), - Selector_Name => - Make_Identifier (Loc, Name_Origin))); + Excep_Choice := + Make_Defining_Identifier (Loc, New_Internal_Name ('E')); - Append_To (Decls, - Make_Raise_Constraint_Error (Loc, - Condition => - Make_Op_Not (Loc, Right_Opnd => Condition), - Reason => CE_Partition_Check_Failed)); - end Insert_Partition_Check; + Excep_Code := New_List ( + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc), + Attribute_Name => Name_Write, + Expressions => New_List ( + New_Occurrence_Of (Result_Parameter, Loc), + New_Occurrence_Of (Excep_Choice, Loc)))); - -- Start of processing for Build_Subprogram_Calling_Stubs + if Dynamically_Asynchronous then + Excep_Code := New_List ( + Make_Implicit_If_Statement (Vis_Decl, + Condition => Make_Op_Not (Loc, + New_Occurrence_Of (Dynamic_Async, Loc)), + Then_Statements => Excep_Code)); + end if; - begin - Target_Partition := - Make_Defining_Identifier (Loc, New_Internal_Name ('P')); + Excep_Handlers := New_List ( + Make_Exception_Handler (Loc, + Choice_Parameter => Excep_Choice, + Exception_Choices => New_List (Make_Others_Choice (Loc)), + Statements => Excep_Code)); - Subp_Spec := Copy_Specification (Loc, - Spec => Specification (Vis_Decl), - New_Name => New_Name); + Subp_Spec := + Make_Procedure_Specification (Loc, + Defining_Unit_Name => + Make_Defining_Identifier (Loc, New_Internal_Name ('F')), - if Locator = Empty then - RCI_Locator := RCI_Cache; - Spec_To_Use := Specification (Vis_Decl); - else - RCI_Locator := Locator; - Spec_To_Use := Subp_Spec; + Parameter_Specifications => New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => Stream_Parameter, + Parameter_Type => + Make_Access_Definition (Loc, + Subtype_Mark => + New_Occurrence_Of (RTE (RE_Params_Stream_Type), Loc))), + + Make_Parameter_Specification (Loc, + Defining_Identifier => Result_Parameter, + Parameter_Type => + Make_Access_Definition (Loc, + Subtype_Mark => + New_Occurrence_Of (RTE (RE_Params_Stream_Type), Loc))))); end if; - -- Find a controlling argument if we have a stub type. Also check - -- if this subprogram can be made asynchronous. + return + Make_Subprogram_Body (Loc, + Specification => Subp_Spec, + Declarations => Decls, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Statements, + Exception_Handlers => Excep_Handlers)); + end Build_Subprogram_Receiving_Stubs; - if Stub_Type /= Empty - and then Present (Parameter_Specifications (Spec_To_Use)) - then - declare - Current_Parameter : Node_Id := - First (Parameter_Specifications - (Spec_To_Use)); - begin - while Current_Parameter /= Empty loop + ------------------------ + -- Copy_Specification -- + ------------------------ - if - Is_RACW_Controlling_Formal (Current_Parameter, Stub_Type) - then - if Controlling_Parameter = Empty then - Controlling_Parameter := - Defining_Identifier (Current_Parameter); - else - Insert_Partition_Check (Current_Parameter); - end if; - end if; + function Copy_Specification + (Loc : Source_Ptr; + Spec : Node_Id; + Object_Type : Entity_Id := Empty; + Stub_Type : Entity_Id := Empty; + New_Name : Name_Id := No_Name) return Node_Id + is + Parameters : List_Id := No_List; + + Current_Parameter : Node_Id; + Current_Identifier : Entity_Id; + Current_Type : Node_Id; + Current_Etype : Entity_Id; - Next (Current_Parameter); - end loop; - end; + Name_For_New_Spec : Name_Id; + + New_Identifier : Entity_Id; + + -- Comments needed in body below ??? + + begin + if New_Name = No_Name then + pragma Assert (Nkind (Spec) = N_Function_Specification + or else Nkind (Spec) = N_Procedure_Specification); + + Name_For_New_Spec := Chars (Defining_Unit_Name (Spec)); + else + Name_For_New_Spec := New_Name; end if; - if Stub_Type /= Empty then - pragma Assert (Controlling_Parameter /= Empty); + if Present (Parameter_Specifications (Spec)) then + Parameters := New_List; + Current_Parameter := First (Parameter_Specifications (Spec)); + while Present (Current_Parameter) loop + Current_Identifier := Defining_Identifier (Current_Parameter); + Current_Type := Parameter_Type (Current_Parameter); - Append_To (Decls, - Make_Object_Declaration (Loc, - Defining_Identifier => Target_Partition, - Constant_Present => True, - Object_Definition => - New_Occurrence_Of (RTE (RE_Partition_ID), Loc), + if Nkind (Current_Type) = N_Access_Definition then + Current_Etype := Entity (Subtype_Mark (Current_Type)); - Expression => - Make_Selected_Component (Loc, - Prefix => - New_Occurrence_Of (Controlling_Parameter, Loc), - Selector_Name => - Make_Identifier (Loc, Name_Origin)))); + if Present (Object_Type) then + pragma Assert ( + Root_Type (Current_Etype) = Root_Type (Object_Type)); + Current_Type := + Make_Access_Definition (Loc, + Subtype_Mark => New_Occurrence_Of (Stub_Type, Loc)); + else + Current_Type := + Make_Access_Definition (Loc, + Subtype_Mark => + New_Occurrence_Of (Current_Etype, Loc)); + end if; - RPC_Receiver := - Make_Selected_Component (Loc, - Prefix => - New_Occurrence_Of (Controlling_Parameter, Loc), - Selector_Name => - Make_Identifier (Loc, Name_Receiver)); + else + Current_Etype := Entity (Current_Type); - else - Append_To (Decls, - Make_Object_Declaration (Loc, - Defining_Identifier => Target_Partition, - Constant_Present => True, - Object_Definition => - New_Occurrence_Of (RTE (RE_Partition_ID), Loc), + if Present (Object_Type) + and then Current_Etype = Object_Type + then + Current_Type := New_Occurrence_Of (Stub_Type, Loc); + else + Current_Type := New_Occurrence_Of (Current_Etype, Loc); + end if; + end if; - Expression => - Make_Function_Call (Loc, - Name => Make_Selected_Component (Loc, - Prefix => - Make_Identifier (Loc, Chars (RCI_Locator)), - Selector_Name => - Make_Identifier (Loc, Name_Get_Active_Partition_ID))))); + New_Identifier := Make_Defining_Identifier (Loc, + Chars (Current_Identifier)); - RPC_Receiver := - Make_Selected_Component (Loc, - Prefix => - Make_Identifier (Loc, Chars (RCI_Locator)), - Selector_Name => - Make_Identifier (Loc, Name_Get_RCI_Package_Receiver)); - end if; + Append_To (Parameters, + Make_Parameter_Specification (Loc, + Defining_Identifier => New_Identifier, + Parameter_Type => Current_Type, + In_Present => In_Present (Current_Parameter), + Out_Present => Out_Present (Current_Parameter), + Expression => + New_Copy_Tree (Expression (Current_Parameter)))); - if Dynamically_Asynchronous then - Asynchronous_Expr := - Make_Selected_Component (Loc, - Prefix => - New_Occurrence_Of (Controlling_Parameter, Loc), - Selector_Name => - Make_Identifier (Loc, Name_Asynchronous)); + Next (Current_Parameter); + end loop; end if; - Build_General_Calling_Stubs - (Decls => Decls, - Statements => Statements, - Target_Partition => Target_Partition, - RPC_Receiver => RPC_Receiver, - Subprogram_Id => Make_Integer_Literal (Loc, Subp_Id), - Asynchronous => Asynchronous_Expr, - Is_Known_Asynchronous => Asynchronous - and then not Dynamically_Asynchronous, - Is_Known_Non_Asynchronous - => not Asynchronous - and then not Dynamically_Asynchronous, - Is_Function => Nkind (Spec_To_Use) = - N_Function_Specification, - Spec => Spec_To_Use, - Stub_Type => Stub_Type, - RACW_Type => RACW_Type, - Nod => Vis_Decl); + case Nkind (Spec) is - RCI_Calling_Stubs_Table.Set - (Defining_Unit_Name (Specification (Vis_Decl)), - Defining_Unit_Name (Spec_To_Use)); + when N_Function_Specification | N_Access_Function_Definition => + return + Make_Function_Specification (Loc, + Defining_Unit_Name => + Make_Defining_Identifier (Loc, + Chars => Name_For_New_Spec), + Parameter_Specifications => Parameters, + Subtype_Mark => + New_Occurrence_Of (Entity (Subtype_Mark (Spec)), Loc)); - return - Make_Subprogram_Body (Loc, - Specification => Subp_Spec, - Declarations => Decls, - Handled_Statement_Sequence => - Make_Handled_Sequence_Of_Statements (Loc, Statements)); - end Build_Subprogram_Calling_Stubs; + when N_Procedure_Specification | N_Access_Procedure_Definition => + return + Make_Procedure_Specification (Loc, + Defining_Unit_Name => + Make_Defining_Identifier (Loc, + Chars => Name_For_New_Spec), + Parameter_Specifications => Parameters); - ------------------------- - -- Build_Subprogram_Id -- - ------------------------- + when others => + raise Program_Error; + end case; + end Copy_Specification; - function Build_Subprogram_Id - (Loc : Source_Ptr; - E : Entity_Id) return Node_Id - is - begin - return Make_Integer_Literal (Loc, Get_Subprogram_Id (E)); - end Build_Subprogram_Id; + --------------------------- + -- Could_Be_Asynchronous -- + --------------------------- - -------------------------------------- - -- Build_Subprogram_Receiving_Stubs -- - -------------------------------------- + function Could_Be_Asynchronous (Spec : Node_Id) return Boolean is + Current_Parameter : Node_Id; - function Build_Subprogram_Receiving_Stubs - (Vis_Decl : Node_Id; - Asynchronous : Boolean; - Dynamically_Asynchronous : Boolean := False; - Stub_Type : Entity_Id := Empty; - RACW_Type : Entity_Id := Empty; - Parent_Primitive : Entity_Id := Empty) return Node_Id - is - Loc : constant Source_Ptr := Sloc (Vis_Decl); + begin + if Present (Parameter_Specifications (Spec)) then + Current_Parameter := First (Parameter_Specifications (Spec)); + while Present (Current_Parameter) loop + if Out_Present (Current_Parameter) then + return False; + end if; - Stream_Parameter : Node_Id; - Result_Parameter : Node_Id; - -- See explanations of those in Build_Subprogram_Calling_Stubs + Next (Current_Parameter); + end loop; + end if; - Decls : constant List_Id := New_List; - -- All the parameters will get declared before calling the real - -- subprograms. Also the out parameters will be declared. + return True; + end Could_Be_Asynchronous; - Statements : constant List_Id := New_List; + --------------------------------------------- + -- Expand_All_Calls_Remote_Subprogram_Call -- + --------------------------------------------- - Extra_Formal_Statements : constant List_Id := New_List; - -- Statements concerning extra formal parameters + procedure Expand_All_Calls_Remote_Subprogram_Call (N : Node_Id) is + Called_Subprogram : constant Entity_Id := Entity (Name (N)); + RCI_Package : constant Entity_Id := Scope (Called_Subprogram); + Loc : constant Source_Ptr := Sloc (N); + RCI_Locator : Node_Id; + RCI_Cache : Entity_Id; + Calling_Stubs : Node_Id; + E_Calling_Stubs : Entity_Id; - After_Statements : constant List_Id := New_List; - -- Statements to be executed after the subprogram call + begin + E_Calling_Stubs := RCI_Calling_Stubs_Table.Get (Called_Subprogram); - Inner_Decls : List_Id := No_List; - -- In case of a function, the inner declarations are needed since - -- the result may be unconstrained. + if E_Calling_Stubs = Empty then + RCI_Cache := RCI_Locator_Table.Get (RCI_Package); - Excep_Handler : Node_Id; - Excep_Choice : Entity_Id; - Excep_Code : List_Id; + if RCI_Cache = Empty then + RCI_Locator := + RCI_Package_Locator + (Loc, Specification (Unit_Declaration_Node (RCI_Package))); + Prepend_To (Current_Sem_Unit_Declarations, RCI_Locator); - Parameter_List : constant List_Id := New_List; - -- List of parameters to be passed to the subprogram + -- The RCI_Locator package is inserted at the top level in the + -- current unit, and must appear in the proper scope, so that it + -- is not prematurely removed by the GCC back-end. - Current_Parameter : Node_Id; + declare + Scop : constant Entity_Id := Cunit_Entity (Current_Sem_Unit); - Ordered_Parameters_List : constant List_Id := - Build_Ordered_Parameters_List - (Specification (Vis_Decl)); + begin + if Ekind (Scop) = E_Package_Body then + New_Scope (Spec_Entity (Scop)); - Subp_Spec : Node_Id; - -- Subprogram specification + elsif Ekind (Scop) = E_Subprogram_Body then + New_Scope + (Corresponding_Spec (Unit_Declaration_Node (Scop))); - Called_Subprogram : Node_Id; - -- The subprogram to call + else + New_Scope (Scop); + end if; - Null_Raise_Statement : Node_Id; + Analyze (RCI_Locator); + Pop_Scope; + end; - Dynamic_Async : Entity_Id; + RCI_Cache := Defining_Unit_Name (RCI_Locator); + + else + RCI_Locator := Parent (RCI_Cache); + end if; - begin - if RACW_Type /= Empty then - Called_Subprogram := - New_Occurrence_Of (Parent_Primitive, Loc); - else - Called_Subprogram := - New_Occurrence_Of ( - Defining_Unit_Name (Specification (Vis_Decl)), Loc); + Calling_Stubs := Build_Subprogram_Calling_Stubs + (Vis_Decl => Parent (Parent (Called_Subprogram)), + Subp_Id => + Build_Subprogram_Id (Loc, Called_Subprogram), + Asynchronous => Nkind (N) = N_Procedure_Call_Statement + and then + Is_Asynchronous (Called_Subprogram), + Locator => RCI_Cache, + New_Name => New_Internal_Name ('S')); + Insert_After (RCI_Locator, Calling_Stubs); + Analyze (Calling_Stubs); + E_Calling_Stubs := Defining_Unit_Name (Specification (Calling_Stubs)); end if; - Stream_Parameter := - Make_Defining_Identifier (Loc, New_Internal_Name ('S')); + Rewrite (Name (N), New_Occurrence_Of (E_Calling_Stubs, Loc)); + end Expand_All_Calls_Remote_Subprogram_Call; - if Dynamically_Asynchronous then - Dynamic_Async := - Make_Defining_Identifier (Loc, New_Internal_Name ('S')); - else - Dynamic_Async := Empty; - end if; + --------------------------------- + -- Expand_Calling_Stubs_Bodies -- + --------------------------------- - if not Asynchronous or else Dynamically_Asynchronous then - Result_Parameter := - Make_Defining_Identifier (Loc, New_Internal_Name ('S')); + procedure Expand_Calling_Stubs_Bodies (Unit_Node : Node_Id) is + Spec : constant Node_Id := Specification (Unit_Node); + Decls : constant List_Id := Visible_Declarations (Spec); - -- The first statement after the subprogram call is a statement to - -- writes a Null_Occurrence into the result stream. + begin + New_Scope (Scope_Of_Spec (Spec)); + Add_Calling_Stubs_To_Declarations + (Specification (Unit_Node), Decls); + Pop_Scope; + end Expand_Calling_Stubs_Bodies; - Null_Raise_Statement := - Make_Attribute_Reference (Loc, - Prefix => - New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc), - Attribute_Name => Name_Write, - Expressions => New_List ( - New_Occurrence_Of (Result_Parameter, Loc), - New_Occurrence_Of (RTE (RE_Null_Occurrence), Loc))); + ----------------------------------- + -- Expand_Receiving_Stubs_Bodies -- + ----------------------------------- - if Dynamically_Asynchronous then - Null_Raise_Statement := - Make_Implicit_If_Statement (Vis_Decl, - Condition => - Make_Op_Not (Loc, New_Occurrence_Of (Dynamic_Async, Loc)), - Then_Statements => New_List (Null_Raise_Statement)); - end if; + procedure Expand_Receiving_Stubs_Bodies (Unit_Node : Node_Id) is + Spec : Node_Id; + Decls : List_Id; + Temp : List_Id; - Append_To (After_Statements, Null_Raise_Statement); + begin + if Nkind (Unit_Node) = N_Package_Declaration then + Spec := Specification (Unit_Node); + Decls := Visible_Declarations (Spec); + New_Scope (Scope_Of_Spec (Spec)); + Add_Receiving_Stubs_To_Declarations (Spec, Decls); else - Result_Parameter := Empty; + Spec := + Package_Specification_Of_Scope (Corresponding_Spec (Unit_Node)); + Decls := Declarations (Unit_Node); + New_Scope (Scope_Of_Spec (Unit_Node)); + Temp := New_List; + Add_Receiving_Stubs_To_Declarations (Spec, Temp); + Insert_List_Before (First (Decls), Temp); end if; - -- Loop through every parameter and get its value from the stream. If - -- the parameter is unconstrained, then the parameter is read using - -- 'Input at the point of declaration. - - Current_Parameter := First (Ordered_Parameters_List); + Pop_Scope; + end Expand_Receiving_Stubs_Bodies; - while Current_Parameter /= Empty loop + -------------------- + -- GARLIC_Support -- + -------------------- - declare - Etyp : Entity_Id; - RACW_Controlling : Boolean; - Constrained : Boolean; - Object : Entity_Id; - Expr : Node_Id := Empty; + package body GARLIC_Support is - begin - Object := Make_Defining_Identifier (Loc, New_Internal_Name ('P')); - Set_Ekind (Object, E_Variable); + -- Local subprograms - RACW_Controlling := - Is_RACW_Controlling_Formal (Current_Parameter, Stub_Type); + procedure Add_RACW_Read_Attribute + (RACW_Type : Entity_Id; + Stub_Type : Entity_Id; + Stub_Type_Access : Entity_Id; + Declarations : List_Id); + -- Add Read attribute in Decls for the RACW type. The Read attribute + -- is added right after the RACW_Type declaration while the body is + -- inserted after Declarations. - if RACW_Controlling then + procedure Add_RACW_Write_Attribute + (RACW_Type : Entity_Id; + Stub_Type : Entity_Id; + Stub_Type_Access : Entity_Id; + RPC_Receiver : Node_Id; + Declarations : List_Id); + -- Same thing for the Write attribute - -- We have a controlling formal parameter. Read its address - -- rather than a real object. The address is in Unsigned_64 - -- form. + function Stream_Parameter return Node_Id; + function Result return Node_Id; + function Object return Node_Id renames Result; + -- Functions to create occurrences of the formal parameter names of + -- the 'Read and 'Write attributes. + + Loc : Source_Ptr; + -- Shared source location used by Add_{Read,Write}_Read_Attribute + -- and their ancillary subroutines (set on entry by Add_RACW_Features). + + procedure Add_RAS_Access_TSS (N : Node_Id); + -- Add a subprogram body for RAS Access TSS + + ----------------------- + -- Add_RACW_Features -- + ----------------------- + + procedure Add_RACW_Features + (RACW_Type : Entity_Id; + Stub_Type : Entity_Id; + Stub_Type_Access : Entity_Id; + RPC_Receiver_Decl : Node_Id; + Declarations : List_Id) + is + RPC_Receiver : Node_Id; + Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type); - Etyp := RTE (RE_Unsigned_64); - else - Etyp := Etype (Parameter_Type (Current_Parameter)); - end if; + begin + Loc := Sloc (RACW_Type); - Constrained := - Is_Constrained (Etyp) or else Is_Elementary_Type (Etyp); + if Is_RAS then - if In_Present (Current_Parameter) - or else not Out_Present (Current_Parameter) - or else not Constrained - or else RACW_Controlling - then - -- If an input parameter is contrained, then its reading is - -- deferred until the beginning of the subprogram body. If - -- it is unconstrained, then an expression is built for - -- the object declaration and the variable is set using - -- 'Input instead of 'Read. + -- For a RAS, the RPC receiver is that of the RCI unit, + -- not that of the corresponding distributed object type. + -- We retrieve its address from the local proxy object. - if Constrained and then not RACW_Controlling then - Append_To (Statements, - Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (Etyp, Loc), - Attribute_Name => Name_Read, - Expressions => New_List ( - New_Occurrence_Of (Stream_Parameter, Loc), - New_Occurrence_Of (Object, Loc)))); + RPC_Receiver := Make_Selected_Component (Loc, + Prefix => + Unchecked_Convert_To (RTE (RE_RAS_Proxy_Type_Access), Object), + Selector_Name => Make_Identifier (Loc, Name_Receiver)); - else - Expr := Input_With_Tag_Check (Loc, - Var_Type => Etyp, - Stream => Stream_Parameter); - Append_To (Decls, Expr); - Expr := Make_Function_Call (Loc, - New_Occurrence_Of (Defining_Unit_Name - (Specification (Expr)), Loc)); - end if; - end if; + else + RPC_Receiver := Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of ( + Defining_Unit_Name (Specification (RPC_Receiver_Decl)), Loc), + Attribute_Name => Name_Address); + end if; - -- If we do not have to output the current parameter, then - -- it can well be flagged as constant. This may allow further - -- optimizations done by the back end. + Add_RACW_Write_Attribute ( + RACW_Type, + Stub_Type, + Stub_Type_Access, + RPC_Receiver, + Declarations); + + Add_RACW_Read_Attribute ( + RACW_Type, + Stub_Type, + Stub_Type_Access, + Declarations); + end Add_RACW_Features; + + ----------------------------- + -- Add_RACW_Read_Attribute -- + ----------------------------- + + procedure Add_RACW_Read_Attribute + (RACW_Type : Entity_Id; + Stub_Type : Entity_Id; + Stub_Type_Access : Entity_Id; + Declarations : List_Id) + is + Proc_Decl : Node_Id; + Attr_Decl : Node_Id; + + Body_Node : Node_Id; + + Decls : List_Id; + Statements : List_Id; + Local_Statements : List_Id; + Remote_Statements : List_Id; + -- Various parts of the procedure + + Procedure_Name : constant Name_Id := + New_Internal_Name ('R'); + Source_Partition : constant Entity_Id := + Make_Defining_Identifier + (Loc, New_Internal_Name ('P')); + Source_Receiver : constant Entity_Id := + Make_Defining_Identifier + (Loc, New_Internal_Name ('S')); + Source_Address : constant Entity_Id := + Make_Defining_Identifier + (Loc, New_Internal_Name ('P')); + Local_Stub : constant Entity_Id := + Make_Defining_Identifier + (Loc, New_Internal_Name ('L')); + Stubbed_Result : constant Entity_Id := + Make_Defining_Identifier + (Loc, New_Internal_Name ('S')); + Asynchronous_Flag : constant Entity_Id := + Asynchronous_Flags_Table.Get (RACW_Type); + pragma Assert (Present (Asynchronous_Flag)); + + -- Start of processing for Add_RACW_Read_Attribute - Append_To (Decls, - Make_Object_Declaration (Loc, - Defining_Identifier => Object, - Constant_Present => - not Constrained and then not Out_Present (Current_Parameter), - Object_Definition => - New_Occurrence_Of (Etyp, Loc), - Expression => Expr)); + begin + -- Generate object declarations - -- An out parameter may be written back using a 'Write - -- attribute instead of a 'Output because it has been - -- constrained by the parameter given to the caller. Note that - -- out controlling arguments in the case of a RACW are not put - -- back in the stream because the pointer on them has not - -- changed. + Decls := New_List ( + Make_Object_Declaration (Loc, + Defining_Identifier => Source_Partition, + Object_Definition => + New_Occurrence_Of (RTE (RE_Partition_ID), Loc)), - if Out_Present (Current_Parameter) - and then - Etype (Parameter_Type (Current_Parameter)) /= Stub_Type - then - Append_To (After_Statements, - Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (Etyp, Loc), - Attribute_Name => Name_Write, - Expressions => New_List ( - New_Occurrence_Of (Result_Parameter, Loc), - New_Occurrence_Of (Object, Loc)))); - end if; + Make_Object_Declaration (Loc, + Defining_Identifier => Source_Receiver, + Object_Definition => + New_Occurrence_Of (RTE (RE_Unsigned_64), Loc)), - if - Is_RACW_Controlling_Formal (Current_Parameter, Stub_Type) - then - if Nkind (Parameter_Type (Current_Parameter)) /= - N_Access_Definition - then - Append_To (Parameter_List, - Make_Parameter_Association (Loc, - Selector_Name => - New_Occurrence_Of ( - Defining_Identifier (Current_Parameter), Loc), - Explicit_Actual_Parameter => - Make_Explicit_Dereference (Loc, - Unchecked_Convert_To (RACW_Type, - OK_Convert_To (RTE (RE_Address), - New_Occurrence_Of (Object, Loc)))))); + Make_Object_Declaration (Loc, + Defining_Identifier => Source_Address, + Object_Definition => + New_Occurrence_Of (RTE (RE_Unsigned_64), Loc)), - else - Append_To (Parameter_List, - Make_Parameter_Association (Loc, - Selector_Name => - New_Occurrence_Of ( - Defining_Identifier (Current_Parameter), Loc), - Explicit_Actual_Parameter => - Unchecked_Convert_To (RACW_Type, - OK_Convert_To (RTE (RE_Address), - New_Occurrence_Of (Object, Loc))))); - end if; + Make_Object_Declaration (Loc, + Defining_Identifier => Local_Stub, + Aliased_Present => True, + Object_Definition => New_Occurrence_Of (Stub_Type, Loc)), - else - Append_To (Parameter_List, - Make_Parameter_Association (Loc, - Selector_Name => - New_Occurrence_Of ( - Defining_Identifier (Current_Parameter), Loc), - Explicit_Actual_Parameter => - New_Occurrence_Of (Object, Loc))); - end if; + Make_Object_Declaration (Loc, + Defining_Identifier => Stubbed_Result, + Object_Definition => + New_Occurrence_Of (Stub_Type_Access, Loc), + Expression => + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Local_Stub, Loc), + Attribute_Name => + Name_Unchecked_Access))); - -- If the current parameter needs an extra formal, then read it - -- from the stream and set the corresponding semantic field in - -- the variable. If the kind of the parameter identifier is - -- E_Void, then this is a compiler generated parameter that - -- doesn't need an extra constrained status. + -- Read the source Partition_ID and RPC_Receiver from incoming stream - -- The case of Extra_Accessibility should also be handled ??? + Statements := New_List ( + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (RTE (RE_Partition_ID), Loc), + Attribute_Name => Name_Read, + Expressions => New_List ( + Stream_Parameter, + New_Occurrence_Of (Source_Partition, Loc))), - if Nkind (Parameter_Type (Current_Parameter)) /= - N_Access_Definition - and then - Ekind (Defining_Identifier (Current_Parameter)) /= E_Void - and then - Present (Extra_Constrained - (Defining_Identifier (Current_Parameter))) - then - declare - Extra_Parameter : constant Entity_Id := - Extra_Constrained - (Defining_Identifier - (Current_Parameter)); + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (RTE (RE_Unsigned_64), Loc), + Attribute_Name => + Name_Read, + Expressions => New_List ( + Stream_Parameter, + New_Occurrence_Of (Source_Receiver, Loc))), - Formal_Entity : constant Entity_Id := - Make_Defining_Identifier - (Loc, Chars (Extra_Parameter)); + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (RTE (RE_Unsigned_64), Loc), + Attribute_Name => + Name_Read, + Expressions => New_List ( + Stream_Parameter, + New_Occurrence_Of (Source_Address, Loc)))); - Formal_Type : constant Entity_Id := - Etype (Extra_Parameter); + -- Build_Get_Unique_RP_Call needs the type of Stubbed_Result - begin - Append_To (Decls, - Make_Object_Declaration (Loc, - Defining_Identifier => Formal_Entity, - Object_Definition => - New_Occurrence_Of (Formal_Type, Loc))); + Set_Etype (Stubbed_Result, Stub_Type_Access); - Append_To (Extra_Formal_Statements, - Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (Formal_Type, Loc), - Attribute_Name => Name_Read, - Expressions => New_List ( - New_Occurrence_Of (Stream_Parameter, Loc), - New_Occurrence_Of (Formal_Entity, Loc)))); - Set_Extra_Constrained (Object, Formal_Entity); - end; - end if; - end; + -- If the Address is Null_Address, then return a null object - Next (Current_Parameter); - end loop; + Append_To (Statements, + Make_Implicit_If_Statement (RACW_Type, + Condition => + Make_Op_Eq (Loc, + Left_Opnd => New_Occurrence_Of (Source_Address, Loc), + Right_Opnd => Make_Integer_Literal (Loc, Uint_0)), + Then_Statements => New_List ( + Make_Assignment_Statement (Loc, + Name => Result, + Expression => Make_Null (Loc)), + Make_Return_Statement (Loc)))); + + -- If the RACW denotes an object created on the current partition, + -- Local_Statements will be executed. The real object will be used. + + Local_Statements := New_List ( + Make_Assignment_Statement (Loc, + Name => Result, + Expression => + Unchecked_Convert_To (RACW_Type, + OK_Convert_To (RTE (RE_Address), + New_Occurrence_Of (Source_Address, Loc))))); - -- Append the formal statements list at the end of regular statements + -- If the object is located on another partition, then a stub object + -- will be created with all the information needed to rebuild the + -- real object at the other end. - Append_List_To (Statements, Extra_Formal_Statements); + Remote_Statements := New_List ( - if Nkind (Specification (Vis_Decl)) = N_Function_Specification then + Make_Assignment_Statement (Loc, + Name => Make_Selected_Component (Loc, + Prefix => New_Occurrence_Of (Stubbed_Result, Loc), + Selector_Name => Make_Identifier (Loc, Name_Origin)), + Expression => + New_Occurrence_Of (Source_Partition, Loc)), - -- The remote subprogram is a function. We build an inner block to - -- be able to hold a potentially unconstrained result in a variable. + Make_Assignment_Statement (Loc, + Name => Make_Selected_Component (Loc, + Prefix => New_Occurrence_Of (Stubbed_Result, Loc), + Selector_Name => Make_Identifier (Loc, Name_Receiver)), + Expression => + New_Occurrence_Of (Source_Receiver, Loc)), - declare - Etyp : constant Entity_Id := - Etype (Subtype_Mark (Specification (Vis_Decl))); - Result : constant Node_Id := - Make_Defining_Identifier (Loc, New_Internal_Name ('R')); + Make_Assignment_Statement (Loc, + Name => Make_Selected_Component (Loc, + Prefix => New_Occurrence_Of (Stubbed_Result, Loc), + Selector_Name => Make_Identifier (Loc, Name_Addr)), + Expression => + New_Occurrence_Of (Source_Address, Loc))); - begin - Inner_Decls := New_List ( - Make_Object_Declaration (Loc, - Defining_Identifier => Result, - Constant_Present => True, - Object_Definition => New_Occurrence_Of (Etyp, Loc), - Expression => - Make_Function_Call (Loc, - Name => Called_Subprogram, - Parameter_Associations => Parameter_List))); + Append_To (Remote_Statements, + Make_Assignment_Statement (Loc, + Name => Make_Selected_Component (Loc, + Prefix => New_Occurrence_Of (Stubbed_Result, Loc), + Selector_Name => Make_Identifier (Loc, Name_Asynchronous)), + Expression => + New_Occurrence_Of (Asynchronous_Flag, Loc))); + + Append_List_To (Remote_Statements, + Build_Get_Unique_RP_Call (Loc, Stubbed_Result, Stub_Type)); + -- ??? Issue with asynchronous calls here: the Asynchronous + -- flag is set on the stub type if, and only if, the RACW type + -- has a pragma Asynchronous. This is incorrect for RACWs that + -- implement RAS types, because in that case the /designated + -- subprogram/ (not the type) might be asynchronous, and + -- that causes the stub to need to be asynchronous too. + -- A solution is to transport a RAS as a struct containing + -- a RACW and an asynchronous flag, and to properly alter + -- the Asynchronous component in the stub type in the RAS's + -- Input TSS. + + Append_To (Remote_Statements, + Make_Assignment_Statement (Loc, + Name => Result, + Expression => Unchecked_Convert_To (RACW_Type, + New_Occurrence_Of (Stubbed_Result, Loc)))); - Append_To (After_Statements, - Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (Etyp, Loc), - Attribute_Name => Name_Output, - Expressions => New_List ( - New_Occurrence_Of (Result_Parameter, Loc), - New_Occurrence_Of (Result, Loc)))); - end; + -- Distinguish between the local and remote cases, and execute the + -- appropriate piece of code. Append_To (Statements, - Make_Block_Statement (Loc, - Declarations => Inner_Decls, - Handled_Statement_Sequence => - Make_Handled_Sequence_Of_Statements (Loc, - Statements => After_Statements))); + Make_Implicit_If_Statement (RACW_Type, + Condition => + Make_Op_Eq (Loc, + Left_Opnd => + Make_Function_Call (Loc, + Name => New_Occurrence_Of ( + RTE (RE_Get_Local_Partition_Id), Loc)), + Right_Opnd => New_Occurrence_Of (Source_Partition, Loc)), + Then_Statements => Local_Statements, + Else_Statements => Remote_Statements)); + + Build_Stream_Procedure + (Loc, RACW_Type, Body_Node, + Make_Defining_Identifier (Loc, Procedure_Name), + Statements, Outp => True); + Set_Declarations (Body_Node, Decls); + + Proc_Decl := Make_Subprogram_Declaration (Loc, + Copy_Specification (Loc, Specification (Body_Node))); + + Attr_Decl := + Make_Attribute_Definition_Clause (Loc, + Name => New_Occurrence_Of (RACW_Type, Loc), + Chars => Name_Read, + Expression => + New_Occurrence_Of ( + Defining_Unit_Name (Specification (Proc_Decl)), Loc)); + + Insert_After (Declaration_Node (RACW_Type), Proc_Decl); + Insert_After (Proc_Decl, Attr_Decl); + Append_To (Declarations, Body_Node); + end Add_RACW_Read_Attribute; + + ------------------------------ + -- Add_RACW_Write_Attribute -- + ------------------------------ + + procedure Add_RACW_Write_Attribute + (RACW_Type : Entity_Id; + Stub_Type : Entity_Id; + Stub_Type_Access : Entity_Id; + RPC_Receiver : Node_Id; + Declarations : List_Id) + is + Body_Node : Node_Id; + Proc_Decl : Node_Id; + Attr_Decl : Node_Id; - else - -- The remote subprogram is a procedure. We do not need any inner - -- block in this case. + Statements : List_Id; + Local_Statements : List_Id; + Remote_Statements : List_Id; + Null_Statements : List_Id; - if Dynamically_Asynchronous then - Append_To (Decls, - Make_Object_Declaration (Loc, - Defining_Identifier => Dynamic_Async, - Object_Definition => - New_Occurrence_Of (Standard_Boolean, Loc))); + Procedure_Name : constant Name_Id := New_Internal_Name ('R'); - Append_To (Statements, - Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (Standard_Boolean, Loc), - Attribute_Name => Name_Read, - Expressions => New_List ( - New_Occurrence_Of (Stream_Parameter, Loc), - New_Occurrence_Of (Dynamic_Async, Loc)))); - end if; + begin + -- Build the code fragment corresponding to the marshalling of a + -- local object. - Append_To (Statements, - Make_Procedure_Call_Statement (Loc, - Name => Called_Subprogram, - Parameter_Associations => Parameter_List)); + Local_Statements := New_List ( - Append_List_To (Statements, After_Statements); - end if; + Pack_Entity_Into_Stream_Access (Loc, + Stream => Stream_Parameter, + Object => RTE (RE_Get_Local_Partition_Id)), - if Asynchronous and then not Dynamically_Asynchronous then + Pack_Node_Into_Stream_Access (Loc, + Stream => Stream_Parameter, + Object => OK_Convert_To (RTE (RE_Unsigned_64), RPC_Receiver), + Etyp => RTE (RE_Unsigned_64)), - -- An asynchronous procedure does not want a Result - -- parameter. Also, we put an exception handler with an others - -- clause that does nothing. + Pack_Node_Into_Stream_Access (Loc, + Stream => Stream_Parameter, + Object => OK_Convert_To (RTE (RE_Unsigned_64), + Make_Attribute_Reference (Loc, + Prefix => + Make_Explicit_Dereference (Loc, + Prefix => Object), + Attribute_Name => Name_Address)), + Etyp => RTE (RE_Unsigned_64))); - Subp_Spec := - Make_Procedure_Specification (Loc, - Defining_Unit_Name => - Make_Defining_Identifier (Loc, New_Internal_Name ('F')), - Parameter_Specifications => New_List ( - Make_Parameter_Specification (Loc, - Defining_Identifier => Stream_Parameter, - Parameter_Type => - Make_Access_Definition (Loc, - Subtype_Mark => - New_Occurrence_Of (RTE (RE_Params_Stream_Type), Loc))))); + -- Build the code fragment corresponding to the marshalling of + -- a remote object. - Excep_Handler := - Make_Exception_Handler (Loc, - Exception_Choices => - New_List (Make_Others_Choice (Loc)), - Statements => New_List ( - Make_Null_Statement (Loc))); + Remote_Statements := New_List ( - else - -- In the other cases, if an exception is raised, then the - -- exception occurrence is copied into the output stream and - -- no other output parameter is written. + Pack_Node_Into_Stream_Access (Loc, + Stream => Stream_Parameter, + Object => + Make_Selected_Component (Loc, + Prefix => Unchecked_Convert_To (Stub_Type_Access, + Object), + Selector_Name => + Make_Identifier (Loc, Name_Origin)), + Etyp => RTE (RE_Partition_ID)), - Excep_Choice := - Make_Defining_Identifier (Loc, New_Internal_Name ('E')); + Pack_Node_Into_Stream_Access (Loc, + Stream => Stream_Parameter, + Object => + Make_Selected_Component (Loc, + Prefix => Unchecked_Convert_To (Stub_Type_Access, + Object), + Selector_Name => + Make_Identifier (Loc, Name_Receiver)), + Etyp => RTE (RE_Unsigned_64)), - Excep_Code := New_List ( - Make_Attribute_Reference (Loc, - Prefix => - New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc), - Attribute_Name => Name_Write, - Expressions => New_List ( - New_Occurrence_Of (Result_Parameter, Loc), - New_Occurrence_Of (Excep_Choice, Loc)))); + Pack_Node_Into_Stream_Access (Loc, + Stream => Stream_Parameter, + Object => + Make_Selected_Component (Loc, + Prefix => Unchecked_Convert_To (Stub_Type_Access, + Object), + Selector_Name => + Make_Identifier (Loc, Name_Addr)), + Etyp => RTE (RE_Unsigned_64))); - if Dynamically_Asynchronous then - Excep_Code := New_List ( - Make_Implicit_If_Statement (Vis_Decl, - Condition => Make_Op_Not (Loc, - New_Occurrence_Of (Dynamic_Async, Loc)), - Then_Statements => Excep_Code)); - end if; + -- Build the code fragment corresponding to the marshalling of a null + -- object. - Excep_Handler := - Make_Exception_Handler (Loc, - Choice_Parameter => Excep_Choice, - Exception_Choices => New_List (Make_Others_Choice (Loc)), - Statements => Excep_Code); + Null_Statements := New_List ( - Subp_Spec := - Make_Procedure_Specification (Loc, - Defining_Unit_Name => - Make_Defining_Identifier (Loc, New_Internal_Name ('F')), + Pack_Entity_Into_Stream_Access (Loc, + Stream => Stream_Parameter, + Object => RTE (RE_Get_Local_Partition_Id)), - Parameter_Specifications => New_List ( - Make_Parameter_Specification (Loc, - Defining_Identifier => Stream_Parameter, - Parameter_Type => - Make_Access_Definition (Loc, - Subtype_Mark => - New_Occurrence_Of (RTE (RE_Params_Stream_Type), Loc))), + Pack_Node_Into_Stream_Access (Loc, + Stream => Stream_Parameter, + Object => OK_Convert_To (RTE (RE_Unsigned_64), RPC_Receiver), + Etyp => RTE (RE_Unsigned_64)), - Make_Parameter_Specification (Loc, - Defining_Identifier => Result_Parameter, - Parameter_Type => - Make_Access_Definition (Loc, - Subtype_Mark => - New_Occurrence_Of (RTE (RE_Params_Stream_Type), Loc))))); - end if; + Pack_Node_Into_Stream_Access (Loc, + Stream => Stream_Parameter, + Object => Make_Integer_Literal (Loc, Uint_0), + Etyp => RTE (RE_Unsigned_64))); - return - Make_Subprogram_Body (Loc, - Specification => Subp_Spec, - Declarations => Decls, - Handled_Statement_Sequence => - Make_Handled_Sequence_Of_Statements (Loc, - Statements => Statements, - Exception_Handlers => New_List (Excep_Handler))); - end Build_Subprogram_Receiving_Stubs; + Statements := New_List ( + Make_Implicit_If_Statement (RACW_Type, + Condition => + Make_Op_Eq (Loc, + Left_Opnd => Object, + Right_Opnd => Make_Null (Loc)), + Then_Statements => Null_Statements, + Elsif_Parts => New_List ( + Make_Elsif_Part (Loc, + Condition => + Make_Op_Eq (Loc, + Left_Opnd => + Make_Attribute_Reference (Loc, + Prefix => Object, + Attribute_Name => Name_Tag), + Right_Opnd => + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Stub_Type, Loc), + Attribute_Name => Name_Tag)), + Then_Statements => Remote_Statements)), + Else_Statements => Local_Statements)); + + Build_Stream_Procedure + (Loc, RACW_Type, Body_Node, + Make_Defining_Identifier (Loc, Procedure_Name), + Statements, Outp => False); + + Proc_Decl := Make_Subprogram_Declaration (Loc, + Copy_Specification (Loc, Specification (Body_Node))); + + Attr_Decl := + Make_Attribute_Definition_Clause (Loc, + Name => New_Occurrence_Of (RACW_Type, Loc), + Chars => Name_Write, + Expression => + New_Occurrence_Of ( + Defining_Unit_Name (Specification (Proc_Decl)), Loc)); - ------------------------ - -- Copy_Specification -- - ------------------------ + Insert_After (Declaration_Node (RACW_Type), Proc_Decl); + Insert_After (Proc_Decl, Attr_Decl); + Append_To (Declarations, Body_Node); + end Add_RACW_Write_Attribute; - function Copy_Specification - (Loc : Source_Ptr; - Spec : Node_Id; - Object_Type : Entity_Id := Empty; - Stub_Type : Entity_Id := Empty; - New_Name : Name_Id := No_Name) return Node_Id - is - Parameters : List_Id := No_List; + ------------------------ + -- Add_RAS_Access_TSS -- + ------------------------ - Current_Parameter : Node_Id; - Current_Identifier : Entity_Id; - Current_Type : Node_Id; - Current_Etype : Entity_Id; + procedure Add_RAS_Access_TSS (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); - Name_For_New_Spec : Name_Id; + Ras_Type : constant Entity_Id := Defining_Identifier (N); + Fat_Type : constant Entity_Id := Equivalent_Type (Ras_Type); + -- Ras_Type is the access to subprogram type while Fat_Type is the + -- corresponding record type. - New_Identifier : Entity_Id; + RACW_Type : constant Entity_Id := + Underlying_RACW_Type (Ras_Type); + Desig : constant Entity_Id := + Etype (Designated_Type (RACW_Type)); - begin - if New_Name = No_Name then - pragma Assert (Nkind (Spec) = N_Function_Specification - or else Nkind (Spec) = N_Procedure_Specification); + Stub_Elements : constant Stub_Structure := + Stubs_Table.Get (Desig); + pragma Assert (Stub_Elements /= Empty_Stub_Structure); - Name_For_New_Spec := Chars (Defining_Unit_Name (Spec)); - else - Name_For_New_Spec := New_Name; - end if; + Proc : constant Entity_Id := + Make_Defining_Identifier (Loc, + Chars => Make_TSS_Name (Ras_Type, TSS_RAS_Access)); - if Present (Parameter_Specifications (Spec)) then - Parameters := New_List; - Current_Parameter := First (Parameter_Specifications (Spec)); - while Current_Parameter /= Empty loop - Current_Identifier := Defining_Identifier (Current_Parameter); - Current_Type := Parameter_Type (Current_Parameter); + Proc_Spec : Node_Id; - if Nkind (Current_Type) = N_Access_Definition then - Current_Etype := Entity (Subtype_Mark (Current_Type)); + -- Formal parameters - if Present (Object_Type) then - pragma Assert ( - Root_Type (Current_Etype) = Root_Type (Object_Type)); - Current_Type := - Make_Access_Definition (Loc, - Subtype_Mark => New_Occurrence_Of (Stub_Type, Loc)); - else - Current_Type := - Make_Access_Definition (Loc, - Subtype_Mark => - New_Occurrence_Of (Current_Etype, Loc)); - end if; + Package_Name : constant Entity_Id := + Make_Defining_Identifier (Loc, + Chars => Name_P); + -- Target package - else - Current_Etype := Entity (Current_Type); + Subp_Id : constant Entity_Id := + Make_Defining_Identifier (Loc, + Chars => Name_S); + -- Target subprogram - if Object_Type /= Empty - and then Current_Etype = Object_Type - then - Current_Type := New_Occurrence_Of (Stub_Type, Loc); - else - Current_Type := New_Occurrence_Of (Current_Etype, Loc); - end if; - end if; + Asynch_P : constant Entity_Id := + Make_Defining_Identifier (Loc, + Chars => Name_Asynchronous); + -- Is the procedure to which the 'Access applies asynchronous? - New_Identifier := Make_Defining_Identifier (Loc, - Chars (Current_Identifier)); + All_Calls_Remote : constant Entity_Id := + Make_Defining_Identifier (Loc, + Chars => Name_All_Calls_Remote); + -- True if an All_Calls_Remote pragma applies to the RCI unit + -- that contains the subprogram. - Append_To (Parameters, - Make_Parameter_Specification (Loc, - Defining_Identifier => New_Identifier, - Parameter_Type => Current_Type, - In_Present => In_Present (Current_Parameter), - Out_Present => Out_Present (Current_Parameter), - Expression => - New_Copy_Tree (Expression (Current_Parameter)))); + -- Common local variables - Next (Current_Parameter); - end loop; - end if; + Proc_Decls : List_Id; + Proc_Statements : List_Id; - case Nkind (Spec) is + Origin : constant Entity_Id := + Make_Defining_Identifier (Loc, + Chars => New_Internal_Name ('P')); - when N_Function_Specification | N_Access_Function_Definition => - return - Make_Function_Specification (Loc, - Defining_Unit_Name => - Make_Defining_Identifier (Loc, - Chars => Name_For_New_Spec), - Parameter_Specifications => Parameters, - Subtype_Mark => - New_Occurrence_Of (Entity (Subtype_Mark (Spec)), Loc)); + -- Additional local variables for the local case - when N_Procedure_Specification | N_Access_Procedure_Definition => + Proxy_Addr : constant Entity_Id := + Make_Defining_Identifier (Loc, + Chars => New_Internal_Name ('P')); + + -- Additional local variables for the remote case + + Local_Stub : constant Entity_Id := + Make_Defining_Identifier (Loc, + Chars => New_Internal_Name ('L')); + + Stub_Ptr : constant Entity_Id := + Make_Defining_Identifier (Loc, + Chars => New_Internal_Name ('S')); + + function Set_Field + (Field_Name : Name_Id; + Value : Node_Id) return Node_Id; + -- Construct an assignment that sets the named component in the + -- returned record + + --------------- + -- Set_Field -- + --------------- + + function Set_Field + (Field_Name : Name_Id; + Value : Node_Id) return Node_Id + is + begin return - Make_Procedure_Specification (Loc, - Defining_Unit_Name => - Make_Defining_Identifier (Loc, - Chars => Name_For_New_Spec), - Parameter_Specifications => Parameters); + Make_Assignment_Statement (Loc, + Name => + Make_Selected_Component (Loc, + Prefix => New_Occurrence_Of (Stub_Ptr, Loc), + Selector_Name => Make_Identifier (Loc, Field_Name)), + Expression => Value); + end Set_Field; - when others => - raise Program_Error; - end case; - end Copy_Specification; + -- Start of processing for Add_RAS_Access_TSS - --------------------------- - -- Could_Be_Asynchronous -- - --------------------------- + begin + Proc_Decls := New_List ( - function Could_Be_Asynchronous (Spec : Node_Id) return Boolean is - Current_Parameter : Node_Id; + -- Common declarations - begin - if Present (Parameter_Specifications (Spec)) then - Current_Parameter := First (Parameter_Specifications (Spec)); - while Current_Parameter /= Empty loop - if Out_Present (Current_Parameter) then - return False; - end if; + Make_Object_Declaration (Loc, + Defining_Identifier => Origin, + Constant_Present => True, + Object_Definition => + New_Occurrence_Of (RTE (RE_Partition_ID), Loc), + Expression => + Make_Function_Call (Loc, + Name => + New_Occurrence_Of (RTE (RE_Get_Active_Partition_Id), Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of (Package_Name, Loc)))), - Next (Current_Parameter); - end loop; - end if; + -- Declaration use only in the local case: proxy address - return True; - end Could_Be_Asynchronous; + Make_Object_Declaration (Loc, + Defining_Identifier => Proxy_Addr, + Object_Definition => + New_Occurrence_Of (RTE (RE_Unsigned_64), Loc)), - --------------------------------------------- - -- Expand_All_Calls_Remote_Subprogram_Call -- - --------------------------------------------- + -- Declarations used only in the remote case: stub object and + -- stub pointer. - procedure Expand_All_Calls_Remote_Subprogram_Call (N : Node_Id) is - Called_Subprogram : constant Entity_Id := Entity (Name (N)); - RCI_Package : constant Entity_Id := Scope (Called_Subprogram); - Loc : constant Source_Ptr := Sloc (N); - RCI_Locator : Node_Id; - RCI_Cache : Entity_Id; - Calling_Stubs : Node_Id; - E_Calling_Stubs : Entity_Id; + Make_Object_Declaration (Loc, + Defining_Identifier => Local_Stub, + Aliased_Present => True, + Object_Definition => + New_Occurrence_Of (Stub_Elements.Stub_Type, Loc)), - begin - E_Calling_Stubs := RCI_Calling_Stubs_Table.Get (Called_Subprogram); + Make_Object_Declaration (Loc, + Defining_Identifier => + Stub_Ptr, + Object_Definition => + New_Occurrence_Of (Stub_Elements.Stub_Type_Access, Loc), + Expression => + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Local_Stub, Loc), + Attribute_Name => Name_Unchecked_Access))); - if E_Calling_Stubs = Empty then - RCI_Cache := RCI_Locator_Table.Get (RCI_Package); + Set_Etype (Stub_Ptr, Stub_Elements.Stub_Type_Access); + -- Build_Get_Unique_RP_Call needs this information - if RCI_Cache = Empty then - RCI_Locator := - RCI_Package_Locator - (Loc, Specification (Unit_Declaration_Node (RCI_Package))); - Prepend_To (Current_Sem_Unit_Declarations, RCI_Locator); + -- Note: Here we assume that the Fat_Type is a record + -- containing just a pointer to a proxy or stub object. - -- The RCI_Locator package is inserted at the top level in the - -- current unit, and must appear in the proper scope, so that it - -- is not prematurely removed by the GCC back-end. + Proc_Statements := New_List ( - declare - Scop : constant Entity_Id := Cunit_Entity (Current_Sem_Unit); + -- Generate: - begin - if Ekind (Scop) = E_Package_Body then - New_Scope (Spec_Entity (Scop)); + -- Get_RAS_Info (Pkg, Subp, PA); + -- if Origin = Local_Partition_Id + -- and then not All_Calls_Remote + -- then + -- return Fat_Type!(PA); + -- end if; - elsif Ekind (Scop) = E_Subprogram_Body then - New_Scope - (Corresponding_Spec (Unit_Declaration_Node (Scop))); + Make_Procedure_Call_Statement (Loc, + Name => + New_Occurrence_Of (RTE (RE_Get_RAS_Info), Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of (Package_Name, Loc), + New_Occurrence_Of (Subp_Id, Loc), + New_Occurrence_Of (Proxy_Addr, Loc))), + + Make_Implicit_If_Statement (N, + Condition => + Make_And_Then (Loc, + Left_Opnd => + Make_Op_Eq (Loc, + Left_Opnd => + New_Occurrence_Of (Origin, Loc), + Right_Opnd => + Make_Function_Call (Loc, + New_Occurrence_Of ( + RTE (RE_Get_Local_Partition_Id), Loc))), + Right_Opnd => + Make_Op_Not (Loc, + New_Occurrence_Of (All_Calls_Remote, Loc))), + Then_Statements => New_List ( + Make_Return_Statement (Loc, + Unchecked_Convert_To (Fat_Type, + OK_Convert_To (RTE (RE_Address), + New_Occurrence_Of (Proxy_Addr, Loc)))))), + + Set_Field (Name_Origin, + New_Occurrence_Of (Origin, Loc)), + + Set_Field (Name_Receiver, + Make_Function_Call (Loc, + Name => + New_Occurrence_Of (RTE (RE_Get_RCI_Package_Receiver), Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of (Package_Name, Loc)))), + + Set_Field (Name_Addr, New_Occurrence_Of (Proxy_Addr, Loc)), + + -- E.4.1(9) A remote call is asynchronous if it is a call to + -- a procedure, or a call through a value of an access-to-procedure + -- type, to which a pragma Asynchronous applies. + + -- Parameter Asynch_P is true when the procedure is asynchronous; + -- Expression Asynch_T is true when the type is asynchronous. + + Set_Field (Name_Asynchronous, + Make_Or_Else (Loc, + New_Occurrence_Of (Asynch_P, Loc), + New_Occurrence_Of (Boolean_Literals ( + Is_Asynchronous (Ras_Type)), Loc)))); + + Append_List_To (Proc_Statements, + Build_Get_Unique_RP_Call + (Loc, Stub_Ptr, Stub_Elements.Stub_Type)); + + -- Return the newly created value + + Append_To (Proc_Statements, + Make_Return_Statement (Loc, + Expression => + Unchecked_Convert_To (Fat_Type, + New_Occurrence_Of (Stub_Ptr, Loc)))); - else - New_Scope (Scop); - end if; + Proc_Spec := + Make_Function_Specification (Loc, + Defining_Unit_Name => Proc, + Parameter_Specifications => New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => Package_Name, + Parameter_Type => + New_Occurrence_Of (Standard_String, Loc)), - Analyze (RCI_Locator); - Pop_Scope; - end; + Make_Parameter_Specification (Loc, + Defining_Identifier => Subp_Id, + Parameter_Type => + New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc)), - RCI_Cache := Defining_Unit_Name (RCI_Locator); + Make_Parameter_Specification (Loc, + Defining_Identifier => Asynch_P, + Parameter_Type => + New_Occurrence_Of (Standard_Boolean, Loc)), - else - RCI_Locator := Parent (RCI_Cache); - end if; + Make_Parameter_Specification (Loc, + Defining_Identifier => All_Calls_Remote, + Parameter_Type => + New_Occurrence_Of (Standard_Boolean, Loc))), - Calling_Stubs := Build_Subprogram_Calling_Stubs - (Vis_Decl => Parent (Parent (Called_Subprogram)), - Subp_Id => Get_Subprogram_Id (Called_Subprogram), - Asynchronous => Nkind (N) = N_Procedure_Call_Statement - and then - Is_Asynchronous (Called_Subprogram), - Locator => RCI_Cache, - New_Name => New_Internal_Name ('S')); - Insert_After (RCI_Locator, Calling_Stubs); - Analyze (Calling_Stubs); - E_Calling_Stubs := Defining_Unit_Name (Specification (Calling_Stubs)); - end if; + Subtype_Mark => + New_Occurrence_Of (Fat_Type, Loc)); - Rewrite (Name (N), New_Occurrence_Of (E_Calling_Stubs, Loc)); - end Expand_All_Calls_Remote_Subprogram_Call; + -- Set the kind and return type of the function to prevent + -- ambiguities between Ras_Type and Fat_Type in subsequent analysis. - --------------------------------- - -- Expand_Calling_Stubs_Bodies -- - --------------------------------- + Set_Ekind (Proc, E_Function); + Set_Etype (Proc, Fat_Type); - procedure Expand_Calling_Stubs_Bodies (Unit_Node : Node_Id) is - Spec : constant Node_Id := Specification (Unit_Node); - Decls : constant List_Id := Visible_Declarations (Spec); + Discard_Node ( + Make_Subprogram_Body (Loc, + Specification => Proc_Spec, + Declarations => Proc_Decls, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Proc_Statements))); - begin - New_Scope (Scope_Of_Spec (Spec)); - Add_Calling_Stubs_To_Declarations (Specification (Unit_Node), - Decls); - Pop_Scope; - end Expand_Calling_Stubs_Bodies; + Set_TSS (Fat_Type, Proc); + end Add_RAS_Access_TSS; - ----------------------------------- - -- Expand_Receiving_Stubs_Bodies -- - ----------------------------------- + ----------------------- + -- Add_RAST_Features -- + ----------------------- - procedure Expand_Receiving_Stubs_Bodies (Unit_Node : Node_Id) is - Spec : Node_Id; - Decls : List_Id; - Temp : List_Id; + procedure Add_RAST_Features + (Vis_Decl : Node_Id; + RAS_Type : Entity_Id; + Decls : List_Id) + is + pragma Warnings (Off); + pragma Unreferenced (RAS_Type, Decls); + pragma Warnings (On); + begin + Add_RAS_Access_TSS (Vis_Decl); + end Add_RAST_Features; - begin - if Nkind (Unit_Node) = N_Package_Declaration then - Spec := Specification (Unit_Node); - Decls := Visible_Declarations (Spec); - New_Scope (Scope_Of_Spec (Spec)); - Add_Receiving_Stubs_To_Declarations (Spec, Decls); + ------------ + -- Result -- + ------------ - else - Spec := - Package_Specification_Of_Scope (Corresponding_Spec (Unit_Node)); - Decls := Declarations (Unit_Node); - New_Scope (Scope_Of_Spec (Unit_Node)); - Temp := New_List; - Add_Receiving_Stubs_To_Declarations (Spec, Temp); - Insert_List_Before (First (Decls), Temp); - end if; + function Result return Node_Id is + begin + return Make_Identifier (Loc, Name_V); + end Result; - Pop_Scope; - end Expand_Receiving_Stubs_Bodies; + ---------------------- + -- Stream_Parameter -- + ---------------------- - ------------------------- - -- Get_Pkg_Name_string -- - ------------------------- + function Stream_Parameter return Node_Id is + begin + return Make_Identifier (Loc, Name_S); + end Stream_Parameter; + + end GARLIC_Support; - procedure Get_Pkg_Name_String (Decl_Node : Node_Id) is - Unit_Name_Id : constant Unit_Name_Type := Get_Unit_Name (Decl_Node); + ------------------ + -- Get_PCS_Name -- + ------------------ + function Get_PCS_Name return PCS_Names is + PCS_Name : constant PCS_Names := + Chars (Entity (Expression (Parent (RTE (RE_DSA_Implementation))))); begin - Get_Unit_Name_String (Unit_Name_Id); + return PCS_Name; + end Get_PCS_Name; - -- Remove seven last character (" (spec)" or " (body)"). + ----------------------- + -- Get_Subprogram_Id -- + ----------------------- - Name_Len := Name_Len - 7; - pragma Assert (Name_Buffer (Name_Len + 1) = ' '); - end Get_Pkg_Name_String; + function Get_Subprogram_Id (Def : Entity_Id) return String_Id is + begin + return Get_Subprogram_Ids (Def).Str_Identifier; + end Get_Subprogram_Id; ----------------------- -- Get_Subprogram_Id -- ----------------------- - function Get_Subprogram_Id (E : Entity_Id) return Int is + function Get_Subprogram_Id (Def : Entity_Id) return Int is + begin + return Get_Subprogram_Ids (Def).Int_Identifier; + end Get_Subprogram_Id; + + ------------------------ + -- Get_Subprogram_Ids -- + ------------------------ + + function Get_Subprogram_Ids + (Def : Entity_Id) return Subprogram_Identifiers + is + Result : Subprogram_Identifiers := + Subprogram_Identifier_Table.Get (Def); + Current_Declaration : Node_Id; - Result : Int := First_RCI_Subprogram_Id; + Current_Subp : Entity_Id; + Current_Subp_Str : String_Id; + Current_Subp_Number : Int := First_RCI_Subprogram_Id; begin - pragma Assert - (Is_Remote_Call_Interface (Scope (E)) - and then - (Nkind (Parent (E)) = N_Procedure_Specification - or else - Nkind (Parent (E)) = N_Function_Specification)); + if Result.Str_Identifier = No_String then - Current_Declaration := - First (Visible_Declarations - (Package_Specification_Of_Scope (Scope (E)))); + -- We are looking up this subprogram's identifier outside of the + -- context of generating calling or receiving stubs. Hence we are + -- processing an 'Access attribute_reference for an RCI subprogram, + -- for the purpose of obtaining a RAS value. - while Current_Declaration /= Empty loop - if Nkind (Current_Declaration) = N_Subprogram_Declaration - and then Comes_From_Source (Current_Declaration) - then - if Defining_Unit_Name - (Specification (Current_Declaration)) = E + pragma Assert + (Is_Remote_Call_Interface (Scope (Def)) + and then + (Nkind (Parent (Def)) = N_Procedure_Specification + or else + Nkind (Parent (Def)) = N_Function_Specification)); + + Current_Declaration := + First (Visible_Declarations + (Package_Specification_Of_Scope (Scope (Def)))); + while Present (Current_Declaration) loop + if Nkind (Current_Declaration) = N_Subprogram_Declaration + and then Comes_From_Source (Current_Declaration) then - return Result; - end if; + Current_Subp := Defining_Unit_Name (Specification ( + Current_Declaration)); + Assign_Subprogram_Identifier + (Current_Subp, Current_Subp_Number, Current_Subp_Str); - Result := Result + 1; - end if; + if Current_Subp = Def then + Result := (Current_Subp_Str, Current_Subp_Number); + end if; - Next (Current_Declaration); - end loop; + Current_Subp_Number := Current_Subp_Number + 1; + end if; - -- Error if we do not find it + Next (Current_Declaration); + end loop; + end if; - raise Program_Error; - end Get_Subprogram_Id; + pragma Assert (Result.Str_Identifier /= No_String); + return Result; + end Get_Subprogram_Ids; ---------- -- Hash -- @@ -4142,6 +4451,15 @@ package body Exp_Dist is return Hash_Index (Natural (F) mod Positive (Hash_Index'Last + 1)); end Hash; + ---------- + -- Hash -- + ---------- + + function Hash (F : Name_Id) return Hash_Index is + begin + return Hash_Index (Natural (F) mod Positive (Hash_Index'Last + 1)); + end Hash; + -------------------------- -- Input_With_Tag_Check -- -------------------------- @@ -4149,8 +4467,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 : Entity_Id) return Node_Id is begin return @@ -4177,8 +4494,7 @@ package body Exp_Dist is function Is_RACW_Controlling_Formal (Parameter : Node_Id; - Stub_Type : Entity_Id) - return Boolean + Stub_Type : Entity_Id) return Boolean is Typ : Entity_Id; @@ -4237,7 +4553,6 @@ package body Exp_Dist is function Need_Extra_Constrained (Parameter : Node_Id) return Boolean is Etyp : constant Entity_Id := Etype (Parameter_Type (Parameter)); - begin return Out_Present (Parameter) and then Has_Discriminants (Etyp) @@ -4258,7 +4573,7 @@ package body Exp_Dist is Typ : Entity_Id; begin - if Etyp /= Empty then + if Present (Etyp) then Typ := Etyp; else Typ := Etype (Object); @@ -4325,13 +4640,55 @@ package body Exp_Dist is Object)); end Pack_Node_Into_Stream_Access; + --------------------- + -- PolyORB_Support -- + --------------------- + + package body PolyORB_Support is + + pragma Warnings (Off); + -- Currently, this package contains empty placeholders + -- that do not reference their parameters. + + ----------------------- + -- Add_RACW_Features -- + ----------------------- + + procedure Add_RACW_Features + (RACW_Type : Entity_Id; + Desig : Entity_Id; + Stub_Type : Entity_Id; + Stub_Type_Access : Entity_Id; + RPC_Receiver_Decl : Node_Id; + Declarations : List_Id) + is + begin + raise Program_Error; + end Add_RACW_Features; + + ----------------------- + -- Add_RAST_Features -- + ----------------------- + + procedure Add_RAST_Features + (Vis_Decl : Node_Id; + RAS_Type : Entity_Id; + Decls : List_Id) is + begin + raise Program_Error; + end Add_RAST_Features; + + pragma Warnings (On); + + end PolyORB_Support; + ------------------------------- -- RACW_Type_Is_Asynchronous -- ------------------------------- procedure RACW_Type_Is_Asynchronous (RACW_Type : Entity_Id) is Asynchronous_Flag : constant Entity_Id := - Asynchronous_Flags_Table.Get (RACW_Type); + Asynchronous_Flags_Table.Get (RACW_Type); begin Replace (Expression (Parent (Asynchronous_Flag)), New_Occurrence_Of (Standard_True, Sloc (Asynchronous_Flag))); @@ -4345,11 +4702,11 @@ package body Exp_Dist is (Loc : Source_Ptr; Package_Spec : Node_Id) return Node_Id is - Inst : Node_Id; + Inst : Node_Id; Pkg_Name : String_Id; begin - Get_Pkg_Name_String (Package_Spec); + Get_Library_Unit_Name_String (Package_Spec); Pkg_Name := String_From_Name_Buffer; Inst := Make_Package_Instantiation (Loc, @@ -4379,12 +4736,11 @@ package body Exp_Dist is is Stub_Elements : constant Stub_Structure := Stubs_Table.Get (Full_View); - begin if Stub_Elements /= Empty_Stub_Structure then Add_RACW_Primitive_Declarations_And_Bodies (Full_View, - Parent (Declaration_Node (Stub_Elements.Object_RPC_Receiver)), + Stub_Elements.RPC_Receiver_Decl, List_Containing (Declaration_Node (Full_View))); end if; end Remote_Types_Tagged_Full_View_Encountered; @@ -4404,6 +4760,93 @@ package body Exp_Dist is return Unit_Name; end Scope_Of_Spec; + ---------------------- + -- Set_Renaming_TSS -- + ---------------------- + + procedure Set_Renaming_TSS + (Typ : Entity_Id; + Nam : Entity_Id; + TSS_Nam : Name_Id) + is + Loc : constant Source_Ptr := Sloc (Nam); + Spec : constant Node_Id := Parent (Nam); + + TSS_Node : constant Node_Id := + Make_Subprogram_Renaming_Declaration (Loc, + Specification => + Copy_Specification (Loc, + Spec => Spec, + New_Name => TSS_Nam), + Name => New_Occurrence_Of (Nam, Loc)); + + Snam : constant Entity_Id := + Defining_Unit_Name (Specification (TSS_Node)); + + begin + if Nkind (Spec) = N_Function_Specification then + Set_Ekind (Snam, E_Function); + Set_Etype (Snam, Entity (Subtype_Mark (Spec))); + else + Set_Ekind (Snam, E_Procedure); + Set_Etype (Snam, Standard_Void_Type); + end if; + Set_TSS (Typ, Snam); + end Set_Renaming_TSS; + + -------------------------------- + -- Specific_Add_RACW_Features -- + -------------------------------- + + procedure Specific_Add_RACW_Features + (RACW_Type : Entity_Id; + Desig : Entity_Id; + Stub_Type : Entity_Id; + Stub_Type_Access : Entity_Id; + RPC_Receiver_Decl : Node_Id; + Declarations : List_Id) + is + begin + case Get_PCS_Name is + when Name_PolyORB_DSA => + PolyORB_Support.Add_RACW_Features ( + RACW_Type, + Desig, + Stub_Type, + Stub_Type_Access, + RPC_Receiver_Decl, + Declarations); + + when others => + GARLIC_Support.Add_RACW_Features ( + RACW_Type, + Stub_Type, + Stub_Type_Access, + RPC_Receiver_Decl, + Declarations); + end case; + end Specific_Add_RACW_Features; + + -------------------------------- + -- Specific_Add_RAST_Features -- + -------------------------------- + + procedure Specific_Add_RAST_Features + (Vis_Decl : Node_Id; + RAS_Type : Entity_Id; + Decls : List_Id) + is + begin + case Get_PCS_Name is + when Name_PolyORB_DSA => + PolyORB_Support.Add_RAST_Features ( + Vis_Decl, RAS_Type, Decls); + when others => + GARLIC_Support.Add_RAST_Features ( + Vis_Decl, RAS_Type, Decls); + end case; + end Specific_Add_RAST_Features; + -------------------------- -- Underlying_RACW_Type -- -------------------------- diff --git a/gcc/ada/sem_dist.adb b/gcc/ada/sem_dist.adb index 8314e6c..c0fccfd 100644 --- a/gcc/ada/sem_dist.adb +++ b/gcc/ada/sem_dist.adb @@ -43,7 +43,6 @@ with Snames; use Snames; with Stand; use Stand; with Stringt; use Stringt; with Tbuild; use Tbuild; -with Uname; use Uname; package body Sem_Dist is @@ -290,18 +289,10 @@ package body Sem_Dist is end if; -- Get and store the String_Id corresponding to the name of the - -- library unit whose Partition_Id is needed + -- library unit whose Partition_Id is needed. - Get_Unit_Name_String (Get_Unit_Name (Unit_Declaration_Node (Ety))); - - -- Remove seven last character ("(spec)" or " (body)"). - -- (this is a bit nasty, should have interface for this ???) - - Name_Len := Name_Len - 7; - - Start_String; - Store_String_Chars (Name_Buffer (1 .. Name_Len)); - Prefix_String := End_String; + Get_Library_Unit_Name_String (Unit_Declaration_Node (Ety)); + Prefix_String := String_From_Name_Buffer; -- Build the function call which will replace the attribute @@ -510,9 +501,6 @@ package body Sem_Dist is Name_Class)))); Set_Is_Remote_Call_Interface (RACW_Type, Is_RCI); Set_Is_Remote_Types (RACW_Type, Is_RT); - -- ??? Object RPC receiver generation should be bypassed for this - -- RACW type, since actually calls will be received by the package - -- RPC receiver for the designated RCI subprogram. Subpkg_Decl := Make_Package_Declaration (Loc, diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 0fcad3e..22066fe 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -58,6 +58,7 @@ with Stringt; use Stringt; with Targparm; use Targparm; with Tbuild; use Tbuild; with Ttypes; use Ttypes; +with Uname; use Uname; package body Sem_Util is @@ -2620,6 +2621,22 @@ package body Sem_Util is end if; end Get_Index_Bounds; + ---------------------------------- + -- Get_Library_Unit_Name_string -- + ---------------------------------- + + procedure Get_Library_Unit_Name_String (Decl_Node : Node_Id) is + Unit_Name_Id : constant Unit_Name_Type := Get_Unit_Name (Decl_Node); + + begin + Get_Unit_Name_String (Unit_Name_Id); + + -- Remove seven last character (" (spec)" or " (body)"). + + Name_Len := Name_Len - 7; + pragma Assert (Name_Buffer (Name_Len + 1) = ' '); + end Get_Library_Unit_Name_String; + ------------------------ -- Get_Name_Entity_Id -- ------------------------ @@ -2864,6 +2881,43 @@ package body Sem_Util is end if; end Has_Private_Component; + ---------------- + -- Has_Stream -- + ---------------- + + function Has_Stream (T : Entity_Id) return Boolean is + E : Entity_Id; + + begin + if No (T) then + return False; + + elsif Is_RTE (Root_Type (T), RE_Root_Stream_Type) then + return True; + + elsif Is_Array_Type (T) then + return Has_Stream (Component_Type (T)); + + elsif Is_Record_Type (T) then + E := First_Component (T); + while Present (E) loop + if Has_Stream (Etype (E)) then + return True; + else + Next_Component (E); + end if; + end loop; + + return False; + + elsif Is_Private_Type (T) then + return Has_Stream (Underlying_Type (T)); + + else + return False; + end if; + end Has_Stream; + -------------------------- -- Has_Tagged_Component -- -------------------------- @@ -5267,7 +5321,13 @@ package body Sem_Util is goto Continue; end if; - Generate_Reference (Ent, Exp, 'm'); + -- Generate a reference only if the assignment comes from + -- source. This excludes, for example, calls to a dispatching + -- assignment operation when the left-hand side is tagged. + + if Modification_Comes_From_Source then + Generate_Reference (Ent, Exp, 'm'); + end if; end if; Kill_Checks (Ent); diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index a356eae..9ee5637 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -333,6 +333,10 @@ package Sem_Util is -- The third argument supplies a source location for constructed -- nodes returned by this function. + procedure Get_Library_Unit_Name_String (Decl_Node : Node_Id); + -- Retrieve the fully expanded name of the library unit declared by + -- Decl_Node into the name buffer. + function Get_Name_Entity_Id (Id : Name_Id) return Entity_Id; -- An entity value is associated with each name in the name table. The -- Get_Name_Entity_Id function fetches the Entity_Id of this entity, @@ -374,6 +378,14 @@ package Sem_Util is -- Check if a type has a (sub)component of a private type that has not -- yet received a full declaration. + function Has_Stream (T : Entity_Id) return Boolean; + -- Tests if type T is derived from Ada.Streams.Root_Stream_Type, or + -- in the case of a composite type, has a component for which this + -- predicate is True, and if so returns True. Otherwise a result of + -- False means that there is no Stream type in sight. For a private + -- type, the test is applied to the underlying type (or returns False + -- if there is no underlying type). + function Has_Tagged_Component (Typ : Entity_Id) return Boolean; -- Typ must be a composite type (array or record). This function is used -- to check if '=' has to be expanded into a bunch component comparaisons. diff --git a/gcc/ada/snames.ads b/gcc/ada/snames.ads index 8cb38b5..10eb49b 100644 --- a/gcc/ada/snames.ads +++ b/gcc/ada/snames.ads @@ -237,9 +237,14 @@ package Snames is -- Names of implementations of the distributed systems annex + First_PCS_Name : constant Name_Id := N + 064; Name_No_DSA : constant Name_Id := N + 064; Name_GARLIC_DSA : constant Name_Id := N + 065; Name_PolyORB_DSA : constant Name_Id := N + 066; + Last_PCS_Name : constant Name_Id := N + 066; + + subtype PCS_Names is Name_Id + range First_PCS_Name .. Last_PCS_Name; -- Names of identifiers used in expanding distribution stubs -- 2.7.4