-- --
-- 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)
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 (Insert_Node,
-- 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
-- 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
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),
begin
-- Skip check if back end does overflow checks, or the overflow flag
- -- is not set anyway, or we are not doing code expansion.
+ -- 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
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))
-- 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
Is_Discrete_Type (S_Typ) = Is_Discrete_Type (Target_Typ)
and then
- (In_Subrange_Of (S_Typ, Target_Typ,
- Assume_Valid => True,
- Fixed_Int => Fixed_Int)
+ (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,
- Assume_Valid => True,
- Fixed_Int => Conv_OK)
+ In_Subrange_Of (Expr_Type, Target_Base, Fixed_Int => Conv_OK)
and then not Float_To_Int
then
Activate_Overflow_Check (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 : Entity_Id := Etype (N);
-- Type to use, may get reset to base type for possibly invalid entity
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) or else not Is_Discrete_Type (Typ)
- or else Error_Posted (N)
+ if No (Typ)
+
+ -- We don't deal with anything except discrete types
+
+ or else not Is_Discrete_Type (Typ)
+
+ -- 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 step, change to use base type if the expression is an entity
- -- which we do not know is valid.
+ -- 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 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;
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;
-- case the literal has already been labeled as having the subtype of
-- the target.
- if In_Subrange_Of (Source_Type, Target_Type, Assume_Valid => True)
+ if In_Subrange_Of (Source_Type, Target_Type)
and then not
(Nkind (N) = N_Integer_Literal
or else
-- The conversions will always work and need no check
- elsif In_Subrange_Of
- (Target_Type, Source_Base_Type, Assume_Valid => True)
- then
+ -- 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,
Condition =>
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),
-- If that is the case, we can freely convert the source to the target,
-- and then test the target result against the bounds.
- elsif In_Subrange_Of
- (Source_Type, Target_Base_Type, Assume_Valid => True)
- then
+ elsif In_Subrange_Of (Source_Type, Target_Base_Type) then
-- We make a temporary to hold the value of the converted value
-- (converted to the base type), and then we will do the test against
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;
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
-- range of the target type.
else
- if not In_Subrange_Of (S_Typ, T_Typ, Assume_Valid => True) then
+ if not In_Subrange_Of (S_Typ, T_Typ) then
Cond := Discrete_Expr_Cond (Ck_Node, T_Typ);
end if;
end if;
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;