From 6349cf36d8bb7fb83f67a7bc27fc67dca73b19dd Mon Sep 17 00:00:00 2001 From: Bob Duff Date: Mon, 30 Mar 2020 10:20:33 -0400 Subject: [PATCH] [Ada] Clean up error handling of 'Image 2020-06-15 Bob Duff gcc/ada/ * sem_attr.adb (Check_Image_Type): New procedure for checking the type, depending on language version. Disable the Ada 2020 support until the corresponding expander work is done. (Analyze_Image_Attribute): Call Check_Image_Type. Rearrange the code to be simplier and more logical. When P_Type is modified, modify P_Base_Type accordingly. * sem_util.adb (Is_Object_Image): Do not return False if the prefix is a type. X'Image should be considered an image of an object iff X is an object (albeit illegal pre-2020 if nonscalar). --- gcc/ada/sem_attr.adb | 69 +++++++++++++++++++++++++------------------- gcc/ada/sem_util.adb | 7 ----- 2 files changed, 39 insertions(+), 37 deletions(-) diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index 2c3cd50f462..801c4457ed6 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -1414,56 +1414,65 @@ package body Sem_Attr is ----------------------------- procedure Analyze_Image_Attribute (Str_Typ : Entity_Id) is + procedure Check_Image_Type (Image_Type : Entity_Id); + -- Check that Image_Type is legal as the type of a prefix of 'Image. + -- Legality depends on the Ada language version. + + procedure Check_Image_Type (Image_Type : Entity_Id) is + begin + if False -- ???Disable 2020 feature until expander work is done + and then Ada_Version >= Ada_2020 + then + null; -- all types are OK + elsif not Is_Scalar_Type (Image_Type) then + if Ada_Version >= Ada_2012 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; + end if; + end Check_Image_Type; + + -- Start of processing for Analyze_Image_Attribute + begin -- AI12-0124: 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. If the prefix is an object, there is no argument. - if Attr_Id = Attribute_Img - or else (Ada_Version >= Ada_2012 and then Is_Object_Image (P)) - then + if Is_Object_Image (P) then Check_E0; Set_Etype (N, Str_Typ); + Check_Image_Type (Etype (P)); - 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"); + if Attr_Id /= Attribute_Img and then Ada_Version < Ada_2012 then + Error_Attr_P ("prefix of % attribute must be a scalar type"); 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. + -- ???It's not clear why 'Img should behave any differently than + -- 'Image. - if Is_Entity_Name (P) - and then Is_Type (Entity (P)) - and then Ekind (Entity (P)) = E_Incomplete_Type + if Attr_Id = Attribute_Img then + Error_Attr_P + ("prefix of % attribute must be a scalar object name"); + end if; + + pragma Assert (Is_Entity_Name (P) and then Is_Type (Entity (P))); + + if Ekind (Entity (P)) = E_Incomplete_Type and then Present (Full_View (Entity (P))) then P_Type := Full_View (Entity (P)); + P_Base_Type := Base_Type (P_Type); 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_2012 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; - + Check_Image_Type (P_Type); Resolve (E1, P_Base_Type); Validate_Non_Static_Attribute_Function_Call; end if; diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index d7d43c90e92..a1bf0ae5b2d 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -16797,13 +16797,6 @@ package body Sem_Util is 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 scenario. - - 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 prefixes of attributes -- 2.30.2