From: Arnaud Charlet Date: Wed, 8 Dec 2004 11:46:11 +0000 (+0100) Subject: exp_dist.adb (Specific_Build_General_Calling_Stubs, [...]): New subprograms. X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=bd7f7a653fcfe6f9e6c62d18522d8792341cfd48;p=gcc.git exp_dist.adb (Specific_Build_General_Calling_Stubs, [...]): New subprograms. * exp_dist.adb (Specific_Build_General_Calling_Stubs, Specific_Build_Stub_Target): New subprograms. (Build_Subprogram_Calling_Stubs): Make this procedure independent from the PCS implementation used, using the above PCS-customized subprograms. Minor reformatting. (PolyORB_Support.Helpers): New subunit containing supporting subprograms for generation of DSA code targeted to the PolyORB PCS. (Add_Stub_Type): Rewrite to isolate the parts that are specific to one implementation of the partition communication subsystem in ancillary subprograms. (Specific_Build_Stub_Type, GARLIC_Support.Build_Stub_Type, PolyORB_Support.Build_Stub_Type): New subrograms containing the PCS-specific part of Add_Stub_Type. (Insert_Partition_Check): Use runtime library function to perform E.4(19) check. * rtsfind.ads: New entity System.PolyORB_Interface.Make_Ref (RE_Same_Partition): New entity, from s-parint. * s-parint.ads, s-parint.adb (Same_Partition): New subprogram. From-SVN: r91884 --- diff --git a/gcc/ada/exp_dist.adb b/gcc/ada/exp_dist.adb index cb00cc589a7..effeee69b44 100644 --- a/gcc/ada/exp_dist.adb +++ b/gcc/ada/exp_dist.adb @@ -41,12 +41,14 @@ with Sem; use Sem; with Sem_Ch3; use Sem_Ch3; with Sem_Ch8; use Sem_Ch8; with Sem_Dist; use Sem_Dist; +with Sem_Eval; use Sem_Eval; with Sem_Util; use Sem_Util; with Sinfo; use Sinfo; with Snames; use Snames; with Stand; use Stand; with Stringt; use Stringt; with Tbuild; use Tbuild; +with Ttypes; use Ttypes; with Uintp; use Uintp; package body Exp_Dist is @@ -186,40 +188,6 @@ package body Exp_Dist is -- 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; - 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); - -- Build calling stubs for general purpose. The parameters are: - -- Decls : a place to put declarations - -- Statements : a place to put statements - -- Target_Partition : a node containing the target partition that must - -- be a N_Defining_Identifier - -- RPC_Receiver : a node containing the RPC receiver - -- Subprogram_Id : a node containing the subprogram ID - -- Asynchronous : True if an APC must be made instead of an RPC. - -- The value needs not be supplied if one of the - -- Is_Known_... is True. - -- Is_Known_Async... : True if we know that this is asynchronous - -- Is_Known_Non_A... : True if we know that this is not asynchronous - -- Spec : a node with a Parameter_Specifications and - -- a Subtype_Mark if applicable - -- Stub_Type : in case of RACW stubs, parameters of type access - -- to Stub_Type will be marshalled using the - -- address of the object (the addr field) rather - -- than using the 'Write on the stub itself - -- Nod : used to provide sloc for generated code - function Build_Subprogram_Calling_Stubs (Vis_Decl : Node_Id; Subp_Id : Node_Id; @@ -254,15 +222,8 @@ package body Exp_Dist is -- class-wide type before doing the real call using any of the RACW type -- pointing on the designated type. - function Build_RPC_Receiver_Specification - (RPC_Receiver : Entity_Id; - Stream_Parameter : Entity_Id; - Result_Parameter : Entity_Id) return Node_Id; - -- Make a subprogram specification for an RPC receiver, - -- with the given defining unit name and formal parameters. - procedure Build_RPC_Receiver_Body - (RPC_Receiver : Entity_Id; + (RPC_Receiver : Entity_Id; Stream : out Entity_Id; Result : out Entity_Id; Subp_Id : out Entity_Id; @@ -331,11 +292,6 @@ package body Exp_Dist is -- 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. @@ -345,11 +301,32 @@ package body Exp_Dist is -- Return True if the current parameter is a controlling formal argument -- of type Stub_Type or access to Stub_Type. + procedure Declare_Create_NVList + (Loc : Source_Ptr; + NVList : Entity_Id; + Decls : List_Id; + Stmts : List_Id); + -- Append the declaration of NVList to Decls, and its + -- initialization to Stmts. + + function Add_Parameter_To_NVList + (Loc : Source_Ptr; + NVList : Entity_Id; + Parameter : Entity_Id; + Constrained : Boolean; + RACW_Ctrl : Boolean := False; + Any : Entity_Id) return Node_Id; + -- Return a call to Add_Item to add the Any corresponding + -- to the designated formal Parameter (with the indicated + -- Constrained status) to NVList. RACW_Ctrl must be set to + -- True for controlling formals of distributed object primitive + -- operations. + type Stub_Structure is record - Stub_Type : Entity_Id; - Stub_Type_Access : Entity_Id; - RPC_Receiver_Decl : Node_Id; - RACW_Type : Entity_Id; + Stub_Type : Entity_Id; + Stub_Type_Access : Entity_Id; + RPC_Receiver_Decl : Node_Id; + RACW_Type : Entity_Id; end record; -- This structure is necessary because of the two phases analysis of -- a RACW declaration occurring in the same Remote_Types package as the @@ -403,13 +380,13 @@ package body Exp_Dist is -- Mapping between a RCI subprogram and the corresponding calling stubs 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); + (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); -- 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, -- then nothing is added in the tree but the right values are returned @@ -491,10 +468,88 @@ package body Exp_Dist is -- bodies are inserted at the end of Decls. PCS-specific ancillary -- subprogram for Add_RAST_Features. + -- An RPC_Target record is used during construction of calling stubs + -- to pass PCS-specific tree fragments corresponding to the information + -- necessary to locate the target of a remote subprogram call. + + type RPC_Target (PCS_Kind : PCS_Names) is record + case PCS_Kind is + when Name_PolyORB_DSA => + Object : Node_Id; + -- An expression whose value is a PolyORB reference to the target + -- object. + when others => + Partition : Entity_Id; + -- A variable containing the Partition_ID of the target parition + + RPC_Receiver : Node_Id; + -- An expression whose value is the address of the target RPC + -- receiver. + end case; + end record; + + procedure Specific_Build_General_Calling_Stubs + (Decls : List_Id; + Statements : List_Id; + Target : RPC_Target; + Subprogram_Id : Node_Id; + Asynchronous : Node_Id := Empty; + Is_Known_Asynchronous : Boolean := False; + Is_Known_Non_Asynchronous : Boolean := False; + Is_Function : Boolean; + Spec : Node_Id; + Stub_Type : Entity_Id := Empty; + RACW_Type : Entity_Id := Empty; + Nod : Node_Id); + -- Build calling stubs for general purpose. The parameters are: + -- Decls : a place to put declarations + -- Statements : a place to put statements + -- Target : PCS-specific target information (see details + -- in RPC_Target declaration). + -- Subprogram_Id : a node containing the subprogram ID + -- Asynchronous : True if an APC must be made instead of an RPC. + -- The value needs not be supplied if one of the + -- Is_Known_... is True. + -- Is_Known_Async... : True if we know that this is asynchronous + -- Is_Known_Non_A... : True if we know that this is not asynchronous + -- Spec : a node with a Parameter_Specifications and + -- a Subtype_Mark if applicable + -- Stub_Type : in case of RACW stubs, parameters of type access + -- to Stub_Type will be marshalled using the + -- address of the object (the addr field) rather + -- than using the 'Write on the stub itself + -- Nod : used to provide sloc for generated code + + function Specific_Build_Stub_Target + (Loc : Source_Ptr; + Decls : List_Id; + RCI_Locator : Entity_Id; + Controlling_Parameter : Entity_Id) return RPC_Target; + -- Build call target information nodes for use within calling stubs. In the + -- RCI case, RCI_Locator is the entity for the instance of RCI_Locator. If + -- for an RACW, Controlling_Parameter is the entity for the controlling + -- formal parameter used to determine the location of the target of the + -- call. Decls provides a location where variable declarations can be + -- appended to construct the necessary values. + + procedure Specific_Build_Stub_Type + (RACW_Type : Entity_Id; + Stub_Type : Entity_Id; + Stub_Type_Decl : out Node_Id; + RPC_Receiver_Decl : out Node_Id); + -- Build a type declaration for the stub type associated with an RACW + -- type, and the necessary RPC receiver, if applicable. PCS-specific + -- ancillary subprogram for Add_Stub_Type. If no RPC receiver declaration + -- is generated, then RPC_Receiver_Decl is set to Empty. + package GARLIC_Support is -- Support for generating DSA code that uses the GARLIC PCS + -- The subprograms below provide the GARLIC versions of + -- the corresponding Specific_ routine declared + -- above. + procedure Add_RACW_Features (RACW_Type : Entity_Id; Stub_Type : Entity_Id; @@ -507,12 +562,50 @@ package body Exp_Dist is RAS_Type : Entity_Id; Decls : List_Id); + procedure Build_General_Calling_Stubs + (Decls : List_Id; + Statements : List_Id; + Target_Partition : Entity_Id; -- From RPC_Target + Target_RPC_Receiver : Node_Id; -- From RPC_Target + Subprogram_Id : Node_Id; + Asynchronous : Node_Id := Empty; + Is_Known_Asynchronous : Boolean := False; + Is_Known_Non_Asynchronous : Boolean := False; + Is_Function : Boolean; + Spec : Node_Id; + Stub_Type : Entity_Id := Empty; + RACW_Type : Entity_Id := Empty; + Nod : Node_Id); + + function Build_Stub_Target + (Loc : Source_Ptr; + Decls : List_Id; + RCI_Locator : Entity_Id; + Controlling_Parameter : Entity_Id) return RPC_Target; + + procedure Build_Stub_Type + (RACW_Type : Entity_Id; + Stub_Type : Entity_Id; + Stub_Type_Decl : out Node_Id; + RPC_Receiver_Decl : out Node_Id); + + function Build_RPC_Receiver_Specification + (RPC_Receiver : Entity_Id; + Stream_Parameter : Entity_Id; + Result_Parameter : Entity_Id) return Node_Id; + -- Make a subprogram specification for an RPC receiver, + -- with the given defining unit name and formal parameters. + end GARLIC_Support; package PolyORB_Support is -- Support for generating DSA code that uses the PolyORB PCS + -- The subprograms below provide the PolyORB versions of + -- the corresponding Specific_ routine declared + -- above. + procedure Add_RACW_Features (RACW_Type : Entity_Id; Desig : Entity_Id; @@ -526,6 +619,130 @@ package body Exp_Dist is RAS_Type : Entity_Id; Decls : List_Id); + procedure Build_General_Calling_Stubs + (Decls : List_Id; + Statements : List_Id; + Target_Object : Node_Id; -- From RPC_Target + Subprogram_Id : Node_Id; + Asynchronous : Node_Id := Empty; + Is_Known_Asynchronous : Boolean := False; + Is_Known_Non_Asynchronous : Boolean := False; + Is_Function : Boolean; + Spec : Node_Id; + Stub_Type : Entity_Id := Empty; + RACW_Type : Entity_Id := Empty; + Nod : Node_Id); + + function Build_Stub_Target + (Loc : Source_Ptr; + Decls : List_Id; + RCI_Locator : Entity_Id; + Controlling_Parameter : Entity_Id) return RPC_Target; + + procedure Build_Stub_Type + (RACW_Type : Entity_Id; + Stub_Type : Entity_Id; + Stub_Type_Decl : out Node_Id; + RPC_Receiver_Decl : out Node_Id); + + function Build_RPC_Receiver_Specification + (RPC_Receiver : Entity_Id; + Request_Parameter : Entity_Id) return Node_Id; + -- Make a subprogram specification for an RPC receiver, + -- with the given defining unit name and formal parameters. + + pragma Warnings (Off); + pragma Unreferenced (Build_RPC_Receiver_Specification); + -- XXX PolyORB support is not completely included yet + pragma Warnings (On); + + package Helpers is + + -- Routines to build distribtion helper subprograms for user-defined + -- types. For implementation of the Distributed systems annex (DSA) + -- over the PolyORB generic middleware components, it is necessary to + -- generate several supporting subprograms for each application data + -- type used in inter-partition communication. These subprograms are: + -- * a Typecode function returning a high-level description of the + -- type's structure; + -- * two conversion functions allowing conversion of values of the + -- type from and to the generic data containers used by PolyORB. + -- These generic containers are called 'Any' type values after + -- the CORBA terminology, and hence the conversion subprograms + -- are named To_Any and From_Any. + + + function Build_From_Any_Call + (Typ : Entity_Id; + N : Node_Id; + Decls : List_Id) return Node_Id; + -- Build call to From_Any attribute function of type Typ with + -- expression N as actual parameter. Decls is the declarations list + -- for an appropriate enclosing scope of the point where the call + -- will be inserted; if the From_Any attribute for Typ needs to be + -- generated at this point, its declaration is appended to Decls. + + procedure Build_From_Any_Function + (Loc : Source_Ptr; + Typ : Entity_Id; + Decl : out Node_Id; + Fnam : out Entity_Id); + -- Build From_Any attribute function for Typ. Loc is the reference + -- location for generated nodes, Typ is the type for which the + -- conversion function is generated. On return, Decl and Fnam contain + -- the declaration and entity for the newly-created function. + + function Build_To_Any_Call + (N : Node_Id; + Decls : List_Id) return Node_Id; + -- Build call to To_Any attribute function with expression as actual + -- parameter. Decls is the declarations list for an appropriate + -- enclosing scope of the point where the call will be inserted; if + -- the To_Any attribute for Typ needs to be generated at this point, + -- its declaration is appended to Decls. + + procedure Build_To_Any_Function + (Loc : Source_Ptr; + Typ : Entity_Id; + Decl : out Node_Id; + Fnam : out Entity_Id); + -- Build To_Any attribute function for Typ. Loc is the reference + -- location for generated nodes, Typ is the type for which the + -- conversion function is generated. On return, Decl and Fnam contain + -- the declaration and entity for the newly-created function. + + function Build_TypeCode_Call + (Loc : Source_Ptr; + Typ : Entity_Id; + Decls : List_Id) return Node_Id; + -- Build call to TypeCode attribute function for Typ. Decls is the + -- declarations list for an appropriate enclosing scope of the point + -- where the call will be inserted; if the To_Any attribute for Typ + -- needs to be generated at this point, its declaration is appended + -- to Decls. + + procedure Build_TypeCode_Function + (Loc : Source_Ptr; + Typ : Entity_Id; + Decl : out Node_Id; + Fnam : out Entity_Id); + -- Build TypeCode attribute function for Typ. Loc is the reference + -- location for generated nodes, Typ is the type for which the + -- conversion function is generated. On return, Decl and Fnam contain + -- the declaration and entity for the newly-created function. + + procedure Build_Name_And_Repository_Id + (E : Entity_Id; + Name_Str : out String_Id; + Repo_Id_Str : out String_Id); + -- In the PolyORB distribution model, each distributed object type + -- and each distributed operation has a globally unique identifier, + -- its Repository Id. This subprogram builds and returns two strings + -- for entity E (a distributed object type or operation): one + -- containing the name of E, the second containing its repository id. + + end Helpers; + end PolyORB_Support; ------------------------------------ @@ -616,6 +833,99 @@ package body Exp_Dist is end loop; end Add_Calling_Stubs_To_Declarations; + ----------------------------- + -- Add_Parameter_To_NVList -- + ----------------------------- + + function Add_Parameter_To_NVList + (Loc : Source_Ptr; + NVList : Entity_Id; + Parameter : Entity_Id; + Constrained : Boolean; + RACW_Ctrl : Boolean := False; + Any : Entity_Id) return Node_Id + is + Parameter_Name_String : String_Id; + Parameter_Mode : Node_Id; + + function Parameter_Passing_Mode + (Loc : Source_Ptr; + Parameter : Entity_Id; + Constrained : Boolean) return Node_Id; + -- Return an expression that denotes the parameter passing + -- mode to be used for Parameter in distribution stubs, + -- where Constrained is Parameter's constrained status. + + ---------------------------- + -- Parameter_Passing_Mode -- + ---------------------------- + + function Parameter_Passing_Mode + (Loc : Source_Ptr; + Parameter : Entity_Id; + Constrained : Boolean) return Node_Id + is + Lib_RE : RE_Id; + + begin + if Out_Present (Parameter) then + if In_Present (Parameter) + or else not Constrained + then + -- Unconstrained formals must be translated + -- to 'in' or 'inout', not 'out', because + -- they need to be constrained by the actual. + + Lib_RE := RE_Mode_Inout; + else + Lib_RE := RE_Mode_Out; + end if; + + else + Lib_RE := RE_Mode_In; + end if; + + return New_Occurrence_Of (RTE (Lib_RE), Loc); + end Parameter_Passing_Mode; + + -- Start of processing for Add_Parameter_To_NVList + + begin + if Nkind (Parameter) = N_Defining_Identifier then + Get_Name_String (Chars (Parameter)); + else + Get_Name_String (Chars (Defining_Identifier + (Parameter))); + end if; + + Parameter_Name_String := String_From_Name_Buffer; + + if RACW_Ctrl then + Parameter_Mode := New_Occurrence_Of + (RTE (RE_Mode_In), Loc); + else + Parameter_Mode := Parameter_Passing_Mode (Loc, + Parameter, Constrained); + end if; + + return + Make_Procedure_Call_Statement (Loc, + Name => + New_Occurrence_Of + (RTE (RE_NVList_Add_Item), Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of (NVList, Loc), + Make_Function_Call (Loc, + Name => + New_Occurrence_Of + (RTE (RE_To_PolyORB_String), Loc), + Parameter_Associations => New_List ( + Make_String_Literal (Loc, + Strval => Parameter_Name_String))), + New_Occurrence_Of (Any, Loc), + Parameter_Mode)); + end Add_Parameter_To_NVList; + -------------------------------- -- Add_RACW_Asynchronous_Flag -- -------------------------------- @@ -658,10 +968,10 @@ package body Exp_Dist is Same_Scope : constant Boolean := Scope (Desig) = Scope (RACW_Type); - Stub_Type : Entity_Id; - Stub_Type_Access : Entity_Id; - RPC_Receiver_Decl : Node_Id; - Existing : Boolean; + Stub_Type : Entity_Id; + Stub_Type_Access : Entity_Id; + RPC_Receiver_Decl : Node_Id; + Existing : Boolean; begin if not Expander_Active then @@ -738,7 +1048,7 @@ package body Exp_Dist is Insertion_Node : Node_Id; Decls : List_Id) is - -- Set sloc of generated declaration copy of insertion node sloc, so + -- Set Sloc of generated declaration copy of insertion node Sloc, so -- the declarations are recognized as belonging to the current package. Loc : constant Source_Ptr := Sloc (Insertion_Node); @@ -752,7 +1062,7 @@ package body Exp_Dist is Current_Insertion_Node : Node_Id := Insertion_Node; - RPC_Receiver : Entity_Id; + RPC_Receiver : Entity_Id; RPC_Receiver_Statements : List_Id; RPC_Receiver_Case_Alternatives : constant List_Id := New_List; RPC_Receiver_Stream : Entity_Id; @@ -798,7 +1108,6 @@ package body Exp_Dist is -- receiver for this type. if Present (Primitive_Operations (Designated_Type)) then - Overload_Counter_Table.Reset; Current_Primitive_Elmt := @@ -991,12 +1300,13 @@ package body Exp_Dist is -- Start of processing for Add_RAS_Dereference_TSS begin - -- 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. + + -- [function|procedure] ras_typeRD (RAS_Value, ) + -- [return <>] + + -- This is called whenever a value of a RAS type is dereferenced -- First construct a list of parameter specifications: @@ -1254,12 +1564,11 @@ package body Exp_Dist is Formal := First (Parameter_Specifications (Subp_Decl_Spec)); pragma Assert (Present (Formal)); - Next (Formal); - - while Present (Formal) loop - Append_To (Actuals, New_Occurrence_Of ( - Defining_Identifier (Formal), Loc)); + loop Next (Formal); + exit when No (Formal); + Append_To (Actuals, + New_Occurrence_Of (Defining_Identifier (Formal), Loc)); end loop; -- O : aliased subpP; @@ -1426,9 +1735,7 @@ package body Exp_Dist is Append_To (RPC_Receiver_Cases, Make_Case_Statement_Alternative (Loc, Discrete_Choices => - New_List ( - Make_Integer_Literal (Loc, Subprogram_Number)), - + New_List (Make_Integer_Literal (Loc, Subprogram_Number)), Statements => New_List ( Make_Procedure_Call_Statement (Loc, @@ -1692,7 +1999,7 @@ package body Exp_Dist is Analyze (Last (Decls)); Append_To (Decls, Pkg_RPC_Receiver_Body); - Analyze (Pkg_RPC_Receiver_Body); + Analyze (Last (Decls)); -- Construction of the dummy package used to register the package -- receiving stubs on the nameserver. @@ -1787,15 +2094,8 @@ package body Exp_Dist is Stub_Elements : constant Stub_Structure := Stubs_Table.Get (Designated_Type); - - Stub_Type_Declaration : Node_Id; - Stub_Type_Access_Declaration : Node_Id; - - Object_RPC_Receiver : Entity_Id; - RPC_Receiver_Stream : Entity_Id; - RPC_Receiver_Result : Entity_Id; - - Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type); + Stub_Type_Decl : Node_Id; + Stub_Type_Access_Decl : Node_Id; begin if Stub_Elements /= Empty_Stub_Structure then @@ -1806,71 +2106,31 @@ package body Exp_Dist is return; end if; - Existing := False; - Stub_Type := - Make_Defining_Identifier (Loc, New_Internal_Name ('S')); - Stub_Type_Access := + Existing := False; + Stub_Type := 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); - - -- 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 ( - - Make_Component_Declaration (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, Name_Origin), - Component_Definition => - Make_Component_Definition (Loc, - Aliased_Present => False, - Subtype_Indication => - New_Occurrence_Of (RTE (RE_Partition_ID), Loc))), - - Make_Component_Declaration (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, Name_Receiver), - Component_Definition => - Make_Component_Definition (Loc, - Aliased_Present => False, - Subtype_Indication => - New_Occurrence_Of (RTE (RE_Unsigned_64), Loc))), + Stub_Type_Access := + Make_Defining_Identifier (Loc, + New_External_Name ( + Related_Id => Chars (Stub_Type), + Suffix => 'A')); - 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))), + Specific_Build_Stub_Type ( + RACW_Type, Stub_Type, + Stub_Type_Decl, RPC_Receiver_Decl); - 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))))))); + Stub_Type_Access_Decl := + Make_Full_Type_Declaration (Loc, + Defining_Identifier => Stub_Type_Access, + Type_Definition => + Make_Access_To_Object_Definition (Loc, + All_Present => True, + Subtype_Indication => New_Occurrence_Of (Stub_Type, Loc))); - Append_To (Decls, Stub_Type_Declaration); - Analyze (Stub_Type_Declaration); + Append_To (Decls, Stub_Type_Decl); + Analyze (Last (Decls)); + Append_To (Decls, Stub_Type_Access_Decl); + Analyze (Last (Decls)); -- This is in no way a type derivation, but we fake it to make -- sure that the dispatching table gets built with the corresponding @@ -1879,27 +2139,12 @@ package body Exp_Dist is Derive_Subprograms (Parent_Type => Designated_Type, Derived_Type => Stub_Type); - 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))); - - Append_To (Decls, Stub_Type_Access_Declaration); - Analyze (Stub_Type_Access_Declaration); - - 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))); + if Present (RPC_Receiver_Decl) then + Append_To (Decls, RPC_Receiver_Decl); + else + RPC_Receiver_Decl := Last (Decls); end if; - RPC_Receiver_Decl := Last (Decls); Stubs_Table.Set (Designated_Type, (Stub_Type => Stub_Type, Stub_Type_Access => Stub_Type_Access, @@ -1942,2744 +2187,7370 @@ package body Exp_Dist is Subprogram_Identifiers'(Str_Identifier => Id, Int_Identifier => Spn)); end Assign_Subprogram_Identifier; - --------------------------------- - -- Build_General_Calling_Stubs -- - --------------------------------- + ------------------------------ + -- Build_Get_Unique_RP_Call -- + ------------------------------ - 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) + function Build_Get_Unique_RP_Call + (Loc : Source_Ptr; + Pointer : Entity_Id; + Stub_Type : Entity_Id) return List_Id is - Loc : constant Source_Ptr := Sloc (Nod); - - Stream_Parameter : Node_Id; - -- Name of the stream used to transmit parameters to the remote package - - Result_Parameter : Node_Id; - -- Name of the result parameter (in non-APC cases) which get the - -- result of the remote subprogram. + 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)))), - Exception_Return_Parameter : Node_Id; - -- Name of the parameter which will hold the exception sent by the - -- remote subprogram. + 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))); - Current_Parameter : Node_Id; - -- Current parameter being handled + -- 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. - Ordered_Parameters_List : constant List_Id := - Build_Ordered_Parameters_List (Spec); + end Build_Get_Unique_RP_Call; - Asynchronous_Statements : List_Id := No_List; - Non_Asynchronous_Statements : List_Id := No_List; - -- Statements specifics to the Asynchronous/Non-Asynchronous cases + ----------------------------------- + -- Build_Ordered_Parameters_List -- + ----------------------------------- - 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_Ordered_Parameters_List (Spec : Node_Id) return List_Id is + Constrained_List : List_Id; + Unconstrained_List : List_Id; + Current_Parameter : Node_Id; - pragma Warnings (Off); - pragma Unreferenced (RACW_Type); - -- Used only for the PolyORB case - pragma Warnings (On); + First_Parameter : Node_Id; + For_RAS : Boolean := False; begin - -- The general form of a calling stub for a given subprogram is: - - -- 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; - - -- 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. + if not Present (Parameter_Specifications (Spec)) then + return New_List; + end if; - Stream_Parameter := - Make_Defining_Identifier (Loc, New_Internal_Name ('S')); + Constrained_List := New_List; + Unconstrained_List := New_List; + First_Parameter := First (Parameter_Specifications (Spec)); - Append_To (Decls, - Make_Object_Declaration (Loc, - Defining_Identifier => Stream_Parameter, - Aliased_Present => True, - Object_Definition => - Make_Subtype_Indication (Loc, - Subtype_Mark => - New_Occurrence_Of (RTE (RE_Params_Stream_Type), Loc), - Constraint => - Make_Index_Or_Discriminant_Constraint (Loc, - Constraints => - New_List (Make_Integer_Literal (Loc, 0)))))); + if Nkind (Parameter_Type (First_Parameter)) = N_Access_Definition + and then Chars (Defining_Identifier (First_Parameter)) = Name_uS + then + For_RAS := True; + end if; - if not Is_Known_Asynchronous then - Result_Parameter := - Make_Defining_Identifier (Loc, New_Internal_Name ('R')); + -- Loop through the parameters and add them to the right list - 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)))))); + 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; - Exception_Return_Parameter := - Make_Defining_Identifier (Loc, New_Internal_Name ('E')); + Next (Current_Parameter); + end loop; - Append_To (Decls, - Make_Object_Declaration (Loc, - Defining_Identifier => Exception_Return_Parameter, - Object_Definition => - New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc))); + -- Unconstrained parameters are returned first - else - Result_Parameter := Empty; - Exception_Return_Parameter := Empty; - end if; + Append_List_To (Unconstrained_List, Constrained_List); - -- Put first the RPC receiver corresponding to the remote package + return Unconstrained_List; + end Build_Ordered_Parameters_List; - 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))); + ---------------------------------- + -- Build_Passive_Partition_Stub -- + ---------------------------------- + + 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); - -- Then put the Subprogram_Id of the subprogram we want to call in - -- the stream. + begin + -- Verify that the implementation supports distribution, by accessing + -- a type defined in the proper version of system.rpc - Append_To (Statements, - Make_Attribute_Reference (Loc, - Prefix => - New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc), - Attribute_Name => - Name_Write, - Expressions => New_List ( + declare + Dist_OK : Entity_Id; + pragma Warnings (Off, Dist_OK); + begin + Dist_OK := RTE (RE_Params_Stream_Type); + end; + + -- Use body if present, spec otherwise + + if Nkind (U) = N_Package_Declaration then + Pkg_Spec := Specification (U); + L := Visible_Declarations (Pkg_Spec); + else + Pkg_Spec := Parent (Corresponding_Spec (U)); + L := Declarations (U); + end if; + + Get_Library_Unit_Name_String (Pkg_Spec); + Pkg_Name := String_From_Name_Buffer; + Reg := + Make_Procedure_Call_Statement (Loc, + Name => + New_Occurrence_Of (RTE (RE_Register_Passive_Package), Loc), + Parameter_Associations => New_List ( + Make_String_Literal (Loc, Pkg_Name), Make_Attribute_Reference (Loc, Prefix => - New_Occurrence_Of (Stream_Parameter, Loc), - Attribute_Name => Name_Access), - Subprogram_Id))); + New_Occurrence_Of (Defining_Entity (Pkg_Spec), Loc), + Attribute_Name => + Name_Version))); + Append_To (L, Reg); + Analyze (Reg); + end Build_Passive_Partition_Stub; - 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; + ---------------------------------------- + -- Build_Remote_Subprogram_Proxy_Type -- + ---------------------------------------- - begin - if Is_RACW_Controlling_Formal (Current_Parameter, Stub_Type) then + 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, - -- In the case of a controlling formal argument, we marshall - -- its addr field rather than the local stub. + 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), - 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))); + 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)), - else - Value := New_Occurrence_Of - (Defining_Identifier (Current_Parameter), Loc); + Make_Component_Declaration (Loc, + Make_Defining_Identifier (Loc, + Name_Subp_Id), + Make_Component_Definition (Loc, + Subtype_Indication => + New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc)))))); + end Build_Remote_Subprogram_Proxy_Type; - -- Access type parameters are transmitted as in out - -- parameters. However, a dereference is needed so that - -- we marshall the designated object. + ----------------------------- + -- Build_RPC_Receiver_Body -- + ----------------------------- - if Nkind (Typ) = N_Access_Definition then - Value := Make_Explicit_Dereference (Loc, Value); - Etyp := Etype (Subtype_Mark (Typ)); - else - Etyp := Etype (Typ); - end if; + 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); - Constrained := - Is_Constrained (Etyp) or else Is_Elementary_Type (Etyp); + RPC_Receiver_Spec : Node_Id; + RPC_Receiver_Decls : List_Id; - -- Any parameter but unconstrained out parameters are - -- transmitted to the peer. + begin + Stream := Make_Defining_Identifier (Loc, Name_S); + Result := Make_Defining_Identifier (Loc, Name_R); - 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; + RPC_Receiver_Spec := + GARLIC_Support.Build_RPC_Receiver_Specification + (RPC_Receiver => RPC_Receiver, + Stream_Parameter => Stream, + Result_Parameter => Result); - -- If the current parameter has a dynamic constrained status, - -- then this status is transmitted as well. - -- This should be done for accessibility as well ??? + Subp_Id := Make_Defining_Identifier (Loc, New_Internal_Name ('P')); - 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. + -- 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. - Extra_Parameter := Make_Defining_Identifier - (Loc, New_Internal_Name ('P')); + 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))))); - 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))); + Stmts := New_List; - 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; + 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; - Next (Current_Parameter); - end; - end loop; + ------------------------------------ + -- Build_Subprogram_Calling_Stubs -- + ------------------------------------ - -- Append the formal statements list to the statements + 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); - Append_List_To (Statements, Extra_Formal_Statements); + Decls : constant List_Id := New_List; + Statements : constant List_Id := New_List; - if not Is_Known_Non_Asynchronous then + Subp_Spec : Node_Id; + -- The specification of the body - -- Build the call to System.RPC.Do_APC + Controlling_Parameter : Entity_Id := Empty; - 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; + Asynchronous_Expr : Node_Id := Empty; - if not Is_Known_Asynchronous then + RCI_Locator : Entity_Id; - -- Build the call to System.RPC.Do_RPC + Spec_To_Use : Node_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), - - Make_Attribute_Reference (Loc, - Prefix => - New_Occurrence_Of (Stream_Parameter, Loc), - Attribute_Name => - Name_Access), - - Make_Attribute_Reference (Loc, - Prefix => - New_Occurrence_Of (Result_Parameter, Loc), - Attribute_Name => - Name_Access)))); - - -- 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 (Non_Asynchronous_Statements, - Make_Attribute_Reference (Loc, - Prefix => - New_Occurrence_Of (RTE (RE_Exception_Occurrence), 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)). - Attribute_Name => - Name_Read, + ---------------------------- + -- Insert_Partition_Check -- + ---------------------------- - 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)))); + procedure Insert_Partition_Check (Parameter : Node_Id) is + Parameter_Entity : constant Entity_Id := + Defining_Identifier (Parameter); + begin + -- The expression that will be built is of the form: - 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 not Same_Partition (Parameter, Controlling_Parameter) then + -- raise Constraint_Error; + -- end if; - if Is_Function then + -- 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). - -- If this is a function call, then read the value and return - -- it. The return value is written/read using 'Output/'Input. + Append_To (Decls, + Make_Raise_Constraint_Error (Loc, + Condition => + Make_Op_Not (Loc, + Right_Opnd => + Make_Function_Call (Loc, + Name => + New_Occurrence_Of (RTE (RE_Same_Partition), Loc), + Parameter_Associations => + New_List ( + Unchecked_Convert_To (RTE (RE_RACW_Stub_Type_Access), + New_Occurrence_Of (Parameter_Entity, Loc)), + Unchecked_Convert_To (RTE (RE_RACW_Stub_Type_Access), + New_Occurrence_Of (Controlling_Parameter, Loc))))), + Reason => CE_Partition_Check_Failed)); + end Insert_Partition_Check; - 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), + -- Start of processing for Build_Subprogram_Calling_Stubs - Attribute_Name => Name_Input, + begin + Subp_Spec := Copy_Specification (Loc, + Spec => Specification (Vis_Decl), + New_Name => New_Name); - Expressions => New_List ( - Make_Attribute_Reference (Loc, - Prefix => - New_Occurrence_Of (Result_Parameter, Loc), - Attribute_Name => Name_Access)))))); + 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; - 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. + -- Find a controlling argument if we have a stub type. Also check + -- if this subprogram can be made asynchronous. - Current_Parameter := First (Ordered_Parameters_List); + 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 - declare - Typ : constant Node_Id := - Parameter_Type (Current_Parameter); - Etyp : Entity_Id; - Value : Node_Id; - - begin - Value := - New_Occurrence_Of - (Defining_Identifier (Current_Parameter), Loc); - - if Nkind (Typ) = N_Access_Definition then - Value := Make_Explicit_Dereference (Loc, Value); - Etyp := Etype (Subtype_Mark (Typ)); + if + Is_RACW_Controlling_Formal (Current_Parameter, Stub_Type) + then + if Controlling_Parameter = Empty then + Controlling_Parameter := + Defining_Identifier (Current_Parameter); else - Etyp := Etype (Typ); - end if; - - if (Out_Present (Current_Parameter) - or else Nkind (Typ) = N_Access_Definition) - and then Etyp /= Stub_Type - then - Append_To (Non_Asynchronous_Statements, - Make_Attribute_Reference (Loc, - Prefix => - New_Occurrence_Of (Etyp, Loc), - - Attribute_Name => Name_Read, - - Expressions => New_List ( - Make_Attribute_Reference (Loc, - Prefix => - New_Occurrence_Of (Result_Parameter, Loc), - Attribute_Name => - Name_Access), - Value))); + Insert_Partition_Check (Current_Parameter); end if; - end; + end if; Next (Current_Parameter); end loop; - end if; + end; end if; - if Is_Known_Asynchronous then - Append_List_To (Statements, Asynchronous_Statements); + pragma Assert (No (Stub_Type) or else Present (Controlling_Parameter)); - elsif Is_Known_Non_Asynchronous then - Append_List_To (Statements, Non_Asynchronous_Statements); + 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; - 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)))); + Specific_Build_General_Calling_Stubs + (Decls => Decls, + Statements => Statements, + Target => Specific_Build_Stub_Target (Loc, + Decls, RCI_Locator, Controlling_Parameter), + Subprogram_Id => Subp_Id, + Asynchronous => Asynchronous_Expr, + Is_Known_Asynchronous => Asynchronous + and then not Dynamically_Asynchronous, + Is_Known_Non_Asynchronous + => not Asynchronous + and then not Dynamically_Asynchronous, + Is_Function => Nkind (Spec_To_Use) = + N_Function_Specification, + Spec => Spec_To_Use, + Stub_Type => Stub_Type, + RACW_Type => RACW_Type, + Nod => Vis_Decl); - 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)))); + RCI_Calling_Stubs_Table.Set + (Defining_Unit_Name (Specification (Vis_Decl)), + Defining_Unit_Name (Spec_To_Use)); - 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; + 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; - ------------------------------ - -- Build_Get_Unique_RP_Call -- - ------------------------------ + ------------------------- + -- Build_Subprogram_Id -- + ------------------------- - function Build_Get_Unique_RP_Call - (Loc : Source_Ptr; - Pointer : Entity_Id; - Stub_Type : Entity_Id) return List_Id + function Build_Subprogram_Id + (Loc : Source_Ptr; + E : Entity_Id) return Node_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)))), + return Make_Integer_Literal (Loc, Get_Subprogram_Id (E)); + end Build_Subprogram_Id; - 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))); + -------------------------------------- + -- Build_Subprogram_Receiving_Stubs -- + -------------------------------------- - -- 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. + 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); - end Build_Get_Unique_RP_Call; + Stream_Parameter : Node_Id; + Result_Parameter : Node_Id; + -- See explanations of these in Build_Subprogram_Calling_Stubs - ----------------------------------- - -- Build_Ordered_Parameters_List -- - ----------------------------------- + Decls : constant List_Id := New_List; + -- All the parameters will get declared before calling the real + -- subprograms. Also the out parameters will be declared. - function Build_Ordered_Parameters_List (Spec : Node_Id) return List_Id is - Constrained_List : List_Id; - Unconstrained_List : List_Id; - Current_Parameter : Node_Id; + Statements : constant List_Id := New_List; - First_Parameter : Node_Id; - For_RAS : Boolean := False; + Extra_Formal_Statements : constant List_Id := New_List; + -- Statements concerning extra formal parameters - begin - if not Present (Parameter_Specifications (Spec)) then - return New_List; - end if; + After_Statements : constant List_Id := New_List; + -- Statements to be executed after the subprogram call - Constrained_List := New_List; - Unconstrained_List := New_List; - First_Parameter := First (Parameter_Specifications (Spec)); + Inner_Decls : List_Id := No_List; + -- In case of a function, the inner declarations are needed since + -- the result may be unconstrained. - if Nkind (Parameter_Type (First_Parameter)) = N_Access_Definition - and then Chars (Defining_Identifier (First_Parameter)) = Name_uS - then - For_RAS := True; - end if; + Excep_Handlers : List_Id := No_List; + Excep_Choice : Entity_Id; + Excep_Code : List_Id; - -- Loop through the parameters and add them to the right list + Parameter_List : constant List_Id := New_List; + -- List of parameters to be passed to the subprogram - Current_Parameter := First_Parameter; - while Present (Current_Parameter) loop - if (Nkind (Parameter_Type (Current_Parameter)) = N_Access_Definition - or else - Is_Constrained (Etype (Parameter_Type (Current_Parameter))) - or else - Is_Elementary_Type (Etype (Parameter_Type (Current_Parameter)))) - and then not (For_RAS and then Current_Parameter = First_Parameter) - then - Append_To (Constrained_List, New_Copy (Current_Parameter)); - else - Append_To (Unconstrained_List, New_Copy (Current_Parameter)); - end if; - - Next (Current_Parameter); - end loop; + Current_Parameter : Node_Id; - -- Unconstrained parameters are returned first + Ordered_Parameters_List : constant List_Id := + Build_Ordered_Parameters_List + (Specification (Vis_Decl)); - Append_List_To (Unconstrained_List, Constrained_List); + Subp_Spec : Node_Id; + -- Subprogram specification - return Unconstrained_List; - end Build_Ordered_Parameters_List; + Called_Subprogram : Node_Id; + -- The subprogram to call - ---------------------------------- - -- Build_Passive_Partition_Stub -- - ---------------------------------- + Null_Raise_Statement : Node_Id; - 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); + Dynamic_Async : Entity_Id; begin - -- Verify that the implementation supports distribution, by accessing - -- a type defined in the proper version of system.rpc + if Present (RACW_Type) then + Called_Subprogram := + New_Occurrence_Of (Parent_Primitive, Loc); + else + Called_Subprogram := + New_Occurrence_Of ( + Defining_Unit_Name (Specification (Vis_Decl)), Loc); + end if; - declare - Dist_OK : Entity_Id; - pragma Warnings (Off, Dist_OK); - begin - Dist_OK := RTE (RE_Params_Stream_Type); - end; + Stream_Parameter := + Make_Defining_Identifier (Loc, New_Internal_Name ('S')); - -- Use body if present, spec otherwise + if Dynamically_Asynchronous then + Dynamic_Async := + Make_Defining_Identifier (Loc, New_Internal_Name ('S')); + else + Dynamic_Async := Empty; + end if; + + if not Asynchronous or else Dynamically_Asynchronous then + Result_Parameter := + Make_Defining_Identifier (Loc, New_Internal_Name ('S')); + + -- The first statement after the subprogram call is a statement to + -- writes a Null_Occurrence into the result stream. + + Null_Raise_Statement := + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc), + Attribute_Name => Name_Write, + Expressions => New_List ( + New_Occurrence_Of (Result_Parameter, Loc), + New_Occurrence_Of (RTE (RE_Null_Occurrence), Loc))); + + if Dynamically_Asynchronous then + Null_Raise_Statement := + Make_Implicit_If_Statement (Vis_Decl, + Condition => + Make_Op_Not (Loc, New_Occurrence_Of (Dynamic_Async, Loc)), + Then_Statements => New_List (Null_Raise_Statement)); + end if; + + Append_To (After_Statements, Null_Raise_Statement); - 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); + Result_Parameter := Empty; end if; - Get_Library_Unit_Name_String (Pkg_Spec); - Pkg_Name := String_From_Name_Buffer; - Reg := - Make_Procedure_Call_Statement (Loc, - Name => - New_Occurrence_Of (RTE (RE_Register_Passive_Package), Loc), - Parameter_Associations => New_List ( - Make_String_Literal (Loc, Pkg_Name), - Make_Attribute_Reference (Loc, - Prefix => - New_Occurrence_Of (Defining_Entity (Pkg_Spec), Loc), - Attribute_Name => - Name_Version))); - Append_To (L, Reg); - Analyze (Reg); - end Build_Passive_Partition_Stub; + -- 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. - ---------------------------------------- - -- Build_Remote_Subprogram_Proxy_Type -- - ---------------------------------------- + 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; - 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, + begin + Object := Make_Defining_Identifier (Loc, New_Internal_Name ('P')); + Set_Ekind (Object, E_Variable); - 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), + RACW_Controlling := + Is_RACW_Controlling_Formal (Current_Parameter, Stub_Type); - 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)), + if RACW_Controlling then - 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; + -- We have a controlling formal parameter. Read its address + -- rather than a real object. The address is in Unsigned_64 + -- form. - ----------------------------- - -- Build_RPC_Receiver_Body -- - ----------------------------- + Etyp := RTE (RE_Unsigned_64); + else + Etyp := Etype (Parameter_Type (Current_Parameter)); + end if; - 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); + Constrained := + Is_Constrained (Etyp) or else Is_Elementary_Type (Etyp); - 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); + 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. - RPC_Receiver_Spec := - Build_RPC_Receiver_Specification - (RPC_Receiver => RPC_Receiver, - Stream_Parameter => Stream, - Result_Parameter => Result); + 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)))); - Subp_Id := - Make_Defining_Identifier (Loc, New_Internal_Name ('P')); + 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; - -- 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. + -- 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. - 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))))); + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Object, + Constant_Present => + not Constrained and then not Out_Present (Current_Parameter), + Object_Definition => + New_Occurrence_Of (Etyp, Loc), + Expression => Expr)); + + -- An out parameter may be written back using a 'Write + -- attribute instead of a 'Output because it has been + -- constrained by the parameter given to the caller. Note that + -- out controlling arguments in the case of a RACW are not put + -- back in the stream because the pointer on them has not + -- changed. + + if Out_Present (Current_Parameter) + and then + Etype (Parameter_Type (Current_Parameter)) /= Stub_Type + then + Append_To (After_Statements, + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Etyp, Loc), + Attribute_Name => Name_Write, + Expressions => New_List ( + New_Occurrence_Of (Result_Parameter, Loc), + New_Occurrence_Of (Object, Loc)))); + end if; + + if + Is_RACW_Controlling_Formal (Current_Parameter, Stub_Type) + then + if Nkind (Parameter_Type (Current_Parameter)) /= + N_Access_Definition + then + Append_To (Parameter_List, + Make_Parameter_Association (Loc, + Selector_Name => + New_Occurrence_Of ( + Defining_Identifier (Current_Parameter), Loc), + Explicit_Actual_Parameter => + Make_Explicit_Dereference (Loc, + Unchecked_Convert_To (RACW_Type, + OK_Convert_To (RTE (RE_Address), + New_Occurrence_Of (Object, Loc)))))); + + else + Append_To (Parameter_List, + Make_Parameter_Association (Loc, + Selector_Name => + New_Occurrence_Of ( + Defining_Identifier (Current_Parameter), Loc), + Explicit_Actual_Parameter => + Unchecked_Convert_To (RACW_Type, + OK_Convert_To (RTE (RE_Address), + New_Occurrence_Of (Object, Loc))))); + end if; + + else + Append_To (Parameter_List, + Make_Parameter_Association (Loc, + Selector_Name => + New_Occurrence_Of ( + Defining_Identifier (Current_Parameter), Loc), + Explicit_Actual_Parameter => + New_Occurrence_Of (Object, Loc))); + end if; + + -- If the current parameter needs an extra formal, then read it + -- from the stream and set the corresponding semantic field in + -- the variable. If the kind of the parameter identifier is + -- E_Void, then this is a compiler generated parameter that + -- doesn't need an extra constrained status. + + -- The case of Extra_Accessibility should also be handled ??? + + if Nkind (Parameter_Type (Current_Parameter)) /= + N_Access_Definition + and then + Ekind (Defining_Identifier (Current_Parameter)) /= E_Void + and then + Present (Extra_Constrained + (Defining_Identifier (Current_Parameter))) + then + declare + Extra_Parameter : constant Entity_Id := + Extra_Constrained + (Defining_Identifier + (Current_Parameter)); + + Formal_Entity : constant Entity_Id := + Make_Defining_Identifier + (Loc, Chars (Extra_Parameter)); + + Formal_Type : constant Entity_Id := + Etype (Extra_Parameter); + + begin + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Formal_Entity, + Object_Definition => + New_Occurrence_Of (Formal_Type, Loc))); + + Append_To (Extra_Formal_Statements, + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Formal_Type, Loc), + Attribute_Name => Name_Read, + Expressions => New_List ( + New_Occurrence_Of (Stream_Parameter, Loc), + New_Occurrence_Of (Formal_Entity, Loc)))); + Set_Extra_Constrained (Object, Formal_Entity); + end; + end if; + end; + + Next (Current_Parameter); + end loop; + + -- Append the formal statements list at the end of regular statements + + Append_List_To (Statements, Extra_Formal_Statements); + + if Nkind (Specification (Vis_Decl)) = N_Function_Specification then + + -- The remote subprogram is a function. We build an inner block to + -- be able to hold a potentially unconstrained result in a variable. + + declare + Etyp : constant Entity_Id := + Etype (Subtype_Mark (Specification (Vis_Decl))); + Result : constant Node_Id := + Make_Defining_Identifier (Loc, New_Internal_Name ('R')); + + begin + Inner_Decls := New_List ( + Make_Object_Declaration (Loc, + Defining_Identifier => Result, + Constant_Present => True, + Object_Definition => New_Occurrence_Of (Etyp, Loc), + Expression => + Make_Function_Call (Loc, + Name => Called_Subprogram, + Parameter_Associations => Parameter_List))); + + Append_To (After_Statements, + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Etyp, Loc), + Attribute_Name => Name_Output, + Expressions => New_List ( + New_Occurrence_Of (Result_Parameter, Loc), + New_Occurrence_Of (Result, Loc)))); + end; + + Append_To (Statements, + Make_Block_Statement (Loc, + Declarations => Inner_Decls, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => After_Statements))); + + else + -- The remote subprogram is a procedure. We do not need any inner + -- block in this case. + + if Dynamically_Asynchronous then + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Dynamic_Async, + Object_Definition => + New_Occurrence_Of (Standard_Boolean, Loc))); + + Append_To (Statements, + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Standard_Boolean, Loc), + Attribute_Name => Name_Read, + Expressions => New_List ( + New_Occurrence_Of (Stream_Parameter, Loc), + New_Occurrence_Of (Dynamic_Async, Loc)))); + end if; + + Append_To (Statements, + Make_Procedure_Call_Statement (Loc, + Name => Called_Subprogram, + Parameter_Associations => Parameter_List)); + + Append_List_To (Statements, After_Statements); + end if; + + if Asynchronous and then not Dynamically_Asynchronous then + + -- An asynchronous procedure does not want a Result parameter. Also + -- put an exception handler with an others clause that does nothing. + + Subp_Spec := + Make_Procedure_Specification (Loc, + Defining_Unit_Name => + Make_Defining_Identifier (Loc, New_Internal_Name ('F')), + Parameter_Specifications => New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => Stream_Parameter, + Parameter_Type => + Make_Access_Definition (Loc, + Subtype_Mark => + New_Occurrence_Of (RTE (RE_Params_Stream_Type), Loc))))); + + Excep_Handlers := New_List ( + Make_Exception_Handler (Loc, + Exception_Choices => + New_List (Make_Others_Choice (Loc)), + Statements => New_List ( + Make_Null_Statement (Loc)))); + + else + -- In the other cases, if an exception is raised, then the + -- exception occurrence is copied into the output stream and + -- no other output parameter is written. + + Excep_Choice := + Make_Defining_Identifier (Loc, New_Internal_Name ('E')); + + Excep_Code := New_List ( + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc), + Attribute_Name => Name_Write, + Expressions => New_List ( + New_Occurrence_Of (Result_Parameter, Loc), + New_Occurrence_Of (Excep_Choice, Loc)))); + + if Dynamically_Asynchronous then + Excep_Code := New_List ( + Make_Implicit_If_Statement (Vis_Decl, + Condition => Make_Op_Not (Loc, + New_Occurrence_Of (Dynamic_Async, Loc)), + Then_Statements => Excep_Code)); + end if; + + Excep_Handlers := New_List ( + Make_Exception_Handler (Loc, + Choice_Parameter => Excep_Choice, + Exception_Choices => New_List (Make_Others_Choice (Loc)), + Statements => Excep_Code)); + + Subp_Spec := + Make_Procedure_Specification (Loc, + Defining_Unit_Name => + Make_Defining_Identifier (Loc, New_Internal_Name ('F')), + + Parameter_Specifications => New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => Stream_Parameter, + Parameter_Type => + Make_Access_Definition (Loc, + Subtype_Mark => + New_Occurrence_Of (RTE (RE_Params_Stream_Type), Loc))), + + Make_Parameter_Specification (Loc, + Defining_Identifier => Result_Parameter, + Parameter_Type => + Make_Access_Definition (Loc, + Subtype_Mark => + New_Occurrence_Of (RTE (RE_Params_Stream_Type), Loc))))); + end if; + + return + Make_Subprogram_Body (Loc, + Specification => Subp_Spec, + Declarations => Decls, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Statements, + Exception_Handlers => Excep_Handlers)); + end Build_Subprogram_Receiving_Stubs; + + ------------------------ + -- Copy_Specification -- + ------------------------ + + function Copy_Specification + (Loc : Source_Ptr; + Spec : Node_Id; + Object_Type : Entity_Id := Empty; + Stub_Type : Entity_Id := Empty; + New_Name : Name_Id := No_Name) return Node_Id + is + Parameters : List_Id := No_List; + + Current_Parameter : Node_Id; + Current_Identifier : Entity_Id; + Current_Type : Node_Id; + Current_Etype : Entity_Id; + + Name_For_New_Spec : Name_Id; + + New_Identifier : Entity_Id; + + -- 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 Present (Parameter_Specifications (Spec)) then + Parameters := New_List; + Current_Parameter := First (Parameter_Specifications (Spec)); + while Present (Current_Parameter) loop + Current_Identifier := Defining_Identifier (Current_Parameter); + Current_Type := Parameter_Type (Current_Parameter); + + if Nkind (Current_Type) = N_Access_Definition then + Current_Etype := Entity (Subtype_Mark (Current_Type)); + + if Present (Object_Type) then + pragma Assert ( + Root_Type (Current_Etype) = Root_Type (Object_Type)); + Current_Type := + Make_Access_Definition (Loc, + Subtype_Mark => New_Occurrence_Of (Stub_Type, Loc)); + else + Current_Type := + Make_Access_Definition (Loc, + Subtype_Mark => + New_Occurrence_Of (Current_Etype, Loc)); + end if; + + else + Current_Etype := Entity (Current_Type); + + if Present (Object_Type) + and then Current_Etype = Object_Type + then + Current_Type := New_Occurrence_Of (Stub_Type, Loc); + else + Current_Type := New_Occurrence_Of (Current_Etype, Loc); + end if; + end if; + + New_Identifier := Make_Defining_Identifier (Loc, + Chars (Current_Identifier)); + + Append_To (Parameters, + Make_Parameter_Specification (Loc, + Defining_Identifier => New_Identifier, + Parameter_Type => Current_Type, + In_Present => In_Present (Current_Parameter), + Out_Present => Out_Present (Current_Parameter), + Expression => + New_Copy_Tree (Expression (Current_Parameter)))); + + Next (Current_Parameter); + end loop; + end if; + + case Nkind (Spec) is + + when N_Function_Specification | N_Access_Function_Definition => + return + Make_Function_Specification (Loc, + Defining_Unit_Name => + Make_Defining_Identifier (Loc, + Chars => Name_For_New_Spec), + Parameter_Specifications => Parameters, + Subtype_Mark => + New_Occurrence_Of (Entity (Subtype_Mark (Spec)), Loc)); + + when N_Procedure_Specification | N_Access_Procedure_Definition => + return + Make_Procedure_Specification (Loc, + Defining_Unit_Name => + Make_Defining_Identifier (Loc, + Chars => Name_For_New_Spec), + Parameter_Specifications => Parameters); + + when others => + raise Program_Error; + end case; + end Copy_Specification; + + --------------------------- + -- Could_Be_Asynchronous -- + --------------------------- + + function Could_Be_Asynchronous (Spec : Node_Id) return Boolean is + Current_Parameter : Node_Id; + + begin + if Present (Parameter_Specifications (Spec)) then + Current_Parameter := First (Parameter_Specifications (Spec)); + while Present (Current_Parameter) loop + if Out_Present (Current_Parameter) then + return False; + end if; + + Next (Current_Parameter); + end loop; + end if; + + return True; + end Could_Be_Asynchronous; + + --------------------------- + -- Declare_Create_NVList -- + --------------------------- + + procedure Declare_Create_NVList + (Loc : Source_Ptr; + NVList : Entity_Id; + Decls : List_Id; + Stmts : List_Id) + is + begin + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => NVList, + Aliased_Present => False, + Object_Definition => + New_Occurrence_Of (RTE (RE_NVList_Ref), Loc))); + + Append_To (Stmts, + Make_Procedure_Call_Statement (Loc, + Name => + New_Occurrence_Of (RTE (RE_NVList_Create), Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of (NVList, Loc)))); + end Declare_Create_NVList; + + --------------------------------------------- + -- Expand_All_Calls_Remote_Subprogram_Call -- + --------------------------------------------- + + procedure Expand_All_Calls_Remote_Subprogram_Call (N : Node_Id) is + Called_Subprogram : constant Entity_Id := Entity (Name (N)); + RCI_Package : constant Entity_Id := Scope (Called_Subprogram); + Loc : constant Source_Ptr := Sloc (N); + RCI_Locator : Node_Id; + RCI_Cache : Entity_Id; + Calling_Stubs : Node_Id; + E_Calling_Stubs : Entity_Id; + + begin + E_Calling_Stubs := RCI_Calling_Stubs_Table.Get (Called_Subprogram); + + if E_Calling_Stubs = Empty then + RCI_Cache := RCI_Locator_Table.Get (RCI_Package); + + if RCI_Cache = Empty then + RCI_Locator := + RCI_Package_Locator + (Loc, Specification (Unit_Declaration_Node (RCI_Package))); + Prepend_To (Current_Sem_Unit_Declarations, RCI_Locator); + + -- 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. + + declare + Scop : constant Entity_Id := Cunit_Entity (Current_Sem_Unit); + + begin + if Ekind (Scop) = E_Package_Body then + New_Scope (Spec_Entity (Scop)); + + elsif Ekind (Scop) = E_Subprogram_Body then + New_Scope + (Corresponding_Spec (Unit_Declaration_Node (Scop))); + + else + New_Scope (Scop); + end if; + + Analyze (RCI_Locator); + Pop_Scope; + end; + + RCI_Cache := Defining_Unit_Name (RCI_Locator); + + else + RCI_Locator := Parent (RCI_Cache); + end if; + + Calling_Stubs := Build_Subprogram_Calling_Stubs + (Vis_Decl => Parent (Parent (Called_Subprogram)), + Subp_Id => + Build_Subprogram_Id (Loc, Called_Subprogram), + Asynchronous => Nkind (N) = N_Procedure_Call_Statement + and then + Is_Asynchronous (Called_Subprogram), + Locator => RCI_Cache, + New_Name => New_Internal_Name ('S')); + Insert_After (RCI_Locator, Calling_Stubs); + Analyze (Calling_Stubs); + E_Calling_Stubs := Defining_Unit_Name (Specification (Calling_Stubs)); + end if; + + Rewrite (Name (N), New_Occurrence_Of (E_Calling_Stubs, Loc)); + end Expand_All_Calls_Remote_Subprogram_Call; + + --------------------------------- + -- Expand_Calling_Stubs_Bodies -- + --------------------------------- + + procedure Expand_Calling_Stubs_Bodies (Unit_Node : Node_Id) is + Spec : constant Node_Id := Specification (Unit_Node); + Decls : constant List_Id := Visible_Declarations (Spec); + begin + New_Scope (Scope_Of_Spec (Spec)); + Add_Calling_Stubs_To_Declarations + (Specification (Unit_Node), Decls); + Pop_Scope; + end Expand_Calling_Stubs_Bodies; + + ----------------------------------- + -- Expand_Receiving_Stubs_Bodies -- + ----------------------------------- + + procedure Expand_Receiving_Stubs_Bodies (Unit_Node : Node_Id) is + Spec : Node_Id; + Decls : List_Id; + Temp : List_Id; + + begin + if Nkind (Unit_Node) = N_Package_Declaration then + Spec := Specification (Unit_Node); + Decls := Visible_Declarations (Spec); + New_Scope (Scope_Of_Spec (Spec)); + Add_Receiving_Stubs_To_Declarations (Spec, Decls); + + else + Spec := + Package_Specification_Of_Scope (Corresponding_Spec (Unit_Node)); + Decls := Declarations (Unit_Node); + New_Scope (Scope_Of_Spec (Unit_Node)); + Temp := New_List; + Add_Receiving_Stubs_To_Declarations (Spec, Temp); + Insert_List_Before (First (Decls), Temp); + end if; + + Pop_Scope; + end Expand_Receiving_Stubs_Bodies; + + -------------------- + -- GARLIC_Support -- + -------------------- + + package body GARLIC_Support is + + -- Local subprograms + + 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; + RPC_Receiver : Node_Id; + Declarations : List_Id); + -- Same thing for the Write attribute + + 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); + + begin + Loc := Sloc (RACW_Type); + + if Is_RAS then + + -- 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. + + RPC_Receiver := Make_Selected_Component (Loc, + Prefix => + Unchecked_Convert_To (RTE (RE_RAS_Proxy_Type_Access), Object), + Selector_Name => Make_Identifier (Loc, Name_Receiver)); + + else + RPC_Receiver := Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of ( + Defining_Unit_Name (Specification (RPC_Receiver_Decl)), Loc), + Attribute_Name => Name_Address); + end if; + + Add_RACW_Write_Attribute ( + RACW_Type, + Stub_Type, + Stub_Type_Access, + RPC_Receiver, + Declarations); + + Add_RACW_Read_Attribute ( + RACW_Type, + Stub_Type, + Stub_Type_Access, + Declarations); + end Add_RACW_Features; + + ----------------------------- + -- 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 + + begin + -- Generate object declarations + + Decls := New_List ( + Make_Object_Declaration (Loc, + Defining_Identifier => Source_Partition, + Object_Definition => + New_Occurrence_Of (RTE (RE_Partition_ID), Loc)), + + Make_Object_Declaration (Loc, + Defining_Identifier => Source_Receiver, + Object_Definition => + New_Occurrence_Of (RTE (RE_Unsigned_64), Loc)), + + Make_Object_Declaration (Loc, + Defining_Identifier => Source_Address, + Object_Definition => + New_Occurrence_Of (RTE (RE_Unsigned_64), Loc)), + + Make_Object_Declaration (Loc, + Defining_Identifier => Local_Stub, + Aliased_Present => True, + Object_Definition => New_Occurrence_Of (Stub_Type, Loc)), + + Make_Object_Declaration (Loc, + Defining_Identifier => Stubbed_Result, + Object_Definition => + New_Occurrence_Of (Stub_Type_Access, Loc), + Expression => + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Local_Stub, Loc), + Attribute_Name => + Name_Unchecked_Access))); + + -- Read the source Partition_ID and RPC_Receiver from incoming stream + + Statements := New_List ( + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (RTE (RE_Partition_ID), Loc), + Attribute_Name => Name_Read, + Expressions => New_List ( + Stream_Parameter, + New_Occurrence_Of (Source_Partition, Loc))), + + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (RTE (RE_Unsigned_64), Loc), + Attribute_Name => + Name_Read, + Expressions => New_List ( + Stream_Parameter, + New_Occurrence_Of (Source_Receiver, Loc))), + + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (RTE (RE_Unsigned_64), Loc), + Attribute_Name => + Name_Read, + Expressions => New_List ( + Stream_Parameter, + New_Occurrence_Of (Source_Address, Loc)))); + + -- Build_Get_Unique_RP_Call needs the type of Stubbed_Result + + Set_Etype (Stubbed_Result, Stub_Type_Access); + + -- If the Address is Null_Address, then return a null object + + 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))))); + + -- 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. + + Remote_Statements := New_List ( + + Make_Assignment_Statement (Loc, + Name => Make_Selected_Component (Loc, + Prefix => New_Occurrence_Of (Stubbed_Result, Loc), + Selector_Name => Make_Identifier (Loc, Name_Origin)), + Expression => + New_Occurrence_Of (Source_Partition, Loc)), + + Make_Assignment_Statement (Loc, + Name => Make_Selected_Component (Loc, + Prefix => New_Occurrence_Of (Stubbed_Result, Loc), + Selector_Name => Make_Identifier (Loc, Name_Receiver)), + Expression => + New_Occurrence_Of (Source_Receiver, Loc)), + + Make_Assignment_Statement (Loc, + Name => Make_Selected_Component (Loc, + Prefix => New_Occurrence_Of (Stubbed_Result, Loc), + Selector_Name => Make_Identifier (Loc, Name_Addr)), + Expression => + New_Occurrence_Of (Source_Address, Loc))); + + Append_To (Remote_Statements, + Make_Assignment_Statement (Loc, + Name => Make_Selected_Component (Loc, + Prefix => New_Occurrence_Of (Stubbed_Result, Loc), + Selector_Name => Make_Identifier (Loc, Name_Asynchronous)), + 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)))); + + -- Distinguish between the local and remote cases, and execute the + -- appropriate piece of code. + + Append_To (Statements, + Make_Implicit_If_Statement (RACW_Type, + Condition => + Make_Op_Eq (Loc, + Left_Opnd => + Make_Function_Call (Loc, + Name => New_Occurrence_Of ( + RTE (RE_Get_Local_Partition_Id), Loc)), + Right_Opnd => New_Occurrence_Of (Source_Partition, Loc)), + Then_Statements => Local_Statements, + Else_Statements => Remote_Statements)); + + Build_Stream_Procedure + (Loc, RACW_Type, Body_Node, + Make_Defining_Identifier (Loc, Procedure_Name), + Statements, Outp => True); + Set_Declarations (Body_Node, Decls); + + Proc_Decl := Make_Subprogram_Declaration (Loc, + Copy_Specification (Loc, Specification (Body_Node))); + + Attr_Decl := + Make_Attribute_Definition_Clause (Loc, + Name => New_Occurrence_Of (RACW_Type, Loc), + Chars => Name_Read, + Expression => + New_Occurrence_Of ( + Defining_Unit_Name (Specification (Proc_Decl)), Loc)); + + Insert_After (Declaration_Node (RACW_Type), Proc_Decl); + Insert_After (Proc_Decl, Attr_Decl); + Append_To (Declarations, Body_Node); + end Add_RACW_Read_Attribute; + + ------------------------------ + -- 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; + + Statements : List_Id; + Local_Statements : List_Id; + Remote_Statements : List_Id; + Null_Statements : List_Id; + + Procedure_Name : constant Name_Id := New_Internal_Name ('R'); + + begin + -- Build the code fragment corresponding to the marshalling of a + -- local object. + + Local_Statements := New_List ( + + Pack_Entity_Into_Stream_Access (Loc, + Stream => Stream_Parameter, + Object => RTE (RE_Get_Local_Partition_Id)), + + Pack_Node_Into_Stream_Access (Loc, + Stream => Stream_Parameter, + Object => OK_Convert_To (RTE (RE_Unsigned_64), RPC_Receiver), + Etyp => RTE (RE_Unsigned_64)), + + Pack_Node_Into_Stream_Access (Loc, + Stream => Stream_Parameter, + Object => OK_Convert_To (RTE (RE_Unsigned_64), + Make_Attribute_Reference (Loc, + Prefix => + Make_Explicit_Dereference (Loc, + Prefix => Object), + Attribute_Name => Name_Address)), + Etyp => RTE (RE_Unsigned_64))); + + -- Build the code fragment corresponding to the marshalling of + -- a remote object. + + Remote_Statements := New_List ( + + Pack_Node_Into_Stream_Access (Loc, + Stream => Stream_Parameter, + Object => + Make_Selected_Component (Loc, + Prefix => Unchecked_Convert_To (Stub_Type_Access, + Object), + Selector_Name => + Make_Identifier (Loc, Name_Origin)), + Etyp => RTE (RE_Partition_ID)), + + Pack_Node_Into_Stream_Access (Loc, + Stream => Stream_Parameter, + Object => + Make_Selected_Component (Loc, + Prefix => Unchecked_Convert_To (Stub_Type_Access, + Object), + Selector_Name => + Make_Identifier (Loc, Name_Receiver)), + Etyp => RTE (RE_Unsigned_64)), + + Pack_Node_Into_Stream_Access (Loc, + Stream => Stream_Parameter, + Object => + Make_Selected_Component (Loc, + Prefix => Unchecked_Convert_To (Stub_Type_Access, + Object), + Selector_Name => + Make_Identifier (Loc, Name_Addr)), + Etyp => RTE (RE_Unsigned_64))); + + -- Build code fragment corresponding to marshalling of a null object + + Null_Statements := New_List ( + + Pack_Entity_Into_Stream_Access (Loc, + Stream => Stream_Parameter, + Object => RTE (RE_Get_Local_Partition_Id)), + + Pack_Node_Into_Stream_Access (Loc, + Stream => Stream_Parameter, + Object => OK_Convert_To (RTE (RE_Unsigned_64), RPC_Receiver), + Etyp => RTE (RE_Unsigned_64)), + + Pack_Node_Into_Stream_Access (Loc, + Stream => Stream_Parameter, + Object => Make_Integer_Literal (Loc, Uint_0), + Etyp => RTE (RE_Unsigned_64))); + + Statements := New_List ( + Make_Implicit_If_Statement (RACW_Type, + Condition => + Make_Op_Eq (Loc, + Left_Opnd => Object, + Right_Opnd => Make_Null (Loc)), + Then_Statements => Null_Statements, + Elsif_Parts => New_List ( + Make_Elsif_Part (Loc, + Condition => + Make_Op_Eq (Loc, + Left_Opnd => + Make_Attribute_Reference (Loc, + Prefix => Object, + Attribute_Name => Name_Tag), + Right_Opnd => + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Stub_Type, Loc), + Attribute_Name => Name_Tag)), + Then_Statements => Remote_Statements)), + Else_Statements => Local_Statements)); + + Build_Stream_Procedure + (Loc, RACW_Type, Body_Node, + Make_Defining_Identifier (Loc, Procedure_Name), + Statements, Outp => False); + + Proc_Decl := Make_Subprogram_Declaration (Loc, + Copy_Specification (Loc, Specification (Body_Node))); + + Attr_Decl := + Make_Attribute_Definition_Clause (Loc, + Name => New_Occurrence_Of (RACW_Type, Loc), + Chars => Name_Write, + Expression => + New_Occurrence_Of ( + Defining_Unit_Name (Specification (Proc_Decl)), Loc)); + + Insert_After (Declaration_Node (RACW_Type), Proc_Decl); + Insert_After (Proc_Decl, Attr_Decl); + Append_To (Declarations, Body_Node); + end Add_RACW_Write_Attribute; + + ------------------------ + -- Add_RAS_Access_TSS -- + ------------------------ + + procedure Add_RAS_Access_TSS (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + + Ras_Type : constant Entity_Id := Defining_Identifier (N); + Fat_Type : constant Entity_Id := Equivalent_Type (Ras_Type); + -- Ras_Type is the access to subprogram type while Fat_Type is the + -- corresponding record type. + + RACW_Type : constant Entity_Id := + Underlying_RACW_Type (Ras_Type); + Desig : constant Entity_Id := + Etype (Designated_Type (RACW_Type)); + + Stub_Elements : constant Stub_Structure := + Stubs_Table.Get (Desig); + pragma Assert (Stub_Elements /= Empty_Stub_Structure); + + Proc : constant Entity_Id := + Make_Defining_Identifier (Loc, + Chars => Make_TSS_Name (Ras_Type, TSS_RAS_Access)); + + Proc_Spec : Node_Id; + + -- Formal parameters + + Package_Name : constant Entity_Id := + Make_Defining_Identifier (Loc, + Chars => Name_P); + -- Target package + + Subp_Id : constant Entity_Id := + Make_Defining_Identifier (Loc, + Chars => Name_S); + -- Target subprogram + + Asynch_P : constant Entity_Id := + Make_Defining_Identifier (Loc, + Chars => Name_Asynchronous); + -- Is the procedure to which the 'Access applies asynchronous? + + 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. + + -- Common local variables + + Proc_Decls : List_Id; + Proc_Statements : List_Id; + + Origin : constant Entity_Id := + Make_Defining_Identifier (Loc, + Chars => New_Internal_Name ('P')); + + -- Additional local variables for the local case + + 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_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 ( + + -- Common declarations + + 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)))), + + -- Declaration use only in the local case: proxy address + + Make_Object_Declaration (Loc, + Defining_Identifier => Proxy_Addr, + Object_Definition => + New_Occurrence_Of (RTE (RE_Unsigned_64), Loc)), + + -- Declarations used only in the remote case: stub object and + -- stub pointer. + + Make_Object_Declaration (Loc, + Defining_Identifier => Local_Stub, + Aliased_Present => True, + Object_Definition => + New_Occurrence_Of (Stub_Elements.Stub_Type, Loc)), + + Make_Object_Declaration (Loc, + Defining_Identifier => + Stub_Ptr, + Object_Definition => + New_Occurrence_Of (Stub_Elements.Stub_Type_Access, Loc), + Expression => + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Local_Stub, Loc), + Attribute_Name => Name_Unchecked_Access))); + + Set_Etype (Stub_Ptr, Stub_Elements.Stub_Type_Access); + -- Build_Get_Unique_RP_Call needs this information + + -- Note: Here we assume that the Fat_Type is a record + -- containing just a pointer to a proxy or stub object. + + Proc_Statements := New_List ( + + -- Generate: + + -- Get_RAS_Info (Pkg, Subp, PA); + -- if Origin = Local_Partition_Id + -- and then not All_Calls_Remote + -- then + -- return Fat_Type!(PA); + -- end if; + + 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)))); + + Proc_Spec := + Make_Function_Specification (Loc, + Defining_Unit_Name => Proc, + Parameter_Specifications => New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => Package_Name, + Parameter_Type => + New_Occurrence_Of (Standard_String, Loc)), + + Make_Parameter_Specification (Loc, + Defining_Identifier => Subp_Id, + Parameter_Type => + New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc)), + + Make_Parameter_Specification (Loc, + Defining_Identifier => Asynch_P, + Parameter_Type => + New_Occurrence_Of (Standard_Boolean, Loc)), + + Make_Parameter_Specification (Loc, + Defining_Identifier => All_Calls_Remote, + Parameter_Type => + New_Occurrence_Of (Standard_Boolean, Loc))), + + Subtype_Mark => + New_Occurrence_Of (Fat_Type, Loc)); + + -- Set the kind and return type of the function to prevent + -- ambiguities between Ras_Type and Fat_Type in subsequent analysis. + + Set_Ekind (Proc, E_Function); + Set_Etype (Proc, Fat_Type); + + Discard_Node ( + Make_Subprogram_Body (Loc, + Specification => Proc_Spec, + Declarations => Proc_Decls, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Proc_Statements))); + + Set_TSS (Fat_Type, Proc); + end Add_RAS_Access_TSS; + + ----------------------- + -- Add_RAST_Features -- + ----------------------- + + 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; + + --------------------------------- + -- Build_General_Calling_Stubs -- + --------------------------------- + + procedure Build_General_Calling_Stubs + (Decls : List_Id; + Statements : List_Id; + Target_Partition : Entity_Id; + Target_RPC_Receiver : Node_Id; + Subprogram_Id : Node_Id; + Asynchronous : Node_Id := Empty; + Is_Known_Asynchronous : Boolean := False; + Is_Known_Non_Asynchronous : Boolean := False; + Is_Function : Boolean; + Spec : Node_Id; + Stub_Type : Entity_Id := Empty; + RACW_Type : Entity_Id := Empty; + Nod : Node_Id) + is + Loc : constant Source_Ptr := Sloc (Nod); + + Stream_Parameter : Node_Id; + -- Name of the stream used to transmit parameters to the + -- remote package. + + Result_Parameter : Node_Id; + -- Name of the result parameter (in non-APC cases) which get the + -- result of the remote subprogram. + + Exception_Return_Parameter : Node_Id; + -- Name of the parameter which will hold the exception sent by the + -- remote subprogram. + + Current_Parameter : Node_Id; + -- Current parameter being handled + + Ordered_Parameters_List : constant List_Id := + Build_Ordered_Parameters_List (Spec); + + Asynchronous_Statements : List_Id := No_List; + Non_Asynchronous_Statements : List_Id := No_List; + -- Statements specifics to the Asynchronous/Non-Asynchronous cases + + 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. + + pragma Warnings (Off); + pragma Unreferenced (RACW_Type); + -- Used only for the PolyORB case + pragma Warnings (On); + + begin + -- The general form of a calling stub for a given subprogram is: + + -- 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; + + -- 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. + + Stream_Parameter := + Make_Defining_Identifier (Loc, New_Internal_Name ('S')); + + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Stream_Parameter, + Aliased_Present => True, + Object_Definition => + Make_Subtype_Indication (Loc, + Subtype_Mark => + New_Occurrence_Of (RTE (RE_Params_Stream_Type), Loc), + Constraint => + Make_Index_Or_Discriminant_Constraint (Loc, + Constraints => + New_List (Make_Integer_Literal (Loc, 0)))))); + + if not Is_Known_Asynchronous then + Result_Parameter := + Make_Defining_Identifier (Loc, New_Internal_Name ('R')); + + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Result_Parameter, + Aliased_Present => True, + Object_Definition => + Make_Subtype_Indication (Loc, + Subtype_Mark => + New_Occurrence_Of (RTE (RE_Params_Stream_Type), Loc), + Constraint => + Make_Index_Or_Discriminant_Constraint (Loc, + Constraints => + New_List (Make_Integer_Literal (Loc, 0)))))); + + Exception_Return_Parameter := + Make_Defining_Identifier (Loc, New_Internal_Name ('E')); + + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Exception_Return_Parameter, + Object_Definition => + New_Occurrence_Of (RTE (RE_Exception_Occurrence), Loc))); + + else + Result_Parameter := Empty; + Exception_Return_Parameter := Empty; + end if; + + -- Put first the RPC receiver corresponding to the remote package + + Append_To (Statements, + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (RTE (RE_Unsigned_64), Loc), + Attribute_Name => Name_Write, + Expressions => New_List ( + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Stream_Parameter, Loc), + Attribute_Name => + Name_Access), + Target_RPC_Receiver))); + + -- Then put the Subprogram_Id of the subprogram we want to call in + -- the stream. + + Append_To (Statements, + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc), + Attribute_Name => + Name_Write, + Expressions => New_List ( + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Stream_Parameter, Loc), + Attribute_Name => Name_Access), + Subprogram_Id))); + + Current_Parameter := First (Ordered_Parameters_List); + while Present (Current_Parameter) loop + declare + Typ : constant Node_Id := + Parameter_Type (Current_Parameter); + Etyp : Entity_Id; + Constrained : Boolean; + Value : Node_Id; + Extra_Parameter : Entity_Id; + + begin + if Is_RACW_Controlling_Formal + (Current_Parameter, Stub_Type) + then + -- In the case of a controlling formal argument, we marshall + -- its addr field rather than the local stub. + + 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))); + + else + Value := New_Occurrence_Of + (Defining_Identifier (Current_Parameter), Loc); + + -- Access type parameters are transmitted as in out + -- parameters. However, a dereference is needed so that + -- we marshall the designated object. + + if Nkind (Typ) = N_Access_Definition then + Value := Make_Explicit_Dereference (Loc, Value); + Etyp := Etype (Subtype_Mark (Typ)); + else + Etyp := Etype (Typ); + end if; + + Constrained := + Is_Constrained (Etyp) or else Is_Elementary_Type (Etyp); + + -- Any parameter but unconstrained out parameters are + -- transmitted to the peer. + + if In_Present (Current_Parameter) + or else not Out_Present (Current_Parameter) + or else not Constrained + then + Append_To (Statements, + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Etyp, Loc), + Attribute_Name => + Output_From_Constrained (Constrained), + Expressions => New_List ( + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Stream_Parameter, Loc), + Attribute_Name => Name_Access), + Value))); + end if; + end if; + + -- If 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); + end; + end loop; + + -- Append the formal statements list to the statements + + Append_List_To (Statements, Extra_Formal_Statements); + + if not Is_Known_Non_Asynchronous then + + -- Build the call to System.RPC.Do_APC + + 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 + + -- Build the call to System.RPC.Do_RPC + + Non_Asynchronous_Statements := New_List ( + Make_Procedure_Call_Statement (Loc, + Name => + New_Occurrence_Of (RTE (RE_Do_Rpc), Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of (Target_Partition, Loc), + + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Stream_Parameter, Loc), + Attribute_Name => + Name_Access), + + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Result_Parameter, Loc), + Attribute_Name => + Name_Access)))); + + -- 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 (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 (Result_Parameter, Loc), + Attribute_Name => Name_Access)))))); + + 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. + + Current_Parameter := First (Ordered_Parameters_List); + while Present (Current_Parameter) loop + declare + Typ : constant Node_Id := + Parameter_Type (Current_Parameter); + Etyp : Entity_Id; + Value : Node_Id; + + begin + Value := + New_Occurrence_Of + (Defining_Identifier (Current_Parameter), Loc); + + if Nkind (Typ) = N_Access_Definition then + Value := Make_Explicit_Dereference (Loc, Value); + Etyp := Etype (Subtype_Mark (Typ)); + else + Etyp := Etype (Typ); + end if; + + if (Out_Present (Current_Parameter) + or else Nkind (Typ) = N_Access_Definition) + and then Etyp /= Stub_Type + then + Append_To (Non_Asynchronous_Statements, + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Etyp, Loc), + + Attribute_Name => Name_Read, + + Expressions => New_List ( + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Result_Parameter, Loc), + Attribute_Name => + Name_Access), + Value))); + end if; + end; + + Next (Current_Parameter); + end loop; + end if; + end if; + + if Is_Known_Asynchronous then + Append_List_To (Statements, Asynchronous_Statements); + + elsif Is_Known_Non_Asynchronous then + Append_List_To (Statements, Non_Asynchronous_Statements); + + else + pragma Assert (Present (Asynchronous)); + Prepend_To (Asynchronous_Statements, + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Standard_Boolean, Loc), + Attribute_Name => Name_Write, + Expressions => New_List ( + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Stream_Parameter, Loc), + Attribute_Name => Name_Access), + New_Occurrence_Of (Standard_True, Loc)))); + + Prepend_To (Non_Asynchronous_Statements, + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Standard_Boolean, Loc), + Attribute_Name => Name_Write, + Expressions => New_List ( + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Stream_Parameter, Loc), + Attribute_Name => Name_Access), + New_Occurrence_Of (Standard_False, Loc)))); + + Append_To (Statements, + Make_Implicit_If_Statement (Nod, + Condition => Asynchronous, + Then_Statements => Asynchronous_Statements, + Else_Statements => Non_Asynchronous_Statements)); + end if; + end Build_General_Calling_Stubs; + + ----------------------- + -- Build_Stub_Target -- + ----------------------- + + function Build_Stub_Target + (Loc : Source_Ptr; + Decls : List_Id; + RCI_Locator : Entity_Id; + Controlling_Parameter : Entity_Id) return RPC_Target + is + Target_Info : RPC_Target (PCS_Kind => Name_GARLIC_DSA); + begin + Target_Info.Partition := + Make_Defining_Identifier (Loc, New_Internal_Name ('P')); + if Present (Controlling_Parameter) then + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Target_Info.Partition, + Constant_Present => True, + Object_Definition => + New_Occurrence_Of (RTE (RE_Partition_ID), Loc), + + Expression => + Make_Selected_Component (Loc, + Prefix => + New_Occurrence_Of (Controlling_Parameter, Loc), + Selector_Name => + Make_Identifier (Loc, Name_Origin)))); + + Target_Info.RPC_Receiver := + Make_Selected_Component (Loc, + Prefix => + New_Occurrence_Of (Controlling_Parameter, Loc), + Selector_Name => + Make_Identifier (Loc, Name_Receiver)); + + else + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Target_Info.Partition, + Constant_Present => True, + Object_Definition => + New_Occurrence_Of (RTE (RE_Partition_ID), Loc), + + Expression => + Make_Function_Call (Loc, + Name => Make_Selected_Component (Loc, + Prefix => + Make_Identifier (Loc, Chars (RCI_Locator)), + Selector_Name => + Make_Identifier (Loc, + Name_Get_Active_Partition_ID))))); + + Target_Info.RPC_Receiver := + Make_Selected_Component (Loc, + Prefix => + Make_Identifier (Loc, Chars (RCI_Locator)), + Selector_Name => + Make_Identifier (Loc, Name_Get_RCI_Package_Receiver)); + end if; + return Target_Info; + end Build_Stub_Target; + + --------------------- + -- Build_Stub_Type -- + --------------------- + + procedure Build_Stub_Type + (RACW_Type : Entity_Id; + Stub_Type : Entity_Id; + Stub_Type_Decl : out Node_Id; + RPC_Receiver_Decl : out Node_Id) + is + Loc : constant Source_Ptr := Sloc (Stub_Type); + Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type); + + begin + Stub_Type_Decl := + Make_Full_Type_Declaration (Loc, + Defining_Identifier => Stub_Type, + Type_Definition => + Make_Record_Definition (Loc, + Tagged_Present => True, + Limited_Present => True, + Component_List => + Make_Component_List (Loc, + Component_Items => New_List ( + + Make_Component_Declaration (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_Origin), + Component_Definition => + Make_Component_Definition (Loc, + Aliased_Present => False, + Subtype_Indication => + New_Occurrence_Of ( + RTE (RE_Partition_ID), Loc))), + + Make_Component_Declaration (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_Receiver), + Component_Definition => + Make_Component_Definition (Loc, + Aliased_Present => False, + Subtype_Indication => + New_Occurrence_Of (RTE (RE_Unsigned_64), Loc))), + + Make_Component_Declaration (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_Addr), + Component_Definition => + Make_Component_Definition (Loc, + Aliased_Present => False, + Subtype_Indication => + New_Occurrence_Of (RTE (RE_Unsigned_64), Loc))), + + Make_Component_Declaration (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_Asynchronous), + Component_Definition => + Make_Component_Definition (Loc, + Aliased_Present => False, + Subtype_Indication => + New_Occurrence_Of ( + Standard_Boolean, Loc))))))); + + if Is_RAS then + RPC_Receiver_Decl := Empty; + else + declare + RPC_Receiver_Stream : constant Entity_Id := + Make_Defining_Identifier (Loc, Name_S); + RPC_Receiver_Result : constant Entity_Id := + Make_Defining_Identifier (Loc, Name_R); + begin + RPC_Receiver_Decl := + Make_Subprogram_Declaration (Loc, + Build_RPC_Receiver_Specification ( + RPC_Receiver => Make_Defining_Identifier (Loc, + New_Internal_Name ('R')), + Stream_Parameter => RPC_Receiver_Stream, + Result_Parameter => RPC_Receiver_Result)); + end; + end if; + end Build_Stub_Type; + + -------------------------------------- + -- Build_RPC_Receiver_Specification -- + -------------------------------------- + + 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); + + 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))), + + 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; + + ------------ + -- Result -- + ------------ + + function Result return Node_Id is + begin + return Make_Identifier (Loc, Name_V); + end Result; + + ---------------------- + -- Stream_Parameter -- + ---------------------- + + function Stream_Parameter return Node_Id is + begin + return Make_Identifier (Loc, Name_S); + end Stream_Parameter; + + end GARLIC_Support; + + ------------------ + -- Get_PCS_Name -- + ------------------ + + function Get_PCS_Name return PCS_Names is + PCS_Name : constant PCS_Names := + Chars (Entity (Expression + (Parent (RTE (RE_DSA_Implementation))))); + begin + return PCS_Name; + end Get_PCS_Name; + + ----------------------- + -- Get_Subprogram_Id -- + ----------------------- + + function Get_Subprogram_Id (Def : Entity_Id) return String_Id is + begin + return Get_Subprogram_Ids (Def).Str_Identifier; + end Get_Subprogram_Id; + + ----------------------- + -- Get_Subprogram_Id -- + ----------------------- + + function Get_Subprogram_Id (Def : Entity_Id) return Int is + begin + return Get_Subprogram_Ids (Def).Int_Identifier; + end Get_Subprogram_Id; + + ------------------------ + -- Get_Subprogram_Ids -- + ------------------------ + + function Get_Subprogram_Ids + (Def : Entity_Id) return Subprogram_Identifiers + is + Result : Subprogram_Identifiers := + Subprogram_Identifier_Table.Get (Def); + + Current_Declaration : Node_Id; + Current_Subp : Entity_Id; + Current_Subp_Str : String_Id; + Current_Subp_Number : Int := First_RCI_Subprogram_Id; + + begin + if Result.Str_Identifier = No_String then + + -- We are looking up this subprogram's identifier outside of the + -- context of generating calling or receiving stubs. Hence we are + -- processing an 'Access attribute_reference for an RCI subprogram, + -- for the purpose of obtaining a RAS value. + + pragma Assert + (Is_Remote_Call_Interface (Scope (Def)) + and then + (Nkind (Parent (Def)) = N_Procedure_Specification + or else + Nkind (Parent (Def)) = N_Function_Specification)); + + Current_Declaration := + First (Visible_Declarations + (Package_Specification_Of_Scope (Scope (Def)))); + while Present (Current_Declaration) loop + if Nkind (Current_Declaration) = N_Subprogram_Declaration + and then Comes_From_Source (Current_Declaration) + then + Current_Subp := Defining_Unit_Name (Specification ( + Current_Declaration)); + Assign_Subprogram_Identifier + (Current_Subp, Current_Subp_Number, Current_Subp_Str); + + if Current_Subp = Def then + Result := (Current_Subp_Str, Current_Subp_Number); + end if; + + Current_Subp_Number := Current_Subp_Number + 1; + end if; + + Next (Current_Declaration); + end loop; + end if; + + pragma Assert (Result.Str_Identifier /= No_String); + return Result; + end Get_Subprogram_Ids; + + ---------- + -- Hash -- + ---------- + + function Hash (F : Entity_Id) return Hash_Index is + begin + return Hash_Index (Natural (F) mod Positive (Hash_Index'Last + 1)); + end Hash; + + function Hash (F : Name_Id) return Hash_Index is + begin + return Hash_Index (Natural (F) mod Positive (Hash_Index'Last + 1)); + end Hash; + + -------------------------- + -- Input_With_Tag_Check -- + -------------------------- + + function Input_With_Tag_Check + (Loc : Source_Ptr; + Var_Type : Entity_Id; + Stream : Entity_Id) return Node_Id + is + begin + return + Make_Subprogram_Body (Loc, + Specification => Make_Function_Specification (Loc, + Defining_Unit_Name => + Make_Defining_Identifier (Loc, New_Internal_Name ('S')), + Subtype_Mark => New_Occurrence_Of (Var_Type, Loc)), + Declarations => No_List, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, New_List ( + Make_Tag_Check (Loc, + Make_Return_Statement (Loc, + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Var_Type, Loc), + Attribute_Name => Name_Input, + Expressions => + New_List (New_Occurrence_Of (Stream, Loc)))))))); + end Input_With_Tag_Check; + + -------------------------------- + -- Is_RACW_Controlling_Formal -- + -------------------------------- + + function Is_RACW_Controlling_Formal + (Parameter : Node_Id; + Stub_Type : Entity_Id) return Boolean + is + Typ : Entity_Id; + + begin + -- If the kind of the parameter is E_Void, then it is not a + -- controlling formal (this can happen in the context of RAS). + + if Ekind (Defining_Identifier (Parameter)) = E_Void then + return False; + end if; + + -- If the parameter is not a controlling formal, then it cannot + -- be possibly a RACW_Controlling_Formal. + + if not Is_Controlling_Formal (Defining_Identifier (Parameter)) then + return False; + end if; + + Typ := Parameter_Type (Parameter); + return (Nkind (Typ) = N_Access_Definition + and then Etype (Subtype_Mark (Typ)) = Stub_Type) + or else Etype (Typ) = Stub_Type; + end Is_RACW_Controlling_Formal; + + -------------------- + -- Make_Tag_Check -- + -------------------- + + function Make_Tag_Check (Loc : Source_Ptr; N : Node_Id) return Node_Id is + Occ : constant Entity_Id := + Make_Defining_Identifier (Loc, New_Internal_Name ('E')); + + begin + return Make_Block_Statement (Loc, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List (N), + + Exception_Handlers => New_List ( + Make_Exception_Handler (Loc, + Choice_Parameter => Occ, + + Exception_Choices => + New_List (New_Occurrence_Of (RTE (RE_Tag_Error), Loc)), + + Statements => + New_List (Make_Procedure_Call_Statement (Loc, + New_Occurrence_Of + (RTE (RE_Raise_Program_Error_Unknown_Tag), Loc), + New_List (New_Occurrence_Of (Occ, Loc)))))))); + end Make_Tag_Check; + + ---------------------------- + -- Need_Extra_Constrained -- + ---------------------------- + + function Need_Extra_Constrained (Parameter : Node_Id) return Boolean is + Etyp : constant Entity_Id := Etype (Parameter_Type (Parameter)); + begin + return Out_Present (Parameter) + and then Has_Discriminants (Etyp) + and then not Is_Constrained (Etyp) + and then not Is_Indefinite_Subtype (Etyp); + end Need_Extra_Constrained; + + ------------------------------------ + -- Pack_Entity_Into_Stream_Access -- + ------------------------------------ + + function Pack_Entity_Into_Stream_Access + (Loc : Source_Ptr; + Stream : Node_Id; + Object : Entity_Id; + Etyp : Entity_Id := Empty) return Node_Id + is + Typ : Entity_Id; + + begin + if Present (Etyp) then + Typ := Etyp; + else + Typ := Etype (Object); + end if; + + return + Pack_Node_Into_Stream_Access (Loc, + Stream => Stream, + Object => New_Occurrence_Of (Object, Loc), + Etyp => Typ); + end Pack_Entity_Into_Stream_Access; + + --------------------------- + -- Pack_Node_Into_Stream -- + --------------------------- + + function Pack_Node_Into_Stream + (Loc : Source_Ptr; + Stream : Entity_Id; + Object : Node_Id; + Etyp : Entity_Id) return Node_Id + is + Write_Attribute : Name_Id := Name_Write; + + begin + if not Is_Constrained (Etyp) then + Write_Attribute := Name_Output; + end if; + + return + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Etyp, Loc), + Attribute_Name => Write_Attribute, + Expressions => New_List ( + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Stream, Loc), + Attribute_Name => Name_Access), + Object)); + end Pack_Node_Into_Stream; + + ---------------------------------- + -- Pack_Node_Into_Stream_Access -- + ---------------------------------- + + function Pack_Node_Into_Stream_Access + (Loc : Source_Ptr; + Stream : Node_Id; + Object : Node_Id; + Etyp : Entity_Id) return Node_Id + is + Write_Attribute : Name_Id := Name_Write; + + begin + if not Is_Constrained (Etyp) then + Write_Attribute := Name_Output; + end if; + + return + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Etyp, Loc), + Attribute_Name => Write_Attribute, + Expressions => New_List ( + Stream, + Object)); + end Pack_Node_Into_Stream_Access; + + --------------------- + -- PolyORB_Support -- + --------------------- + + package body PolyORB_Support is + + -- Local subprograms + + 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; + Declarations : List_Id); + -- Same thing for the Write attribute + + procedure Add_RACW_From_Any + (RACW_Type : Entity_Id; + Stub_Type : Entity_Id; + Stub_Type_Access : Entity_Id; + Declarations : List_Id); + -- Add the From_Any TSS for this RACW type + + procedure Add_RACW_To_Any + (Designated_Type : Entity_Id; + RACW_Type : Entity_Id; + Stub_Type : Entity_Id; + Stub_Type_Access : Entity_Id; + Declarations : List_Id); + -- Add the To_Any TSS for this RACW type + + procedure Add_RACW_TypeCode + (Designated_Type : Entity_Id; + RACW_Type : Entity_Id; + Declarations : List_Id); + -- Add the TypeCode TSS for this RACW type + + procedure Add_RAS_From_Any + (RAS_Type : Entity_Id; + Declarations : List_Id); + -- Add the From_Any TSS for this RAS type + + procedure Add_RAS_To_Any + (RAS_Type : Entity_Id; + Declarations : List_Id); + -- Add the To_Any TSS for this RAS type + + procedure Add_RAS_TypeCode + (RAS_Type : Entity_Id; + Declarations : List_Id); + -- Add the TypeCode TSS for this RAS type + + 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; + Desig : Entity_Id; + Stub_Type : Entity_Id; + Stub_Type_Access : Entity_Id; + RPC_Receiver_Decl : Node_Id; + Declarations : List_Id) + is + pragma Warnings (Off); + pragma Unreferenced (RPC_Receiver_Decl); + pragma Warnings (On); + + begin + Add_RACW_From_Any + (RACW_Type => RACW_Type, + Stub_Type => Stub_Type, + Stub_Type_Access => Stub_Type_Access, + Declarations => Declarations); + + Add_RACW_To_Any + (Designated_Type => Desig, + RACW_Type => RACW_Type, + Stub_Type => Stub_Type, + Stub_Type_Access => Stub_Type_Access, + Declarations => Declarations); + + -- In the PolyORB case, the RACW 'Read and 'Write attributes + -- are implemented in terms of the From_Any and To_Any TSSs, + -- so these TSSs must be expanded before 'Read and 'Write. + + Add_RACW_Write_Attribute + (RACW_Type => RACW_Type, + Stub_Type => Stub_Type, + Stub_Type_Access => Stub_Type_Access, + Declarations => Declarations); + + Add_RACW_Read_Attribute + (RACW_Type => RACW_Type, + Stub_Type => Stub_Type, + Stub_Type_Access => Stub_Type_Access, + Declarations => Declarations); + + Add_RACW_TypeCode + (Designated_Type => Desig, + RACW_Type => RACW_Type, + Declarations => Declarations); + end Add_RACW_Features; + + ----------------------- + -- Add_RACW_From_Any -- + ----------------------- + + procedure Add_RACW_From_Any + (RACW_Type : Entity_Id; + Stub_Type : Entity_Id; + Stub_Type_Access : Entity_Id; + Declarations : List_Id) + is + Loc : constant Source_Ptr := Sloc (RACW_Type); + Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type); + + Fnam : constant Entity_Id := + Make_Defining_Identifier (Loc, New_Internal_Name ('F')); + + Func_Spec : Node_Id; + Func_Decl : Node_Id; + Func_Body : Node_Id; + + Decls : List_Id; + Statements : List_Id; + Stub_Statements : List_Id; + Local_Statements : List_Id; + -- Various parts of the subprogram + + Any_Parameter : constant Entity_Id := + Make_Defining_Identifier (Loc, Name_A); + Reference : constant Entity_Id := + Make_Defining_Identifier + (Loc, New_Internal_Name ('R')); + Is_Local : constant Entity_Id := + Make_Defining_Identifier + (Loc, New_Internal_Name ('L')); + Addr : constant Entity_Id := + Make_Defining_Identifier + (Loc, New_Internal_Name ('A')); + Local_Stub : constant Entity_Id := + Make_Defining_Identifier + (Loc, New_Internal_Name ('L')); + Stubbed_Result : constant Entity_Id := + Make_Defining_Identifier + (Loc, New_Internal_Name ('S')); + + Stub_Condition : Node_Id; + -- An expression that determines whether we create a stub for the + -- newly-unpacked RACW. Normally we create a stub only for remote + -- objects, but in the case of an RACW used to implement a RAS, + -- we also create a stub for local subprograms if a pragma + -- All_Calls_Remote applies. + + Asynchronous_Flag : constant Entity_Id := + Asynchronous_Flags_Table.Get (RACW_Type); + -- The flag object declared in Add_RACW_Asynchronous_Flag + + begin + -- Object declarations + + Decls := New_List ( + Make_Object_Declaration (Loc, + Defining_Identifier => + Reference, + Object_Definition => + New_Occurrence_Of (RTE (RE_Object_Ref), Loc), + Expression => + Make_Function_Call (Loc, + Name => + New_Occurrence_Of (RTE (RE_FA_ObjRef), Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of (Any_Parameter, Loc)))), + + Make_Object_Declaration (Loc, + Defining_Identifier => Local_Stub, + Aliased_Present => True, + Object_Definition => New_Occurrence_Of (Stub_Type, Loc)), + + Make_Object_Declaration (Loc, + Defining_Identifier => Stubbed_Result, + Object_Definition => + New_Occurrence_Of (Stub_Type_Access, Loc), + Expression => + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Local_Stub, Loc), + Attribute_Name => + Name_Unchecked_Access)), + + Make_Object_Declaration (Loc, + Defining_Identifier => Is_Local, + Object_Definition => + New_Occurrence_Of (Standard_Boolean, Loc)), + + Make_Object_Declaration (Loc, + Defining_Identifier => Addr, + Object_Definition => + New_Occurrence_Of (RTE (RE_Address), Loc))); + + -- Build_Get_Unique_RP_Call needs the type of Stubbed_Result + + Set_Etype (Stubbed_Result, Stub_Type_Access); + + -- If the ref Is_Nil, return a null pointer + + Statements := New_List ( + Make_Implicit_If_Statement (RACW_Type, + Condition => + Make_Function_Call (Loc, + Name => + New_Occurrence_Of (RTE (RE_Is_Nil), Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of (Reference, Loc))), + Then_Statements => New_List ( + Make_Return_Statement (Loc, + Expression => + Make_Null (Loc))))); + + Append_To (Statements, + Make_Procedure_Call_Statement (Loc, + Name => + New_Occurrence_Of (RTE (RE_Get_Local_Address), Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of (Reference, Loc), + New_Occurrence_Of (Is_Local, Loc), + New_Occurrence_Of (Addr, Loc)))); + + -- 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. This stanza is always used in the + -- case of RAS types, for which a stub is required even for local + -- subprograms. + + Stub_Statements := New_List ( + Make_Assignment_Statement (Loc, + Name => Make_Selected_Component (Loc, + Prefix => New_Occurrence_Of (Stubbed_Result, Loc), + Selector_Name => Make_Identifier (Loc, Name_Target)), + Expression => + Make_Function_Call (Loc, + Name => + New_Occurrence_Of (RTE (RE_Entity_Of), Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of (Reference, Loc)))), + + Make_Procedure_Call_Statement (Loc, + Name => + New_Occurrence_Of (RTE (RE_Inc_Usage), Loc), + Parameter_Associations => New_List ( + Make_Selected_Component (Loc, + Prefix => New_Occurrence_Of (Stubbed_Result, Loc), + Selector_Name => Make_Identifier (Loc, Name_Target)))), + + Make_Assignment_Statement (Loc, + Name => Make_Selected_Component (Loc, + Prefix => New_Occurrence_Of (Stubbed_Result, Loc), + Selector_Name => Make_Identifier (Loc, Name_Asynchronous)), + Expression => + New_Occurrence_Of (Asynchronous_Flag, Loc))); + + -- ??? 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 + -- _From_Any TSS. + + Append_List_To (Stub_Statements, + Build_Get_Unique_RP_Call (Loc, Stubbed_Result, Stub_Type)); + + -- Distinguish between the local and remote cases, and execute the + -- appropriate piece of code. + + Stub_Condition := New_Occurrence_Of (Is_Local, Loc); + + if Is_RAS then + Stub_Condition := Make_And_Then (Loc, + Left_Opnd => + Stub_Condition, + Right_Opnd => + Make_Selected_Component (Loc, + Prefix => + Unchecked_Convert_To ( + RTE (RE_RAS_Proxy_Type_Access), + New_Occurrence_Of (Addr, Loc)), + Selector_Name => + Make_Identifier (Loc, + Name_All_Calls_Remote))); + end if; + + Local_Statements := New_List ( + Make_Return_Statement (Loc, + Expression => + Unchecked_Convert_To (RACW_Type, + New_Occurrence_Of (Addr, Loc)))); + + Append_To (Statements, + Make_Implicit_If_Statement (RACW_Type, + Condition => + Stub_Condition, + Then_Statements => Local_Statements, + Else_Statements => Stub_Statements)); + + Append_To (Statements, + Make_Return_Statement (Loc, + Expression => Unchecked_Convert_To (RACW_Type, + New_Occurrence_Of (Stubbed_Result, Loc)))); + + Func_Spec := + Make_Function_Specification (Loc, + Defining_Unit_Name => + Fnam, + Parameter_Specifications => New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => + Any_Parameter, + Parameter_Type => + New_Occurrence_Of (RTE (RE_Any), Loc))), + Subtype_Mark => New_Occurrence_Of (RACW_Type, Loc)); + + -- NOTE: The usage occurrences of RACW_Parameter must + -- refer to the entity in the declaration spec, not those + -- of the body spec. + + Func_Decl := Make_Subprogram_Declaration (Loc, Func_Spec); + + Func_Body := + Make_Subprogram_Body (Loc, + Specification => + Copy_Specification (Loc, Func_Spec), + Declarations => Decls, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Statements)); + + Insert_After (Declaration_Node (RACW_Type), Func_Decl); + Append_To (Declarations, Func_Body); + + Set_Renaming_TSS (RACW_Type, Fnam, Name_uFrom_Any); + end Add_RACW_From_Any; + + ----------------------------- + -- 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 + pragma Warnings (Off); + pragma Unreferenced (Stub_Type, Stub_Type_Access); + pragma Warnings (On); + Loc : constant Source_Ptr := Sloc (RACW_Type); + + Proc_Decl : Node_Id; + Attr_Decl : Node_Id; + + Body_Node : Node_Id; + + Decls : List_Id; + Statements : List_Id; + -- Various parts of the procedure + + Procedure_Name : constant Name_Id := + New_Internal_Name ('R'); + Source_Ref : constant Entity_Id := + Make_Defining_Identifier + (Loc, New_Internal_Name ('R')); + Asynchronous_Flag : constant Entity_Id := + Asynchronous_Flags_Table.Get (RACW_Type); + pragma Assert (Present (Asynchronous_Flag)); + + function Stream_Parameter return Node_Id; + function Result return Node_Id; + -- Functions to create occurrences of the formal parameter names + + ------------ + -- Result -- + ------------ + + function Result return Node_Id is + begin + return Make_Identifier (Loc, Name_V); + end Result; + + ---------------------- + -- Stream_Parameter -- + ---------------------- + + function Stream_Parameter return Node_Id is + begin + return Make_Identifier (Loc, Name_S); + end Stream_Parameter; + + -- Start of processing for Add_RACW_Read_Attribute + + begin + -- Generate object declarations + + Decls := New_List ( + Make_Object_Declaration (Loc, + Defining_Identifier => Source_Ref, + Object_Definition => + New_Occurrence_Of (RTE (RE_Object_Ref), Loc))); + + Statements := New_List ( + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (RTE (RE_Object_Ref), Loc), + Attribute_Name => Name_Read, + Expressions => New_List ( + Stream_Parameter, + New_Occurrence_Of (Source_Ref, Loc))), + Make_Assignment_Statement (Loc, + Name => + Result, + Expression => + PolyORB_Support.Helpers.Build_From_Any_Call ( + RACW_Type, + Make_Function_Call (Loc, + Name => + New_Occurrence_Of (RTE (RE_TA_ObjRef), Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of (Source_Ref, Loc))), + Decls))); + + Build_Stream_Procedure + (Loc, RACW_Type, Body_Node, + Make_Defining_Identifier (Loc, Procedure_Name), + Statements, Outp => True); + Set_Declarations (Body_Node, Decls); + + Proc_Decl := Make_Subprogram_Declaration (Loc, + Copy_Specification (Loc, Specification (Body_Node))); + + Attr_Decl := + Make_Attribute_Definition_Clause (Loc, + Name => New_Occurrence_Of (RACW_Type, Loc), + Chars => Name_Read, + Expression => + New_Occurrence_Of ( + Defining_Unit_Name (Specification (Proc_Decl)), Loc)); + + Insert_After (Declaration_Node (RACW_Type), Proc_Decl); + Insert_After (Proc_Decl, Attr_Decl); + Append_To (Declarations, Body_Node); + end Add_RACW_Read_Attribute; + + --------------------- + -- Add_RACW_To_Any -- + --------------------- + + procedure Add_RACW_To_Any + (Designated_Type : Entity_Id; + RACW_Type : Entity_Id; + Stub_Type : Entity_Id; + Stub_Type_Access : Entity_Id; + Declarations : List_Id) + is + Loc : constant Source_Ptr := Sloc (RACW_Type); + + Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type); + + Fnam : Entity_Id; + + Stub_Elements : constant Stub_Structure := + Stubs_Table.Get (Designated_Type); + pragma Assert (Stub_Elements /= Empty_Stub_Structure); + + Func_Spec : Node_Id; + Func_Decl : Node_Id; + Func_Body : Node_Id; + + Decls : List_Id; + Statements : List_Id; + Null_Statements : List_Id; + Local_Statements : List_Id := No_List; + Stub_Statements : List_Id; + If_Node : Node_Id; + -- Various parts of the subprogram + + RACW_Parameter : constant Entity_Id + := Make_Defining_Identifier (Loc, Name_R); + + Reference : constant Entity_Id := + Make_Defining_Identifier + (Loc, New_Internal_Name ('R')); + Any : constant Entity_Id := + Make_Defining_Identifier + (Loc, New_Internal_Name ('A')); + + begin + -- Object declarations + + Decls := New_List ( + Make_Object_Declaration (Loc, + Defining_Identifier => + Reference, + Object_Definition => + New_Occurrence_Of (RTE (RE_Object_Ref), Loc)), + Make_Object_Declaration (Loc, + Defining_Identifier => + Any, + Object_Definition => + New_Occurrence_Of (RTE (RE_Any), Loc))); + + -- If the object is null, nothing to do (Reference is already + -- a Nil ref.) + + Null_Statements := New_List (Make_Null_Statement (Loc)); + + if Is_RAS then + + -- If the object is a RAS designating a local subprogram, + -- we already have a target reference. + + Local_Statements := New_List ( + Make_Procedure_Call_Statement (Loc, + Name => + New_Occurrence_Of (RTE (RE_Set_Ref), Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of (Reference, Loc), + Make_Selected_Component (Loc, + Prefix => + Unchecked_Convert_To (RTE (RE_RAS_Proxy_Type_Access), + New_Occurrence_Of (RACW_Parameter, Loc)), + Selector_Name => Make_Identifier (Loc, Name_Target))))); + + else + -- If the object is a local RACW object, use Get_Reference now + -- to obtain a reference. + + Local_Statements := New_List ( + Make_Procedure_Call_Statement (Loc, + Name => + New_Occurrence_Of (RTE (RE_Get_Reference), Loc), + Parameter_Associations => New_List ( + Unchecked_Convert_To ( + RTE (RE_Address), + New_Occurrence_Of (RACW_Parameter, Loc)), + Make_String_Literal (Loc, + Full_Qualified_Name (Designated_Type)), + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of ( + Defining_Identifier ( + Stub_Elements.RPC_Receiver_Decl), Loc), + Attribute_Name => + Name_Access), + New_Occurrence_Of (Reference, Loc)))); + end if; + + -- If the object is located on another partition, use the target + -- from the stub. + + Stub_Statements := New_List ( + Make_Procedure_Call_Statement (Loc, + Name => + New_Occurrence_Of (RTE (RE_Set_Ref), Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of (Reference, Loc), + Make_Selected_Component (Loc, + Prefix => Unchecked_Convert_To (Stub_Type_Access, + New_Occurrence_Of (RACW_Parameter, Loc)), + Selector_Name => + Make_Identifier (Loc, Name_Target))))); + + -- Distinguish between the null, local and remote cases, + -- and execute the appropriate piece of code. + + If_Node := + Make_Implicit_If_Statement (RACW_Type, + Condition => + Make_Op_Eq (Loc, + Left_Opnd => New_Occurrence_Of (RACW_Parameter, Loc), + Right_Opnd => Make_Null (Loc)), + Then_Statements => Null_Statements, + Elsif_Parts => New_List ( + Make_Elsif_Part (Loc, + Condition => + Make_Op_Ne (Loc, + Left_Opnd => + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (RACW_Parameter, Loc), + Attribute_Name => Name_Tag), + Right_Opnd => + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Stub_Type, Loc), + Attribute_Name => Name_Tag)), + Then_Statements => Local_Statements)), + Else_Statements => Stub_Statements); + + Statements := New_List ( + If_Node, + Make_Assignment_Statement (Loc, + Name => + New_Occurrence_Of (Any, Loc), + Expression => + Make_Function_Call (Loc, + Name => New_Occurrence_Of (RTE (RE_TA_ObjRef), Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of (Reference, Loc)))), + Make_Procedure_Call_Statement (Loc, + Name => + New_Occurrence_Of (RTE (RE_Set_TC), Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of (Any, Loc), + Make_Selected_Component (Loc, + Prefix => + New_Occurrence_Of ( + Defining_Identifier ( + Stub_Elements.RPC_Receiver_Decl), Loc), + Selector_Name => + Make_Identifier (Loc, Name_Obj_TypeCode)))), + Make_Return_Statement (Loc, + Expression => + New_Occurrence_Of (Any, Loc))); + + Fnam := Make_Defining_Identifier ( + Loc, New_Internal_Name ('T')); + + Func_Spec := + Make_Function_Specification (Loc, + Defining_Unit_Name => + Fnam, + Parameter_Specifications => New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => + RACW_Parameter, + Parameter_Type => + New_Occurrence_Of (RACW_Type, Loc))), + Subtype_Mark => New_Occurrence_Of (RTE (RE_Any), Loc)); + + -- NOTE: The usage occurrences of RACW_Parameter must + -- refer to the entity in the declaration spec, not in + -- the body spec. + + Func_Decl := Make_Subprogram_Declaration (Loc, Func_Spec); + + Func_Body := + Make_Subprogram_Body (Loc, + Specification => + Copy_Specification (Loc, Func_Spec), + Declarations => Decls, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Statements)); + + Insert_After (Declaration_Node (RACW_Type), Func_Decl); + Append_To (Declarations, Func_Body); + + Set_Renaming_TSS (RACW_Type, Fnam, Name_uTo_Any); + end Add_RACW_To_Any; + + ----------------------- + -- Add_RACW_TypeCode -- + ----------------------- + + procedure Add_RACW_TypeCode + (Designated_Type : Entity_Id; + RACW_Type : Entity_Id; + Declarations : List_Id) + is + Loc : constant Source_Ptr := Sloc (RACW_Type); + + Fnam : Entity_Id; + + Stub_Elements : constant Stub_Structure := + Stubs_Table.Get (Designated_Type); + pragma Assert (Stub_Elements /= Empty_Stub_Structure); + + Func_Spec : Node_Id; + Func_Decl : Node_Id; + Func_Body : Node_Id; + + RACW_Parameter : constant Entity_Id := + Make_Defining_Identifier (Loc, Name_R); + + begin + Fnam := + Make_Defining_Identifier (Loc, + Chars => New_Internal_Name ('T')); + + -- The spec for this subprogram has a dummy 'access RACW' + -- argument, which serves only for overloading purposes. + + Func_Spec := + Make_Function_Specification (Loc, + Defining_Unit_Name => + Fnam, + Parameter_Specifications => New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => + RACW_Parameter, + Parameter_Type => + Make_Access_Definition (Loc, + Subtype_Mark => + New_Occurrence_Of (RACW_Type, Loc)))), + Subtype_Mark => New_Occurrence_Of (RTE (RE_TypeCode), Loc)); + + -- NOTE: The usage occurrences of RACW_Parameter must + -- refer to the entity in the declaration spec, not those + -- of the body spec. + + Func_Decl := Make_Subprogram_Declaration (Loc, Func_Spec); + + Func_Body := + Make_Subprogram_Body (Loc, + Specification => + Copy_Specification (Loc, Func_Spec), + Declarations => Empty_List, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List ( + Make_Return_Statement (Loc, + Expression => + Make_Selected_Component (Loc, + Prefix => + New_Occurrence_Of ( + Defining_Identifier ( + Stub_Elements.RPC_Receiver_Decl), Loc), + Selector_Name => + Make_Identifier (Loc, Name_Obj_TypeCode)))))); + + Insert_After (Declaration_Node (RACW_Type), Func_Decl); + Append_To (Declarations, Func_Body); + + Set_Renaming_TSS (RACW_Type, Fnam, Name_uTypeCode); + end Add_RACW_TypeCode; + + ------------------------------ + -- Add_RACW_Write_Attribute -- + ------------------------------ + + procedure Add_RACW_Write_Attribute + (RACW_Type : Entity_Id; + Stub_Type : Entity_Id; + Stub_Type_Access : Entity_Id; + Declarations : List_Id) + is + Loc : constant Source_Ptr := Sloc (RACW_Type); + pragma Warnings (Off); + pragma Unreferenced ( + Stub_Type, + Stub_Type_Access); + + Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type); + pragma Unreferenced (Is_RAS); + pragma Warnings (On); + + Body_Node : Node_Id; + Proc_Decl : Node_Id; + Attr_Decl : Node_Id; + + Statements : List_Id; + Procedure_Name : constant Name_Id := New_Internal_Name ('R'); + + function Stream_Parameter return Node_Id; + function Object return Node_Id; + -- Functions to create occurrences of the formal parameter names + + ------------ + -- Object -- + ------------ + + function Object return Node_Id is + Object_Ref : constant Node_Id := + Make_Identifier (Loc, Name_V); + + begin + -- Etype must be set for Build_To_Any_Call + + Set_Etype (Object_Ref, RACW_Type); + + return Object_Ref; + end Object; + + ---------------------- + -- Stream_Parameter -- + ---------------------- + + function Stream_Parameter return Node_Id is + begin + return Make_Identifier (Loc, Name_S); + end Stream_Parameter; + + -- Start of processing for Add_RACW_Write_Attribute + + begin + Statements := New_List ( + Pack_Node_Into_Stream_Access (Loc, + Stream => Stream_Parameter, + Object => + Make_Function_Call (Loc, + Name => + New_Occurrence_Of (RTE (RE_FA_ObjRef), Loc), + Parameter_Associations => New_List ( + PolyORB_Support.Helpers.Build_To_Any_Call + (Object, Declarations))), + Etyp => RTE (RE_Object_Ref))); + + Build_Stream_Procedure + (Loc, RACW_Type, Body_Node, + Make_Defining_Identifier (Loc, Procedure_Name), + Statements, Outp => False); + + Proc_Decl := + Make_Subprogram_Declaration (Loc, + Copy_Specification (Loc, Specification (Body_Node))); + + Attr_Decl := + Make_Attribute_Definition_Clause (Loc, + Name => New_Occurrence_Of (RACW_Type, Loc), + Chars => Name_Write, + Expression => + New_Occurrence_Of ( + Defining_Unit_Name (Specification (Proc_Decl)), Loc)); + + Insert_After (Declaration_Node (RACW_Type), Proc_Decl); + Insert_After (Proc_Decl, Attr_Decl); + Append_To (Declarations, Body_Node); + end Add_RACW_Write_Attribute; + + ----------------------- + -- Add_RAST_Features -- + ----------------------- + + procedure Add_RAST_Features + (Vis_Decl : Node_Id; + RAS_Type : Entity_Id; + Decls : List_Id) + is + begin + Add_RAS_Access_TSS (Vis_Decl); + + Add_RAS_From_Any (RAS_Type, Decls); + Add_RAS_TypeCode (RAS_Type, Decls); + + -- To_Any uses TypeCode, and therefore needs to be generated last + + Add_RAS_To_Any (RAS_Type, Decls); + end Add_RAST_Features; + + ------------------------ + -- Add_RAS_Access_TSS -- + ------------------------ + + procedure Add_RAS_Access_TSS (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + + Ras_Type : constant Entity_Id := Defining_Identifier (N); + Fat_Type : constant Entity_Id := Equivalent_Type (Ras_Type); + -- Ras_Type is the access to subprogram type; Fat_Type is the + -- corresponding record type. + + RACW_Type : constant Entity_Id := + Underlying_RACW_Type (Ras_Type); + Desig : constant Entity_Id := + Etype (Designated_Type (RACW_Type)); + + Stub_Elements : constant Stub_Structure := + Stubs_Table.Get (Desig); + pragma Assert (Stub_Elements /= Empty_Stub_Structure); + + Proc : constant Entity_Id := + Make_Defining_Identifier (Loc, + Chars => Make_TSS_Name (Ras_Type, TSS_RAS_Access)); + + Proc_Spec : Node_Id; + + -- Formal parameters + + Package_Name : constant Entity_Id := + Make_Defining_Identifier (Loc, + Chars => Name_P); + + -- Target package + + Subp_Id : constant Entity_Id := + Make_Defining_Identifier (Loc, + Chars => Name_S); + + -- Target subprogram + + Asynch_P : constant Entity_Id := + Make_Defining_Identifier (Loc, + Chars => Name_Asynchronous); + -- Is the procedure to which the 'Access applies asynchronous? + + 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. + + -- Common local variables + + Proc_Decls : List_Id; + Proc_Statements : List_Id; + + Subp_Ref : constant Entity_Id := + Make_Defining_Identifier (Loc, Name_R); + -- Reference that designates the target subprogram (returned + -- by Get_RAS_Info). + + Is_Local : constant Entity_Id := + Make_Defining_Identifier (Loc, Name_L); + Local_Addr : constant Entity_Id := + Make_Defining_Identifier (Loc, Name_A); + -- For the call to Get_Local_Address + + -- 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_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 ( + + -- Common declarations + + Make_Object_Declaration (Loc, + Defining_Identifier => Subp_Ref, + Object_Definition => + New_Occurrence_Of (RTE (RE_Object_Ref), Loc)), + + Make_Object_Declaration (Loc, + Defining_Identifier => Is_Local, + Object_Definition => + New_Occurrence_Of (Standard_Boolean, Loc)), + + Make_Object_Declaration (Loc, + Defining_Identifier => Local_Addr, + Object_Definition => + New_Occurrence_Of (RTE (RE_Address), Loc)), + + Make_Object_Declaration (Loc, + Defining_Identifier => Local_Stub, + Aliased_Present => True, + Object_Definition => + New_Occurrence_Of (Stub_Elements.Stub_Type, Loc)), + + Make_Object_Declaration (Loc, + Defining_Identifier => + Stub_Ptr, + Object_Definition => + New_Occurrence_Of (Stub_Elements.Stub_Type_Access, Loc), + Expression => + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Local_Stub, Loc), + Attribute_Name => Name_Unchecked_Access))); + + Set_Etype (Stub_Ptr, Stub_Elements.Stub_Type_Access); + -- Build_Get_Unique_RP_Call needs this information + + -- Get_RAS_Info (Pkg, Subp, R); + -- Obtain a reference to the target subprogram + + Proc_Statements := New_List ( + Make_Procedure_Call_Statement (Loc, + Name => + New_Occurrence_Of (RTE (RE_Get_RAS_Info), Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of (Package_Name, Loc), + New_Occurrence_Of (Subp_Id, Loc), + New_Occurrence_Of (Subp_Ref, Loc))), + + -- Get_Local_Address (R, L, A); + -- Determine whether the subprogram is local (L), and if so + -- obtain the local address of its proxy (A). + + Make_Procedure_Call_Statement (Loc, + Name => + New_Occurrence_Of (RTE (RE_Get_Local_Address), Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of (Subp_Ref, Loc), + New_Occurrence_Of (Is_Local, Loc), + New_Occurrence_Of (Local_Addr, Loc)))); + + -- Note: Here we assume that the Fat_Type is a record containing just + -- an access to a proxy or stub object. + + Append_To (Proc_Statements, + + -- if L then + + Make_Implicit_If_Statement (N, + Condition => + New_Occurrence_Of (Is_Local, Loc), + + Then_Statements => New_List ( + + -- if A.Target = null then + + Make_Implicit_If_Statement (N, + Condition => + Make_Op_Eq (Loc, + Make_Selected_Component (Loc, + Prefix => + Unchecked_Convert_To ( + RTE (RE_RAS_Proxy_Type_Access), + New_Occurrence_Of (Local_Addr, Loc)), + Selector_Name => + Make_Identifier (Loc, Name_Target)), + Make_Null (Loc)), + + Then_Statements => New_List ( + + -- A.Target := Entity_Of (Ref); + + Make_Assignment_Statement (Loc, + Name => + Make_Selected_Component (Loc, + Prefix => + Unchecked_Convert_To ( + RTE (RE_RAS_Proxy_Type_Access), + New_Occurrence_Of (Local_Addr, Loc)), + Selector_Name => + Make_Identifier (Loc, Name_Target)), + Expression => + Make_Function_Call (Loc, + Name => + New_Occurrence_Of (RTE (RE_Entity_Of), Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of (Subp_Ref, Loc)))), + + -- Inc_Usage (A.Target); + + Make_Procedure_Call_Statement (Loc, + Name => + New_Occurrence_Of (RTE (RE_Inc_Usage), Loc), + Parameter_Associations => New_List ( + Make_Selected_Component (Loc, + Prefix => + Unchecked_Convert_To ( + RTE (RE_RAS_Proxy_Type_Access), + New_Occurrence_Of (Local_Addr, Loc)), + Selector_Name => Make_Identifier (Loc, + Name_Target)))))), + + -- end if; + -- if not All_Calls_Remote then + -- return Fat_Type!(A); + -- end if; + + Make_Implicit_If_Statement (N, + Condition => + Make_Op_Not (Loc, + New_Occurrence_Of (All_Calls_Remote, Loc)), + + Then_Statements => New_List ( + Make_Return_Statement (Loc, + Unchecked_Convert_To (Fat_Type, + New_Occurrence_Of (Local_Addr, Loc)))))))); + + Append_List_To (Proc_Statements, New_List ( + + -- Stub.Target := Entity_Of (Ref); + + Set_Field (Name_Target, + Make_Function_Call (Loc, + Name => + New_Occurrence_Of (RTE (RE_Entity_Of), Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of (Subp_Ref, Loc)))), + + -- Inc_Usage (Stub.Target); - Stmts := New_List; + Make_Procedure_Call_Statement (Loc, + Name => + New_Occurrence_Of (RTE (RE_Inc_Usage), Loc), + Parameter_Associations => New_List ( + Make_Selected_Component (Loc, + Prefix => New_Occurrence_Of (Stub_Ptr, Loc), + Selector_Name => Make_Identifier (Loc, Name_Target)))), - 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; + -- 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. - -------------------------------------- - -- Build_RPC_Receiver_Specification -- - -------------------------------------- + -- Parameter Asynch_P is true when the procedure is asynchronous; + -- Expression Asynch_T is true when the type is asynchronous. - 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); + Set_Field (Name_Asynchronous, + Make_Or_Else (Loc, + New_Occurrence_Of (Asynch_P, Loc), + New_Occurrence_Of (Boolean_Literals ( + Is_Asynchronous (Ras_Type)), Loc))))); - 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))), + Append_List_To (Proc_Statements, + Build_Get_Unique_RP_Call (Loc, + Stub_Ptr, Stub_Elements.Stub_Type)); - 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_To (Proc_Statements, + Make_Return_Statement (Loc, + Expression => + Unchecked_Convert_To (Fat_Type, + New_Occurrence_Of (Stub_Ptr, Loc)))); - ------------------------------------ - -- Build_Subprogram_Calling_Stubs -- - ------------------------------------ + 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)), - 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); + Make_Parameter_Specification (Loc, + Defining_Identifier => Subp_Id, + Parameter_Type => + New_Occurrence_Of (Standard_String, Loc)), + + Make_Parameter_Specification (Loc, + Defining_Identifier => Asynch_P, + Parameter_Type => + New_Occurrence_Of (Standard_Boolean, Loc)), - Target_Partition : Node_Id; - -- Contains the name of the target partition + Make_Parameter_Specification (Loc, + Defining_Identifier => All_Calls_Remote, + Parameter_Type => + New_Occurrence_Of (Standard_Boolean, Loc))), - Decls : constant List_Id := New_List; - Statements : constant List_Id := New_List; + Subtype_Mark => + New_Occurrence_Of (Fat_Type, Loc)); - Subp_Spec : Node_Id; - -- The specification of the body + -- Set the kind and return type of the function to prevent + -- ambiguities between Ras_Type and Fat_Type in subsequent analysis. - Controlling_Parameter : Entity_Id := Empty; - RPC_Receiver : Node_Id; + Set_Ekind (Proc, E_Function); + Set_Etype (Proc, Fat_Type); - Asynchronous_Expr : Node_Id := Empty; + Discard_Node ( + Make_Subprogram_Body (Loc, + Specification => Proc_Spec, + Declarations => Proc_Decls, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Proc_Statements))); - RCI_Locator : Entity_Id; + Set_TSS (Fat_Type, Proc); + end Add_RAS_Access_TSS; - Spec_To_Use : Node_Id; + ---------------------- + -- Add_RAS_From_Any -- + ---------------------- - 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)). + procedure Add_RAS_From_Any + (RAS_Type : Entity_Id; + Declarations : List_Id) + is + Loc : constant Source_Ptr := Sloc (RAS_Type); - ---------------------------- - -- Insert_Partition_Check -- - ---------------------------- + Fnam : constant Entity_Id := + Make_Defining_Identifier (Loc, New_Internal_Name ('F')); - procedure Insert_Partition_Check (Parameter : Node_Id) is - Parameter_Entity : constant Entity_Id := - Defining_Identifier (Parameter); + Func_Spec : Node_Id; + Func_Decl : Node_Id; + Func_Body : Node_Id; + + Statements : List_Id; - Condition : Node_Id; + Any_Parameter : constant Entity_Id := + Make_Defining_Identifier (Loc, Name_A); 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; + Statements := New_List ( + Make_Return_Statement (Loc, + Expression => + Make_Aggregate (Loc, + Component_Associations => New_List ( + Make_Component_Association (Loc, + Choices => New_List ( + Make_Identifier (Loc, Name_Ras)), + Expression => + PolyORB_Support.Helpers.Build_From_Any_Call ( + Underlying_RACW_Type (RAS_Type), + New_Occurrence_Of (Any_Parameter, Loc), + No_List)))))); + + Func_Spec := + Make_Function_Specification (Loc, + Defining_Unit_Name => + Fnam, + Parameter_Specifications => New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => + Any_Parameter, + Parameter_Type => + New_Occurrence_Of (RTE (RE_Any), Loc))), + Subtype_Mark => New_Occurrence_Of (RAS_Type, Loc)); - -- 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). + -- NOTE: The usage occurrences of RACW_Parameter must + -- refer to the entity in the declaration spec, not those + -- of the body spec. - 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)), + Func_Decl := Make_Subprogram_Declaration (Loc, Func_Spec); - Right_Opnd => - Make_Selected_Component (Loc, - Prefix => - New_Occurrence_Of (Controlling_Parameter, Loc), - Selector_Name => - Make_Identifier (Loc, Name_Origin))); + Func_Body := + Make_Subprogram_Body (Loc, + Specification => + Copy_Specification (Loc, Func_Spec), + Declarations => No_List, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Statements)); - 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; + Insert_After (Declaration_Node (RAS_Type), Func_Decl); + Append_To (Declarations, Func_Body); - -- Start of processing for Build_Subprogram_Calling_Stubs + Set_Renaming_TSS (RAS_Type, Fnam, Name_uFrom_Any); + end Add_RAS_From_Any; - begin - Target_Partition := - Make_Defining_Identifier (Loc, New_Internal_Name ('P')); + -------------------- + -- Add_RAS_To_Any -- + -------------------- - Subp_Spec := Copy_Specification (Loc, - Spec => Specification (Vis_Decl), - New_Name => New_Name); + procedure Add_RAS_To_Any + (RAS_Type : Entity_Id; + Declarations : List_Id) + is + Loc : constant Source_Ptr := Sloc (RAS_Type); - 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; + Fnam : Entity_Id; - -- Find a controlling argument if we have a stub type. Also check - -- if this subprogram can be made asynchronous. + Decls : List_Id; + Statements : List_Id; - if Present (Stub_Type) - and then Present (Parameter_Specifications (Spec_To_Use)) - then - declare - Current_Parameter : Node_Id := - First (Parameter_Specifications - (Spec_To_Use)); - begin - while Present (Current_Parameter) loop - if - Is_RACW_Controlling_Formal (Current_Parameter, Stub_Type) - then - if Controlling_Parameter = Empty then - Controlling_Parameter := - Defining_Identifier (Current_Parameter); - else - Insert_Partition_Check (Current_Parameter); - end if; - end if; + Func_Spec : Node_Id; + Func_Decl : Node_Id; + Func_Body : Node_Id; - Next (Current_Parameter); - end loop; - end; - end if; + Any : constant Entity_Id := + Make_Defining_Identifier (Loc, + Chars => New_Internal_Name ('A')); + RAS_Parameter : constant Entity_Id := + Make_Defining_Identifier (Loc, + Chars => New_Internal_Name ('R')); + RACW_Parameter : constant Node_Id := + Make_Selected_Component (Loc, + Prefix => + New_Occurrence_Of (RAS_Parameter, Loc), + Selector_Name => + Make_Identifier (Loc, Name_Ras)); - if Present (Stub_Type) then - pragma Assert (Present (Controlling_Parameter)); + begin + -- Object declarations - Append_To (Decls, + Set_Etype (RACW_Parameter, Underlying_RACW_Type (RAS_Type)); + Decls := New_List ( Make_Object_Declaration (Loc, - Defining_Identifier => Target_Partition, - Constant_Present => True, - Object_Definition => - New_Occurrence_Of (RTE (RE_Partition_ID), Loc), + Defining_Identifier => + Any, + Object_Definition => + New_Occurrence_Of (RTE (RE_Any), Loc), + Expression => + PolyORB_Support.Helpers.Build_To_Any_Call + (RACW_Parameter, No_List))); - Expression => - Make_Selected_Component (Loc, - Prefix => - New_Occurrence_Of (Controlling_Parameter, Loc), - Selector_Name => - Make_Identifier (Loc, Name_Origin)))); + Statements := New_List ( + Make_Procedure_Call_Statement (Loc, + Name => + New_Occurrence_Of (RTE (RE_Set_TC), Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of (Any, Loc), + PolyORB_Support.Helpers.Build_TypeCode_Call (Loc, + RAS_Type, Decls))), + Make_Return_Statement (Loc, + Expression => + New_Occurrence_Of (Any, Loc))); - RPC_Receiver := - Make_Selected_Component (Loc, - Prefix => - New_Occurrence_Of (Controlling_Parameter, Loc), - Selector_Name => - Make_Identifier (Loc, Name_Receiver)); + Fnam := Make_Defining_Identifier ( + Loc, New_Internal_Name ('T')); - 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), + Func_Spec := + Make_Function_Specification (Loc, + Defining_Unit_Name => + Fnam, + Parameter_Specifications => New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => + RAS_Parameter, + Parameter_Type => + New_Occurrence_Of (RAS_Type, Loc))), + Subtype_Mark => New_Occurrence_Of (RTE (RE_Any), Loc)); - 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))))); + -- NOTE: The usage occurrences of RAS_Parameter must + -- refer to the entity in the declaration spec, not in + -- the body spec. - 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; + Func_Decl := Make_Subprogram_Declaration (Loc, Func_Spec); - 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; + Func_Body := + Make_Subprogram_Body (Loc, + Specification => + Copy_Specification (Loc, Func_Spec), + Declarations => Decls, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Statements)); - 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); + Insert_After (Declaration_Node (RAS_Type), Func_Decl); + Append_To (Declarations, Func_Body); - RCI_Calling_Stubs_Table.Set - (Defining_Unit_Name (Specification (Vis_Decl)), - Defining_Unit_Name (Spec_To_Use)); + Set_Renaming_TSS (RAS_Type, Fnam, Name_uTo_Any); + end Add_RAS_To_Any; - 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; + ---------------------- + -- Add_RAS_TypeCode -- + ---------------------- - ------------------------- - -- Build_Subprogram_Id -- - ------------------------- + procedure Add_RAS_TypeCode + (RAS_Type : Entity_Id; + Declarations : List_Id) + is + Loc : constant Source_Ptr := Sloc (RAS_Type); - 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; + Fnam : Entity_Id; + + Func_Spec : Node_Id; + Func_Decl : Node_Id; + Func_Body : Node_Id; + + Decls : constant List_Id := New_List; + Name_String, Repo_Id_String : String_Id; + + RAS_Parameter : constant Entity_Id := + Make_Defining_Identifier (Loc, Name_R); - -------------------------------------- - -- Build_Subprogram_Receiving_Stubs -- - -------------------------------------- + begin - 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); + Fnam := + Make_Defining_Identifier (Loc, + Chars => New_Internal_Name ('T')); - Stream_Parameter : Node_Id; - Result_Parameter : Node_Id; - -- See explanations of these in Build_Subprogram_Calling_Stubs + -- The spec for this subprogram has a dummy 'access RAS' + -- argument, which serves only for overloading purposes. - Decls : constant List_Id := New_List; - -- All the parameters will get declared before calling the real - -- subprograms. Also the out parameters will be declared. + Func_Spec := + Make_Function_Specification (Loc, + Defining_Unit_Name => + Fnam, + Parameter_Specifications => New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => + RAS_Parameter, + Parameter_Type => + Make_Access_Definition (Loc, + Subtype_Mark => New_Occurrence_Of (RAS_Type, Loc)))), + Subtype_Mark => New_Occurrence_Of (RTE (RE_TypeCode), Loc)); - Statements : constant List_Id := New_List; + -- NOTE: The usage occurrences of RAS_Parameter must + -- refer to the entity in the declaration spec, not those + -- of the body spec. - Extra_Formal_Statements : constant List_Id := New_List; - -- Statements concerning extra formal parameters + Func_Decl := Make_Subprogram_Declaration (Loc, Func_Spec); - After_Statements : constant List_Id := New_List; - -- Statements to be executed after the subprogram call + PolyORB_Support.Helpers.Build_Name_And_Repository_Id + (RAS_Type, Name_Str => Name_String, Repo_Id_Str => Repo_Id_String); - Inner_Decls : List_Id := No_List; - -- In case of a function, the inner declarations are needed since - -- the result may be unconstrained. + Func_Body := + Make_Subprogram_Body (Loc, + Specification => + Copy_Specification (Loc, Func_Spec), + Declarations => Decls, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List ( + Make_Return_Statement (Loc, + Expression => + Make_Function_Call (Loc, + Name => + New_Occurrence_Of (RTE (RE_TC_Build), Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of (RTE (RE_TC_Object), Loc), + Make_Aggregate (Loc, + Expressions => + New_List ( + Make_Function_Call (Loc, + Name => New_Occurrence_Of ( + RTE (RE_TA_String), Loc), + Parameter_Associations => New_List ( + Make_String_Literal (Loc, Name_String))), + Make_Function_Call (Loc, + Name => New_Occurrence_Of ( + RTE (RE_TA_String), Loc), + Parameter_Associations => New_List ( + Make_String_Literal (Loc, + Repo_Id_String))))))))))); + + Insert_After (Declaration_Node (RAS_Type), Func_Decl); + Append_To (Declarations, Func_Body); + + Set_Renaming_TSS (RAS_Type, Fnam, Name_uTypeCode); + end Add_RAS_TypeCode; + + --------------------------------- + -- Build_General_Calling_Stubs -- + --------------------------------- + + procedure Build_General_Calling_Stubs + (Decls : List_Id; + Statements : List_Id; + Target_Object : Node_Id; + Subprogram_Id : Node_Id; + Asynchronous : Node_Id := Empty; + Is_Known_Asynchronous : Boolean := False; + Is_Known_Non_Asynchronous : Boolean := False; + Is_Function : Boolean; + Spec : Node_Id; + Stub_Type : Entity_Id := Empty; + RACW_Type : Entity_Id := Empty; + Nod : Node_Id) + is + Loc : constant Source_Ptr := Sloc (Nod); - Excep_Handlers : List_Id := No_List; - Excep_Choice : Entity_Id; - Excep_Code : List_Id; + Arguments : Node_Id; + -- Name of the named values list used to transmit parameters + -- to the remote package - Parameter_List : constant List_Id := New_List; - -- List of parameters to be passed to the subprogram + Request : Node_Id; + -- The request object constructed by these stubs. - Current_Parameter : Node_Id; + Result : Node_Id; + -- Name of the result named value (in non-APC cases) which get the + -- result of the remote subprogram. - Ordered_Parameters_List : constant List_Id := - Build_Ordered_Parameters_List - (Specification (Vis_Decl)); + Result_TC : Node_Id; + -- Typecode expression for the result of the request (void + -- typecode for procedures). - Subp_Spec : Node_Id; - -- Subprogram specification + Exception_Return_Parameter : Node_Id; + -- Name of the parameter which will hold the exception sent by the + -- remote subprogram. - Called_Subprogram : Node_Id; - -- The subprogram to call + Current_Parameter : Node_Id; + -- Current parameter being handled - Null_Raise_Statement : Node_Id; + Ordered_Parameters_List : constant List_Id := + Build_Ordered_Parameters_List (Spec); - Dynamic_Async : Entity_Id; + Asynchronous_P : Node_Id; + -- A Boolean expression indicating whether this call is asynchronous - begin - if Present (RACW_Type) then - Called_Subprogram := - New_Occurrence_Of (Parent_Primitive, Loc); - else - Called_Subprogram := - New_Occurrence_Of ( - Defining_Unit_Name (Specification (Vis_Decl)), Loc); - end if; + Asynchronous_Statements : List_Id := No_List; + Non_Asynchronous_Statements : List_Id := No_List; + -- Statements specifics to the Asynchronous/Non-Asynchronous cases - Stream_Parameter := - Make_Defining_Identifier (Loc, New_Internal_Name ('S')); + 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. - if Dynamically_Asynchronous then - Dynamic_Async := - Make_Defining_Identifier (Loc, New_Internal_Name ('S')); - else - Dynamic_Async := Empty; - end if; + After_Statements : constant List_Id := New_List; + -- Statements to be executed after call returns (to assign + -- in out or out parameter values). - if not Asynchronous or else Dynamically_Asynchronous then - Result_Parameter := - Make_Defining_Identifier (Loc, New_Internal_Name ('S')); + Etyp : Entity_Id; + -- The type of the formal parameter being processed. - -- The first statement after the subprogram call is a statement to - -- writes a Null_Occurrence into the result stream. + Is_Controlling_Formal : Boolean; + Is_First_Controlling_Formal : Boolean; + First_Controlling_Formal_Seen : Boolean := False; + -- Controlling formal parameters of distributed object + -- primitives require special handling, and the first + -- such parameter needs even more. - 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))); + begin + -- ??? document general form of stub subprograms for the PolyORB case + Request := + Make_Defining_Identifier (Loc, New_Internal_Name ('R')); - 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)); + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Request, + Aliased_Present => False, + Object_Definition => + New_Occurrence_Of (RTE (RE_Request_Access), Loc))); + + Result := + Make_Defining_Identifier (Loc, New_Internal_Name ('R')); + + if Is_Function then + Result_TC := PolyORB_Support.Helpers.Build_TypeCode_Call (Loc, + Etype (Subtype_Mark (Spec)), Decls); + else + Result_TC := New_Occurrence_Of (RTE (RE_TC_Void), Loc); end if; - Append_To (After_Statements, Null_Raise_Statement); + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Result, + Aliased_Present => False, + Object_Definition => + New_Occurrence_Of (RTE (RE_NamedValue), Loc), + Expression => + Make_Aggregate (Loc, + Component_Associations => New_List ( + Make_Component_Association (Loc, + Choices => New_List ( + Make_Identifier (Loc, Name_Name)), + Expression => + New_Occurrence_Of (RTE (RE_Result_Name), Loc)), + Make_Component_Association (Loc, + Choices => New_List ( + Make_Identifier (Loc, Name_Argument)), + Expression => + Make_Function_Call (Loc, + Name => + New_Occurrence_Of (RTE (RE_Create_Any), Loc), + Parameter_Associations => New_List ( + Result_TC))), + Make_Component_Association (Loc, + Choices => New_List ( + Make_Identifier (Loc, Name_Arg_Modes)), + Expression => + Make_Integer_Literal (Loc, 0)))))); + + if not Is_Known_Asynchronous then + Exception_Return_Parameter := + Make_Defining_Identifier (Loc, New_Internal_Name ('E')); - else - Result_Parameter := Empty; - end if; + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Exception_Return_Parameter, + Object_Definition => + New_Occurrence_Of (RTE (RE_Exception_Occurrence), 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. + else + Exception_Return_Parameter := Empty; + end if; - 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; + -- Initialize and fill in arguments list - begin - Object := Make_Defining_Identifier (Loc, New_Internal_Name ('P')); - Set_Ekind (Object, E_Variable); + Arguments := + Make_Defining_Identifier (Loc, New_Internal_Name ('A')); + Declare_Create_NVList (Loc, Arguments, Decls, Statements); - RACW_Controlling := - Is_RACW_Controlling_Formal (Current_Parameter, Stub_Type); + Current_Parameter := First (Ordered_Parameters_List); + while Present (Current_Parameter) loop - if RACW_Controlling then + if Is_RACW_Controlling_Formal (Current_Parameter, Stub_Type) then + Is_Controlling_Formal := True; + Is_First_Controlling_Formal := + not First_Controlling_Formal_Seen; + First_Controlling_Formal_Seen := True; + else + Is_Controlling_Formal := False; + Is_First_Controlling_Formal := False; + end if; - -- We have a controlling formal parameter. Read its address - -- rather than a real object. The address is in Unsigned_64 - -- form. + if Is_Controlling_Formal then + + -- In the case of a controlling formal argument, we send + -- its reference. + + Etyp := RACW_Type; - Etyp := RTE (RE_Unsigned_64); else Etyp := Etype (Parameter_Type (Current_Parameter)); end if; - Constrained := - Is_Constrained (Etyp) or else Is_Elementary_Type (Etyp); + -- The first controlling formal parameter is treated + -- specially: it is used to set the target object of + -- the call. - 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 not Is_First_Controlling_Formal then - 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)))); + declare + Constrained : constant Boolean := + Is_Constrained (Etyp) + or else Is_Elementary_Type (Etyp); - 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; + Any : constant Entity_Id := + Make_Defining_Identifier (Loc, + New_Internal_Name ('A')); - -- 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. + Actual_Parameter : Node_Id := + New_Occurrence_Of ( + Defining_Identifier ( + Current_Parameter), Loc); - 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)); + Expr : Node_Id; - -- 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. + begin + if Is_Controlling_Formal then + + -- For a controlling formal parameter (other + -- than the first one), use the corresponding + -- RACW. If the parameter is not an anonymous + -- access parameter, that involves taking + -- its 'Unrestricted_Access. + + if Nkind (Parameter_Type (Current_Parameter)) + = N_Access_Definition + then + Actual_Parameter := OK_Convert_To + (Etyp, Actual_Parameter); + else + Actual_Parameter := OK_Convert_To (Etyp, + Make_Attribute_Reference (Loc, + Prefix => + Actual_Parameter, + Attribute_Name => + Name_Unrestricted_Access)); + end if; - 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; + end if; - if - Is_RACW_Controlling_Formal (Current_Parameter, Stub_Type) - then - if Nkind (Parameter_Type (Current_Parameter)) /= - N_Access_Definition - then - Append_To (Parameter_List, - Make_Parameter_Association (Loc, - Selector_Name => - New_Occurrence_Of ( - Defining_Identifier (Current_Parameter), Loc), - Explicit_Actual_Parameter => - Make_Explicit_Dereference (Loc, - Unchecked_Convert_To (RACW_Type, - OK_Convert_To (RTE (RE_Address), - New_Occurrence_Of (Object, Loc)))))); + if In_Present (Current_Parameter) + or else not Out_Present (Current_Parameter) + or else not Constrained + or else Is_Controlling_Formal + then + -- The parameter has an input value, is constrained + -- at runtime by an input value, or is a controlling + -- formal parameter (always passed as a reference) + -- other than the first one. - 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; + Expr := PolyORB_Support.Helpers.Build_To_Any_Call ( + Actual_Parameter, Decls); + else + Expr := Make_Function_Call (Loc, + Name => + New_Occurrence_Of (RTE (RE_Create_Any), Loc), + Parameter_Associations => New_List ( + PolyORB_Support.Helpers.Build_TypeCode_Call (Loc, + Etyp, Decls))); + end if; - 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; + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => + Any, + Aliased_Present => False, + Object_Definition => + New_Occurrence_Of (RTE (RE_Any), Loc), + Expression => + Expr)); - -- 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. + Append_To (Statements, + Add_Parameter_To_NVList (Loc, + Parameter => Current_Parameter, + NVList => Arguments, + Constrained => Constrained, + Any => Any)); + + if Out_Present (Current_Parameter) + and then not Is_Controlling_Formal + then + Append_To (After_Statements, + Make_Assignment_Statement (Loc, + Name => + New_Occurrence_Of ( + Defining_Identifier (Current_Parameter), Loc), + Expression => + PolyORB_Support.Helpers.Build_From_Any_Call ( + Etype (Parameter_Type (Current_Parameter)), + New_Occurrence_Of (Any, Loc), + Decls))); + + end if; + end; + end if; - -- The case of Extra_Accessibility should also be handled ??? + -- 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 (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))) + if Nkind (Parameter_Type (Current_Parameter)) + /= N_Access_Definition + and then Need_Extra_Constrained (Current_Parameter) then - declare - Extra_Parameter : constant Entity_Id := - Extra_Constrained - (Defining_Identifier - (Current_Parameter)); - - Formal_Entity : constant Entity_Id := - Make_Defining_Identifier - (Loc, Chars (Extra_Parameter)); + -- 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. - Formal_Type : constant Entity_Id := - Etype (Extra_Parameter); + declare + Extra_Any_Parameter : constant Entity_Id := + Make_Defining_Identifier + (Loc, New_Internal_Name ('P')); begin Append_To (Decls, Make_Object_Declaration (Loc, - Defining_Identifier => Formal_Entity, + Defining_Identifier => + Extra_Any_Parameter, + Aliased_Present => False, Object_Definition => - New_Occurrence_Of (Formal_Type, Loc))); - + New_Occurrence_Of (RTE (RE_Any), Loc), + Expression => + PolyORB_Support.Helpers.Build_To_Any_Call ( + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of ( + Defining_Identifier (Current_Parameter), Loc), + Attribute_Name => Name_Constrained), + Decls))); Append_To (Extra_Formal_Statements, - 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); + Add_Parameter_To_NVList (Loc, + Parameter => Extra_Any_Parameter, + NVList => Arguments, + Constrained => True, + Any => Extra_Any_Parameter)); end; end if; - end; - Next (Current_Parameter); - end loop; + Next (Current_Parameter); + end loop; - -- Append the formal statements list at the end of regular statements + -- Append the formal statements list to the statements - Append_List_To (Statements, Extra_Formal_Statements); + Append_List_To (Statements, Extra_Formal_Statements); - if Nkind (Specification (Vis_Decl)) = N_Function_Specification then + Append_To (Statements, + Make_Procedure_Call_Statement (Loc, + Name => + New_Occurrence_Of (RTE (RE_Request_Create), Loc), + Parameter_Associations => New_List ( + Target_Object, + Subprogram_Id, + New_Occurrence_Of (Arguments, Loc), + New_Occurrence_Of (Result, Loc), + New_Occurrence_Of (RTE (RE_Nil_Exc_List), Loc)))); + + Append_To (Parameter_Associations (Last (Statements)), + New_Occurrence_Of (Request, Loc)); + + pragma Assert ( + not (Is_Known_Non_Asynchronous and Is_Known_Asynchronous)); + if Is_Known_Non_Asynchronous or Is_Known_Asynchronous then + Asynchronous_P := New_Occurrence_Of ( + Boolean_Literals (Is_Known_Asynchronous), Loc); + else + pragma Assert (Present (Asynchronous)); + Asynchronous_P := New_Copy_Tree (Asynchronous); + -- The expression node Asynchronous will be used to build + -- an 'if' statement at the end of Build_General_Calling_Stubs: + -- we need to make a copy here. + end if; - -- The remote subprogram is a function. We build an inner block to - -- be able to hold a potentially unconstrained result in a variable. + Append_To (Parameter_Associations (Last (Statements)), + Make_Indexed_Component (Loc, + Prefix => + New_Occurrence_Of ( + RTE (RE_Asynchronous_P_To_Sync_Scope), Loc), + Expressions => New_List (Asynchronous_P))); - declare - Etyp : constant Entity_Id := - Etype (Subtype_Mark (Specification (Vis_Decl))); - Result : constant Node_Id := - Make_Defining_Identifier (Loc, New_Internal_Name ('R')); + Append_To (Statements, + Make_Procedure_Call_Statement (Loc, + Name => + New_Occurrence_Of (RTE (RE_Request_Invoke), Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of (Request, Loc)))); - begin - Inner_Decls := New_List ( - Make_Object_Declaration (Loc, - Defining_Identifier => Result, - Constant_Present => True, - Object_Definition => New_Occurrence_Of (Etyp, Loc), - Expression => - Make_Function_Call (Loc, - Name => Called_Subprogram, - Parameter_Associations => Parameter_List))); + Non_Asynchronous_Statements := New_List (Make_Null_Statement (Loc)); + Asynchronous_Statements := New_List (Make_Null_Statement (Loc)); - 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; + if not Is_Known_Asynchronous then - Append_To (Statements, - Make_Block_Statement (Loc, - Declarations => Inner_Decls, - Handled_Statement_Sequence => - Make_Handled_Sequence_Of_Statements (Loc, - Statements => After_Statements))); + -- Reraise an exception occurrence from the completed request. + -- If the exception occurrence is empty, this is a no-op. - else - -- The remote subprogram is a procedure. We do not need any inner - -- block in this case. + Append_To (Non_Asynchronous_Statements, + Make_Procedure_Call_Statement (Loc, + Name => + New_Occurrence_Of (RTE (RE_Request_Raise_Occurrence), Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of (Request, Loc)))); + + if Is_Function then + + -- If this is a function call, then read the value and + -- return it. + + Append_To (Non_Asynchronous_Statements, + Make_Tag_Check (Loc, + Make_Return_Statement (Loc, + PolyORB_Support.Helpers.Build_From_Any_Call ( + Etype (Subtype_Mark (Spec)), + Make_Selected_Component (Loc, + Prefix => + New_Occurrence_Of (Result, Loc), + Selector_Name => + Make_Identifier (Loc, Name_Argument)), + Decls)))); + end if; + end if; - if Dynamically_Asynchronous then - Append_To (Decls, - Make_Object_Declaration (Loc, - Defining_Identifier => Dynamic_Async, - Object_Definition => - New_Occurrence_Of (Standard_Boolean, Loc))); + Append_List_To (Non_Asynchronous_Statements, + After_Statements); - 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; + if Is_Known_Asynchronous then + Append_List_To (Statements, Asynchronous_Statements); - Append_To (Statements, - Make_Procedure_Call_Statement (Loc, - Name => Called_Subprogram, - Parameter_Associations => Parameter_List)); + elsif Is_Known_Non_Asynchronous then + Append_List_To (Statements, Non_Asynchronous_Statements); - Append_List_To (Statements, After_Statements); - end if; + else + pragma Assert (Present (Asynchronous)); + Append_To (Statements, + Make_Implicit_If_Statement (Nod, + Condition => Asynchronous, + Then_Statements => Asynchronous_Statements, + Else_Statements => Non_Asynchronous_Statements)); + end if; + end Build_General_Calling_Stubs; - if Asynchronous and then not Dynamically_Asynchronous then + ----------------------- + -- Build_Stub_Target -- + ----------------------- - -- An asynchronous procedure does not want a Result parameter. Also - -- put an exception handler with an others clause that does nothing. + function Build_Stub_Target + (Loc : Source_Ptr; + Decls : List_Id; + RCI_Locator : Entity_Id; + Controlling_Parameter : Entity_Id) return RPC_Target + is + Target_Info : RPC_Target (PCS_Kind => Name_PolyORB_DSA); + Target_Reference : constant Entity_Id := + Make_Defining_Identifier (Loc, + New_Internal_Name ('T')); + begin + if Present (Controlling_Parameter) then + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Target_Reference, + Object_Definition => + New_Occurrence_Of (RTE (RE_Object_Ref), Loc), + Expression => + Make_Function_Call (Loc, + Name => + New_Occurrence_Of (RTE (RE_Make_Ref), Loc), + Parameter_Associations => New_List ( + Make_Selected_Component (Loc, + Prefix => + New_Occurrence_Of (Controlling_Parameter, Loc), + Selector_Name => + Make_Identifier (Loc, Name_Target)))))); + -- Controlling_Parameter has the same components + -- as System.Partition_Interface.RACW_Stub_Type. - 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))))); + Target_Info.Object := New_Occurrence_Of (Target_Reference, Loc); - Excep_Handlers := New_List ( - Make_Exception_Handler (Loc, - Exception_Choices => - New_List (Make_Others_Choice (Loc)), - Statements => New_List ( - Make_Null_Statement (Loc)))); + else + Target_Info.Object := + Make_Selected_Component (Loc, + Prefix => + Make_Identifier (Loc, Chars (RCI_Locator)), + Selector_Name => + Make_Identifier (Loc, Name_Get_RCI_Package_Ref)); + end if; + return Target_Info; + end Build_Stub_Target; - 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. + --------------------- + -- Build_Stub_Type -- + --------------------- - Excep_Choice := - Make_Defining_Identifier (Loc, New_Internal_Name ('E')); + procedure Build_Stub_Type + (RACW_Type : Entity_Id; + Stub_Type : Entity_Id; + Stub_Type_Decl : out Node_Id; + RPC_Receiver_Decl : out Node_Id) + is + Loc : constant Source_Ptr := Sloc (Stub_Type); + pragma Warnings (Off); + pragma Unreferenced (RACW_Type); + pragma Warnings (On); - 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)))); + begin + Stub_Type_Decl := + Make_Full_Type_Declaration (Loc, + Defining_Identifier => Stub_Type, + Type_Definition => + Make_Record_Definition (Loc, + Tagged_Present => True, + Limited_Present => True, + Component_List => + Make_Component_List (Loc, + Component_Items => New_List ( + + Make_Component_Declaration (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_Target), + Component_Definition => + Make_Component_Definition (Loc, + Aliased_Present => + False, + Subtype_Indication => + New_Occurrence_Of (RTE (RE_Entity_Ptr), Loc))), + + Make_Component_Declaration (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Name_Asynchronous), + Component_Definition => + Make_Component_Definition (Loc, + Aliased_Present => False, + Subtype_Indication => + New_Occurrence_Of ( + Standard_Boolean, Loc))))))); + + RPC_Receiver_Decl := + Make_Object_Declaration (Loc, + Defining_Identifier => Make_Defining_Identifier (Loc, + New_Internal_Name ('R')), + Aliased_Present => True, + Object_Definition => + New_Occurrence_Of (RTE (RE_Servant), Loc)); + end Build_Stub_Type; - 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_RPC_Receiver_Specification -- + -------------------------------------- - Excep_Handlers := New_List ( - Make_Exception_Handler (Loc, - Choice_Parameter => Excep_Choice, - Exception_Choices => New_List (Make_Others_Choice (Loc)), - Statements => Excep_Code)); + function Build_RPC_Receiver_Specification + (RPC_Receiver : Entity_Id; + Request_Parameter : Entity_Id) return Node_Id + is + Loc : constant Source_Ptr := Sloc (RPC_Receiver); - Subp_Spec := + begin + return Make_Procedure_Specification (Loc, - Defining_Unit_Name => - Make_Defining_Identifier (Loc, New_Internal_Name ('F')), - + 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))), - - Make_Parameter_Specification (Loc, - Defining_Identifier => Result_Parameter, + Defining_Identifier => Request_Parameter, Parameter_Type => - Make_Access_Definition (Loc, - Subtype_Mark => - New_Occurrence_Of (RTE (RE_Params_Stream_Type), Loc))))); - end if; - - return - Make_Subprogram_Body (Loc, - Specification => Subp_Spec, - Declarations => Decls, - Handled_Statement_Sequence => - Make_Handled_Sequence_Of_Statements (Loc, - Statements => Statements, - Exception_Handlers => Excep_Handlers)); - end Build_Subprogram_Receiving_Stubs; - - ------------------------ - -- Copy_Specification -- - ------------------------ - - function Copy_Specification - (Loc : Source_Ptr; - Spec : Node_Id; - Object_Type : Entity_Id := Empty; - Stub_Type : Entity_Id := Empty; - New_Name : Name_Id := No_Name) return Node_Id - is - Parameters : List_Id := No_List; + New_Occurrence_Of ( + RTE (RE_Request_Access), Loc)))); + end Build_RPC_Receiver_Specification; + + ------------- + -- Helpers -- + ------------- + + package body Helpers is + + ----------------------- + -- Local Subprograms -- + ----------------------- + + function Find_Inherited_TSS + (Typ : Entity_Id; + Nam : Name_Id) return Entity_Id; + -- A TSS reference for a representation aspect of a derived tagged + -- type must take into account inheritance of that aspect from + -- ancestor types. (copied from exp_attr.adb, should be shared???) + + function Find_Numeric_Representation + (Typ : Entity_Id) return Entity_Id; + -- Given a numeric type Typ, return the smallest integer or floarting + -- point type from Standard, or the smallest unsigned (modular) type + -- from System.Unsigned_Types, whose range encompasses that of Typ. + + function Make_Stream_Procedure_Function_Name + (Loc : Source_Ptr; + Typ : Entity_Id; + Nam : Name_Id) return Entity_Id; + -- Return the name to be assigned for stream subprogram Nam of Typ. + -- (copied from exp_strm.adb, should be shared???) + + ------------------------------------------------------------ + -- Common subprograms for building various tree fragments -- + ------------------------------------------------------------ + + function Build_Get_Aggregate_Element + (Loc : Source_Ptr; + Any : Entity_Id; + TC : Node_Id; + Idx : Node_Id) return Node_Id; + -- Build a call to Get_Aggregate_Element on Any + -- for typecode TC, returning the Idx'th element. + + generic + Subprogram : Entity_Id; + -- Reference location for constructed nodes + + Arry : Entity_Id; + -- For 'Range and Etype + + Indices : List_Id; + -- For the construction of the innermost element expression + + with procedure Add_Process_Element + (Stmts : List_Id; + Any : Entity_Id; + Counter : Entity_Id; + Datum : Node_Id); + + procedure Append_Array_Traversal + (Stmts : List_Id; + Any : Entity_Id; + Counter : Entity_Id := Empty; + Depth : Pos := 1); + -- Build nested loop statements that iterate over the elements of an + -- array Arry. The statement(s) built by Add_Process_Element are + -- executed for each element; Indices is the list of indices to be + -- used in the construction of the indexed component that denotes the + -- current element. Subprogram is the entity for the subprogram for + -- which this iterator is generated. The generated statements are + -- appended to Stmts. + + generic + Rec : Entity_Id; + -- The record entity being dealt with + + with procedure Add_Process_Element + (Stmts : List_Id; + Container : Node_Or_Entity_Id; + Counter : in out Int; + Rec : Entity_Id; + Field : Node_Id); + -- Rec is the instance of the record type, or Empty. + -- Field is either the N_Defining_Identifier for a component, + -- or an N_Variant_Part. + + procedure Append_Record_Traversal + (Stmts : List_Id; + Clist : Node_Id; + Container : Node_Or_Entity_Id; + Counter : in out Int); + -- Process component list Clist. Individual fields are passed + -- to Field_Processing. Each variant part is also processed. + -- Container is the outer Any (for From_Any/To_Any), + -- the outer typecode (for TC) to which the operation applies. + + ----------------------------- + -- Append_Record_Traversal -- + ----------------------------- + + procedure Append_Record_Traversal + (Stmts : List_Id; + Clist : Node_Id; + Container : Node_Or_Entity_Id; + Counter : in out Int) + is + CI : constant List_Id := Component_Items (Clist); + VP : constant Node_Id := Variant_Part (Clist); - Current_Parameter : Node_Id; - Current_Identifier : Entity_Id; - Current_Type : Node_Id; - Current_Etype : Entity_Id; + Item : Node_Id := First (CI); + Def : Entity_Id; - Name_For_New_Spec : Name_Id; + begin + while Present (Item) loop + Def := Defining_Identifier (Item); + if not Is_Internal_Name (Chars (Def)) then + Add_Process_Element + (Stmts, Container, Counter, Rec, Def); + end if; + Next (Item); + end loop; - New_Identifier : Entity_Id; + if Present (VP) then + Add_Process_Element (Stmts, Container, Counter, Rec, VP); + end if; + end Append_Record_Traversal; - -- Comments needed in body below ??? + ------------------------- + -- Build_From_Any_Call -- + ------------------------- - begin - if New_Name = No_Name then - pragma Assert (Nkind (Spec) = N_Function_Specification - or else Nkind (Spec) = N_Procedure_Specification); + function Build_From_Any_Call + (Typ : Entity_Id; + N : Node_Id; + Decls : List_Id) return Node_Id + is + Loc : constant Source_Ptr := Sloc (N); - Name_For_New_Spec := Chars (Defining_Unit_Name (Spec)); - else - Name_For_New_Spec := New_Name; - end if; + U_Type : Entity_Id := Underlying_Type (Typ); - 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); + Fnam : Entity_Id := Empty; + Lib_RE : RE_Id := RE_Null; - if Nkind (Current_Type) = N_Access_Definition then - Current_Etype := Entity (Subtype_Mark (Current_Type)); + begin - 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; + -- First simple case where the From_Any function is present + -- in the type's TSS. - else - Current_Etype := Entity (Current_Type); + Fnam := Find_Inherited_TSS (U_Type, Name_uFrom_Any); - 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; + if Sloc (U_Type) <= Standard_Location then + U_Type := Base_Type (U_Type); end if; - New_Identifier := Make_Defining_Identifier (Loc, - Chars (Current_Identifier)); + -- Check first for Boolean and Character. These are enumeration + -- types, but we treat them specially, since they may require + -- special handling in the transfer protocol. However, this + -- special handling only applies if they have standard + -- representation, otherwise they are treated like any other + -- enumeration type. - 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 Present (Fnam) then + null; - Next (Current_Parameter); - end loop; - end if; + elsif U_Type = Standard_Boolean then + Lib_RE := RE_FA_B; - case Nkind (Spec) is + elsif U_Type = Standard_Character then + Lib_RE := RE_FA_C; - 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)); + elsif U_Type = Standard_Wide_Character then + Lib_RE := RE_FA_WC; - 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); + -- Floating point types - when others => - raise Program_Error; - end case; - end Copy_Specification; + elsif U_Type = Standard_Short_Float then + Lib_RE := RE_FA_SF; - --------------------------- - -- Could_Be_Asynchronous -- - --------------------------- + elsif U_Type = Standard_Float then + Lib_RE := RE_FA_F; - function Could_Be_Asynchronous (Spec : Node_Id) return Boolean is - Current_Parameter : Node_Id; + elsif U_Type = Standard_Long_Float then + Lib_RE := RE_FA_LF; - 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; + elsif U_Type = Standard_Long_Long_Float then + Lib_RE := RE_FA_LLF; - Next (Current_Parameter); - end loop; - end if; + -- Integer types - return True; - end Could_Be_Asynchronous; + elsif U_Type = Etype (Standard_Short_Short_Integer) then + Lib_RE := RE_FA_SSI; - --------------------------------------------- - -- Expand_All_Calls_Remote_Subprogram_Call -- - --------------------------------------------- + elsif U_Type = Etype (Standard_Short_Integer) then + Lib_RE := RE_FA_SI; - 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; + elsif U_Type = Etype (Standard_Integer) then + Lib_RE := RE_FA_I; - begin - E_Calling_Stubs := RCI_Calling_Stubs_Table.Get (Called_Subprogram); + elsif U_Type = Etype (Standard_Long_Integer) then + Lib_RE := RE_FA_LI; - if E_Calling_Stubs = Empty then - RCI_Cache := RCI_Locator_Table.Get (RCI_Package); + elsif U_Type = Etype (Standard_Long_Long_Integer) then + Lib_RE := RE_FA_LLI; - 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); + -- Unsigned integer types - -- 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. + elsif U_Type = RTE (RE_Short_Short_Unsigned) then + Lib_RE := RE_FA_SSU; - declare - Scop : constant Entity_Id := Cunit_Entity (Current_Sem_Unit); + elsif U_Type = RTE (RE_Short_Unsigned) then + Lib_RE := RE_FA_SU; - begin - if Ekind (Scop) = E_Package_Body then - New_Scope (Spec_Entity (Scop)); + elsif U_Type = RTE (RE_Unsigned) then + Lib_RE := RE_FA_U; - elsif Ekind (Scop) = E_Subprogram_Body then - New_Scope - (Corresponding_Spec (Unit_Declaration_Node (Scop))); + elsif U_Type = RTE (RE_Long_Unsigned) then + Lib_RE := RE_FA_LU; - else - New_Scope (Scop); - end if; + elsif U_Type = RTE (RE_Long_Long_Unsigned) then + Lib_RE := RE_FA_LLU; - Analyze (RCI_Locator); - Pop_Scope; - end; + elsif U_Type = Standard_String then + Lib_RE := RE_FA_String; - RCI_Cache := Defining_Unit_Name (RCI_Locator); + -- Other (non-primitive) types - else - RCI_Locator := Parent (RCI_Cache); - end if; + else + declare + Decl : Entity_Id; + begin + Build_From_Any_Function (Loc, U_Type, Decl, Fnam); + Append_To (Decls, Decl); + end; + end if; - Calling_Stubs := Build_Subprogram_Calling_Stubs - (Vis_Decl => Parent (Parent (Called_Subprogram)), - Subp_Id => - Build_Subprogram_Id (Loc, Called_Subprogram), - Asynchronous => Nkind (N) = N_Procedure_Call_Statement - and then - Is_Asynchronous (Called_Subprogram), - Locator => RCI_Cache, - New_Name => New_Internal_Name ('S')); - Insert_After (RCI_Locator, Calling_Stubs); - Analyze (Calling_Stubs); - E_Calling_Stubs := Defining_Unit_Name (Specification (Calling_Stubs)); - end if; + -- Call the function - Rewrite (Name (N), New_Occurrence_Of (E_Calling_Stubs, Loc)); - end Expand_All_Calls_Remote_Subprogram_Call; + if Lib_RE /= RE_Null then + pragma Assert (No (Fnam)); + Fnam := RTE (Lib_RE); + end if; - --------------------------------- - -- Expand_Calling_Stubs_Bodies -- - --------------------------------- + return + Make_Function_Call (Loc, + Name => New_Occurrence_Of (Fnam, Loc), + Parameter_Associations => New_List (N)); + end Build_From_Any_Call; + + ----------------------------- + -- Build_From_Any_Function -- + ----------------------------- + + procedure Build_From_Any_Function + (Loc : Source_Ptr; + Typ : Entity_Id; + Decl : out Node_Id; + Fnam : out Entity_Id) + is + Spec : Node_Id; + Decls : constant List_Id := New_List; + Stms : constant List_Id := New_List; + Any_Parameter : constant Entity_Id + := Make_Defining_Identifier (Loc, New_Internal_Name ('A')); + begin + Fnam := Make_Stream_Procedure_Function_Name (Loc, + Typ, Name_uFrom_Any); - procedure Expand_Calling_Stubs_Bodies (Unit_Node : Node_Id) is - Spec : constant Node_Id := Specification (Unit_Node); - Decls : constant List_Id := Visible_Declarations (Spec); + Spec := + Make_Function_Specification (Loc, + Defining_Unit_Name => Fnam, + Parameter_Specifications => New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => + Any_Parameter, + Parameter_Type => + New_Occurrence_Of (RTE (RE_Any), Loc))), + Subtype_Mark => New_Occurrence_Of (Typ, Loc)); - begin - New_Scope (Scope_Of_Spec (Spec)); - Add_Calling_Stubs_To_Declarations - (Specification (Unit_Node), Decls); - Pop_Scope; - end Expand_Calling_Stubs_Bodies; + -- The following is taken care of by Exp_Dist.Add_RACW_From_Any - ----------------------------------- - -- Expand_Receiving_Stubs_Bodies -- - ----------------------------------- + pragma Assert + (not (Is_Remote_Access_To_Class_Wide_Type (Typ))); - procedure Expand_Receiving_Stubs_Bodies (Unit_Node : Node_Id) is - Spec : Node_Id; - Decls : List_Id; - Temp : List_Id; - begin - if Nkind (Unit_Node) = N_Package_Declaration then - Spec := Specification (Unit_Node); - Decls := Visible_Declarations (Spec); - New_Scope (Scope_Of_Spec (Spec)); - Add_Receiving_Stubs_To_Declarations (Spec, Decls); + if Is_Derived_Type (Typ) + and then not Is_Tagged_Type (Typ) + then + Append_To (Stms, + Make_Return_Statement (Loc, + Expression => + OK_Convert_To ( + Typ, + Build_From_Any_Call ( + Root_Type (Typ), + New_Occurrence_Of (Any_Parameter, Loc), + Decls)))); + + elsif Is_Record_Type (Typ) + and then not Is_Derived_Type (Typ) + and then not Is_Tagged_Type (Typ) + then + if Nkind (Declaration_Node (Typ)) = N_Subtype_Declaration then + Append_To (Stms, + Make_Return_Statement (Loc, + Expression => + OK_Convert_To ( + Typ, + Build_From_Any_Call ( + Etype (Typ), + New_Occurrence_Of (Any_Parameter, Loc), + Decls)))); + else + declare + Disc : Entity_Id := Empty; + Discriminant_Associations : List_Id; + Rdef : constant Node_Id := + Type_Definition (Declaration_Node (Typ)); + Component_Counter : Int := 0; + + -- The returned object + + Res : constant Entity_Id := + Make_Defining_Identifier (Loc, + New_Internal_Name ('R')); + + Res_Definition : Node_Id := New_Occurrence_Of (Typ, Loc); + + procedure FA_Rec_Add_Process_Element + (Stmts : List_Id; + Any : Entity_Id; + Counter : in out Int; + Rec : Entity_Id; + Field : Node_Id); + + procedure FA_Append_Record_Traversal is + new Append_Record_Traversal + (Rec => Res, + Add_Process_Element => FA_Rec_Add_Process_Element); + + -------------------------------- + -- FA_Rec_Add_Process_Element -- + -------------------------------- + + procedure FA_Rec_Add_Process_Element + (Stmts : List_Id; + Any : Entity_Id; + Counter : in out Int; + Rec : Entity_Id; + Field : Node_Id) + is + begin + if Nkind (Field) = N_Defining_Identifier then + + -- A regular component + + Append_To (Stmts, + Make_Assignment_Statement (Loc, + Name => Make_Selected_Component (Loc, + Prefix => + New_Occurrence_Of (Rec, Loc), + Selector_Name => + New_Occurrence_Of (Field, Loc)), + Expression => + Build_From_Any_Call (Etype (Field), + Build_Get_Aggregate_Element (Loc, + Any => Any, + Tc => Build_TypeCode_Call (Loc, + Etype (Field), Decls), + Idx => Make_Integer_Literal (Loc, + Counter)), + Decls))); + + else + -- A variant part + + declare + Variant : Node_Id; + Struct_Counter : Int := 0; + + Block_Decls : constant List_Id := New_List; + Block_Stmts : constant List_Id := New_List; + VP_Stmts : List_Id; + + Alt_List : constant List_Id := New_List; + Choice_List : List_Id; + + Struct_Any : constant Entity_Id := + Make_Defining_Identifier (Loc, + New_Internal_Name ('S')); + + begin + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => + Struct_Any, + Constant_Present => + True, + Object_Definition => + New_Occurrence_Of (RTE (RE_Any), Loc), + Expression => + Make_Function_Call (Loc, + Name => New_Occurrence_Of ( + RTE (RE_Extract_Union_Value), Loc), + Parameter_Associations => New_List ( + Build_Get_Aggregate_Element (Loc, + Any => Any, + Tc => Make_Function_Call (Loc, + Name => New_Occurrence_Of ( + RTE (RE_Any_Member_Type), Loc), + Parameter_Associations => + New_List ( + New_Occurrence_Of (Any, Loc), + Make_Integer_Literal (Loc, + Counter))), + Idx => Make_Integer_Literal (Loc, + Counter)))))); + + Append_To (Stmts, + Make_Block_Statement (Loc, + Declarations => + Block_Decls, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Block_Stmts))); + + Append_To (Block_Stmts, + Make_Case_Statement (Loc, + Expression => + Make_Selected_Component (Loc, + Prefix => + New_Occurrence_Of (Rec, Loc), + Selector_Name => + New_Occurrence_Of ( + Entity (Name (Field)), Loc)), + Alternatives => + Alt_List)); + + Variant := First_Non_Pragma (Variants (Field)); + + while Present (Variant) loop + Choice_List := New_Copy_List_Tree + (Discrete_Choices (Variant)); + + VP_Stmts := New_List; + FA_Append_Record_Traversal ( + Stmts => VP_Stmts, + Clist => Component_List (Variant), + Container => Struct_Any, + Counter => Struct_Counter); + + Append_To (Alt_List, + Make_Case_Statement_Alternative (Loc, + Discrete_Choices => Choice_List, + Statements => + VP_Stmts)); + Next_Non_Pragma (Variant); + end loop; + end; + end if; + Counter := Counter + 1; + end FA_Rec_Add_Process_Element; + + begin + -- First all discriminants + + if Has_Discriminants (Typ) then + Disc := First_Discriminant (Typ); + Discriminant_Associations := New_List; + + while Present (Disc) loop + declare + Disc_Var_Name : constant Entity_Id := + Make_Defining_Identifier (Loc, Chars (Disc)); + Disc_Type : constant Entity_Id := + Etype (Disc); + begin + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => + Disc_Var_Name, + Constant_Present => True, + Object_Definition => + New_Occurrence_Of (Disc_Type, Loc), + Expression => + Build_From_Any_Call (Etype (Disc), + Build_Get_Aggregate_Element (Loc, + Any => Any_Parameter, + Tc => Build_TypeCode_Call + (Loc, Etype (Disc), Decls), + Idx => Make_Integer_Literal + (Loc, Component_Counter)), + Decls))); + Component_Counter := Component_Counter + 1; + + Append_To (Discriminant_Associations, + Make_Discriminant_Association (Loc, + Selector_Names => New_List ( + New_Occurrence_Of (Disc, Loc)), + Expression => + New_Occurrence_Of (Disc_Var_Name, Loc))); + end; + Next_Discriminant (Disc); + end loop; + + Res_Definition := Make_Subtype_Indication (Loc, + Subtype_Mark => Res_Definition, + Constraint => + Make_Index_Or_Discriminant_Constraint (Loc, + Discriminant_Associations)); + end if; + + -- Now we have all the discriminants in variables, we can + -- declared a constrained object. Note that we are not + -- initializing (non-discriminant) components directly in + -- the object declarations, because which fields to + -- initialize depends (at run time) on the discriminant + -- values. + + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => + Res, + Object_Definition => + Res_Definition)); + + -- ... then all components + + FA_Append_Record_Traversal (Stms, + Clist => Component_List (Rdef), + Container => Any_Parameter, + Counter => Component_Counter); + + Append_To (Stms, + Make_Return_Statement (Loc, + Expression => New_Occurrence_Of (Res, Loc))); + end; + end if; - 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; + elsif Is_Array_Type (Typ) then + declare + Constrained : constant Boolean := Is_Constrained (Typ); + + procedure FA_Ary_Add_Process_Element + (Stmts : List_Id; + Any : Entity_Id; + Counter : Entity_Id; + Datum : Node_Id); + -- Assign the current element (as identified by Counter) of + -- Any to the variable denoted by name Datum, and advance + -- Counter by 1. If Datum is not an Any, a call to From_Any + -- for its type is inserted. + + -------------------------------- + -- FA_Ary_Add_Process_Element -- + -------------------------------- + + procedure FA_Ary_Add_Process_Element + (Stmts : List_Id; + Any : Entity_Id; + Counter : Entity_Id; + Datum : Node_Id) + is + Assignment : constant Node_Id := + Make_Assignment_Statement (Loc, + Name => Datum, + Expression => Empty); + + Element_Any : constant Node_Id := + Build_Get_Aggregate_Element (Loc, + Any => Any, + Tc => Build_TypeCode_Call (Loc, + Etype (Datum), Decls), + Idx => New_Occurrence_Of (Counter, Loc)); + + begin + -- Note: here we *prepend* statements to Stmts, so + -- we must do it in reverse order. + + Prepend_To (Stmts, + Make_Assignment_Statement (Loc, + Name => + New_Occurrence_Of (Counter, Loc), + Expression => + Make_Op_Add (Loc, + Left_Opnd => + New_Occurrence_Of (Counter, Loc), + Right_Opnd => + Make_Integer_Literal (Loc, 1)))); + + if Nkind (Datum) /= N_Attribute_Reference then + + -- We ignore the value of the length of each + -- dimension, since the target array has already + -- been constrained anyway. + + if Etype (Datum) /= RTE (RE_Any) then + Set_Expression (Assignment, + Build_From_Any_Call ( + Component_Type (Typ), + Element_Any, + Decls)); + else + Set_Expression (Assignment, Element_Any); + end if; + Prepend_To (Stmts, Assignment); + end if; + end FA_Ary_Add_Process_Element; + + Counter : constant Entity_Id := + Make_Defining_Identifier (Loc, Name_J); + + Initial_Counter_Value : Int := 0; + + Component_TC : constant Entity_Id := + Make_Defining_Identifier (Loc, Name_T); + + Res : constant Entity_Id := + Make_Defining_Identifier (Loc, Name_R); + + procedure Append_From_Any_Array_Iterator is + new Append_Array_Traversal ( + Subprogram => Fnam, + Arry => Res, + Indices => New_List, + Add_Process_Element => FA_Ary_Add_Process_Element); + + Res_Subtype_Indication : Node_Id := + New_Occurrence_Of (Typ, Loc); - Pop_Scope; - end Expand_Receiving_Stubs_Bodies; + begin + if not Constrained then + declare + Ndim : constant Int := Number_Dimensions (Typ); + Lnam : Name_Id; + Hnam : Name_Id; + Indx : Node_Id := First_Index (Typ); + Indt : Entity_Id; + + Ranges : constant List_Id := New_List; + + begin + for J in 1 .. Ndim loop + Lnam := New_External_Name ('L', J); + Hnam := New_External_Name ('H', J); + Indt := Etype (Indx); + + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Lnam), + Constant_Present => + True, + Object_Definition => + New_Occurrence_Of (Indt, Loc), + Expression => + Build_From_Any_Call ( + Indt, + Build_Get_Aggregate_Element (Loc, + Any => Any_Parameter, + Tc => Build_TypeCode_Call (Loc, + Indt, Decls), + Idx => Make_Integer_Literal (Loc, J - 1)), + Decls))); + + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Hnam), + Constant_Present => + True, + Object_Definition => + New_Occurrence_Of (Indt, Loc), + Expression => Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Indt, Loc), + Attribute_Name => Name_Val, + Expressions => New_List ( + Make_Op_Subtract (Loc, + Left_Opnd => + Make_Op_Add (Loc, + Left_Opnd => + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Indt, Loc), + Attribute_Name => + Name_Pos, + Expressions => New_List ( + Make_Identifier (Loc, Lnam))), + Right_Opnd => + Make_Function_Call (Loc, + Name => New_Occurrence_Of (RTE ( + RE_Get_Nested_Sequence_Length), + Loc), + Parameter_Associations => + New_List ( + New_Occurrence_Of ( + Any_Parameter, Loc), + Make_Integer_Literal (Loc, + J)))), + Right_Opnd => + Make_Integer_Literal (Loc, 1)))))); + + Append_To (Ranges, + Make_Range (Loc, + Low_Bound => Make_Identifier (Loc, Lnam), + High_Bound => Make_Identifier (Loc, Hnam))); + + Next_Index (Indx); + end loop; + + -- Now we have all the necessary bound information: + -- apply the set of range constraints to the + -- (unconstrained) nominal subtype of Res. + + Initial_Counter_Value := Ndim; + Res_Subtype_Indication := Make_Subtype_Indication (Loc, + Subtype_Mark => + Res_Subtype_Indication, + Constraint => + Make_Index_Or_Discriminant_Constraint (Loc, + Constraints => Ranges)); + end; + end if; - -------------------- - -- GARLIC_Support -- - -------------------- + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Res, + Object_Definition => Res_Subtype_Indication)); + Set_Etype (Res, Typ); - package body GARLIC_Support is + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Counter, + Object_Definition => + New_Occurrence_Of (RTE (RE_Long_Unsigned), Loc), + Expression => + Make_Integer_Literal (Loc, Initial_Counter_Value))); - -- Local subprograms + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Component_TC, + Constant_Present => True, + Object_Definition => + New_Occurrence_Of (RTE (RE_TypeCode), Loc), + Expression => + Build_TypeCode_Call (Loc, + Component_Type (Typ), Decls))); + + Append_From_Any_Array_Iterator (Stms, + Any_Parameter, Counter); + + Append_To (Stms, + Make_Return_Statement (Loc, + Expression => New_Occurrence_Of (Res, Loc))); + end; - 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. + elsif Is_Integer_Type (Typ) or else Is_Unsigned_Type (Typ) then + Append_To (Stms, + Make_Return_Statement (Loc, + Expression => + Unchecked_Convert_To ( + Typ, + Build_From_Any_Call ( + Find_Numeric_Representation (Typ), + New_Occurrence_Of (Any_Parameter, Loc), + Decls)))); - 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 + else + -- Default: type is represented as an opaque sequence of bytes - 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. + declare + Strm : constant Entity_Id := + Make_Defining_Identifier (Loc, + Chars => New_Internal_Name ('S')); + Res : constant Entity_Id := + Make_Defining_Identifier (Loc, + Chars => New_Internal_Name ('R')); - Loc : Source_Ptr; - -- Shared source location used by Add_{Read,Write}_Read_Attribute - -- and their ancillary subroutines (set on entry by Add_RACW_Features). + begin + -- Strm : Buffer_Stream_Type; - procedure Add_RAS_Access_TSS (N : Node_Id); - -- Add a subprogram body for RAS Access TSS + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => + Strm, + Aliased_Present => + True, + Object_Definition => + New_Occurrence_Of (RTE (RE_Buffer_Stream_Type), Loc))); + + -- Any_To_BS (Strm, A); + + Append_To (Stms, + Make_Procedure_Call_Statement (Loc, + Name => + New_Occurrence_Of (RTE (RE_Any_To_BS), Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of (Any_Parameter, Loc), + New_Occurrence_Of (Strm, Loc)))); + + -- declare + -- Res : constant T := T'Input (Strm); + -- begin + -- Release_Buffer (Strm); + -- return Res; + -- end; + + Append_To (Stms, Make_Block_Statement (Loc, + Declarations => New_List ( + Make_Object_Declaration (Loc, + Defining_Identifier => Res, + Constant_Present => True, + Object_Definition => + New_Occurrence_Of (Typ, Loc), + Expression => + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Typ, Loc), + Attribute_Name => Name_Input, + Expressions => New_List ( + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Strm, Loc), + Attribute_Name => Name_Access))))), + + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List ( + Make_Procedure_Call_Statement (Loc, + Name => + New_Occurrence_Of (RTE (RE_Release_Buffer), Loc), + Parameter_Associations => + New_List ( + New_Occurrence_Of (Strm, Loc))), + Make_Return_Statement (Loc, + Expression => New_Occurrence_Of (Res, Loc)))))); - ----------------------- - -- Add_RACW_Features -- - ----------------------- + end; + end if; - 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); + Decl := + Make_Subprogram_Body (Loc, + Specification => Spec, + Declarations => Decls, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Stms)); + end Build_From_Any_Function; + + --------------------------------- + -- Build_Get_Aggregate_Element -- + --------------------------------- + + function Build_Get_Aggregate_Element + (Loc : Source_Ptr; + Any : Entity_Id; + TC : Node_Id; + Idx : Node_Id) return Node_Id + is + begin + return Make_Function_Call (Loc, + Name => + New_Occurrence_Of ( + RTE (RE_Get_Aggregate_Element), Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of (Any, Loc), + TC, + Idx)); + end Build_Get_Aggregate_Element; + + ------------------------- + -- Build_Reposiroty_Id -- + ------------------------- + + procedure Build_Name_And_Repository_Id + (E : Entity_Id; + Name_Str : out String_Id; + Repo_Id_Str : out String_Id) + is + begin + Start_String; + Store_String_Chars ("DSA:"); + Get_Library_Unit_Name_String (Scope (E)); + Store_String_Chars ( + Name_Buffer (Name_Buffer'First + .. Name_Buffer'First + Name_Len - 1)); + Store_String_Char ('.'); + Get_Name_String (Chars (E)); + Store_String_Chars ( + Name_Buffer (Name_Buffer'First + .. Name_Buffer'First + Name_Len - 1)); + Store_String_Chars (":1.0"); + Repo_Id_Str := End_String; + Name_Str := String_From_Name_Buffer; + end Build_Name_And_Repository_Id; + + ----------------------- + -- Build_To_Any_Call -- + ----------------------- + + function Build_To_Any_Call + (N : Node_Id; + Decls : List_Id) return Node_Id + is + Loc : constant Source_Ptr := Sloc (N); - begin - Loc := Sloc (RACW_Type); + Typ : Entity_Id := Etype (N); + U_Type : Entity_Id; - if Is_RAS then + Fnam : Entity_Id := Empty; + Lib_RE : RE_Id := RE_Null; - -- 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. + begin + -- If N is a selected component, then maybe its Etype + -- has not been set yet: try to use the Etype of the + -- selector_name in that case. - RPC_Receiver := Make_Selected_Component (Loc, - Prefix => - Unchecked_Convert_To (RTE (RE_RAS_Proxy_Type_Access), Object), - Selector_Name => Make_Identifier (Loc, Name_Receiver)); + if No (Typ) and then Nkind (N) = N_Selected_Component then + Typ := Etype (Selector_Name (N)); + end if; + pragma Assert (Present (Typ)); - 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; + -- The full view, if Typ is private; the completion, + -- if Typ is incomplete. - Add_RACW_Write_Attribute ( - RACW_Type, - Stub_Type, - Stub_Type_Access, - RPC_Receiver, - Declarations); + U_Type := Underlying_Type (Typ); - Add_RACW_Read_Attribute ( - RACW_Type, - Stub_Type, - Stub_Type_Access, - Declarations); - end Add_RACW_Features; + -- First simple case where the To_Any function is present + -- in the type's TSS. - ----------------------------- - -- Add_RACW_Read_Attribute -- - ----------------------------- + Fnam := Find_Inherited_TSS (U_Type, Name_uTo_Any); - 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; + -- Check first for Boolean and Character. These are enumeration + -- types, but we treat them specially, since they may require + -- special handling in the transfer protocol. However, this + -- special handling only applies if they have standard + -- representation, otherwise they are treated like any other + -- enumeration type. - Body_Node : Node_Id; + if Sloc (U_Type) <= Standard_Location then + U_Type := Base_Type (U_Type); + end if; - Decls : List_Id; - Statements : List_Id; - Local_Statements : List_Id; - Remote_Statements : List_Id; - -- Various parts of the procedure + if Present (Fnam) then + null; - 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)); + elsif U_Type = Standard_Boolean then + Lib_RE := RE_TA_B; - -- Start of processing for Add_RACW_Read_Attribute + elsif U_Type = Standard_Character then + Lib_RE := RE_TA_C; - begin - -- Generate object declarations + elsif U_Type = Standard_Wide_Character then + Lib_RE := RE_TA_WC; - Decls := New_List ( - Make_Object_Declaration (Loc, - Defining_Identifier => Source_Partition, - Object_Definition => - New_Occurrence_Of (RTE (RE_Partition_ID), Loc)), + -- Floating point types - Make_Object_Declaration (Loc, - Defining_Identifier => Source_Receiver, - Object_Definition => - New_Occurrence_Of (RTE (RE_Unsigned_64), Loc)), + elsif U_Type = Standard_Short_Float then + Lib_RE := RE_TA_SF; - Make_Object_Declaration (Loc, - Defining_Identifier => Source_Address, - Object_Definition => - New_Occurrence_Of (RTE (RE_Unsigned_64), Loc)), + elsif U_Type = Standard_Float then + Lib_RE := RE_TA_F; - Make_Object_Declaration (Loc, - Defining_Identifier => Local_Stub, - Aliased_Present => True, - Object_Definition => New_Occurrence_Of (Stub_Type, Loc)), + elsif U_Type = Standard_Long_Float then + Lib_RE := RE_TA_LF; - 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))); + elsif U_Type = Standard_Long_Long_Float then + Lib_RE := RE_TA_LLF; - -- Read the source Partition_ID and RPC_Receiver from incoming stream + -- Integer types - 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))), + elsif U_Type = Etype (Standard_Short_Short_Integer) then + Lib_RE := RE_TA_SSI; - 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))), + elsif U_Type = Etype (Standard_Short_Integer) then + Lib_RE := RE_TA_SI; - 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)))); + elsif U_Type = Etype (Standard_Integer) then + Lib_RE := RE_TA_I; - -- Build_Get_Unique_RP_Call needs the type of Stubbed_Result + elsif U_Type = Etype (Standard_Long_Integer) then + Lib_RE := RE_TA_LI; - Set_Etype (Stubbed_Result, Stub_Type_Access); + elsif U_Type = Etype (Standard_Long_Long_Integer) then + Lib_RE := RE_TA_LLI; - -- If the Address is Null_Address, then return a null object + -- Unsigned integer types - 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)))); + elsif U_Type = RTE (RE_Short_Short_Unsigned) then + Lib_RE := RE_TA_SSU; - -- If the RACW denotes an object created on the current partition, - -- Local_Statements will be executed. The real object will be used. + elsif U_Type = RTE (RE_Short_Unsigned) then + Lib_RE := RE_TA_SU; - 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))))); + elsif U_Type = RTE (RE_Unsigned) then + Lib_RE := RE_TA_U; - -- 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. + elsif U_Type = RTE (RE_Long_Unsigned) then + Lib_RE := RE_TA_LU; - Remote_Statements := New_List ( + elsif U_Type = RTE (RE_Long_Long_Unsigned) then + Lib_RE := RE_TA_LLU; - 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)), + elsif U_Type = Standard_String then + Lib_RE := RE_TA_String; - 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)), + elsif U_Type = Underlying_Type (RTE (RE_TypeCode)) then + Lib_RE := RE_TA_TC; - 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))); + -- Other (non-primitive) types - 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))); + else + declare + Decl : Entity_Id; + begin + Build_To_Any_Function (Loc, U_Type, Decl, Fnam); + Append_To (Decls, Decl); + end; + end if; - 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. + -- Call the function - Append_To (Remote_Statements, - Make_Assignment_Statement (Loc, - Name => Result, - Expression => Unchecked_Convert_To (RACW_Type, - New_Occurrence_Of (Stubbed_Result, Loc)))); + if Lib_RE /= RE_Null then + pragma Assert (No (Fnam)); + Fnam := RTE (Lib_RE); + end if; - -- Distinguish between the local and remote cases, and execute the - -- appropriate piece of code. + return + Make_Function_Call (Loc, + Name => New_Occurrence_Of (Fnam, Loc), + Parameter_Associations => New_List (N)); + end Build_To_Any_Call; + + --------------------------- + -- Build_To_Any_Function -- + --------------------------- + + procedure Build_To_Any_Function + (Loc : Source_Ptr; + Typ : Entity_Id; + Decl : out Node_Id; + Fnam : out Entity_Id) + is + Spec : Node_Id; + Decls : constant List_Id := New_List; + Stms : constant List_Id := New_List; - 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)); + Expr_Parameter : constant Entity_Id := + Make_Defining_Identifier (Loc, Name_E); - Build_Stream_Procedure - (Loc, RACW_Type, Body_Node, - Make_Defining_Identifier (Loc, Procedure_Name), - Statements, Outp => True); - Set_Declarations (Body_Node, Decls); + Any : constant Entity_Id := + Make_Defining_Identifier (Loc, Name_A); - Proc_Decl := Make_Subprogram_Declaration (Loc, - Copy_Specification (Loc, Specification (Body_Node))); + Any_Decl : Node_Id; + Result_TC : Node_Id := Build_TypeCode_Call (Loc, Typ, Decls); - 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)); + begin + Fnam := Make_Stream_Procedure_Function_Name (Loc, + Typ, Name_uTo_Any); - Insert_After (Declaration_Node (RACW_Type), Proc_Decl); - Insert_After (Proc_Decl, Attr_Decl); - Append_To (Declarations, Body_Node); - end Add_RACW_Read_Attribute; + Spec := + Make_Function_Specification (Loc, + Defining_Unit_Name => Fnam, + Parameter_Specifications => New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => + Expr_Parameter, + Parameter_Type => + New_Occurrence_Of (Typ, Loc))), + Subtype_Mark => New_Occurrence_Of (RTE (RE_Any), Loc)); + Set_Etype (Expr_Parameter, Typ); + + Any_Decl := + Make_Object_Declaration (Loc, + Defining_Identifier => + Any, + Object_Definition => + New_Occurrence_Of (RTE (RE_Any), Loc)); - ------------------------------ - -- Add_RACW_Write_Attribute -- - ------------------------------ + if Is_Derived_Type (Typ) and then not Is_Tagged_Type (Typ) then + declare + Rt_Type : constant Entity_Id + := Root_Type (Typ); + Expr : constant Node_Id + := OK_Convert_To ( + Rt_Type, + New_Occurrence_Of (Expr_Parameter, Loc)); + begin + Set_Expression (Any_Decl, Build_To_Any_Call (Expr, Decls)); + end; - 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; + elsif Is_Record_Type (Typ) and then not Is_Tagged_Type (Typ) then + if Nkind (Declaration_Node (Typ)) = N_Subtype_Declaration then + declare + Rt_Type : constant Entity_Id + := Etype (Typ); + Expr : constant Node_Id + := OK_Convert_To ( + Rt_Type, + New_Occurrence_Of (Expr_Parameter, Loc)); + + begin + Set_Expression (Any_Decl, + Build_To_Any_Call (Expr, Decls)); + end; + + else + declare + Disc : Entity_Id := Empty; + Rdef : constant Node_Id := + Type_Definition (Declaration_Node (Typ)); + Counter : Int := 0; + Elements : constant List_Id := New_List; + + procedure TA_Rec_Add_Process_Element + (Stmts : List_Id; + Container : Node_Or_Entity_Id; + Counter : in out Int; + Rec : Entity_Id; + Field : Node_Id); + + procedure TA_Append_Record_Traversal is + new Append_Record_Traversal + (Rec => Expr_Parameter, + Add_Process_Element => TA_Rec_Add_Process_Element); + + -------------------------------- + -- TA_Rec_Add_Process_Element -- + -------------------------------- + + procedure TA_Rec_Add_Process_Element + (Stmts : List_Id; + Container : Node_Or_Entity_Id; + Counter : in out Int; + Rec : Entity_Id; + Field : Node_Id) + is + Field_Ref : Node_Id; + + begin + if Nkind (Field) = N_Defining_Identifier then + + -- A regular component + + Field_Ref := Make_Selected_Component (Loc, + Prefix => New_Occurrence_Of (Rec, Loc), + Selector_Name => New_Occurrence_Of (Field, Loc)); + Set_Etype (Field_Ref, Etype (Field)); + + Append_To (Stmts, + Make_Procedure_Call_Statement (Loc, + Name => + New_Occurrence_Of ( + RTE (RE_Add_Aggregate_Element), Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of (Any, Loc), + Build_To_Any_Call (Field_Ref, Decls)))); + + else + -- A variant part + + declare + Variant : Node_Id; + Struct_Counter : Int := 0; + + Block_Decls : constant List_Id := New_List; + Block_Stmts : constant List_Id := New_List; + VP_Stmts : List_Id; + + Alt_List : constant List_Id := New_List; + Choice_List : List_Id; + + Union_Any : constant Entity_Id := + Make_Defining_Identifier (Loc, + New_Internal_Name ('U')); + + Struct_Any : constant Entity_Id := + Make_Defining_Identifier (Loc, + New_Internal_Name ('S')); + + function Make_Discriminant_Reference + return Node_Id; + -- Build a selected component for the + -- discriminant of this variant part. + + --------------------------------- + -- Make_Discriminant_Reference -- + --------------------------------- + + function Make_Discriminant_Reference + return Node_Id + is + Nod : constant Node_Id := + Make_Selected_Component (Loc, + Prefix => + New_Occurrence_Of (Rec, Loc), + Selector_Name => + New_Occurrence_Of ( + Entity (Name (Field)), Loc)); + begin + Set_Etype (Nod, Name (Field)); + return Nod; + end Make_Discriminant_Reference; + + begin + Append_To (Stmts, + Make_Block_Statement (Loc, + Declarations => + Block_Decls, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Block_Stmts))); + + Append_To (Block_Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Union_Any, + Object_Definition => + New_Occurrence_Of (RTE (RE_Any), Loc), + Expression => + Make_Function_Call (Loc, + Name => New_Occurrence_Of ( + RTE (RE_Create_Any), Loc), + Parameter_Associations => New_List ( + Make_Function_Call (Loc, + Name => + New_Occurrence_Of ( + RTE (RE_Any_Member_Type), Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of (Container, Loc), + Make_Integer_Literal (Loc, + Counter))))))); + + Append_To (Block_Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Struct_Any, + Object_Definition => + New_Occurrence_Of (RTE (RE_Any), Loc), + Expression => + Make_Function_Call (Loc, + Name => New_Occurrence_Of ( + RTE (RE_Create_Any), Loc), + Parameter_Associations => New_List ( + Make_Function_Call (Loc, + Name => + New_Occurrence_Of ( + RTE (RE_Any_Member_Type), Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of (Union_Any, Loc), + Make_Integer_Literal (Loc, + Uint_0))))))); + + Append_To (Block_Stmts, + Make_Case_Statement (Loc, + Expression => + Make_Discriminant_Reference, + Alternatives => + Alt_List)); + + Variant := First_Non_Pragma (Variants (Field)); + while Present (Variant) loop + Choice_List := New_Copy_List_Tree + (Discrete_Choices (Variant)); + + VP_Stmts := New_List; + TA_Append_Record_Traversal ( + Stmts => VP_Stmts, + Clist => Component_List (Variant), + Container => Struct_Any, + Counter => Struct_Counter); + + -- Append discriminant value and inner struct + -- to union aggregate. + + Append_To (VP_Stmts, + Make_Procedure_Call_Statement (Loc, + Name => + New_Occurrence_Of ( + RTE (RE_Add_Aggregate_Element), Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of (Union_Any, Loc), + Build_To_Any_Call ( + Make_Discriminant_Reference, + Block_Decls)))); + + Append_To (VP_Stmts, + Make_Procedure_Call_Statement (Loc, + Name => + New_Occurrence_Of ( + RTE (RE_Add_Aggregate_Element), Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of (Union_Any, Loc), + New_Occurrence_Of (Struct_Any, Loc)))); + + -- Append union to outer aggregate + + Append_To (VP_Stmts, + Make_Procedure_Call_Statement (Loc, + Name => + New_Occurrence_Of ( + RTE (RE_Add_Aggregate_Element), Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of (Container, Loc), + Make_Function_Call (Loc, + Name => New_Occurrence_Of ( + RTE (RE_Any_Aggregate_Build), Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of ( + Union_Any, Loc)))))); + + Append_To (Alt_List, + Make_Case_Statement_Alternative (Loc, + Discrete_Choices => Choice_List, + Statements => + VP_Stmts)); + Next_Non_Pragma (Variant); + end loop; + end; + end if; + end TA_Rec_Add_Process_Element; + + begin + -- First all discriminants + + if Has_Discriminants (Typ) then + Disc := First_Discriminant (Typ); + + while Present (Disc) loop + Append_To (Elements, + Make_Component_Association (Loc, + Choices => New_List ( + Make_Integer_Literal (Loc, Counter)), + Expression => + Build_To_Any_Call ( + Make_Selected_Component (Loc, + Prefix => + New_Occurrence_Of (Expr_Parameter, Loc), + Selector_Name => + New_Occurrence_Of (Disc, Loc)), + Decls))); + Counter := Counter + 1; + Next_Discriminant (Disc); + end loop; + + else + -- Make elements an empty array + + declare + Dummy_Any : constant Entity_Id := + Make_Defining_Identifier (Loc, + Chars => New_Internal_Name ('A')); + + begin + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Dummy_Any, + Object_Definition => + New_Occurrence_Of (RTE (RE_Any), Loc))); + + Append_To (Elements, + Make_Component_Association (Loc, + Choices => New_List ( + Make_Range (Loc, + Low_Bound => + Make_Integer_Literal (Loc, 1), + High_Bound => + Make_Integer_Literal (Loc, 0))), + Expression => + New_Occurrence_Of (Dummy_Any, Loc))); + end; + end if; + + Set_Expression (Any_Decl, + Make_Function_Call (Loc, + Name => New_Occurrence_Of ( + RTE (RE_Any_Aggregate_Build), Loc), + Parameter_Associations => New_List ( + Result_TC, + Make_Aggregate (Loc, + Component_Associations => Elements)))); + Result_TC := Empty; + + -- ... then all components + + TA_Append_Record_Traversal (Stms, + Clist => Component_List (Rdef), + Container => Any, + Counter => Counter); + end; + end if; - Statements : List_Id; - Local_Statements : List_Id; - Remote_Statements : List_Id; - Null_Statements : List_Id; + elsif Is_Array_Type (Typ) then + declare + Constrained : constant Boolean := Is_Constrained (Typ); + + procedure TA_Ary_Add_Process_Element + (Stmts : List_Id; + Any : Entity_Id; + Counter : Entity_Id; + Datum : Node_Id); + + -------------------------------- + -- TA_Ary_Add_Process_Element -- + -------------------------------- + + procedure TA_Ary_Add_Process_Element + (Stmts : List_Id; + Any : Entity_Id; + Counter : Entity_Id; + Datum : Node_Id) + is + pragma Warnings (Off); + pragma Unreferenced (Counter); + pragma Warnings (On); + + Element_Any : Node_Id; + + begin + if Etype (Datum) = RTE (RE_Any) then + Element_Any := Datum; + else + Element_Any := Build_To_Any_Call (Datum, Decls); + end if; + + Append_To (Stmts, + Make_Procedure_Call_Statement (Loc, + Name => New_Occurrence_Of ( + RTE (RE_Add_Aggregate_Element), Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of (Any, Loc), + Element_Any))); + end TA_Ary_Add_Process_Element; + + procedure Append_To_Any_Array_Iterator is + new Append_Array_Traversal ( + Subprogram => Fnam, + Arry => Expr_Parameter, + Indices => New_List, + Add_Process_Element => TA_Ary_Add_Process_Element); + + Index : Node_Id; - Procedure_Name : constant Name_Id := New_Internal_Name ('R'); + begin + Set_Expression (Any_Decl, + Make_Function_Call (Loc, + Name => + New_Occurrence_Of (RTE (RE_Create_Any), Loc), + Parameter_Associations => New_List (Result_TC))); + Result_TC := Empty; + + if not Constrained then + Index := First_Index (Typ); + for J in 1 .. Number_Dimensions (Typ) loop + Append_To (Stms, + Make_Procedure_Call_Statement (Loc, + Name => + New_Occurrence_Of ( + RTE (RE_Add_Aggregate_Element), Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of (Any, Loc), + Build_To_Any_Call ( + OK_Convert_To (Etype (Index), + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Expr_Parameter, Loc), + Attribute_Name => Name_First, + Expressions => New_List ( + Make_Integer_Literal (Loc, J)))), + Decls)))); + Next_Index (Index); + end loop; + end if; - begin - -- Build the code fragment corresponding to the marshalling of a - -- local object. + Append_To_Any_Array_Iterator (Stms, Any); + end; - Local_Statements := New_List ( + elsif Is_Integer_Type (Typ) or else Is_Unsigned_Type (Typ) then + Set_Expression (Any_Decl, + Build_To_Any_Call ( + OK_Convert_To ( + Find_Numeric_Representation (Typ), + New_Occurrence_Of (Expr_Parameter, Loc)), + Decls)); - Pack_Entity_Into_Stream_Access (Loc, - Stream => Stream_Parameter, - Object => RTE (RE_Get_Local_Partition_Id)), + else + -- Default: type is represented as an opaque sequence of bytes - Pack_Node_Into_Stream_Access (Loc, - Stream => Stream_Parameter, - Object => OK_Convert_To (RTE (RE_Unsigned_64), RPC_Receiver), - Etyp => RTE (RE_Unsigned_64)), + declare + Strm : constant Entity_Id := Make_Defining_Identifier (Loc, + New_Internal_Name ('S')); - 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))); + begin + -- Strm : aliased Buffer_Stream_Type; - -- Build the code fragment corresponding to the marshalling of - -- a remote object. + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => + Strm, + Aliased_Present => + True, + Object_Definition => + New_Occurrence_Of (RTE (RE_Buffer_Stream_Type), Loc))); - Remote_Statements := New_List ( + -- Allocate_Buffer (Strm); - 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)), + Append_To (Stms, + Make_Procedure_Call_Statement (Loc, + Name => + New_Occurrence_Of (RTE (RE_Allocate_Buffer), Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of (Strm, Loc)))); - 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)), + -- T'Output (Strm'Access, 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_Addr)), - Etyp => RTE (RE_Unsigned_64))); + Append_To (Stms, + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Typ, Loc), + Attribute_Name => Name_Output, + Expressions => New_List ( + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Strm, Loc), + Attribute_Name => Name_Access), + New_Occurrence_Of (Expr_Parameter, Loc)))); + + -- BS_To_Any (Strm, A); + + Append_To (Stms, + Make_Procedure_Call_Statement (Loc, + Name => + New_Occurrence_Of (RTE (RE_BS_To_Any), Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of (Strm, Loc), + New_Occurrence_Of (Any, Loc)))); + + -- Release_Buffer (Strm); + + Append_To (Stms, + Make_Procedure_Call_Statement (Loc, + Name => + New_Occurrence_Of (RTE (RE_Release_Buffer), Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of (Strm, Loc)))); + end; + end if; - -- Build the code fragment corresponding to the marshalling of a null - -- object. + Append_To (Decls, Any_Decl); - Null_Statements := New_List ( + if Present (Result_TC) then + Append_To (Stms, + Make_Procedure_Call_Statement (Loc, + Name => New_Occurrence_Of (RTE (RE_Set_TC), Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of (Any, Loc), + Result_TC))); + end if; - Pack_Entity_Into_Stream_Access (Loc, - Stream => Stream_Parameter, - Object => RTE (RE_Get_Local_Partition_Id)), + Append_To (Stms, + Make_Return_Statement (Loc, + Expression => New_Occurrence_Of (Any, Loc))); + + Decl := + Make_Subprogram_Body (Loc, + Specification => Spec, + Declarations => Decls, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Stms)); + end Build_To_Any_Function; + + ------------------------- + -- Build_TypeCode_Call -- + ------------------------- + + function Build_TypeCode_Call + (Loc : Source_Ptr; + Typ : Entity_Id; + Decls : List_Id) return Node_Id + is + U_Type : Entity_Id := Underlying_Type (Typ); + -- The full view, if Typ is private; the completion, + -- if Typ is incomplete. - Pack_Node_Into_Stream_Access (Loc, - Stream => Stream_Parameter, - Object => OK_Convert_To (RTE (RE_Unsigned_64), RPC_Receiver), - Etyp => RTE (RE_Unsigned_64)), + Fnam : Entity_Id := Empty; + Tnam : Entity_Id := Empty; + Pnam : Entity_Id := Empty; + Args : List_Id := Empty_List; + Lib_RE : RE_Id := RE_Null; - Pack_Node_Into_Stream_Access (Loc, - Stream => Stream_Parameter, - Object => Make_Integer_Literal (Loc, Uint_0), - Etyp => RTE (RE_Unsigned_64))); + Expr : Node_Id; - 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)); + begin + -- Special case System.PolyORB.Interface.Any: its primitives have + -- not been set yet, so can't call Find_Inherited_TSS. - Build_Stream_Procedure - (Loc, RACW_Type, Body_Node, - Make_Defining_Identifier (Loc, Procedure_Name), - Statements, Outp => False); + if Typ = RTE (RE_Any) then + Fnam := RTE (RE_TC_Any); - Proc_Decl := Make_Subprogram_Declaration (Loc, - Copy_Specification (Loc, Specification (Body_Node))); + else + -- First simple case where the TypeCode is present + -- in the type's TSS. - 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)); + Fnam := Find_Inherited_TSS (U_Type, Name_uTypeCode); - Insert_After (Declaration_Node (RACW_Type), Proc_Decl); - Insert_After (Proc_Decl, Attr_Decl); - Append_To (Declarations, Body_Node); - end Add_RACW_Write_Attribute; + if Present (Fnam) then - ------------------------ - -- Add_RAS_Access_TSS -- - ------------------------ + -- When a TypeCode TSS exists, it has a single parameter + -- that is an anonymous access to the corresponding type. + -- This parameter is not used in any way; its purpose is + -- solely to provide overloading of the TSS. - procedure Add_RAS_Access_TSS (N : Node_Id) is - Loc : constant Source_Ptr := Sloc (N); + Tnam := + Make_Defining_Identifier (Loc, New_Internal_Name ('T')); + Pnam := + Make_Defining_Identifier (Loc, New_Internal_Name ('P')); - 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. + Append_To (Decls, + Make_Full_Type_Declaration (Loc, + Defining_Identifier => Tnam, + Type_Definition => + Make_Access_To_Object_Definition (Loc, + Subtype_Indication => + New_Occurrence_Of (U_Type, Loc)))); + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Pnam, + Constant_Present => True, + Object_Definition => New_Occurrence_Of (Tnam, Loc), - RACW_Type : constant Entity_Id := - Underlying_RACW_Type (Ras_Type); - Desig : constant Entity_Id := - Etype (Designated_Type (RACW_Type)); + -- Use a variable here to force proper freezing of Tnam - Stub_Elements : constant Stub_Structure := - Stubs_Table.Get (Desig); - pragma Assert (Stub_Elements /= Empty_Stub_Structure); + Expression => Make_Null (Loc))); - Proc : constant Entity_Id := - Make_Defining_Identifier (Loc, - Chars => Make_TSS_Name (Ras_Type, TSS_RAS_Access)); + -- Normally, calling _TypeCode with a null access parameter + -- should raise Constraint_Error, but this check is + -- suppressed for expanded code, and we do not care anyway + -- because we do not actually ever use this value. - Proc_Spec : Node_Id; + Args := New_List (New_Occurrence_Of (Pnam, Loc)); + end if; + end if; - -- Formal parameters + if No (Fnam) then + if Sloc (U_Type) <= Standard_Location then - Package_Name : constant Entity_Id := - Make_Defining_Identifier (Loc, - Chars => Name_P); - -- Target package + -- Do not try to build alias typecodes for subtypes from + -- Standard. - Subp_Id : constant Entity_Id := - Make_Defining_Identifier (Loc, - Chars => Name_S); - -- Target subprogram + U_Type := Base_Type (U_Type); + end if; - Asynch_P : constant Entity_Id := - Make_Defining_Identifier (Loc, - Chars => Name_Asynchronous); - -- Is the procedure to which the 'Access applies asynchronous? + if Is_Itype (U_Type) then + return Build_TypeCode_Call + (Loc, Associated_Node_For_Itype (U_Type), Decls); + end if; - 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. + if U_Type = Standard_Boolean then + Lib_RE := RE_TC_B; - -- Common local variables + elsif U_Type = Standard_Character then + Lib_RE := RE_TC_C; - Proc_Decls : List_Id; - Proc_Statements : List_Id; + elsif U_Type = Standard_Wide_Character then + Lib_RE := RE_TC_WC; - Origin : constant Entity_Id := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('P')); + -- Floating point types - -- Additional local variables for the local case + elsif U_Type = Standard_Short_Float then + Lib_RE := RE_TC_SF; - Proxy_Addr : constant Entity_Id := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('P')); + elsif U_Type = Standard_Float then + Lib_RE := RE_TC_F; - -- Additional local variables for the remote case + elsif U_Type = Standard_Long_Float then + Lib_RE := RE_TC_LF; - Local_Stub : constant Entity_Id := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('L')); + elsif U_Type = Standard_Long_Long_Float then + Lib_RE := RE_TC_LLF; - Stub_Ptr : constant Entity_Id := - Make_Defining_Identifier (Loc, - Chars => New_Internal_Name ('S')); + -- Integer types (walk back to the base type) - 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 + elsif U_Type = Etype (Standard_Short_Short_Integer) then + Lib_RE := RE_TC_SSI; - --------------- - -- Set_Field -- - --------------- + elsif U_Type = Etype (Standard_Short_Integer) then + Lib_RE := RE_TC_SI; - function Set_Field - (Field_Name : Name_Id; - Value : Node_Id) return Node_Id - is - begin - return - Make_Assignment_Statement (Loc, - Name => - Make_Selected_Component (Loc, - Prefix => New_Occurrence_Of (Stub_Ptr, Loc), - Selector_Name => Make_Identifier (Loc, Field_Name)), - Expression => Value); - end Set_Field; + elsif U_Type = Etype (Standard_Integer) then + Lib_RE := RE_TC_I; - -- Start of processing for Add_RAS_Access_TSS + elsif U_Type = Etype (Standard_Long_Integer) then + Lib_RE := RE_TC_LI; - begin - Proc_Decls := New_List ( + elsif U_Type = Etype (Standard_Long_Long_Integer) then + Lib_RE := RE_TC_LLI; - -- Common declarations + -- Unsigned integer types - 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)))), + elsif U_Type = RTE (RE_Short_Short_Unsigned) then + Lib_RE := RE_TC_SSU; - -- Declaration use only in the local case: proxy address + elsif U_Type = RTE (RE_Short_Unsigned) then + Lib_RE := RE_TC_SU; - Make_Object_Declaration (Loc, - Defining_Identifier => Proxy_Addr, - Object_Definition => - New_Occurrence_Of (RTE (RE_Unsigned_64), Loc)), + elsif U_Type = RTE (RE_Unsigned) then + Lib_RE := RE_TC_U; - -- Declarations used only in the remote case: stub object and - -- stub pointer. + elsif U_Type = RTE (RE_Long_Unsigned) then + Lib_RE := RE_TC_LU; - Make_Object_Declaration (Loc, - Defining_Identifier => Local_Stub, - Aliased_Present => True, - Object_Definition => - New_Occurrence_Of (Stub_Elements.Stub_Type, Loc)), + elsif U_Type = RTE (RE_Long_Long_Unsigned) then + Lib_RE := RE_TC_LLU; - 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))); + elsif U_Type = Standard_String then + Lib_RE := RE_TC_String; - Set_Etype (Stub_Ptr, Stub_Elements.Stub_Type_Access); - -- Build_Get_Unique_RP_Call needs this information + -- Other (non-primitive) types + + else + declare + Decl : Entity_Id; + begin + Build_TypeCode_Function (Loc, U_Type, Decl, Fnam); + Append_To (Decls, Decl); + end; + end if; + + if Lib_RE /= RE_Null then + Fnam := RTE (Lib_RE); + end if; + end if; + + -- Call the function - -- Note: Here we assume that the Fat_Type is a record - -- containing just a pointer to a proxy or stub object. + Expr := + Make_Function_Call (Loc, + Name => New_Occurrence_Of (Fnam, Loc), + Parameter_Associations => Args); - Proc_Statements := New_List ( + -- Allow Expr to be used as arg to Build_To_Any_Call immediately - -- Generate: + Set_Etype (Expr, RTE (RE_TypeCode)); - -- Get_RAS_Info (Pkg, Subp, PA); - -- if Origin = Local_Partition_Id - -- and then not All_Calls_Remote - -- then - -- return Fat_Type!(PA); - -- end if; + return Expr; + end Build_TypeCode_Call; - 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))), + ----------------------------- + -- Build_TypeCode_Function -- + ----------------------------- - 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)))))), + procedure Build_TypeCode_Function + (Loc : Source_Ptr; + Typ : Entity_Id; + Decl : out Node_Id; + Fnam : out Entity_Id) + is + Spec : Node_Id; + Decls : constant List_Id := New_List; + Stms : constant List_Id := New_List; + + TCNam : constant Entity_Id := + Make_Stream_Procedure_Function_Name (Loc, + Typ, Name_uTypeCode); + + Parameters : List_Id; + + procedure Add_String_Parameter + (S : String_Id; + Parameter_List : List_Id); + -- Add a literal for S to Parameters + + procedure Add_TypeCode_Parameter + (TC_Node : Node_Id; + Parameter_List : List_Id); + -- Add the typecode for Typ to Parameters + + procedure Add_Long_Parameter + (Expr_Node : Node_Id; + Parameter_List : List_Id); + -- Add a signed long integer expression to Parameters + + procedure Initialize_Parameter_List + (Name_String : String_Id; + Repo_Id_String : String_Id; + Parameter_List : out List_Id); + -- Return a list that contains the first two parameters + -- for a parameterized typecode: name and repository id. + + function Make_Constructed_TypeCode + (Kind : Entity_Id; + Parameters : List_Id) return Node_Id; + -- Call TC_Build with the given kind and parameters + + procedure Return_Constructed_TypeCode (Kind : Entity_Id); + -- Make a return statement that calls TC_Build with the given + -- typecode kind, and the constructed parameters list. + + procedure Return_Alias_TypeCode (Base_TypeCode : Node_Id); + -- Return a typecode that is a TC_Alias for the given typecode + + -------------------------- + -- Add_String_Parameter -- + -------------------------- + + procedure Add_String_Parameter + (S : String_Id; + Parameter_List : List_Id) + is + begin + Append_To (Parameter_List, + Make_Function_Call (Loc, + Name => + New_Occurrence_Of (RTE (RE_TA_String), Loc), + Parameter_Associations => New_List ( + Make_String_Literal (Loc, S)))); + end Add_String_Parameter; + + ---------------------------- + -- Add_TypeCode_Parameter -- + ---------------------------- + + procedure Add_TypeCode_Parameter + (TC_Node : Node_Id; + Parameter_List : List_Id) + is + begin + Append_To (Parameter_List, + Make_Function_Call (Loc, + Name => + New_Occurrence_Of (RTE (RE_TA_TC), Loc), + Parameter_Associations => New_List ( + TC_Node))); + end Add_TypeCode_Parameter; + + ------------------------ + -- Add_Long_Parameter -- + ------------------------ + + procedure Add_Long_Parameter + (Expr_Node : Node_Id; + Parameter_List : List_Id) + is + begin + Append_To (Parameter_List, + Make_Function_Call (Loc, + Name => + New_Occurrence_Of (RTE (RE_TA_LI), Loc), + Parameter_Associations => New_List (Expr_Node))); + end Add_Long_Parameter; + + ------------------------------- + -- Initialize_Parameter_List -- + ------------------------------- + + procedure Initialize_Parameter_List + (Name_String : String_Id; + Repo_Id_String : String_Id; + Parameter_List : out List_Id) + is + begin + Parameter_List := New_List; + Add_String_Parameter (Name_String, Parameter_List); + Add_String_Parameter (Repo_Id_String, Parameter_List); + end Initialize_Parameter_List; + + --------------------------- + -- Return_Alias_TypeCode -- + --------------------------- + + procedure Return_Alias_TypeCode + (Base_TypeCode : Node_Id) + is + begin + Add_TypeCode_Parameter (Base_TypeCode, Parameters); + Return_Constructed_TypeCode (RTE (RE_TC_Alias)); + end Return_Alias_TypeCode; + + ------------------------------- + -- Make_Constructed_TypeCode -- + ------------------------------- + + function Make_Constructed_TypeCode + (Kind : Entity_Id; + Parameters : List_Id) return Node_Id + is + Constructed_TC : constant Node_Id := + Make_Function_Call (Loc, + Name => + New_Occurrence_Of (RTE (RE_TC_Build), Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of (Kind, Loc), + Make_Aggregate (Loc, + Expressions => Parameters))); + begin + Set_Etype (Constructed_TC, RTE (RE_TypeCode)); + return Constructed_TC; + end Make_Constructed_TypeCode; - Set_Field (Name_Origin, - New_Occurrence_Of (Origin, Loc)), + --------------------------------- + -- Return_Constructed_TypeCode -- + --------------------------------- - 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)))), + procedure Return_Constructed_TypeCode (Kind : Entity_Id) is + begin + Append_To (Stms, + Make_Return_Statement (Loc, + Expression => + Make_Constructed_TypeCode (Kind, Parameters))); + end Return_Constructed_TypeCode; + + ------------------ + -- Record types -- + ------------------ + + procedure TC_Rec_Add_Process_Element + (Params : List_Id; + Any : Entity_Id; + Counter : in out Int; + Rec : Entity_Id; + Field : Node_Id); + + procedure TC_Append_Record_Traversal is + new Append_Record_Traversal ( + Rec => Empty, + Add_Process_Element => TC_Rec_Add_Process_Element); + + -------------------------------- + -- TC_Rec_Add_Process_Element -- + -------------------------------- + + procedure TC_Rec_Add_Process_Element + (Params : List_Id; + Any : Entity_Id; + Counter : in out Int; + Rec : Entity_Id; + Field : Node_Id) + is + pragma Warnings (Off); + pragma Unreferenced (Any, Counter, Rec); + pragma Warnings (On); - Set_Field (Name_Addr, New_Occurrence_Of (Proxy_Addr, Loc)), + begin + if Nkind (Field) = N_Defining_Identifier then - -- 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. + -- A regular component - -- Parameter Asynch_P is true when the procedure is asynchronous; - -- Expression Asynch_T is true when the type is asynchronous. + Add_TypeCode_Parameter ( + Build_TypeCode_Call (Loc, Etype (Field), Decls), Params); + Get_Name_String (Chars (Field)); + Add_String_Parameter (String_From_Name_Buffer, Params); - Set_Field (Name_Asynchronous, - Make_Or_Else (Loc, - New_Occurrence_Of (Asynch_P, Loc), - New_Occurrence_Of (Boolean_Literals ( - Is_Asynchronous (Ras_Type)), Loc)))); + else - Append_List_To (Proc_Statements, - Build_Get_Unique_RP_Call - (Loc, Stub_Ptr, Stub_Elements.Stub_Type)); + -- A variant part - -- Return the newly created value + declare + Discriminant_Type : constant Entity_Id := + Etype (Name (Field)); - Append_To (Proc_Statements, - Make_Return_Statement (Loc, - Expression => - Unchecked_Convert_To (Fat_Type, - New_Occurrence_Of (Stub_Ptr, Loc)))); + Is_Enum : constant Boolean := + Is_Enumeration_Type (Discriminant_Type); - 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)), + Union_TC_Params : List_Id; + + U_Name : constant Name_Id := + New_External_Name (Chars (Typ), 'U', -1); + + Name_Str : String_Id; + Struct_TC_Params : List_Id; + + Variant : Node_Id; + Choice : Node_Id; + Default : constant Node_Id := + Make_Integer_Literal (Loc, -1); + + Dummy_Counter : Int := 0; + + procedure Add_Params_For_Variant_Components; + -- Add a struct TypeCode and a corresponding member name + -- to the union parameter list. + + -- Ordering of declarations is a complete mess in this + -- area, it is supposed to be types/varibles, then + -- subprogram specs, then subprogram bodies ??? + + --------------------------------------- + -- Add_Params_For_Variant_Components -- + --------------------------------------- + + procedure Add_Params_For_Variant_Components + is + S_Name : constant Name_Id := + New_External_Name (U_Name, 'S', -1); + + begin + Get_Name_String (S_Name); + Name_Str := String_From_Name_Buffer; + Initialize_Parameter_List + (Name_Str, Name_Str, Struct_TC_Params); + + -- Build struct parameters + + TC_Append_Record_Traversal (Struct_TC_Params, + Component_List (Variant), + Empty, + Dummy_Counter); + + Add_TypeCode_Parameter + (Make_Constructed_TypeCode + (RTE (RE_TC_Struct), Struct_TC_Params), + Union_TC_Params); + + Add_String_Parameter (Name_Str, Union_TC_Params); + end Add_Params_For_Variant_Components; + + begin + Get_Name_String (U_Name); + Name_Str := String_From_Name_Buffer; + + Initialize_Parameter_List + (Name_Str, Name_Str, Union_TC_Params); + + Add_String_Parameter (Name_Str, Params); + + -- Add union in enclosing parameter list + + Add_TypeCode_Parameter + (Make_Constructed_TypeCode + (RTE (RE_TC_Union), Union_TC_Params), + Parameters); + + -- Build union parameters + + Add_TypeCode_Parameter + (Discriminant_Type, Union_TC_Params); + Add_Long_Parameter (Default, Union_TC_Params); + + Variant := First_Non_Pragma (Variants (Field)); + while Present (Variant) loop + Choice := First (Discrete_Choices (Variant)); + while Present (Choice) loop + case Nkind (Choice) is + when N_Range => + declare + L : constant Uint := + Expr_Value (Low_Bound (Choice)); + H : constant Uint := + Expr_Value (High_Bound (Choice)); + J : Uint := L; + -- 3.8.1(8) guarantees that the bounds of + -- this range are static. + + Expr : Node_Id; + + begin + while J <= H loop + if Is_Enum then + Expr := New_Occurrence_Of ( + Get_Enum_Lit_From_Pos ( + Discriminant_Type, J, Loc), Loc); + else + Expr := + Make_Integer_Literal (Loc, J); + end if; + Append_To (Union_TC_Params, + Build_To_Any_Call (Expr, Decls)); + Add_Params_For_Variant_Components; + J := J + Uint_1; + end loop; + end; + + when N_Others_Choice => + Add_Long_Parameter ( + Make_Integer_Literal (Loc, 0), + Union_TC_Params); + Add_Params_For_Variant_Components; + + when others => + Append_To (Union_TC_Params, + Build_To_Any_Call (Choice, Decls)); + Add_Params_For_Variant_Components; + + end case; + + end loop; + + Next_Non_Pragma (Variant); + end loop; + + end; + end if; + end TC_Rec_Add_Process_Element; - Make_Parameter_Specification (Loc, - Defining_Identifier => Subp_Id, - Parameter_Type => - New_Occurrence_Of (RTE (RE_Subprogram_Id), Loc)), + Type_Name_Str : String_Id; + Type_Repo_Id_Str : String_Id; - Make_Parameter_Specification (Loc, - Defining_Identifier => Asynch_P, - Parameter_Type => - New_Occurrence_Of (Standard_Boolean, Loc)), + begin + pragma Assert (not Is_Itype (Typ)); + Fnam := TCNam; - Make_Parameter_Specification (Loc, - Defining_Identifier => All_Calls_Remote, - Parameter_Type => - New_Occurrence_Of (Standard_Boolean, Loc))), + Spec := + Make_Function_Specification (Loc, + Defining_Unit_Name => Fnam, + Parameter_Specifications => Empty_List, + Subtype_Mark => New_Occurrence_Of (RTE (RE_TypeCode), Loc)); - Subtype_Mark => - New_Occurrence_Of (Fat_Type, Loc)); + Build_Name_And_Repository_Id (Typ, + Name_Str => Type_Name_Str, Repo_Id_Str => Type_Repo_Id_Str); + Initialize_Parameter_List + (Type_Name_Str, Type_Repo_Id_Str, Parameters); - -- Set the kind and return type of the function to prevent - -- ambiguities between Ras_Type and Fat_Type in subsequent analysis. + if Is_Derived_Type (Typ) + and then not Is_Tagged_Type (Typ) + then + declare + D_Node : constant Node_Id := Declaration_Node (Typ); + Parent_Type : Entity_Id := Etype (Typ); + begin - Set_Ekind (Proc, E_Function); - Set_Etype (Proc, Fat_Type); + if Is_Enumeration_Type (Typ) + and then Nkind (D_Node) = N_Subtype_Declaration + and then Nkind (Original_Node (D_Node)) + /= N_Subtype_Declaration + then - Discard_Node ( - Make_Subprogram_Body (Loc, - Specification => Proc_Spec, - Declarations => Proc_Decls, - Handled_Statement_Sequence => - Make_Handled_Sequence_Of_Statements (Loc, - Statements => Proc_Statements))); + -- Parent_Type is the implicit intermediate base type + -- created by Build_Derived_Enumeration_Type. - Set_TSS (Fat_Type, Proc); - end Add_RAS_Access_TSS; + Parent_Type := Etype (Parent_Type); + end if; - ----------------------- - -- Add_RAST_Features -- - ----------------------- + Return_Alias_TypeCode ( + Build_TypeCode_Call (Loc, Parent_Type, Decls)); + end; - 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; + elsif Is_Integer_Type (Typ) + or else Is_Unsigned_Type (Typ) + then + Return_Alias_TypeCode ( + Build_TypeCode_Call (Loc, + Find_Numeric_Representation (Typ), Decls)); - ------------ - -- Result -- - ------------ + elsif Is_Record_Type (Typ) + and then not Is_Tagged_Type (Typ) + then + if Nkind (Declaration_Node (Typ)) = N_Subtype_Declaration then + Return_Alias_TypeCode ( + Build_TypeCode_Call (Loc, Etype (Typ), Decls)); + else + declare + Disc : Entity_Id := Empty; + Rdef : constant Node_Id := + Type_Definition (Declaration_Node (Typ)); + Dummy_Counter : Int := 0; + begin + -- First all discriminants + + if Has_Discriminants (Typ) then + Disc := First_Discriminant (Typ); + end if; + while Present (Disc) loop + Add_TypeCode_Parameter ( + Build_TypeCode_Call (Loc, Etype (Disc), Decls), + Parameters); + Get_Name_String (Chars (Disc)); + Add_String_Parameter ( + String_From_Name_Buffer, + Parameters); + Next_Discriminant (Disc); + end loop; + + -- ... then all components + + TC_Append_Record_Traversal + (Parameters, Component_List (Rdef), + Empty, Dummy_Counter); + Return_Constructed_TypeCode (RTE (RE_TC_Struct)); + end; + end if; - function Result return Node_Id is - begin - return Make_Identifier (Loc, Name_V); - end Result; + elsif Is_Array_Type (Typ) then + declare + Ndim : constant Pos := Number_Dimensions (Typ); + Inner_TypeCode : Node_Id; + Constrained : constant Boolean := Is_Constrained (Typ); + Indx : Node_Id := First_Index (Typ); - ---------------------- - -- Stream_Parameter -- - ---------------------- + begin + Inner_TypeCode := Build_TypeCode_Call (Loc, + Component_Type (Typ), + Decls); + + for J in 1 .. Ndim loop + if Constrained then + Inner_TypeCode := Make_Constructed_TypeCode + (RTE (RE_TC_Array), New_List ( + Build_To_Any_Call ( + OK_Convert_To (RTE (RE_Long_Unsigned), + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Typ, Loc), + Attribute_Name => + Name_Length, + Expressions => New_List ( + Make_Integer_Literal (Loc, + Ndim - J + 1)))), + Decls), + Build_To_Any_Call (Inner_TypeCode, Decls))); + + else + -- Unconstrained case: add low bound for each + -- dimension. + + Add_TypeCode_Parameter + (Build_TypeCode_Call (Loc, Etype (Indx), Decls), + Parameters); + Get_Name_String (New_External_Name ('L', J)); + Add_String_Parameter ( + String_From_Name_Buffer, + Parameters); + Next_Index (Indx); + + Inner_TypeCode := Make_Constructed_TypeCode + (RTE (RE_TC_Sequence), New_List ( + Build_To_Any_Call ( + OK_Convert_To (RTE (RE_Long_Unsigned), + Make_Integer_Literal (Loc, 0)), + Decls), + Build_To_Any_Call (Inner_TypeCode, Decls))); + end if; + end loop; + + if Constrained then + Return_Alias_TypeCode (Inner_TypeCode); + else + Add_TypeCode_Parameter (Inner_TypeCode, Parameters); + Start_String; + Store_String_Char ('V'); + Add_String_Parameter (End_String, Parameters); + Return_Constructed_TypeCode (RTE (RE_TC_Struct)); + end if; + end; - function Stream_Parameter return Node_Id is - begin - return Make_Identifier (Loc, Name_S); - end Stream_Parameter; + else + -- Default: type is represented as an opaque sequence of bytes - end GARLIC_Support; + Return_Alias_TypeCode + (New_Occurrence_Of (RTE (RE_TC_Opaque), Loc)); + end if; - ------------------ - -- Get_PCS_Name -- - ------------------ + Decl := + Make_Subprogram_Body (Loc, + Specification => Spec, + Declarations => Decls, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Stms)); + end Build_TypeCode_Function; + + ------------------------ + -- Find_Inherited_TSS -- + ------------------------ + + function Find_Inherited_TSS + (Typ : Entity_Id; + Nam : Name_Id) return Entity_Id + is + P_Type : Entity_Id := Typ; + Proc : Entity_Id; - function Get_PCS_Name return PCS_Names is - PCS_Name : constant PCS_Names := - Chars (Entity (Expression (Parent (RTE (RE_DSA_Implementation))))); - begin - return PCS_Name; - end Get_PCS_Name; + begin + Proc := TSS (Base_Type (Typ), Nam); - ----------------------- - -- Get_Subprogram_Id -- - ----------------------- + -- Check first if there is a TSS given for the type itself - function Get_Subprogram_Id (Def : Entity_Id) return String_Id is - begin - return Get_Subprogram_Ids (Def).Str_Identifier; - end Get_Subprogram_Id; + if Present (Proc) then + return Proc; + end if; - ----------------------- - -- Get_Subprogram_Id -- - ----------------------- + -- If Typ is a derived type, it may inherit attributes from some + -- ancestor which is not the ultimate underlying one. If Typ is a + -- derived tagged type, The corresponding primitive operation has + -- been created explicitly. - function Get_Subprogram_Id (Def : Entity_Id) return Int is - begin - return Get_Subprogram_Ids (Def).Int_Identifier; - end Get_Subprogram_Id; + if Is_Derived_Type (P_Type) then + if Is_Tagged_Type (P_Type) then + return Find_Prim_Op (P_Type, Nam); + else + while Is_Derived_Type (P_Type) loop + Proc := TSS (Base_Type (Etype (Typ)), Nam); + + if Present (Proc) then + return Proc; + else + P_Type := Base_Type (Etype (P_Type)); + end if; + end loop; + end if; + end if; - ------------------------ - -- Get_Subprogram_Ids -- - ------------------------ + -- If nothing else, use the TSS of the root type - function Get_Subprogram_Ids - (Def : Entity_Id) return Subprogram_Identifiers - is - Result : Subprogram_Identifiers := - Subprogram_Identifier_Table.Get (Def); + return TSS (Base_Type (Underlying_Type (Typ)), Nam); + end Find_Inherited_TSS; - Current_Declaration : Node_Id; - Current_Subp : Entity_Id; - Current_Subp_Str : String_Id; - Current_Subp_Number : Int := First_RCI_Subprogram_Id; + --------------------------------- + -- Find_Numeric_Representation -- + --------------------------------- - begin - if Result.Str_Identifier = No_String then + function Find_Numeric_Representation (Typ : Entity_Id) + return Entity_Id + is + FST : constant Entity_Id := First_Subtype (Typ); + P_Size : constant Uint := Esize (FST); - -- 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. + begin + if Is_Unsigned_Type (Typ) then + if P_Size <= Standard_Short_Short_Integer_Size then + return RTE (RE_Short_Short_Unsigned); - pragma Assert - (Is_Remote_Call_Interface (Scope (Def)) - and then - (Nkind (Parent (Def)) = N_Procedure_Specification - or else - Nkind (Parent (Def)) = N_Function_Specification)); + elsif P_Size <= Standard_Short_Integer_Size then + return RTE (RE_Short_Unsigned); - Current_Declaration := - First (Visible_Declarations - (Package_Specification_Of_Scope (Scope (Def)))); - while Present (Current_Declaration) loop - if Nkind (Current_Declaration) = N_Subprogram_Declaration - and then Comes_From_Source (Current_Declaration) - then - Current_Subp := Defining_Unit_Name (Specification ( - Current_Declaration)); - Assign_Subprogram_Identifier - (Current_Subp, Current_Subp_Number, Current_Subp_Str); + elsif P_Size <= Standard_Integer_Size then + return RTE (RE_Unsigned); - if Current_Subp = Def then - Result := (Current_Subp_Str, Current_Subp_Number); + elsif P_Size <= Standard_Long_Integer_Size then + return RTE (RE_Long_Unsigned); + + else + return RTE (RE_Long_Long_Unsigned); end if; - Current_Subp_Number := Current_Subp_Number + 1; - end if; + elsif Is_Integer_Type (Typ) then + if P_Size <= Standard_Short_Short_Integer_Size then + return Standard_Short_Short_Integer; - Next (Current_Declaration); - end loop; - end if; + elsif P_Size <= Standard_Short_Integer_Size then + return Standard_Short_Integer; - pragma Assert (Result.Str_Identifier /= No_String); - return Result; - end Get_Subprogram_Ids; + elsif P_Size <= Standard_Integer_Size then + return Standard_Integer; - ---------- - -- Hash -- - ---------- + elsif P_Size <= Standard_Long_Integer_Size then + return Standard_Long_Integer; - function Hash (F : Entity_Id) return Hash_Index is - begin - return Hash_Index (Natural (F) mod Positive (Hash_Index'Last + 1)); - end Hash; + else + return Standard_Long_Long_Integer; + end if; - ---------- - -- Hash -- - ---------- + elsif Is_Floating_Point_Type (Typ) then + if P_Size <= Standard_Short_Float_Size then + return Standard_Short_Float; - function Hash (F : Name_Id) return Hash_Index is - begin - return Hash_Index (Natural (F) mod Positive (Hash_Index'Last + 1)); - end Hash; + elsif P_Size <= Standard_Float_Size then + return Standard_Float; - -------------------------- - -- Input_With_Tag_Check -- - -------------------------- + elsif P_Size <= Standard_Long_Float_Size then + return Standard_Long_Float; - function Input_With_Tag_Check - (Loc : Source_Ptr; - Var_Type : Entity_Id; - Stream : Entity_Id) return Node_Id - is - begin - return - Make_Subprogram_Body (Loc, - Specification => Make_Function_Specification (Loc, - Defining_Unit_Name => - Make_Defining_Identifier (Loc, New_Internal_Name ('S')), - Subtype_Mark => New_Occurrence_Of (Var_Type, Loc)), - Declarations => No_List, - Handled_Statement_Sequence => - Make_Handled_Sequence_Of_Statements (Loc, New_List ( - Make_Tag_Check (Loc, - Make_Return_Statement (Loc, - Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (Var_Type, Loc), - Attribute_Name => Name_Input, - Expressions => - New_List (New_Occurrence_Of (Stream, Loc)))))))); - end Input_With_Tag_Check; + else + return Standard_Long_Long_Float; + end if; - -------------------------------- - -- Is_RACW_Controlling_Formal -- - -------------------------------- + else + raise Program_Error; + end if; - function Is_RACW_Controlling_Formal - (Parameter : Node_Id; - Stub_Type : Entity_Id) return Boolean - is - Typ : Entity_Id; + -- TBD: fixed point types??? + -- TBverified numeric types with a biased representation??? - begin - -- If the kind of the parameter is E_Void, then it is not a - -- controlling formal (this can happen in the context of RAS). + end Find_Numeric_Representation; - if Ekind (Defining_Identifier (Parameter)) = E_Void then - return False; - end if; + --------------------------- + -- Append_Array_Traversal -- + --------------------------- - -- If the parameter is not a controlling formal, then it cannot - -- be possibly a RACW_Controlling_Formal. + procedure Append_Array_Traversal + (Stmts : List_Id; + Any : Entity_Id; + Counter : Entity_Id := Empty; + Depth : Pos := 1) + is + Loc : constant Source_Ptr := Sloc (Subprogram); + Typ : constant Entity_Id := Etype (Arry); + Constrained : constant Boolean := Is_Constrained (Typ); + Ndim : constant Pos := Number_Dimensions (Typ); - if not Is_Controlling_Formal (Defining_Identifier (Parameter)) then - return False; - end if; + Inner_Any, Inner_Counter : Entity_Id; - Typ := Parameter_Type (Parameter); - return (Nkind (Typ) = N_Access_Definition - and then Etype (Subtype_Mark (Typ)) = Stub_Type) - or else Etype (Typ) = Stub_Type; - end Is_RACW_Controlling_Formal; + Loop_Stm : Node_Id; + Inner_Stmts : constant List_Id := New_List; - -------------------- - -- Make_Tag_Check -- - -------------------- + begin + if Depth > Ndim then - function Make_Tag_Check (Loc : Source_Ptr; N : Node_Id) return Node_Id is - Occ : constant Entity_Id := - Make_Defining_Identifier (Loc, New_Internal_Name ('E')); + -- Processing for one element of an array - begin - return Make_Block_Statement (Loc, - Handled_Statement_Sequence => - Make_Handled_Sequence_Of_Statements (Loc, - Statements => New_List (N), + declare + Element_Expr : constant Node_Id := + Make_Indexed_Component (Loc, + New_Occurrence_Of (Arry, Loc), + Indices); - Exception_Handlers => New_List ( - Make_Exception_Handler (Loc, - Choice_Parameter => Occ, + begin + Set_Etype (Element_Expr, Component_Type (Typ)); + Add_Process_Element (Stmts, + Any => Any, + Counter => Counter, + Datum => Element_Expr); + end; - Exception_Choices => - New_List (New_Occurrence_Of (RTE (RE_Tag_Error), Loc)), + return; + end if; - Statements => - New_List (Make_Procedure_Call_Statement (Loc, - New_Occurrence_Of - (RTE (RE_Raise_Program_Error_Unknown_Tag), Loc), - New_List (New_Occurrence_Of (Occ, Loc)))))))); - end Make_Tag_Check; + Append_To (Indices, + Make_Identifier (Loc, New_External_Name ('L', Depth))); - ---------------------------- - -- Need_Extra_Constrained -- - ---------------------------- + if Constrained then + Inner_Any := Any; + Inner_Counter := Counter; + else + Inner_Any := Make_Defining_Identifier (Loc, + New_External_Name ('A', Depth)); + Set_Etype (Inner_Any, RTE (RE_Any)); - function Need_Extra_Constrained (Parameter : Node_Id) return Boolean is - Etyp : constant Entity_Id := Etype (Parameter_Type (Parameter)); - begin - return Out_Present (Parameter) - and then Has_Discriminants (Etyp) - and then not Is_Constrained (Etyp) - and then not Is_Indefinite_Subtype (Etyp); - end Need_Extra_Constrained; + if Present (Counter) then + Inner_Counter := Make_Defining_Identifier (Loc, + New_External_Name ('J', Depth)); + else + Inner_Counter := Empty; + end if; + end if; - ------------------------------------ - -- Pack_Entity_Into_Stream_Access -- - ------------------------------------ + Append_Array_Traversal (Inner_Stmts, + Any => Inner_Any, + Counter => Inner_Counter, + Depth => Depth + 1); + + Loop_Stm := + Make_Implicit_Loop_Statement (Subprogram, + Iteration_Scheme => + Make_Iteration_Scheme (Loc, + Loop_Parameter_Specification => + Make_Loop_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, + Chars => New_External_Name ('L', Depth)), - function Pack_Entity_Into_Stream_Access - (Loc : Source_Ptr; - Stream : Node_Id; - Object : Entity_Id; - Etyp : Entity_Id := Empty) return Node_Id - is - Typ : Entity_Id; + Discrete_Subtype_Definition => + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Arry, Loc), + Attribute_Name => Name_Range, - begin - if Present (Etyp) then - Typ := Etyp; - else - Typ := Etype (Object); - end if; + Expressions => New_List ( + Make_Integer_Literal (Loc, Depth))))), + Statements => Inner_Stmts); - return - Pack_Node_Into_Stream_Access (Loc, - Stream => Stream, - Object => New_Occurrence_Of (Object, Loc), - Etyp => Typ); - end Pack_Entity_Into_Stream_Access; + if Constrained then + Append_To (Stmts, Loop_Stm); + return; + end if; - --------------------------- - -- Pack_Node_Into_Stream -- - --------------------------- + declare + Decls : constant List_Id := New_List; + Dimen_Stmts : constant List_Id := New_List; + Length_Node : Node_Id; - function Pack_Node_Into_Stream - (Loc : Source_Ptr; - Stream : Entity_Id; - Object : Node_Id; - Etyp : Entity_Id) return Node_Id - is - Write_Attribute : Name_Id := Name_Write; + Inner_Any_TypeCode : constant Entity_Id := + Make_Defining_Identifier (Loc, + New_External_Name ('T', Depth)); - begin - if not Is_Constrained (Etyp) then - Write_Attribute := Name_Output; - end if; + Inner_Any_TypeCode_Expr : Node_Id; - return - Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (Etyp, Loc), - Attribute_Name => Write_Attribute, - Expressions => New_List ( - Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (Stream, Loc), - Attribute_Name => Name_Access), - Object)); - end Pack_Node_Into_Stream; + begin + if Depth = 1 then + Inner_Any_TypeCode_Expr := + Make_Function_Call (Loc, + Name => + New_Occurrence_Of (RTE (RE_Any_Member_Type), Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of (Any, Loc), + Make_Integer_Literal (Loc, Ndim))); + else + Inner_Any_TypeCode_Expr := + Make_Function_Call (Loc, + Name => + New_Occurrence_Of (RTE (RE_Content_Type), Loc), + Parameter_Associations => New_List ( + Make_Identifier (Loc, + New_External_Name ('T', Depth - 1)))); + end if; - ---------------------------------- - -- Pack_Node_Into_Stream_Access -- - ---------------------------------- + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Inner_Any_TypeCode, + Constant_Present => True, + Object_Definition => New_Occurrence_Of ( + RTE (RE_TypeCode), Loc), + Expression => Inner_Any_TypeCode_Expr)); + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Inner_Any, + Object_Definition => + New_Occurrence_Of (RTE (RE_Any), Loc), + Expression => + Make_Function_Call (Loc, + Name => + New_Occurrence_Of ( + RTE (RE_Create_Any), Loc), + Parameter_Associations => New_List ( + New_Occurrence_Of (Inner_Any_TypeCode, Loc))))); - function Pack_Node_Into_Stream_Access - (Loc : Source_Ptr; - Stream : Node_Id; - Object : Node_Id; - Etyp : Entity_Id) return Node_Id - is - Write_Attribute : Name_Id := Name_Write; + if Present (Inner_Counter) then + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Inner_Counter, + Object_Definition => + New_Occurrence_Of (RTE (RE_Long_Unsigned), Loc), + Expression => + Make_Integer_Literal (Loc, 0))); + end if; - begin - if not Is_Constrained (Etyp) then - Write_Attribute := Name_Output; - end if; + Length_Node := Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Arry, Loc), + Attribute_Name => Name_Length, + Expressions => + New_List (Make_Integer_Literal (Loc, Depth))); + Set_Etype (Length_Node, RTE (RE_Long_Unsigned)); - return - Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (Etyp, Loc), - Attribute_Name => Write_Attribute, - Expressions => New_List ( - Stream, - Object)); - end Pack_Node_Into_Stream_Access; + Add_Process_Element (Dimen_Stmts, + Datum => Length_Node, + Any => Inner_Any, + Counter => Inner_Counter); - --------------------- - -- PolyORB_Support -- - --------------------- + -- Loop_Stm does approrpriate processing for each element + -- of Inner_Any. - package body PolyORB_Support is + Append_To (Dimen_Stmts, Loop_Stm); - pragma Warnings (Off); - -- Currently, this package contains empty placeholders - -- that do not reference their parameters. + -- Link outer and inner any - ----------------------- - -- Add_RACW_Features -- - ----------------------- + Add_Process_Element (Dimen_Stmts, + Any => Any, + Counter => Counter, + Datum => New_Occurrence_Of (Inner_Any, Loc)); - 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 -- - ----------------------- + Append_To (Stmts, + Make_Block_Statement (Loc, + Declarations => + Decls, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Dimen_Stmts))); + end; + end Append_Array_Traversal; - procedure Add_RAST_Features - (Vis_Decl : Node_Id; - RAS_Type : Entity_Id; - Decls : List_Id) is - begin - raise Program_Error; - end Add_RAST_Features; + ----------------------------------------- + -- Make_Stream_Procedure_Function_Name -- + ----------------------------------------- - pragma Warnings (On); + function Make_Stream_Procedure_Function_Name + (Loc : Source_Ptr; + Typ : Entity_Id; + Nam : Name_Id) return Entity_Id + is + begin + -- For tagged types, we use a canonical name so that it matches + -- the primitive spec. For all other cases, we use a serialized + -- name so that multiple generations of the same procedure do not + -- clash. + if Is_Tagged_Type (Typ) then + return Make_Defining_Identifier (Loc, Nam); + else + return Make_Defining_Identifier (Loc, + Chars => + New_External_Name (Nam, ' ', Increment_Serial_Number)); + end if; + end Make_Stream_Procedure_Function_Name; + end Helpers; end PolyORB_Support; ------------------------------- @@ -4791,6 +9662,7 @@ package body Exp_Dist is Set_Ekind (Snam, E_Procedure); Set_Etype (Snam, Standard_Void_Type); end if; + Set_TSS (Typ, Snam); end Set_Renaming_TSS; @@ -4847,6 +9719,101 @@ package body Exp_Dist is end case; end Specific_Add_RAST_Features; + ------------------------------------------ + -- Specific_Build_General_Calling_Stubs -- + ------------------------------------------ + + procedure Specific_Build_General_Calling_Stubs + (Decls : List_Id; + Statements : List_Id; + Target : RPC_Target; + Subprogram_Id : Node_Id; + Asynchronous : Node_Id := Empty; + Is_Known_Asynchronous : Boolean := False; + Is_Known_Non_Asynchronous : Boolean := False; + Is_Function : Boolean; + Spec : Node_Id; + Stub_Type : Entity_Id := Empty; + RACW_Type : Entity_Id := Empty; + Nod : Node_Id) + is + begin + case Get_PCS_Name is + when Name_PolyORB_DSA => + PolyORB_Support.Build_General_Calling_Stubs ( + Decls, + Statements, + Target.Object, + Subprogram_Id, + Asynchronous, + Is_Known_Asynchronous, + Is_Known_Non_Asynchronous, + Is_Function, + Spec, + Stub_Type, + RACW_Type, + Nod); + when others => + GARLIC_Support.Build_General_Calling_Stubs ( + Decls, + Statements, + Target.Partition, + Target.RPC_Receiver, + Subprogram_Id, + Asynchronous, + Is_Known_Asynchronous, + Is_Known_Non_Asynchronous, + Is_Function, + Spec, + Stub_Type, + RACW_Type, + Nod); + end case; + end Specific_Build_General_Calling_Stubs; + + -------------------------------- + -- Specific_Build_Stub_Target -- + -------------------------------- + + function Specific_Build_Stub_Target + (Loc : Source_Ptr; + Decls : List_Id; + RCI_Locator : Entity_Id; + Controlling_Parameter : Entity_Id) return RPC_Target is + begin + case Get_PCS_Name is + when Name_PolyORB_DSA => + return PolyORB_Support.Build_Stub_Target (Loc, + Decls, RCI_Locator, Controlling_Parameter); + when others => + return GARLIC_Support.Build_Stub_Target (Loc, + Decls, RCI_Locator, Controlling_Parameter); + end case; + end Specific_Build_Stub_Target; + + ------------------------------ + -- Specific_Build_Stub_Type -- + ------------------------------ + + procedure Specific_Build_Stub_Type + (RACW_Type : Entity_Id; + Stub_Type : Entity_Id; + Stub_Type_Decl : out Node_Id; + RPC_Receiver_Decl : out Node_Id) + is + begin + case Get_PCS_Name is + when Name_PolyORB_DSA => + PolyORB_Support.Build_Stub_Type ( + RACW_Type, Stub_Type, + Stub_Type_Decl, RPC_Receiver_Decl); + when others => + GARLIC_Support.Build_Stub_Type ( + RACW_Type, Stub_Type, + Stub_Type_Decl, RPC_Receiver_Decl); + end case; + end Specific_Build_Stub_Type; + -------------------------- -- Underlying_RACW_Type -- -------------------------- diff --git a/gcc/ada/rtsfind.ads b/gcc/ada/rtsfind.ads index 14f8fc9bb39..04e32bb9133 100644 --- a/gcc/ada/rtsfind.ads +++ b/gcc/ada/rtsfind.ads @@ -1020,6 +1020,7 @@ package Rtsfind is RE_RCI_Locator, -- System.Partition_Interface RE_RCI_Subp_Info, -- System.Partition_Interface RE_RCI_Subp_Info_Array, -- System.Partition_Interface + RE_Same_Partition, -- System.Partition_Interface RE_Subprogram_Id, -- System.Partition_Interface RE_Get_RAS_Info, -- System.Partition_Interface @@ -1072,6 +1073,7 @@ package Rtsfind is RE_Entity_Of, -- System.PolyORB_Interface RE_Inc_Usage, -- System.PolyORB_Interface RE_Set_Ref, -- System.PolyORB_Interface + RE_Make_Ref, -- System.PolyORB_Interface RE_Get_Local_Address, -- System.PolyORB_Interface RE_Get_Reference, -- System.PolyORB_Interface RE_Local_Oid_To_Address, -- System.PolyORB_Interface @@ -2099,6 +2101,7 @@ package Rtsfind is RE_RCI_Locator => System_Partition_Interface, RE_RCI_Subp_Info => System_Partition_Interface, RE_RCI_Subp_Info_Array => System_Partition_Interface, + RE_Same_Partition => System_Partition_Interface, RE_Subprogram_Id => System_Partition_Interface, RE_Get_RAS_Info => System_Partition_Interface, @@ -2141,6 +2144,7 @@ package Rtsfind is RE_Entity_Of => System_PolyORB_Interface, RE_Inc_Usage => System_PolyORB_Interface, RE_Set_Ref => System_PolyORB_Interface, + RE_Make_Ref => System_PolyORB_Interface, RE_Get_Local_Address => System_PolyORB_Interface, RE_Get_Reference => System_PolyORB_Interface, RE_Local_Oid_To_Address => System_PolyORB_Interface, diff --git a/gcc/ada/s-parint.adb b/gcc/ada/s-parint.adb index cb9ee4f3c63..11c47cd1dfd 100644 --- a/gcc/ada/s-parint.adb +++ b/gcc/ada/s-parint.adb @@ -306,4 +306,18 @@ package body System.Partition_Interface is end if; end Run; + -------------------- + -- Same_Partition -- + -------------------- + + function Same_Partition + (Left : access RACW_Stub_Type; + Right : access RACW_Stub_Type) return Boolean + is + pragma Unreferenced (Left); + pragma Unreferenced (Right); + begin + return True; + end Same_Partition; + end System.Partition_Interface; diff --git a/gcc/ada/s-parint.ads b/gcc/ada/s-parint.ads index 7e47db17917..e1dab339172 100644 --- a/gcc/ada/s-parint.ads +++ b/gcc/ada/s-parint.ads @@ -96,6 +96,12 @@ package System.Partition_Interface is -- Use by the main subprogram to check that a remote receiver -- unit has has the same version than the caller's one. + function Same_Partition + (Left : access RACW_Stub_Type; + Right : access RACW_Stub_Type) return Boolean; + -- Determine whether Left and Right correspond to objects instantiated + -- on the same partition, for enforcement of E.4(19). + function Get_Active_Partition_ID (Name : Unit_Name) return RPC.Partition_ID; -- Similar in some respects to RCI_Locator.Get_Active_Partition_ID