-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2008, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2010, 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
-- 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
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
-- 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
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);
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
Desig_Typ : Entity_Id;
begin
+ -- No checks inside a generic (check the instantiations)
+
if Inside_A_Generic then
return;
+ end if;
+
+ -- Apply required constaint checks
- elsif Is_Scalar_Type (Typ) then
+ if Is_Scalar_Type (Typ) then
Apply_Scalar_Range_Check (N, Typ);
elsif Is_Array_Type (Typ) then
Cond : Node_Id;
T_Typ : Entity_Id;
+ function Denotes_Explicit_Dereference (Obj : Node_Id) return Boolean;
+ -- A heap object with an indefinite subtype is constrained by its
+ -- initial value, and assigning to it requires a constraint_check.
+ -- The target may be an explicit dereference, or a renaming of one.
+
function Is_Aliased_Unconstrained_Component return Boolean;
-- It is possible for an aliased component to have a nominal
-- unconstrained subtype (through instantiation). If this is a
-- in an initialization, the check must be suppressed. This unusual
-- situation requires a predicate of its own.
+ ----------------------------------
+ -- Denotes_Explicit_Dereference --
+ ----------------------------------
+
+ function Denotes_Explicit_Dereference (Obj : Node_Id) return Boolean is
+ begin
+ return
+ Nkind (Obj) = N_Explicit_Dereference
+ or else
+ (Is_Entity_Name (Obj)
+ and then Present (Renamed_Object (Entity (Obj)))
+ and then Nkind (Renamed_Object (Entity (Obj))) =
+ N_Explicit_Dereference);
+ end Denotes_Explicit_Dereference;
+
----------------------------------------
-- Is_Aliased_Unconstrained_Component --
----------------------------------------
-- Ada 2005 (AI-363): For Ada 2005, we limit the building of the actual
-- subtype to the parameter and dereference cases, since other aliased
-- objects are unconstrained (unless the nominal subtype is explicitly
- -- constrained). (But we also need to test for renamings???)
+ -- constrained).
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 Nkind (Lhs) = N_Explicit_Dereference
+ and then Denotes_Explicit_Dereference (Lhs)
and then Nkind (Original_Node (Lhs)) /=
N_Function_Call))
then
-- 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
pragma Assert (Target_Base /= Target_Typ);
- Temp : constant Entity_Id :=
- Make_Defining_Identifier (Loc,
- Chars => New_Internal_Name ('T'));
+ Temp : constant Entity_Id := Make_Temporary (Loc, 'T', Par);
begin
Apply_Float_Conversion_Check (Ck_Node, Target_Base);
(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 ???
end case;
if K = N_Op_And then
- Error_Msg_N ("use `AND THEN` instead of AND?", P);
+ Error_Msg_N -- CODEFIX
+ ("use `AND THEN` instead of AND?", P);
else
- Error_Msg_N ("use `OR ELSE` instead of OR?", P);
+ Error_Msg_N -- CODEFIX
+ ("use `OR ELSE` instead of OR?", P);
end if;
-- If not short-circuited, we need the ckeck
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 --
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
- if No (Typ) or else not Is_Discrete_Type (Typ)
- or else Error_Posted (N)
+ 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;
-- 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)))
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
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.
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
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);
-- 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),
-- Then the conversion itself is replaced by an occurrence of Tnn
declare
- Tnn : constant Entity_Id :=
- Make_Defining_Identifier (Loc,
- Chars => New_Internal_Name ('T'));
+ Tnn : constant Entity_Id := Make_Temporary (Loc, 'T', N);
begin
Insert_Actions (N, New_List (
-- the value is non-negative
declare
- Tnn : constant Entity_Id :=
- Make_Defining_Identifier (Loc,
- Chars => New_Internal_Name ('T'));
+ Tnn : constant Entity_Id := Make_Temporary (Loc, 'T', N);
begin
Insert_Actions (N, New_List (
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!
----------------------------------
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 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;
+
+ -- If we are in a case eexpression, and not part of the
+ -- expression, then we return False, since a particular
+ -- branch may not always be elaborated
+
+ if Nkind (P) = N_Case_Expression
+ and then N /= Expression (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;
---------------------
-- Expr > Typ'Last
function Get_E_First_Or_Last
- (E : Entity_Id;
+ (Loc : Source_Ptr;
+ E : Entity_Id;
Indx : Nat;
Nam : Name_Id) return Node_Id;
- -- Returns expression to compute:
+ -- 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
+ -- array dimension).
function Get_N_First (N : Node_Id; Indx : Nat) return Node_Id;
function Get_N_Last (N : Node_Id; Indx : Nat) return Node_Id;
Duplicate_Subexpr_No_Checks (Expr)),
Right_Opnd =>
Convert_To (Base_Type (Typ),
- Get_E_First_Or_Last (Typ, 0, Name_First))),
+ Get_E_First_Or_Last (Loc, Typ, 0, Name_First))),
Right_Opnd =>
Make_Op_Gt (Loc,
Right_Opnd =>
Convert_To
(Base_Type (Typ),
- Get_E_First_Or_Last (Typ, 0, Name_Last))));
+ Get_E_First_Or_Last (Loc, Typ, 0, Name_Last))));
end Discrete_Expr_Cond;
-------------------------
Right_Opnd =>
Convert_To
- (Base_Type (Typ), Get_E_First_Or_Last (Typ, 0, Name_First)));
+ (Base_Type (Typ),
+ Get_E_First_Or_Last (Loc, Typ, 0, Name_First)));
if Base_Type (Typ) = Typ then
return Left_Opnd;
Right_Opnd =>
Convert_To
(Base_Type (Typ),
- Get_E_First_Or_Last (Typ, 0, Name_Last)));
+ Get_E_First_Or_Last (Loc, Typ, 0, Name_Last)));
return Make_Or_Else (Loc, Left_Opnd, Right_Opnd);
end Discrete_Range_Cond;
-------------------------
function Get_E_First_Or_Last
- (E : Entity_Id;
+ (Loc : Source_Ptr;
+ E : Entity_Id;
Indx : Nat;
Nam : Name_Id) return Node_Id
is
- N : Node_Id;
- LB : Node_Id;
- HB : Node_Id;
- Bound : Node_Id;
-
+ Exprs : List_Id;
begin
- if Is_Array_Type (E) then
- N := First_Index (E);
-
- for J in 2 .. Indx loop
- Next_Index (N);
- end loop;
-
+ if Indx > 0 then
+ Exprs := New_List (Make_Integer_Literal (Loc, UI_From_Int (Indx)));
else
- N := Scalar_Range (E);
+ Exprs := No_List;
end if;
- if Nkind (N) = N_Subtype_Indication then
- LB := Low_Bound (Range_Expression (Constraint (N)));
- HB := High_Bound (Range_Expression (Constraint (N)));
-
- elsif Is_Entity_Name (N) then
- LB := Type_Low_Bound (Etype (N));
- HB := Type_High_Bound (Etype (N));
-
- else
- LB := Low_Bound (N);
- HB := High_Bound (N);
- end if;
-
- if Nam = Name_First then
- Bound := LB;
- else
- Bound := HB;
- end if;
-
- if Nkind (Bound) = N_Identifier
- and then Ekind (Entity (Bound)) = E_Discriminant
- then
- -- If this is a task discriminant, and we are the body, we must
- -- retrieve the corresponding body discriminal. This is another
- -- consequence of the early creation of discriminals, and the
- -- need to generate constraint checks before their declarations
- -- are made visible.
-
- if Is_Concurrent_Record_Type (Scope (Entity (Bound))) then
- declare
- Tsk : constant Entity_Id :=
- Corresponding_Concurrent_Type
- (Scope (Entity (Bound)));
- Disc : Entity_Id;
-
- begin
- if In_Open_Scopes (Tsk)
- and then Has_Completion (Tsk)
- then
- -- Find discriminant of original task, and use its
- -- current discriminal, which is the renaming within
- -- the task body.
-
- Disc := First_Discriminant (Tsk);
- while Present (Disc) loop
- if Chars (Disc) = Chars (Entity (Bound)) then
- Set_Scope (Discriminal (Disc), Tsk);
- return New_Occurrence_Of (Discriminal (Disc), Loc);
- end if;
-
- Next_Discriminant (Disc);
- end loop;
-
- -- That loop should always succeed in finding a matching
- -- entry and returning. Fatal error if not.
-
- raise Program_Error;
-
- else
- return
- New_Occurrence_Of (Discriminal (Entity (Bound)), Loc);
- end if;
- end;
- else
- return New_Occurrence_Of (Discriminal (Entity (Bound)), Loc);
- end if;
-
- elsif Nkind (Bound) = N_Identifier
- and then Ekind (Entity (Bound)) = E_In_Parameter
- and then not Inside_Init_Proc
- then
- return Get_Discriminal (E, Bound);
-
- elsif Nkind (Bound) = N_Integer_Literal then
- return Make_Integer_Literal (Loc, Intval (Bound));
-
- -- Case of a bound rewritten to an N_Raise_Constraint_Error node
- -- because it is an out-of-range value. Duplicate_Subexpr cannot be
- -- called on this node because an N_Raise_Constraint_Error is not
- -- side effect free, and we may not assume that we are in the proper
- -- context to remove side effects on it at the point of reference.
-
- elsif Nkind (Bound) = N_Raise_Constraint_Error then
- return New_Copy_Tree (Bound);
-
- else
- return Duplicate_Subexpr_No_Checks (Bound);
- end if;
+ return Make_Attribute_Reference (Loc,
+ Prefix => New_Occurrence_Of (E, Loc),
+ Attribute_Name => Nam,
+ Expressions => Exprs);
end Get_E_First_Or_Last;
-----------------
Make_Or_Else (Loc,
Left_Opnd =>
Make_Op_Lt (Loc,
- Left_Opnd => Get_E_First_Or_Last (Exptyp, Indx, Name_First),
- Right_Opnd => Get_E_First_Or_Last (Typ, Indx, Name_First)),
+ Left_Opnd =>
+ Get_E_First_Or_Last (Loc, Exptyp, Indx, Name_First),
+ Right_Opnd =>
+ Get_E_First_Or_Last (Loc, Typ, Indx, Name_First)),
Right_Opnd =>
Make_Op_Gt (Loc,
- Left_Opnd => Get_E_First_Or_Last (Exptyp, Indx, Name_Last),
- Right_Opnd => Get_E_First_Or_Last (Typ, Indx, Name_Last)));
+ Left_Opnd =>
+ Get_E_First_Or_Last (Loc, Exptyp, Indx, Name_Last),
+ Right_Opnd =>
+ Get_E_First_Or_Last (Loc, Typ, Indx, Name_Last)));
end Range_E_Cond;
------------------------
Make_Or_Else (Loc,
Left_Opnd =>
Make_Op_Ne (Loc,
- Left_Opnd => Get_E_First_Or_Last (Exptyp, Indx, Name_First),
- Right_Opnd => Get_E_First_Or_Last (Typ, Indx, Name_First)),
+ Left_Opnd =>
+ Get_E_First_Or_Last (Loc, Exptyp, Indx, Name_First),
+ Right_Opnd =>
+ Get_E_First_Or_Last (Loc, Typ, Indx, Name_First)),
+
Right_Opnd =>
Make_Op_Ne (Loc,
- Left_Opnd => Get_E_First_Or_Last (Exptyp, Indx, Name_Last),
- Right_Opnd => Get_E_First_Or_Last (Typ, Indx, Name_Last)));
+ Left_Opnd =>
+ Get_E_First_Or_Last (Loc, Exptyp, Indx, Name_Last),
+ Right_Opnd =>
+ Get_E_First_Or_Last (Loc, Typ, Indx, Name_Last)));
end Range_Equal_E_Cond;
------------------
Make_Or_Else (Loc,
Left_Opnd =>
Make_Op_Lt (Loc,
- Left_Opnd => Get_N_First (Expr, Indx),
- Right_Opnd => Get_E_First_Or_Last (Typ, Indx, Name_First)),
+ Left_Opnd =>
+ Get_N_First (Expr, Indx),
+ Right_Opnd =>
+ Get_E_First_Or_Last (Loc, Typ, Indx, Name_First)),
Right_Opnd =>
Make_Op_Gt (Loc,
- Left_Opnd => Get_N_Last (Expr, Indx),
- Right_Opnd => Get_E_First_Or_Last (Typ, Indx, Name_Last)));
+ Left_Opnd =>
+ Get_N_Last (Expr, Indx),
+ Right_Opnd =>
+ Get_E_First_Or_Last (Loc, Typ, Indx, Name_Last)));
end Range_N_Cond;
-- Start of processing for Selected_Range_Checks
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
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
