===================================================================
@@ -4440,7 +4440,8 @@
----------
-- 1. Deal with enumeration types with holes
- -- 2. For floating-point, generate call to attribute function
+ -- 2. For floating-point, generate call to attribute function and deal
+ -- with range checking if Check_Float_Overflow modde.
-- 3. For other cases, deal with constraint checking
when Attribute_Pred => Pred :
@@ -4512,9 +4513,36 @@
Analyze_And_Resolve (N, Typ);
-- For floating-point, we transform 'Pred into a call to the Pred
- -- floating-point attribute function in Fat_xxx (xxx is root type)
+ -- floating-point attribute function in Fat_xxx (xxx is root type).
elsif Is_Floating_Point_Type (Ptyp) then
+
+ -- Handle case of range check. The Do_Range_Check flag is set only
+ -- in Check_Float_Overflow mode, and what we need is a specific
+ -- check against typ'First, since that is the only overflow case.
+
+ declare
+ Expr : constant Node_Id := First (Exprs);
+ begin
+ if Do_Range_Check (Expr) then
+ Set_Do_Range_Check (Expr, False);
+ Insert_Action (N,
+ Make_Raise_Constraint_Error (Loc,
+ Condition =>
+ Make_Op_Eq (Loc,
+ Left_Opnd => Duplicate_Subexpr (Expr),
+ Right_Opnd =>
+ Make_Attribute_Reference (Loc,
+ Attribute_Name => Name_First,
+ Prefix =>
+ New_Occurrence_Of (Base_Type (Ptyp), Loc))),
+ Reason => CE_Range_Check_Failed),
+ Suppress => All_Checks);
+ end if;
+ end;
+
+ -- Transform into call to attribute function
+
Expand_Fpt_Attribute_R (N);
Analyze_And_Resolve (N, Typ);
@@ -5563,6 +5591,33 @@
-- floating-point attribute function in Fat_xxx (xxx is root type)
elsif Is_Floating_Point_Type (Ptyp) then
+
+ -- Handle case of range check. The Do_Range_Check flag is set only
+ -- in Check_Float_Overflow mode, and what we need is a specific
+ -- check against typ'Last, since that is the only overflow case.
+
+ declare
+ Expr : constant Node_Id := First (Exprs);
+ begin
+ if Do_Range_Check (Expr) then
+ Set_Do_Range_Check (Expr, False);
+ Insert_Action (N,
+ Make_Raise_Constraint_Error (Loc,
+ Condition =>
+ Make_Op_Eq (Loc,
+ Left_Opnd => Duplicate_Subexpr (Expr),
+ Right_Opnd =>
+ Make_Attribute_Reference (Loc,
+ Attribute_Name => Name_Last,
+ Prefix =>
+ New_Occurrence_Of (Base_Type (Ptyp), Loc))),
+ Reason => CE_Range_Check_Failed),
+ Suppress => All_Checks);
+ end if;
+ end;
+
+ -- Transform into call to attribute function
+
Expand_Fpt_Attribute_R (N);
Analyze_And_Resolve (N, Typ);
===================================================================
@@ -2409,6 +2409,8 @@
end if;
end if;
+ -- Cases where prefix must be resolvable by itself
+
if Is_Overloaded (P)
and then Aname /= Name_Access
and then Aname /= Name_Address
@@ -4835,17 +4837,20 @@
if Is_Real_Type (P_Type) or else Is_Boolean_Type (P_Type) then
Error_Msg_Name_1 := Aname;
Error_Msg_Name_2 := Chars (P_Type);
- Check_SPARK_Restriction
- ("attribute% is not allowed for type%", P);
+ Check_SPARK_Restriction ("attribute% is not allowed for type%", P);
end if;
Resolve (E1, P_Base_Type);
Set_Etype (N, P_Base_Type);
- -- Nothing to do for real type case
+ -- For real types, enable range check in Check_Overflow_Mode only
if Is_Real_Type (P_Type) then
- null;
+ if Check_Float_Overflow
+ and then not Range_Checks_Suppressed (P_Base_Type)
+ then
+ Enable_Range_Check (E1);
+ end if;
-- If not modular type, test for overflow check required
@@ -5739,17 +5744,20 @@
if Is_Real_Type (P_Type) or else Is_Boolean_Type (P_Type) then
Error_Msg_Name_1 := Aname;
Error_Msg_Name_2 := Chars (P_Type);
- Check_SPARK_Restriction
- ("attribute% is not allowed for type%", P);
+ Check_SPARK_Restriction ("attribute% is not allowed for type%", P);
end if;
Resolve (E1, P_Base_Type);
Set_Etype (N, P_Base_Type);
- -- Nothing to do for real type case
+ -- For real types, enable range check in Check_Overflow_Mode only
if Is_Real_Type (P_Type) then
- null;
+ if Check_Float_Overflow
+ and then not Range_Checks_Suppressed (P_Base_Type)
+ then
+ Enable_Range_Check (E1);
+ end if;
-- If not modular type, test for overflow check required
In Float_Check_Overflow mode, Succ applied to type'Last or Pred applied to type'First generates a constraint error since the argument is out of range. This was not previously changed, the following test: 1. with Ada.Exceptions; use Ada.Exceptions; 2. with Text_IO; use Text_IO; 3. procedure Bad_Succ is 4. X : Float; 5. begin 6. begin 7. X := Float'Last; 8. X := Float'Succ (X); 9. exception 10. when E : Constraint_Error => 11. Put_Line (Exception_Information (E)); 12. end; 13. begin 14. X := Float'First; 15. X := Float'Pred (X); 16. exception 17. when E : Constraint_Error => 18. Put_Line (Exception_Information (E)); 19. end; 20. end Bad_Succ; Compiled with -gnatc -gnatdt generates a tree file with two occurrences of Do_Range_Check (one on the succ and one on the pred). If this program is executed, the output is: Exception name: CONSTRAINT_ERROR Message: bad_succ.adb:8 range check failed Exception name: CONSTRAINT_ERROR Message: bad_succ.adb:15 range check failed Tested on x86_64-pc-linux-gnu, committed on trunk 2014-06-13 Robert Dewar <dewar@adacore.com> * exp_attr.adb (Expand_N_Attribute_Reference, case Pred): Handle float range check case (Expand_N_Attribute_Reference, case Succ): Handle float range check case. * sem_attr.adb (Analyze_Attribute, case Pred/Succ): Handle float range check case.