OpenE2K/gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

2008-05-20 Thomas Quinot <quinot@adacore.com>

Browse Source 
* 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
This commit is contained in:
Thomas Quinot 2008-05-20 14:46:31 +02:00 committed by Arnaud Charlet
parent 5b7dd52da8
commit 25e9b6fe27
1 changed files with 201 additions and 94 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

233
gcc/ada/exp_dist.adb
View File

@ -1085,8 +1085,8 @@ package body Exp_Dist is
Existing : Boolean; Existing : Boolean;
-- True when appropriate stubs have already been generated (this is the -- True when appropriate stubs have already been generated (this is the
-- case when another RACW with the same designated type has already been -- case when another RACW with the same designated type has already been
-- encountered, in which case we reuse the previous stubs rather than -- encountered), in which case we reuse the previous stubs rather than
-- generating new ones). -- generating new ones.
begin begin
if not Expander_Active then if not Expander_Active then
@ -1164,12 +1164,13 @@ package body Exp_Dist is
RPC_Receiver_Decl => RPC_Receiver_Decl, RPC_Receiver_Decl => RPC_Receiver_Decl,
Body_Decls => Body_Decls); 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 if Existing then
-- type and has not been handled by another RACW in the same package return;
-- as the first one, so add primitives for the stub type here. end if;
if Is_Frozen (Desig) then
Validate_RACW_Primitives (RACW_Type); Validate_RACW_Primitives (RACW_Type);
Add_RACW_Primitive_Declarations_And_Bodies Add_RACW_Primitive_Declarations_And_Bodies
(Designated_Type => Desig, (Designated_Type => Desig,
@ -1177,10 +1178,9 @@ package body Exp_Dist is
Body_Decls => Body_Decls); Body_Decls => Body_Decls);
else else
-- Validate_RACW_Primitives will be called when the designated type -- Validate_RACW_Primitives requires the list of all primitives of
-- is frozen, see Exp_Ch3.Freeze_Type. -- the designated type, so defer processing until Desig is frozen.
-- See Exp_Ch3.Freeze_Type.
-- ??? Shouldn't we have a pragma Assert (not Is_Frozen (Desig))?
Add_Access_Type_To_Process (E => Desig, A => RACW_Type); Add_Access_Type_To_Process (E => Desig, A => RACW_Type);
end if; end if;
@ -1870,6 +1870,8 @@ package body Exp_Dist is
Stub_Type := Stub_Type :=
Make_Defining_Identifier (Loc, Make_Defining_Identifier (Loc,
Chars => New_Internal_Name ('S')); Chars => New_Internal_Name ('S'));
Set_Ekind (Stub_Type, E_Record_Type);
Set_Is_RACW_Stub_Type (Stub_Type);
Stub_Type_Access := Stub_Type_Access :=
Make_Defining_Identifier (Loc, Make_Defining_Identifier (Loc,
Chars => New_External_Name Chars => New_External_Name
@ -3085,7 +3087,25 @@ package body Exp_Dist is
Set_Etype (Stubbed_Result, Stub_Type_Access); 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.
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, Append_To (Statements,
Make_Implicit_If_Statement (RACW_Type, Make_Implicit_If_Statement (RACW_Type,
@ -3093,11 +3113,8 @@ package body Exp_Dist is
Make_Op_Eq (Loc, Make_Op_Eq (Loc,
Left_Opnd => New_Occurrence_Of (Source_Address, Loc), Left_Opnd => New_Occurrence_Of (Source_Address, Loc),
Right_Opnd => Make_Integer_Literal (Loc, Uint_0)), Right_Opnd => Make_Integer_Literal (Loc, Uint_0)),
Then_Statements => New_List ( Then_Statements => Zero_Statements));
Make_Assignment_Statement (Loc, end;
Name => Result,
Expression => Make_Null (Loc)),
Make_Simple_Return_Statement (Loc))));
-- If the RACW denotes an object created on the current partition, -- If the RACW denotes an object created on the current partition,
-- Local_Statements will be executed. The real object will be used. -- Local_Statements will be executed. The real object will be used.
@ -8470,7 +8487,7 @@ package body Exp_Dist is
function Find_Numeric_Representation function Find_Numeric_Representation
(Typ : Entity_Id) return Entity_Id; (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 -- point type from Standard, or the smallest unsigned (modular) type
-- from System.Unsigned_Types, whose range encompasses that of Typ. -- from System.Unsigned_Types, whose range encompasses that of Typ.
@ -8732,8 +8749,13 @@ package body Exp_Dist is
Spec : Node_Id; Spec : Node_Id;
Decls : constant List_Id := New_List; Decls : constant List_Id := New_List;
Stms : constant List_Id := New_List; Stms : constant List_Id := New_List;
Any_Parameter : constant Entity_Id
:= Make_Defining_Identifier (Loc, New_Internal_Name ('A')); Any_Parameter : constant Entity_Id :=
Make_Defining_Identifier (Loc,
New_Internal_Name ('A'));
Use_Opaque_Representation : Boolean;
begin begin
if Is_Itype (Typ) then if Is_Itype (Typ) then
Build_From_Any_Function Build_From_Any_Function
@ -8763,9 +8785,21 @@ package body Exp_Dist is
pragma Assert pragma Assert
(not (Is_Remote_Access_To_Class_Wide_Type (Typ))); (not (Is_Remote_Access_To_Class_Wide_Type (Typ)));
if Is_Derived_Type (Typ) Use_Opaque_Representation := False;
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 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, Append_To (Stms,
Make_Simple_Return_Statement (Loc, Make_Simple_Return_Statement (Loc,
Expression => Expression =>
@ -9292,6 +9326,11 @@ package body Exp_Dist is
Decls)))); Decls))));
else else
Use_Opaque_Representation := True;
end if;
if Use_Opaque_Representation then
-- Default: type is represented as an opaque sequence of bytes -- Default: type is represented as an opaque sequence of bytes
declare declare
@ -9588,6 +9627,10 @@ package body Exp_Dist is
Any_Decl : Node_Id; Any_Decl : Node_Id;
Result_TC : Node_Id := Build_TypeCode_Call (Loc, Typ, Decls); 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 begin
if Is_Itype (Typ) then if Is_Itype (Typ) then
Build_To_Any_Function Build_To_Any_Function
@ -9598,8 +9641,8 @@ package body Exp_Dist is
return; return;
end if; end if;
Fnam := Make_Stream_Procedure_Function_Name (Loc, Fnam :=
Typ, Name_uTo_Any); Make_Stream_Procedure_Function_Name (Loc, Typ, Name_uTo_Any);
Spec := Spec :=
Make_Function_Specification (Loc, Make_Function_Specification (Loc,
@ -9620,26 +9663,43 @@ package body Exp_Dist is
Object_Definition => Object_Definition =>
New_Occurrence_Of (RTE (RE_Any), Loc)); 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 declare
Rt_Type : constant Entity_Id Rt_Type : constant Entity_Id := Root_Type (Typ);
:= Root_Type (Typ); Expr : constant Node_Id :=
Expr : constant Node_Id OK_Convert_To
:= OK_Convert_To ( (Rt_Type,
Rt_Type,
New_Occurrence_Of (Expr_Parameter, Loc)); New_Occurrence_Of (Expr_Parameter, Loc));
begin begin
Set_Expression (Any_Decl, Build_To_Any_Call (Expr, Decls)); Set_Expression (Any_Decl, Build_To_Any_Call (Expr, Decls));
end; end;
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
-- Non-tagged record type
if Nkind (Declaration_Node (Typ)) = N_Subtype_Declaration then if Nkind (Declaration_Node (Typ)) = N_Subtype_Declaration then
declare declare
Rt_Type : constant Entity_Id Rt_Type : constant Entity_Id := Etype (Typ);
:= Etype (Typ); Expr : constant Node_Id :=
Expr : constant Node_Id OK_Convert_To (Rt_Type,
:= OK_Convert_To (
Rt_Type,
New_Occurrence_Of (Expr_Parameter, Loc)); New_Occurrence_Of (Expr_Parameter, Loc));
begin begin
@ -9647,6 +9707,8 @@ package body Exp_Dist is
Build_To_Any_Call (Expr, Decls)); Build_To_Any_Call (Expr, Decls));
end; end;
-- Comment needed here (and label on declare block ???)
else else
declare declare
Disc : Entity_Id := Empty; Disc : Entity_Id := Empty;
@ -9661,6 +9723,7 @@ package body Exp_Dist is
Counter : in out Int; Counter : in out Int;
Rec : Entity_Id; Rec : Entity_Id;
Field : Node_Id); Field : Node_Id);
-- Processing routine for traversal below
procedure TA_Append_Record_Traversal is procedure TA_Append_Record_Traversal is
new Append_Record_Traversal new Append_Record_Traversal
@ -9702,7 +9765,7 @@ package body Exp_Dist is
else else
-- A variant part -- A variant part
declare Variant_Part : declare
Variant : Node_Id; Variant : Node_Id;
Struct_Counter : Int := 0; Struct_Counter : Int := 0;
@ -9723,8 +9786,8 @@ package body Exp_Dist is
function Make_Discriminant_Reference function Make_Discriminant_Reference
return Node_Id; return Node_Id;
-- Build a selected component for the -- Build reference to the discriminant for this
-- discriminant of this variant part. -- variant part.
--------------------------------- ---------------------------------
-- Make_Discriminant_Reference -- -- Make_Discriminant_Reference --
@ -9743,6 +9806,8 @@ package body Exp_Dist is
return Nod; return Nod;
end Make_Discriminant_Reference; end Make_Discriminant_Reference;
-- Start processing for Variant_Part
begin begin
Append_To (Stmts, Append_To (Stmts,
Make_Block_Statement (Loc, Make_Block_Statement (Loc,
@ -9752,11 +9817,10 @@ package body Exp_Dist is
Make_Handled_Sequence_Of_Statements (Loc, Make_Handled_Sequence_Of_Statements (Loc,
Statements => Block_Stmts))); Statements => Block_Stmts)));
-- Declare the Variant Part aggregate -- Declare variant part aggregate (Union_Any).
-- (Union_Any). -- Knowing the position of this VP in the
-- Knowing the position of this VP in -- variant record, we can fetch the VP typecode
-- the variant record, we can fetch the -- from Container.
-- VP typecode from Container.
Append_To (Block_Decls, Append_To (Block_Decls,
Make_Object_Declaration (Loc, Make_Object_Declaration (Loc,
@ -9777,9 +9841,8 @@ package body Exp_Dist is
Make_Integer_Literal (Loc, Make_Integer_Literal (Loc,
Counter))))))); Counter)))))));
-- Declare the inner struct aggregate -- Declare inner struct aggregate (which
-- (that will contain the components -- contains the components of this VP).
-- of this VP)
Append_To (Block_Decls, Append_To (Block_Decls,
Make_Object_Declaration (Loc, Make_Object_Declaration (Loc,
@ -9800,9 +9863,7 @@ package body Exp_Dist is
Make_Integer_Literal (Loc, Make_Integer_Literal (Loc,
Uint_1))))))); Uint_1)))))));
-- Construct a case statement that will choose -- Build case statement
-- the appropriate code at runtime depending on
-- the discriminant.
Append_To (Block_Stmts, Append_To (Block_Stmts,
Make_Case_Statement (Loc, Make_Case_Statement (Loc,
@ -9818,8 +9879,7 @@ package body Exp_Dist is
VP_Stmts := New_List; VP_Stmts := New_List;
-- Append discriminant value to union -- Append discriminant val to union aggregate
-- aggregate.
Append_To (VP_Stmts, Append_To (VP_Stmts,
Make_Procedure_Call_Statement (Loc, Make_Procedure_Call_Statement (Loc,
@ -9878,8 +9938,9 @@ package body Exp_Dist is
Next_Non_Pragma (Variant); Next_Non_Pragma (Variant);
end loop; end loop;
end; end Variant_Part;
end if; end if;
Counter := Counter + 1; Counter := Counter + 1;
end TA_Rec_Add_Process_Element; end TA_Rec_Add_Process_Element;
@ -9989,6 +10050,9 @@ package body Exp_Dist is
end if; end if;
elsif Is_Array_Type (Typ) then elsif Is_Array_Type (Typ) then
-- Constrained and unconstrained array types
declare declare
Constrained : constant Boolean := Is_Constrained (Typ); Constrained : constant Boolean := Is_Constrained (Typ);
@ -10074,6 +10138,9 @@ package body Exp_Dist is
end; end;
elsif Is_Integer_Type (Typ) or else Is_Unsigned_Type (Typ) then elsif Is_Integer_Type (Typ) or else Is_Unsigned_Type (Typ) then
-- Integer types
Set_Expression (Any_Decl, Set_Expression (Any_Decl,
Build_To_Any_Call ( Build_To_Any_Call (
OK_Convert_To ( OK_Convert_To (
@ -10082,13 +10149,21 @@ package body Exp_Dist is
Decls)); Decls));
else 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 declare
Strm : constant Entity_Id := Make_Defining_Identifier (Loc, Strm : constant Entity_Id :=
New_Internal_Name ('S')); Make_Defining_Identifier (Loc,
Chars => New_Internal_Name ('S'));
-- Stream used to store data representation produced by
-- stream attribute.
begin begin
-- Generate:
-- Strm : aliased Buffer_Stream_Type; -- Strm : aliased Buffer_Stream_Type;
Append_To (Decls, Append_To (Decls,
@ -10100,6 +10175,7 @@ package body Exp_Dist is
Object_Definition => Object_Definition =>
New_Occurrence_Of (RTE (RE_Buffer_Stream_Type), Loc))); New_Occurrence_Of (RTE (RE_Buffer_Stream_Type), Loc)));
-- Generate:
-- Allocate_Buffer (Strm); -- Allocate_Buffer (Strm);
Append_To (Stms, Append_To (Stms,
@ -10109,6 +10185,7 @@ package body Exp_Dist is
Parameter_Associations => New_List ( Parameter_Associations => New_List (
New_Occurrence_Of (Strm, Loc)))); New_Occurrence_Of (Strm, Loc))));
-- Generate:
-- T'Output (Strm'Access, E); -- T'Output (Strm'Access, E);
Append_To (Stms, Append_To (Stms,
@ -10121,6 +10198,7 @@ package body Exp_Dist is
Attribute_Name => Name_Access), Attribute_Name => Name_Access),
New_Occurrence_Of (Expr_Parameter, Loc)))); New_Occurrence_Of (Expr_Parameter, Loc))));
-- Generate:
-- BS_To_Any (Strm, A); -- BS_To_Any (Strm, A);
Append_To (Stms, Append_To (Stms,
@ -10131,6 +10209,7 @@ package body Exp_Dist is
New_Occurrence_Of (Strm, Loc), New_Occurrence_Of (Strm, Loc),
New_Occurrence_Of (Any, Loc)))); New_Occurrence_Of (Any, Loc))));
-- Generate:
-- Release_Buffer (Strm); -- Release_Buffer (Strm);
Append_To (Stms, Append_To (Stms,
@ -10181,7 +10260,6 @@ package body Exp_Dist is
Fnam : Entity_Id := Empty; Fnam : Entity_Id := Empty;
Lib_RE : RE_Id := RE_Null; Lib_RE : RE_Id := RE_Null;
Expr : Node_Id; Expr : Node_Id;
begin begin
@ -10729,22 +10807,29 @@ package body Exp_Dist is
Initialize_Parameter_List Initialize_Parameter_List
(Type_Name_Str, Type_Repo_Id_Str, Parameters); (Type_Name_Str, Type_Repo_Id_Str, Parameters);
if Is_Derived_Type (Typ) if Has_Stream_Attribute_Definition
and then not Is_Tagged_Type (Typ) (Typ, TSS_Stream_Output, At_Any_Place => True)
or else
Has_Stream_Attribute_Definition
(Typ, TSS_Stream_Write, At_Any_Place => True)
then 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 ( Return_Alias_TypeCode (
Build_TypeCode_Call (Loc, Etype (Typ), Decls)); Build_TypeCode_Call (Loc, Etype (Typ), Decls));
elsif Is_Integer_Type (Typ) elsif Is_Integer_Type (Typ) or else Is_Unsigned_Type (Typ) then
or else Is_Unsigned_Type (Typ)
then
Return_Alias_TypeCode ( Return_Alias_TypeCode (
Build_TypeCode_Call (Loc, Build_TypeCode_Call (Loc,
Find_Numeric_Representation (Typ), Decls)); Find_Numeric_Representation (Typ), Decls));
elsif Is_Record_Type (Typ) elsif Is_Record_Type (Typ) and then not Is_Tagged_Type (Typ) then
and then not Is_Tagged_Type (Typ)
then
-- Record typecodes are encoded as follows: -- Record typecodes are encoded as follows:
-- -- TC_STRUCT -- -- TC_STRUCT
@ -11280,11 +11365,33 @@ package body Exp_Dist is
Stub_Elements : constant Stub_Structure := Stub_Elements : constant Stub_Structure :=
Stubs_Table.Get (Full_View); Stubs_Table.Get (Full_View);
begin 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 if Stub_Elements /= Empty_Stub_Structure then
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 Add_RACW_Primitive_Declarations_And_Bodies
(Full_View, (Full_View,
Stub_Elements.RPC_Receiver_Decl, Stub_Elements.RPC_Receiver_Decl,
Stub_Elements.Body_Decls); Stub_Elements.Body_Decls);
if Current_Scope /= Saved_Scope then
Pop_Scope;
end if;
end;
end if; end if;
end Remote_Types_Tagged_Full_View_Encountered; end Remote_Types_Tagged_Full_View_Encountered;