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

sem_ch13.adb: Complete previous change. 

2014-11-20  Thomas Quinot  <quinot@adacore.com>

	* sem_ch13.adb: Complete previous change.
	* exp_dist.adb, exp_dist.ads: Rework PolyORB/DSA arguments processing
	circuitry to correctly handle the case of non-private limited
	unconstrained formals.

From-SVN: r217845
This commit is contained in:
Thomas Quinot 2014-11-20 11:39:44 +00:00 committed by Arnaud Charlet
parent 5e9d6f05dd
commit 8b64ed4caa
4 changed files with 158 additions and 81 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
gcc/ada/ChangeLog
View File

@ -1,3 +1,10 @@
2014-11-20 Thomas Quinot <quinot@adacore.com>
* sem_ch13.adb: Complete previous change.
* exp_dist.adb, exp_dist.ads: Rework PolyORB/DSA arguments processing
circuitry to correctly handle the case of non-private limited
unconstrained formals.
2014-11-20 Robert Dewar <dewar@adacore.com> 2014-11-20 Robert Dewar <dewar@adacore.com>
* freeze.adb, exp_dbug.adb, sem_ch13.adb: Minor reformatting. * freeze.adb, exp_dbug.adb, sem_ch13.adb: Minor reformatting.

209
gcc/ada/exp_dist.adb
View File

@ -802,15 +802,18 @@ package body Exp_Dist is
-- the declaration and entity for the newly-created function. -- the declaration and entity for the newly-created function.
function Build_To_Any_Call function Build_To_Any_Call
(Loc : Source_Ptr; (Loc : Source_Ptr;
N : Node_Id; N : Node_Id;
Decls : List_Id) return Node_Id; Decls : List_Id;
Constrained : Boolean := False) return Node_Id;
-- Build call to To_Any attribute function with expression as actual -- Build call to To_Any attribute function with expression as actual
-- parameter. Loc is the reference location ofr generated nodes, -- parameter. Loc is the reference location of generated nodes,
-- Decls is the declarations list for an appropriate enclosing scope -- Decls is the declarations list for an appropriate enclosing scope
-- of the point where the call will be inserted; if the To_Any -- of the point where the call will be inserted; if the To_Any
-- attribute for the type of N needs to be generated at this point, -- attribute for the type of N needs to be generated at this point,
-- its declaration is appended to Decls. -- its declaration is appended to Decls. For the case of a limited
-- type, there is an additional parameter Constrained indicating
-- whether 'Write (when True) or 'Output (when False) is used.
procedure Build_To_Any_Function procedure Build_To_Any_Function
(Loc : Source_Ptr; (Loc : Source_Ptr;
@ -853,11 +856,12 @@ package body Exp_Dist is
-- containing the name of E, the second containing its repository id. -- containing the name of E, the second containing its repository id.
procedure Assign_Opaque_From_Any procedure Assign_Opaque_From_Any
(Loc : Source_Ptr; (Loc : Source_Ptr;
Stms : List_Id; Stms : List_Id;
Typ : Entity_Id; Typ : Entity_Id;
N : Node_Id; N : Node_Id;
Target : Entity_Id); Target : Entity_Id;
Constrained : Boolean := False);
-- For a Target object of type Typ, which has opaque representation -- For a Target object of type Typ, which has opaque representation
-- as a sequence of octets determined by stream attributes (which -- as a sequence of octets determined by stream attributes (which
-- includes all limited types), append code to Stmts performing the -- includes all limited types), append code to Stmts performing the
@ -866,6 +870,9 @@ package body Exp_Dist is
-- --
-- or, if Target is Empty: -- or, if Target is Empty:
-- return Typ'From_Any (N) -- return Typ'From_Any (N)
--
-- Constrained determines whether 'Input (when False) or 'Read
-- (when True) is used.
end Helpers; end Helpers;
@ -880,9 +887,10 @@ package body Exp_Dist is
renames PolyORB_Support.Helpers.Build_From_Any_Call; renames PolyORB_Support.Helpers.Build_From_Any_Call;
function Build_To_Any_Call function Build_To_Any_Call
(Loc : Source_Ptr; (Loc : Source_Ptr;
N : Node_Id; N : Node_Id;
Decls : List_Id) return Node_Id Decls : List_Id;
Constrained : Boolean := False) return Node_Id
renames PolyORB_Support.Helpers.Build_To_Any_Call; renames PolyORB_Support.Helpers.Build_To_Any_Call;
function Build_TypeCode_Call function Build_TypeCode_Call
@ -7395,11 +7403,13 @@ package body Exp_Dist is
then then
if Is_Limited_Type (Etyp) then if Is_Limited_Type (Etyp) then
Helpers.Assign_Opaque_From_Any (Loc, Helpers.Assign_Opaque_From_Any (Loc,
Stms => After_Statements, Stms => After_Statements,
Typ => Etyp, Typ => Etyp,
N => New_Occurrence_Of (Any, Loc), N => New_Occurrence_Of (Any, Loc),
Target => Target =>
Defining_Identifier (Current_Parameter)); Defining_Identifier (Current_Parameter),
Constrained => True);
else else
Append_To (After_Statements, Append_To (After_Statements,
Make_Assignment_Statement (Loc, Make_Assignment_Statement (Loc,
@ -7925,7 +7935,7 @@ package body Exp_Dist is
-- An out parameter may be written back using a 'Write -- An out parameter may be written back using a 'Write
-- attribute instead of a 'Output because it has been -- attribute instead of a 'Output because it has been
-- constrained by the parameter given to the caller. Note that -- constrained by the parameter given to the caller. Note that
-- out controlling arguments in the case of a RACW are not put -- OUT controlling arguments in the case of a RACW are not put
-- back in the stream because the pointer on them has not -- back in the stream because the pointer on them has not
-- changed. -- changed.
@ -7938,7 +7948,10 @@ package body Exp_Dist is
Parameter_Associations => New_List ( Parameter_Associations => New_List (
New_Occurrence_Of (Any, Loc), New_Occurrence_Of (Any, Loc),
PolyORB_Support.Helpers.Build_To_Any_Call PolyORB_Support.Helpers.Build_To_Any_Call
(Loc, New_Occurrence_Of (Object, Loc), Decls)))); (Loc,
New_Occurrence_Of (Object, Loc),
Decls,
Constrained => True))));
end if; end if;
-- For RACW controlling formals, the Etyp of Object is always -- For RACW controlling formals, the Etyp of Object is always
@ -8314,11 +8327,12 @@ package body Exp_Dist is
----------------------------- -----------------------------
procedure Assign_Opaque_From_Any procedure Assign_Opaque_From_Any
(Loc : Source_Ptr; (Loc : Source_Ptr;
Stms : List_Id; Stms : List_Id;
Typ : Entity_Id; Typ : Entity_Id;
N : Node_Id; N : Node_Id;
Target : Entity_Id) Target : Entity_Id;
Constrained : Boolean := False)
is is
Strm : constant Entity_Id := Make_Temporary (Loc, 'S'); Strm : constant Entity_Id := Make_Temporary (Loc, 'S');
Expr : Node_Id; Expr : Node_Id;
@ -8345,7 +8359,7 @@ package body Exp_Dist is
N, N,
New_Occurrence_Of (Strm, Loc)))); New_Occurrence_Of (Strm, Loc))));
if Transmit_As_Unconstrained (Typ) then if Transmit_As_Unconstrained (Typ) and then not Constrained then
Expr := Expr :=
Make_Attribute_Reference (Loc, Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (Typ, Loc), Prefix => New_Occurrence_Of (Typ, Loc),
@ -9223,9 +9237,10 @@ package body Exp_Dist is
----------------------- -----------------------
function Build_To_Any_Call function Build_To_Any_Call
(Loc : Source_Ptr; (Loc : Source_Ptr;
N : Node_Id; N : Node_Id;
Decls : List_Id) return Node_Id Decls : List_Id;
Constrained : Boolean := False) return Node_Id
is is
Typ : Entity_Id := Etype (N); Typ : Entity_Id := Etype (N);
U_Type : Entity_Id; U_Type : Entity_Id;
@ -9382,11 +9397,20 @@ package body Exp_Dist is
C_Type := U_Type; C_Type := U_Type;
end if; end if;
return declare
Make_Function_Call (Loc, Params : constant List_Id :=
Name => New_Occurrence_Of (Fnam, Loc), New_List (OK_Convert_To (C_Type, N));
Parameter_Associations => begin
New_List (OK_Convert_To (C_Type, N))); if Is_Limited_Type (C_Type) then
Append_To (Params,
New_Occurrence_Of (Boolean_Literals (Constrained), Loc));
end if;
return
Make_Function_Call (Loc,
Name => New_Occurrence_Of (Fnam, Loc),
Parameter_Associations => Params);
end;
end Build_To_Any_Call; end Build_To_Any_Call;
--------------------------- ---------------------------
@ -9399,13 +9423,15 @@ package body Exp_Dist is
Decl : out Node_Id; Decl : out Node_Id;
Fnam : out Entity_Id) Fnam : out Entity_Id)
is is
Spec : Node_Id; Spec : Node_Id;
Decls : constant List_Id := New_List; Params : List_Id;
Stms : constant List_Id := New_List; Decls : List_Id;
Stms : List_Id;
Expr_Parameter : Entity_Id; Expr_Formal : Entity_Id;
Any : Entity_Id; Cstr_Formal : Entity_Id;
Result_TC : Node_Id; Any : Entity_Id;
Result_TC : Node_Id;
Any_Decl : Node_Id; Any_Decl : Node_Id;
@ -9428,21 +9454,36 @@ package body Exp_Dist is
return; return;
end if; end if;
Expr_Parameter := Make_Defining_Identifier (Loc, Name_E); Decls := New_List;
Any := Make_Defining_Identifier (Loc, Name_A); Stms := New_List;
Result_TC := Build_TypeCode_Call (Loc, Typ, Decls);
Any := Make_Defining_Identifier (Loc, Name_A);
Result_TC := Build_TypeCode_Call (Loc, Typ, Decls);
Fnam := Make_Helper_Function_Name (Loc, Typ, Name_To_Any); Fnam := Make_Helper_Function_Name (Loc, Typ, Name_To_Any);
Expr_Formal := Make_Defining_Identifier (Loc, Name_E);
Params := New_List (
Make_Parameter_Specification (Loc,
Defining_Identifier => Expr_Formal,
Parameter_Type => New_Occurrence_Of (Typ, Loc)));
Set_Etype (Expr_Formal, Typ);
if Is_Limited_Type (Typ) then
Cstr_Formal := Make_Defining_Identifier (Loc, Name_C);
Append_To (Params,
Make_Parameter_Specification (Loc,
Defining_Identifier => Cstr_Formal,
Parameter_Type =>
New_Occurrence_Of (Standard_Boolean, Loc)));
end if;
Spec := Spec :=
Make_Function_Specification (Loc, Make_Function_Specification (Loc,
Defining_Unit_Name => Fnam, Defining_Unit_Name => Fnam,
Parameter_Specifications => New_List ( Parameter_Specifications => Params,
Make_Parameter_Specification (Loc, Result_Definition =>
Defining_Identifier => Expr_Parameter, New_Occurrence_Of (RTE (RE_Any), Loc));
Parameter_Type => New_Occurrence_Of (Typ, Loc))),
Result_Definition => New_Occurrence_Of (RTE (RE_Any), Loc));
Set_Etype (Expr_Parameter, Typ);
Any_Decl := Any_Decl :=
Make_Object_Declaration (Loc, Make_Object_Declaration (Loc,
@ -9472,7 +9513,7 @@ package body Exp_Dist is
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_Formal, Loc));
begin begin
Set_Expression (Any_Decl, Set_Expression (Any_Decl,
Build_To_Any_Call (Loc, Expr, Decls)); Build_To_Any_Call (Loc, Expr, Decls));
@ -9487,7 +9528,7 @@ package body Exp_Dist is
Rt_Type : constant Entity_Id := Etype (Typ); Rt_Type : constant Entity_Id := 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_Formal, Loc));
begin begin
Set_Expression Set_Expression
@ -9514,7 +9555,7 @@ package body Exp_Dist is
procedure TA_Append_Record_Traversal is procedure TA_Append_Record_Traversal is
new Append_Record_Traversal new Append_Record_Traversal
(Rec => Expr_Parameter, (Rec => Expr_Formal,
Add_Process_Element => TA_Rec_Add_Process_Element); Add_Process_Element => TA_Rec_Add_Process_Element);
-------------------------------- --------------------------------
@ -9762,7 +9803,7 @@ package body Exp_Dist is
Discriminant : constant Entity_Id := Discriminant : constant Entity_Id :=
Make_Selected_Component (Loc, Make_Selected_Component (Loc,
Prefix => Prefix =>
Expr_Parameter, Expr_Formal,
Selector_Name => Selector_Name =>
Chars (Disc)); Chars (Disc));
@ -9880,7 +9921,7 @@ package body Exp_Dist is
procedure Append_To_Any_Array_Iterator is procedure Append_To_Any_Array_Iterator is
new Append_Array_Traversal ( new Append_Array_Traversal (
Subprogram => Fnam, Subprogram => Fnam,
Arry => Expr_Parameter, Arry => Expr_Formal,
Indexes => New_List, Indexes => New_List,
Add_Process_Element => TA_Ary_Add_Process_Element); Add_Process_Element => TA_Ary_Add_Process_Element);
@ -9908,7 +9949,7 @@ package body Exp_Dist is
OK_Convert_To (Etype (Index), OK_Convert_To (Etype (Index),
Make_Attribute_Reference (Loc, Make_Attribute_Reference (Loc,
Prefix => Prefix =>
New_Occurrence_Of (Expr_Parameter, Loc), New_Occurrence_Of (Expr_Formal, Loc),
Attribute_Name => Name_First, Attribute_Name => Name_First,
Expressions => New_List ( Expressions => New_List (
Make_Integer_Literal (Loc, J)))), Make_Integer_Literal (Loc, J)))),
@ -9928,7 +9969,7 @@ package body Exp_Dist is
Build_To_Any_Call (Loc, Build_To_Any_Call (Loc,
OK_Convert_To ( OK_Convert_To (
Find_Numeric_Representation (Typ), Find_Numeric_Representation (Typ),
New_Occurrence_Of (Expr_Parameter, Loc)), New_Occurrence_Of (Expr_Formal, Loc)),
Decls)); Decls));
else else
@ -9958,27 +9999,49 @@ package body Exp_Dist is
-- T'Output (Strm'Access, E); -- T'Output (Strm'Access, E);
-- or -- or
-- T'Write (Strm'Access, E); -- T'Write (Strm'Access, E);
-- depending on whether to transmit as unconstrained -- depending on whether to transmit as unconstrained.
-- For limited types, select at run time depending on
-- Constrained parameter.
declare declare
Attr_Name : Name_Id; function Stream_Call (Attr : Name_Id) return Node_Id;
-- Return a call to the named attribute
-----------------
-- Stream_Call --
-----------------
function Stream_Call (Attr : Name_Id) return Node_Id is
begin
return Make_Attribute_Reference (Loc,
Prefix =>
New_Occurrence_Of (Typ, Loc),
Attribute_Name => Attr,
Expressions => New_List (
Make_Attribute_Reference (Loc,
Prefix =>
New_Occurrence_Of (Strm, Loc),
Attribute_Name => Name_Access),
New_Occurrence_Of (Expr_Formal, Loc)));
end Stream_Call;
begin begin
if Transmit_As_Unconstrained (Typ) then if Is_Limited_Type (Typ) then
Attr_Name := Name_Output; Append_To (Stms,
else Make_Implicit_If_Statement (Typ,
Attr_Name := Name_Write; Condition => New_Occurrence_Of (Cstr_Formal, Loc),
end if; Then_Statements => New_List (
Stream_Call (Name_Write)),
Else_Statements => New_List (
Stream_Call (Name_Output))));
Append_To (Stms, elsif Transmit_As_Unconstrained (Typ) then
Make_Attribute_Reference (Loc, Append_To (Stms, Stream_Call (Name_Output));
Prefix => New_Occurrence_Of (Typ, Loc), else
Attribute_Name => Attr_Name, Append_To (Stms, Stream_Call (Name_Write));
Expressions => New_List ( end if;
Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (Strm, Loc),
Attribute_Name => Name_Access),
New_Occurrence_Of (Expr_Parameter, Loc))));
end; end;
-- Generate: -- Generate:

11
gcc/ada/exp_dist.ads
View File

@ -6,7 +6,7 @@
-- -- -- --
-- S p e c -- -- S p e c --
-- -- -- --
-- Copyright (C) 1992-2013, Free Software Foundation, Inc. -- -- Copyright (C) 1992-2014, Free Software Foundation, Inc. --
-- -- -- --
-- GNAT is free software; you can redistribute it and/or modify it under -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
@ -146,14 +146,17 @@ package Exp_Dist is
-- declaration is appended to Decls. -- declaration is appended to Decls.
function Build_To_Any_Call function Build_To_Any_Call
(Loc : Source_Ptr; (Loc : Source_Ptr;
N : Node_Id; N : Node_Id;
Decls : List_Id) return Node_Id; Decls : List_Id;
Constrained : Boolean := False) return Node_Id;
-- Build call to To_Any attribute function with expression as actual -- Build call to To_Any attribute function with expression as actual
-- parameter. Loc is the reference location for generated nodes, Decls is -- parameter. Loc is the reference location for generated nodes, Decls is
-- the declarations list for an appropriate enclosing scope of the point -- the declarations list for an appropriate enclosing scope of the point
-- where the call will be inserted; if the To_Any attribute for Typ needs -- where the call will be inserted; if the To_Any attribute for Typ needs
-- to be generated at this point, its declaration is appended to Decls. -- to be generated at this point, its declaration is appended to Decls.
-- For limited types, if Constrained is True then use 'Write else use
-- 'Output.
function Build_TypeCode_Call function Build_TypeCode_Call
(Loc : Source_Ptr; (Loc : Source_Ptr;

12
gcc/ada/sem_ch13.adb
View File

@ -10912,11 +10912,14 @@ package body Sem_Ch13 is
end if; end if;
end if; end if;
-- Scalar_Storage_Order (first subtypes only) -- Scalar_Storage_Order
-- Note: the aspect is specified on a first subtype, but recorded
-- in a flag of the base type!
if (Is_Record_Type (Typ) or else Is_Array_Type (Typ)) if (Is_Record_Type (Typ) or else Is_Array_Type (Typ))
and then and then
Is_First_Subtype (Typ) Typ = Bas_Typ
then then
-- For a type extension, always inherit from parent; otherwise -- For a type extension, always inherit from parent; otherwise
@ -10924,7 +10927,8 @@ package body Sem_Ch13 is
-- an explicit rep item on the parent type when inheriting, -- an explicit rep item on the parent type when inheriting,
-- because the parent SSO may itself have been set by default. -- because the parent SSO may itself have been set by default.
if not Has_Rep_Item (Typ, Name_Scalar_Storage_Order, False) if not Has_Rep_Item (First_Subtype (Typ),
Name_Scalar_Storage_Order, False)
and then (Is_Tagged_Type (Bas_Typ) and then (Is_Tagged_Type (Bas_Typ)
or else or else
not (SSO_Set_Low_By_Default (Bas_Typ) not (SSO_Set_Low_By_Default (Bas_Typ)
@ -10932,7 +10936,7 @@ package body Sem_Ch13 is
SSO_Set_High_By_Default (Bas_Typ))) SSO_Set_High_By_Default (Bas_Typ)))
then then
Set_Reverse_Storage_Order (Bas_Typ, Set_Reverse_Storage_Order (Bas_Typ,
Reverse_Storage_Order (First_Subtype (Etype (Bas_Typ)))); Reverse_Storage_Order (Base_Type (Etype (Bas_Typ))));
-- Clear default SSO indications, since the inherited aspect -- Clear default SSO indications, since the inherited aspect
-- which was set explicitly overrides the default. -- which was set explicitly overrides the default.