From 25e9b6fe27d7665b70f22067411328f07e8ae9ff Mon Sep 17 00:00:00 2001 From: Thomas Quinot Date: Tue, 20 May 2008 14:46:31 +0200 Subject: [PATCH] 2008-05-20 Thomas Quinot * exp_dist.adb (GARLIC_Support.Add_RACW_Read_Attribute): When a zero value is received, and the RACW is null-excluding, raise CONSTRAINT_ERROR instead of assigning NULL into the result, to avoid a spurious warning. (Add_RACW_Features, case Same_Scope): Add assertion that designated type is not frozen. (Add_Stub_Type): Set entity flag Is_RACW_Stub_Type on generated stub type. (Build_From_Any_Function, Build_To_Any_Function, Build_TypeCode_Function): For a type that has user-specified stream attributes, use an opaque sequence of octets as the representation. From-SVN: r135626 --- gcc/ada/exp_dist.adb | 295 +++++++++++++++++++++++++++++-------------- 1 file changed, 201 insertions(+), 94 deletions(-) diff --git a/gcc/ada/exp_dist.adb b/gcc/ada/exp_dist.adb index 435afc5c51c..a409fe44191 100644 --- a/gcc/ada/exp_dist.adb +++ b/gcc/ada/exp_dist.adb @@ -1085,8 +1085,8 @@ package body Exp_Dist is Existing : Boolean; -- True when appropriate stubs have already been generated (this is the -- case when another RACW with the same designated type has already been - -- encountered, in which case we reuse the previous stubs rather than - -- generating new ones). + -- encountered), in which case we reuse the previous stubs rather than + -- generating new ones. begin if not Expander_Active then @@ -1164,12 +1164,13 @@ package body Exp_Dist is RPC_Receiver_Decl => RPC_Receiver_Decl, Body_Decls => Body_Decls); - if not Same_Scope and then not Existing then + -- If we already have stubs for this designated type, nothing to do - -- 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 primitives for the stub type here. + if Existing then + return; + end if; + if Is_Frozen (Desig) then Validate_RACW_Primitives (RACW_Type); Add_RACW_Primitive_Declarations_And_Bodies (Designated_Type => Desig, @@ -1177,10 +1178,9 @@ package body Exp_Dist is Body_Decls => Body_Decls); else - -- Validate_RACW_Primitives will be called when the designated type - -- is frozen, see Exp_Ch3.Freeze_Type. - - -- ??? Shouldn't we have a pragma Assert (not Is_Frozen (Desig))? + -- Validate_RACW_Primitives requires the list of all primitives of + -- the designated type, so defer processing until Desig is frozen. + -- See Exp_Ch3.Freeze_Type. Add_Access_Type_To_Process (E => Desig, A => RACW_Type); end if; @@ -1870,6 +1870,8 @@ package body Exp_Dist is Stub_Type := Make_Defining_Identifier (Loc, Chars => New_Internal_Name ('S')); + Set_Ekind (Stub_Type, E_Record_Type); + Set_Is_RACW_Stub_Type (Stub_Type); Stub_Type_Access := Make_Defining_Identifier (Loc, Chars => New_External_Name @@ -3085,19 +3087,34 @@ package body Exp_Dist is Set_Etype (Stubbed_Result, Stub_Type_Access); - -- If the Address is Null_Address, then return a null object + -- If the Address is Null_Address, then return a null object, unless + -- RACW_Type is null-excluding, in which case inconditionally raise + -- CONSTRAINT_ERROR instead. - Append_To (Statements, - Make_Implicit_If_Statement (RACW_Type, - Condition => - Make_Op_Eq (Loc, - Left_Opnd => New_Occurrence_Of (Source_Address, Loc), - Right_Opnd => Make_Integer_Literal (Loc, Uint_0)), - Then_Statements => New_List ( - Make_Assignment_Statement (Loc, - Name => Result, - Expression => Make_Null (Loc)), - Make_Simple_Return_Statement (Loc)))); + declare + Zero_Statements : List_Id; + -- Statements executed when a zero value is received + begin + if Can_Never_Be_Null (RACW_Type) then + Zero_Statements := New_List ( + Make_Raise_Constraint_Error (Loc, + Reason => CE_Null_Not_Allowed)); + else + Zero_Statements := New_List ( + Make_Assignment_Statement (Loc, + Name => Result, + Expression => Make_Null (Loc)), + Make_Simple_Return_Statement (Loc)); + end if; + + Append_To (Statements, + Make_Implicit_If_Statement (RACW_Type, + Condition => + Make_Op_Eq (Loc, + Left_Opnd => New_Occurrence_Of (Source_Address, Loc), + Right_Opnd => Make_Integer_Literal (Loc, Uint_0)), + Then_Statements => Zero_Statements)); + end; -- If the RACW denotes an object created on the current partition, -- Local_Statements will be executed. The real object will be used. @@ -8470,7 +8487,7 @@ package body Exp_Dist is function Find_Numeric_Representation (Typ : Entity_Id) return Entity_Id; - -- Given a numeric type Typ, return the smallest integer or floarting + -- Given a numeric type Typ, return the smallest integer or floating -- point type from Standard, or the smallest unsigned (modular) type -- from System.Unsigned_Types, whose range encompasses that of Typ. @@ -8729,11 +8746,16 @@ package body Exp_Dist is Decl : out Node_Id; Fnam : out Entity_Id) is - Spec : Node_Id; + Spec : Node_Id; Decls : constant List_Id := New_List; - Stms : constant List_Id := New_List; - Any_Parameter : constant Entity_Id - := Make_Defining_Identifier (Loc, New_Internal_Name ('A')); + Stms : constant List_Id := New_List; + + Any_Parameter : constant Entity_Id := + Make_Defining_Identifier (Loc, + New_Internal_Name ('A')); + + Use_Opaque_Representation : Boolean; + begin if Is_Itype (Typ) then Build_From_Any_Function @@ -8763,9 +8785,21 @@ package body Exp_Dist is pragma Assert (not (Is_Remote_Access_To_Class_Wide_Type (Typ))); - if Is_Derived_Type (Typ) - and then not Is_Tagged_Type (Typ) + Use_Opaque_Representation := False; + + if Has_Stream_Attribute_Definition + (Typ, TSS_Stream_Output, At_Any_Place => True) + or else + Has_Stream_Attribute_Definition + (Typ, TSS_Stream_Write, At_Any_Place => True) then + -- If user-defined stream attributes are specified for this + -- type, use them and transmit data as an opaque sequence of + -- stream elements. + + Use_Opaque_Representation := True; + + elsif Is_Derived_Type (Typ) and then not Is_Tagged_Type (Typ) then Append_To (Stms, Make_Simple_Return_Statement (Loc, Expression => @@ -9292,6 +9326,11 @@ package body Exp_Dist is Decls)))); else + Use_Opaque_Representation := True; + end if; + + if Use_Opaque_Representation then + -- Default: type is represented as an opaque sequence of bytes declare @@ -9588,6 +9627,10 @@ package body Exp_Dist is Any_Decl : Node_Id; Result_TC : Node_Id := Build_TypeCode_Call (Loc, Typ, Decls); + Use_Opaque_Representation : Boolean; + -- When True, use stream attributes and represent type as an + -- opaque sequence of bytes. + begin if Is_Itype (Typ) then Build_To_Any_Function @@ -9598,8 +9641,8 @@ package body Exp_Dist is return; end if; - Fnam := Make_Stream_Procedure_Function_Name (Loc, - Typ, Name_uTo_Any); + Fnam := + Make_Stream_Procedure_Function_Name (Loc, Typ, Name_uTo_Any); Spec := Make_Function_Specification (Loc, @@ -9620,39 +9663,58 @@ package body Exp_Dist is Object_Definition => New_Occurrence_Of (RTE (RE_Any), Loc)); - if Is_Derived_Type (Typ) and then not Is_Tagged_Type (Typ) then + Use_Opaque_Representation := False; + + if Has_Stream_Attribute_Definition + (Typ, TSS_Stream_Output, At_Any_Place => True) + or else + Has_Stream_Attribute_Definition + (Typ, TSS_Stream_Write, At_Any_Place => True) + then + -- If user-defined stream attributes are specified for this + -- type, use them and transmit data as an opaque sequence of + -- stream elements. + + Use_Opaque_Representation := True; + + elsif Is_Derived_Type (Typ) and then not Is_Tagged_Type (Typ) then + + -- Non-tagged derived type: convert to root type + declare - Rt_Type : constant Entity_Id - := Root_Type (Typ); - Expr : constant Node_Id - := OK_Convert_To ( - Rt_Type, - New_Occurrence_Of (Expr_Parameter, Loc)); + Rt_Type : constant Entity_Id := Root_Type (Typ); + Expr : constant Node_Id := + OK_Convert_To + (Rt_Type, + New_Occurrence_Of (Expr_Parameter, Loc)); begin Set_Expression (Any_Decl, Build_To_Any_Call (Expr, Decls)); end; elsif Is_Record_Type (Typ) and then not Is_Tagged_Type (Typ) then + + -- Non-tagged record type + if Nkind (Declaration_Node (Typ)) = N_Subtype_Declaration then declare - Rt_Type : constant Entity_Id - := Etype (Typ); - Expr : constant Node_Id - := OK_Convert_To ( - Rt_Type, - New_Occurrence_Of (Expr_Parameter, Loc)); + Rt_Type : constant Entity_Id := Etype (Typ); + Expr : constant Node_Id := + OK_Convert_To (Rt_Type, + New_Occurrence_Of (Expr_Parameter, Loc)); begin Set_Expression (Any_Decl, Build_To_Any_Call (Expr, Decls)); end; + -- Comment needed here (and label on declare block ???) + else declare - Disc : Entity_Id := Empty; - Rdef : constant Node_Id := - Type_Definition (Declaration_Node (Typ)); - Counter : Int := 0; + Disc : Entity_Id := Empty; + Rdef : constant Node_Id := + Type_Definition (Declaration_Node (Typ)); + Counter : Int := 0; Elements : constant List_Id := New_List; procedure TA_Rec_Add_Process_Element @@ -9661,6 +9723,7 @@ package body Exp_Dist is Counter : in out Int; Rec : Entity_Id; Field : Node_Id); + -- Processing routine for traversal below procedure TA_Append_Record_Traversal is new Append_Record_Traversal @@ -9702,15 +9765,15 @@ package body Exp_Dist is else -- A variant part - declare - Variant : Node_Id; + Variant_Part : declare + Variant : Node_Id; Struct_Counter : Int := 0; Block_Decls : constant List_Id := New_List; Block_Stmts : constant List_Id := New_List; VP_Stmts : List_Id; - Alt_List : constant List_Id := New_List; + Alt_List : constant List_Id := New_List; Choice_List : List_Id; Union_Any : constant Entity_Id := @@ -9723,8 +9786,8 @@ package body Exp_Dist is function Make_Discriminant_Reference return Node_Id; - -- Build a selected component for the - -- discriminant of this variant part. + -- Build reference to the discriminant for this + -- variant part. --------------------------------- -- Make_Discriminant_Reference -- @@ -9743,6 +9806,8 @@ package body Exp_Dist is return Nod; end Make_Discriminant_Reference; + -- Start processing for Variant_Part + begin Append_To (Stmts, Make_Block_Statement (Loc, @@ -9752,11 +9817,10 @@ 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. + -- Declare 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, @@ -9777,9 +9841,8 @@ package body Exp_Dist is Make_Integer_Literal (Loc, Counter))))))); - -- Declare the inner struct aggregate - -- (that will contain the components - -- of this VP) + -- Declare inner struct aggregate (which + -- contains the components of this VP). Append_To (Block_Decls, Make_Object_Declaration (Loc, @@ -9800,9 +9863,7 @@ package body Exp_Dist is Make_Integer_Literal (Loc, Uint_1))))))); - -- Construct a case statement that will choose - -- the appropriate code at runtime depending on - -- the discriminant. + -- Build case statement Append_To (Block_Stmts, Make_Case_Statement (Loc, @@ -9818,8 +9879,7 @@ package body Exp_Dist is VP_Stmts := New_List; - -- Append discriminant value to union - -- aggregate. + -- Append discriminant val to union aggregate Append_To (VP_Stmts, Make_Procedure_Call_Statement (Loc, @@ -9878,8 +9938,9 @@ package body Exp_Dist is Next_Non_Pragma (Variant); end loop; - end; + end Variant_Part; end if; + Counter := Counter + 1; end TA_Rec_Add_Process_Element; @@ -9989,6 +10050,9 @@ package body Exp_Dist is end if; elsif Is_Array_Type (Typ) then + + -- Constrained and unconstrained array types + declare Constrained : constant Boolean := Is_Constrained (Typ); @@ -10074,6 +10138,9 @@ package body Exp_Dist is end; elsif Is_Integer_Type (Typ) or else Is_Unsigned_Type (Typ) then + + -- Integer types + Set_Expression (Any_Decl, Build_To_Any_Call ( OK_Convert_To ( @@ -10082,14 +10149,22 @@ package body Exp_Dist is Decls)); else - -- Default: type is represented as an opaque sequence of bytes + -- Default case, including tagged types: opaque representation + + Use_Opaque_Representation := True; + end if; + if Use_Opaque_Representation then declare - Strm : constant Entity_Id := Make_Defining_Identifier (Loc, - New_Internal_Name ('S')); + Strm : constant Entity_Id := + Make_Defining_Identifier (Loc, + Chars => New_Internal_Name ('S')); + -- Stream used to store data representation produced by + -- stream attribute. begin - -- Strm : aliased Buffer_Stream_Type; + -- Generate: + -- Strm : aliased Buffer_Stream_Type; Append_To (Decls, Make_Object_Declaration (Loc, @@ -10100,7 +10175,8 @@ package body Exp_Dist is Object_Definition => New_Occurrence_Of (RTE (RE_Buffer_Stream_Type), Loc))); - -- Allocate_Buffer (Strm); + -- Generate: + -- Allocate_Buffer (Strm); Append_To (Stms, Make_Procedure_Call_Statement (Loc, @@ -10109,19 +10185,21 @@ package body Exp_Dist is Parameter_Associations => New_List ( New_Occurrence_Of (Strm, Loc)))); - -- T'Output (Strm'Access, E); + -- Generate: + -- T'Output (Strm'Access, E); Append_To (Stms, Make_Attribute_Reference (Loc, Prefix => New_Occurrence_Of (Typ, Loc), Attribute_Name => Name_Output, - Expressions => New_List ( + Expressions => New_List ( Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (Strm, Loc), + Prefix => New_Occurrence_Of (Strm, Loc), Attribute_Name => Name_Access), New_Occurrence_Of (Expr_Parameter, Loc)))); - -- BS_To_Any (Strm, A); + -- Generate: + -- BS_To_Any (Strm, A); Append_To (Stms, Make_Procedure_Call_Statement (Loc, @@ -10131,7 +10209,8 @@ package body Exp_Dist is New_Occurrence_Of (Strm, Loc), New_Occurrence_Of (Any, Loc)))); - -- Release_Buffer (Strm); + -- Generate: + -- Release_Buffer (Strm); Append_To (Stms, Make_Procedure_Call_Statement (Loc, @@ -10175,14 +10254,13 @@ package body Exp_Dist is Typ : Entity_Id; Decls : List_Id) return Node_Id is - U_Type : Entity_Id := Underlying_Type (Typ); + U_Type : Entity_Id := Underlying_Type (Typ); -- The full view, if Typ is private; the completion, -- if Typ is incomplete. - Fnam : Entity_Id := Empty; - Lib_RE : RE_Id := RE_Null; - - Expr : Node_Id; + Fnam : Entity_Id := Empty; + Lib_RE : RE_Id := RE_Null; + Expr : Node_Id; begin -- Special case System.PolyORB.Interface.Any: its primitives have @@ -10729,22 +10807,29 @@ package body Exp_Dist is Initialize_Parameter_List (Type_Name_Str, Type_Repo_Id_Str, Parameters); - if Is_Derived_Type (Typ) - and then not Is_Tagged_Type (Typ) + if Has_Stream_Attribute_Definition + (Typ, TSS_Stream_Output, At_Any_Place => True) + or else + Has_Stream_Attribute_Definition + (Typ, TSS_Stream_Write, At_Any_Place => True) then + -- If user-defined stream attributes are specified for this + -- type, use them and transmit data as an opaque sequence of + -- stream elements. + + Return_Alias_TypeCode + (New_Occurrence_Of (RTE (RE_TC_Opaque), Loc)); + + elsif Is_Derived_Type (Typ) and then not Is_Tagged_Type (Typ) then Return_Alias_TypeCode ( Build_TypeCode_Call (Loc, Etype (Typ), Decls)); - elsif Is_Integer_Type (Typ) - or else Is_Unsigned_Type (Typ) - then + elsif Is_Integer_Type (Typ) or else Is_Unsigned_Type (Typ) then Return_Alias_TypeCode ( Build_TypeCode_Call (Loc, Find_Numeric_Representation (Typ), Decls)); - elsif Is_Record_Type (Typ) - and then not Is_Tagged_Type (Typ) - then + elsif Is_Record_Type (Typ) and then not Is_Tagged_Type (Typ) then -- Record typecodes are encoded as follows: -- -- TC_STRUCT @@ -11280,11 +11365,33 @@ package body Exp_Dist is Stub_Elements : constant Stub_Structure := Stubs_Table.Get (Full_View); begin + -- For an RACW encountered before the freeze point of its designated + -- type, the stub type is generated at the point of the RACW declaration + -- but the primitives are generated only once the designated type is + -- frozen. That freeze can occur in another scope, for example when the + -- RACW is declared in a nested package. In that case we need to + -- reestablish the stub type's scope prior to generating its primitive + -- operations. + if Stub_Elements /= Empty_Stub_Structure then - Add_RACW_Primitive_Declarations_And_Bodies - (Full_View, - Stub_Elements.RPC_Receiver_Decl, - Stub_Elements.Body_Decls); + declare + Saved_Scope : constant Entity_Id := Current_Scope; + Stubs_Scope : constant Entity_Id := + Scope (Stub_Elements.Stub_Type); + begin + if Current_Scope /= Stubs_Scope then + Push_Scope (Stubs_Scope); + end if; + + Add_RACW_Primitive_Declarations_And_Bodies + (Full_View, + Stub_Elements.RPC_Receiver_Decl, + Stub_Elements.Body_Decls); + + if Current_Scope /= Saved_Scope then + Pop_Scope; + end if; + end; end if; end Remote_Types_Tagged_Full_View_Encountered; -- 2.30.2