* [Ada] Bogus warning for null-excluding RACWs
@ 2008-05-21 8:26 Arnaud Charlet
0 siblings, 0 replies; only message in thread
From: Arnaud Charlet @ 2008-05-21 8:26 UTC (permalink / raw)
To: gcc-patches; +Cc: Thomas Quinot
[-- Attachment #1: Type: text/plain, Size: 2312 bytes --]
Tested on i686-linux, commited on trunk
In certain cases, a junk warning for an assignment of a null value is
produced when expanding stream attributes for null-excluding RACW types.
This change reorganizes code to avoid this warning (the raise node
is generated explicitly instead of through a static check on an assignment,
and thus does not trigger a warning).
The following compilation must be accepted silently:
$ gcc -c -gnat05 rci.ads
package Pure_T is
pragma Pure;
type TL_Public is tagged limited null record;
type TL_Private is tagged limited private;
private
type Ref is access all Integer;
for Ref'Storage_Size use 0;
type TL_Private is tagged limited record
A : Ref;
end record;
end;
with Pure_T;
package RCI is
pragma Remote_Call_Interface (RCI);
type RACW is access constant Pure_T.TL_Private'Class;
type NRACW is not null access constant Pure_T.TL_Private'Class;
end;
Also: when using the PolyORB-based implementation of the distributed systems
annex, parameters in remote calls are passed to the distribution runtime
as typed containers, and it is up to the runtime to determine an
appropriate wire representation. However in the case of types for which
a user defined external representation is specified through attribute
definition clauses, said representation must be used (the type may in
particular include access components for which external semantics cannot
be provided outside of the user defined stream attributes), and the
data must be passed to the underlying distribution runtime as an opaque
sequence of octets. This change implements this value passing circuitry
for all types with user defined stream attributes.
2008-05-20 Thomas Quinot <quinot@adacore.com>
* 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.
[-- Attachment #2: difs --]
[-- Type: text/plain, Size: 23684 bytes --]
Index: exp_dist.adb
===================================================================
--- exp_dist.adb (revision 134945)
+++ exp_dist.adb (working copy)
@@ -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;
^ permalink raw reply [flat|nested] only message in thread
only message in thread, other threads:[~2008-05-21 8:25 UTC | newest]
Thread overview: (only message) (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2008-05-21 8:26 [Ada] Bogus warning for null-excluding RACWs Arnaud Charlet
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).