[Ada] fixes for polyorb
Arnaud Charlet
charlet@adacore.com
Sat Apr 7 12:38:00 GMT 2007
Tested on i686-linux, committed on trunk
This patch fixes PolyORB support for private RCI parameters.
PolyORB helpers need to work with the underlying type when called
with private types. This caused a view inconsistency when the helpers
where called from the receiving and callind stubs (which use the private
type). This patch handles the conversion between the underlying and base
type for To_Any and From_Any helpers.
The code that generates bodies for primitive operations of RACW calling
stubs, and for RACW stream attributes, has been reorganized. We used to
always generate these bodies at the end of the package spec, but this
caused incorrect freezing attempts for Taft-amendment types. We now
generate these bodies in the package body when there is one, to avoid
this incorrect freezing.
This patch also defers registration of the receiving stubs until the
end of the elaboration of the RCI.
Thus an RCI unit cannot receive RPC calls before it is elaborated.
When running a distributed program with cyclic elaboration
dependencies, this makes the partitions deadlock. This is conformant
to AI-226.
Fixes a bug in polyORB helpers concerning unconstrained arrays types for
which the actual has a negative low bound.
The bound was mistakenly converted to an unsigned type, and a constraint
error was raised at run time.
This change also adds a missing guard in an expansion routine for the
PolyORB-based implementation of the distributed systems annex.
The following unit must compile quietly when using PolyORB/DSA:
$ gcc -c rt3.ads `polyorb-config --cflags`
with Ada.Streams; use Ada.Streams;
package RT3 is
pragma Remote_Types;
type L (D : Integer) is null record;
type Obj is abstract tagged limited private;
type RACW is access all Obj'Class;
procedure Proc1 (Self : Obj; Arg : L) is abstract;
private
type Obj is abstract tagged limited null record;
end RT3;
When preparing the object that contains the actual value for a parameter
in a server-side stubs, special processing needs to occur in the case
of limited types: we cannot use a 'Input call as an initialization
expression in the object declaration for the actual, because such
initialization is illegal in Ada 95. So, we use a renaming of the call
instead.
For the case of an in out formal, we provide a non-constant view of
the actual by overlaying an object declaration on the (constant)
renaming view.
The following source code must compile cleanly.
$ gcc -c rt.ads
with Ada.Streams; use Ada.Streams;
package RT1 is
pragma Remote_Types;
type L is limited private;
type A is array (Integer range <>) of L;
procedure Read (S : access Root_Stream_Type'Class; V : out A);
procedure Write (S : access Root_Stream_Type'Class; V : A);
for A'Read use Read;
for A'Write use Write;
private
type L is null record;
end RT1;
package body RT1 is
procedure Read (S : access Root_Stream_Type'Class; V : out A) is
begin
null;
end Read;
procedure Write (S : access Root_Stream_Type'Class; V : A) is
begin
null;
end Write;
end RT1;
with RT1; use RT1;
package RT is
pragma Remote_Types;
type Obj is abstract tagged limited private;
type RACW is access all Obj'Class;
procedure Proc1 (Self : Obj; Arg : A) is abstract;
procedure Proc2 (Self : Obj; Arg : in out A) is abstract;
procedure Proc3 (Self : Obj; Arg : out A) is abstract;
private
type Obj is abstract tagged limited null record;
end RT;
2007-04-06 Thomas Quinot <quinot@adacore.com>
* exp_dist.ads, exp_dist.adb (Build_To_Any_Call, Build_From_Any_Call):
Do an Unchecked_Conversion to handle the passage from the Underlying
Type to the Base Type when calling Build_To_Any_Call and
Build_From_Any_Call.
(Build_Actual_Object_Declaration): Set Object's Ekind to E_Variable or
E_Constant, depending upon Variable formal.
(GARLIC_Support.Build_Subprogram_Receiving_Stubs,
PolyORB_Support.Build_Subprogram_Receiving_Stubs): For a formal
parameter that requires an extra constrained parameter, declare
temporary for actual as a variable, not a constant.
(Add_RACW_Primitive_Declarations_And_Bodies): Generate bodies only when
the unit being compiled is the one that contains the stub type.
Change primitive operation name for the RACW associated with a RAS
from Call to _Call so it cannot clash with any legal identifier.
(PolyORB_Support.Add_RACW_Write_Attribute): Remove unused constant
Is_RAS.
(Append_RACW_Bodies): New subprogram.
(Expand_Receiving_Stubs_Bodies): Pass a 'Stmts' list to
Add_Receiving_Stubs_To_Declarations functions.
When expanding a package body, this list correspond to the
statements in the HSS at the end of the pacakge.
When expanding a package spec, this list correspond to the
spec declarations.
(Add_Receiving_Stubs_To_Declarations): Append the function
registering the receiving stubs at the end of the 'Stmts' list.
(RCI_Package_Locator): Pass the new Version generic formal when
instantiating a RCI_Locator package.
(Build_From_Any_Function): To compute the High bound for an
unconstrained array actual, we add the Low bound with the length.
Thus we must convert the low bound and the length to an appropriate
type before doing the sum.
(Build_Subprogram_Receiving_Stubs, PolyORB):
* Retrieve the extra formals parameters at the
end of the parameter stream.
* Use Move_Any_Value to write back out parameters
after executing the request as it is more efficient
than Copy_Any_Value.
* Build the any containing Extra Formals with the
appropriate typecode.
(PolyORB_Support.Helpers.Append_Record_Traversal): Nothing to do for an
empty Component_List.
(Build_Actual_Object_Declaration): New subprogram. Build and insert into
the tree the declaration for an object that serves as actual parameter
in server-side stubs.
(GARLIC_Support.Build_Subprogram_Receiving_Stubs,
PolyORB_Support.Build_Subprogram_Receiving_Stubs):
Use Build_Actual_Object_Declaration to prepare the actuals.
(Add_Parameter_To_NVList): Set the parameter mode to In for
Extra Constrained Parameters.
(Build_General_Calling_Stubs): Set the parameter type to boolean for
Extra Constrained parameters.
(Build_To_Any_Function, Build_From_Any_Function,
Built_TypeCode_Function): When Typ is implicit, call the correct
function with the first not implicit parent type.
(TC_Rec_Add_Process_Element, FA_Rec_Add_Process_Element,
(FA_Ary_Add_Process_Element): When Datum is an Any, we cannot infer the
typecode from the Etype. Therefore we retrieve the correct typecode
with a call to Get_Any_Type.
(Copy_Specification): Do controlling formal type substitution based on
Is_Controlling_Formal flag, instead of caller-provided object type.
(Build_Subprogram_Calling_Stubs): When retrieveing the original spec for
a RACW primitive operation, we might get a subprogram declaration for an
ancestor of the RACW designated type (not for the designated type
itself), in the case where this operation is inherited. In this case we
have no easy means of determining the original tagged type for which
the primitive was declared, so instead we now rely on
Copy_Specification to use the Is_Controlling_Formal flag to determine
which formals require type substitution.
-------------- next part --------------
Index: exp_dist.ads
===================================================================
--- exp_dist.ads (revision 123291)
+++ exp_dist.ads (working copy)
@@ -44,7 +44,7 @@ package Exp_Dist is
procedure Add_RACW_Primitive_Declarations_And_Bodies
(Designated_Type : Entity_Id;
Insertion_Node : Node_Id;
- Decls : List_Id);
+ Body_Decls : List_Id);
-- Add primitive for the stub type, and the RPC receiver. The declarations
-- are inserted after insertion_Node, while the bodies are appened at the
-- end of Decls.
@@ -86,21 +86,28 @@ package Exp_Dist is
function Copy_Specification
(Loc : Source_Ptr;
Spec : Node_Id;
- Object_Type : Entity_Id := Empty;
- Stub_Type : Entity_Id := Empty;
+ Ctrl_Type : Entity_Id := Empty;
New_Name : Name_Id := No_Name) return Node_Id;
- -- Build a subprogram specification from another one, or from
- -- an access-to-subprogram definition. If Object_Type is not Empty
- -- and any access to Object_Type is found, then it is replaced by an
- -- access to Stub_Type. If New_Name is given, then it will be used as
- -- the name for the newly created spec.
+ -- Build a subprogram specification from another one, or from an
+ -- access-to-subprogram definition. If Ctrl_Type is not Empty, and any
+ -- controlling formal of an anonymous access type is found, then it is
+ -- replaced by an access to Ctrl_Type. If New_Name is given, then it will
+ -- be used as the name for the newly created spec.
function Corresponding_Stub_Type (RACW_Type : Entity_Id) return Entity_Id;
-- Return the stub type associated with the given RACW type
- function Underlying_RACW_Type
- (RAS_Typ : Entity_Id) return Entity_Id;
+ function Underlying_RACW_Type (RAS_Typ : Entity_Id) return Entity_Id;
-- Given a remote access-to-subprogram type or its equivalent
-- record type, return the RACW type generated to implement it.
+ procedure Append_RACW_Bodies (Decls : List_Id; Spec_Id : Entity_Id);
+ -- Append the unanalyzed subprogram bodies generated to support RACWs
+ -- declared in the given package spec (RACW stream subprograms, calling
+ -- stubs primitive operations) to the given list (which is expected to be
+ -- the declarations list for the corresponding package body, if there is
+ -- one). In the case where a body is present, the subprogram bodies must
+ -- not be generated in the package spec because this would cause an
+ -- incorrect attempt to freeze Taft amendment types declared in the spec.
+
end Exp_Dist;
Index: exp_dist.adb
===================================================================
--- exp_dist.adb (revision 123291)
+++ exp_dist.adb (working copy)
@@ -292,30 +292,53 @@ package body Exp_Dist is
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.
+ -- 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.
+
+ --------------------
+ -- Stub_Structure --
+ --------------------
+
+ -- This record describes various tree fragments associated with the
+ -- generation of RACW calling stubs. One such record exists for every
+ -- distributed object type, i.e. each tagged type that is the designated
+ -- type of one or more RACW type.
type Stub_Structure is record
Stub_Type : Entity_Id;
+ -- Stub type: this type has the same primitive operations as the
+ -- designated types, but the provided bodies for these operations
+ -- a remote call to an actual target object potentially located on
+ -- another partition; each value of the stub type encapsulates a
+ -- reference to a remote object.
+
Stub_Type_Access : Entity_Id;
+ -- A local access type designating the stub type (this is not an RACW
+ -- type).
+
RPC_Receiver_Decl : Node_Id;
+ -- Declaration for the RPC receiver entity associated with the
+ -- designated type. As an exception, for the case of an RACW that
+ -- implements a RAS, no object RPC receiver is generated. Instead,
+ -- RPC_Receiver_Decl is the declaration after which the RPC receiver
+ -- would have been inserted.
+
+ Body_Decls : List_Id;
+ -- List of subprogram bodies to be included in generated code: bodies
+ -- for the RACW's stream attributes, and for the primitive operations
+ -- of the stub type.
+
RACW_Type : Entity_Id;
+ -- One of the RACW types designating this distributed object type
+ -- (they are all interchangeable; we use any one of them in order to
+ -- avoid having to create various anonymous access types).
+
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
- -- designated type. RACW_Type is any of the RACW types pointing on this
- -- designated type, it is used here to save an anonymous type creation
- -- for each primitive operation.
- --
- -- For a RACW that implements a RAS, no object RPC receiver is generated.
- -- Instead, RPC_Receiver_Decl is the declaration after which the
- -- RPC receiver would have been inserted.
Empty_Stub_Structure : constant Stub_Structure :=
- (Empty, Empty, Empty, Empty);
+ (Empty, Empty, Empty, No_List, Empty);
package Stubs_Table is
new Simple_HTable (Header_Num => Hash_Index,
@@ -362,12 +385,17 @@ package body Exp_Dist is
Stub_Type : out Entity_Id;
Stub_Type_Access : out Entity_Id;
RPC_Receiver_Decl : out Node_Id;
+ Body_Decls : out List_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
-- anyhow and Existing is set to True.
+ function Get_And_Reset_RACW_Bodies (RACW_Type : Entity_Id) return List_Id;
+ -- Retrieve the Body_Decls list associated to RACW_Type in the stub
+ -- structure table, reset it to No_List, and return the previous value.
+
procedure Add_RACW_Asynchronous_Flag
(Declarations : List_Id;
RACW_Type : Entity_Id);
@@ -413,6 +441,19 @@ package body Exp_Dist is
-- Exception_Message (E));
-- end R;
+ procedure Build_Actual_Object_Declaration
+ (Object : Entity_Id;
+ Etyp : Entity_Id;
+ Variable : Boolean;
+ Expr : Node_Id;
+ Decls : List_Id);
+ -- Build the declaration of an object with the given defining identifier,
+ -- initialized with Expr if provided, to serve as actual parameter in a
+ -- server stub. If Variable is true, the declared object will be a variable
+ -- (case of an out or in out formal), else it will be a constant. Object's
+ -- Ekind is set accordingly. The declaration, as well as any other
+ -- declarations it requires, are appended to Decls.
+
--------------------------------------------
-- Hooks for PCS-specific code generation --
--------------------------------------------
@@ -429,10 +470,10 @@ package body Exp_Dist is
Stub_Type : Entity_Id;
Stub_Type_Access : Entity_Id;
RPC_Receiver_Decl : Node_Id;
- Declarations : List_Id);
+ Body_Decls : List_Id);
-- Add declaration for TSSs for a given RACW type. The declarations are
-- added just after the declaration of the RACW type itself, while the
- -- bodies are inserted at the end of Decls. Runtime-specific ancillary
+ -- bodies are inserted at the end of Body_Decls. Runtime-specific ancillary
-- subprogram for Add_RACW_Features.
procedure Specific_Add_RAST_Features
@@ -556,7 +597,8 @@ package body Exp_Dist is
procedure Specific_Add_Receiving_Stubs_To_Declarations
(Pkg_Spec : Node_Id;
- Decls : List_Id);
+ Decls : List_Id;
+ Stmts : List_Id);
-- Add receiving stubs to the declarative part of an RCI unit
package GARLIC_Support is
@@ -572,7 +614,7 @@ package body Exp_Dist is
Stub_Type : Entity_Id;
Stub_Type_Access : Entity_Id;
RPC_Receiver_Decl : Node_Id;
- Declarations : List_Id);
+ Body_Decls : List_Id);
procedure Add_RAST_Features
(Vis_Decl : Node_Id;
@@ -621,7 +663,8 @@ package body Exp_Dist is
procedure Add_Receiving_Stubs_To_Declarations
(Pkg_Spec : Node_Id;
- Decls : List_Id);
+ Decls : List_Id;
+ Stmts : List_Id);
procedure Build_RPC_Receiver_Body
(RPC_Receiver : Entity_Id;
@@ -647,7 +690,7 @@ package body Exp_Dist is
Stub_Type : Entity_Id;
Stub_Type_Access : Entity_Id;
RPC_Receiver_Decl : Node_Id;
- Declarations : List_Id);
+ Body_Decls : List_Id);
procedure Add_RAST_Features
(Vis_Decl : Node_Id;
@@ -695,7 +738,8 @@ package body Exp_Dist is
procedure Add_Receiving_Stubs_To_Declarations
(Pkg_Spec : Node_Id;
- Decls : List_Id);
+ Decls : List_Id;
+ Stmts : List_Id);
procedure Build_RPC_Receiver_Body
(RPC_Receiver : Entity_Id;
@@ -956,12 +1000,18 @@ package body Exp_Dist is
Parameter_Name_String := String_From_Name_Buffer;
- if RACW_Ctrl then
- Parameter_Mode := New_Occurrence_Of
- (RTE (RE_Mode_In), Loc);
+ if RACW_Ctrl or else Nkind (Parameter) = N_Defining_Identifier then
+
+ -- When the parameter passed to Add_Parameter_To_NVList is an
+ -- Extra_Constrained parameter, Parameter is an N_Defining_
+ -- Identifier, instead of a complete N_Parameter_Specification.
+ -- Thus, we explicitly set 'in' mode in this case.
+
+ Parameter_Mode := New_Occurrence_Of (RTE (RE_Mode_In), Loc);
+
else
Parameter_Mode := Parameter_Passing_Mode (Loc,
- Parameter, Constrained);
+ Parameter, Constrained);
end if;
return
@@ -1017,7 +1067,10 @@ package body Exp_Dist is
procedure Add_RACW_Features (RACW_Type : Entity_Id) is
Desig : constant Entity_Id := Etype (Designated_Type (RACW_Type));
Same_Scope : constant Boolean := Scope (Desig) = Scope (RACW_Type);
+
+ Pkg_Spec : Node_Id;
Decls : List_Id;
+ Body_Decls : List_Id;
Stub_Type : Entity_Id;
Stub_Type_Access : Entity_Id;
@@ -1034,28 +1087,38 @@ package body Exp_Dist is
return;
end if;
- -- Look for declarations
+ -- Mark the current package declaration as containing an RACW, so that
+ -- the bodies for the calling stubs and the RACW stream subprograms
+ -- are attached to the tree when the corresponding body is encountered.
+
+ Set_Has_RACW (Current_Scope);
- -- Case of declaring a RACW in the same package than its designated
- -- type, so the list to use for late declarations must be the private
- -- part of the package. We do know that this private part exists since
- -- the designated type has to be a private one.
+ -- Look for place to declare the RACW stub type and RACW operations
+
+ Pkg_Spec := Empty;
if Same_Scope then
- Decls := Private_Declarations
- (Package_Specification_Of_Scope (Current_Scope));
+ -- Case of declaring the RACW in the same package as its designated
+ -- type: we know that the designated type is a private type, so we
+ -- use the private declarations list.
- -- Comment here???
+ Pkg_Spec := Package_Specification_Of_Scope (Current_Scope);
+
+ if Present (Private_Declarations (Pkg_Spec)) then
+ Decls := Private_Declarations (Pkg_Spec);
+ else
+ Decls := Visible_Declarations (Pkg_Spec);
+ end if;
else
+
+ -- Case of declaring the RACW in another package than its designated
+ -- type: use the private declarations list if present; otherwise
+ -- use the visible declarations.
+
Decls := List_Containing (Declaration_Node (RACW_Type));
- if Nkind (Parent (Decls)) = N_Package_Specification
- and then Present (Private_Declarations (Parent (Decls)))
- then
- Decls := Private_Declarations (Parent (Decls));
- end if;
end if;
-- If we were unable to find the declarations, that means that the
@@ -1073,6 +1136,7 @@ package body Exp_Dist is
Stub_Type => Stub_Type,
Stub_Type_Access => Stub_Type_Access,
RPC_Receiver_Decl => RPC_Receiver_Decl,
+ Body_Decls => Body_Decls,
Existing => Existing);
Add_RACW_Asynchronous_Flag
@@ -1085,19 +1149,19 @@ package body Exp_Dist is
Stub_Type => Stub_Type,
Stub_Type_Access => Stub_Type_Access,
RPC_Receiver_Decl => RPC_Receiver_Decl,
- Declarations => Decls);
+ Body_Decls => Body_Decls);
if not Same_Scope and then not Existing then
-- The RACW has been declared in another scope than the designated
-- type and has not been handled by another RACW in the same package
- -- as the first one, so add primitive for the stub type here.
+ -- as the first one, so add primitives for the stub type here.
Validate_RACW_Primitives (RACW_Type);
Add_RACW_Primitive_Declarations_And_Bodies
(Designated_Type => Desig,
Insertion_Node => RPC_Receiver_Decl,
- Decls => Decls);
+ Body_Decls => Body_Decls);
else
-- Validate_RACW_Primitives will be called when the designated type
@@ -1115,7 +1179,7 @@ package body Exp_Dist is
procedure Add_RACW_Primitive_Declarations_And_Bodies
(Designated_Type : Entity_Id;
Insertion_Node : Node_Id;
- Decls : List_Id)
+ Body_Decls : List_Id)
is
Loc : constant Source_Ptr := Sloc (Insertion_Node);
-- Set Sloc of generated declaration copy of insertion node Sloc, so
@@ -1128,6 +1192,13 @@ package body Exp_Dist is
Is_RAS : constant Boolean :=
not Comes_From_Source (Stub_Elements.RACW_Type);
+ -- Case of the RACW generated to implement a remote access-to-
+ -- subprogram type.
+
+ Build_Bodies : constant Boolean :=
+ In_Extended_Main_Code_Unit (Stub_Elements.Stub_Type);
+ -- True when bodies must be prepared in Body_Decls. Bodies are generated
+ -- only when the main unit is the unit that contains the stub type.
Current_Insertion_Node : Node_Id := Insertion_Node;
@@ -1215,18 +1286,27 @@ package body Exp_Dist is
Current_Primitive_Alias := Alias (Current_Primitive_Alias);
end loop;
+ -- Copy the spec from the original declaration for the purpose
+ -- of declaring an overriding subprogram: we need to replace
+ -- the type of each controlling formal with Stub_Type. The
+ -- primitive may have been declared for Designated_Type or
+ -- inherited from some ancestor type for which we do not have
+ -- an easily determined Entity_Id. We have no systematic way
+ -- of knowing which type to substitute Stub_Type for. Instead,
+ -- Copy_Specification relies on the flag Is_Controlling_Formal
+ -- to determine which formals to change.
+
Current_Primitive_Spec :=
Copy_Specification (Loc,
Spec => Parent (Current_Primitive_Alias),
- Object_Type => Designated_Type,
- Stub_Type => Stub_Elements.Stub_Type);
+ Ctrl_Type => Stub_Elements.Stub_Type);
Current_Primitive_Decl :=
Make_Subprogram_Declaration (Loc,
Specification => Current_Primitive_Spec);
- Insert_After (Current_Insertion_Node, Current_Primitive_Decl);
- Analyze (Current_Primitive_Decl);
+ Insert_After_And_Analyze (Current_Insertion_Node,
+ Current_Primitive_Decl);
Current_Insertion_Node := Current_Primitive_Decl;
Possibly_Asynchronous :=
@@ -1238,26 +1318,30 @@ package body Exp_Dist is
Current_Primitive_Number,
Subp_Str);
- Current_Primitive_Body :=
- Build_Subprogram_Calling_Stubs
- (Vis_Decl => Current_Primitive_Decl,
- Subp_Id =>
- Build_Subprogram_Id (Loc,
- Defining_Unit_Name (Current_Primitive_Spec)),
- Asynchronous => Possibly_Asynchronous,
- Dynamically_Asynchronous => Possibly_Asynchronous,
- Stub_Type => Stub_Elements.Stub_Type,
- RACW_Type => Stub_Elements.RACW_Type);
- Append_To (Decls, Current_Primitive_Body);
-
- -- Analyzing the body here would cause the Stub type to be
- -- frozen, thus preventing subsequent primitive declarations.
- -- For this reason, it will be analyzed later in the regular
- -- flow.
+ if Build_Bodies then
+ Current_Primitive_Body :=
+ Build_Subprogram_Calling_Stubs
+ (Vis_Decl => Current_Primitive_Decl,
+ Subp_Id =>
+ Build_Subprogram_Id (Loc,
+ Defining_Unit_Name (Current_Primitive_Spec)),
+ Asynchronous => Possibly_Asynchronous,
+ Dynamically_Asynchronous => Possibly_Asynchronous,
+ Stub_Type => Stub_Elements.Stub_Type,
+ RACW_Type => Stub_Elements.RACW_Type);
+ Append_To (Body_Decls, Current_Primitive_Body);
+
+ -- Analyzing the body here would cause the Stub type to be
+ -- frozen, thus preventing subsequent primitive
+ -- declarations. For this reason, it will be analyzed later
+ -- in the regular flow (and in the context of the
+ -- appropriate unit body, see Append_RACW_Bodies).
+
+ end if;
-- Build the receiver stubs
- if not Is_RAS then
+ if Build_Bodies and then not Is_RAS then
Current_Receiver_Body :=
Specific_Build_Subprogram_Receiving_Stubs
(Vis_Decl => Current_Primitive_Decl,
@@ -1270,7 +1354,7 @@ package body Exp_Dist is
Current_Receiver := Defining_Unit_Name (
Specification (Current_Receiver_Body));
- Append_To (Decls, Current_Receiver_Body);
+ Append_To (Body_Decls, Current_Receiver_Body);
-- Add a case alternative to the receiver
@@ -1318,7 +1402,7 @@ package body Exp_Dist is
-- Build the case statement and the heart of the subprogram
- if not Is_RAS then
+ if Build_Bodies and then not Is_RAS then
if Get_PCS_Name = Name_PolyORB_DSA
and then Present (First (RPC_Receiver_Elsif_Parts))
then
@@ -1340,15 +1424,15 @@ package body Exp_Dist is
New_Occurrence_Of (RPC_Receiver_Subp_Index, Loc),
Alternatives => RPC_Receiver_Case_Alternatives));
- Append_To (Decls, RPC_Receiver_Decl);
+ Append_To (Body_Decls, RPC_Receiver_Decl);
Specific_Add_Obj_RPC_Receiver_Completion (Loc,
- Decls, RPC_Receiver, Stub_Elements);
- end if;
+ Body_Decls, RPC_Receiver, Stub_Elements);
- -- Do not analyze RPC receiver at this stage since it will otherwise
- -- reference subprograms that have not been analyzed yet. It will be
- -- analyzed in the regular flow.
+ -- Do not analyze RPC receiver body at this stage since it references
+ -- subprograms that have not been analyzed yet. It will be analyzed in
+ -- the regular flow (see Append_RACW_Bodies).
+ end if;
end Add_RACW_Primitive_Declarations_And_Bodies;
-----------------------------
@@ -1468,9 +1552,10 @@ package body Exp_Dist is
Unchecked_Convert_To (RACW_Type,
New_Occurrence_Of (RAS_Parameter, Loc)));
- RACW_Primitive_Name := Make_Selected_Component (Loc,
- Prefix => Scope (RACW_Type),
- Selector_Name => Name_Call);
+ RACW_Primitive_Name :=
+ Make_Selected_Component (Loc,
+ Prefix => Scope (RACW_Type),
+ Selector_Name => Name_uCall);
end if;
if Is_Function then
@@ -1478,15 +1563,13 @@ package body Exp_Dist is
Make_Return_Statement (Loc,
Expression =>
Make_Function_Call (Loc,
- Name =>
- RACW_Primitive_Name,
- Parameter_Associations => Param_Assoc)));
+ Name => RACW_Primitive_Name,
+ Parameter_Associations => Param_Assoc)));
else
Append_To (Stmts,
Make_Procedure_Call_Statement (Loc,
- Name =>
- RACW_Primitive_Name,
+ Name => RACW_Primitive_Name,
Parameter_Associations => Param_Assoc));
end if;
@@ -1619,8 +1702,8 @@ package body Exp_Dist is
Build_Remote_Subprogram_Proxy_Type (Loc,
New_Occurrence_Of (All_Calls_Remote_E, Loc))));
- -- Trick semantic analysis into swapping the public and
- -- full view when freezing the public view.
+ -- Trick semantic analysis into swapping the public and full view when
+ -- freezing the public view.
Set_Comes_From_Source (Proxy_Type_Full_View, True);
@@ -1745,6 +1828,7 @@ package body Exp_Dist is
Stub_Type : out Entity_Id;
Stub_Type_Access : out Entity_Id;
RPC_Receiver_Decl : out Node_Id;
+ Body_Decls : out List_Id;
Existing : out Boolean)
is
Loc : constant Source_Ptr := Sloc (RACW_Type);
@@ -1759,6 +1843,7 @@ package body Exp_Dist is
Stub_Type := Stub_Elements.Stub_Type;
Stub_Type_Access := Stub_Elements.Stub_Type_Access;
RPC_Receiver_Decl := Stub_Elements.RPC_Receiver_Decl;
+ Body_Decls := Stub_Elements.Body_Decls;
Existing := True;
return;
end if;
@@ -1789,9 +1874,9 @@ package body Exp_Dist is
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
- -- primitive operations at the right place.
+ -- This is in no way a type derivation, but we fake it to make sure that
+ -- the dispatching table gets built with the corresponding primitive
+ -- operations at the right place.
Derive_Subprograms (Parent_Type => Designated_Type,
Derived_Type => Stub_Type);
@@ -1802,13 +1887,34 @@ package body Exp_Dist is
RPC_Receiver_Decl := Last (Decls);
end if;
+ Body_Decls := New_List;
+
Stubs_Table.Set (Designated_Type,
(Stub_Type => Stub_Type,
Stub_Type_Access => Stub_Type_Access,
RPC_Receiver_Decl => RPC_Receiver_Decl,
+ Body_Decls => Body_Decls,
RACW_Type => RACW_Type));
end Add_Stub_Type;
+ ------------------------
+ -- Append_RACW_Bodies --
+ ------------------------
+
+ procedure Append_RACW_Bodies (Decls : List_Id; Spec_Id : Entity_Id) is
+ E : Entity_Id;
+
+ begin
+ E := First_Entity (Spec_Id);
+ while Present (E) loop
+ if Is_Remote_Access_To_Class_Wide_Type (E) then
+ Append_List_To (Decls, Get_And_Reset_RACW_Bodies (E));
+ end if;
+
+ Next_Entity (E);
+ end loop;
+ end Append_RACW_Bodies;
+
----------------------------------
-- Assign_Subprogram_Identifier --
----------------------------------
@@ -1844,6 +1950,126 @@ package body Exp_Dist is
Subprogram_Identifiers'(Str_Identifier => Id, Int_Identifier => Spn));
end Assign_Subprogram_Identifier;
+ -------------------------------------
+ -- Build_Actual_Object_Declaration --
+ -------------------------------------
+
+ procedure Build_Actual_Object_Declaration
+ (Object : Entity_Id;
+ Etyp : Entity_Id;
+ Variable : Boolean;
+ Expr : Node_Id;
+ Decls : List_Id)
+ is
+ Loc : constant Source_Ptr := Sloc (Object);
+ begin
+ -- Declare a temporary object for the actual, possibly initialized with
+ -- a 'Input/From_Any call.
+
+ -- Complication arises in the case of limited types, for which such a
+ -- declaration is illegal in Ada 95. In that case, we first generate a
+ -- renaming declaration of the 'Input call, and then if needed we
+ -- generate an overlaid non-constant view.
+
+ if Ada_Version <= Ada_95
+ and then Is_Limited_Type (Etyp)
+ and then Present (Expr)
+ then
+
+ -- Object : Etyp renames <func-call>
+
+ Append_To (Decls,
+ Make_Object_Renaming_Declaration (Loc,
+ Defining_Identifier => Object,
+ Subtype_Mark => New_Occurrence_Of (Etyp, Loc),
+ Name => Expr));
+
+ if Variable then
+
+ -- The name defined by the renaming declaration denotes a
+ -- constant view; create a non-constant object at the same address
+ -- to be used as the actual.
+
+ declare
+ Constant_Object : constant Entity_Id :=
+ Make_Defining_Identifier (Loc,
+ New_Internal_Name ('P'));
+ begin
+ Set_Defining_Identifier
+ (Last (Decls), Constant_Object);
+
+ -- We have an unconstrained Etyp: build the actual constrained
+ -- subtype for the value we just read from the stream.
+
+ -- suubtype S is <actual subtype of Constant_Object>;
+
+ Append_To (Decls,
+ Build_Actual_Subtype (Etyp,
+ New_Occurrence_Of (Constant_Object, Loc)));
+
+ -- Object : S;
+
+ Append_To (Decls,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Object,
+ Object_Definition =>
+ New_Occurrence_Of
+ (Defining_Identifier (Last (Decls)), Loc)));
+ Set_Ekind (Object, E_Variable);
+
+ -- Suppress default initialization:
+ -- pragma Import (Ada, Object);
+
+ Append_To (Decls,
+ Make_Pragma (Loc,
+ Chars => Name_Import,
+ Pragma_Argument_Associations => New_List (
+ Make_Pragma_Argument_Association (Loc,
+ Chars => Name_Convention,
+ Expression => Make_Identifier (Loc, Name_Ada)),
+ Make_Pragma_Argument_Association (Loc,
+ Chars => Name_Entity,
+ Expression => New_Occurrence_Of (Object, Loc)))));
+
+ -- for Object'Address use Constant_Object'Address;
+
+ Append_To (Decls,
+ Make_Attribute_Definition_Clause (Loc,
+ Name => New_Occurrence_Of (Object, Loc),
+ Chars => Name_Address,
+ Expression =>
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ New_Occurrence_Of (Constant_Object, Loc),
+ Attribute_Name =>
+ Name_Address)));
+ end;
+ end if;
+
+ else
+
+ -- General case of a regular object declaration. Object is flagged
+ -- constant unless it has mode out or in out, to allow the backend
+ -- to optimize where possible.
+
+ -- Object : [constant] Etyp [:= <expr>];
+
+ Append_To (Decls,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Object,
+ Constant_Present => Present (Expr) and then not Variable,
+ Object_Definition =>
+ New_Occurrence_Of (Etyp, Loc),
+ Expression => Expr));
+
+ if Constant_Present (Last (Decls)) then
+ Set_Ekind (Object, E_Constant);
+ else
+ Set_Ekind (Object, E_Variable);
+ end if;
+ end if;
+ end Build_Actual_Object_Declaration;
+
------------------------------
-- Build_Get_Unique_RP_Call --
------------------------------
@@ -2270,8 +2496,7 @@ package body Exp_Dist is
function Copy_Specification
(Loc : Source_Ptr;
Spec : Node_Id;
- Object_Type : Entity_Id := Empty;
- Stub_Type : Entity_Id := Empty;
+ Ctrl_Type : Entity_Id := Empty;
New_Name : Name_Id := No_Name) return Node_Id
is
Parameters : List_Id := No_List;
@@ -2279,7 +2504,6 @@ package body Exp_Dist is
Current_Parameter : Node_Id;
Current_Identifier : Entity_Id;
Current_Type : Node_Id;
- Current_Etype : Entity_Id;
Name_For_New_Spec : Name_Id;
@@ -2305,14 +2529,11 @@ package body Exp_Dist is
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));
+ if Present (Ctrl_Type) then
+ pragma Assert (Is_Controlling_Formal (Current_Identifier));
Current_Type :=
Make_Access_Definition (Loc,
- Subtype_Mark => New_Occurrence_Of (Stub_Type, Loc),
+ Subtype_Mark => New_Occurrence_Of (Ctrl_Type, Loc),
Null_Exclusion_Present =>
Null_Exclusion_Present (Current_Type));
@@ -2320,20 +2541,18 @@ package body Exp_Dist is
Current_Type :=
Make_Access_Definition (Loc,
Subtype_Mark =>
- New_Occurrence_Of (Current_Etype, Loc),
+ New_Copy_Tree (Subtype_Mark (Current_Type)),
Null_Exclusion_Present =>
- Null_Exclusion_Present (Current_Type));
+ Null_Exclusion_Present (Current_Type));
end if;
else
- Current_Etype := Entity (Current_Type);
-
- if Present (Object_Type)
- and then Current_Etype = Object_Type
+ if Present (Ctrl_Type)
+ and then Is_Controlling_Formal (Current_Identifier)
then
- Current_Type := New_Occurrence_Of (Stub_Type, Loc);
+ Current_Type := New_Occurrence_Of (Ctrl_Type, Loc);
else
- Current_Type := New_Occurrence_Of (Current_Etype, Loc);
+ Current_Type := New_Copy_Tree (Current_Type);
end if;
end if;
@@ -2556,15 +2775,17 @@ package body Exp_Dist is
end if;
New_Scope (Scope_Of_Spec (Spec));
- Specific_Add_Receiving_Stubs_To_Declarations (Spec, Decls);
-
+ Specific_Add_Receiving_Stubs_To_Declarations
+ (Spec, Decls, 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;
- Specific_Add_Receiving_Stubs_To_Declarations (Spec, Temp);
+ Specific_Add_Receiving_Stubs_To_Declarations
+ (Spec, Temp, Statements (Handled_Statement_Sequence (Unit_Node)));
Insert_List_Before (First (Decls), Temp);
end if;
@@ -2583,28 +2804,28 @@ package body Exp_Dist is
(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.
+ Body_Decls : List_Id);
+ -- Add Read attribute for the RACW type. The declaration and attribute
+ -- definition clauses are inserted right after the declaration of
+ -- RACW_Type, while the subprogram body is appended to Body_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
+ Body_Decls : List_Id);
+ -- Same as above 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.
+ -- 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).
+ -- 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
@@ -2621,11 +2842,11 @@ package body Exp_Dist is
begin
-- The RPC receiver body should not be the completion of the
-- declaration recorded in the stub structure, because then the
- -- occurrences of the formal parameters within the body should
- -- refer to the entities from the declaration, not from the
- -- completion, to which we do not have easy access. Instead, the
- -- RPC receiver body acts as its own declaration, and the RPC
- -- receiver declaration is completed by a renaming-as-body.
+ -- occurrences of the formal parameters within the body should refer
+ -- to the entities from the declaration, not from the completion, to
+ -- which we do not have easy access. Instead, the RPC receiver body
+ -- acts as its own declaration, and the RPC receiver declaration is
+ -- completed by a renaming-as-body.
Append_To (Decls,
Make_Subprogram_Renaming_Declaration (Loc,
@@ -2644,7 +2865,7 @@ package body Exp_Dist is
Stub_Type : Entity_Id;
Stub_Type_Access : Entity_Id;
RPC_Receiver_Decl : Node_Id;
- Declarations : List_Id)
+ Body_Decls : List_Id)
is
RPC_Receiver : Node_Id;
Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type);
@@ -2654,9 +2875,9 @@ package body Exp_Dist is
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.
+ -- 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 =>
@@ -2675,13 +2896,13 @@ package body Exp_Dist is
Stub_Type,
Stub_Type_Access,
RPC_Receiver,
- Declarations);
+ Body_Decls);
Add_RACW_Read_Attribute (
RACW_Type,
Stub_Type,
Stub_Type_Access,
- Declarations);
+ Body_Decls);
end Add_RACW_Features;
-----------------------------
@@ -2692,7 +2913,7 @@ package body Exp_Dist is
(RACW_Type : Entity_Id;
Stub_Type : Entity_Id;
Stub_Type_Access : Entity_Id;
- Declarations : List_Id)
+ Body_Decls : List_Id)
is
Proc_Decl : Node_Id;
Attr_Decl : Node_Id;
@@ -2858,16 +3079,15 @@ package body Exp_Dist is
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.
+ -- ??? 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,
@@ -2909,7 +3129,7 @@ package body Exp_Dist is
Insert_After (Declaration_Node (RACW_Type), Proc_Decl);
Insert_After (Proc_Decl, Attr_Decl);
- Append_To (Declarations, Body_Node);
+ Append_To (Body_Decls, Body_Node);
end Add_RACW_Read_Attribute;
------------------------------
@@ -2921,7 +3141,7 @@ package body Exp_Dist is
Stub_Type : Entity_Id;
Stub_Type_Access : Entity_Id;
RPC_Receiver : Node_Id;
- Declarations : List_Id)
+ Body_Decls : List_Id)
is
Body_Node : Node_Id;
Proc_Decl : Node_Id;
@@ -3052,7 +3272,7 @@ package body Exp_Dist is
Insert_After (Declaration_Node (RACW_Type), Proc_Decl);
Insert_After (Proc_Decl, Attr_Decl);
- Append_To (Declarations, Body_Node);
+ Append_To (Body_Decls, Body_Node);
end Add_RACW_Write_Attribute;
------------------------
@@ -3346,7 +3566,8 @@ package body Exp_Dist is
procedure Add_Receiving_Stubs_To_Declarations
(Pkg_Spec : Node_Id;
- Decls : List_Id)
+ Decls : List_Id;
+ Stmts : List_Id)
is
Loc : constant Source_Ptr := Sloc (Pkg_Spec);
@@ -3710,12 +3931,12 @@ package body Exp_Dist is
Attribute_Name =>
Name_Length));
- Append_To (Decls,
+ Append_To (Stmts,
Make_Procedure_Call_Statement (Loc,
Name =>
New_Occurrence_Of (RTE (RE_Register_Receiving_Stub), Loc),
Parameter_Associations => Register_Pkg_Actuals));
- Analyze (Last (Decls));
+ Analyze (Last (Stmts));
end Add_Receiving_Stubs_To_Declarations;
---------------------------------
@@ -4378,8 +4599,11 @@ package body Exp_Dist is
is
Loc : constant Source_Ptr := Sloc (Vis_Decl);
- Request_Parameter : Node_Id;
- -- ???
+ Request_Parameter : constant Entity_Id :=
+ Make_Defining_Identifier (Loc,
+ New_Internal_Name ('R'));
+ -- Formal parameter for receiving stubs: a descriptor for an incoming
+ -- request.
Decls : constant List_Id := New_List;
-- All the parameters will get declared before calling the real
@@ -4422,17 +4646,13 @@ package body Exp_Dist is
begin
if Present (RACW_Type) then
- Called_Subprogram :=
- New_Occurrence_Of (Parent_Primitive, Loc);
+ Called_Subprogram := New_Occurrence_Of (Parent_Primitive, Loc);
else
Called_Subprogram :=
- New_Occurrence_Of (
- Defining_Unit_Name (Specification (Vis_Decl)), Loc);
+ New_Occurrence_Of
+ (Defining_Unit_Name (Specification (Vis_Decl)), Loc);
end if;
- Request_Parameter :=
- Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
-
if Dynamically_Asynchronous then
Dynamic_Async :=
Make_Defining_Identifier (Loc, New_Internal_Name ('S'));
@@ -4443,7 +4663,7 @@ package body Exp_Dist is
if not Asynchronous or Dynamically_Asynchronous then
-- The first statement after the subprogram call is a statement to
- -- writes a Null_Occurrence into the result stream.
+ -- write a Null_Occurrence into the result stream.
Null_Raise_Statement :=
Make_Attribute_Reference (Loc,
@@ -4477,19 +4697,20 @@ package body Exp_Dist is
Etyp : Entity_Id;
Constrained : Boolean;
+ Need_Extra_Constrained : Boolean;
+ -- True when an Extra_Constrained actual is required
+
Object : constant Entity_Id :=
Make_Defining_Identifier (Loc,
New_Internal_Name ('P'));
- Expr : Node_Id := Empty;
+ Expr : Node_Id := Empty;
Is_Controlling_Formal : constant Boolean :=
Is_RACW_Controlling_Formal
(Current_Parameter, Stub_Type);
begin
- Set_Ekind (Object, E_Variable);
-
if Is_Controlling_Formal then
-- We have a controlling formal parameter. Read its address
@@ -4530,30 +4751,44 @@ package body Exp_Dist is
New_Occurrence_Of (Object, Loc))));
else
- Expr := Input_With_Tag_Check (Loc,
- Var_Type => Etyp,
- Stream => Make_Selected_Component (Loc,
- Prefix => Request_Parameter,
- Selector_Name => Name_Params));
- Append_To (Decls, Expr);
+
+ -- Build and append Input_With_Tag_Check function
+
+ Append_To (Decls,
+ Input_With_Tag_Check (Loc,
+ Var_Type => Etyp,
+ Stream => Make_Selected_Component (Loc,
+ Prefix => Request_Parameter,
+ Selector_Name => Name_Params)));
+
+ -- Prepare function call expression
+
Expr := Make_Function_Call (Loc,
New_Occurrence_Of (Defining_Unit_Name
- (Specification (Expr)), Loc));
+ (Specification (Last (Decls))), Loc));
end if;
end if;
- -- If we do not have to output the current parameter, then it
- -- can well be flagged as constant. This may allow further
- -- optimizations done by the back end.
-
- Append_To (Decls,
- Make_Object_Declaration (Loc,
- Defining_Identifier => Object,
- Constant_Present => not Constrained
- and then not Out_Present (Current_Parameter),
- Object_Definition =>
- New_Occurrence_Of (Etyp, Loc),
- Expression => Expr));
+ Need_Extra_Constrained :=
+ 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)));
+
+ -- We may not associate an extra constrained actual to a
+ -- constant object, so if one is needed, declare the actual
+ -- as a variable even if it won't be modified.
+
+ Build_Actual_Object_Declaration
+ (Object => Object,
+ Etyp => Etyp,
+ Variable => Need_Extra_Constrained
+ or else Out_Present (Current_Parameter),
+ Expr => Expr,
+ Decls => Decls);
-- An out parameter may be written back using a 'Write
-- attribute instead of a 'Output because it has been
@@ -4626,14 +4861,7 @@ package body Exp_Dist is
-- 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
+ if Need_Extra_Constrained then
declare
Extra_Parameter : constant Entity_Id :=
Extra_Constrained
@@ -4664,6 +4892,11 @@ package body Exp_Dist is
Prefix => Request_Parameter,
Selector_Name => Name_Params),
New_Occurrence_Of (Formal_Entity, Loc))));
+
+ -- Note: the call to Set_Extra_Constrained below relies
+ -- on the fact that Object's Ekind has been set by
+ -- Build_Actual_Object_Declaration.
+
Set_Extra_Constrained (Object, Formal_Entity);
end;
end if;
@@ -4752,7 +4985,7 @@ package body Exp_Dist is
-- For an asynchronous procedure, add a null exception handler
Excep_Handlers := New_List (
- Make_Exception_Handler (Loc,
+ Make_Implicit_Exception_Handler (Loc,
Exception_Choices => New_List (Make_Others_Choice (Loc)),
Statements => New_List (Make_Null_Statement (Loc))));
@@ -4784,7 +5017,7 @@ package body Exp_Dist is
end if;
Excep_Handlers := New_List (
- Make_Exception_Handler (Loc,
+ Make_Implicit_Exception_Handler (Loc,
Choice_Parameter => Excep_Choice,
Exception_Choices => New_List (Make_Others_Choice (Loc)),
Statements => Excep_Code));
@@ -4832,20 +5065,31 @@ package body Exp_Dist is
end GARLIC_Support;
- -----------------------------
- -- Make_Selected_Component --
- -----------------------------
+ -------------------------------
+ -- Get_And_Reset_RACW_Bodies --
+ -------------------------------
+
+ function Get_And_Reset_RACW_Bodies (RACW_Type : Entity_Id) return List_Id is
+ Desig : constant Entity_Id := Etype (Designated_Type (RACW_Type));
+ Stub_Elements : Stub_Structure := Stubs_Table.Get (Desig);
+
+ Body_Decls : List_Id;
+ -- Returned list of declarations
- function Make_Selected_Component
- (Loc : Source_Ptr;
- Prefix : Entity_Id;
- Selector_Name : Name_Id) return Node_Id
- is
begin
- return Make_Selected_Component (Loc,
- Prefix => New_Occurrence_Of (Prefix, Loc),
- Selector_Name => Make_Identifier (Loc, Selector_Name));
- end Make_Selected_Component;
+ if Stub_Elements = Empty_Stub_Structure then
+
+ -- Stub elements may be missing as a consequence of a previously
+ -- detected error.
+
+ return No_List;
+ end if;
+
+ Body_Decls := Stub_Elements.Body_Decls;
+ Stub_Elements.Body_Decls := No_List;
+ Stubs_Table.Set (Desig, Stub_Elements);
+ return Body_Decls;
+ end Get_And_Reset_RACW_Bodies;
-----------------------
-- Get_Subprogram_Id --
@@ -4951,6 +5195,21 @@ package body Exp_Dist is
or else Etype (Typ) = Stub_Type;
end Is_RACW_Controlling_Formal;
+ -----------------------------
+ -- Make_Selected_Component --
+ -----------------------------
+
+ function Make_Selected_Component
+ (Loc : Source_Ptr;
+ Prefix : Entity_Id;
+ Selector_Name : Name_Id) return Node_Id
+ is
+ begin
+ return Make_Selected_Component (Loc,
+ Prefix => New_Occurrence_Of (Prefix, Loc),
+ Selector_Name => Make_Identifier (Loc, Selector_Name));
+ end Make_Selected_Component;
+
--------------------
-- Make_Tag_Check --
--------------------
@@ -4966,7 +5225,7 @@ package body Exp_Dist is
Statements => New_List (N),
Exception_Handlers => New_List (
- Make_Exception_Handler (Loc,
+ Make_Implicit_Exception_Handler (Loc,
Choice_Parameter => Occ,
Exception_Choices =>
@@ -5084,23 +5343,23 @@ package body Exp_Dist is
(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.
+ Body_Decls : List_Id);
+ -- Add Read attribute for the RACW type. The declaration and attribute
+ -- definition clauses are inserted right after the declaration of
+ -- RACW_Type, while the subprogram body is appended to Body_Decls.
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
+ Body_Decls : List_Id);
+ -- Same as above 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);
+ Body_Decls : List_Id);
-- Add the From_Any TSS for this RACW type
procedure Add_RACW_To_Any
@@ -5108,13 +5367,13 @@ package body Exp_Dist is
RACW_Type : Entity_Id;
Stub_Type : Entity_Id;
Stub_Type_Access : Entity_Id;
- Declarations : List_Id);
+ Body_Decls : 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);
+ Body_Decls : List_Id);
-- Add the TypeCode TSS for this RACW type
procedure Add_RAS_From_Any (RAS_Type : Entity_Id);
@@ -5185,7 +5444,7 @@ package body Exp_Dist is
Stub_Type : Entity_Id;
Stub_Type_Access : Entity_Id;
RPC_Receiver_Decl : Node_Id;
- Declarations : List_Id)
+ Body_Decls : List_Id)
is
pragma Warnings (Off);
pragma Unreferenced (RPC_Receiver_Decl);
@@ -5196,35 +5455,35 @@ package body Exp_Dist is
(RACW_Type => RACW_Type,
Stub_Type => Stub_Type,
Stub_Type_Access => Stub_Type_Access,
- Declarations => Declarations);
+ Body_Decls => Body_Decls);
Add_RACW_To_Any
(Designated_Type => Desig,
RACW_Type => RACW_Type,
Stub_Type => Stub_Type,
Stub_Type_Access => Stub_Type_Access,
- Declarations => Declarations);
+ Body_Decls => Body_Decls);
- -- 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.
+ -- 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);
+ Body_Decls => Body_Decls);
Add_RACW_Read_Attribute
(RACW_Type => RACW_Type,
Stub_Type => Stub_Type,
Stub_Type_Access => Stub_Type_Access,
- Declarations => Declarations);
+ Body_Decls => Body_Decls);
Add_RACW_TypeCode
(Designated_Type => Desig,
RACW_Type => RACW_Type,
- Declarations => Declarations);
+ Body_Decls => Body_Decls);
end Add_RACW_Features;
-----------------------
@@ -5235,7 +5494,7 @@ package body Exp_Dist is
(RACW_Type : Entity_Id;
Stub_Type : Entity_Id;
Stub_Type_Access : Entity_Id;
- Declarations : List_Id)
+ Body_Decls : List_Id)
is
Loc : constant Source_Ptr := Sloc (RACW_Type);
Is_RAS : constant Boolean := not Comes_From_Source (RACW_Type);
@@ -5274,8 +5533,8 @@ package body Exp_Dist is
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
+ -- 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 :=
@@ -5283,6 +5542,7 @@ package body Exp_Dist is
-- The flag object declared in Add_RACW_Asynchronous_Flag
begin
+
-- Object declarations
Decls := New_List (
@@ -5385,16 +5645,15 @@ package body Exp_Dist is
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.
+ -- ??? 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));
@@ -5449,9 +5708,8 @@ package body Exp_Dist is
New_Occurrence_Of (RTE (RE_Any), Loc))),
Result_Definition => 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.
+ -- 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);
@@ -5465,7 +5723,7 @@ package body Exp_Dist is
Statements => Statements));
Insert_After (Declaration_Node (RACW_Type), Func_Decl);
- Append_To (Declarations, Func_Body);
+ Append_To (Body_Decls, Func_Body);
Set_Renaming_TSS (RACW_Type, Fnam, TSS_From_Any);
end Add_RACW_From_Any;
@@ -5478,7 +5736,7 @@ package body Exp_Dist is
(RACW_Type : Entity_Id;
Stub_Type : Entity_Id;
Stub_Type_Access : Entity_Id;
- Declarations : List_Id)
+ Body_Decls : List_Id)
is
pragma Warnings (Off);
pragma Unreferenced (Stub_Type, Stub_Type_Access);
@@ -5576,7 +5834,7 @@ package body Exp_Dist is
Insert_After (Declaration_Node (RACW_Type), Proc_Decl);
Insert_After (Proc_Decl, Attr_Decl);
- Append_To (Declarations, Body_Node);
+ Append_To (Body_Decls, Body_Node);
end Add_RACW_Read_Attribute;
---------------------
@@ -5588,7 +5846,7 @@ package body Exp_Dist is
RACW_Type : Entity_Id;
Stub_Type : Entity_Id;
Stub_Type_Access : Entity_Id;
- Declarations : List_Id)
+ Body_Decls : List_Id)
is
Loc : constant Source_Ptr := Sloc (RACW_Type);
@@ -5623,6 +5881,7 @@ package body Exp_Dist is
(Loc, New_Internal_Name ('A'));
begin
+
-- Object declarations
Decls := New_List (
@@ -5644,8 +5903,8 @@ package body Exp_Dist is
if Is_RAS then
- -- If the object is a RAS designating a local subprogram,
- -- we already have a target reference.
+ -- 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,
@@ -5660,8 +5919,8 @@ package body Exp_Dist is
Selector_Name => Make_Identifier (Loc, Name_Target)))));
else
- -- If the object is a local RACW object, use Get_Reference now
- -- to obtain a reference.
+ -- 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,
@@ -5683,8 +5942,8 @@ package body Exp_Dist is
New_Occurrence_Of (Reference, Loc))));
end if;
- -- If the object is located on another partition, use the target
- -- from the stub.
+ -- If the object is located on another partition, use the target from
+ -- the stub.
Stub_Statements := New_List (
Make_Procedure_Call_Statement (Loc,
@@ -5698,8 +5957,8 @@ package body Exp_Dist is
Selector_Name =>
Make_Identifier (Loc, Name_Target)))));
- -- Distinguish between the null, local and remote cases,
- -- and execute the appropriate piece of code.
+ -- Distinguish between the null, local and remote cases, and execute
+ -- the appropriate piece of code.
If_Node :=
Make_Implicit_If_Statement (RACW_Type,
@@ -5763,9 +6022,8 @@ package body Exp_Dist is
New_Occurrence_Of (RACW_Type, Loc))),
Result_Definition => 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.
+ -- 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);
@@ -5779,7 +6037,7 @@ package body Exp_Dist is
Statements => Statements));
Insert_After (Declaration_Node (RACW_Type), Func_Decl);
- Append_To (Declarations, Func_Body);
+ Append_To (Body_Decls, Func_Body);
Set_Renaming_TSS (RACW_Type, Fnam, TSS_To_Any);
end Add_RACW_To_Any;
@@ -5791,7 +6049,7 @@ package body Exp_Dist is
procedure Add_RACW_TypeCode
(Designated_Type : Entity_Id;
RACW_Type : Entity_Id;
- Declarations : List_Id)
+ Body_Decls : List_Id)
is
Loc : constant Source_Ptr := Sloc (RACW_Type);
@@ -5810,8 +6068,8 @@ package body Exp_Dist is
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.
+ -- The spec for this subprogram has a dummy 'access RACW' argument,
+ -- which serves only for overloading purposes.
Func_Spec :=
Make_Function_Specification (Loc,
@@ -5819,9 +6077,8 @@ package body Exp_Dist is
Fnam,
Result_Definition => 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.
+ -- 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);
@@ -5842,7 +6099,7 @@ package body Exp_Dist is
Selector_Name => Name_Obj_TypeCode)))));
Insert_After (Declaration_Node (RACW_Type), Func_Decl);
- Append_To (Declarations, Func_Body);
+ Append_To (Body_Decls, Func_Body);
Set_Renaming_TSS (RACW_Type, Fnam, TSS_TypeCode);
end Add_RACW_TypeCode;
@@ -5855,18 +6112,14 @@ package body Exp_Dist is
(RACW_Type : Entity_Id;
Stub_Type : Entity_Id;
Stub_Type_Access : Entity_Id;
- Declarations : List_Id)
+ Body_Decls : 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 Unreferenced (Stub_Type, Stub_Type_Access);
pragma Warnings (On);
+ Loc : constant Source_Ptr := Sloc (RACW_Type);
+
Body_Node : Node_Id;
Proc_Decl : Node_Id;
Attr_Decl : Node_Id;
@@ -5915,7 +6168,7 @@ package body Exp_Dist is
New_Occurrence_Of (RTE (RE_FA_ObjRef), Loc),
Parameter_Associations => New_List (
PolyORB_Support.Helpers.Build_To_Any_Call
- (Object, Declarations))),
+ (Object, Body_Decls))),
Etyp => RTE (RE_Object_Ref)));
Build_Stream_Procedure
@@ -5937,7 +6190,7 @@ package body Exp_Dist is
Insert_After (Declaration_Node (RACW_Type), Proc_Decl);
Insert_After (Proc_Decl, Attr_Decl);
- Append_To (Declarations, Body_Node);
+ Append_To (Body_Decls, Body_Node);
end Add_RACW_Write_Attribute;
-----------------------
@@ -6480,7 +6733,8 @@ package body Exp_Dist is
procedure Add_Receiving_Stubs_To_Declarations
(Pkg_Spec : Node_Id;
- Decls : List_Id)
+ Decls : List_Id;
+ Stmts : List_Id)
is
Loc : constant Source_Ptr := Sloc (Pkg_Spec);
@@ -6932,12 +7186,12 @@ package body Exp_Dist is
-- Is_All_Calls_Remote
New_Occurrence_Of (All_Calls_Remote_E, Loc));
- Append_To (Decls,
+ Append_To (Stmts,
Make_Procedure_Call_Statement (Loc,
Name =>
New_Occurrence_Of (RTE (RE_Register_Pkg_Receiving_Stub), Loc),
Parameter_Associations => Register_Pkg_Actuals));
- Analyze (Last (Decls));
+ Analyze (Last (Stmts));
end Add_Receiving_Stubs_To_Declarations;
@@ -7226,7 +7480,14 @@ package body Exp_Dist is
Make_Defining_Identifier
(Loc, New_Internal_Name ('P'));
+ Parameter_Exp : constant Node_Id :=
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Occurrence_Of (
+ Defining_Identifier (Current_Parameter), Loc),
+ Attribute_Name => Name_Constrained);
begin
+ Set_Etype (Parameter_Exp, Etype (Standard_Boolean));
+
Append_To (Decls,
Make_Object_Declaration (Loc,
Defining_Identifier =>
@@ -7236,12 +7497,9 @@ package body Exp_Dist is
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),
+ Parameter_Exp,
Decls)));
+
Append_To (Extra_Formal_Statements,
Add_Parameter_To_NVList (Loc,
Parameter => Extra_Any_Parameter,
@@ -7524,8 +7782,11 @@ package body Exp_Dist is
is
Loc : constant Source_Ptr := Sloc (Vis_Decl);
- Request_Parameter : Node_Id;
- -- ???
+ Request_Parameter : constant Entity_Id :=
+ Make_Defining_Identifier (Loc,
+ New_Internal_Name ('R'));
+ -- Formal parameter for receiving stubs: a descriptor for an incoming
+ -- request.
Outer_Decls : constant List_Id := New_List;
-- At the outermost level, an NVList and Any's are declared for all
@@ -7536,6 +7797,10 @@ package body Exp_Dist is
-- Statements that occur prior to the declaration of the actual
-- parameter variables.
+ Outer_Extra_Formal_Statements : constant List_Id := New_List;
+ -- Statements concerning extra formal parameters, prior to the
+ -- declaration of the actual parameter variables.
+
Decls : constant List_Id := New_List;
-- All the parameters will get declared before calling the real
-- subprograms. Also the out parameters will be declared.
@@ -7543,9 +7808,6 @@ package body Exp_Dist is
Statements : constant List_Id := New_List;
- Extra_Formal_Statements : constant List_Id := New_List;
- -- Statements concerning extra formal parameters
-
After_Statements : constant List_Id := New_List;
-- Statements to be executed after the subprogram call
@@ -7566,7 +7828,9 @@ package body Exp_Dist is
Build_Ordered_Parameters_List
(Specification (Vis_Decl));
- Arguments : Node_Id;
+ Arguments : constant Entity_Id :=
+ Make_Defining_Identifier (Loc,
+ New_Internal_Name ('A'));
-- Name of the named values list used to retrieve parameters
Subp_Spec : Node_Id;
@@ -7585,11 +7849,6 @@ package body Exp_Dist is
Defining_Unit_Name (Specification (Vis_Decl)), Loc);
end if;
- Request_Parameter :=
- Make_Defining_Identifier (Loc, New_Internal_Name ('R'));
-
- Arguments :=
- Make_Defining_Identifier (Loc, New_Internal_Name ('A'));
Declare_Create_NVList (Loc, Arguments, Outer_Decls, Outer_Statements);
-- Loop through every parameter and get its value from the stream. If
@@ -7611,9 +7870,11 @@ package body Exp_Dist is
:= Is_RACW_Controlling_Formal (Current_Parameter, Stub_Type);
Is_First_Controlling_Formal : Boolean := False;
- begin
- Set_Ekind (Object, E_Variable);
+ Need_Extra_Constrained : Boolean;
+ -- True when an extra constrained actual is required
+
+ begin
if Is_Controlling_Formal then
-- Controlling formals in distributed object primitive
@@ -7670,9 +7931,9 @@ package body Exp_Dist is
New_Internal_Name ('L'));
begin
- -- Special case: obtain the first controlling
- -- formal from the target of the remote call,
- -- instead of the argument list.
+ -- Special case: obtain the first controlling formal
+ -- from the target of the remote call, instead of the
+ -- argument list.
Append_To (Outer_Decls,
Make_Object_Declaration (Loc,
@@ -7719,7 +7980,6 @@ package body Exp_Dist is
Etyp, New_Occurrence_Of (Any, Loc), Decls);
if Constrained then
-
Append_To (Statements,
Make_Assignment_Statement (Loc,
Name =>
@@ -7735,18 +7995,26 @@ package body Exp_Dist is
end if;
- -- If we do not have to output the current parameter, then
- -- it can well be flagged as constant. This may allow further
- -- optimizations done by the back end.
-
- Append_To (Decls,
- Make_Object_Declaration (Loc,
- Defining_Identifier => Object,
- Constant_Present => not Constrained
- and then not Out_Present (Current_Parameter),
- Object_Definition =>
- New_Occurrence_Of (Etyp, Loc),
- Expression => Expr));
+ Need_Extra_Constrained :=
+ 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)));
+
+ -- We may not associate an extra constrained actual to a
+ -- constant object, so if one is needed, declare the actual
+ -- as a variable even if it won't be modified.
+
+ Build_Actual_Object_Declaration
+ (Object => Object,
+ Etyp => Etyp,
+ Variable => Need_Extra_Constrained
+ or else Out_Present (Current_Parameter),
+ Expr => Expr,
+ Decls => Decls);
Set_Etype (Object, Etyp);
-- An out parameter may be written back using a 'Write
@@ -7762,7 +8030,7 @@ package body Exp_Dist is
Append_To (After_Statements,
Make_Procedure_Call_Statement (Loc,
Name =>
- New_Occurrence_Of (RTE (RE_Copy_Any_Value), Loc),
+ New_Occurrence_Of (RTE (RE_Move_Any_Value), Loc),
Parameter_Associations => New_List (
New_Occurrence_Of (Any, Loc),
PolyORB_Support.Helpers.Build_To_Any_Call (
@@ -7819,14 +8087,7 @@ package body Exp_Dist is
-- 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
+ if Need_Extra_Constrained then
declare
Extra_Parameter : constant Entity_Id :=
Extra_Constrained
@@ -7835,6 +8096,7 @@ package body Exp_Dist is
Extra_Any : constant Entity_Id :=
Make_Defining_Identifier
(Loc, New_Internal_Name ('A'));
+
Formal_Entity : constant Entity_Id :=
Make_Defining_Identifier
(Loc, Chars (Extra_Parameter));
@@ -7847,9 +8109,16 @@ package body Exp_Dist is
Defining_Identifier =>
Extra_Any,
Object_Definition =>
- New_Occurrence_Of (RTE (RE_Any), Loc)));
+ New_Occurrence_Of (RTE (RE_Any), Loc),
+ Expression =>
+ Make_Function_Call (Loc,
+ Name =>
+ New_Occurrence_Of (RTE (RE_Create_Any), Loc),
+ Parameter_Associations => New_List (
+ PolyORB_Support.Helpers.Build_TypeCode_Call
+ (Loc, Formal_Type, Outer_Decls)))));
- Append_To (Outer_Statements,
+ Append_To (Outer_Extra_Formal_Statements,
Add_Parameter_To_NVList (Loc,
Parameter => Extra_Parameter,
NVList => Arguments,
@@ -7862,17 +8131,16 @@ package body Exp_Dist is
Object_Definition =>
New_Occurrence_Of (Formal_Type, Loc)));
- Append_To (Extra_Formal_Statements,
+ Append_To (Statements,
Make_Assignment_Statement (Loc,
Name =>
- New_Occurrence_Of (Extra_Parameter, Loc),
+ New_Occurrence_Of (Formal_Entity, Loc),
Expression =>
PolyORB_Support.Helpers.Build_From_Any_Call (
- Etype (Extra_Parameter),
+ Formal_Type,
New_Occurrence_Of (Extra_Any, Loc),
- Decls)));
+ Decls)));
Set_Extra_Constrained (Object, Formal_Entity);
-
end;
end if;
end;
@@ -7880,6 +8148,10 @@ package body Exp_Dist is
Next (Current_Parameter);
end loop;
+ -- Extra Formals should go after all the other parameters
+
+ Append_List_To (Outer_Statements, Outer_Extra_Formal_Statements);
+
Append_To (Outer_Statements,
Make_Procedure_Call_Statement (Loc,
Name =>
@@ -7888,8 +8160,6 @@ package body Exp_Dist is
New_Occurrence_Of (Request_Parameter, Loc),
New_Occurrence_Of (Arguments, Loc))));
- Append_List_To (Statements, Extra_Formal_Statements);
-
if Nkind (Specification (Vis_Decl)) = N_Function_Specification then
-- The remote subprogram is a function. We build an inner block to
@@ -7977,7 +8247,7 @@ package body Exp_Dist is
-- For an asynchronous procedure, add a null exception handler
Excep_Handlers := New_List (
- Make_Exception_Handler (Loc,
+ Make_Implicit_Exception_Handler (Loc,
Exception_Choices => New_List (Make_Others_Choice (Loc)),
Statements => New_List (Make_Null_Statement (Loc))));
@@ -8006,6 +8276,7 @@ package body Exp_Dist is
Statements => Outer_Statements,
Exception_Handlers => Excep_Handlers));
end Build_Subprogram_Receiving_Stubs;
+
-------------
-- Helpers --
-------------
@@ -8104,13 +8375,22 @@ package body Exp_Dist is
Container : Node_Or_Entity_Id;
Counter : in out Int)
is
- CI : constant List_Id := Component_Items (Clist);
- VP : constant Node_Id := Variant_Part (Clist);
+ CI : List_Id;
+ VP : Node_Id;
+ -- Clist's Component_Items and Variant_Part
- Item : Node_Id := First (CI);
+ Item : Node_Id;
Def : Entity_Id;
begin
+ if No (Clist) then
+ return;
+ end if;
+
+ CI := Component_Items (Clist);
+ VP := Variant_Part (Clist);
+
+ Item := First (CI);
while Present (Item) loop
Def := Defining_Identifier (Item);
if not Is_Internal_Name (Chars (Def)) then
@@ -8140,7 +8420,7 @@ package body Exp_Dist is
Fnam : Entity_Id := Empty;
Lib_RE : RE_Id := RE_Null;
-
+ Result : Node_Id;
begin
-- First simple case where the From_Any function is present
@@ -8243,10 +8523,17 @@ package body Exp_Dist is
Fnam := RTE (Lib_RE);
end if;
- return
- Make_Function_Call (Loc,
- Name => New_Occurrence_Of (Fnam, Loc),
- Parameter_Associations => New_List (N));
+ Result :=
+ Make_Function_Call (Loc,
+ Name => New_Occurrence_Of (Fnam, Loc),
+ Parameter_Associations => New_List (N));
+
+ -- We must set the type of Result, so the unchecked conversion
+ -- from the underlying type to the base type is properly done.
+
+ Set_Etype (Result, U_Type);
+
+ return Unchecked_Convert_To (Typ, Result);
end Build_From_Any_Call;
-----------------------------
@@ -8265,6 +8552,15 @@ package body Exp_Dist is
Any_Parameter : constant Entity_Id
:= Make_Defining_Identifier (Loc, New_Internal_Name ('A'));
begin
+ if Is_Itype (Typ) then
+ Build_From_Any_Function
+ (Loc => Loc,
+ Typ => Etype (Typ),
+ Decl => Decl,
+ Fnam => Fnam);
+ return;
+ end if;
+
Fnam := Make_Stream_Procedure_Function_Name (Loc,
Typ, Name_uFrom_Any);
@@ -8442,6 +8738,15 @@ package body Exp_Dist is
(Discrete_Choices (Variant));
VP_Stmts := New_List;
+
+ -- Struct_Counter should be reset before
+ -- handling a variant part. Indeed only one
+ -- of the case statement alternatives will be
+ -- executed at run-time, so the counter must
+ -- start at 0 for every case statement.
+
+ Struct_Counter := 0;
+
FA_Append_Record_Traversal (
Stmts => VP_Stmts,
Clist => Component_List (Variant),
@@ -8482,11 +8787,11 @@ package body Exp_Dist is
Object_Definition =>
New_Occurrence_Of (Disc_Type, Loc),
Expression =>
- Build_From_Any_Call (Etype (Disc),
+ Build_From_Any_Call (Disc_Type,
Build_Get_Aggregate_Element (Loc,
Any => Any_Parameter,
Tc => Build_TypeCode_Call
- (Loc, Etype (Disc), Decls),
+ (Loc, Disc_Type, Decls),
Idx => Make_Integer_Literal
(Loc, Component_Counter)),
Decls)));
@@ -8565,14 +8870,44 @@ package body Exp_Dist is
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));
-
+ Element_Any : Node_Id;
begin
+
+ declare
+ Element_TC : Node_Id;
+ begin
+
+ if Etype (Datum) = RTE (RE_Any) then
+
+ -- When Datum is an Any the Etype field is not
+ -- sufficient to determine the typecode of Datum
+ -- (which can be a TC_SEQUENCE or TC_ARRAY
+ -- depending on the value of Constrained).
+ -- Therefore we retrieve the typecode which has
+ -- been constructed in Append_Array_Traversal with
+ -- a call to Get_Any_Type.
+
+ Element_TC :=
+ Make_Function_Call (Loc,
+ Name => New_Occurrence_Of (
+ RTE (RE_Get_Any_Type), Loc),
+ Parameter_Associations => New_List (
+ New_Occurrence_Of (Entity (Datum), Loc)));
+ else
+ -- For non Any Datum we simply construct a typecode
+ -- matching the Etype of the Datum.
+
+ Element_TC := Build_TypeCode_Call
+ (Loc, Etype (Datum), Decls);
+ end if;
+
+ Element_Any :=
+ Build_Get_Aggregate_Element (Loc,
+ Any => Any,
+ Tc => Element_TC,
+ Idx => New_Occurrence_Of (Counter, Loc));
+ end;
+
-- Note: here we *prepend* statements to Stmts, so
-- we must do it in reverse order.
@@ -8679,24 +9014,22 @@ package body Exp_Dist is
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))),
+ OK_Convert_To (
+ Standard_Long_Integer,
+ 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)))),
+ OK_Convert_To (
+ Standard_Long_Integer,
+ 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))))));
@@ -8918,22 +9251,22 @@ package body Exp_Dist is
Lib_RE : RE_Id := RE_Null;
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.
+ -- 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.
if No (Typ) and then Nkind (N) = N_Selected_Component then
Typ := Etype (Selector_Name (N));
end if;
pragma Assert (Present (Typ));
- -- The full view, if Typ is private; the completion,
- -- if Typ is incomplete.
+ -- The full view, if Typ is private; the completion, if Typ is
+ -- incomplete.
U_Type := Underlying_Type (Typ);
- -- First simple case where the To_Any function is present
- -- in the type's TSS.
+ -- First simple case where the To_Any function is present in the
+ -- type's TSS.
Fnam := Find_Inherited_TSS (U_Type, TSS_To_Any);
@@ -9037,8 +9370,9 @@ package body Exp_Dist is
return
Make_Function_Call (Loc,
- Name => New_Occurrence_Of (Fnam, Loc),
- Parameter_Associations => New_List (N));
+ Name => New_Occurrence_Of (Fnam, Loc),
+ Parameter_Associations =>
+ New_List (Unchecked_Convert_To (U_Type, N)));
end Build_To_Any_Call;
---------------------------
@@ -9065,6 +9399,15 @@ package body Exp_Dist is
Result_TC : Node_Id := Build_TypeCode_Call (Loc, Typ, Decls);
begin
+ if Is_Itype (Typ) then
+ Build_To_Any_Function
+ (Loc => Loc,
+ Typ => Etype (Typ),
+ Decl => Decl,
+ Fnam => Fnam);
+ return;
+ end if;
+
Fnam := Make_Stream_Procedure_Function_Name (Loc,
Typ, Name_uTo_Any);
@@ -9163,7 +9506,7 @@ package body Exp_Dist is
New_Occurrence_Of (
RTE (RE_Add_Aggregate_Element), Loc),
Parameter_Associations => New_List (
- New_Occurrence_Of (Any, Loc),
+ New_Occurrence_Of (Container, Loc),
Build_To_Any_Call (Field_Ref, Decls))));
else
@@ -9182,7 +9525,7 @@ package body Exp_Dist is
Union_Any : constant Entity_Id :=
Make_Defining_Identifier (Loc,
- New_Internal_Name ('U'));
+ New_Internal_Name ('V'));
Struct_Any : constant Entity_Id :=
Make_Defining_Identifier (Loc,
@@ -9206,7 +9549,7 @@ package body Exp_Dist is
Selector_Name =>
Chars (Name (Field)));
begin
- Set_Etype (Nod, Name (Field));
+ Set_Etype (Nod, Etype (Name (Field)));
return Nod;
end Make_Discriminant_Reference;
@@ -9219,6 +9562,12 @@ package body Exp_Dist is
Make_Handled_Sequence_Of_Statements (Loc,
Statements => Block_Stmts)));
+ -- Declare the Variant Part aggregate
+ -- (Union_Any).
+ -- Knowing the position of this VP in
+ -- the variant record, we can fetch the
+ -- VP typecode from Container.
+
Append_To (Block_Decls,
Make_Object_Declaration (Loc,
Defining_Identifier => Union_Any,
@@ -9238,6 +9587,10 @@ package body Exp_Dist is
Make_Integer_Literal (Loc,
Counter)))))));
+ -- Declare the inner struct aggregate
+ -- (that will contain the components
+ -- of this VP)
+
Append_To (Block_Decls,
Make_Object_Declaration (Loc,
Defining_Identifier => Struct_Any,
@@ -9255,7 +9608,11 @@ package body Exp_Dist is
Parameter_Associations => New_List (
New_Occurrence_Of (Union_Any, Loc),
Make_Integer_Literal (Loc,
- Uint_0)))))));
+ Uint_1)))))));
+
+ -- Construct a case statement that will choose
+ -- the appropriate code at runtime depending on
+ -- the discriminant.
Append_To (Block_Stmts,
Make_Case_Statement (Loc,
@@ -9270,14 +9627,9 @@ package body Exp_Dist is
(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 discriminant value to union
+ -- aggregate.
Append_To (VP_Stmts,
Make_Procedure_Call_Statement (Loc,
@@ -9290,6 +9642,24 @@ package body Exp_Dist is
Make_Discriminant_Reference,
Block_Decls))));
+ -- Populate inner struct aggregate
+
+ -- Struct_Counter should be reset before
+ -- handling a variant part. Indeed only one
+ -- of the case statement alternatives will be
+ -- executed at run-time, so the counter must
+ -- start at 0 for every case statement.
+
+ Struct_Counter := 0;
+
+ TA_Append_Record_Traversal (
+ Stmts => VP_Stmts,
+ Clist => Component_List (Variant),
+ Container => Struct_Any,
+ Counter => Struct_Counter);
+
+ -- Append inner struct to union aggregate
+
Append_To (VP_Stmts,
Make_Procedure_Call_Statement (Loc,
Name =>
@@ -9306,49 +9676,77 @@ package body Exp_Dist is
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))))));
+ Parameter_Associations => New_List (
+ New_Occurrence_Of (Container, Loc),
+ New_Occurrence_Of
+ (Union_Any, Loc))));
Append_To (Alt_List,
Make_Case_Statement_Alternative (Loc,
Discrete_Choices => Choice_List,
- Statements =>
- VP_Stmts));
+ Statements => VP_Stmts));
+
Next_Non_Pragma (Variant);
end loop;
end;
end if;
+ Counter := Counter + 1;
end TA_Rec_Add_Process_Element;
begin
- -- First all discriminants
+ -- Records are encoded in a TC_STRUCT aggregate:
+ -- -- Outer aggregate (TC_STRUCT)
+ -- | [discriminant1]
+ -- | [discriminant2]
+ -- | ...
+ --
+ -- | [component1]
+ -- | [component2]
+ -- | ...
+ --
+ -- A component can be a common component or a variant
+ -- part.
+ --
+ -- A variant part is encoded as a TC_UNION aggregate:
+ -- -- Variant Part Aggregate (TC_UNION)
+ -- | [discriminant choice for this Variant Part]
+ -- |
+ -- | -- Inner struct (TC_STRUCT)
+ -- | | [component1]
+ -- | | [component2]
+ -- | | ...
+
+ -- Let's start by building the outer aggregate
+ -- First we construct an Elements array containing all
+ -- the 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,
+
+ declare
+ Discriminant : constant Entity_Id :=
+ Make_Selected_Component (Loc,
Prefix => Expr_Parameter,
- Selector_Name => Chars (Disc)),
- Decls)));
+ Selector_Name => Chars (Disc));
+ begin
+ Set_Etype (Discriminant, Etype (Disc));
+
+ Append_To (Elements,
+ Make_Component_Association (Loc,
+ Choices => New_List (
+ Make_Integer_Literal (Loc, Counter)),
+ Expression =>
+ Build_To_Any_Call (Discriminant, Decls)));
+ end;
Counter := Counter + 1;
Next_Discriminant (Disc);
end loop;
else
- -- Make elements an empty array
+ -- If there are no discriminants, we declare an empty
+ -- Elements array.
declare
Dummy_Any : constant Entity_Id :=
@@ -9375,6 +9773,9 @@ package body Exp_Dist is
end;
end if;
+ -- We build the result aggregate with discriminants
+ -- as the first elements.
+
Set_Expression (Any_Decl,
Make_Function_Call (Loc,
Name => New_Occurrence_Of (
@@ -9385,7 +9786,8 @@ package body Exp_Dist is
Component_Associations => Elements))));
Result_TC := Empty;
- -- ... then all components
+ -- Then we append all the components to the result
+ -- aggregate.
TA_Append_Record_Traversal (Stms,
Clist => Component_List (Rdef),
@@ -9923,7 +10325,7 @@ package body Exp_Dist is
Union_TC_Params : List_Id;
U_Name : constant Name_Id :=
- New_External_Name (Chars (Typ), 'U', -1);
+ New_External_Name (Chars (Typ), 'V', -1);
Name_Str : String_Id;
Struct_TC_Params : List_Id;
@@ -9935,6 +10337,8 @@ package body Exp_Dist is
Dummy_Counter : Int := 0;
+ Choice_Index : Int := 0;
+
procedure Add_Params_For_Variant_Components;
-- Add a struct TypeCode and a corresponding member name
-- to the union parameter list.
@@ -9980,19 +10384,22 @@ package body Exp_Dist is
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);
+ Params);
+
+ Add_String_Parameter (Name_Str, Params);
-- Build union parameters
Add_TypeCode_Parameter
- (Discriminant_Type, Union_TC_Params);
+ (Build_TypeCode_Call
+ (Loc, Discriminant_Type, Decls),
+ Union_TC_Params);
+
Add_Long_Parameter (Default, Union_TC_Params);
Variant := First_Non_Pragma (Variants (Field));
@@ -10023,24 +10430,92 @@ package body Exp_Dist is
Make_Integer_Literal (Loc, J);
end if;
Append_To (Union_TC_Params,
- Build_To_Any_Call (Expr, Decls));
+ Make_Function_Call (Loc,
+ Name => New_Occurrence_Of
+ (RTE (RE_TA_A), Loc),
+ Parameter_Associations =>
+ New_List (
+ 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);
+
+ -- This variant possess a default choice.
+ -- We must therefore set the default
+ -- parameter to the current choice index. The
+ -- default parameter is by construction the
+ -- fourth in the Union_TC_Params list.
+
+ declare
+ Default_Node : constant Node_Id :=
+ Pick (Union_TC_Params, 4);
+
+ New_Default_Node : constant Node_Id :=
+ Make_Function_Call (Loc,
+ Name =>
+ New_Occurrence_Of
+ (RTE (RE_TA_LI), Loc),
+ Parameter_Associations =>
+ New_List (
+ Make_Integer_Literal
+ (Loc, Choice_Index)));
+ begin
+ Insert_Before (
+ Default_Node,
+ New_Default_Node);
+
+ Remove (Default_Node);
+ end;
+
+ -- Add a placeholder member label
+ -- for the default case.
+ -- It must be of the discriminant
+ -- type.
+
+ declare
+ Exp : constant Node_Id :=
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Occurrence_Of
+ (Discriminant_Type, Loc),
+ Attribute_Name => Name_First);
+ begin
+ Set_Etype (Exp, Discriminant_Type);
+ Append_To (Union_TC_Params,
+ Make_Function_Call (Loc,
+ Name => New_Occurrence_Of
+ (RTE (RE_TA_A), Loc),
+ Parameter_Associations =>
+ New_List (
+ Build_To_Any_Call
+ (Exp, Decls))));
+ end;
+
Add_Params_For_Variant_Components;
when others =>
- Append_To (Union_TC_Params,
- Build_To_Any_Call (Choice, Decls));
- Add_Params_For_Variant_Components;
+ declare
+ Exp : constant Node_Id :=
+ New_Copy_Tree (Choice);
+ begin
+ Append_To (Union_TC_Params,
+ Make_Function_Call (Loc,
+ Name => New_Occurrence_Of
+ (RTE (RE_TA_A), Loc),
+ Parameter_Associations =>
+ New_List (
+ Build_To_Any_Call
+ (Exp, Decls))));
+ end;
+ Add_Params_For_Variant_Components;
end case;
+ Next (Choice);
+ Choice_Index := Choice_Index + 1;
end loop;
@@ -10055,7 +10530,15 @@ package body Exp_Dist is
Type_Repo_Id_Str : String_Id;
begin
- pragma Assert (not Is_Itype (Typ));
+ if Is_Itype (Typ) then
+ Build_TypeCode_Function
+ (Loc => Loc,
+ Typ => Etype (Typ),
+ Decl => Decl,
+ Fnam => Fnam);
+ return;
+ end if;
+
Fnam := TCNam;
Spec :=
@@ -10073,20 +10556,8 @@ package body Exp_Dist is
if Is_Derived_Type (Typ)
and then not Is_Tagged_Type (Typ)
then
- declare
- Parent_Type : Entity_Id := Etype (Typ);
- begin
-
- if Is_Itype (Parent_Type) then
-
- -- Skip implicit base type
-
- Parent_Type := Etype (Parent_Type);
- end if;
-
- Return_Alias_TypeCode (
- Build_TypeCode_Call (Loc, Parent_Type, Decls));
- end;
+ Return_Alias_TypeCode (
+ Build_TypeCode_Call (Loc, Etype (Typ), Decls));
elsif Is_Integer_Type (Typ)
or else Is_Unsigned_Type (Typ)
@@ -10098,6 +10569,49 @@ package body Exp_Dist is
elsif Is_Record_Type (Typ)
and then not Is_Tagged_Type (Typ)
then
+
+ -- Record typecodes are encoded as follows:
+ -- -- TC_STRUCT
+ -- |
+ -- | [Name]
+ -- | [Repository Id]
+ --
+ -- Then for each discriminant:
+ --
+ -- | [Discriminant Type Code]
+ -- | [Discriminant Name]
+ -- | ...
+ --
+ -- Then for each component:
+ --
+ -- | [Component Type Code]
+ -- | [Component Name]
+ -- | ...
+ --
+ -- Variants components type codes are encoded as follows:
+ -- -- TC_UNION
+ -- |
+ -- | [Name]
+ -- | [Repository Id]
+ -- | [Discriminant Type Code]
+ -- | [Index of Default Variant Part or -1 for no default]
+ --
+ -- Then for each Variant Part :
+ --
+ -- | [VP Label]
+ -- |
+ -- | -- TC_STRUCT
+ -- | | [Variant Part Name]
+ -- | | [Variant Part Repository Id]
+ -- | |
+ -- | Then for each VP component:
+ -- | | [VP component Typecode]
+ -- | | [VP component Name]
+ -- | | ...
+ -- | --
+ -- |
+ -- | [VP Name]
+
if Nkind (Declaration_Node (Typ)) = N_Subtype_Declaration then
Return_Alias_TypeCode (
Build_TypeCode_Call (Loc, Etype (Typ), Decls));
@@ -10108,7 +10622,7 @@ package body Exp_Dist is
Type_Definition (Declaration_Node (Typ));
Dummy_Counter : Int := 0;
begin
- -- First all discriminants
+ -- Construct the discriminants typecodes
if Has_Discriminants (Typ) then
Disc := First_Discriminant (Typ);
@@ -10124,7 +10638,7 @@ package body Exp_Dist is
Next_Discriminant (Disc);
end loop;
- -- ... then all components
+ -- then the components typecodes
TC_Append_Record_Traversal
(Parameters, Component_List (Rdef),
@@ -10463,7 +10977,7 @@ package body Exp_Dist is
Counter => Inner_Counter);
end if;
- -- Loop_Stm does approrpriate processing for each element
+ -- Loop_Stm does appropriate processing for each element
-- of Inner_Any.
Append_To (Dimen_Stmts, Loop_Stm);
@@ -10564,7 +11078,16 @@ package body Exp_Dist is
Make_Identifier (Loc, Name_RCI_Name),
Explicit_Generic_Actual_Parameter =>
Make_String_Literal (Loc,
- Strval => Pkg_Name))));
+ Strval => Pkg_Name)),
+ Make_Generic_Association (Loc,
+ Selector_Name =>
+ Make_Identifier (Loc, Name_Version),
+ Explicit_Generic_Actual_Parameter =>
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ New_Occurrence_Of (Defining_Entity (Package_Spec), Loc),
+ Attribute_Name =>
+ Name_Version))));
RCI_Locator_Table.Set (Defining_Unit_Name (Package_Spec),
Defining_Unit_Name (Inst));
@@ -10585,7 +11108,7 @@ package body Exp_Dist is
Add_RACW_Primitive_Declarations_And_Bodies
(Full_View,
Stub_Elements.RPC_Receiver_Decl,
- List_Containing (Declaration_Node (Full_View)));
+ Stub_Elements.Body_Decls);
end if;
end Remote_Types_Tagged_Full_View_Encountered;
@@ -10670,7 +11193,7 @@ package body Exp_Dist is
Stub_Type : Entity_Id;
Stub_Type_Access : Entity_Id;
RPC_Receiver_Decl : Node_Id;
- Declarations : List_Id) is
+ Body_Decls : List_Id) is
begin
case Get_PCS_Name is
when Name_PolyORB_DSA =>
@@ -10680,7 +11203,7 @@ package body Exp_Dist is
Stub_Type,
Stub_Type_Access,
RPC_Receiver_Decl,
- Declarations);
+ Body_Decls);
when others =>
GARLIC_Support.Add_RACW_Features (
@@ -10688,7 +11211,7 @@ package body Exp_Dist is
Stub_Type,
Stub_Type_Access,
RPC_Receiver_Decl,
- Declarations);
+ Body_Decls);
end case;
end Specific_Add_RACW_Features;
@@ -10714,16 +11237,17 @@ package body Exp_Dist is
procedure Specific_Add_Receiving_Stubs_To_Declarations
(Pkg_Spec : Node_Id;
- Decls : List_Id)
+ Decls : List_Id;
+ Stmts : List_Id)
is
begin
case Get_PCS_Name is
when Name_PolyORB_DSA =>
PolyORB_Support.Add_Receiving_Stubs_To_Declarations (
- Pkg_Spec, Decls);
+ Pkg_Spec, Decls, Stmts);
when others =>
GARLIC_Support.Add_Receiving_Stubs_To_Declarations (
- Pkg_Spec, Decls);
+ Pkg_Spec, Decls, Stmts);
end case;
end Specific_Add_Receiving_Stubs_To_Declarations;
More information about the Gcc-patches
mailing list