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;
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
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;
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;
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
-- 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
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;
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;
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
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
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
(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);
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.
-- 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
projects / platform / upstream / gcc.git / commitdiff