From e943fe8a6ae5d1b5f1f82825145cbd4e7c764405 Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Mon, 4 Aug 2014 11:49:19 +0200 Subject: [PATCH] [multiple changes] 2014-08-04 Robert Dewar * sem_ch12.adb: Minor reformatting. 2014-08-04 Arnaud Charlet * exp_util.adb, checks.adb (Check_Float_Op_Overflow): Add special expansion in CodePeer_Mode. (Selected_Range_Checks): Add handling of overflow checks in CodePeer_Mode. From-SVN: r213547 --- gcc/ada/ChangeLog | 11 +++++++++++ gcc/ada/checks.adb | 17 +++++++++++++++-- gcc/ada/exp_util.adb | 22 ++++++++++++++++++++++ gcc/ada/sem_ch12.adb | 1 + 4 files changed, 49 insertions(+), 2 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index b273bfc7fa2..474921e0726 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,14 @@ +2014-08-04 Robert Dewar + + * sem_ch12.adb: Minor reformatting. + +2014-08-04 Arnaud Charlet + + * exp_util.adb, checks.adb (Check_Float_Op_Overflow): Add special + expansion in CodePeer_Mode. + (Selected_Range_Checks): Add handling of overflow checks in + CodePeer_Mode. + 2014-08-04 Robert Dewar * exp_attr.adb (Expand_N_Attribute_Reference, case Pred): diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb index 1f9493d1d18..cddd15a57f9 100644 --- a/gcc/ada/checks.adb +++ b/gcc/ada/checks.adb @@ -391,11 +391,13 @@ package body Checks is begin -- Nothing to do for unconstrained floating-point types (the test for -- Etype (N) being present seems necessary in some cases, should be - -- tracked down, but for now just ignore the check in this case ???) + -- tracked down, but for now just ignore the check in this case ???), + -- except if Check_Float_Overflow is set. if Present (Etype (N)) and then Is_Floating_Point_Type (Etype (N)) and then not Is_Constrained (Etype (N)) + and then not Check_Float_Overflow then return; end if; @@ -9212,6 +9214,7 @@ package body Checks is Wnode : Node_Id := Warn_Node; Ret_Result : Check_Result := (Empty, Empty); Num_Checks : Integer := 0; + Reason : RT_Exception_Code := CE_Range_Check_Failed; procedure Add_Check (N : Node_Id); -- Adds the action given to Ret_Result if N is non-Empty @@ -9833,6 +9836,16 @@ package body Checks is else if not In_Subrange_Of (S_Typ, T_Typ) then Cond := Discrete_Expr_Cond (Ck_Node, T_Typ); + + -- Special case CodePeer_Mode and apparently redundant checks on + -- floating point types: these are used as overflow checks, see + -- Exp_Util.Check_Float_Op_Overflow. + + elsif CodePeer_Mode and then Check_Float_Overflow + and then Is_Floating_Point_Type (S_Typ) + then + Cond := Discrete_Expr_Cond (Ck_Node, T_Typ); + Reason := CE_Overflow_Check_Failed; end if; end if; end if; @@ -10027,7 +10040,7 @@ package body Checks is Add_Check (Make_Raise_Constraint_Error (Loc, Condition => Cond, - Reason => CE_Range_Check_Failed)); + Reason => Reason)); end if; return Ret_Result; diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index 481fc37115a..f3ea21fe2bf 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -1647,6 +1647,28 @@ package body Exp_Util is return; end if; + -- Special expansion for CodePeer_Mode: we reuse the Apply_Range_Check + -- machinery instead of expanding a 'Valid attribute, since CodePeer + -- does not know how to handle expansion of 'Valid on floating point. + -- ??? Consider using the same expansion in normal mode. This should + -- work assuming division checks are also enabled (to prevent generation + -- of NaNs), except for e.g. unchecked conversions which might also + -- generate NaNs. + + if CodePeer_Mode then + declare + Typ : constant Entity_Id := Etype (N); + begin + -- Prevent recursion + + Set_Analyzed (N); + + Apply_Range_Check (N, Typ); + Analyze_And_Resolve (N, Typ); + return; + end; + end if; + -- Otherwise we replace the expression by -- do Tnn : constant ftype := expression; diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb index ada3adc76b8..ee6a1d978b4 100644 --- a/gcc/ada/sem_ch12.adb +++ b/gcc/ada/sem_ch12.adb @@ -1682,6 +1682,7 @@ package body Sem_Ch12 is if Present (Match) then if Nkind (Match) = N_Operator_Symbol then + -- If the name is a default, find its visible -- entity at the point of instantiation. -- 2.30.2