From a4f4dbdb5aed55635b7977300ed7a860c5cd606a Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Wed, 6 Sep 2017 12:07:16 +0200 Subject: [PATCH] [multiple changes] 2017-09-06 Hristian Kirtchev * exp_ch5.adb, freeze.adb, exp_ch4.adb, exp_ch6.adb, lib-xref.adb: Minor reformatting. 2017-09-06 Justin Squirek * 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 --- gcc/ada/ChangeLog | 17 +++++++ gcc/ada/exp_attr.adb | 45 ++++++++++++++++--- gcc/ada/exp_ch4.adb | 23 +++++----- gcc/ada/exp_ch5.adb | 18 ++++---- gcc/ada/exp_ch6.adb | 8 ++-- gcc/ada/freeze.adb | 4 +- gcc/ada/lib-xref.adb | 3 ++ gcc/ada/sem_attr.adb | 104 ++++++++++++++++++++----------------------- gcc/ada/sem_util.adb | 22 ++++++++- gcc/ada/sem_util.ads | 12 +++++ 10 files changed, 164 insertions(+), 92 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 196edaec3e4..e5e1c7d0d68 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,20 @@ +2017-09-06 Hristian Kirtchev + + * exp_ch5.adb, freeze.adb, exp_ch4.adb, exp_ch6.adb, lib-xref.adb: + Minor reformatting. + +2017-09-06 Justin Squirek + + * 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 * freeze.adb (Freeze_Entity): Do not generate a freeze diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb index 5413581002f..456c1cb01f6 100644 --- a/gcc/ada/exp_attr.adb +++ b/gcc/ada/exp_attr.adb @@ -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. diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index 9e18ec78e3d..ce8783742f5 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -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); diff --git a/gcc/ada/exp_ch5.adb b/gcc/ada/exp_ch5.adb index 4a892556356..c30307415fa 100644 --- a/gcc/ada/exp_ch5.adb +++ b/gcc/ada/exp_ch5.adb @@ -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); diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index 3101b7c35c1..756eeaba449 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -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 diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb index 5540c78fecf..42c7463bed8 100644 --- a/gcc/ada/freeze.adb +++ b/gcc/ada/freeze.adb @@ -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; diff --git a/gcc/ada/lib-xref.adb b/gcc/ada/lib-xref.adb index d40f0d42fbd..c2958ead326 100644 --- a/gcc/ada/lib-xref.adb +++ b/gcc/ada/lib-xref.adb @@ -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; diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index d7ee88e7bc5..44320b89ff0 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -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; diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index dde75ce39e8..4e03381463c 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -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 diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index 8eb71d0db74..1656c402437 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -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. -- 2.30.2