+2009-04-07 Robert Dewar <dewar@adacore.com>
+
+ * checks.adb (Determine_Range): Add Assume_Valid parameter
+
+ * checks.ads (Determine_Range): Add Assume_Valid parameter
+
+ * errout.adb (Error_Msg_NEL): Use Suppress_Loop_Warnings rather than
+ Is_Null_Loop to suppress warnings in a loop body.
+
+ * exp_ch4.adb:
+ (Rewrite_Comparison): Major rewrite to accomodate invalid values
+
+ * exp_ch5.adb:
+ (Expand_N_Loop_Statement): Delete loop known not to execute
+
+ * opt.ads:
+ (Assume_No_Invalid_Values): Now set to False, and as documented, this
+ fully enables the proper handling of invalid values.
+
+ * sem_attr.adb:
+ New calling sequence for Is_In_Range
+
+ * sem_ch5.adb:
+ (Analyze_Iteration_Scheme): Accomodate possible invalid values
+ in determining if a loop range is null.
+
+ * sem_eval.adb:
+ (Is_In_Range): Add Assume_Valid parameter
+ (Is_Out_Of_Range): Add Assume_Valid_Parameter
+ (Compile_Time_Compare): Major rewrite to accomodate invalid values and
+ also to do more accurate and complete range analysis, catching more
+ cases.
+
+ * sem_eval.ads:
+ (Is_In_Range): Add Assume_Valid parameter
+ (Is_Out_Of_Range): Add Assume_Valid_Parameter
+
+ * sem_util.adb:
+ New calling sequence for Is_In_Range
+
+ * sinfo.adb:
+ (Suppress_Loop_Warnings): New flag
+
+ * sinfo.ads:
+ (Is_Null_Loop): Update documentation
+ (Suppress_Loop_Warnings): New flag
+
+ * gnat_ugn.texi: Document -gnatB switch
+
2009-04-07 Arnaud Charlet <charlet@adacore.com>
* gnatvsn.ads: Bump version number.
Tlo := Expr_Value (Type_Low_Bound (Target_Type));
Thi := Expr_Value (Type_High_Bound (Target_Type));
- Determine_Range (Left_Opnd (N), LOK, Llo, Lhi);
- Determine_Range (Right_Opnd (N), ROK, Rlo, Rhi);
+ Determine_Range
+ (Left_Opnd (N), LOK, Llo, Lhi, Assume_Valid => True);
+ Determine_Range
+ (Right_Opnd (N), ROK, Rlo, Rhi, Assume_Valid => True);
if (LOK and ROK)
and then Tlo <= Llo and then Lhi <= Thi
and then Tlo <= Rlo and then Rhi <= Thi
then
- Determine_Range (N, VOK, Vlo, Vhi);
+ Determine_Range (N, VOK, Vlo, Vhi, Assume_Valid => True);
if VOK and then Tlo <= Vlo and then Vhi <= Thi then
Rewrite (Left_Opnd (N),
and then not Backend_Divide_Checks_On_Target
and then Check_Needed (Right, Division_Check)
then
- Determine_Range (Right, ROK, Rlo, Rhi);
+ Determine_Range (Right, ROK, Rlo, Rhi, Assume_Valid => True);
-- See if division by zero possible, and if so generate test. This
-- part of the test is not controlled by the -gnato switch.
if Nkind (N) = N_Op_Divide
and then Is_Signed_Integer_Type (Typ)
then
- Determine_Range (Left, LOK, Llo, Lhi);
+ Determine_Range (Left, LOK, Llo, Lhi, Assume_Valid => True);
LLB := Expr_Value (Type_Low_Bound (Base_Type (Typ)));
if ((not ROK) or else (Rlo <= (-1) and then (-1) <= Rhi))
-- Otherwise determine range of value
- Determine_Range (Expr, OK, Lo, Hi);
+ Determine_Range (Expr, OK, Lo, Hi, Assume_Valid => True);
if OK then
Assume_Valid => True,
Fixed_Int => Fixed_Int)
or else
- Is_In_Range (Expr, Target_Typ, Fixed_Int, Int_Real))
+ Is_In_Range (Expr, Target_Typ,
+ Assume_Valid => True,
+ Fixed_Int => Fixed_Int,
+ Int_Real => Int_Real))
then
return;
- elsif Is_Out_Of_Range (Expr, Target_Typ, Fixed_Int, Int_Real) then
+ elsif Is_Out_Of_Range (Expr, Target_Typ,
+ Assume_Valid => True,
+ Fixed_Int => Fixed_Int,
+ Int_Real => Int_Real)
+ then
Bad_Value;
return;
-- Determine size of below cache (power of 2 is more efficient!)
Determine_Range_Cache_N : array (Cache_Index) of Node_Id;
+ Determine_Range_Cache_V : array (Cache_Index) of Boolean;
Determine_Range_Cache_Lo : array (Cache_Index) of Uint;
Determine_Range_Cache_Hi : array (Cache_Index) of Uint;
-- The above arrays are used to implement a small direct cache for
-- on the way up the tree, a quadratic behavior can otherwise be
-- encountered in large expressions. The cache entry for node N is stored
-- in the (N mod Cache_Size) entry, and can be validated by checking the
- -- actual node value stored there.
+ -- actual node value stored there. The Range_Cache_V array records the
+ -- setting of Assume_Valid for the cache entry.
procedure Determine_Range
- (N : Node_Id;
- OK : out Boolean;
- Lo : out Uint;
- Hi : out Uint)
+ (N : Node_Id;
+ OK : out Boolean;
+ Lo : out Uint;
+ Hi : out Uint;
+ Assume_Valid : Boolean := False)
is
Typ : Entity_Id := Etype (N);
-- Type to use, may get reset to base type for possibly invalid entity
function OK_Operands return Boolean is
begin
- Determine_Range (Left_Opnd (N), OK1, Lo_Left, Hi_Left);
+ Determine_Range
+ (Left_Opnd (N), OK1, Lo_Left, Hi_Left, Assume_Valid);
if not OK1 then
return False;
end if;
- Determine_Range (Right_Opnd (N), OK1, Lo_Right, Hi_Right);
+ Determine_Range
+ (Right_Opnd (N), OK1, Lo_Right, Hi_Right, Assume_Valid);
return OK1;
end OK_Operands;
Cindex := Cache_Index (N mod Cache_Size);
- if Determine_Range_Cache_N (Cindex) = N then
+ if Determine_Range_Cache_N (Cindex) = N
+ and then
+ Determine_Range_Cache_V (Cindex) = Assume_Valid
+ then
Lo := Determine_Range_Cache_Lo (Cindex);
Hi := Determine_Range_Cache_Hi (Cindex);
return;
-- overflow situation, which is a separate check, we are talking here
-- only about the expression value).
- -- First step, change to use base type if the expression is an entity
- -- which we do not know is valid.
+ -- First step, change to use base type unless we know the value is valid
- if Is_Entity_Name (N)
- and then not Is_Known_Valid (Entity (N))
- and then not Assume_No_Invalid_Values
+ if (Is_Entity_Name (N) and then Is_Known_Valid (Entity (N)))
+ or else Assume_No_Invalid_Values
+ or else Assume_Valid
then
- Typ := Base_Type (Typ);
+ null;
+ else
+ Typ := Underlying_Type (Base_Type (Typ));
end if;
-- We use the actual bound unless it is dynamic, in which case use the
-- For unary plus, result is limited by range of operand
when N_Op_Plus =>
- Determine_Range (Right_Opnd (N), OK1, Lor, Hir);
+ Determine_Range
+ (Right_Opnd (N), OK1, Lor, Hir, Assume_Valid);
-- For unary minus, determine range of operand, and negate it
when N_Op_Minus =>
- Determine_Range (Right_Opnd (N), OK1, Lo_Right, Hi_Right);
+ Determine_Range
+ (Right_Opnd (N), OK1, Lo_Right, Hi_Right, Assume_Valid);
if OK1 then
Lor := -Hi_Right;
-- possible range of values of the attribute expression
when Name_Pos | Name_Val =>
- Determine_Range (First (Expressions (N)), OK1, Lor, Hir);
+ Determine_Range
+ (First (Expressions (N)), OK1, Lor, Hir, Assume_Valid);
-- For Length attribute, use the bounds of the corresponding
-- index type to refine the range.
end loop;
Determine_Range
- (Type_Low_Bound (Etype (Indx)), OK1, LL, LU);
+ (Type_Low_Bound (Etype (Indx)), OK1, LL, LU,
+ Assume_Valid);
if OK1 then
Determine_Range
- (Type_High_Bound (Etype (Indx)), OK1, UL, UU);
+ (Type_High_Bound (Etype (Indx)), OK1, UL, UU,
+ Assume_Valid);
if OK1 then
-- possible gap between the values of the bounds.
-- But of course, this value cannot be negative.
- Hir := UI_Max (Uint_0, UU - LL);
+ Hir := UI_Max (Uint_0, UU - LL + 1);
-- For constrained arrays, the minimum value for
-- Length is taken from the actual value of the
-- this subtype.
if Is_Constrained (Atyp) then
- Lor := UI_Max (Uint_0, UL - LU);
+ Lor := UI_Max (Uint_0, UL - LU + 1);
-- For an unconstrained array, the minimum value
-- for length is always zero.
-- refine the range using the converted value.
when N_Type_Conversion =>
- Determine_Range (Expression (N), OK1, Lor, Hir);
+ Determine_Range (Expression (N), OK1, Lor, Hir, Assume_Valid);
-- Nothing special to do for all other expression kinds
-- Set cache entry for future call and we are all done
Determine_Range_Cache_N (Cindex) := N;
+ Determine_Range_Cache_V (Cindex) := Assume_Valid;
Determine_Range_Cache_Lo (Cindex) := Lo;
Determine_Range_Cache_Hi (Cindex) := Hi;
return;
-- different.
if Nkind (N) /= N_Type_Conversion then
- Determine_Range (N, OK, Lo, Hi);
+ Determine_Range (N, OK, Lo, Hi, Assume_Valid => True);
-- Note in the test below that we assume that the range is not OK
-- if a bound of the range is equal to that of the type. That's not
begin
Opnd_Index := First_Index (Get_Actual_Subtype (Ck_Node));
Targ_Index := First_Index (T_Typ);
-
while Present (Opnd_Index) loop
-- If the index is a range, use its bounds. If it is an
end if;
if Nkind (Opnd_Range) = N_Range then
- if Is_In_Range
- (Low_Bound (Opnd_Range), Etype (Targ_Index))
+ if Is_In_Range
+ (Low_Bound (Opnd_Range), Etype (Targ_Index),
+ Assume_Valid => True)
and then
Is_In_Range
- (High_Bound (Opnd_Range), Etype (Targ_Index))
+ (High_Bound (Opnd_Range), Etype (Targ_Index),
+ Assume_Valid => True)
then
null;
null;
elsif Is_Out_Of_Range
- (Low_Bound (Opnd_Range), Etype (Targ_Index))
+ (Low_Bound (Opnd_Range), Etype (Targ_Index),
+ Assume_Valid => True)
or else
Is_Out_Of_Range
- (High_Bound (Opnd_Range), Etype (Targ_Index))
+ (High_Bound (Opnd_Range), Etype (Targ_Index),
+ Assume_Valid => True)
then
Add_Check
(Compile_Time_Constraint_Error
-- to make sure that the universal result is in range.
procedure Determine_Range
- (N : Node_Id;
- OK : out Boolean;
- Lo : out Uint;
- Hi : out Uint);
+ (N : Node_Id;
+ OK : out Boolean;
+ Lo : out Uint;
+ Hi : out Uint;
+ Assume_Valid : Boolean := False);
-- N is a node for a subexpression. If N is of a discrete type with no
-- error indications, and no other peculiarities (e.g. missing type
-- fields), then OK is True on return, and Lo and Hi are set to a
-- type, or some kind of error condition is detected, then OK is False on
-- exit, and Lo/Hi are set to No_Uint. Thus the significance of OK being
-- False on return is that no useful information is available on the range
- -- of the expression.
+ -- of the expression. Assume_Valid determines whether the processing is
+ -- allowed to assume that values are in range of their subtypes. If it is
+ -- set to True, then this assumption is valid, if False, then processing
+ -- is done using base types to allow invalid values.
procedure Install_Null_Excluding_Check (N : Node_Id);
-- Determines whether an access node requires a runtime access check and
return;
end if;
- -- Suppress if inside loop that is known to be null
+ -- Suppress if inside loop that is known to be null or is probably
+ -- null (case where loop executes only if invalid values present).
+ -- In either case warnings in the loop are likely to be junk.
declare
P : Node_Id;
begin
P := Parent (N);
while Present (P) loop
- if Nkind (P) = N_Loop_Statement and then Is_Null_Loop (P) then
+ if Nkind (P) = N_Loop_Statement
+ and then Suppress_Loop_Warnings (P)
+ then
return;
end if;
Lo_Orig : constant Node_Id := Original_Node (Lo);
Hi_Orig : constant Node_Id := Original_Node (Hi);
- Lcheck : constant Compare_Result :=
- Compile_Time_Compare (Lop, Lo, Assume_Valid => True);
- Ucheck : constant Compare_Result :=
- Compile_Time_Compare (Lop, Hi, Assume_Valid => True);
+ Lcheck : Compare_Result;
+ Ucheck : Compare_Result;
Warn1 : constant Boolean :=
Constant_Condition_Warnings
- and then Comes_From_Source (N);
+ and then Comes_From_Source (N)
+ and then not In_Instance;
-- This must be true for any of the optimization warnings, we
-- clearly want to give them only for source with the flag on.
+ -- We also skip these warnings in an instance since it may be
+ -- the case that different instantiations have different ranges.
Warn2 : constant Boolean :=
Warn1
-- If we have an explicit range, do a bit of optimization based
-- on range analysis (we may be able to kill one or both checks).
+ Lcheck := Compile_Time_Compare (Lop, Lo, Assume_Valid => False);
+ Ucheck := Compile_Time_Compare (Lop, Hi, Assume_Valid => False);
+
-- If either check is known to fail, replace result by False since
-- the other check does not matter. Preserve the static flag for
-- legality checks, because we are constant-folding beyond RM 4.9.
if Lcheck = LT or else Ucheck = GT then
- if Warn1 and then not In_Instance then
+ if Warn1 then
Error_Msg_N ("?range test optimized away", N);
Error_Msg_N ("\?value is known to be out of range", N);
end if;
-- since we know we are in range.
elsif Lcheck in Compare_GE and then Ucheck in Compare_LE then
- if Warn1 and then not In_Instance then
+ if Warn1 then
Error_Msg_N ("?range test optimized away", N);
Error_Msg_N ("\?value is known to be in range", N);
end if;
return;
end if;
+
+ -- We couldn't optimize away the range check, but there is one
+ -- more issue. If we are checking constant conditionals, then we
+ -- see if we can determine the outcome assuming everything is
+ -- valid, and if so give an appropriate warning.
+
+ if Warn1 and then not Assume_No_Invalid_Values then
+ Lcheck := Compile_Time_Compare (Lop, Lo, Assume_Valid => True);
+ Ucheck := Compile_Time_Compare (Lop, Hi, Assume_Valid => True);
+
+ -- Result is out of range for valid value
+
+ if Lcheck = LT or else Ucheck = GT then
+ Error_Msg_N
+ ("?value can only be in range if it is invalid", N);
+
+ -- Result is in range for valid value
+
+ elsif Lcheck in Compare_GE and then Ucheck in Compare_LE then
+ Error_Msg_N
+ ("?value can only be out of range if it is invalid", N);
+
+ -- Lower bound check succeeds if value is valid
+
+ elsif Warn2 and then Lcheck in Compare_GE then
+ Error_Msg_N
+ ("?lower bound check only fails if it is invalid", Lo);
+
+ -- Upper bound check succeeds if value is valid
+
+ elsif Warn2 and then Ucheck in Compare_LE then
+ Error_Msg_N
+ ("?upper bound check only fails for invalid values", Hi);
+ end if;
+ end if;
end;
-- For all other cases of an explicit range, nothing to be done
-- If type is scalar type, rewrite as x in t'first .. t'last.
-- This reason we do this is that the bounds may have the wrong
- -- type if they come from the original type definition.
+ -- type if they come from the original type definition. Also this
+ -- way we get all the processing above for an explicit range.
elsif Is_Scalar_Type (Typ) then
Rewrite (Rop,
------------------------
procedure Rewrite_Comparison (N : Node_Id) is
+ Warning_Generated : Boolean := False;
+ -- Set to True if first pass with Assume_Valid generates a warning in
+ -- which case we skip the second pass to avoid warning overloaded.
+
+ Result : Node_Id;
+ -- Set to Standard_True or Standard_False
+
begin
if Nkind (N) = N_Type_Conversion then
Rewrite_Comparison (Expression (N));
return;
end if;
- declare
- Typ : constant Entity_Id := Etype (N);
- Op1 : constant Node_Id := Left_Opnd (N);
- Op2 : constant Node_Id := Right_Opnd (N);
+ -- Now start looking at the comparison in detail. We potentially go
+ -- through this loop twice. The first time, Assume_Valid is set False
+ -- in the call to Compile_Time_Compare. If this call results in a
+ -- clear result of always True or Always False, that's decisive and
+ -- we are done. Otherwise we repeat the processing with Assume_Valid
+ -- set to True to generate additional warnings. We can stil that step
+ -- if Constant_Condition_Warnings is False.
+
+ for AV in False .. True loop
+ declare
+ Typ : constant Entity_Id := Etype (N);
+ Op1 : constant Node_Id := Left_Opnd (N);
+ Op2 : constant Node_Id := Right_Opnd (N);
- Res : constant Compare_Result :=
- Compile_Time_Compare (Op1, Op2, Assume_Valid => True);
- -- Res indicates if compare outcome can be compile time determined
+ Res : constant Compare_Result :=
+ Compile_Time_Compare (Op1, Op2, Assume_Valid => AV);
+ -- Res indicates if compare outcome can be compile time determined
- True_Result : Boolean;
- False_Result : Boolean;
+ True_Result : Boolean;
+ False_Result : Boolean;
- begin
- case N_Op_Compare (Nkind (N)) is
+ begin
+ case N_Op_Compare (Nkind (N)) is
when N_Op_Eq =>
True_Result := Res = EQ;
False_Result := Res = LT or else Res = GT or else Res = NE;
then
Error_Msg_N
("can never be greater than, could replace by ""'=""?", N);
+ Warning_Generated := True;
end if;
when N_Op_Gt =>
then
Error_Msg_N
("can never be less than, could replace by ""'=""?", N);
+ Warning_Generated := True;
end if;
when N_Op_Ne =>
True_Result := Res = NE or else Res = GT or else Res = LT;
False_Result := Res = EQ;
- end case;
+ end case;
- if True_Result then
- Rewrite (N,
- Convert_To (Typ,
- New_Occurrence_Of (Standard_True, Sloc (N))));
- Analyze_And_Resolve (N, Typ);
- Warn_On_Known_Condition (N);
+ -- If this is the first iteration, then we actually convert the
+ -- comparison into True or False, if the result is certain.
- elsif False_Result then
- Rewrite (N,
- Convert_To (Typ,
- New_Occurrence_Of (Standard_False, Sloc (N))));
- Analyze_And_Resolve (N, Typ);
- Warn_On_Known_Condition (N);
- end if;
- end;
+ if AV = False then
+ if True_Result or False_Result then
+ if True_Result then
+ Result := Standard_True;
+ else
+ Result := Standard_False;
+ end if;
+
+ Rewrite (N,
+ Convert_To (Typ,
+ New_Occurrence_Of (Result, Sloc (N))));
+ Analyze_And_Resolve (N, Typ);
+ Warn_On_Known_Condition (N);
+ return;
+ end if;
+
+ -- If this is the second iteration (AV = True), and the original
+ -- node comes from source and we are not in an instance, then
+ -- give a warning if we know result would be True or False. Note
+ -- we know Constant_Condition_Warnings is set if we get here.
+
+ elsif Comes_From_Source (Original_Node (N))
+ and then not In_Instance
+ then
+ if True_Result then
+ Error_Msg_N
+ ("condition can only be False if invalid values present?",
+ N);
+ elsif False_Result then
+ Error_Msg_N
+ ("condition can only be True if invalid values present?",
+ N);
+ end if;
+ end if;
+ end;
+
+ -- Skip second iteration if not warning on constant conditions or
+ -- if the first iteration already generated a warning of some kind
+ -- or if we are in any case assuming all values are valid (so that
+ -- the first iteration took care of the valid case).
+
+ exit when not Constant_Condition_Warnings;
+ exit when Warning_Generated;
+ exit when Assume_No_Invalid_Values;
+ end loop;
end Rewrite_Comparison;
----------------------------
-- Expand_N_Loop_Statement --
-----------------------------
- -- 1. Deal with while condition for C/Fortran boolean
- -- 2. Deal with loops with a non-standard enumeration type range
- -- 3. Deal with while loops where Condition_Actions is set
- -- 4. Insert polling call if required
+ -- 1. Remove null loop entirely
+ -- 2. Deal with while condition for C/Fortran boolean
+ -- 3. Deal with loops with a non-standard enumeration type range
+ -- 4. Deal with while loops where Condition_Actions is set
+ -- 5. Insert polling call if required
procedure Expand_N_Loop_Statement (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
Isc : constant Node_Id := Iteration_Scheme (N);
begin
+ -- Delete null loop
+
+ if Is_Null_Loop (N) then
+ Rewrite (N, Make_Null_Statement (Loc));
+ return;
+ end if;
+
+ -- Deal with condition for C/Fortran Boolean
+
if Present (Isc) then
Adjust_Condition (Condition (Isc));
end if;
+ -- Generate polling call
+
if Is_Non_Empty_List (Statements (N)) then
Generate_Poll_Call (First (Statements (N)));
end if;
@cindex @option{-gnatb} (@command{gcc})
Generate brief messages to @file{stderr} even if verbose mode set.
+@item -gnatB
+@cindex @option{-gnatB} (@command{gcc})
+Assume no invalid (bad) values except for 'Valid attribute use.
+
@item -gnatc
@cindex @option{-gnatc} (@command{gcc})
Check syntax and semantics only (no code generation attempted).
and subscripts on the left hand side (where memory corruption could
occur as a result of an invalid value).
+The @option{-gnatB} switch tells the compiler to assume that all
+values are valid (that is, within their declared subtype range)
+except in the context of a use of the Valid attribute. This means
+the compiler can generate more efficient code, since the range
+of values is better known at compile time.
+
The @option{-gnatV^@var{x}^^} switch allows more control over the validity
checking mode.
@ifclear vms
-- GNAT
-- Enable assertions made using pragma Assert
- Assume_No_Invalid_Values : Boolean := True;
- -- ??? true for now, enable by setting to false later
+ Assume_No_Invalid_Values : Boolean := False;
-- GNAT
-- Normally, in accordance with (RM 13.9.1 (9-11)) the front end assumes
-- that values could have invalid representations, unless it can clearly
-- prove that the values are valid. If this switch is set (by -gnatB or by
-- pragma Assume_No_Invalid_Values (Off)), then the compiler assumes values
- -- are valid and in range of their representations.
+ -- are valid and in range of their representations. This feature is now
+ -- fully enabled in the compiler.
Back_Annotate_Rep_Info : Boolean := False;
-- GNAT
-- Check that result is in bounds of the type if it is static
- if Is_In_Range (N, T) then
+ if Is_In_Range (N, T, Assume_Valid => False) then
null;
elsif Is_Out_Of_Range (N, T) then
L : constant Node_Id := Low_Bound (DS);
H : constant Node_Id := High_Bound (DS);
- Llo : Uint;
- Lhi : Uint;
- LOK : Boolean;
- Hlo : Uint;
- Hhi : Uint;
- HOK : Boolean;
-
- pragma Warnings (Off, Hlo);
-
begin
- Determine_Range (L, LOK, Llo, Lhi);
- Determine_Range (H, HOK, Hlo, Hhi);
-
-- If range of loop is null, issue warning
- if (LOK and HOK) and then Llo > Hhi then
-
+ if Compile_Time_Compare
+ (L, H, Assume_Valid => True) = GT
+ then
-- Suppress the warning if inside a generic
-- template or instance, since in practice
-- they tend to be dubious in these cases since
if not Inside_A_Generic
and then not In_Instance
then
- Error_Msg_N
- ("?loop range is null, loop will not execute",
- DS);
+ -- Specialize msg if invalid values could make
+ -- the loop non-null after all.
+
+ if Compile_Time_Compare
+ (L, H, Assume_Valid => False) = GT
+ then
+ Error_Msg_N
+ ("?loop range is null, "
+ & "loop will not execute",
+ DS);
+
+ -- Since we know the range of the loop is
+ -- null, set the appropriate flag to remove
+ -- the loop entirely during expansion.
+
+ Set_Is_Null_Loop (Parent (N));
+
+ -- Here is where the loop could execute because
+ -- of invalid values, so issue appropriate
+ -- message and in this case we do not set the
+ -- Is_Null_Loop flag since the loop may execute.
+
+ else
+ Error_Msg_N
+ ("?loop range may be null, "
+ & "loop may not execute",
+ DS);
+ Error_Msg_N
+ ("?can only execute if invalid values "
+ & "are present",
+ DS);
+ end if;
end if;
- -- Since we know the range of the loop is null,
- -- set the appropriate flag to suppress any
- -- warnings that would otherwise be issued in
- -- the body of the loop that will not execute.
- -- We do this even in the generic case, since
- -- if it is dubious to warn on the null loop
- -- itself, it is certainly dubious to warn for
- -- conditions that occur inside it!
+ -- In either case, suppress warnings in the body of
+ -- the loop, since it is likely that these warnings
+ -- will be inappropriate if the loop never actually
+ -- executes, which is unlikely.
- Set_Is_Null_Loop (Parent (N));
+ Set_Suppress_Loop_Warnings (Parent (N));
-- The other case for a warning is a reverse loop
-- where the upper bound is the integer literal
elsif Reverse_Present (LP)
and then Nkind (Original_Node (H)) =
N_Integer_Literal
- and then (Intval (H) = Uint_0
+ and then (Intval (Original_Node (H)) = Uint_0
or else
- Intval (H) = Uint_1)
- and then Lhi > Hhi
+ Intval (Original_Node (H)) = Uint_1)
then
Error_Msg_N ("?loop range may be null", DS);
Error_Msg_N ("\?bounds may be wrong way round", DS);
if not Is_Static_Expression (N) then
if Is_Floating_Point_Type (T)
- and then Is_Out_Of_Range (N, Base_Type (T))
+ and then Is_Out_Of_Range (N, Base_Type (T), Assume_Valid => True)
then
Error_Msg_N
("?float value out of range, infinity will be generated", N);
-- number, so as not to lose case where value overflows in the
-- least significant bit or less. See B490001.
- if Is_Out_Of_Range (N, Base_Type (T)) then
+ if Is_Out_Of_Range (N, Base_Type (T), Assume_Valid => True) then
Out_Of_Range (N);
return;
end if;
-- Check out of range of base type
- elsif Is_Out_Of_Range (N, Base_Type (T)) then
+ elsif Is_Out_Of_Range (N, Base_Type (T), Assume_Valid => True) then
Out_Of_Range (N);
- -- Give warning if outside subtype (where one or both of the
- -- bounds of the subtype is static). This warning is omitted
- -- if the expression appears in a range that could be null
- -- (warnings are handled elsewhere for this case).
+ -- Give warning if outside subtype (where one or both of the bounds of
+ -- the subtype is static). This warning is omitted if the expression
+ -- appears in a range that could be null (warnings are handled elsewhere
+ -- for this case).
elsif T /= Base_Type (T)
and then Nkind (Parent (N)) /= N_Range
then
- if Is_In_Range (N, T) then
+ if Is_In_Range (N, T, Assume_Valid => True) then
null;
- elsif Is_Out_Of_Range (N, T) then
+ elsif Is_Out_Of_Range (N, T, Assume_Valid => True) then
Apply_Compile_Time_Constraint_Error
(N, "value not in range of}?", CE_Range_Check_Failed);
begin
-- Values are the same if they refer to the same entity and the
- -- entity is a constant object (E_Constant). This does not however
- -- apply to Float types, since we may have two NaN values and they
- -- should never compare equal.
+ -- entity is non-volatile. This does not however apply to Float
+ -- types, since we may have two NaN values and they should never
+ -- compare equal.
if Nkind_In (Lf, N_Identifier, N_Expanded_Name)
and then Nkind_In (Rf, N_Identifier, N_Expanded_Name)
and then Entity (Lf) = Entity (Rf)
and then Present (Entity (Lf))
and then not Is_Floating_Point_Type (Etype (L))
- and then Is_Constant_Object (Entity (Lf))
+ and then not Is_Volatile_Reference (L)
+ and then not Is_Volatile_Reference (R)
then
return True;
-- not known to have valid representations. This takes care of
-- properly dealing with invalid representations.
- if not Assume_Valid then
+ if not Assume_Valid and then not Assume_No_Invalid_Values then
if Is_Entity_Name (L) and then not Is_Known_Valid (Entity (L)) then
Ltyp := Base_Type (Ltyp);
end if;
end if;
end if;
+ -- Try range analysis on variables and see if ranges are disjoint
+
+ declare
+ LOK, ROK : Boolean;
+ LLo, LHi : Uint;
+ RLo, RHi : Uint;
+
+ begin
+ Determine_Range (L, LOK, LLo, LHi, Assume_Valid);
+ Determine_Range (R, ROK, RLo, RHi, Assume_Valid);
+
+ if LOK and ROK then
+ if LHi < RLo then
+ return LT;
+
+ elsif RHi < LLo then
+ return GT;
+
+ elsif LLo = LHi
+ and then RLo = RHi
+ and then LLo = RLo
+ then
+ return EQ;
+
+ elsif LHi = RLo then
+ return LE;
+
+ elsif RHi = LLo then
+ return GE;
+ end if;
+ end if;
+ end;
+
-- Here is where we check for comparisons against maximum bounds of
-- types, where we know that no value can be outside the bounds of
-- the subtype. Note that this routine is allowed to assume that all
-- Modular integer literals must be in their base range
if Is_Modular_Integer_Type (T)
- and then Is_Out_Of_Range (N, Base_Type (T))
+ and then Is_Out_Of_Range (N, Base_Type (T), Assume_Valid => True)
then
Out_Of_Range (N);
end if;
Set_Is_Static_Expression (N, Stat);
- if Is_Out_Of_Range (N, Etype (N)) then
+ if Is_Out_Of_Range (N, Etype (N), Assume_Valid => True) then
Out_Of_Range (N);
end if;
end Eval_Qualified_Expression;
Fold_Uint (N, Expr_Value (Operand), Stat);
end if;
- if Is_Out_Of_Range (N, Etype (N)) then
+ if Is_Out_Of_Range (N, Etype (N), Assume_Valid => True) then
Out_Of_Range (N);
end if;
-----------------
function Is_In_Range
- (N : Node_Id;
- Typ : Entity_Id;
- Fixed_Int : Boolean := False;
- Int_Real : Boolean := False) return Boolean
+ (N : Node_Id;
+ Typ : Entity_Id;
+ Assume_Valid : Boolean := False;
+ Fixed_Int : Boolean := False;
+ Int_Real : Boolean := False) return Boolean
is
Val : Uint;
Valr : Ureal;
elsif not Compile_Time_Known_Value (N) then
return False;
+ -- General processing with a known compile time value
+
else
declare
- Lo : constant Node_Id := Type_Low_Bound (Typ);
- Hi : constant Node_Id := Type_High_Bound (Typ);
- LB_Known : constant Boolean := Compile_Time_Known_Value (Lo);
- UB_Known : constant Boolean := Compile_Time_Known_Value (Hi);
+ Lo : Node_Id;
+ Hi : Node_Id;
+ LB_Known : Boolean;
+ UB_Known : Boolean;
+ Typt : Entity_Id;
begin
+ if Assume_Valid
+ or else Assume_No_Invalid_Values
+ or else (Is_Entity_Name (N)
+ and then Is_Known_Valid (Entity (N)))
+ then
+ Typt := Typ;
+ else
+ Typt := Underlying_Type (Base_Type (Typ));
+ end if;
+
+ Lo := Type_Low_Bound (Typt);
+ Hi := Type_High_Bound (Typt);
+
+ LB_Known := Compile_Time_Known_Value (Lo);
+ UB_Known := Compile_Time_Known_Value (Hi);
+
-- Fixed point types should be considered as such only in
-- flag Fixed_Int is set to False.
- if Is_Floating_Point_Type (Typ)
- or else (Is_Fixed_Point_Type (Typ) and then not Fixed_Int)
+ if Is_Floating_Point_Type (Typt)
+ or else (Is_Fixed_Point_Type (Typt) and then not Fixed_Int)
or else Int_Real
then
Valr := Expr_Value_R (N);
function Is_Out_Of_Range
(N : Node_Id;
Typ : Entity_Id;
+ Assume_Valid : Boolean := False;
Fixed_Int : Boolean := False;
Int_Real : Boolean := False) return Boolean
is
else
declare
- Lo : constant Node_Id := Type_Low_Bound (Typ);
- Hi : constant Node_Id := Type_High_Bound (Typ);
- LB_Known : constant Boolean := Compile_Time_Known_Value (Lo);
- UB_Known : constant Boolean := Compile_Time_Known_Value (Hi);
+ Lo : Node_Id;
+ Hi : Node_Id;
+ LB_Known : Boolean;
+ UB_Known : Boolean;
+ Typt : Entity_Id;
begin
+ -- Go to base type if we could have invalid values
+
+ if Assume_Valid
+ or else Assume_No_Invalid_Values
+ or else (Is_Entity_Name (N)
+ and then Is_Known_Valid (Entity (N)))
+ then
+ Typt := Typ;
+ else
+ Typt := Underlying_Type (Base_Type (Typ));
+ end if;
+
+ Lo := Type_Low_Bound (Typt);
+ Hi := Type_High_Bound (Typt);
+
+ LB_Known := Compile_Time_Known_Value (Lo);
+ UB_Known := Compile_Time_Known_Value (Hi);
+
-- Real types (note that fixed-point types are not treated
-- as being of a real type if the flag Fixed_Int is set,
-- since in that case they are regarded as integer types).
- if Is_Floating_Point_Type (Typ)
- or else (Is_Fixed_Point_Type (Typ) and then not Fixed_Int)
+ if Is_Floating_Point_Type (Typt)
+ or else (Is_Fixed_Point_Type (Typt) and then not Fixed_Int)
or else Int_Real
then
Valr := Expr_Value_R (N);
-- known at compile time but not static, then the result is not static.
function Is_In_Range
- (N : Node_Id;
- Typ : Entity_Id;
- Fixed_Int : Boolean := False;
- Int_Real : Boolean := False) return Boolean;
+ (N : Node_Id;
+ Typ : Entity_Id;
+ Assume_Valid : Boolean := False;
+ Fixed_Int : Boolean := False;
+ Int_Real : Boolean := False) return Boolean;
-- Returns True if it can be guaranteed at compile time that expression is
-- known to be in range of the subtype Typ. If the values of N or of either
-- bounds of Type are unknown at compile time, False will always be
-- value (i.e. the underlying integer value is used). In this case we use
-- the corresponding integer value, both for the bounds of Typ, and for the
-- value of the expression N. If Typ is a discrete type and Fixed_Int as
- -- well as Int_Real are false, integer values are used throughout.
+ -- well as Int_Real are false, integer values are used throughout. The
+ -- Assume_Valid parameter determines whether values are to be assumed to
+ -- be valid (True), or invalid values can occur (False).
function Is_Out_Of_Range
- (N : Node_Id;
- Typ : Entity_Id;
- Fixed_Int : Boolean := False;
- Int_Real : Boolean := False) return Boolean;
+ (N : Node_Id;
+ Typ : Entity_Id;
+ Assume_Valid : Boolean := False;
+ Fixed_Int : Boolean := False;
+ Int_Real : Boolean := False) return Boolean;
-- Returns True if it can be guaranteed at compile time that expression is
-- known to be out of range of the subtype Typ. True is returned if Typ is
-- a scalar type, at least one of whose bounds is known at compile time,
-- outside a compile_time known bound of Typ. A result of False does not
-- mean that the expression is in range, but rather merely that it cannot
-- be determined at compile time that it is out of range. Flags Int_Real
- -- and Fixed_Int are used as in routine Is_In_Range above.
+ -- and Fixed_Int are used as in routine Is_In_Range above. The Assume_Valid
+ -- parameter determines whether values are to be assumed to be valid
+ -- (True), or invalid values can occur (False).
function In_Subrange_Of
(T1 : Entity_Id;
elsif Is_Entity_Name (Choice)
and then Is_Type (Entity (Choice))
then
- exit Search when Is_In_Range (Expr, Etype (Choice));
+ exit Search when Is_In_Range (Expr, Etype (Choice),
+ Assume_Valid => False);
-- Choice is a subtype indication
return Node5 (N);
end Subtype_Indication;
+ function Suppress_Loop_Warnings
+ (N : Node_Id) return Boolean is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Loop_Statement);
+ return Flag17 (N);
+ end Suppress_Loop_Warnings;
+
function Subtype_Mark
(N : Node_Id) return Node_Id is
begin
Set_List2_With_Parent (N, Val);
end Set_Subtype_Marks;
+ procedure Set_Suppress_Loop_Warnings
+ (N : Node_Id; Val : Boolean := True) is
+ begin
+ pragma Assert (False
+ or else NT (N).Nkind = N_Loop_Statement);
+ Set_Flag17 (N, Val);
+ end Set_Suppress_Loop_Warnings;
+
procedure Set_Synchronized_Present
(N : Node_Id; Val : Boolean := True) is
begin
-- Is_Null_Loop (Flag16-Sem)
-- This flag is set in an N_Loop_Statement node if the corresponding loop
- -- can be determined to be null at compile time. This is used to suppress
- -- any warnings that would otherwise be issued inside the loop since they
- -- are probably not useful.
+ -- can be determined to be null at compile time. This is used to remove
+ -- the loop entirely at expansion time.
-- Is_Overloaded (Flag5-Sem)
-- A flag present in all expression nodes. Used temporarily during
-- value of a type whose size is not known at compile time on the
-- secondary stack.
+ -- Suppress_Loop_Warnings (Flag17-Sem)
+ -- Used in N_Loop_Statement node to indicate that warnings within the
+ -- body of the loop should be suppressed. This is set when the range
+ -- of a FOR loop is known to be null, or is probably null (loop would
+ -- only execute if invalid values are present).
+
-- Target_Type (Node2-Sem)
-- Used in an N_Validate_Unchecked_Conversion node to point to the target
-- type entity for the unchecked conversion instantiation which gigi must
-- End_Label (Node4)
-- Has_Created_Identifier (Flag15)
-- Is_Null_Loop (Flag16)
+ -- Suppress_Loop_Warnings (Flag17)
--------------------------
-- 5.5 Iteration Scheme --
function Subtype_Marks
(N : Node_Id) return List_Id; -- List2
+ function Suppress_Loop_Warnings
+ (N : Node_Id) return Boolean; -- Flag17
+
function Synchronized_Present
(N : Node_Id) return Boolean; -- Flag7
procedure Set_Subtype_Marks
(N : Node_Id; Val : List_Id); -- List2
+ procedure Set_Suppress_Loop_Warnings
+ (N : Node_Id; Val : Boolean := True); -- Flag17
+
procedure Set_Synchronized_Present
(N : Node_Id; Val : Boolean := True); -- Flag7
pragma Inline (Subtype_Indication);
pragma Inline (Subtype_Mark);
pragma Inline (Subtype_Marks);
+ pragma Inline (Suppress_Loop_Warnings);
pragma Inline (Synchronized_Present);
pragma Inline (Tagged_Present);
pragma Inline (Target_Type);
pragma Inline (Set_Subtype_Indication);
pragma Inline (Set_Subtype_Mark);
pragma Inline (Set_Subtype_Marks);
+ pragma Inline (Set_Suppress_Loop_Warnings);
pragma Inline (Set_Synchronized_Present);
pragma Inline (Set_Tagged_Present);
pragma Inline (Set_Target_Type);
projects / thirdparty / gcc.git / commitdiff
