[Ada] Fix incorrect fixed-point computation in expression function
Commit Message
This fixes a couple of issues pertaining to (ordinary) fixed-point types
declared with a Small aspect whose value is not equal to the default one.
The processing of this aspect is delayed until the freeze point of the type,
which means that the Small_Value of the entity for the type does not have
the right value until after the freeze point is encountered.
The first issue is that Resolve_Real_Literal could use the Small_Value of
the entity for an unfrozen type, for example during the pre-analysis of a
default expression or of an expression function.
The second issue is that Freeze_Fixed_Point_Type could still use the old
value of Small_Value even after it has set the field to its final value.
It could also overwrite a correct Small_Value with garbage in the case of
the subtype of a private fixed-point type.
Tested on x86_64-pc-linux-gnu, committed on trunk
gcc/ada/
* einfo.ads (E_Decimal_Fixed_Point_Subtype): Fix pasto.
* freeze.adb (Freeze_Fixed_Point_Type): Retrieve the underlying type
of the first subtype and do not use a stale value of Small_Value.
* sem_res.adb (Resolve_Real_Literal): In the case of a fixed-point
type, make sure that the base type is frozen and use its Small_Value
to compute the corresponding integer value of the literal.
@@ -5353,7 +5353,7 @@ package Einfo is
-- Size_Clause (synth)
-- E_Decimal_Fixed_Point_Type
- -- E_Decimal_Fixed_Subtype$$$no such thing
+ -- E_Decimal_Fixed_Point_Subtype
-- Scale_Value
-- Digits_Value
-- Scalar_Range
@@ -8997,8 +8997,9 @@ package body Freeze is
Brng : constant Node_Id := Scalar_Range (Btyp);
BLo : constant Node_Id := Low_Bound (Brng);
BHi : constant Node_Id := High_Bound (Brng);
- Par : constant Entity_Id := First_Subtype (Typ);
- Small : constant Ureal := Small_Value (Typ);
+ Ftyp : constant Entity_Id := Underlying_Type (First_Subtype (Typ));
+
+ Small : Ureal;
Loval : Ureal;
Hival : Ureal;
Atype : Entity_Id;
@@ -9037,7 +9038,7 @@ package body Freeze is
function Larger (A, B : Ureal) return Boolean is
begin
- return A > B and then A - Small > B;
+ return A > B and then A - Small_Value (Typ) > B;
end Larger;
-------------
@@ -9046,7 +9047,7 @@ package body Freeze is
function Smaller (A, B : Ureal) return Boolean is
begin
- return A < B and then A + Small < B;
+ return A < B and then A + Small_Value (Typ) < B;
end Smaller;
-- Start of processing for Freeze_Fixed_Point_Type
@@ -9057,9 +9058,15 @@ package body Freeze is
-- so that all characteristics of the type (size, bounds) can be
-- computed and validated in the call to Minimum_Size that follows.
- if Has_Delayed_Aspects (First_Subtype (Typ)) then
- Analyze_Aspects_At_Freeze_Point (First_Subtype (Typ));
- Set_Has_Delayed_Aspects (First_Subtype (Typ), False);
+ if Has_Delayed_Aspects (Ftyp) then
+ Analyze_Aspects_At_Freeze_Point (Ftyp);
+ Set_Has_Delayed_Aspects (Ftyp, False);
+ end if;
+
+ -- Inherit the Small value from the first subtype in any case
+
+ if Typ /= Ftyp then
+ Set_Small_Value (Typ, Small_Value (Ftyp));
end if;
-- If Esize of a subtype has not previously been set, set it now
@@ -9074,16 +9081,6 @@ package body Freeze is
end if;
end if;
- -- The 'small attribute may have been specified with an aspect,
- -- in which case it is processed after a subtype declaration, so
- -- inherit now the specified value.
-
- if Typ /= Par
- and then Present (Find_Aspect (Par, Aspect_Small))
- then
- Set_Small_Value (Typ, Small_Value (Par));
- end if;
-
-- Immediate return if the range is already analyzed. This means that
-- the range is already set, and does not need to be computed by this
-- routine.
@@ -9100,6 +9097,7 @@ package body Freeze is
return;
end if;
+ Small := Small_Value (Typ);
Loval := Realval (Lo);
Hival := Realval (Hi);
@@ -9137,7 +9135,6 @@ package body Freeze is
Size_Excl_EP : Int;
Model_Num : Ureal;
- First_Subt : Entity_Id;
Actual_Lo : Ureal;
Actual_Hi : Ureal;
@@ -9279,10 +9276,8 @@ package body Freeze is
-- to get a base type whose size is smaller than the specified
-- size of the first subtype.
- First_Subt := First_Subtype (Typ);
-
- if Has_Size_Clause (First_Subt)
- and then Size_Incl_EP <= Esize (First_Subt)
+ if Has_Size_Clause (Ftyp)
+ and then Size_Incl_EP <= Esize (Ftyp)
then
Actual_Size := Size_Incl_EP;
Actual_Lo := Loval_Incl_EP;
@@ -10765,17 +10765,23 @@ package body Sem_Res is
begin
-- Special processing for fixed-point literals to make sure that the
- -- value is an exact multiple of small where this is required. We skip
- -- this for the universal real case, and also for generic types.
+ -- value is an exact multiple of the small where this is required. We
+ -- skip this for the universal real case, and also for generic types.
if Is_Fixed_Point_Type (Typ)
and then Typ /= Universal_Fixed
and then Typ /= Any_Fixed
and then not Is_Generic_Type (Typ)
then
+ -- We must freeze the base type to get the proper value of the small
+
+ if not Is_Frozen (Base_Type (Typ)) then
+ Freeze_Fixed_Point_Type (Base_Type (Typ));
+ end if;
+
declare
Val : constant Ureal := Realval (N);
- Cintr : constant Ureal := Val / Small_Value (Typ);
+ Cintr : constant Ureal := Val / Small_Value (Base_Type (Typ));
Cint : constant Uint := UR_Trunc (Cintr);
Den : constant Uint := Norm_Den (Cintr);
Stat : Boolean;