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 <de...@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.
Index: exp_attr.adb
===================================================================
--- exp_attr.adb (revision 211622)
+++ exp_attr.adb (working copy)
@@ -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);
Index: sem_attr.adb
===================================================================
--- sem_attr.adb (revision 211622)
+++ sem_attr.adb (working copy)
@@ -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
