From: Arnaud Charlet Date: Mon, 4 Jan 2021 11:43:09 +0000 (-0500) Subject: [Ada] Address some ??? comments in checks.adb X-Git-Tag: upstream/12.2.0~8288 X-Git-Url: http://review.tizen.org/git/?a=commitdiff_plain;h=869a06d981893b769829975bf27d8a3069cacf47;p=platform%2Fupstream%2Fgcc.git [Ada] Address some ??? comments in checks.adb gcc/ada/ * checks.adb (Append_Range_Checks, Apply_Selected_Length_Checks, Determine_Range, Insert_Range_Checks, Install_Null_Excluding_Check, Selected_Length_Checks, Selected_Range_Checks): Address ??? comments and code cleanups. --- diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb index d20ede9..a4ad4e6 100644 --- a/gcc/ada/checks.adb +++ b/gcc/ada/checks.adb @@ -500,9 +500,9 @@ package body Checks is not Range_Checks_Suppressed (Suppress_Typ); begin - -- For now we just return if Checks_On is false, however this should be + -- For now we just return if Checks_On is false, however this could be -- enhanced to check for an always True value in the condition and to - -- generate a compilation warning??? + -- generate a compilation warning. if not Checks_On then return; @@ -3459,9 +3459,6 @@ package body Checks is end if; end if; - -- If the item is a conditional raise of constraint error, then have - -- a look at what check is being performed and ??? - if Nkind (R_Cno) = N_Raise_Constraint_Error and then Present (Condition (R_Cno)) then @@ -5395,8 +5392,7 @@ package body Checks is OK1 := True; end; - -- No special handling for other attributes - -- Probably more opportunities exist here??? + -- No special handling for other attributes for now when others => OK1 := False; @@ -7986,7 +7982,7 @@ package body Checks is begin -- For now we just return if Checks_On is false, however this should be -- enhanced to check for an always True value in the condition and to - -- generate a compilation warning??? + -- generate a compilation warning. if not Expander_Active or not Checks_On then return; @@ -8515,22 +8511,6 @@ package body Checks is return; end if; - -- No check needed for the Get_Current_Excep.all.all idiom generated by - -- the expander within exception handlers, since we know that the value - -- can never be null. - - -- Is this really the right way to do this? Normally we generate such - -- code in the expander with checks off, and that's how we suppress this - -- kind of junk check ??? - - if Nkind (N) = N_Function_Call - and then Nkind (Name (N)) = N_Explicit_Dereference - and then Nkind (Prefix (Name (N))) = N_Identifier - and then Is_RTE (Entity (Prefix (Name (N))), RE_Get_Current_Excep) - then - return; - end if; - -- In GNATprove mode, we do not apply the check if GNATprove_Mode then @@ -9821,8 +9801,10 @@ package body Checks is -- Adds the action given to Ret_Result if N is non-Empty function Get_E_Length (E : Entity_Id; Indx : Nat) return Node_Id; + -- Return E'Length (Indx) + function Get_N_Length (N : Node_Id; Indx : Nat) return Node_Id; - -- Comments required ??? + -- Return N'Length (Indx) function Same_Bounds (L : Node_Id; R : Node_Id) return Boolean; -- True for equal literals and for nodes that denote the same constant @@ -9858,8 +9840,10 @@ package body Checks is begin if Present (N) then - -- For now, ignore attempt to place more than two checks ??? - -- This is really worrisome, are we really discarding checks ??? + -- We do not support inserting more than 2 checks on the same + -- node. If this happens it means we have already added an + -- unconditional raise, so we can skip the other checks safely + -- since N will always raise an exception. if Num_Checks = 2 then return; @@ -10429,7 +10413,10 @@ package body Checks is begin if Present (N) then - -- For now, ignore attempt to place more than 2 checks ??? + -- We do not support inserting more than 2 checks on the same + -- node. If this happens it means we have already added an + -- unconditional raise, so we can skip the other checks safely + -- since N will always raise an exception. if Num_Checks = 2 then return; @@ -10659,6 +10646,13 @@ package body Checks is Get_E_First_Or_Last (Loc, Typ, Indx, Name_Last))); end Range_N_Cond; + function "<" (Left, Right : Node_Id) return Boolean + is (if Is_Floating_Point_Type (S_Typ) + then Expr_Value_R (Left) < Expr_Value_R (Right) + else Expr_Value (Left) < Expr_Value (Right)); + -- Convenience comparison function of integer or floating point + -- values. + -- Start of processing for Selected_Range_Checks begin @@ -10729,14 +10723,14 @@ package body Checks is 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 (Expr); - HB : Node_Id := High_Bound (Expr); - Known_LB : Boolean := False; - Known_HB : Boolean := False; + LB : Node_Id := Low_Bound (Expr); + HB : Node_Id := High_Bound (Expr); + Known_LB : Boolean := False; + Known_HB : Boolean := False; + Check_Added : Boolean := False; - Null_Range : Boolean; - Out_Of_Range_L : Boolean; - Out_Of_Range_H : Boolean; + Out_Of_Range_L : Boolean := False; + Out_Of_Range_H : Boolean := False; begin -- Compute what is known at compile time @@ -10769,61 +10763,46 @@ package body Checks is 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 - - if Is_Floating_Point_Type (S_Typ) then - 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 - (Expr_Value_R (LB) > Expr_Value_R (T_HB)); - - Out_Of_Range_H := - (Expr_Value_R (HB) > Expr_Value_R (T_HB)) - or else - (Expr_Value_R (HB) < Expr_Value_R (T_LB)); - - -- Fixed or discrete type case + -- Check for the simple cases where we can do the check at + -- compile time. This is skipped if we have an access type, since + -- the access value may be null. - else - Null_Range := Expr_Value (HB) < Expr_Value (LB); - Out_Of_Range_L := - (Expr_Value (LB) < Expr_Value (T_LB)) - or else - (Expr_Value (LB) > Expr_Value (T_HB)); + if not Do_Access and then Not_Null_Range (LB, HB) then + if Known_LB then + if Known_T_LB then + Out_Of_Range_L := LB < T_LB; + end if; - Out_Of_Range_H := - (Expr_Value (HB) > Expr_Value (T_HB)) - or else - (Expr_Value (HB) < Expr_Value (T_LB)); - end if; + if Known_T_HB and not Out_Of_Range_L then + Out_Of_Range_L := T_HB < LB; + end if; - if not Null_Range then if Out_Of_Range_L then if No (Warn_Node) then Add_Check (Compile_Time_Constraint_Error (Low_Bound (Expr), "static value out of range of}??", T_Typ)); + Check_Added := True; else Add_Check (Compile_Time_Constraint_Error (Wnode, "static range out of bounds of}??", T_Typ)); + Check_Added := True; end if; end if; + end if; + + if Known_HB then + if Known_T_HB then + Out_Of_Range_H := T_HB < HB; + end if; + + if Known_T_LB and not Out_Of_Range_H then + Out_Of_Range_H := HB < T_LB; + end if; if Out_Of_Range_H then if No (Warn_Node) then @@ -10831,17 +10810,29 @@ package body Checks is (Compile_Time_Constraint_Error (High_Bound (Expr), "static value out of range of}??", T_Typ)); + Check_Added := True; else Add_Check (Compile_Time_Constraint_Error (Wnode, "static range out of bounds of}??", T_Typ)); + Check_Added := True; end if; end if; end if; + end if; - else + -- Check for the case where not everything is static + + if not Check_Added + and then + (Do_Access + or else not Known_T_LB + or else not Known_LB + or else not Known_T_HB + or else not Known_HB) + then declare LB : Node_Id := Low_Bound (Expr); HB : Node_Id := High_Bound (Expr); @@ -10908,8 +10899,8 @@ package body Checks is elsif Is_Scalar_Type (S_Typ) then -- This somewhat duplicates what Apply_Scalar_Range_Check does, - -- except the above simply sets a flag in the node and lets - -- gigi generate the check base on the Etype of the expression. + -- except the above simply sets a flag in the node and lets the + -- check be generated based on the Etype of the expression. -- Sometimes, however we want to do a dynamic check against an -- arbitrary target type, so we do that here. @@ -10923,56 +10914,24 @@ package body Checks is -- expression. As usual, skip this for access types elsif Compile_Time_Known_Value (Expr) and then not Do_Access then - declare - LB : constant Node_Id := Type_Low_Bound (T_Typ); - UB : constant Node_Id := Type_High_Bound (T_Typ); - - Out_Of_Range : Boolean; - Static_Bounds : constant Boolean := - Compile_Time_Known_Value (LB) - and Compile_Time_Known_Value (UB); - - begin - -- Following range tests should use Sem_Eval routine ??? - - if Static_Bounds then - if Is_Floating_Point_Type (S_Typ) then - Out_Of_Range := - (Expr_Value_R (Expr) < Expr_Value_R (LB)) - or else - (Expr_Value_R (Expr) > Expr_Value_R (UB)); - - -- Fixed or discrete type - - else - Out_Of_Range := - Expr_Value (Expr) < Expr_Value (LB) - or else - Expr_Value (Expr) > Expr_Value (UB); - end if; - - -- Bounds of the type are static and the literal is out of - -- range so output a warning message. + if Is_Out_Of_Range (Expr, T_Typ) then - if Out_Of_Range then - if No (Warn_Node) then - Add_Check - (Compile_Time_Constraint_Error - (Expr, - "static value out of range of}??", T_Typ)); + -- Bounds of the type are static and the literal is out of + -- range so output a warning message. - else - Add_Check - (Compile_Time_Constraint_Error - (Wnode, - "static value out of range of}??", T_Typ)); - end if; - end if; + if No (Warn_Node) then + Add_Check + (Compile_Time_Constraint_Error + (Expr, "static value out of range of}??", T_Typ)); else - Cond := Discrete_Expr_Cond (Expr, T_Typ); + Add_Check + (Compile_Time_Constraint_Error + (Wnode, "static value out of range of}??", T_Typ)); end if; - end; + else + Cond := Discrete_Expr_Cond (Expr, T_Typ); + end if; -- Here for the case of a non-static expression, we need a runtime -- check unless the source type range is guaranteed to be in the