From c3d593c9d3e2716097a4feb03d16c92ba35f3fe7 Mon Sep 17 00:00:00 2001 From: Thomas Quinot Date: Wed, 6 Jun 2007 12:26:39 +0200 Subject: [PATCH] exp_dist.ads, [...] (Make_Transportable_Check): New subprogram (GARLIC_Support.Build_Subprogram_Receiving_Stubs... 2007-04-20 Thomas Quinot * exp_dist.ads, exp_dist.adb (Make_Transportable_Check): New subprogram (GARLIC_Support.Build_Subprogram_Receiving_Stubs, PolyORB_Support.Build_Subprogram_Receiving_Stubs): For a remote call to a function with a classwide return type, apply an E.4(18) check to the returned value. (Add_RACW_Primitive_Declarations_And_Bodies): Do not generate stubs for stream attributes of the designated type of an RACW, as they are not dispatching primitive operations. From-SVN: r125403 --- gcc/ada/exp_dist.adb | 341 +++++++++++++++++++++++++++++-------------- gcc/ada/exp_dist.ads | 11 +- 2 files changed, 240 insertions(+), 112 deletions(-) diff --git a/gcc/ada/exp_dist.adb b/gcc/ada/exp_dist.adb index 9e97bb10bf5..10eae084718 100644 --- a/gcc/ada/exp_dist.adb +++ b/gcc/ada/exp_dist.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2006, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2007, 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,11 +27,11 @@ with Atree; use Atree; with Einfo; use Einfo; with Elists; use Elists; +with Exp_Atag; use Exp_Atag; with Exp_Strm; use Exp_Strm; with Exp_Tss; use Exp_Tss; with Exp_Util; use Exp_Util; with Lib; use Lib; -with Namet; use Namet; with Nlists; use Nlists; with Nmake; use Nmake; with Opt; use Opt; @@ -162,12 +162,12 @@ package body Exp_Dist is Vis_Decl : Node_Id; All_Calls_Remote_E : Entity_Id; Proxy_Object_Addr : out Entity_Id); - -- Add the proxy type necessary to call the subprogram declared - -- by Vis_Decl through a remote access to subprogram type. - -- All_Calls_Remote_E must be Standard_True if a pragma All_Calls_Remote - -- applies, Standard_False otherwise. The new proxy type is appended - -- to Decls. Proxy_Object_Addr is a constant of type System.Address that - -- designates an instance of the proxy object. + -- Add the proxy type required, on the receiving (server) side, to handle + -- calls to the subprogram declared by Vis_Decl through a remote access + -- to subprogram type. All_Calls_Remote_E must be Standard_True if a pragma + -- All_Calls_Remote applies, Standard_False otherwise. The new proxy type + -- is appended to Decls. Proxy_Object_Addr is a constant of type + -- System.Address that designates an instance of the proxy object. function Build_Remote_Subprogram_Proxy_Type (Loc : Source_Ptr; @@ -1270,7 +1270,12 @@ package body Exp_Dist is if Chars (Current_Primitive) /= Name_uSize and then Chars (Current_Primitive) /= Name_uAlignment - and then not Is_TSS (Current_Primitive, TSS_Deep_Finalize) + and then not + (Is_TSS (Current_Primitive, TSS_Deep_Finalize) or else + Is_TSS (Current_Primitive, TSS_Stream_Input) or else + Is_TSS (Current_Primitive, TSS_Stream_Output) or else + Is_TSS (Current_Primitive, TSS_Stream_Read) or else + Is_TSS (Current_Primitive, TSS_Stream_Write)) then -- The first thing to do is build an up-to-date copy of the -- spec with all the formals referencing Designated_Type @@ -2705,14 +2710,14 @@ package body Exp_Dist is begin if Ekind (Scop) = E_Package_Body then - New_Scope (Spec_Entity (Scop)); + Push_Scope (Spec_Entity (Scop)); elsif Ekind (Scop) = E_Subprogram_Body then - New_Scope + Push_Scope (Corresponding_Spec (Unit_Declaration_Node (Scop))); else - New_Scope (Scop); + Push_Scope (Scop); end if; Analyze (RCI_Locator); @@ -2750,7 +2755,7 @@ package body Exp_Dist is Spec : constant Node_Id := Specification (Unit_Node); Decls : constant List_Id := Visible_Declarations (Spec); begin - New_Scope (Scope_Of_Spec (Spec)); + Push_Scope (Scope_Of_Spec (Spec)); Add_Calling_Stubs_To_Declarations (Specification (Unit_Node), Decls); Pop_Scope; @@ -2774,7 +2779,7 @@ package body Exp_Dist is Decls := Visible_Declarations (Spec); end if; - New_Scope (Scope_Of_Spec (Spec)); + Push_Scope (Scope_Of_Spec (Spec)); Specific_Add_Receiving_Stubs_To_Declarations (Spec, Decls, Decls); else @@ -2782,7 +2787,7 @@ package body Exp_Dist is Package_Specification_Of_Scope (Corresponding_Spec (Unit_Node)); Decls := Declarations (Unit_Node); - New_Scope (Scope_Of_Spec (Unit_Node)); + Push_Scope (Scope_Of_Spec (Unit_Node)); Temp := New_List; Specific_Add_Receiving_Stubs_To_Declarations (Spec, Temp, Statements (Handled_Statement_Sequence (Unit_Node))); @@ -3645,17 +3650,17 @@ package body Exp_Dist is -- - a package RPC receiver must be built. This subprogram -- will get a Subprogram_Id from the incoming stream - -- and will dispatch the call to the right subprogram + -- and will dispatch the call to the right subprogram; - -- - a receiving stub for any subprogram visible in the package + -- - a receiving stub for each subprogram visible in the package -- spec. This stub will read all the parameters from the stream, -- and put the result as well as the exception occurrence in the - -- output stream + -- output stream; -- - a dummy package with an empty spec and a body made of an -- elaboration part, whose job is to register the receiving -- part of this RCI package on the name server. This is done - -- by calling System.Partition_Interface.Register_Receiving_Stub + -- by calling System.Partition_Interface.Register_Receiving_Stub. Build_RPC_Receiver_Body ( RPC_Receiver => Pkg_RPC_Receiver, @@ -3861,76 +3866,121 @@ package body Exp_Dist is High_Bound => Make_Integer_Literal (Loc, First_RCI_Subprogram_Id - + List_Length (Subp_Info_List) - 1))))), - Expression => - Make_Aggregate (Loc, - Component_Associations => Subp_Info_List))); + + List_Length (Subp_Info_List) - 1))))))); + + -- For a degenerate RCI with no visible subprograms, Subp_Info_List + -- has zero length, and the declaration is for an empty array, in + -- which case no initialization aggregate must be generated. + + if Present (First (Subp_Info_List)) then + Set_Expression (Last (Decls), + Make_Aggregate (Loc, + Component_Associations => Subp_Info_List)); + + -- No initialization provided: remove CONSTANT so that the + -- declaration is not an incomplete deferred constant. + + else + Set_Constant_Present (Last (Decls), False); + end if; + Analyze (Last (Decls)); - Append_To (Decls, - Make_Subprogram_Body (Loc, - Specification => - Copy_Specification (Loc, Parent (Lookup_RAS_Info)), - Declarations => - No_List, - Handled_Statement_Sequence => - Make_Handled_Sequence_Of_Statements (Loc, - Statements => New_List ( - Make_Return_Statement (Loc, - Expression => OK_Convert_To (RTE (RE_Unsigned_64), - Make_Selected_Component (Loc, - Prefix => - Make_Indexed_Component (Loc, - Prefix => - New_Occurrence_Of (Subp_Info_Array, Loc), - Expressions => New_List ( - Convert_To (Standard_Integer, - Make_Identifier (Loc, Name_Subp_Id)))), - Selector_Name => - Make_Identifier (Loc, Name_Addr)))))))); + declare + Subp_Info_Addr : Node_Id; + -- Return statement for Lookup_RAS_Info: address of the subprogram + -- information record for the requested subprogram id. + + begin + if Present (First (Subp_Info_List)) then + Subp_Info_Addr := + Make_Selected_Component (Loc, + Prefix => + Make_Indexed_Component (Loc, + Prefix => + New_Occurrence_Of (Subp_Info_Array, Loc), + Expressions => New_List ( + Convert_To (Standard_Integer, + Make_Identifier (Loc, Name_Subp_Id)))), + Selector_Name => + Make_Identifier (Loc, Name_Addr)); + + -- Case of no visible subprogram: just raise Constraint_Error, we + -- know for sure we got junk from a remote partition. + + else + Subp_Info_Addr := + Make_Raise_Constraint_Error (Loc, + Reason => CE_Range_Check_Failed); + Set_Etype (Subp_Info_Addr, RTE (RE_Unsigned_64)); + end if; + + Append_To (Decls, + Make_Subprogram_Body (Loc, + Specification => + Copy_Specification (Loc, Parent (Lookup_RAS_Info)), + Declarations => + No_List, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List ( + Make_Return_Statement (Loc, + Expression => + OK_Convert_To (RTE (RE_Unsigned_64), + Subp_Info_Addr)))))); + end; + Analyze (Last (Decls)); Append_To (Decls, Pkg_RPC_Receiver_Body); Analyze (Last (Decls)); Get_Library_Unit_Name_String (Pkg_Spec); + + -- Name + Append_To (Register_Pkg_Actuals, - -- Name Make_String_Literal (Loc, Strval => String_From_Name_Buffer)); + -- Receiver + Append_To (Register_Pkg_Actuals, - -- Receiver Make_Attribute_Reference (Loc, Prefix => New_Occurrence_Of (Pkg_RPC_Receiver, Loc), Attribute_Name => Name_Unrestricted_Access)); + -- Version + Append_To (Register_Pkg_Actuals, - -- Version Make_Attribute_Reference (Loc, Prefix => New_Occurrence_Of (Defining_Entity (Pkg_Spec), Loc), Attribute_Name => Name_Version)); + -- Subp_Info + Append_To (Register_Pkg_Actuals, - -- Subp_Info Make_Attribute_Reference (Loc, Prefix => New_Occurrence_Of (Subp_Info_Array, Loc), Attribute_Name => Name_Address)); + -- Subp_Info_Len + Append_To (Register_Pkg_Actuals, - -- Subp_Info_Len Make_Attribute_Reference (Loc, Prefix => New_Occurrence_Of (Subp_Info_Array, Loc), Attribute_Name => Name_Length)); + -- Generate the call + Append_To (Stmts, Make_Procedure_Call_Statement (Loc, Name => @@ -4932,6 +4982,18 @@ package body Exp_Dist is Name => Called_Subprogram, Parameter_Associations => Parameter_List))); + if Is_Class_Wide_Type (Etyp) then + + -- For a remote call to a function with a class-wide type, + -- check that the returned value satisfies the requirements + -- of E.4(18). + + Append_To (Inner_Decls, + Make_Transportable_Check (Loc, + New_Occurrence_Of (Result, Loc))); + + end if; + Append_To (After_Statements, Make_Attribute_Reference (Loc, Prefix => New_Occurrence_Of (Etyp, Loc), @@ -5195,6 +5257,25 @@ package body Exp_Dist is or else Etype (Typ) = Stub_Type; end Is_RACW_Controlling_Formal; + ------------------------------ + -- Make_Transportable_Check -- + ------------------------------ + + function Make_Transportable_Check + (Loc : Source_Ptr; + Expr : Node_Id) return Node_Id is + begin + return + Make_Raise_Program_Error (Loc, + Condition => + Make_Op_Not (Loc, + Build_Get_Transportable (Loc, + Make_Selected_Component (Loc, + Prefix => Expr, + Selector_Name => Make_Identifier (Loc, Name_uTag)))), + Reason => PE_Non_Transportable_Actual); + end Make_Transportable_Check; + ----------------------------- -- Make_Selected_Component -- ----------------------------- @@ -6873,17 +6954,17 @@ package body Exp_Dist is -- - a package RPC receiver must be built. This subprogram -- will get a Subprogram_Id from the incoming stream - -- and will dispatch the call to the right subprogram + -- and will dispatch the call to the right subprogram; - -- - a receiving stub for any subprogram visible in the package + -- - a receiving stub for each subprogram visible in the package -- spec. This stub will read all the parameters from the stream, -- and put the result as well as the exception occurrence in the - -- output stream + -- output stream; -- - a dummy package with an empty spec and a body made of an -- elaboration part, whose job is to register the receiving -- part of this RCI package on the name server. This is done - -- by calling System.Partition_Interface.Register_Receiving_Stub + -- by calling System.Partition_Interface.Register_Receiving_Stub. Build_RPC_Receiver_Body ( RPC_Receiver => Pkg_RPC_Receiver, @@ -6922,41 +7003,6 @@ package body Exp_Dist is New_Occurrence_Of (Is_Local, Loc), New_Occurrence_Of (Local_Address, Loc)))); - -- Determine whether the reference that was used to make - -- the call was the base RCI reference (in which case - -- Local_Address is 0, and the method identifier from the - -- request must be used to determine which subprogram is - -- called) or a reference identifying one particular subprogram - -- (in which case Local_Address is the address of that - -- subprogram, and the method name from the request is - -- ignored). - -- In each case, cascaded elsifs are used to determine the - -- proper subprogram index. Using hash tables might be - -- more efficient. - - Append_To (Pkg_RPC_Receiver_Statements, - Make_Implicit_If_Statement (Pkg_Spec, - Condition => - Make_Op_Ne (Loc, - Left_Opnd => New_Occurrence_Of (Local_Address, Loc), - Right_Opnd => New_Occurrence_Of (RTE (RE_Null_Address), Loc)), - Then_Statements => New_List ( - Make_Implicit_If_Statement (Pkg_Spec, - Condition => - New_Occurrence_Of (Standard_False, Loc), - Then_Statements => New_List ( - Make_Null_Statement (Loc)), - Elsif_Parts => - Dispatch_On_Address)), - Else_Statements => New_List ( - Make_Implicit_If_Statement (Pkg_Spec, - Condition => - New_Occurrence_Of (Standard_False, Loc), - Then_Statements => New_List ( - Make_Null_Statement (Loc)), - Elsif_Parts => - Dispatch_On_Name)))); - -- For each subprogram, the receiving stub will be built and a -- case statement will be made on the Subprogram_Id to dispatch -- to the right subprogram. @@ -7076,6 +7122,88 @@ package body Exp_Dist is Next (Current_Declaration); end loop; + Append_To (Decls, + Make_Object_Declaration (Loc, + Defining_Identifier => Subp_Info_Array, + Constant_Present => True, + Aliased_Present => True, + Object_Definition => + Make_Subtype_Indication (Loc, + Subtype_Mark => + New_Occurrence_Of (RTE (RE_RCI_Subp_Info_Array), Loc), + Constraint => + Make_Index_Or_Discriminant_Constraint (Loc, + New_List ( + Make_Range (Loc, + Low_Bound => Make_Integer_Literal (Loc, + First_RCI_Subprogram_Id), + High_Bound => + Make_Integer_Literal (Loc, + First_RCI_Subprogram_Id + + List_Length (Subp_Info_List) - 1))))))); + + if Present (First (Subp_Info_List)) then + Set_Expression (Last (Decls), + Make_Aggregate (Loc, + Component_Associations => Subp_Info_List)); + + -- Generate the dispatch statement to determine the subprogram id + -- of the called subprogram. + + -- We first test whether the reference that was used to make the + -- call was the base RCI reference (in which case Local_Address is + -- zero, and the method identifier from the request must be used + -- to determine which subprogram is called) or a reference + -- identifying one particular subprogram (in which case + -- Local_Address is the address of that subprogram, and the + -- method name from the request is ignored). The latter occurs + -- for the case of a call through a remote access-to-subprogram. + + -- In each case, cascaded elsifs are used to determine the proper + -- subprogram index. Using hash tables might be more efficient. + + Append_To (Pkg_RPC_Receiver_Statements, + Make_Implicit_If_Statement (Pkg_Spec, + Condition => + Make_Op_Ne (Loc, + Left_Opnd => New_Occurrence_Of + (Local_Address, Loc), + Right_Opnd => New_Occurrence_Of + (RTE (RE_Null_Address), Loc)), + Then_Statements => New_List ( + Make_Implicit_If_Statement (Pkg_Spec, + Condition => + New_Occurrence_Of (Standard_False, Loc), + Then_Statements => New_List ( + Make_Null_Statement (Loc)), + Elsif_Parts => + Dispatch_On_Address)), + + Else_Statements => New_List ( + Make_Implicit_If_Statement (Pkg_Spec, + Condition => + New_Occurrence_Of (Standard_False, Loc), + Then_Statements => New_List ( + Make_Null_Statement (Loc)), + Elsif_Parts => + Dispatch_On_Name)))); + + else + -- For a degenerate RCI with no visible subprograms, + -- Subp_Info_List has zero length, and the declaration is for an + -- empty array, in which case no initialization aggregate must be + -- generated. We do not generate a Dispatch_Statement either. + + -- No initialization provided: remove CONSTANT so that the + -- declaration is not an incomplete deferred constant. + + Set_Constant_Present (Last (Decls), False); + end if; + + -- Analyze Subp_Info_Array declaration + + Analyze (Last (Decls)); + -- If we receive an invalid Subprogram_Id, it is best to do nothing -- rather than raising an exception since we do not want someone -- to crash a remote partition by sending invalid subprogram ids. @@ -7097,29 +7225,8 @@ package body Exp_Dist is New_Occurrence_Of (Subp_Index, Loc), Alternatives => Pkg_RPC_Receiver_Cases)); - Append_To (Decls, - Make_Object_Declaration (Loc, - Defining_Identifier => Subp_Info_Array, - Constant_Present => True, - Aliased_Present => True, - Object_Definition => - Make_Subtype_Indication (Loc, - Subtype_Mark => - New_Occurrence_Of (RTE (RE_RCI_Subp_Info_Array), Loc), - Constraint => - Make_Index_Or_Discriminant_Constraint (Loc, - New_List ( - Make_Range (Loc, - Low_Bound => Make_Integer_Literal (Loc, - First_RCI_Subprogram_Id), - High_Bound => - Make_Integer_Literal (Loc, - First_RCI_Subprogram_Id - + List_Length (Subp_Info_List) - 1))))), - Expression => - Make_Aggregate (Loc, - Component_Associations => Subp_Info_List))); - Analyze (Last (Decls)); + -- Pkg_RPC_Receiver body is now complete: insert it into the tree and + -- analyze it. Append_To (Decls, Pkg_RPC_Receiver_Body); Analyze (Last (Decls)); @@ -8183,6 +8290,18 @@ package body Exp_Dist is Name => Called_Subprogram, Parameter_Associations => Parameter_List))); + if Is_Class_Wide_Type (Etyp) then + + -- For a remote call to a function with a class-wide type, + -- check that the returned value satisfies the requirements + -- of E.4(18). + + Append_To (Inner_Decls, + Make_Transportable_Check (Loc, + New_Occurrence_Of (Result, Loc))); + + end if; + Set_Etype (Result, Etyp); Append_To (After_Statements, Make_Procedure_Call_Statement (Loc, diff --git a/gcc/ada/exp_dist.ads b/gcc/ada/exp_dist.ads index 5e9361c3668..41c4d3f2c94 100644 --- a/gcc/ada/exp_dist.ads +++ b/gcc/ada/exp_dist.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2006, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2007, 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 @@ -- This package contains utility routines used for the generation of the -- stubs relevant to the distribution annex. +with Namet; use Namet; with Types; use Types; package Exp_Dist is @@ -110,4 +111,12 @@ package Exp_Dist is -- not be generated in the package spec because this would cause an -- incorrect attempt to freeze Taft amendment types declared in the spec. + function Make_Transportable_Check + (Loc : Source_Ptr; + Expr : Node_Id) return Node_Id; + -- Generate a check that the given expression (an actual in a remote + -- subprogram call, or the return value of a function in the context of + -- a remote call) satisfies the requirements for being transportable + -- across partitions, raising Program_Error if it does not. + end Exp_Dist;