procedure Apply_Arithmetic_Overflow_Check (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
- Typ : Entity_Id := Etype (N);
- Rtyp : Entity_Id := Root_Type (Typ);
+ Typ : constant Entity_Id := Etype (N);
+ Rtyp : constant Entity_Id := Root_Type (Typ);
begin
-- An interesting special case. If the arithmetic operation appears as
Subtype_Mark => New_Occurrence_Of (Target_Type, Loc),
Expression => Relocate_Node (Right_Opnd (N))));
+ -- Rewrite the conversion operand so that the original
+ -- node is retained, in order to avoid the warning for
+ -- redundant conversions in Resolve_Type_Conversion.
+
+ Rewrite (N, Relocate_Node (N));
+
Set_Etype (N, Target_Type);
- Typ := Target_Type;
- Rtyp := Root_Type (Typ);
+
Analyze_And_Resolve (Left_Opnd (N), Target_Type);
Analyze_And_Resolve (Right_Opnd (N), Target_Type);
Desig_Typ : Entity_Id;
begin
+ -- No checks inside a generic (check the instantiations)
+
if Inside_A_Generic then
return;
+ end if;
- elsif Is_Scalar_Type (Typ) then
+ -- Apply required constaint checks
+
+ if Is_Scalar_Type (Typ) then
Apply_Scalar_Range_Check (N, Typ);
elsif Is_Array_Type (Typ) then
if Present (Lhs)
and then (Present (Param_Entity (Lhs))
- or else (Ada_Version < Ada_05
+ or else (Ada_Version < Ada_2005
and then not Is_Constrained (T_Typ)
and then Is_Aliased_View (Lhs)
and then not Is_Aliased_Unconstrained_Component)
- or else (Ada_Version >= Ada_05
+ or else (Ada_Version >= Ada_2005
and then not Is_Constrained (T_Typ)
and then Denotes_Explicit_Dereference (Lhs)
and then Nkind (Original_Node (Lhs)) /=
-- Ada 2005: nothing to do if the type is one for which there is a
-- partial view that is constrained.
- elsif Ada_Version >= Ada_05
+ elsif Ada_Version >= Ada_2005
and then Has_Constrained_Partial_View (Base_Type (T_Typ))
then
return;
Truncate : constant Boolean := Float_Truncate (Par);
Max_Bound : constant Uint :=
UI_Expon
- (Machine_Radix (Expr_Type),
- Machine_Mantissa (Expr_Type) - 1) - 1;
+ (Machine_Radix_Value (Expr_Type),
+ Machine_Mantissa_Value (Expr_Type) - 1) - 1;
-- Largest bound, so bound plus or minus half is a machine number of F
(Ck_Node, Target_Typ, Source_Typ, Do_Static => False);
end Apply_Length_Check;
+ ---------------------------
+ -- Apply_Predicate_Check --
+ ---------------------------
+
+ procedure Apply_Predicate_Check (N : Node_Id; Typ : Entity_Id) is
+ begin
+ if Present (Predicate_Function (Typ)) then
+ Insert_Action (N,
+ Make_Predicate_Check (Typ, Duplicate_Subexpr (N)));
+ end if;
+ end Apply_Predicate_Check;
+
-----------------------
-- Apply_Range_Check --
-----------------------
-- one of the stored discriminants, this will provide the
-- required consistency check.
- Append_Elmt (
- Make_Selected_Component (Loc,
- Prefix =>
+ Append_Elmt
+ (Make_Selected_Component (Loc,
+ Prefix =>
Duplicate_Subexpr_No_Checks
(Expr, Name_Req => True),
Selector_Name =>
Make_Identifier (Loc, Chars (Discr))),
- New_Constraints);
+ New_Constraints);
else
-- Discriminant of more remote ancestor ???
Indx := Next_Index (Indx);
end loop;
+ -- If the index type is a formal type or derived from
+ -- one, the bounds are not static.
+
+ if Is_Generic_Type (Root_Type (Etype (Indx))) then
+ OK := False;
+ return;
+ end if;
+
Determine_Range
(Type_Low_Bound (Etype (Indx)), OK1, LL, LU,
Assume_Valid);
-- For constrained arrays, the minimum value for
-- Length is taken from the actual value of the
- -- bounds, since the index will be exactly of
- -- this subtype.
+ -- bounds, since the index will be exactly of this
+ -- subtype.
if Is_Constrained (Atyp) then
Lor := UI_Max (Uint_0, UL - LU + 1);
end;
-- No special handling for other attributes
- -- Probably more opportunities exist here ???
+ -- Probably more opportunities exist here???
when others =>
OK1 := False;
Hir := No_Uint;
end case;
- -- At this stage, if OK1 is true, then we know that the actual
- -- result of the computed expression is in the range Lor .. Hir.
- -- We can use this to restrict the possible range of results.
+ -- At this stage, if OK1 is true, then we know that the actual result of
+ -- the computed expression is in the range Lor .. Hir. We can use this
+ -- to restrict the possible range of results.
if OK1 then
- -- If the refined value of the low bound is greater than the
- -- type high bound, then reset it to the more restrictive
- -- value. However, we do NOT do this for the case of a modular
- -- type where the possible upper bound on the value is above the
- -- base type high bound, because that means the result could wrap.
+ -- If the refined value of the low bound is greater than the type
+ -- high bound, then reset it to the more restrictive value. However,
+ -- we do NOT do this for the case of a modular type where the
+ -- possible upper bound on the value is above the base type high
+ -- bound, because that means the result could wrap.
if Lor > Lo
- and then not (Is_Modular_Integer_Type (Typ)
- and then Hir > Hbound)
+ and then not (Is_Modular_Integer_Type (Typ) and then Hir > Hbound)
then
Lo := Lor;
end if;
- -- Similarly, if the refined value of the high bound is less
- -- than the value so far, then reset it to the more restrictive
- -- value. Again, we do not do this if the refined low bound is
- -- negative for a modular type, since this would wrap.
+ -- Similarly, if the refined value of the high bound is less than the
+ -- value so far, then reset it to the more restrictive value. Again,
+ -- we do not do this if the refined low bound is negative for a
+ -- modular type, since this would wrap.
if Hir < Hi
- and then not (Is_Modular_Integer_Type (Typ)
- and then Lor < Uint_0)
+ and then not (Is_Modular_Integer_Type (Typ) and then Lor < Uint_0)
then
Hi := Hir;
end if;
Determine_Range_Cache_Hi (Cindex) := Hi;
return;
- -- If any exception occurs, it means that we have some bug in the compiler
- -- possibly triggered by a previous error, or by some unforseen peculiar
+ -- If any exception occurs, it means that we have some bug in the compiler,
+ -- possibly triggered by a previous error, or by some unforeseen peculiar
-- occurrence. However, this is only an optimization attempt, so there is
-- really no point in crashing the compiler. Instead we just decide, too
-- bad, we can't figure out a range in this case after all.
return;
end if;
+ -- Do not set range check flag if parent is assignment statement or
+ -- object declaration with Suppress_Assignment_Checks flag set
+
+ if Nkind_In (Parent (N), N_Assignment_Statement, N_Object_Declaration)
+ and then Suppress_Assignment_Checks (Parent (N))
+ then
+ return;
+ end if;
+
-- Check for various cases where we should suppress the range check
-- No check if range checks suppressed for type of node
end if;
end if;
+ -- If this is a boolean expression, only its elementary operands need
+ -- checking: if they are valid, a boolean or short-circuit operation
+ -- with them will be valid as well.
+
+ if Base_Type (Typ) = Standard_Boolean
+ and then
+ (Nkind (Expr) in N_Op or else Nkind (Expr) in N_Short_Circuit)
+ then
+ return;
+ end if;
+
-- If we fall through, a validity check is required
Insert_Valid_Check (Expr);
----------------------------------
procedure Install_Null_Excluding_Check (N : Node_Id) is
- Loc : constant Source_Ptr := Sloc (N);
+ Loc : constant Source_Ptr := Sloc (Parent (N));
Typ : constant Entity_Id := Etype (N);
function Safe_To_Capture_In_Parameter_Value return Boolean;
-- Returns an attribute reference
-- E'First or E'Last
-- with a source location of Loc.
+ --
-- Nam is Name_First or Name_Last, according to which attribute is
-- desired. If Indx is non-zero, it is passed as a literal in the
-- Expressions of the attribute reference (identifying the desired
OSDN Git Service
