From b276ab7a45afb2181df553fcf064d1fc80a1a450 Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Wed, 6 Sep 2017 13:02:33 +0200 Subject: [PATCH] [multiple changes] 2017-09-06 Yannick Moy * inline.adb: Add comments to Can_Be_Inlined_In_GNATprove_Mode. 2017-09-06 Javier Miranda * exp_aggr.adb (Component_Not_OK_For_Backend): The C backend cannot handle a type conversion of an array as an aggregate component. 2017-09-06 Bob Duff * g-comlin.adb (Try_Help): Remove ".exe" so we get the same results on windows and unix. 2017-09-06 Justin Squirek * exp_imgv.adb (Expand_Image_Attribute), (Expand_Wide_Image_Attribute), (Expand_Wide_Wide_Image_Attribute): Added case to handle new-style 'Image expansion (Rewrite_Object_Image): Moved from exp_attr.adb * exp_attr.adb (Expand_N_Attribute_Reference): Modified Image attribute cases so that the relevant subprograms in exp_imgv.adb handle all expansion. (Rewrite_Object_Reference_Image): Moved to exp_imgv.adb * sem_attr.adb (Analyze_Attribute): Modified Image attribute cases to call common function Analyze_Image_Attribute. (Analyze_Image_Attribute): Created as a common path for all image attributes (Check_Object_Reference_Image): Removed * sem_util.ads, sem_util.adb (Is_Image_Applied_To_Object): Removed and refactored into Is_Object_Image (Is_Object_Image): Created as a replacement for Is_Image_Applied_To_Object From-SVN: r251779 --- gcc/ada/ChangeLog | 33 ++++++++ gcc/ada/exp_aggr.adb | 7 ++ gcc/ada/exp_attr.adb | 43 +--------- gcc/ada/exp_imgv.adb | 73 ++++++++++++++--- gcc/ada/exp_imgv.ads | 18 ++--- gcc/ada/g-comlin.adb | 2 +- gcc/ada/inline.adb | 13 ++- gcc/ada/sem_attr.adb | 184 ++++++++++++++++++++----------------------- gcc/ada/sem_util.adb | 40 ++++++---- gcc/ada/sem_util.ads | 21 +++-- 10 files changed, 243 insertions(+), 191 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 733214da004..2d8077d3e24 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,36 @@ +2017-09-06 Yannick Moy + + * inline.adb: Add comments to Can_Be_Inlined_In_GNATprove_Mode. + +2017-09-06 Javier Miranda + + * exp_aggr.adb (Component_Not_OK_For_Backend): The C backend + cannot handle a type conversion of an array as an aggregate + component. + +2017-09-06 Bob Duff + + * g-comlin.adb (Try_Help): Remove ".exe" so we + get the same results on windows and unix. + +2017-09-06 Justin Squirek + + * exp_imgv.adb (Expand_Image_Attribute), + (Expand_Wide_Image_Attribute), (Expand_Wide_Wide_Image_Attribute): + Added case to handle new-style 'Image expansion + (Rewrite_Object_Image): Moved from exp_attr.adb + * exp_attr.adb (Expand_N_Attribute_Reference): Modified Image + attribute cases so that the relevant subprograms in exp_imgv.adb + handle all expansion. + (Rewrite_Object_Reference_Image): Moved to exp_imgv.adb + * sem_attr.adb (Analyze_Attribute): Modified Image attribute + cases to call common function Analyze_Image_Attribute. + (Analyze_Image_Attribute): Created as a common path for all + image attributes (Check_Object_Reference_Image): Removed + * sem_util.ads, sem_util.adb (Is_Image_Applied_To_Object): + Removed and refactored into Is_Object_Image (Is_Object_Image): + Created as a replacement for Is_Image_Applied_To_Object + 2017-09-06 Yannick Moy * sem_prag.adb (Analyze_Depends_In_Decl_Part): Add continuation diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb index 38d233b2973..549be9673ef 100644 --- a/gcc/ada/exp_aggr.adb +++ b/gcc/ada/exp_aggr.adb @@ -7151,6 +7151,13 @@ package body Exp_Aggr is then Static_Components := False; return True; + + elsif Modify_Tree_For_C + and then Nkind (Expr_Q) = N_Type_Conversion + and then Is_Array_Type (Etype (Expr_Q)) + then + Static_Components := False; + return True; end if; if Is_Elementary_Type (Etype (Expr_Q)) then diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb index aa23038e740..d1908bd04f9 100644 --- a/gcc/ada/exp_attr.adb +++ b/gcc/ada/exp_attr.adb @@ -1594,34 +1594,10 @@ 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); - -- AI12-00124: Rewrite attribute 'Image when it is applied to an object - -- reference as 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 -- ------------------------------ @@ -3637,11 +3613,6 @@ 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. @@ -3658,7 +3629,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_Object_Reference_Image (Name_Image, Standard_String); + Exp_Imgv.Expand_Image_Attribute (N); ----------- -- Input -- @@ -7004,12 +6975,6 @@ 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. @@ -7026,12 +6991,6 @@ 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_imgv.adb b/gcc/ada/exp_imgv.adb index 28de1f47945..f42f94dabab 100644 --- a/gcc/ada/exp_imgv.adb +++ b/gcc/ada/exp_imgv.adb @@ -36,6 +36,7 @@ with Opt; use Opt; with Rtsfind; use Rtsfind; with Sem_Aux; use Sem_Aux; with Sem_Res; use Sem_Res; +with Sem_Util; use Sem_Util; with Sinfo; use Sinfo; with Snames; use Snames; with Stand; use Stand; @@ -52,6 +53,17 @@ package body Exp_Imgv is -- Ordinary_Fixed_Point_Type with a small that is a negative power of ten. -- Shouldn't this be in einfo.adb or sem_aux.adb??? + procedure Rewrite_Object_Image + (N : Node_Id; + Pref : Entity_Id; + Attr_Name : Name_Id; + Str_Typ : Entity_Id); + -- AI12-00124: Rewrite attribute 'Image when it is applied to an object + -- reference as an attribute applied to a type. N denotes the node to be + -- rewritten, Pref denotes the prefix of the 'Image attribute, and Name + -- and Str_Typ specify which specific string type and 'Image attribute to + -- apply (e.g. Name_Wide_Image and Standard_Wide_String). + ------------------------------------ -- Build_Enumeration_Image_Tables -- ------------------------------------ @@ -254,10 +266,10 @@ package body Exp_Imgv is Loc : constant Source_Ptr := Sloc (N); Exprs : constant List_Id := Expressions (N); Pref : constant Node_Id := Prefix (N); - Ptyp : constant Entity_Id := Entity (Pref); - Rtyp : constant Entity_Id := Root_Type (Ptyp); Expr : constant Node_Id := Relocate_Node (First (Exprs)); Imid : RE_Id; + Ptyp : Entity_Id; + Rtyp : Entity_Id; Tent : Entity_Id; Ttyp : Entity_Id; Proc_Ent : Entity_Id; @@ -273,6 +285,14 @@ package body Exp_Imgv is Pnn : constant Entity_Id := Make_Temporary (Loc, 'P'); begin + if Is_Object_Image (Pref) then + Rewrite_Object_Image (N, Pref, Name_Image, Standard_String); + return; + end if; + + Ptyp := Entity (Pref); + Rtyp := Root_Type (Ptyp); + -- Build declarations of Snn and Pnn to be inserted Ins_List := New_List ( @@ -791,11 +811,19 @@ package body Exp_Imgv is procedure Expand_Wide_Image_Attribute (N : Node_Id) is Loc : constant Source_Ptr := Sloc (N); - Rtyp : constant Entity_Id := Root_Type (Entity (Prefix (N))); - Rnn : constant Entity_Id := Make_Temporary (Loc, 'S'); - Lnn : constant Entity_Id := Make_Temporary (Loc, 'P'); + Pref : constant Entity_Id := Prefix (N); + Rnn : constant Entity_Id := Make_Temporary (Loc, 'S'); + Lnn : constant Entity_Id := Make_Temporary (Loc, 'P'); + Rtyp : Entity_Id; begin + if Is_Object_Image (Pref) then + Rewrite_Object_Image (N, Pref, Name_Wide_Image, Standard_Wide_String); + return; + end if; + + Rtyp := Root_Type (Entity (Pref)); + Insert_Actions (N, New_List ( -- Rnn : Wide_String (1 .. base_typ'Width); @@ -882,12 +910,20 @@ package body Exp_Imgv is procedure Expand_Wide_Wide_Image_Attribute (N : Node_Id) is Loc : constant Source_Ptr := Sloc (N); - Rtyp : constant Entity_Id := Root_Type (Entity (Prefix (N))); - - Rnn : constant Entity_Id := Make_Temporary (Loc, 'S'); - Lnn : constant Entity_Id := Make_Temporary (Loc, 'P'); + Pref : constant Entity_Id := Prefix (N); + Rnn : constant Entity_Id := Make_Temporary (Loc, 'S'); + Lnn : constant Entity_Id := Make_Temporary (Loc, 'P'); + Rtyp : Entity_Id; begin + if Is_Object_Image (Pref) then + Rewrite_Object_Image + (N, Pref, Name_Wide_Wide_Image, Standard_Wide_Wide_String); + return; + end if; + + Rtyp := Root_Type (Entity (Pref)); + Insert_Actions (N, New_List ( -- Rnn : Wide_Wide_String (1 .. rt'Wide_Wide_Width); @@ -1373,4 +1409,23 @@ package body Exp_Imgv is and then Ureal_10**Aft_Value (E) * Small_Value (E) = Ureal_1); end Has_Decimal_Small; + -------------------------- + -- Rewrite_Object_Image -- + -------------------------- + + procedure Rewrite_Object_Image + (N : Node_Id; + Pref : Entity_Id; + Attr_Name : Name_Id; + Str_Typ : Entity_Id) + is + begin + Rewrite (N, + Make_Attribute_Reference (Sloc (N), + Prefix => New_Occurrence_Of (Etype (Pref), Sloc (N)), + Attribute_Name => Attr_Name, + Expressions => New_List (Relocate_Node (Pref)))); + + Analyze_And_Resolve (N, Str_Typ); + end Rewrite_Object_Image; end Exp_Imgv; diff --git a/gcc/ada/exp_imgv.ads b/gcc/ada/exp_imgv.ads index 27b2452ab4e..30cae4cfd25 100644 --- a/gcc/ada/exp_imgv.ads +++ b/gcc/ada/exp_imgv.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2000-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 2000-2017, Free Software Foundation, Inc. -- -- -- -- 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- -- @@ -70,20 +70,20 @@ package Exp_Imgv is -- declarations are not constructed, and the fields remain Empty. procedure Expand_Image_Attribute (N : Node_Id); - -- This procedure is called from Exp_Attr to expand an occurrence - -- of the attribute Image. + -- This procedure is called from Exp_Attr to expand an occurrence of the + -- attribute Image. procedure Expand_Wide_Image_Attribute (N : Node_Id); - -- This procedure is called from Exp_Attr to expand an occurrence - -- of the attribute Wide_Image. + -- This procedure is called from Exp_Attr to expand an occurrence of the + -- attribute Wide_Image. procedure Expand_Wide_Wide_Image_Attribute (N : Node_Id); - -- This procedure is called from Exp_Attr to expand an occurrence - -- of the attribute Wide_Wide_Image. + -- This procedure is called from Exp_Attr to expand an occurrence of the + -- attribute Wide_Wide_Image. procedure Expand_Value_Attribute (N : Node_Id); - -- This procedure is called from Exp_Attr to expand an occurrence - -- of the attribute Value. + -- This procedure is called from Exp_Attr to expand an occurrence of the + -- attribute Value. type Atype is (Normal, Wide, Wide_Wide); -- Type of attribute in call to Expand_Width_Attribute diff --git a/gcc/ada/g-comlin.adb b/gcc/ada/g-comlin.adb index dc279153542..2fd90df4802 100644 --- a/gcc/ada/g-comlin.adb +++ b/gcc/ada/g-comlin.adb @@ -3606,7 +3606,7 @@ package body GNAT.Command_Line is begin Put_Line (Standard_Error, - "try """ & Base_Name (Ada.Command_Line.Command_Name) + "try """ & Base_Name (Ada.Command_Line.Command_Name, Suffix => ".exe") & " --help"" for more information."); end Try_Help; diff --git a/gcc/ada/inline.adb b/gcc/ada/inline.adb index 6b6222b4d82..0bbe9cfd9de 100644 --- a/gcc/ada/inline.adb +++ b/gcc/ada/inline.adb @@ -1178,8 +1178,9 @@ package body Inline is -- types. function Has_Some_Contract (Id : Entity_Id) return Boolean; - -- Returns True if subprogram Id has any contract (Pre, Post, Global, - -- Depends, etc.) + -- Returns True if subprogram Id has any contract (Pre, Post, + -- Global, Depends, etc.) The presence of Extensions_Visible + -- or Volatile_Function is also considered as a contract here. function Is_Unit_Subprogram (Id : Entity_Id) return Boolean; -- Returns True if subprogram Id defines a compilation unit @@ -1272,6 +1273,11 @@ package body Inline is if Is_Subprogram_Or_Generic_Subprogram (Id) then Items := Contract (Id); + -- Note that Classifications is not Empty when Extensions_Visible + -- or Volatile_Function is present, which causes such subprograms + -- to be considered to have a contract here. This is fine as we + -- want to avoid inlining these too. + return Present (Items) and then (Present (Pre_Post_Conditions (Items)) or else Present (Contract_Test_Cases (Items)) or else @@ -1365,7 +1371,8 @@ package body Inline is return False; -- Do not inline subprograms that have a contract on the spec or the - -- body. Use the contract(s) instead in GNATprove. + -- body. Use the contract(s) instead in GNATprove. This also prevents + -- inlining of subprograms with Extensions_Visible or Volatile_Function. elsif (Present (Spec_Id) and then Has_Some_Contract (Spec_Id)) or else diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index 1578aded403..748df60736c 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -261,6 +261,12 @@ package body Sem_Attr is -- when the above criteria are met. Spec_Id denotes the entity of the -- subprogram [body] or Empty if the attribute is illegal. + procedure Analyze_Image_Attribute (Str_Typ : Entity_Id); + -- Common processing for attributes 'Img, 'Image, 'Wide_Image, and + -- 'Wide_Wide_Image. The routine checks that the prefix is valid and + -- sets the entity type to the one specified by Str_Typ (e.g. + -- Standard_String for 'Image and Standard_Wide_String for 'Wide_Image). + procedure Bad_Attribute_For_Predicate; -- Output error message for use of a predicate (First, Last, Range) not -- allowed with a type that has predicates. If the type is a generic @@ -363,10 +369,6 @@ 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 attribute 'Image is an object reference and - -- set the type of the prefix to Str_Typ. - procedure Check_PolyORB_Attribute; -- Validity checking for PolyORB/DSA attribute @@ -1427,6 +1429,82 @@ package body Sem_Attr is end if; end Analyze_Attribute_Old_Result; + ----------------------------- + -- Analyze_Image_Attribute -- + ----------------------------- + + procedure Analyze_Image_Attribute (Str_Typ : Entity_Id) is + begin + Check_SPARK_05_Restriction_On_Attribute; + + -- AI12-00124: The ARG has adopted the GNAT semantics of 'Img for + -- scalar types, so that the prefix can be an object, a named value, + -- or a type, and there is no need for an argument in this case. + + if Attr_Id = Attribute_Img + or else (Ada_Version > Ada_2005 and then Is_Object_Image (P)) + then + Check_E0; + Set_Etype (N, Str_Typ); + + if Attr_Id = Attribute_Img and then not Is_Object_Image (P) then + Error_Attr_P + ("prefix of % attribute must be a scalar object name"); + end if; + else + Check_E1; + Set_Etype (N, Str_Typ); + + -- Check that the prefix type is scalar - much in the same way as + -- Check_Scalar_Type but with custom error messages to denote the + -- variants of 'Image attributes. + + if Is_Entity_Name (P) + and then Is_Type (Entity (P)) + and then Ekind (Entity (P)) = E_Incomplete_Type + and then Present (Full_View (Entity (P))) + then + P_Type := Full_View (Entity (P)); + Set_Entity (P, P_Type); + end if; + + if not Is_Entity_Name (P) + or else not Is_Type (Entity (P)) + or else not Is_Scalar_Type (P_Type) + then + if Ada_Version > Ada_2005 then + Error_Attr_P + ("prefix of % attribute must be a scalar type or a scalar " + & "object name"); + else + Error_Attr_P ("prefix of % attribute must be a scalar type"); + end if; + + elsif Is_Protected_Self_Reference (P) then + Error_Attr_P + ("prefix of % attribute denotes current instance " + & "(RM 9.4(21/2))"); + end if; + + Resolve (E1, P_Base_Type); + Validate_Non_Static_Attribute_Function_Call; + end if; + + Check_Enum_Image; + + -- Check restriction No_Fixed_IO. Note the check of Comes_From_Source + -- to avoid giving a duplicate message for when Image attributes + -- applied to object references get expanded into type-based Image + -- attributes. + + if Restriction_Check_Required (No_Fixed_IO) + and then Comes_From_Source (N) + and then Is_Fixed_Point_Type (P_Type) + then + Check_Restriction (No_Fixed_IO, P); + end if; + end Analyze_Image_Attribute; + --------------------------------- -- Bad_Attribute_For_Predicate -- --------------------------------- @@ -2164,33 +2242,6 @@ 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 -- ---------------------------- @@ -4073,16 +4124,6 @@ package body Sem_Attr is ----------- when Attribute_Image => - Check_SPARK_05_Restriction_On_Attribute; - - if Is_Image_Applied_To_Object (P, P_Type) then - Check_Object_Reference_Image (Standard_String); - return; - end if; - - Check_Scalar_Type; - Set_Etype (N, Standard_String); - if Is_Real_Type (P_Type) then if Ada_Version = Ada_83 and then Comes_From_Source (N) then Error_Msg_Name_1 := Aname; @@ -4091,31 +4132,14 @@ package body Sem_Attr is end if; end if; - if Is_Enumeration_Type (P_Type) then - Check_Restriction (No_Enumeration_Maps, N); - end if; - - Check_E1; - Resolve (E1, P_Base_Type); - Check_Enum_Image; - Validate_Non_Static_Attribute_Function_Call; - - -- Check restriction No_Fixed_IO. Note the check of Comes_From_Source - -- to avoid giving a duplicate message for Img expanded into Image. - - if Restriction_Check_Required (No_Fixed_IO) - and then Comes_From_Source (N) - and then Is_Fixed_Point_Type (P_Type) - then - Check_Restriction (No_Fixed_IO, P); - end if; + Analyze_Image_Attribute (Standard_String); --------- -- Img -- --------- when Attribute_Img => - Check_Object_Reference_Image (Standard_String); + Analyze_Image_Attribute (Standard_String); ----------- -- Input -- @@ -6995,50 +7019,14 @@ 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; - Resolve (E1, P_Base_Type); - Validate_Non_Static_Attribute_Function_Call; - - -- 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; + Analyze_Image_Attribute (Standard_Wide_String); --------------------- -- Wide_Wide_Image -- --------------------- 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; - Resolve (E1, P_Base_Type); - Validate_Non_Static_Attribute_Function_Call; - - -- 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; + Analyze_Image_Attribute (Standard_Wide_Wide_String); ---------------- -- Wide_Value -- diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index a06ce637748..ffbe86afbc2 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -13773,21 +13773,6 @@ 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 -- ---------------------------- @@ -14139,6 +14124,27 @@ package body Sem_Util is or else Null_Present (Component_List (Type_Definition (Decl)))); end Is_Null_Record_Type; + --------------------- + -- Is_Object_Image -- + --------------------- + + function Is_Object_Image (Prefix : Node_Id) return Boolean is + begin + -- When the type of the prefix is not scalar then the prefix is not + -- valid in any senario. + + if not Is_Scalar_Type (Etype (Prefix)) then + return False; + end if; + + -- Here we test for the case that the prefix is not a type and assume + -- if it is not then it must be a named value or an object reference. + -- This is because the parser always checks that prefix's of attributes + -- are named. + + return not (Is_Entity_Name (Prefix) and then Is_Type (Entity (Prefix))); + end Is_Object_Image; + ------------------------- -- Is_Object_Reference -- ------------------------- @@ -14222,9 +14228,9 @@ package body Sem_Util is return not Nkind_In (Original_Node (N), N_Case_Expression, N_If_Expression); - -- A view conversion of a tagged object is an object reference - when N_Type_Conversion => + -- A view conversion of a tagged object is an object reference + return Is_Tagged_Type (Etype (Subtype_Mark (N))) and then Is_Tagged_Type (Etype (Expression (N))) and then Is_Object_Reference (Expression (N)); diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index b73dc0e7879..4331b2405ec 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -1598,18 +1598,6 @@ 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). - - -- AI12-00124: 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. @@ -1683,6 +1671,15 @@ package Sem_Util is -- Determine whether T is declared with a null record definition or a -- null component list. + function Is_Object_Image (Prefix : Node_Id) return Boolean; + -- Returns true if an 'Image, 'Wide_Image, or 'Wide_Wide_Image attribute + -- is applied to a given object or named value prefix (see below). + + -- AI12-00124: The ARG has adopted the GNAT semantics of 'Img for scalar + -- types, so that the prefix of any 'Image attribute can be an object, a + -- named value, or a type, and there is no need for an argument in the + -- case it is an object reference. + function Is_Object_Reference (N : Node_Id) return Boolean; -- Determines if the tree referenced by N represents an object. Both -- variable and constant objects return True (compare Is_Variable). -- 2.30.2