diff options
Diffstat (limited to 'gcc/ada')
| -rw-r--r-- | gcc/ada/ChangeLog | 5 | ||||
| -rw-r--r-- | gcc/ada/checks.adb | 93 |
2 files changed, 70 insertions, 28 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 520a806..3d759ce 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,8 @@ +2009-07-13 Eric Botcazou <ebotcazou@adacore.com> + + * checks.adb (Selected_Range_Checks): Do not consider that a non-static + integer bound forces the check if it is compared to its subtype range. + 2009-07-13 Robert Dewar <dewar@adacore.com> * prj.ads, prj-dect.adb, prj-err.ads, prj-err.adb, prj-nmsc.adb, diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb index d086161..015256e 100644 --- a/gcc/ada/checks.adb +++ b/gcc/ada/checks.adb @@ -6644,27 +6644,65 @@ package body Checks is declare T_LB : constant Node_Id := Type_Low_Bound (T_Typ); T_HB : constant Node_Id := Type_High_Bound (T_Typ); - LB : constant Node_Id := Low_Bound (Ck_Node); - HB : constant Node_Id := High_Bound (Ck_Node); - Null_Range : Boolean; + Known_T_LB : constant Boolean := Compile_Time_Known_Value (T_LB); + Known_T_HB : constant Boolean := Compile_Time_Known_Value (T_HB); + LB : Node_Id := Low_Bound (Ck_Node); + HB : Node_Id := High_Bound (Ck_Node); + Known_LB : Boolean; + Known_HB : Boolean; + + Null_Range : Boolean; Out_Of_Range_L : Boolean; Out_Of_Range_H : Boolean; begin - -- Check for case where everything is static and we can - -- do the check at compile time. This is skipped if we - -- have an access type, since the access value may be null. - - -- ??? This code can be improved since you only need to know - -- that the two respective bounds (LB & T_LB or HB & T_HB) - -- are known at compile time to emit pertinent messages. - - if Compile_Time_Known_Value (LB) - and then Compile_Time_Known_Value (HB) - and then Compile_Time_Known_Value (T_LB) - and then Compile_Time_Known_Value (T_HB) - and then not Do_Access + -- Compute what is known at compile time + + if Known_T_LB and Known_T_HB then + if Compile_Time_Known_Value (LB) then + Known_LB := True; + + -- There's no point in checking that a bound is within its + -- own range so pretend that it is known in this case. First + -- deal with low bound. + + elsif Ekind (Etype (LB)) = E_Signed_Integer_Subtype + and then Scalar_Range (Etype (LB)) = Scalar_Range (T_Typ) + then + LB := T_LB; + Known_LB := True; + + else + Known_LB := False; + end if; + + -- Likewise for the high bound + + if Compile_Time_Known_Value (HB) then + Known_HB := True; + + elsif Ekind (Etype (HB)) = E_Signed_Integer_Subtype + and then Scalar_Range (Etype (HB)) = Scalar_Range (T_Typ) + then + HB := T_HB; + Known_HB := True; + + else + Known_HB := False; + end if; + end if; + + -- Check for case where everything is static and we can do the + -- check at compile time. This is skipped if we have an access + -- type, since the access value may be null. + + -- ??? This code can be improved since you only need to know that + -- the two respective bounds (LB & T_LB or HB & T_HB) are known at + -- compile time to emit pertinent messages. + + if Known_T_LB and Known_T_HB and Known_LB and Known_HB + and not Do_Access then -- Floating-point case @@ -6672,12 +6710,12 @@ package body Checks is Null_Range := Expr_Value_R (HB) < Expr_Value_R (LB); Out_Of_Range_L := (Expr_Value_R (LB) < Expr_Value_R (T_LB)) - or else + or else (Expr_Value_R (LB) > Expr_Value_R (T_HB)); Out_Of_Range_H := (Expr_Value_R (HB) > Expr_Value_R (T_HB)) - or else + or else (Expr_Value_R (HB) < Expr_Value_R (T_LB)); -- Fixed or discrete type case @@ -6686,12 +6724,12 @@ package body Checks is Null_Range := Expr_Value (HB) < Expr_Value (LB); Out_Of_Range_L := (Expr_Value (LB) < Expr_Value (T_LB)) - or else + or else (Expr_Value (LB) > Expr_Value (T_HB)); Out_Of_Range_H := (Expr_Value (HB) > Expr_Value (T_HB)) - or else + or else (Expr_Value (HB) < Expr_Value (T_LB)); end if; @@ -6725,7 +6763,6 @@ package body Checks is "static range out of bounds of}?", T_Typ)); end if; end if; - end if; else @@ -6827,15 +6864,17 @@ package body Checks is or else (Expr_Value_R (Ck_Node) > Expr_Value_R (UB)); - else -- fixed or discrete type + -- Fixed or discrete type + + else Out_Of_Range := Expr_Value (Ck_Node) < Expr_Value (LB) or else Expr_Value (Ck_Node) > Expr_Value (UB); end if; - -- Bounds of the type are static and the literal is - -- out of range so make a warning message. + -- Bounds of the type are static and the literal is out of + -- range so output a warning message. if Out_Of_Range then if No (Warn_Node) then @@ -6936,7 +6975,6 @@ package body Checks is Next (L_Index); Next (R_Index); - end if; end loop; end; @@ -6963,7 +7001,6 @@ package body Checks is (Cond, Range_N_Cond (Ck_Node, T_Typ, Indx)); end loop; end; - end if; else @@ -7059,8 +7096,8 @@ package body Checks is Add_Check (Make_Raise_Constraint_Error (Loc, - Condition => Cond, - Reason => CE_Range_Check_Failed)); + Condition => Cond, + Reason => CE_Range_Check_Failed)); end if; return Ret_Result; |