https://gcc.gnu.org/g:169699428d3c54ccdd56654e1f7b20ea49109d17
commit r16-5236-g169699428d3c54ccdd56654e1f7b20ea49109d17 Author: Eric Botcazou <[email protected]> Date: Mon Oct 27 09:18:53 2025 +0100 ada: Detect illegal value of static expression of decimal fixed point type The RM 4.9(36/2) subclause says that, if a static expression is of type universal_real and its expected type is a decimal fixed point type, then its value shall be a multiple of the small of the decimal type. This was enforced for real literals, but not for real named numbers. Fixing the problem involves tweaking Fold_Ureal and the same tweak is also applied to Fold_Uint for the sake of consistency in the implementation. gcc/ada/ChangeLog: PR ada/29463 * sem_eval.adb (Fold_Uint): Use Universal_Integer as actual type for a named number. (Fold_Ureal): Likewise with Universal_Real. * sem_res.adb (Resolve_Real_Literal): Test whether the literal is a static expression instead of coming from source to give the error prescribed by the RM 4.9(36/2) subclause. Diff: --- gcc/ada/sem_eval.adb | 32 +++++++++++++++++++++----------- gcc/ada/sem_res.adb | 9 +++++---- 2 files changed, 26 insertions(+), 15 deletions(-) diff --git a/gcc/ada/sem_eval.adb b/gcc/ada/sem_eval.adb index 76401495d588..7e146fe71bc4 100644 --- a/gcc/ada/sem_eval.adb +++ b/gcc/ada/sem_eval.adb @@ -5151,8 +5151,10 @@ package body Sem_Eval is procedure Fold_Uint (N : Node_Id; Val : Uint; Static : Boolean) is Loc : constant Source_Ptr := Sloc (N); - Typ : Entity_Id := Etype (N); - Ent : Entity_Id; + + Actual_Typ : Entity_Id; + Ent : Entity_Id; + Typ : Entity_Id; begin if Raises_Constraint_Error (N) then @@ -5160,19 +5162,23 @@ package body Sem_Eval is return; end if; + Typ := Etype (N); + + if Is_Private_Type (Typ) then + Typ := Full_View (Typ); + end if; + -- If we are folding a named number, retain the entity in the literal -- in the original tree. if Is_Entity_Name (N) and then Ekind (Entity (N)) = E_Named_Integer then + Actual_Typ := Universal_Integer; Ent := Entity (N); else + Actual_Typ := Typ; Ent := Empty; end if; - if Is_Private_Type (Typ) then - Typ := Full_View (Typ); - end if; - -- For a result of type integer, substitute an N_Integer_Literal node -- for the result of the compile time evaluation of the expression. -- Set a link to the original named number when not in a generic context @@ -5202,8 +5208,8 @@ package body Sem_Eval is Analyze (N); Set_Is_Static_Expression (N, Static); - Set_Etype (N, Typ); - Resolve (N); + Set_Etype (N, Actual_Typ); + Resolve (N, Typ); Set_Is_Static_Expression (N, Static); end Fold_Uint; @@ -5214,7 +5220,9 @@ package body Sem_Eval is procedure Fold_Ureal (N : Node_Id; Val : Ureal; Static : Boolean) is Loc : constant Source_Ptr := Sloc (N); Typ : constant Entity_Id := Etype (N); - Ent : Entity_Id; + + Actual_Typ : Entity_Id; + Ent : Entity_Id; begin if Raises_Constraint_Error (N) then @@ -5226,8 +5234,10 @@ package body Sem_Eval is -- in the original tree. if Is_Entity_Name (N) and then Ekind (Entity (N)) = E_Named_Real then + Actual_Typ := Universal_Real; Ent := Entity (N); else + Actual_Typ := Typ; Ent := Empty; end if; @@ -5251,8 +5261,8 @@ package body Sem_Eval is Analyze (N); Set_Is_Static_Expression (N, Static); - Set_Etype (N, Typ); - Resolve (N); + Set_Etype (N, Actual_Typ); + Resolve (N, Typ); Set_Analyzed (N); Set_Is_Static_Expression (N, Static); end Fold_Ureal; diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index 301894b6bbd2..1db373b58fb9 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -11310,12 +11310,13 @@ package body Sem_Res is if Den /= 1 then - -- For a source program literal for a decimal fixed-point type, - -- this is statically illegal (RM 4.9(36)). + -- This is illegal for the value of a static expression of type + -- universal_real if the expected type is a decimal fixed-point + -- type (RM 4.9(36/2)). - if Is_Decimal_Fixed_Point_Type (Typ) + if Is_OK_Static_Expression (N) and then Actual_Typ = Universal_Real - and then Comes_From_Source (N) + and then Is_Decimal_Fixed_Point_Type (Typ) then Error_Msg_N ("value has extraneous low order digits", N); end if;
