-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2008, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2009, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
with Einfo; use Einfo;
with Errout; use Errout;
with Exp_Ch2; use Exp_Ch2;
+with Exp_Ch4; use Exp_Ch4;
with Exp_Ch11; use Exp_Ch11;
with Exp_Pakd; use Exp_Pakd;
with Exp_Util; use Exp_Util;
with Rident; use Rident;
with Rtsfind; use Rtsfind;
with Sem; use Sem;
+with Sem_Aux; use Sem_Aux;
with Sem_Eval; use Sem_Eval;
with Sem_Ch3; use Sem_Ch3;
with Sem_Ch8; use Sem_Ch8;
-- No check if accessing the Offset_To_Top component of a dispatch
-- table. They are safe by construction.
- if Present (Etype (P))
+ if Tagged_Type_Expansion
+ and then Present (Etype (P))
and then RTU_Loaded (Ada_Tags)
and then RTE_Available (RE_Offset_To_Top_Ptr)
and then Etype (P) = RTE (RE_Offset_To_Top_Ptr)
-- Apply_Accessibility_Check --
-------------------------------
- procedure Apply_Accessibility_Check (N : Node_Id; Typ : Entity_Id) is
+ procedure Apply_Accessibility_Check
+ (N : Node_Id;
+ Typ : Entity_Id;
+ Insert_Node : Node_Id)
+ is
Loc : constant Source_Ptr := Sloc (N);
Param_Ent : constant Entity_Id := Param_Entity (N);
Param_Level : Node_Id;
if Inside_A_Generic then
return;
- -- Only apply the run-time check if the access parameter
- -- has an associated extra access level parameter and
- -- when the level of the type is less deep than the level
- -- of the access parameter.
+ -- Only apply the run-time check if the access parameter has an
+ -- associated extra access level parameter and when the level of the
+ -- type is less deep than the level of the access parameter, and
+ -- accessibility checks are not suppressed.
elsif Present (Param_Ent)
and then Present (Extra_Accessibility (Param_Ent))
- and then UI_Gt (Object_Access_Level (N),
- Type_Access_Level (Typ))
+ and then UI_Gt (Object_Access_Level (N), Type_Access_Level (Typ))
and then not Accessibility_Checks_Suppressed (Param_Ent)
and then not Accessibility_Checks_Suppressed (Typ)
then
Type_Level :=
Make_Integer_Literal (Loc, Type_Access_Level (Typ));
- -- Raise Program_Error if the accessibility level of the the access
+ -- Raise Program_Error if the accessibility level of the access
-- parameter is deeper than the level of the target access type.
- Insert_Action (N,
+ Insert_Action (Insert_Node,
Make_Raise_Program_Error (Loc,
Condition =>
Make_Op_Gt (Loc,
-- when Aexp is a reference to a constant, in which case Expr gets
-- reset to reference the value expression of the constant.
- Size_Warning_Output : Boolean := False;
- -- If we output a size warning we set this True, to stop generating
- -- what is likely to be an unuseful redundant alignment warning.
-
procedure Compile_Time_Bad_Alignment;
-- Post error warnings when alignment is known to be incompatible. Note
-- that we do not go as far as inserting a raise of Program_Error since
-- this is an erroneous case, and it may happen that we are lucky and an
- -- underaligned address turns out to be OK after all. Also this warning
- -- is suppressed if we already complained about the size.
+ -- underaligned address turns out to be OK after all.
--------------------------------
-- Compile_Time_Bad_Alignment --
procedure Compile_Time_Bad_Alignment is
begin
- if not Size_Warning_Output
- and then Address_Clause_Overlay_Warnings
- then
+ if Address_Clause_Overlay_Warnings then
Error_Msg_FE
("?specified address for& may be inconsistent with alignment ",
Aexp, E);
-- Start of processing for Apply_Address_Clause_Check
begin
- -- First obtain expression from address clause
+ -- See if alignment check needed. Note that we never need a check if the
+ -- maximum alignment is one, since the check will always succeed.
+
+ -- Note: we do not check for checks suppressed here, since that check
+ -- was done in Sem_Ch13 when the address clause was processed. We are
+ -- only called if checks were not suppressed. The reason for this is
+ -- that we have to delay the call to Apply_Alignment_Check till freeze
+ -- time (so that all types etc are elaborated), but we have to check
+ -- the status of check suppressing at the point of the address clause.
+
+ if No (AC)
+ or else not Check_Address_Alignment (AC)
+ or else Maximum_Alignment = 1
+ then
+ return;
+ end if;
+
+ -- Obtain expression from address clause
Expr := Expression (AC);
end if;
end loop;
- -- Output a warning if we have the situation of
-
- -- for X'Address use Y'Address
-
- -- and X and Y both have known object sizes, and Y is smaller than X
-
- if Nkind (Expr) = N_Attribute_Reference
- and then Attribute_Name (Expr) = Name_Address
- and then Is_Entity_Name (Prefix (Expr))
- then
- declare
- Exp_Ent : constant Entity_Id := Entity (Prefix (Expr));
- Obj_Size : Uint := No_Uint;
- Exp_Size : Uint := No_Uint;
-
- begin
- if Known_Esize (E) then
- Obj_Size := Esize (E);
- elsif Known_Esize (Etype (E)) then
- Obj_Size := Esize (Etype (E));
- end if;
-
- if Known_Esize (Exp_Ent) then
- Exp_Size := Esize (Exp_Ent);
- elsif Known_Esize (Etype (Exp_Ent)) then
- Exp_Size := Esize (Etype (Exp_Ent));
- end if;
-
- if Obj_Size /= No_Uint
- and then Exp_Size /= No_Uint
- and then Obj_Size > Exp_Size
- and then not Has_Warnings_Off (E)
- then
- if Address_Clause_Overlay_Warnings then
- Error_Msg_FE
- ("?& overlays smaller object", Aexp, E);
- Error_Msg_FE
- ("\?program execution may be erroneous", Aexp, E);
- Size_Warning_Output := True;
- Set_Address_Warning_Posted (AC);
- end if;
- end if;
- end;
- end if;
-
- -- See if alignment check needed. Note that we never need a check if the
- -- maximum alignment is one, since the check will always succeed.
-
- -- Note: we do not check for checks suppressed here, since that check
- -- was done in Sem_Ch13 when the address clause was processed. We are
- -- only called if checks were not suppressed. The reason for this is
- -- that we have to delay the call to Apply_Alignment_Check till freeze
- -- time (so that all types etc are elaborated), but we have to check
- -- the status of check suppressing at the point of the address clause.
-
- if No (AC)
- or else not Check_Address_Alignment (AC)
- or else Maximum_Alignment = 1
- then
- return;
- end if;
-
- -- See if we know that Expr is a bad alignment at compile time
+ -- See if we know that Expr has a bad alignment at compile time
if Compile_Time_Known_Value (Expr)
and then (Known_Alignment (E) or else Known_Alignment (Typ))
-- If the expression has the form X'Address, then we can find out if
-- the object X has an alignment that is compatible with the object E.
+ -- If it hasn't or we don't know, we defer issuing the warning until
+ -- the end of the compilation to take into account back end annotations.
elsif Nkind (Expr) = N_Attribute_Reference
and then Attribute_Name (Expr) = Name_Address
+ and then Has_Compatible_Alignment (E, Prefix (Expr)) = Known_Compatible
then
- declare
- AR : constant Alignment_Result :=
- Has_Compatible_Alignment (E, Prefix (Expr));
- begin
- if AR = Known_Compatible then
- return;
- elsif AR = Known_Incompatible then
- Compile_Time_Bad_Alignment;
- end if;
- end;
+ return;
end if;
-- Here we do not know if the value is acceptable. Stricly we don't have
-- Apply_Arithmetic_Overflow_Check --
-------------------------------------
- -- This routine is called only if the type is an integer type, and
- -- a software arithmetic overflow check must be performed for op
- -- (add, subtract, multiply). The check is performed only if
- -- Software_Overflow_Checking is enabled and Do_Overflow_Check
- -- is set. In this case we expand the operation into a more complex
- -- sequence of tests that ensures that overflow is properly caught.
+ -- This routine is called only if the type is an integer type, and a
+ -- software arithmetic overflow check may be needed for op (add, subtract,
+ -- or multiply). This check is performed only if Software_Overflow_Checking
+ -- is enabled and Do_Overflow_Check is set. In this case we expand the
+ -- operation into a more complex sequence of tests that ensures that
+ -- overflow is properly caught.
procedure Apply_Arithmetic_Overflow_Check (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
- Typ : constant Entity_Id := Etype (N);
- Rtyp : constant Entity_Id := Root_Type (Typ);
- Siz : constant Int := UI_To_Int (Esize (Rtyp));
- Dsiz : constant Int := Siz * 2;
- Opnod : Node_Id;
- Ctyp : Entity_Id;
- Opnd : Node_Id;
- Cent : RE_Id;
+ Typ : Entity_Id := Etype (N);
+ Rtyp : Entity_Id := Root_Type (Typ);
begin
- -- Skip this if overflow checks are done in back end, or the overflow
- -- flag is not set anyway, or we are not doing code expansion.
- -- Special case CLI target, where arithmetic overflow checks can be
- -- performed for integer and long_integer
-
- if Backend_Overflow_Checks_On_Target
- or else (VM_Target = CLI_Target and then Siz >= Standard_Integer_Size)
- or else not Do_Overflow_Check (N)
- or else not Expander_Active
+ -- An interesting special case. If the arithmetic operation appears as
+ -- the operand of a type conversion:
+
+ -- type1 (x op y)
+
+ -- and all the following conditions apply:
+
+ -- arithmetic operation is for a signed integer type
+ -- target type type1 is a static integer subtype
+ -- range of x and y are both included in the range of type1
+ -- range of x op y is included in the range of type1
+ -- size of type1 is at least twice the result size of op
+
+ -- then we don't do an overflow check in any case, instead we transform
+ -- the operation so that we end up with:
+
+ -- type1 (type1 (x) op type1 (y))
+
+ -- This avoids intermediate overflow before the conversion. It is
+ -- explicitly permitted by RM 3.5.4(24):
+
+ -- For the execution of a predefined operation of a signed integer
+ -- type, the implementation need not raise Constraint_Error if the
+ -- result is outside the base range of the type, so long as the
+ -- correct result is produced.
+
+ -- It's hard to imagine that any programmer counts on the exception
+ -- being raised in this case, and in any case it's wrong coding to
+ -- have this expectation, given the RM permission. Furthermore, other
+ -- Ada compilers do allow such out of range results.
+
+ -- Note that we do this transformation even if overflow checking is
+ -- off, since this is precisely about giving the "right" result and
+ -- avoiding the need for an overflow check.
+
+ -- Note: this circuit is partially redundant with respect to the similar
+ -- processing in Exp_Ch4.Expand_N_Type_Conversion, but the latter deals
+ -- with cases that do not come through here. We still need the following
+ -- processing even with the Exp_Ch4 code in place, since we want to be
+ -- sure not to generate the arithmetic overflow check in these cases
+ -- (Exp_Ch4 would have a hard time removing them once generated).
+
+ if Is_Signed_Integer_Type (Typ)
+ and then Nkind (Parent (N)) = N_Type_Conversion
then
- return;
+ declare
+ Target_Type : constant Entity_Id :=
+ Base_Type (Entity (Subtype_Mark (Parent (N))));
+
+ Llo, Lhi : Uint;
+ Rlo, Rhi : Uint;
+ LOK, ROK : Boolean;
+
+ Vlo : Uint;
+ Vhi : Uint;
+ VOK : Boolean;
+
+ Tlo : Uint;
+ Thi : Uint;
+
+ begin
+ if Is_Integer_Type (Target_Type)
+ and then RM_Size (Root_Type (Target_Type)) >= 2 * RM_Size (Rtyp)
+ then
+ Tlo := Expr_Value (Type_Low_Bound (Target_Type));
+ Thi := Expr_Value (Type_High_Bound (Target_Type));
+
+ 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, Assume_Valid => True);
+
+ if VOK and then Tlo <= Vlo and then Vhi <= Thi then
+ Rewrite (Left_Opnd (N),
+ Make_Type_Conversion (Loc,
+ Subtype_Mark => New_Occurrence_Of (Target_Type, Loc),
+ Expression => Relocate_Node (Left_Opnd (N))));
+
+ Rewrite (Right_Opnd (N),
+ Make_Type_Conversion (Loc,
+ Subtype_Mark => New_Occurrence_Of (Target_Type, Loc),
+ Expression => Relocate_Node (Right_Opnd (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);
+
+ -- Given that the target type is twice the size of the
+ -- source type, overflow is now impossible, so we can
+ -- safely kill the overflow check and return.
+
+ Set_Do_Overflow_Check (N, False);
+ return;
+ end if;
+ end if;
+ end if;
+ end;
end if;
- -- Otherwise, we generate the full general code for front end overflow
- -- detection, which works by doing arithmetic in a larger type:
+ -- Now see if an overflow check is required
+
+ declare
+ Siz : constant Int := UI_To_Int (Esize (Rtyp));
+ Dsiz : constant Int := Siz * 2;
+ Opnod : Node_Id;
+ Ctyp : Entity_Id;
+ Opnd : Node_Id;
+ Cent : RE_Id;
- -- x op y
+ begin
+ -- Skip check if back end does overflow checks, or the overflow flag
+ -- is not set anyway, or we are not doing code expansion, or the
+ -- parent node is a type conversion whose operand is an arithmetic
+ -- operation on signed integers on which the expander can promote
+ -- later the operands to type Integer (see Expand_N_Type_Conversion).
+
+ -- Special case CLI target, where arithmetic overflow checks can be
+ -- performed for integer and long_integer
+
+ if Backend_Overflow_Checks_On_Target
+ or else not Do_Overflow_Check (N)
+ or else not Expander_Active
+ or else (Present (Parent (N))
+ and then Nkind (Parent (N)) = N_Type_Conversion
+ and then Integer_Promotion_Possible (Parent (N)))
+ or else
+ (VM_Target = CLI_Target and then Siz >= Standard_Integer_Size)
+ then
+ return;
+ end if;
- -- is expanded into
+ -- Otherwise, generate the full general code for front end overflow
+ -- detection, which works by doing arithmetic in a larger type:
- -- Typ (Checktyp (x) op Checktyp (y));
+ -- x op y
- -- where Typ is the type of the original expression, and Checktyp is
- -- an integer type of sufficient length to hold the largest possible
- -- result.
+ -- is expanded into
- -- In the case where check type exceeds the size of Long_Long_Integer,
- -- we use a different approach, expanding to:
+ -- Typ (Checktyp (x) op Checktyp (y));
- -- typ (xxx_With_Ovflo_Check (Integer_64 (x), Integer (y)))
+ -- where Typ is the type of the original expression, and Checktyp is
+ -- an integer type of sufficient length to hold the largest possible
+ -- result.
- -- where xxx is Add, Multiply or Subtract as appropriate
+ -- If the size of check type exceeds the size of Long_Long_Integer,
+ -- we use a different approach, expanding to:
- -- Find check type if one exists
+ -- typ (xxx_With_Ovflo_Check (Integer_64 (x), Integer (y)))
- if Dsiz <= Standard_Integer_Size then
- Ctyp := Standard_Integer;
+ -- where xxx is Add, Multiply or Subtract as appropriate
- elsif Dsiz <= Standard_Long_Long_Integer_Size then
- Ctyp := Standard_Long_Long_Integer;
+ -- Find check type if one exists
- -- No check type exists, use runtime call
+ if Dsiz <= Standard_Integer_Size then
+ Ctyp := Standard_Integer;
- else
- if Nkind (N) = N_Op_Add then
- Cent := RE_Add_With_Ovflo_Check;
+ elsif Dsiz <= Standard_Long_Long_Integer_Size then
+ Ctyp := Standard_Long_Long_Integer;
- elsif Nkind (N) = N_Op_Multiply then
- Cent := RE_Multiply_With_Ovflo_Check;
+ -- No check type exists, use runtime call
else
- pragma Assert (Nkind (N) = N_Op_Subtract);
- Cent := RE_Subtract_With_Ovflo_Check;
- end if;
+ if Nkind (N) = N_Op_Add then
+ Cent := RE_Add_With_Ovflo_Check;
- Rewrite (N,
- OK_Convert_To (Typ,
- Make_Function_Call (Loc,
- Name => New_Reference_To (RTE (Cent), Loc),
- Parameter_Associations => New_List (
- OK_Convert_To (RTE (RE_Integer_64), Left_Opnd (N)),
- OK_Convert_To (RTE (RE_Integer_64), Right_Opnd (N))))));
+ elsif Nkind (N) = N_Op_Multiply then
+ Cent := RE_Multiply_With_Ovflo_Check;
- Analyze_And_Resolve (N, Typ);
- return;
- end if;
+ else
+ pragma Assert (Nkind (N) = N_Op_Subtract);
+ Cent := RE_Subtract_With_Ovflo_Check;
+ end if;
- -- If we fall through, we have the case where we do the arithmetic in
- -- the next higher type and get the check by conversion. In these cases
- -- Ctyp is set to the type to be used as the check type.
+ Rewrite (N,
+ OK_Convert_To (Typ,
+ Make_Function_Call (Loc,
+ Name => New_Reference_To (RTE (Cent), Loc),
+ Parameter_Associations => New_List (
+ OK_Convert_To (RTE (RE_Integer_64), Left_Opnd (N)),
+ OK_Convert_To (RTE (RE_Integer_64), Right_Opnd (N))))));
- Opnod := Relocate_Node (N);
+ Analyze_And_Resolve (N, Typ);
+ return;
+ end if;
- Opnd := OK_Convert_To (Ctyp, Left_Opnd (Opnod));
+ -- If we fall through, we have the case where we do the arithmetic
+ -- in the next higher type and get the check by conversion. In these
+ -- cases Ctyp is set to the type to be used as the check type.
- Analyze (Opnd);
- Set_Etype (Opnd, Ctyp);
- Set_Analyzed (Opnd, True);
- Set_Left_Opnd (Opnod, Opnd);
+ Opnod := Relocate_Node (N);
- Opnd := OK_Convert_To (Ctyp, Right_Opnd (Opnod));
+ Opnd := OK_Convert_To (Ctyp, Left_Opnd (Opnod));
- Analyze (Opnd);
- Set_Etype (Opnd, Ctyp);
- Set_Analyzed (Opnd, True);
- Set_Right_Opnd (Opnod, Opnd);
+ Analyze (Opnd);
+ Set_Etype (Opnd, Ctyp);
+ Set_Analyzed (Opnd, True);
+ Set_Left_Opnd (Opnod, Opnd);
- -- The type of the operation changes to the base type of the check type,
- -- and we reset the overflow check indication, since clearly no overflow
- -- is possible now that we are using a double length type. We also set
- -- the Analyzed flag to avoid a recursive attempt to expand the node.
+ Opnd := OK_Convert_To (Ctyp, Right_Opnd (Opnod));
- Set_Etype (Opnod, Base_Type (Ctyp));
- Set_Do_Overflow_Check (Opnod, False);
- Set_Analyzed (Opnod, True);
+ Analyze (Opnd);
+ Set_Etype (Opnd, Ctyp);
+ Set_Analyzed (Opnd, True);
+ Set_Right_Opnd (Opnod, Opnd);
- -- Now build the outer conversion
+ -- The type of the operation changes to the base type of the check
+ -- type, and we reset the overflow check indication, since clearly no
+ -- overflow is possible now that we are using a double length type.
+ -- We also set the Analyzed flag to avoid a recursive attempt to
+ -- expand the node.
- Opnd := OK_Convert_To (Typ, Opnod);
- Analyze (Opnd);
- Set_Etype (Opnd, Typ);
+ Set_Etype (Opnod, Base_Type (Ctyp));
+ Set_Do_Overflow_Check (Opnod, False);
+ Set_Analyzed (Opnod, True);
- -- In the discrete type case, we directly generate the range check for
- -- the outer operand. This range check will implement the required
- -- overflow check.
+ -- Now build the outer conversion
- if Is_Discrete_Type (Typ) then
- Rewrite (N, Opnd);
- Generate_Range_Check (Expression (N), Typ, CE_Overflow_Check_Failed);
+ Opnd := OK_Convert_To (Typ, Opnod);
+ Analyze (Opnd);
+ Set_Etype (Opnd, Typ);
- -- For other types, we enable overflow checking on the conversion,
- -- after setting the node as analyzed to prevent recursive attempts
- -- to expand the conversion node.
+ -- In the discrete type case, we directly generate the range check
+ -- for the outer operand. This range check will implement the
+ -- required overflow check.
- else
- Set_Analyzed (Opnd, True);
- Enable_Overflow_Check (Opnd);
- Rewrite (N, Opnd);
- end if;
+ if Is_Discrete_Type (Typ) then
+ Rewrite (N, Opnd);
+ Generate_Range_Check
+ (Expression (N), Typ, CE_Overflow_Check_Failed);
- exception
- when RE_Not_Available =>
- return;
+ -- For other types, we enable overflow checking on the conversion,
+ -- after setting the node as analyzed to prevent recursive attempts
+ -- to expand the conversion node.
+
+ else
+ Set_Analyzed (Opnd, True);
+ Enable_Overflow_Check (Opnd);
+ Rewrite (N, Opnd);
+ end if;
+
+ exception
+ when RE_Not_Available =>
+ return;
+ end;
end Apply_Arithmetic_Overflow_Check;
----------------------------
Apply_Discriminant_Check (N, Typ);
end if;
- -- Apply the the 2005 Null_Excluding check. Note that we do not apply
+ -- Apply the 2005 Null_Excluding check. Note that we do not apply
-- this check if the constraint node is illegal, as shown by having
-- an error posted. This additional guard prevents cascaded errors
-- and compiler aborts on illegal programs involving Ada 2005 checks.
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))
end;
end if;
- -- Get the bounds of the target type
+ -- Get the (static) bounds of the target type
Ifirst := Expr_Value (LB);
Ilast := Expr_Value (HB);
+ -- A simple optimization: if the expression is a universal literal,
+ -- we can do the comparison with the bounds and the conversion to
+ -- an integer type statically. The range checks are unchanged.
+
+ if Nkind (Ck_Node) = N_Real_Literal
+ and then Etype (Ck_Node) = Universal_Real
+ and then Is_Integer_Type (Target_Typ)
+ and then Nkind (Parent (Ck_Node)) = N_Type_Conversion
+ then
+ declare
+ Int_Val : constant Uint := UR_To_Uint (Realval (Ck_Node));
+
+ begin
+ if Int_Val <= Ilast and then Int_Val >= Ifirst then
+
+ -- Conversion is safe
+
+ Rewrite (Parent (Ck_Node),
+ Make_Integer_Literal (Loc, UI_To_Int (Int_Val)));
+ Analyze_And_Resolve (Parent (Ck_Node), Target_Typ);
+ return;
+ end if;
+ end;
+ end if;
+
-- Check against lower bound
if Truncate and then Ifirst > 0 then
-- Otherwise determine range of value
- Determine_Range (Expr, OK, Lo, Hi);
+ Determine_Range (Expr, OK, Lo, Hi, Assume_Valid => True);
if OK then
and then
(In_Subrange_Of (S_Typ, Target_Typ, 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;
begin
if not Overflow_Checks_Suppressed (Target_Base)
- and then not In_Subrange_Of (Expr_Type, Target_Base, Conv_OK)
+ and then not
+ In_Subrange_Of (Expr_Type, Target_Base, Fixed_Int => Conv_OK)
and then not Float_To_Int
then
Activate_Overflow_Check (N);
end;
elsif Comes_From_Source (N)
+ and then not Discriminant_Checks_Suppressed (Target_Type)
and then Is_Record_Type (Target_Type)
and then Is_Derived_Type (Target_Type)
and then not Is_Tagged_Type (Target_Type)
-- be applied to a [sub]type that does not exclude null already.
elsif Can_Never_Be_Null (Typ)
-
- -- No need to check itypes that have a null exclusion because
- -- they are already examined at their point of creation.
-
- and then not Is_Itype (Typ)
+ and then Comes_From_Source (Typ)
then
Error_Msg_NE
("`NOT NULL` not allowed (& already excludes null)",
-- Check that a null-excluding component, formal or object is not being
-- assigned a null value. Otherwise generate a warning message and
- -- replace Expression (N) by an N_Contraint_Error node.
+ -- replace Expression (N) by an N_Constraint_Error node.
if K /= N_Function_Specification then
Expr := Expression (N);
-- 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 : constant Entity_Id := Etype (N);
+ Typ : Entity_Id := Etype (N);
+ -- Type to use, may get reset to base type for possibly invalid entity
Lo_Left : Uint;
Hi_Left : Uint;
function OK_Operands return Boolean;
-- Used for binary operators. Determines the ranges of the left and
-- right operands, and if they are both OK, returns True, and puts
- -- the results in Lo_Right, Hi_Right, Lo_Left, Hi_Left
+ -- the results in Lo_Right, Hi_Right, Lo_Left, Hi_Left.
-----------------
-- OK_Operands --
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;
Lor := No_Uint;
Hir := No_Uint;
- -- If the type is not discrete, or is undefined, then we can't do
- -- anything about determining the range.
+ -- If type is not defined, we can't determine its range
+
+ if No (Typ)
+
+ -- We don't deal with anything except discrete types
+
+ or else not Is_Discrete_Type (Typ)
- if No (Typ) or else not Is_Discrete_Type (Typ)
- or else Error_Posted (N)
+ -- Ignore type for which an error has been posted, since range in
+ -- this case may well be a bogosity deriving from the error. Also
+ -- ignore if error posted on the reference node.
+
+ or else Error_Posted (N) or else Error_Posted (Typ)
then
OK := False;
return;
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 a check, never try to find the bounds of a generic type, since
+ -- these bounds are always junk values, and it is only valid to look at
+ -- the bounds in an instance.
+
+ if Is_Generic_Type (Typ) then
+ OK := False;
+ return;
+ end if;
+
+ -- First step, change to use base type unless we know the value is valid
+
+ if (Is_Entity_Name (N) and then Is_Known_Valid (Entity (N)))
+ or else Assume_No_Invalid_Values
+ or else Assume_Valid
+ then
+ null;
+ else
+ Typ := Underlying_Type (Base_Type (Typ));
+ end if;
+
-- We use the actual bound unless it is dynamic, in which case use the
-- corresponding base type bound if possible. If we can't get a bound
-- then we figure we can't determine the range (a peculiar case, that
-- 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;
case Attribute_Name (N) is
-- For Pos/Val attributes, we can refine the range using the
- -- possible range of values of the attribute expression
+ -- 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;
pg (Union_Id (N));
end if;
+ -- No check if overflow checks suppressed for type of node
+
+ if Present (Etype (N))
+ and then Overflow_Checks_Suppressed (Etype (N))
+ then
+ return;
+
+ -- Nothing to do for unsigned integer types, which do not overflow
+
+ elsif Is_Modular_Integer_Type (Typ) then
+ return;
+
-- Nothing to do if the range of the result is known OK. We skip this
-- for conversions, since the caller already did the check, and in any
-- case the condition for deleting the check for a type conversion is
-- different.
- if Nkind (N) /= N_Type_Conversion then
- Determine_Range (N, OK, Lo, Hi);
+ elsif Nkind (N) /= N_Type_Conversion then
+ 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
-- Start of processing for Find_Check
begin
- -- Establish default, to avoid warnings from GCC
+ -- Establish default, in case no entry is found
Check_Num := 0;
-- If we fall through entry was not found
- Check_Num := 0;
return;
end Find_Check;
-- The conversions will always work and need no check
+ -- Unchecked_Convert_To is used instead of Convert_To to handle the case
+ -- of converting from an enumeration value to an integer type, such as
+ -- occurs for the case of generating a range check on Enum'Val(Exp)
+ -- (which used to be handled by gigi). This is OK, since the conversion
+ -- itself does not require a check.
+
elsif In_Subrange_Of (Target_Type, Source_Base_Type) then
Insert_Action (N,
Make_Raise_Constraint_Error (Loc,
Right_Opnd =>
Make_Range (Loc,
Low_Bound =>
- Convert_To (Source_Base_Type,
+ Unchecked_Convert_To (Source_Base_Type,
Make_Attribute_Reference (Loc,
Prefix =>
New_Occurrence_Of (Target_Type, Loc),
Attribute_Name => Name_First)),
High_Bound =>
- Convert_To (Source_Base_Type,
+ Unchecked_Convert_To (Source_Base_Type,
Make_Attribute_Reference (Loc,
Prefix =>
New_Occurrence_Of (Target_Type, Loc),
Suppress => All_Checks);
-- Only remaining possibility is that the source is signed and
- -- the target is unsigned
+ -- the target is unsigned.
else
pragma Assert (not Is_Unsigned_Type (Source_Base_Type)
New_Occurrence_Of (Target_Base_Type, Loc),
Constant_Present => True,
Expression =>
- Make_Type_Conversion (Loc,
+ Make_Unchecked_Type_Conversion (Loc,
Subtype_Mark =>
New_Occurrence_Of (Target_Base_Type, Loc),
Expression => Duplicate_Subexpr (N))),
Exp : Node_Id;
begin
- -- Do not insert if checks off, or if not checking validity
+ -- Do not insert if checks off, or if not checking validity or
+ -- if expression is known to be valid
if not Validity_Checks_On
or else Range_Or_Validity_Checks_Suppressed (Expr)
+ or else Expr_Known_Valid (Expr)
then
return;
end if;
begin
Set_Do_Range_Check (Exp, False);
+ -- Force evaluation to avoid multiple reads for atomic/volatile
+
+ if Is_Entity_Name (Exp)
+ and then Is_Volatile (Entity (Exp))
+ then
+ Force_Evaluation (Exp, Name_Req => True);
+ end if;
+
-- Insert the validity check. Note that we do this with validity
-- checks turned off, to avoid recursion, we do not want validity
-- checks on the validity checking code itself!
Loc : constant Source_Ptr := Sloc (N);
Typ : constant Entity_Id := Etype (N);
- function In_Declarative_Region_Of_Subprogram_Body return Boolean;
- -- Determine whether node N, a reference to an *in* parameter, is
- -- inside the declarative region of the current subprogram body.
+ function Safe_To_Capture_In_Parameter_Value return Boolean;
+ -- Determines if it is safe to capture Known_Non_Null status for an
+ -- the entity referenced by node N. The caller ensures that N is indeed
+ -- an entity name. It is safe to capture the non-null status for an IN
+ -- parameter when the reference occurs within a declaration that is sure
+ -- to be executed as part of the declarative region.
procedure Mark_Non_Null;
-- After installation of check, if the node in question is an entity
-- name, then mark this entity as non-null if possible.
- ----------------------------------------------
- -- In_Declarative_Region_Of_Subprogram_Body --
- ----------------------------------------------
-
- function In_Declarative_Region_Of_Subprogram_Body return Boolean is
+ function Safe_To_Capture_In_Parameter_Value return Boolean is
E : constant Entity_Id := Entity (N);
S : constant Entity_Id := Current_Scope;
S_Par : Node_Id;
begin
- pragma Assert (Ekind (E) = E_In_Parameter);
+ if Ekind (E) /= E_In_Parameter then
+ return False;
+ end if;
-- Two initial context checks. We must be inside a subprogram body
-- with declarations and reference must not appear in nested scopes.
- if (Ekind (S) /= E_Function
- and then Ekind (S) /= E_Procedure)
+ if (Ekind (S) /= E_Function and then Ekind (S) /= E_Procedure)
or else Scope (E) /= S
then
return False;
N_Decl := Empty;
while Present (P) loop
+ -- If we have a short circuit form, and we are within the right
+ -- hand expression, we return false, since the right hand side
+ -- is not guaranteed to be elaborated.
+
+ if Nkind (P) in N_Short_Circuit
+ and then N = Right_Opnd (P)
+ then
+ return False;
+ end if;
+
+ -- Similarly, if we are in a conditional expression and not
+ -- part of the condition, then we return False, since neither
+ -- the THEN or ELSE expressions will always be elaborated.
+
+ if Nkind (P) = N_Conditional_Expression
+ and then N /= First (Expressions (P))
+ then
+ return False;
+ end if;
+
-- While traversing the parent chain, we find that N
-- belongs to a statement, thus it may never appear in
-- a declarative region.
return False;
end if;
+ -- If we are at a declaration, record it and exit
+
if Nkind (P) in N_Declaration
and then Nkind (P) not in N_Subprogram_Specification
then
return List_Containing (N_Decl) = Declarations (S_Par);
end;
- end In_Declarative_Region_Of_Subprogram_Body;
+ end Safe_To_Capture_In_Parameter_Value;
-------------------
-- Mark_Non_Null --
-- safe to capture the value, or in the case of an IN parameter,
-- which is a constant, if the check we just installed is in the
-- declarative region of the subprogram body. In this latter case,
- -- a check is decisive for the rest of the body, since we know we
- -- must complete all declarations before executing the body.
+ -- a check is decisive for the rest of the body if the expression
+ -- is sure to be elaborated, since we know we have to elaborate
+ -- all declarations before executing the body.
+
+ -- Couldn't this always be part of Safe_To_Capture_Value ???
if Safe_To_Capture_Value (N, Entity (N))
- or else
- (Ekind (Entity (N)) = E_In_Parameter
- and then In_Declarative_Region_Of_Subprogram_Body)
+ or else Safe_To_Capture_In_Parameter_Value
then
Set_Is_Known_Non_Null (Entity (N));
end if;
-- If known to be null, here is where we generate a compile time check
if Known_Null (N) then
- Apply_Compile_Time_Constraint_Error
- (N,
- "null value not allowed here?",
- CE_Access_Check_Failed);
+
+ -- Avoid generating warning message inside init procs
+
+ if not Inside_Init_Proc then
+ Apply_Compile_Time_Constraint_Error
+ (N,
+ "null value not allowed here?",
+ CE_Access_Check_Failed);
+ else
+ Insert_Action (N,
+ Make_Raise_Constraint_Error (Loc,
+ Reason => CE_Access_Check_Failed));
+ end if;
+
Mark_Non_Null;
return;
end if;
Set_Etype (R_Cno, Typ);
Set_Raises_Constraint_Error (R_Cno);
Set_Is_Static_Expression (R_Cno, Stat);
+
+ -- Now deal with possible local raise handling
+
+ Possible_Local_Raise (R_Cno, Standard_Constraint_Error);
end Install_Static_Check;
---------------------
return Scope_Suppress (Overflow_Check);
end if;
end Overflow_Checks_Suppressed;
+
-----------------------------
-- Range_Checks_Suppressed --
-----------------------------
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
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
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;
"static range out of bounds of}?", T_Typ));
end if;
end if;
-
end if;
else
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
Next (L_Index);
Next (R_Index);
-
end if;
end loop;
end;
(Cond, Range_N_Cond (Ck_Node, T_Typ, Indx));
end loop;
end;
-
end if;
else
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
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;
OSDN Git Service
