diff options
Diffstat (limited to 'gcc/ada/exp_dist.adb')
-rw-r--r-- | gcc/ada/exp_dist.adb | 621 |
1 files changed, 295 insertions, 326 deletions
diff --git a/gcc/ada/exp_dist.adb b/gcc/ada/exp_dist.adb index 4dff14e..a5bab92 100644 --- a/gcc/ada/exp_dist.adb +++ b/gcc/ada/exp_dist.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2002 Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2003 Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -27,6 +27,7 @@ with Atree; use Atree; with Einfo; use Einfo; with Elists; use Elists; +with Exp_Strm; use Exp_Strm; with Exp_Tss; use Exp_Tss; with Exp_Util; use Exp_Util; with GNAT.HTable; use GNAT.HTable; @@ -145,6 +146,14 @@ 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. + function Build_Ordered_Parameters_List (Spec : Node_Id) return List_Id; -- Return an ordered parameter list: unconstrained parameters are put -- at the beginning of the list and constrained ones are put after. If @@ -177,7 +186,7 @@ package body Exp_Dist is function Pack_Entity_Into_Stream_Access (Loc : Source_Ptr; - Stream : Entity_Id; + Stream : Node_Id; Object : Entity_Id; Etyp : Entity_Id := Empty) return Node_Id; @@ -196,7 +205,7 @@ package body Exp_Dist is function Pack_Node_Into_Stream_Access (Loc : Source_Ptr; - Stream : Entity_Id; + Stream : Node_Id; Object : Node_Id; Etyp : Entity_Id) return Node_Id; @@ -567,7 +576,6 @@ package body Exp_Dist is Possibly_Asynchronous : Boolean; begin - if not Expander_Active then return; end if; @@ -588,7 +596,8 @@ package body Exp_Dist is -- ones that are not remotely dispatching. if Chars (Current_Primitive) /= Name_uSize - and then Chars (Current_Primitive) /= Name_uDeep_Finalize + and then Chars (Current_Primitive) /= Name_uAlignment + and then not Is_TSS (Current_Primitive, TSS_Deep_Finalize) then -- The first thing to do is build an up-to-date copy of -- the spec with all the formals referencing Designated_Type @@ -740,11 +749,6 @@ package body Exp_Dist is is Loc : constant Source_Ptr := Sloc (RACW_Type); - Proc_Spec : Node_Id; - -- Specification and body of the currently built procedure - - Proc_Body_Spec : Node_Id; - Proc_Decl : Node_Id; Attr_Decl : Node_Id; @@ -767,12 +771,6 @@ package body Exp_Dist is Source_Address : constant Entity_Id := Make_Defining_Identifier (Loc, New_Internal_Name ('P')); - Stream_Parameter : constant Entity_Id := - Make_Defining_Identifier - (Loc, New_Internal_Name ('S')); - Result : constant Entity_Id := - Make_Defining_Identifier - (Loc, New_Internal_Name ('P')); Stubbed_Result : constant Entity_Id := Make_Defining_Identifier (Loc, New_Internal_Name ('S')); @@ -782,6 +780,22 @@ package body Exp_Dist is Asynchronous_Node : constant Node_Id := New_Occurrence_Of (Standard_False, Loc); + -- Functions to create occurrences of the formal + -- parameter names. + + function Stream_Parameter return Node_Id; + function Result return Node_Id; + + function Stream_Parameter return Node_Id is + begin + return Make_Identifier (Loc, Name_S); + end Stream_Parameter; + + function Result return Node_Id is + begin + return Make_Identifier (Loc, Name_V); + end Result; + begin -- Declare the asynchronous flag. This flag will be changed to True -- whenever it is known that the RACW type is asynchronous. Also, the @@ -828,7 +842,7 @@ package body Exp_Dist is New_Occurrence_Of (RTE (RE_Partition_ID), Loc), Attribute_Name => Name_Read, Expressions => New_List ( - New_Occurrence_Of (Stream_Parameter, Loc), + Stream_Parameter, New_Occurrence_Of (Source_Partition, Loc))), Make_Attribute_Reference (Loc, @@ -837,7 +851,7 @@ package body Exp_Dist is Attribute_Name => Name_Read, Expressions => New_List ( - New_Occurrence_Of (Stream_Parameter, Loc), + Stream_Parameter, New_Occurrence_Of (Source_Receiver, Loc))), Make_Attribute_Reference (Loc, @@ -846,7 +860,7 @@ package body Exp_Dist is Attribute_Name => Name_Read, Expressions => New_List ( - New_Occurrence_Of (Stream_Parameter, Loc), + Stream_Parameter, New_Occurrence_Of (Source_Address, Loc)))); -- If the Address is Null_Address, then return a null object @@ -859,7 +873,7 @@ package body Exp_Dist is Right_Opnd => Make_Integer_Literal (Loc, Uint_0)), Then_Statements => New_List ( Make_Assignment_Statement (Loc, - Name => New_Occurrence_Of (Result, Loc), + Name => Result, Expression => Make_Null (Loc)), Make_Return_Statement (Loc)))); @@ -868,7 +882,7 @@ package body Exp_Dist is Local_Statements := New_List ( Make_Assignment_Statement (Loc, - Name => New_Occurrence_Of (Result, Loc), + Name => Result, Expression => Unchecked_Convert_To (RACW_Type, OK_Convert_To (RTE (RE_Address), @@ -925,7 +939,7 @@ package body Exp_Dist is Append_To (Remote_Statements, Make_Assignment_Statement (Loc, - Name => New_Occurrence_Of (Result, Loc), + Name => Result, Expression => Unchecked_Convert_To (RACW_Type, New_Occurrence_Of (Stubbed_Result, Loc)))); @@ -944,71 +958,22 @@ package body Exp_Dist is Then_Statements => Local_Statements, Else_Statements => Remote_Statements)); - Proc_Spec := - Make_Procedure_Specification (Loc, - Defining_Unit_Name => - Make_Defining_Identifier (Loc, Procedure_Name), + Build_Stream_Procedure + (Loc, RACW_Type, Body_Node, + Make_Defining_Identifier (Loc, Procedure_Name), + Statements, Outp => True); + Set_Declarations (Body_Node, Decls); - Parameter_Specifications => New_List ( - Make_Parameter_Specification (Loc, - Defining_Identifier => Stream_Parameter, - Parameter_Type => - Make_Access_Definition (Loc, - Subtype_Mark => - Make_Attribute_Reference (Loc, - Prefix => - New_Occurrence_Of (RTE (RE_Root_Stream_Type), Loc), - Attribute_Name => - Name_Class))), - - Make_Parameter_Specification (Loc, - Defining_Identifier => Result, - Out_Present => True, - Parameter_Type => - New_Occurrence_Of (RACW_Type, Loc)))); - - Proc_Body_Spec := - Make_Procedure_Specification (Loc, - Defining_Unit_Name => - Make_Defining_Identifier (Loc, Procedure_Name), - - Parameter_Specifications => New_List ( - Make_Parameter_Specification (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, Chars (Stream_Parameter)), - Parameter_Type => - Make_Access_Definition (Loc, - Subtype_Mark => - Make_Attribute_Reference (Loc, - Prefix => - New_Occurrence_Of (RTE (RE_Root_Stream_Type), Loc), - Attribute_Name => - Name_Class))), - - Make_Parameter_Specification (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, Chars (Result)), - Out_Present => True, - Parameter_Type => - New_Occurrence_Of (RACW_Type, Loc)))); - - Body_Node := - Make_Subprogram_Body (Loc, - Specification => Proc_Body_Spec, - Declarations => Decls, - Handled_Statement_Sequence => - Make_Handled_Sequence_Of_Statements (Loc, - Statements => Statements)); - - Proc_Decl := - Make_Subprogram_Declaration (Loc, Specification => Proc_Spec); + 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 (Proc_Spec), Loc)); + New_Occurrence_Of ( + Defining_Unit_Name (Specification (Proc_Decl)), Loc)); Insert_After (Declaration_Node (RACW_Type), Proc_Decl); Insert_After (Proc_Decl, Attr_Decl); @@ -1052,16 +1017,11 @@ package body Exp_Dist is Object_RPC_Receiver : in Entity_Id; Declarations : in List_Id) is - Loc : constant Source_Ptr := Sloc (RACW_Type); - - Proc_Spec : Node_Id; - - Proc_Body_Spec : Node_Id; - - Body_Node : Node_Id; + Loc : constant Source_Ptr := Sloc (RACW_Type); - Proc_Decl : Node_Id; - Attr_Decl : Node_Id; + Body_Node : Node_Id; + Proc_Decl : Node_Id; + Attr_Decl : Node_Id; Statements : List_Id; Local_Statements : List_Id; @@ -1070,12 +1030,21 @@ package body Exp_Dist is Procedure_Name : constant Name_Id := New_Internal_Name ('R'); - Stream_Parameter : constant Entity_Id := - Make_Defining_Identifier - (Loc, New_Internal_Name ('S')); + -- Functions to create occurrences of the formal + -- parameter names. - Object : constant Entity_Id := - Make_Defining_Identifier (Loc, New_Internal_Name ('P')); + function Stream_Parameter return Node_Id; + function Object return Node_Id; + + function Stream_Parameter return Node_Id is + begin + return Make_Identifier (Loc, Name_S); + end Stream_Parameter; + + function Object return Node_Id is + begin + return Make_Identifier (Loc, Name_V); + end Object; begin -- Build the code fragment corresponding to the marshalling of a @@ -1101,7 +1070,7 @@ package body Exp_Dist is Make_Attribute_Reference (Loc, Prefix => Make_Explicit_Dereference (Loc, - Prefix => New_Occurrence_Of (Object, Loc)), + Prefix => Object), Attribute_Name => Name_Address)), Etyp => RTE (RE_Unsigned_64))); @@ -1115,7 +1084,7 @@ package body Exp_Dist is Object => Make_Selected_Component (Loc, Prefix => Unchecked_Convert_To (Stub_Type_Access, - New_Occurrence_Of (Object, Loc)), + Object), Selector_Name => Make_Identifier (Loc, Name_Origin)), Etyp => RTE (RE_Partition_ID)), @@ -1125,7 +1094,7 @@ package body Exp_Dist is Object => Make_Selected_Component (Loc, Prefix => Unchecked_Convert_To (Stub_Type_Access, - New_Occurrence_Of (Object, Loc)), + Object), Selector_Name => Make_Identifier (Loc, Name_Receiver)), Etyp => RTE (RE_Unsigned_64)), @@ -1135,7 +1104,7 @@ package body Exp_Dist is Object => Make_Selected_Component (Loc, Prefix => Unchecked_Convert_To (Stub_Type_Access, - New_Occurrence_Of (Object, Loc)), + Object), Selector_Name => Make_Identifier (Loc, Name_Addr)), Etyp => RTE (RE_Unsigned_64))); @@ -1166,7 +1135,7 @@ package body Exp_Dist is Make_Implicit_If_Statement (RACW_Type, Condition => Make_Op_Eq (Loc, - Left_Opnd => New_Occurrence_Of (Object, Loc), + Left_Opnd => Object, Right_Opnd => Make_Null (Loc)), Then_Statements => Null_Statements, Elsif_Parts => New_List ( @@ -1175,7 +1144,7 @@ package body Exp_Dist is Make_Op_Eq (Loc, Left_Opnd => Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (Object, Loc), + Prefix => Object, Attribute_Name => Name_Tag), Right_Opnd => Make_Attribute_Reference (Loc, @@ -1184,71 +1153,21 @@ package body Exp_Dist is Then_Statements => Remote_Statements)), Else_Statements => Local_Statements)); - Proc_Spec := - Make_Procedure_Specification (Loc, - Defining_Unit_Name => - Make_Defining_Identifier (Loc, Procedure_Name), - - Parameter_Specifications => New_List ( - Make_Parameter_Specification (Loc, - Defining_Identifier => Stream_Parameter, - Parameter_Type => - Make_Access_Definition (Loc, - Subtype_Mark => - Make_Attribute_Reference (Loc, - Prefix => - New_Occurrence_Of (RTE (RE_Root_Stream_Type), Loc), - Attribute_Name => - Name_Class))), - - Make_Parameter_Specification (Loc, - Defining_Identifier => Object, - In_Present => True, - Parameter_Type => - New_Occurrence_Of (RACW_Type, Loc)))); + Build_Stream_Procedure + (Loc, RACW_Type, Body_Node, + Make_Defining_Identifier (Loc, Procedure_Name), + Statements, Outp => False); - Proc_Decl := - Make_Subprogram_Declaration (Loc, Specification => Proc_Spec); + 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 (Proc_Spec), Loc)); - - Proc_Body_Spec := - Make_Procedure_Specification (Loc, - Defining_Unit_Name => - Make_Defining_Identifier (Loc, Procedure_Name), - - Parameter_Specifications => New_List ( - Make_Parameter_Specification (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, Chars (Stream_Parameter)), - Parameter_Type => - Make_Access_Definition (Loc, - Subtype_Mark => - Make_Attribute_Reference (Loc, - Prefix => - New_Occurrence_Of (RTE (RE_Root_Stream_Type), Loc), - Attribute_Name => - Name_Class))), - - Make_Parameter_Specification (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, Chars (Object)), - In_Present => True, - Parameter_Type => - New_Occurrence_Of (RACW_Type, Loc)))); - - Body_Node := - Make_Subprogram_Body (Loc, - Specification => Proc_Body_Spec, - Declarations => No_List, - Handled_Statement_Sequence => - Make_Handled_Sequence_Of_Statements (Loc, - Statements => Statements)); + New_Occurrence_Of ( + Defining_Unit_Name (Specification (Proc_Decl)), Loc)); Insert_After (Declaration_Node (RACW_Type), Proc_Decl); Insert_After (Proc_Decl, Attr_Decl); @@ -1269,7 +1188,6 @@ package body Exp_Dist is Proc_Statements : constant List_Id := New_List; Proc_Spec : Node_Id; - Proc_Body : Node_Id; Proc : Node_Id; @@ -1346,7 +1264,9 @@ package body Exp_Dist is Expression => New_Occurrence_Of (Return_Value, Loc))); - Proc := Make_Defining_Identifier (Loc, Name_uRAS_Access); + Proc := + Make_Defining_Identifier (Loc, + Chars => Make_TSS_Name (Ras_Type, TSS_RAS_Access)); Proc_Spec := Make_Function_Specification (Loc, @@ -1381,13 +1301,13 @@ package body Exp_Dist is Set_Ekind (Proc, E_Function); Set_Etype (Proc, New_Occurrence_Of (Fat_Type, Loc)); - Proc_Body := + Discard_Node ( Make_Subprogram_Body (Loc, Specification => Proc_Spec, Declarations => Proc_Decls, Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, - Statements => Proc_Statements)); + Statements => Proc_Statements))); Set_TSS (Fat_Type, Proc); @@ -1414,11 +1334,8 @@ package body Exp_Dist is Direct_Statements : constant List_Id := New_List; - Proc : Node_Id; - - Proc_Spec : Node_Id; - Proc_Body : Node_Id; - + Proc : Node_Id; + Proc_Spec : Node_Id; Param_Specs : constant List_Id := New_List; Param_Assoc : constant List_Id := New_List; @@ -1506,14 +1423,14 @@ package body Exp_Dist is Make_Parameter_Specification (Loc, Defining_Identifier => Make_Defining_Identifier (Loc, - Chars => Chars (Defining_Identifier (Current_Parameter))), - In_Present => In_Present (Current_Parameter), - Out_Present => Out_Present (Current_Parameter), - Parameter_Type => - New_Occurrence_Of - (Etype (Parameter_Type (Current_Parameter)), Loc), - Expression => - New_Copy_Tree (Expression (Current_Parameter)))); + Chars => + Chars (Defining_Identifier (Current_Parameter))), + In_Present => In_Present (Current_Parameter), + Out_Present => Out_Present (Current_Parameter), + Parameter_Type => + New_Copy_Tree (Parameter_Type (Current_Parameter)), + Expression => + New_Copy_Tree (Expression (Current_Parameter)))); Append_To (Param_Assoc, Make_Identifier (Loc, @@ -1523,7 +1440,9 @@ package body Exp_Dist is end loop; end if; - Proc := Make_Defining_Identifier (Loc, Name_uRAS_Dereference); + Proc := + Make_Defining_Identifier (Loc, + Chars => Make_TSS_Name (Ras_Type, TSS_RAS_Dereference)); if Is_Function then Proc_Spec := @@ -1628,13 +1547,13 @@ package body Exp_Dist is Make_Handled_Sequence_Of_Statements (Loc, Statements => Inner_Statements))))); - Proc_Body := + Discard_Node ( Make_Subprogram_Body (Loc, Specification => Proc_Spec, Declarations => Proc_Decls, Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, - Statements => Proc_Statements)); + Statements => Proc_Statements))); Set_TSS (Fat_Type, Defining_Unit_Name (Proc_Spec)); @@ -1650,8 +1569,8 @@ package body Exp_Dist is -- be replaced by an assert or this comment removed if we decide -- that this is normal to be called several times ??? - if Present (TSS (Equivalent_Type (Defining_Identifier - (Vis_Decl)), Name_uRAS_Access)) + if Present (TSS (Equivalent_Type (Defining_Identifier (Vis_Decl)), + TSS_RAS_Access)) then return; end if; @@ -1675,10 +1594,9 @@ package body Exp_Dist is Pkg_RPC_Receiver : Node_Id; Pkg_RPC_Receiver_Spec : Node_Id; - Pkg_RPC_Receiver_Formals : List_Id; Pkg_RPC_Receiver_Decls : List_Id; Pkg_RPC_Receiver_Statements : List_Id; - Pkg_RPC_Receiver_Cases : List_Id := New_List; + Pkg_RPC_Receiver_Cases : constant List_Id := New_List; Pkg_RPC_Receiver_Body : Node_Id; -- A Pkg_RPC_Receiver is built to decode the request @@ -1726,24 +1644,11 @@ package body Exp_Dist is -- The parameters of the package RPC receiver are made of two -- streams, an input one and an output one. - Pkg_RPC_Receiver_Formals := 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)))); - Pkg_RPC_Receiver_Spec := - Make_Procedure_Specification (Loc, - Defining_Unit_Name => Pkg_RPC_Receiver, - Parameter_Specifications => Pkg_RPC_Receiver_Formals); + Build_RPC_Receiver_Specification + (RPC_Receiver => Pkg_RPC_Receiver, + Stream_Parameter => Stream_Parameter, + Result_Parameter => Result_Parameter); Pkg_RPC_Receiver_Decls := New_List ( Make_Object_Declaration (Loc, @@ -2024,23 +1929,10 @@ package body Exp_Dist is Object_RPC_Receiver_Declaration := Make_Subprogram_Declaration (Loc, - Make_Procedure_Specification (Loc, - Defining_Unit_Name => Object_RPC_Receiver, - Parameter_Specifications => New_List ( - Make_Parameter_Specification (Loc, - Defining_Identifier => RPC_Receiver_Stream, - Parameter_Type => - Make_Access_Definition (Loc, - Subtype_Mark => - New_Occurrence_Of (RTE (RE_Params_Stream_Type), Loc))), - - Make_Parameter_Specification (Loc, - Defining_Identifier => RPC_Receiver_Result, - Parameter_Type => - Make_Access_Definition (Loc, - Subtype_Mark => - New_Occurrence_Of - (RTE (RE_Params_Stream_Type), Loc)))))); + Build_RPC_Receiver_Specification ( + RPC_Receiver => Object_RPC_Receiver, + Stream_Parameter => RPC_Receiver_Stream, + Result_Parameter => RPC_Receiver_Result)); Append_To (Decls, Object_RPC_Receiver_Declaration); end Add_Stub_Type; @@ -2193,33 +2085,54 @@ package body Exp_Dist is while Current_Parameter /= Empty loop - if Is_RACW_Controlling_Formal (Current_Parameter, Object_Type) then + declare + Typ : constant Node_Id := + Parameter_Type (Current_Parameter); + Etyp : Entity_Id; + Constrained : Boolean; + Value : Node_Id; + Extra_Parameter : Entity_Id; - -- In the case of a controlling formal argument, we marshall - -- its addr field rather than the local stub. + begin - 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))); + if Is_RACW_Controlling_Formal (Current_Parameter, Object_Type) then - else - declare - Etyp : constant Entity_Id := - Etype (Parameter_Type (Current_Parameter)); + -- In the case of a controlling formal argument, we marshall + -- its addr field rather than the local stub. - Constrained : constant Boolean := - Is_Constrained (Etyp) - or else Is_Elementary_Type (Etyp); + 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. - begin if In_Present (Current_Parameter) or else not Out_Present (Current_Parameter) or else not Constrained @@ -2234,61 +2147,56 @@ package body Exp_Dist is Prefix => New_Occurrence_Of (Stream_Parameter, Loc), Attribute_Name => Name_Access), - New_Occurrence_Of ( - Defining_Identifier (Current_Parameter), Loc)))); + Value))); end if; - end; - 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 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 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. + 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. - declare - Extra_Parameter : constant Entity_Id := - Make_Defining_Identifier - (Loc, New_Internal_Name ('P')); + Extra_Parameter := Make_Defining_Identifier + (Loc, New_Internal_Name ('P')); - begin 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))); + 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; - end if; + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Standard_Boolean, Loc), + Attribute_Name => + Name_Write, + Expressions => New_List ( + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Stream_Parameter, Loc), + Attribute_Name => + Name_Access), + New_Occurrence_Of (Extra_Parameter, Loc)))); + end if; - Next (Current_Parameter); + Next (Current_Parameter); + end; end loop; -- Append the formal statements list to the statements @@ -2397,27 +2305,42 @@ package body Exp_Dist is while Current_Parameter /= Empty loop - if Out_Present (Current_Parameter) - and then - Etype (Parameter_Type (Current_Parameter)) /= Object_Type - then - Append_To (Non_Asynchronous_Statements, - Make_Attribute_Reference (Loc, - Prefix => - New_Occurrence_Of ( - Etype (Parameter_Type (Current_Parameter)), Loc), + 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); - Attribute_Name => Name_Read, + if Nkind (Typ) = N_Access_Definition then + Value := Make_Explicit_Dereference (Loc, Value); + Etyp := Etype (Subtype_Mark (Typ)); + else + Etyp := Etype (Typ); + end if; - Expressions => New_List ( + if (Out_Present (Current_Parameter) + or else Nkind (Typ) = N_Access_Definition) + and then Etyp /= Object_Type + then + Append_To (Non_Asynchronous_Statements, Make_Attribute_Reference (Loc, Prefix => - New_Occurrence_Of (Result_Parameter, Loc), - Attribute_Name => - Name_Access), - New_Occurrence_Of ( - Defining_Identifier (Current_Parameter), Loc)))); - end if; + 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; @@ -2511,13 +2434,18 @@ package body Exp_Dist is L : List_Id; Reg : Node_Id; Loc : constant Source_Ptr := Sloc (U); - Dist_OK : Entity_Id; begin -- Verify that the implementation supports distribution, by accessing -- a type defined in the proper version of system.rpc - Dist_OK := RTE (RE_Params_Stream_Type); + 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 @@ -2544,6 +2472,39 @@ package body Exp_Dist is Analyze (Reg); end Build_Passive_Partition_Stub; + -------------------------------------- + -- Build_RPC_Receiver_Specification -- + -------------------------------------- + + function Build_RPC_Receiver_Specification + (RPC_Receiver : Entity_Id; + 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; + ------------------------------------ -- Build_Subprogram_Calling_Stubs -- ------------------------------------ @@ -2589,9 +2550,12 @@ package body Exp_Dist is procedure Insert_Partition_Check (Parameter : in Node_Id) is Parameter_Entity : constant Entity_Id := Defining_Identifier (Parameter); - Designated_Object : Node_Id; Condition : Node_Id; + Designated_Object : Node_Id; + pragma Warnings (Off, Designated_Object); + -- Is it really right that this is unreferenced ??? + begin -- The expression that will be built is of the form: -- if not (Parameter in Stub_Type and then @@ -2790,16 +2754,16 @@ package body Exp_Dist is Result_Parameter : Node_Id; -- See explanations of those in Build_Subprogram_Calling_Stubs - Decls : List_Id := New_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. - Statements : List_Id := New_List; + Statements : constant List_Id := New_List; - Extra_Formal_Statements : List_Id := New_List; + Extra_Formal_Statements : constant List_Id := New_List; -- Statements concerning extra formal parameters - After_Statements : List_Id := New_List; + After_Statements : constant List_Id := New_List; -- Statements to be executed after the subprogram call Inner_Decls : List_Id := No_List; @@ -2810,13 +2774,14 @@ package body Exp_Dist is Excep_Choice : Entity_Id; Excep_Code : List_Id; - Parameter_List : List_Id := New_List; + Parameter_List : constant List_Id := New_List; -- List of parameters to be passed to the subprogram. Current_Parameter : Node_Id; Ordered_Parameters_List : constant List_Id := - Build_Ordered_Parameters_List (Specification (Vis_Decl)); + Build_Ordered_Parameters_List + (Specification (Vis_Decl)); Subp_Spec : Node_Id; -- Subprogram specification @@ -3238,6 +3203,7 @@ package body Exp_Dist is Current_Parameter : Node_Id; Current_Type : Node_Id; + Current_Etype : Entity_Id; Name_For_New_Spec : Name_Id; @@ -3260,28 +3226,31 @@ 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 Object_Type = Empty then Current_Type := Make_Access_Definition (Loc, Subtype_Mark => - New_Occurrence_Of (Etype ( - Subtype_Mark (Current_Type)), Loc)); + New_Occurrence_Of (Current_Etype, Loc)); else pragma Assert - (Root_Type (Etype (Subtype_Mark (Current_Type))) - = Root_Type (Object_Type)); + (Root_Type (Current_Etype) = Root_Type (Object_Type)); Current_Type := Make_Access_Definition (Loc, Subtype_Mark => New_Occurrence_Of (Stub_Type, Loc)); end if; - elsif Object_Type /= Empty - and then Etype (Current_Type) = Object_Type - then - Current_Type := New_Occurrence_Of (Stub_Type, Loc); - else - Current_Type := New_Occurrence_Of (Etype (Current_Type), Loc); + Current_Etype := Entity (Current_Type); + + if Object_Type /= Empty + and then Current_Etype = Object_Type + then + Current_Type := New_Occurrence_Of (Stub_Type, Loc); + else + Current_Type := New_Occurrence_Of (Current_Etype, Loc); + end if; end if; New_Identifier := Make_Defining_Identifier (Loc, @@ -3308,7 +3277,7 @@ package body Exp_Dist is Chars => Name_For_New_Spec), Parameter_Specifications => Parameters, Subtype_Mark => - New_Occurrence_Of (Etype (Subtype_Mark (Spec)), Loc)); + New_Occurrence_Of (Entity (Subtype_Mark (Spec)), Loc)); else return @@ -3373,7 +3342,7 @@ package body Exp_Dist is -- is not prematurely removed by the GCC back-end. declare - Scop : Entity_Id := Cunit_Entity (Current_Sem_Unit); + Scop : constant Entity_Id := Cunit_Entity (Current_Sem_Unit); begin if Ekind (Scop) = E_Package_Body then @@ -3462,7 +3431,7 @@ package body Exp_Dist is ---------------------------- function Get_Pkg_Name_String_Id (Decl_Node : Node_Id) return String_Id is - Unit_Name_Id : Unit_Name_Type := Get_Unit_Name (Decl_Node); + Unit_Name_Id : constant Unit_Name_Type := Get_Unit_Name (Decl_Node); begin Get_Unit_Name_String (Unit_Name_Id); @@ -3604,7 +3573,7 @@ package body Exp_Dist is function Pack_Entity_Into_Stream_Access (Loc : Source_Ptr; - Stream : Entity_Id; + Stream : Node_Id; Object : Entity_Id; Etyp : Entity_Id := Empty) return Node_Id @@ -3660,7 +3629,7 @@ package body Exp_Dist is function Pack_Node_Into_Stream_Access (Loc : Source_Ptr; - Stream : Entity_Id; + Stream : Node_Id; Object : Node_Id; Etyp : Entity_Id) return Node_Id @@ -3677,7 +3646,7 @@ package body Exp_Dist is Prefix => New_Occurrence_Of (Etyp, Loc), Attribute_Name => Write_Attribute, Expressions => New_List ( - New_Occurrence_Of (Stream, Loc), + Stream, Object)); end Pack_Node_Into_Stream_Access; |