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

[multiple changes]

Browse Source 
2017-09-06  Hristian Kirtchev  <kirtchev@adacore.com>

	* exp_ch5.adb, freeze.adb, exp_ch4.adb, exp_ch6.adb, lib-xref.adb:
	Minor reformatting.

2017-09-06  Justin Squirek  <squirek@adacore.com>

	* exp_attr.adb (Expand_N_Attribute_Reference): Modified Image
	attribute cases (Rewrite_Object_Reference_Image): Created to
	aid the rewriting of new-style 'Image attributes.
	* sem_attr.adb (Analyze_Attribute): Modified Image attribute cases
	(Check_Object_Reference_Image): Created to handle verification of
	'Image with object-references as prefixes.
	* sem_util.ads, sem_util.adb (Is_Image_Applied_To_Object):
	Create predicate to identify cases where an 'Image attribute's
	prefix applies to an object reference.

From-SVN: r251767
This commit is contained in:
Arnaud Charlet 2017-09-06 12:07:16 +02:00
parent 3e69995410
commit a4f4dbdb5a
10 changed files with 164 additions and 92 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

17
gcc/ada/ChangeLog
View File

@ -1,3 +1,20 @@
2017-09-06 Hristian Kirtchev <kirtchev@adacore.com>
* exp_ch5.adb, freeze.adb, exp_ch4.adb, exp_ch6.adb, lib-xref.adb:
Minor reformatting.
2017-09-06 Justin Squirek <squirek@adacore.com>
* exp_attr.adb (Expand_N_Attribute_Reference): Modified Image
attribute cases (Rewrite_Object_Reference_Image): Created to
aid the rewriting of new-style 'Image attributes.
* sem_attr.adb (Analyze_Attribute): Modified Image attribute cases
(Check_Object_Reference_Image): Created to handle verification of
'Image with object-references as prefixes.
* sem_util.ads, sem_util.adb (Is_Image_Applied_To_Object):
Create predicate to identify cases where an 'Image attribute's
prefix applies to an object reference.
2017-09-06 Ed Schonberg <schonberg@adacore.com>
* freeze.adb (Freeze_Entity): Do not generate a freeze

45
gcc/ada/exp_attr.adb
View File

@ -1594,10 +1594,33 @@ package body Exp_Attr is
Exprs : constant List_Id := Expressions (N);
Id : constant Attribute_Id := Get_Attribute_Id (Attribute_Name (N));
procedure Rewrite_Object_Reference_Image
(Name : Name_Id;
Str_Typ : Entity_Id);
-- Rewrite an 'Image attribute applied to an object reference for
-- AI12-0012401 into an attribute applied to a type.
procedure Rewrite_Stream_Proc_Call (Pname : Entity_Id);
-- Rewrites a stream attribute for Read, Write or Output with the
-- procedure call. Pname is the entity for the procedure to call.
------------------------------------
-- Rewrite_Object_Reference_Image --
------------------------------------
procedure Rewrite_Object_Reference_Image
(Name : Name_Id;
Str_Typ : Entity_Id) is
begin
Rewrite (N,
Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (Ptyp, Loc),
Attribute_Name => Name,
Expressions => New_List (Relocate_Node (Pref))));
Analyze_And_Resolve (N, Str_Typ);
end Rewrite_Object_Reference_Image;
------------------------------
-- Rewrite_Stream_Proc_Call --
------------------------------
@ -3613,6 +3636,10 @@ package body Exp_Attr is
-- Image attribute is handled in separate unit Exp_Imgv
when Attribute_Image =>
if Is_Image_Applied_To_Object (Pref, Ptyp) then
Rewrite_Object_Reference_Image (Name_Image, Standard_String);
return;
end if;
-- Leave attribute unexpanded in CodePeer mode: the gnat2scil
-- back-end knows how to handle this attribute directly.
@ -3630,13 +3657,7 @@ package body Exp_Attr is
-- X'Img is expanded to typ'Image (X), where typ is the type of X
when Attribute_Img =>
Rewrite (N,
Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (Ptyp, Loc),
Attribute_Name => Name_Image,
Expressions => New_List (Relocate_Node (Pref))));
Analyze_And_Resolve (N, Standard_String);
Rewrite_Object_Reference_Image (Name_Image, Standard_String);
-----------
-- Input --
@ -6982,6 +7003,11 @@ package body Exp_Attr is
-- Wide_Image attribute is handled in separate unit Exp_Imgv
when Attribute_Wide_Image =>
if Is_Image_Applied_To_Object (Pref, Ptyp) then
Rewrite_Object_Reference_Image
(Name_Wide_Image, Standard_Wide_String);
return;
end if;
-- Leave attribute unexpanded in CodePeer mode: the gnat2scil
-- back-end knows how to handle this attribute directly.
@ -6999,6 +7025,11 @@ package body Exp_Attr is
-- Wide_Wide_Image attribute is handled in separate unit Exp_Imgv
when Attribute_Wide_Wide_Image =>
if Is_Image_Applied_To_Object (Pref, Ptyp) then
Rewrite_Object_Reference_Image
(Name_Wide_Wide_Image, Standard_Wide_Wide_String);
return;
end if;
-- Leave attribute unexpanded in CodePeer mode: the gnat2scil
-- back-end knows how to handle this attribute directly.

23
gcc/ada/exp_ch4.adb
View File

@ -4072,10 +4072,9 @@ package body Exp_Ch4 is
-- Link this node to the tree to analyze it
-- If the parent node is an expression with actions we link it
-- to N since otherwise Force_Evaluation cannot identify if this
-- node comes from the Expression and rejects generating the
-- temporary.
-- If the parent node is an expression with actions we link it to
-- N since otherwise Force_Evaluation cannot identify if this node
-- comes from the Expression and rejects generating the temporary.
if Nkind (Parent (N)) = N_Expression_With_Actions then
Set_Parent (Op_Expr, N);
@ -10698,13 +10697,13 @@ package body Exp_Ch4 is
declare
Stored : constant Elist_Id :=
Stored_Constraint (Operand_Type);
Stored_Constraint (Operand_Type);
Elmt : Elmt_Id;
Disc_O : Entity_Id;
-- Discriminant of the operand type. Its value in the
-- the object is captured in a selected component.
-- object is captured in a selected component.
Disc_S : Entity_Id;
-- Stored discriminant of the operand. If present, it
@ -10732,7 +10731,7 @@ package body Exp_Ch4 is
Make_Selected_Component (Loc,
Prefix =>
Duplicate_Subexpr_Move_Checks (Operand),
Selector_Name =>
Selector_Name =>
Make_Identifier (Loc, Chars (Disc_O))));
Next_Discriminant (Disc_O);
@ -10756,10 +10755,10 @@ package body Exp_Ch4 is
Append_To (Cons,
Make_Range (Loc,
Low_Bound =>
Low_Bound =>
Unchecked_Convert_To (Etype (N_Ix),
Make_Attribute_Reference (Loc,
Prefix =>
Prefix =>
Duplicate_Subexpr_No_Checks
(Operand, Name_Req => True),
Attribute_Name => Name_First,
@ -10769,7 +10768,7 @@ package body Exp_Ch4 is
High_Bound =>
Unchecked_Convert_To (Etype (N_Ix),
Make_Attribute_Reference (Loc,
Prefix =>
Prefix =>
Duplicate_Subexpr_No_Checks
(Operand, Name_Req => True),
Attribute_Name => Name_Last,
@ -10787,7 +10786,7 @@ package body Exp_Ch4 is
Odef :=
Make_Subtype_Indication (Loc,
Subtype_Mark => Odef,
Constraint =>
Constraint =>
Make_Index_Or_Discriminant_Constraint (Loc,
Constraints => Cons));
end if;
@ -10808,7 +10807,7 @@ package body Exp_Ch4 is
New_List (
Decl,
Make_Assignment_Statement (Loc,
Name => New_Occurrence_Of (Temp, Loc),
Name => New_Occurrence_Of (Temp, Loc),
Expression => Relocate_Node (N))),
Suppress => All_Checks);

18
gcc/ada/exp_ch5.adb
View File

@ -1452,10 +1452,9 @@ package body Exp_Ch5 is
Expr : Node_Id;
begin
-- The discriminant entity to be used in the retrieval below must
-- be one in the corresponding type, given that the assignment
-- may be between derived and parent types.
-- be one in the corresponding type, given that the assignment may
-- be between derived and parent types.
if Is_Derived_Type (Etype (Rhs)) then
Disc := Find_Component (R_Typ, C);
@ -1599,8 +1598,8 @@ package body Exp_Ch5 is
if Stored_Constraint (R_Typ) /= No_Elist then
declare
Discr_Val : Elmt_Id;
Assign : Node_Id;
Discr_Val : Elmt_Id;
begin
Discr_Val := First_Elmt (Stored_Constraint (R_Typ));
@ -1609,19 +1608,20 @@ package body Exp_Ch5 is
if Ekind (F) = E_Discriminant
and then Is_Completely_Hidden (F)
and then Present (Corresponding_Record_Component (F))
and then (not Is_Entity_Name (Node (Discr_Val))
or else Ekind (Entity (Node (Discr_Val)))
/= E_Discriminant)
and then
(not Is_Entity_Name (Node (Discr_Val))
or else Ekind (Entity (Node (Discr_Val))) /=
E_Discriminant)
then
Assign :=
Make_Assignment_Statement (Loc,
Name =>
Name =>
Make_Selected_Component (Loc,
Prefix => Duplicate_Subexpr (Lhs),
Selector_Name =>
New_Occurrence_Of
(Corresponding_Record_Component (F), Loc)),
Expression => New_Copy (Node ((Discr_Val))));
Expression => New_Copy (Node (Discr_Val)));
Set_Assignment_OK (Name (Assign));
Insert_Action (N, Assign);

8
gcc/ada/exp_ch6.adb
View File

@ -3505,8 +3505,8 @@ package body Exp_Ch6 is
Root_Type (Etype (Name (Ass)))
then
Error_Msg_NE
("tag-indeterminate expression "
& " must have designated type& (RM 5.2 (6))",
("tag-indeterminate expression must have designated "
& "type& (RM 5.2 (6))",
Call_Node, Root_Type (Etype (Name (Ass))));
else
Propagate_Tag (Name (Ass), Call_Node);
@ -3514,8 +3514,8 @@ package body Exp_Ch6 is
elsif Etype (Call_Node) /= Root_Type (Etype (Name (Ass))) then
Error_Msg_NE
("tag-indeterminate expression must have type&"
& " (RM 5.2 (6))",
("tag-indeterminate expression must have type & "
& "(RM 5.2 (6))",
Call_Node, Root_Type (Etype (Name (Ass))));
else

4
gcc/ada/freeze.adb
View File

@ -5270,7 +5270,7 @@ package body Freeze is
-- delayed in the parent, so these must also be captured now.
if Has_Delayed_Aspects (E)
or else May_Inherit_Delayed_Rep_Aspects (E)
or else May_Inherit_Delayed_Rep_Aspects (E)
then
Analyze_Aspects_At_Freeze_Point (E);
end if;
@ -5490,7 +5490,7 @@ package body Freeze is
Explode_Initialization_Compound_Statement (E);
end if;
-- Do not generate a freeze node for a generic unit.
-- Do not generate a freeze node for a generic unit
if Is_Generic_Unit (E) then
Result := No_List;

3
gcc/ada/lib-xref.adb
View File

@ -415,6 +415,7 @@ package body Lib.Xref is
function Get_Through_Renamings (E : Entity_Id) return Entity_Id is
begin
case Ekind (E) is
-- For subprograms we just need to check once if they are have a
-- Renamed_Entity, because Renamed_Entity is set transitively.
@ -443,6 +444,7 @@ package body Lib.Xref is
declare
Renamed : constant Entity_Id := Renamed_Object (Obj);
begin
if Present (Renamed) then
Obj := Get_Enclosing_Object (Renamed);
@ -450,6 +452,7 @@ package body Lib.Xref is
-- The renamed expression denotes a non-object,
-- e.g. function call, slicing of a function call,
-- pointer dereference, etc.
if No (Obj) then
return Empty;
end if;

104
gcc/ada/sem_attr.adb
View File

@ -326,18 +326,18 @@ package body Sem_Attr is
procedure Check_Fixed_Point_Type_0;
-- Verify that prefix of attribute N is a fixed type and that
-- no attribute expressions are present
-- no attribute expressions are present.
procedure Check_Floating_Point_Type;
-- Verify that prefix of attribute N is a float type
procedure Check_Floating_Point_Type_0;
-- Verify that prefix of attribute N is a float type and that
-- no attribute expressions are present
-- no attribute expressions are present.
procedure Check_Floating_Point_Type_1;
-- Verify that prefix of attribute N is a float type and that
-- exactly one attribute expression is present
-- exactly one attribute expression is present.
procedure Check_Floating_Point_Type_2;
-- Verify that prefix of attribute N is a float type and that
@ -363,6 +363,9 @@ package body Sem_Attr is
procedure Check_Object_Reference (P : Node_Id);
-- Check that P is an object reference
procedure Check_Object_Reference_Image (Str_Typ : Entity_Id);
-- Verify that the prefix of an image attribute....
procedure Check_PolyORB_Attribute;
-- Validity checking for PolyORB/DSA attribute
@ -2160,6 +2163,33 @@ package body Sem_Attr is
end if;
end Check_Object_Reference;
----------------------------------
-- Check_Object_Reference_Image --
----------------------------------
procedure Check_Object_Reference_Image (Str_Typ : Entity_Id) is
begin
Check_E0;
Set_Etype (N, Str_Typ);
if not Is_Scalar_Type (P_Type)
or else (Is_Entity_Name (P) and then Is_Type (Entity (P)))
then
Error_Attr_P
("prefix of % attribute must be scalar object name");
end if;
Check_Enum_Image;
-- Check restriction No_Fixed_IO
if Restriction_Check_Required (No_Fixed_IO)
and then Is_Fixed_Point_Type (P_Type)
then
Check_Restriction (No_Fixed_IO, P);
end if;
end Check_Object_Reference_Image;
----------------------------
-- Check_PolyORB_Attribute --
----------------------------
@ -4044,43 +4074,12 @@ package body Sem_Attr is
when Attribute_Image =>
Check_SPARK_05_Restriction_On_Attribute;
-- AI12-00124-1 : The ARG has adopted the GNAT semantics of 'Img for
-- scalar types, so that the prefix can be an object and not a type,
-- and there is no need for an argument. Given the vote of confidence
-- from the ARG, simplest is to transform this new usage of 'Image
-- into a reference to 'Img.
if Ada_Version > Ada_2005
and then Is_Object_Reference (P)
and then Is_Scalar_Type (P_Type)
then
if No (Expressions (N)) then
Rewrite (N,
Make_Attribute_Reference (Loc,
Prefix => Relocate_Node (P),
Attribute_Name => Name_Img));
-- If the attribute reference includes expressions, the only
-- possible interpretation is as an indexing of the parameterless
-- version of 'Image, so rewrite it accordingly.
else
Rewrite (N,
Make_Indexed_Component (Loc,
Prefix =>
Make_Attribute_Reference (Loc,
Prefix => Relocate_Node (P),
Attribute_Name => Name_Img),
Expressions => Expressions (N)));
end if;
Analyze (N);
if Is_Image_Applied_To_Object (P, P_Type) then
Check_Object_Reference_Image (Standard_String);
return;
else
Check_Scalar_Type;
end if;
Check_Scalar_Type;
Set_Etype (N, Standard_String);
if Is_Real_Type (P_Type) then
@ -4115,25 +4114,7 @@ package body Sem_Attr is
---------
when Attribute_Img =>
Check_E0;
Set_Etype (N, Standard_String);
if not Is_Scalar_Type (P_Type)
or else (Is_Entity_Name (P) and then Is_Type (Entity (P)))
then
Error_Attr_P
("prefix of % attribute must be scalar object name");
end if;
Check_Enum_Image;
-- Check restriction No_Fixed_IO
if Restriction_Check_Required (No_Fixed_IO)
and then Is_Fixed_Point_Type (P_Type)
then
Check_Restriction (No_Fixed_IO, P);
end if;
Check_Object_Reference_Image (Standard_String);
-----------
-- Input --
@ -7014,6 +6995,12 @@ package body Sem_Attr is
when Attribute_Wide_Image =>
Check_SPARK_05_Restriction_On_Attribute;
if Is_Image_Applied_To_Object (P, P_Type) then
Check_Object_Reference_Image (Standard_Wide_String);
return;
end if;
Check_Scalar_Type;
Set_Etype (N, Standard_Wide_String);
Check_E1;
@ -7033,6 +7020,11 @@ package body Sem_Attr is
---------------------
when Attribute_Wide_Wide_Image =>
if Is_Image_Applied_To_Object (P, P_Type) then
Check_Object_Reference_Image (Standard_Wide_Wide_String);
return;
end if;
Check_Scalar_Type;
Set_Etype (N, Standard_Wide_Wide_String);
Check_E1;

22
gcc/ada/sem_util.adb
View File

@ -13773,6 +13773,20 @@ package body Sem_Util is
N_Generic_Subprogram_Declaration);
end Is_Generic_Declaration_Or_Body;
--------------------------------
-- Is_Image_Applied_To_Object --
--------------------------------
function Is_Image_Applied_To_Object
(Prefix : Node_Id;
P_Typ : Entity_Id) return Boolean
is
begin
return Ada_Version > Ada_2005
and then Is_Object_Reference (Prefix)
and then Is_Scalar_Type (P_Typ);
end Is_Image_Applied_To_Object;
----------------------------
-- Is_Inherited_Operation --
----------------------------
@ -17045,12 +17059,16 @@ package body Sem_Util is
Formal : Entity_Id;
begin
-- Ada 2005 or later, and formals present
-- Ada 2005 or later, and formals present. The first formal must
-- be of type that supports prefix notation: a controlling argument,
-- a class-wide type, or an access to such.
if Ada_Version >= Ada_2005
and then Present (First_Formal (E))
and then No (Default_Value (First_Formal (E)))
and then Is_Controlling_Formal (First_Formal (E))
and then (Is_Controlling_Formal (First_Formal (E))
or else Is_Class_Wide_Type (Etype (First_Formal (E)))
or else Is_Anonymous_Access_Type (Etype (First_Formal (E))))
then
Formal := Next_Formal (First_Formal (E));
while Present (Formal) loop

12
gcc/ada/sem_util.ads
View File

@ -1598,6 +1598,18 @@ package Sem_Util is
-- Determine whether arbitrary declaration Decl denotes a generic package,
-- a generic subprogram or a generic body.
function Is_Image_Applied_To_Object
(Prefix : Node_Id;
P_Typ : Entity_Id) return Boolean;
-- Returns true if an 'Image, 'Wide_Image, or 'Wide_Wide_Image attribute
-- can be applied to a given object-reference prefix (see AI12-00124-1).
-- AI12-00124-1 : The ARG has adopted the GNAT semantics of 'Img for
-- scalar types, so that the prefix can be an object and not a type,
-- and there is no need for an argument. Given the vote of confidence
-- from the ARG, simplest is to transform this new usage of 'Image
-- into a reference to 'Img.
function Is_Inherited_Operation (E : Entity_Id) return Boolean;
-- E is a subprogram. Return True is E is an implicit operation inherited
-- by a derived type declaration.