https://gcc.gnu.org/g:1a83eb97fbef42e3a04d6575dd82cbbe9445b04e
commit r16-8984-g1a83eb97fbef42e3a04d6575dd82cbbe9445b04e Author: Eric Botcazou <[email protected]> Date: Wed Jan 21 10:05:17 2026 +0100 ada: Fix different 'Img and 'Image on enumeration type with Put_Image As documented in the GNAT RM, 'Img should behave like 'Image for objects. The change fixes the problem and also implements more aggressive folding. gcc/ada/ChangeLog: * sem_attr.adb: Add with and use clauses for Exp_Put_Image. (Eval_Attribute.Fold_Compile_Time_Known_Enumeration_Image): New procedure factored out from.... (Eval_Attribute): ...here. Attempt to fold 'Img and 'Image for all compile-time known values of enumeration, but not character, types, provided that Put_Image need not be called, by invoking the nested Fold_Compile_Time_Known_Enumeration_Image procedure on the value. Diff: --- gcc/ada/sem_attr.adb | 116 +++++++++++++++++++++++++-------------------------- 1 file changed, 58 insertions(+), 58 deletions(-) diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index e4fc782fcd92..6c049b82e835 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -37,6 +37,7 @@ with Elists; use Elists; with Errout; use Errout; with Eval_Fat; with Exp_Dist; use Exp_Dist; +with Exp_Put_Image; use Exp_Put_Image; with Exp_Util; use Exp_Util; with Expander; use Expander; with Freeze; use Freeze; @@ -8096,6 +8097,10 @@ package body Sem_Attr is function Mantissa return Uint; -- Returns the Mantissa value for the prefix type + procedure Fold_Compile_Time_Known_Enumeration_Image (Expr : Node_Id); + -- Folds 'Image of a compile-time known enumeration value into a string + -- literal whose contents depend on whether names are available. + procedure Set_Bounds; -- Used for First, Last and Length attributes applied to an array or -- array subtype. Sets the variables Lo_Bound and Hi_Bound to the low @@ -8193,6 +8198,37 @@ package body Sem_Attr is Compile_Time_Known_Value (Type_High_Bound (Typ)); end Compile_Time_Known_Bounds; + ----------------------------------------------- + -- Fold_Compile_Time_Known_Enumeration_Image -- + ----------------------------------------------- + + procedure Fold_Compile_Time_Known_Enumeration_Image (Expr : Node_Id) is + Lit : constant Entity_Id := Expr_Value_E (Expr); + Typ : constant Entity_Id := First_Subtype (Etype (Expr)); + + begin + pragma Assert (Ekind (Lit) = E_Enumeration_Literal); + + Start_String; + + -- If Discard_Names is in effect for the type, either specifically + -- or globally, then we emit the numeric representation of the 'Pos + -- attribute of the enumeration literal with a leading space. + + if Discard_Names (Typ) or else Global_Discard_Names then + UI_Image (Enumeration_Pos (Lit), Decimal); + Store_String_Char (' '); + Store_String_Chars (UI_Image_Buffer (1 .. UI_Image_Length)); + else + Get_Unqualified_Decoded_Name_String (Chars (Lit)); + Set_Casing (All_Upper_Case); + Store_String_Chars (Name_Buffer (1 .. Name_Len)); + end if; + + Rewrite (N, Make_String_Literal (Loc, Strval => End_String)); + Analyze_And_Resolve (N, Standard_String); + end Fold_Compile_Time_Known_Enumeration_Image; + ---------------- -- Fore_Value -- ---------------- @@ -8478,43 +8514,20 @@ package body Sem_Attr is -- Attribute 'Img applied to a static enumeration value is static, and -- we will do the folding right here (things get confused if we let this - -- case go through the normal circuitry). - - if Id = Attribute_Img - and then Is_Entity_Name (P) - and then Is_Enumeration_Type (Etype (Entity (P))) - and then Is_OK_Static_Expression (P) + -- case go through the normal circuitry) provided that the default Image + -- implementation has not been overridden. Likewise for 'Image applied + -- to an object, except that it is never static, see a few lines below. + + if (Id = Attribute_Img + or else (Id = Attribute_Image and then Is_Object_Reference (P))) + and then Is_Enumeration_Type (Etype (P)) + and then not Is_Character_Type (Etype (P)) + and then Compile_Time_Known_Value (P) + and then not Image_Should_Call_Put_Image (N) then - declare - Lit : constant Entity_Id := Expr_Value_E (P); - Typ : constant Entity_Id := Etype (Entity (P)); - Str : String_Id; - - begin - Start_String; - - -- If Discard_Names is in effect for the type, then we emit the - -- numeric representation of the prefix literal 'Pos attribute, - -- prefixed with a single space. - - if Discard_Names (Typ) then - UI_Image (Enumeration_Pos (Lit), Decimal); - Store_String_Char (' '); - Store_String_Chars (UI_Image_Buffer (1 .. UI_Image_Length)); - else - Get_Unqualified_Decoded_Name_String (Chars (Lit)); - Set_Casing (All_Upper_Case); - Store_String_Chars (Name_Buffer (1 .. Name_Len)); - end if; - - Str := End_String; - - Rewrite (N, Make_String_Literal (Loc, Strval => Str)); - Analyze_And_Resolve (N, Standard_String); - Set_Is_Static_Expression (N, True); - end; - - return; + Fold_Compile_Time_Known_Enumeration_Image (P); + Set_Is_Static_Expression + (N, Id = Attribute_Img and then Is_OK_Static_Expression (P)); end if; -- Special processing for cases where the prefix is an object or value, @@ -9716,32 +9729,19 @@ package body Sem_Attr is -- Image -- ----------- - -- Image is a scalar attribute, but is never static, because it is - -- not a static function (having a non-scalar argument (RM 4.9(22)). + -- Image is a scalar attribute, but is never static, because it is not + -- a static function (as having a non-scalar result type (RM 4.9(22)). -- However, we can constant-fold the image of an enumeration literal - -- if names are available and default Image implementation has not - -- been overridden. + -- if the default Image implementation has not been overridden. when Attribute_Image => - if Is_Entity_Name (E1) - and then Ekind (Entity (E1)) = E_Enumeration_Literal - and then not Discard_Names (First_Subtype (Etype (E1))) - and then not Global_Discard_Names - and then not Has_Aspect (Etype (E1), Aspect_Put_Image) + if Is_Enumeration_Type (Etype (P)) + and then not Is_Character_Type (Etype (P)) + and then Compile_Time_Known_Value (E1) + and then not Image_Should_Call_Put_Image (N) then - declare - Lit : constant Entity_Id := Entity (E1); - Str : String_Id; - begin - Start_String; - Get_Unqualified_Decoded_Name_String (Chars (Lit)); - Set_Casing (All_Upper_Case); - Store_String_Chars (Name_Buffer (1 .. Name_Len)); - Str := End_String; - Rewrite (N, Make_String_Literal (Loc, Strval => Str)); - Analyze_And_Resolve (N, Standard_String); - Set_Is_Static_Expression (N, False); - end; + Fold_Compile_Time_Known_Enumeration_Image (E1); + Set_Is_Static_Expression (N, False); end if; -------------------
