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 --git a/gcc/ada/sem_eval.adb b/gcc/ada/sem_eval.adb
index 76401495d5880d8eec2806f91011ba27ffd27d49..7e146fe71bc4717573100a7d2008ac995eea13d2 100644 (file)
--- 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 301894b6bbd2393b7c2951d59ae7c9027c6eaa34..1db373b58fb90c07c8d1e2db0cd3253685345eb0 100644 (file)
--- 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;