-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2005 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- --
--- ware Foundation; either version 2, or (at your option) any later ver- --
+-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
--- Public License distributed with GNAT; see file COPYING. If not, write --
--- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
--- Boston, MA 02110-1301, USA. --
+-- Public License distributed with GNAT; see file COPYING3. If not, go to --
+-- http://www.gnu.org/licenses for a complete copy of the license. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
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 Elists; use Elists;
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;
-- routine. The Do_Static flag indicates that only a static check is
-- to be done.
+ type Check_Type is new Check_Id range Access_Check .. Division_Check;
+ function Check_Needed (Nod : Node_Id; Check : Check_Type) return Boolean;
+ -- This function is used to see if an access or division by zero check is
+ -- needed. The check is to be applied to a single variable appearing in the
+ -- source, and N is the node for the reference. If N is not of this form,
+ -- True is returned with no further processing. If N is of the right form,
+ -- then further processing determines if the given Check is needed.
+ --
+ -- The particular circuit is to see if we have the case of a check that is
+ -- not needed because it appears in the right operand of a short circuited
+ -- conditional where the left operand guards the check. For example:
+ --
+ -- if Var = 0 or else Q / Var > 12 then
+ -- ...
+ -- end if;
+ --
+ -- In this example, the division check is not required. At the same time
+ -- we can issue warnings for suspicious use of non-short-circuited forms,
+ -- such as:
+ --
+ -- if Var = 0 or Q / Var > 12 then
+ -- ...
+ -- end if;
+
procedure Find_Check
(Expr : Node_Id;
Check_Type : Character;
-- of the enclosing protected operation). This clumsy transformation is
-- needed because privals are created too late and their actual subtypes
-- are not available when analysing the bodies of the protected operations.
+ -- This function is called whenever the bound is an entity and the scope
+ -- indicates a protected operation. If the bound is an in-parameter of
+ -- a protected operation that is not a prival, the function returns the
+ -- bound itself.
-- To be cleaned up???
function Guard_Access
-- that the access value is non-null, since the checks do not
-- not apply to null access values.
- procedure Install_Null_Excluding_Check (N : Node_Id);
- -- Determines whether an access node requires a runtime access check and
- -- if so inserts the appropriate run-time check
-
procedure Install_Static_Check (R_Cno : Node_Id; Loc : Source_Ptr);
-- Called by Apply_{Length,Range}_Checks to rewrite the tree with the
-- Constraint_Error node.
+ function Range_Or_Validity_Checks_Suppressed
+ (Expr : Node_Id) return Boolean;
+ -- Returns True if either range or validity checks or both are suppressed
+ -- for the type of the given expression, or, if the expression is the name
+ -- of an entity, if these checks are suppressed for the entity.
+
function Selected_Length_Checks
(Ck_Node : Node_Id;
Target_Typ : Entity_Id;
end if;
end Accessibility_Checks_Suppressed;
+ -----------------------------
+ -- Activate_Division_Check --
+ -----------------------------
+
+ procedure Activate_Division_Check (N : Node_Id) is
+ begin
+ Set_Do_Division_Check (N, True);
+ Possible_Local_Raise (N, Standard_Constraint_Error);
+ end Activate_Division_Check;
+
+ -----------------------------
+ -- Activate_Overflow_Check --
+ -----------------------------
+
+ procedure Activate_Overflow_Check (N : Node_Id) is
+ begin
+ Set_Do_Overflow_Check (N, True);
+ Possible_Local_Raise (N, Standard_Constraint_Error);
+ end Activate_Overflow_Check;
+
+ --------------------------
+ -- Activate_Range_Check --
+ --------------------------
+
+ procedure Activate_Range_Check (N : Node_Id) is
+ begin
+ Set_Do_Range_Check (N, True);
+ Possible_Local_Raise (N, Standard_Constraint_Error);
+ end Activate_Range_Check;
+
+ ---------------------------------
+ -- Alignment_Checks_Suppressed --
+ ---------------------------------
+
+ function Alignment_Checks_Suppressed (E : Entity_Id) return Boolean is
+ begin
+ if Present (E) and then Checks_May_Be_Suppressed (E) then
+ return Is_Check_Suppressed (E, Alignment_Check);
+ else
+ return Scope_Suppress (Alignment_Check);
+ end if;
+ end Alignment_Checks_Suppressed;
+
-------------------------
-- Append_Range_Checks --
-------------------------
P : constant Node_Id := Prefix (N);
begin
- if Inside_A_Generic then
- return;
- end if;
-
- if Is_Entity_Name (P) then
- Check_Unset_Reference (P);
- end if;
-
- -- We do not need access checks if prefix is known to be non-null
-
- if Known_Non_Null (P) then
- return;
-
- -- We do not need access checks if they are suppressed on the type
+ -- We do not need checks if we are not generating code (i.e. the
+ -- expander is not active). This is not just an optimization, there
+ -- are cases (e.g. with pragma Debug) where generating the checks
+ -- can cause real trouble).
- elsif Access_Checks_Suppressed (Etype (P)) then
+ if not Expander_Active then
return;
+ end if;
- -- We do not need checks if we are not generating code (i.e. the
- -- expander is not active). This is not just an optimization, there
- -- are cases (e.g. with pragma Debug) where generating the checks
- -- can cause real trouble).
+ -- No check if short circuiting makes check unnecessary
- elsif not Expander_Active then
+ if not Check_Needed (P, Access_Check) then
return;
end if;
- -- Case where P is an entity name
-
- if Is_Entity_Name (P) then
- declare
- Ent : constant Entity_Id := Entity (P);
+ -- No check if accessing the Offset_To_Top component of a dispatch
+ -- table. They are safe by construction.
- begin
- if Access_Checks_Suppressed (Ent) then
- return;
- end if;
-
- -- Otherwise we are going to generate an access check, and
- -- are we have done it, the entity will now be known non null
- -- But we have to check for safe sequential semantics here!
-
- if Safe_To_Capture_Value (N, Ent) then
- Set_Is_Known_Non_Null (Ent);
- end if;
- end;
+ 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)
+ then
+ return;
end if;
- -- Access check is required
+ -- Otherwise go ahead and install the check
Install_Null_Excluding_Check (P);
end Apply_Access_Check;
-- 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 parameter is deeper than the level of the
- -- target access type.
+ -- 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,
end if;
end Apply_Accessibility_Check;
- ---------------------------
- -- Apply_Alignment_Check --
- ---------------------------
+ --------------------------------
+ -- Apply_Address_Clause_Check --
+ --------------------------------
+
+ procedure Apply_Address_Clause_Check (E : Entity_Id; N : Node_Id) is
+ AC : constant Node_Id := Address_Clause (E);
+ Loc : constant Source_Ptr := Sloc (AC);
+ Typ : constant Entity_Id := Etype (E);
+ Aexp : constant Node_Id := Expression (AC);
- procedure Apply_Alignment_Check (E : Entity_Id; N : Node_Id) is
- AC : constant Node_Id := Address_Clause (E);
- Typ : constant Entity_Id := Etype (E);
Expr : Node_Id;
- Loc : Source_Ptr;
+ -- Address expression (not necessarily the same as Aexp, for example
+ -- when Aexp is a reference to a constant, in which case Expr gets
+ -- reset to reference the value expression of the constant.
- Alignment_Required : constant Boolean := Maximum_Alignment > 1;
- -- Constant to show whether target requires alignment checks
+ 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.
+
+ --------------------------------
+ -- Compile_Time_Bad_Alignment --
+ --------------------------------
+
+ procedure Compile_Time_Bad_Alignment is
+ begin
+ if Address_Clause_Overlay_Warnings then
+ Error_Msg_FE
+ ("?specified address for& may be inconsistent with alignment ",
+ Aexp, E);
+ Error_Msg_FE
+ ("\?program execution may be erroneous (RM 13.3(27))",
+ Aexp, E);
+ Set_Address_Warning_Posted (AC);
+ end if;
+ end Compile_Time_Bad_Alignment;
+
+ -- Start of processing for Apply_Address_Clause_Check
begin
- -- See if check needed. Note that we never need a check if the
- -- maximum alignment is one, since the check will always succeed
+ -- 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 not Alignment_Required
+ or else Maximum_Alignment = 1
then
return;
end if;
- Loc := Sloc (AC);
+ -- Obtain expression from address clause
+
Expr := Expression (AC);
- if Nkind (Expr) = N_Unchecked_Type_Conversion then
- Expr := Expression (Expr);
+ -- The following loop digs for the real expression to use in the check
- elsif Nkind (Expr) = N_Function_Call
- and then Is_Entity_Name (Name (Expr))
- and then Is_RTE (Entity (Name (Expr)), RE_To_Address)
- then
- Expr := First (Parameter_Associations (Expr));
+ loop
+ -- For constant, get constant expression
+
+ if Is_Entity_Name (Expr)
+ and then Ekind (Entity (Expr)) = E_Constant
+ then
+ Expr := Constant_Value (Entity (Expr));
+
+ -- For unchecked conversion, get result to convert
+
+ elsif Nkind (Expr) = N_Unchecked_Type_Conversion then
+ Expr := Expression (Expr);
+
+ -- For (common case) of To_Address call, get argument
- if Nkind (Expr) = N_Parameter_Association then
- Expr := Explicit_Actual_Parameter (Expr);
+ elsif Nkind (Expr) = N_Function_Call
+ and then Is_Entity_Name (Name (Expr))
+ and then Is_RTE (Entity (Name (Expr)), RE_To_Address)
+ then
+ Expr := First (Parameter_Associations (Expr));
+
+ if Nkind (Expr) = N_Parameter_Association then
+ Expr := Explicit_Actual_Parameter (Expr);
+ end if;
+
+ -- We finally have the real expression
+
+ else
+ exit;
end if;
- end if;
+ end loop;
- -- Here Expr is the address value. See if we know that the
- -- value is unacceptable 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))
end if;
if Expr_Value (Expr) mod AL /= 0 then
- Insert_Action (N,
- Make_Raise_Program_Error (Loc,
- Reason => PE_Misaligned_Address_Value));
- Error_Msg_NE
- ("?specified address for& not " &
- "consistent with alignment ('R'M 13.3(27))", Expr, E);
+ Compile_Time_Bad_Alignment;
+ else
+ return;
end if;
end;
- -- Here we do not know if the value is acceptable, generate
- -- code to raise PE if alignment is inappropriate.
+ -- 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
+ return;
+ end if;
+
+ -- Here we do not know if the value is acceptable. Stricly we don't have
+ -- to do anything, since if the alignment is bad, we have an erroneous
+ -- program. However we are allowed to check for erroneous conditions and
+ -- we decide to do this by default if the check is not suppressed.
+
+ -- However, don't do the check if elaboration code is unwanted
+
+ if Restriction_Active (No_Elaboration_Code) then
+ return;
+
+ -- Generate a check to raise PE if alignment may be inappropriate
else
- -- Skip generation of this code if we don't want elab code
+ -- If the original expression is a non-static constant, use the
+ -- name of the constant itself rather than duplicating its
+ -- defining expression, which was extracted above.
- if not Restriction_Active (No_Elaboration_Code) then
- Insert_After_And_Analyze (N,
- Make_Raise_Program_Error (Loc,
- Condition =>
- Make_Op_Ne (Loc,
- Left_Opnd =>
- Make_Op_Mod (Loc,
- Left_Opnd =>
- Unchecked_Convert_To
- (RTE (RE_Integer_Address),
- Duplicate_Subexpr_No_Checks (Expr)),
- Right_Opnd =>
- Make_Attribute_Reference (Loc,
- Prefix => New_Occurrence_Of (E, Loc),
- Attribute_Name => Name_Alignment)),
- Right_Opnd => Make_Integer_Literal (Loc, Uint_0)),
- Reason => PE_Misaligned_Address_Value),
- Suppress => All_Checks);
+ -- Note: Expr is empty if the address-clause is applied to in-mode
+ -- actuals (allowed by 13.1(22)).
+
+ if not Present (Expr)
+ or else
+ (Is_Entity_Name (Expression (AC))
+ and then Ekind (Entity (Expression (AC))) = E_Constant
+ and then Nkind (Parent (Entity (Expression (AC))))
+ = N_Object_Declaration)
+ then
+ Expr := New_Copy_Tree (Expression (AC));
+ else
+ Remove_Side_Effects (Expr);
end if;
- end if;
- return;
+ Insert_After_And_Analyze (N,
+ Make_Raise_Program_Error (Loc,
+ Condition =>
+ Make_Op_Ne (Loc,
+ Left_Opnd =>
+ Make_Op_Mod (Loc,
+ Left_Opnd =>
+ Unchecked_Convert_To
+ (RTE (RE_Integer_Address), Expr),
+ Right_Opnd =>
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Occurrence_Of (E, Loc),
+ Attribute_Name => Name_Alignment)),
+ Right_Opnd => Make_Integer_Literal (Loc, Uint_0)),
+ Reason => PE_Misaligned_Address_Value),
+ Suppress => All_Checks);
+ return;
+ end if;
exception
+ -- If we have some missing run time component in configurable run time
+ -- mode then just skip the check (it is not required in any case).
+
when RE_Not_Available =>
return;
- end Apply_Alignment_Check;
+ end Apply_Address_Clause_Check;
-------------------------------------
-- 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;
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.
-
- if Backend_Overflow_Checks_On_Target
- or else not Do_Overflow_Check (N)
- or else not Expander_Active
- then
- return;
- end if;
-
- -- Otherwise, we generate the full general code for front end overflow
- -- detection, which works by doing arithmetic in a larger type:
-
- -- x op y
-
- -- is expanded into
+ -- An interesting special case. If the arithmetic operation appears as
+ -- the operand of a type conversion:
- -- Typ (Checktyp (x) op Checktyp (y));
+ -- type1 (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.
+ -- and all the following conditions apply:
- -- In the case where check type exceeds the size of Long_Long_Integer,
- -- we use a different approach, expanding to:
+ -- 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
- -- typ (xxx_With_Ovflo_Check (Integer_64 (x), Integer (y)))
+ -- then we don't do an overflow check in any case, instead we transform
+ -- the operation so that we end up with:
- -- where xxx is Add, Multiply or Subtract as appropriate
+ -- type1 (type1 (x) op type1 (y))
- -- Find check type if one exists
+ -- This avoids intermediate overflow before the conversion. It is
+ -- explicitly permitted by RM 3.5.4(24):
- if Dsiz <= Standard_Integer_Size then
- Ctyp := Standard_Integer;
+ -- 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.
- elsif Dsiz <= Standard_Long_Long_Integer_Size then
- Ctyp := Standard_Long_Long_Integer;
+ -- 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.
- -- No check type exists, use runtime call
+ -- 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.
- else
- if Nkind (N) = N_Op_Add then
- Cent := RE_Add_With_Ovflo_Check;
-
- elsif Nkind (N) = N_Op_Multiply then
- Cent := RE_Multiply_With_Ovflo_Check;
-
- else
- pragma Assert (Nkind (N) = N_Op_Subtract);
- Cent := RE_Subtract_With_Ovflo_Check;
- end if;
-
- 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))))));
+ -- 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).
- Analyze_And_Resolve (N, Typ);
- return;
- end if;
+ if Is_Signed_Integer_Type (Typ)
+ and then Nkind (Parent (N)) = N_Type_Conversion
+ then
+ declare
+ Target_Type : constant Entity_Id :=
+ Base_Type (Entity (Subtype_Mark (Parent (N))));
- -- 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.
+ Llo, Lhi : Uint;
+ Rlo, Rhi : Uint;
+ LOK, ROK : Boolean;
- Opnod := Relocate_Node (N);
+ Vlo : Uint;
+ Vhi : Uint;
+ VOK : Boolean;
- Opnd := OK_Convert_To (Ctyp, Left_Opnd (Opnod));
+ Tlo : Uint;
+ Thi : Uint;
- Analyze (Opnd);
- Set_Etype (Opnd, Ctyp);
- Set_Analyzed (Opnd, True);
- Set_Left_Opnd (Opnod, Opnd);
+ 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));
- Opnd := OK_Convert_To (Ctyp, Right_Opnd (Opnod));
+ Determine_Range
+ (Left_Opnd (N), LOK, Llo, Lhi, Assume_Valid => True);
+ Determine_Range
+ (Right_Opnd (N), ROK, Rlo, Rhi, Assume_Valid => True);
- Analyze (Opnd);
- Set_Etype (Opnd, Ctyp);
- Set_Analyzed (Opnd, True);
- Set_Right_Opnd (Opnod, Opnd);
+ 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);
- -- 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.
+ 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))));
- Set_Etype (Opnod, Base_Type (Ctyp));
- Set_Do_Overflow_Check (Opnod, False);
- Set_Analyzed (Opnod, True);
+ Rewrite (Right_Opnd (N),
+ Make_Type_Conversion (Loc,
+ Subtype_Mark => New_Occurrence_Of (Target_Type, Loc),
+ Expression => Relocate_Node (Right_Opnd (N))));
- -- Now build the outer conversion
+ -- Rewrite the conversion operand so that the original
+ -- node is retained, in order to avoid the warning for
+ -- redundant conversions in Resolve_Type_Conversion.
- Opnd := OK_Convert_To (Typ, Opnod);
- Analyze (Opnd);
- Set_Etype (Opnd, Typ);
+ Rewrite (N, Relocate_Node (N));
- -- In the discrete type case, we directly generate the range check
- -- for the outer operand. This range check will implement the required
- -- overflow check.
+ Set_Etype (N, Target_Type);
- if Is_Discrete_Type (Typ) then
- Rewrite (N, Opnd);
- Generate_Range_Check (Expression (N), Typ, CE_Overflow_Check_Failed);
+ Analyze_And_Resolve (Left_Opnd (N), Target_Type);
+ Analyze_And_Resolve (Right_Opnd (N), Target_Type);
- -- 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.
+ -- 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.
- else
- Set_Analyzed (Opnd, True);
- Enable_Overflow_Check (Opnd);
- Rewrite (N, Opnd);
+ Set_Do_Overflow_Check (N, False);
+ return;
+ end if;
+ end if;
+ end if;
+ end;
end if;
- exception
- when RE_Not_Available =>
- return;
- end Apply_Arithmetic_Overflow_Check;
-
- ----------------------------
- -- Apply_Array_Size_Check --
- ----------------------------
-
- -- The situation is as follows. In GNAT 3 (GCC 2.x), the size in bits
- -- is computed in 32 bits without an overflow check. That's a real
- -- problem for Ada. So what we do in GNAT 3 is to approximate the
- -- size of an array by manually multiplying the element size by the
- -- number of elements, and comparing that against the allowed limits.
+ -- Now see if an overflow check is required
- -- In GNAT 5, the size in byte is still computed in 32 bits without
- -- an overflow check in the dynamic case, but the size in bits is
- -- computed in 64 bits. We assume that's good enough, and we do not
- -- bother to generate any front end test.
+ 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;
- procedure Apply_Array_Size_Check (N : Node_Id; Typ : Entity_Id) is
- Loc : constant Source_Ptr := Sloc (N);
- Ctyp : constant Entity_Id := Component_Type (Typ);
- Ent : constant Entity_Id := Defining_Identifier (N);
- Decl : Node_Id;
- Lo : Node_Id;
- Hi : Node_Id;
- Lob : Uint;
- Hib : Uint;
- Siz : Uint;
- Xtyp : Entity_Id;
- Indx : Node_Id;
- Sizx : Node_Id;
- Code : Node_Id;
-
- Static : Boolean := True;
- -- Set false if any index subtye bound is non-static
-
- Umark : constant Uintp.Save_Mark := Uintp.Mark;
- -- We can throw away all the Uint computations here, since they are
- -- done only to generate boolean test results.
-
- Check_Siz : Uint;
- -- Size to check against
-
- function Is_Address_Or_Import (Decl : Node_Id) return Boolean;
- -- Determines if Decl is an address clause or Import/Interface pragma
- -- that references the defining identifier of the current declaration.
-
- --------------------------
- -- Is_Address_Or_Import --
- --------------------------
-
- function Is_Address_Or_Import (Decl : Node_Id) return Boolean is
begin
- if Nkind (Decl) = N_At_Clause then
- return Chars (Identifier (Decl)) = Chars (Ent);
-
- elsif Nkind (Decl) = N_Attribute_Definition_Clause then
- return
- Chars (Decl) = Name_Address
- and then
- Nkind (Name (Decl)) = N_Identifier
- and then
- Chars (Name (Decl)) = Chars (Ent);
-
- elsif Nkind (Decl) = N_Pragma then
- if (Chars (Decl) = Name_Import
- or else
- Chars (Decl) = Name_Interface)
- and then Present (Pragma_Argument_Associations (Decl))
- then
- declare
- F : constant Node_Id :=
- First (Pragma_Argument_Associations (Decl));
-
- begin
- return
- Present (F)
- and then
- Present (Next (F))
- and then
- Nkind (Expression (Next (F))) = N_Identifier
- and then
- Chars (Expression (Next (F))) = Chars (Ent);
- end;
-
- else
- return False;
- end if;
-
- else
- return False;
+ -- 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;
- end Is_Address_Or_Import;
- -- Start of processing for Apply_Array_Size_Check
+ -- Otherwise, generate the full general code for front end overflow
+ -- detection, which works by doing arithmetic in a larger type:
- begin
- -- Do size check on local arrays. We only need this in the GCC 2
- -- case, since in GCC 3, we expect the back end to properly handle
- -- things. This routine can be removed when we baseline GNAT 3.
+ -- x op y
- if Opt.GCC_Version >= 3 then
- return;
- end if;
+ -- is expanded into
- -- No need for a check if not expanding
+ -- Typ (Checktyp (x) op Checktyp (y));
- if not Expander_Active then
- return;
- end if;
+ -- where Typ is the type of the original expression, and Checktyp is
+ -- an integer type of sufficient length to hold the largest possible
+ -- result.
- -- No need for a check if checks are suppressed
+ -- If the size of check type exceeds the size of Long_Long_Integer,
+ -- we use a different approach, expanding to:
- if Storage_Checks_Suppressed (Typ) then
- return;
- end if;
+ -- typ (xxx_With_Ovflo_Check (Integer_64 (x), Integer (y)))
- -- It is pointless to insert this check inside an init proc, because
- -- that's too late, we have already built the object to be the right
- -- size, and if it's too large, too bad!
+ -- where xxx is Add, Multiply or Subtract as appropriate
- if Inside_Init_Proc then
- return;
- end if;
+ -- Find check type if one exists
- -- Look head for pragma interface/import or address clause applying
- -- to this entity. If found, we suppress the check entirely. For now
- -- we only look ahead 20 declarations to stop this becoming too slow
- -- Note that eventually this whole routine gets moved to gigi.
+ if Dsiz <= Standard_Integer_Size then
+ Ctyp := Standard_Integer;
- Decl := N;
- for Ctr in 1 .. 20 loop
- Next (Decl);
- exit when No (Decl);
+ elsif Dsiz <= Standard_Long_Long_Integer_Size then
+ Ctyp := Standard_Long_Long_Integer;
- if Is_Address_Or_Import (Decl) then
- return;
- end if;
- end loop;
+ -- No check type exists, use runtime call
- -- First step is to calculate the maximum number of elements. For
- -- this calculation, we use the actual size of the subtype if it is
- -- static, and if a bound of a subtype is non-static, we go to the
- -- bound of the base type.
+ else
+ if Nkind (N) = N_Op_Add then
+ Cent := RE_Add_With_Ovflo_Check;
- Siz := Uint_1;
- Indx := First_Index (Typ);
- while Present (Indx) loop
- Xtyp := Etype (Indx);
- Lo := Type_Low_Bound (Xtyp);
- Hi := Type_High_Bound (Xtyp);
+ elsif Nkind (N) = N_Op_Multiply then
+ Cent := RE_Multiply_With_Ovflo_Check;
- -- If any bound raises constraint error, we will never get this
- -- far, so there is no need to generate any kind of check.
+ else
+ pragma Assert (Nkind (N) = N_Op_Subtract);
+ Cent := RE_Subtract_With_Ovflo_Check;
+ end if;
- if Raises_Constraint_Error (Lo)
- or else
- Raises_Constraint_Error (Hi)
- then
- Uintp.Release (Umark);
+ 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))))));
+
+ Analyze_And_Resolve (N, Typ);
return;
end if;
- -- Otherwise get bounds values
+ -- 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.
- if Is_Static_Expression (Lo) then
- Lob := Expr_Value (Lo);
- else
- Lob := Expr_Value (Type_Low_Bound (Base_Type (Xtyp)));
- Static := False;
- end if;
+ Opnod := Relocate_Node (N);
- if Is_Static_Expression (Hi) then
- Hib := Expr_Value (Hi);
- else
- Hib := Expr_Value (Type_High_Bound (Base_Type (Xtyp)));
- Static := False;
- end if;
-
- Siz := Siz * UI_Max (Hib - Lob + 1, Uint_0);
- Next_Index (Indx);
- end loop;
+ Opnd := OK_Convert_To (Ctyp, Left_Opnd (Opnod));
- -- Compute the limit against which we want to check. For subprograms,
- -- where the array will go on the stack, we use 8*2**24, which (in
- -- bits) is the size of a 16 megabyte array.
+ Analyze (Opnd);
+ Set_Etype (Opnd, Ctyp);
+ Set_Analyzed (Opnd, True);
+ Set_Left_Opnd (Opnod, Opnd);
- if Is_Subprogram (Scope (Ent)) then
- Check_Siz := Uint_2 ** 27;
- else
- Check_Siz := Uint_2 ** 31;
- end if;
+ Opnd := OK_Convert_To (Ctyp, Right_Opnd (Opnod));
- -- If we have all static bounds and Siz is too large, then we know
- -- we know we have a storage error right now, so generate message
+ Analyze (Opnd);
+ Set_Etype (Opnd, Ctyp);
+ Set_Analyzed (Opnd, True);
+ Set_Right_Opnd (Opnod, Opnd);
- if Static and then Siz >= Check_Siz then
- Insert_Action (N,
- Make_Raise_Storage_Error (Loc,
- Reason => SE_Object_Too_Large));
- Error_Msg_N ("?Storage_Error will be raised at run-time", N);
- Uintp.Release (Umark);
- return;
- end if;
+ -- 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.
- -- Case of component size known at compile time. If the array
- -- size is definitely in range, then we do not need a check.
+ Set_Etype (Opnod, Base_Type (Ctyp));
+ Set_Do_Overflow_Check (Opnod, False);
+ Set_Analyzed (Opnod, True);
- if Known_Esize (Ctyp)
- and then Siz * Esize (Ctyp) < Check_Siz
- then
- Uintp.Release (Umark);
- return;
- end if;
+ -- Now build the outer conversion
- -- Here if a dynamic check is required
+ Opnd := OK_Convert_To (Typ, Opnod);
+ Analyze (Opnd);
+ Set_Etype (Opnd, Typ);
- -- What we do is to build an expression for the size of the array,
- -- which is computed as the 'Size of the array component, times
- -- the size of each dimension.
+ -- In the discrete type case, we directly generate the range check
+ -- for the outer operand. This range check will implement the
+ -- required overflow check.
- Uintp.Release (Umark);
+ if Is_Discrete_Type (Typ) then
+ Rewrite (N, Opnd);
+ Generate_Range_Check
+ (Expression (N), Typ, CE_Overflow_Check_Failed);
- Sizx :=
- Make_Attribute_Reference (Loc,
- Prefix => New_Occurrence_Of (Ctyp, Loc),
- Attribute_Name => Name_Size);
+ -- 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.
- Indx := First_Index (Typ);
- for J in 1 .. Number_Dimensions (Typ) loop
- if Sloc (Etype (Indx)) = Sloc (N) then
- Ensure_Defined (Etype (Indx), N);
+ else
+ Set_Analyzed (Opnd, True);
+ Enable_Overflow_Check (Opnd);
+ Rewrite (N, Opnd);
end if;
- Sizx :=
- Make_Op_Multiply (Loc,
- Left_Opnd => Sizx,
- Right_Opnd =>
- Make_Attribute_Reference (Loc,
- Prefix => New_Occurrence_Of (Typ, Loc),
- Attribute_Name => Name_Length,
- Expressions => New_List (
- Make_Integer_Literal (Loc, J))));
- Next_Index (Indx);
- end loop;
-
- -- Emit the check
-
- Code :=
- Make_Raise_Storage_Error (Loc,
- Condition =>
- Make_Op_Ge (Loc,
- Left_Opnd => Sizx,
- Right_Opnd =>
- Make_Integer_Literal (Loc,
- Intval => Check_Siz)),
- Reason => SE_Object_Too_Large);
-
- Set_Size_Check_Code (Defining_Identifier (N), Code);
- Insert_Action (N, Code, Suppress => All_Checks);
- end Apply_Array_Size_Check;
+ exception
+ when RE_Not_Available =>
+ return;
+ end;
+ end Apply_Arithmetic_Overflow_Check;
----------------------------
-- Apply_Constraint_Check --
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
-- No checks necessary if expression statically null
- if Nkind (N) = N_Null then
- null;
+ if Known_Null (N) then
+ if Can_Never_Be_Null (Typ) then
+ Install_Null_Excluding_Check (N);
+ end if;
-- No sliding possible on access to arrays
Apply_Discriminant_Check (N, Typ);
end if;
+ -- 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.
+
if Can_Never_Be_Null (Typ)
and then not Can_Never_Be_Null (Etype (N))
+ and then not Error_Posted (N)
then
Install_Null_Excluding_Check (N);
end if;
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
-- discriminated component assigned in the expansion of an aggregate
-- in an initialization, the check must be suppressed. This unusual
- -- situation requires a predicate of its own (see 7503-008).
+ -- 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 --
return;
end if;
- -- No discriminant checks necessary for an access when expression
- -- is statically Null. This is not only an optimization, this is
- -- fundamental because otherwise discriminant checks may be generated
- -- in init procs for types containing an access to a not-yet-frozen
- -- record, causing a deadly forward reference.
+ -- No discriminant checks necessary for an access when expression is
+ -- statically Null. This is not only an optimization, it is fundamental
+ -- because otherwise discriminant checks may be generated in init procs
+ -- for types containing an access to a not-yet-frozen record, causing a
+ -- deadly forward reference.
- -- Also, if the expression is of an access type whose designated
- -- type is incomplete, then the access value must be null and
- -- we suppress the check.
+ -- Also, if the expression is of an access type whose designated type is
+ -- incomplete, then the access value must be null and we suppress the
+ -- check.
- if Nkind (N) = N_Null then
+ if Known_Null (N) then
return;
elsif Is_Access_Type (S_Typ) then
end if;
end if;
- -- If an assignment target is present, then we need to generate
- -- the actual subtype if the target is a parameter or aliased
- -- object with an unconstrained nominal subtype.
+ -- If an assignment target is present, then we need to generate the
+ -- actual subtype if the target is a parameter or aliased object with
+ -- an unconstrained nominal subtype.
+
+ -- 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).
if Present (Lhs)
and then (Present (Param_Entity (Lhs))
- or else (not Is_Constrained (T_Typ)
+ 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))
+ and then not Is_Aliased_Unconstrained_Component)
+ or else (Ada_Version >= Ada_2005
+ and then not Is_Constrained (T_Typ)
+ and then Denotes_Explicit_Dereference (Lhs)
+ and then Nkind (Original_Node (Lhs)) /=
+ N_Function_Call))
then
T_Typ := Get_Actual_Subtype (Lhs);
end if;
- -- Nothing to do if the type is unconstrained (this is the case
- -- where the actual subtype in the RM sense of N is unconstrained
- -- and no check is required).
+ -- Nothing to do if the type is unconstrained (this is the case where
+ -- the actual subtype in the RM sense of N is unconstrained and no check
+ -- is required).
if not Is_Constrained (T_Typ) then
return;
-- 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;
return;
end if;
- -- Suppress checks if the subtypes are the same.
- -- the check must be preserved in an assignment to a formal, because
- -- the constraint is given by the actual.
+ -- Suppress checks if the subtypes are the same. the check must be
+ -- preserved in an assignment to a formal, because the constraint is
+ -- given by the actual.
if Nkind (Original_Node (N)) /= N_Allocator
and then (No (Lhs)
return;
end if;
- -- We can also eliminate checks on allocators with a subtype mark
- -- that coincides with the context type. The context type may be a
- -- subtype without a constraint (common case, a generic actual).
+ -- We can also eliminate checks on allocators with a subtype mark that
+ -- coincides with the context type. The context type may be a subtype
+ -- without a constraint (common case, a generic actual).
elsif Nkind (Original_Node (N)) = N_Allocator
and then Is_Entity_Name (Expression (Original_Node (N)))
end;
end if;
- -- See if we have a case where the types are both constrained, and
- -- all the constraints are constants. In this case, we can do the
- -- check successfully at compile time.
+ -- See if we have a case where the types are both constrained, and all
+ -- the constraints are constants. In this case, we can do the check
+ -- successfully at compile time.
-- We skip this check for the case where the node is a rewritten`
-- allocator, because it already carries the context subtype, and
begin
-- S_Typ may not have discriminants in the case where it is a
- -- private type completed by a default discriminated type. In
- -- that case, we need to get the constraints from the
- -- underlying_type. If the underlying type is unconstrained (i.e.
- -- has no default discriminants) no check is needed.
+ -- private type completed by a default discriminated type. In that
+ -- case, we need to get the constraints from the underlying_type.
+ -- If the underlying type is unconstrained (i.e. has no default
+ -- discriminants) no check is needed.
if Has_Discriminants (S_Typ) then
Discr := First_Discriminant (S_Typ);
ItemS := Node (DconS);
ItemT := Node (DconT);
- exit when
- not Is_OK_Static_Expression (ItemS)
- or else
- not Is_OK_Static_Expression (ItemT);
+ -- For a discriminated component type constrained by the
+ -- current instance of an enclosing type, there is no
+ -- applicable discriminant check.
+
+ if Nkind (ItemT) = N_Attribute_Reference
+ and then Is_Access_Type (Etype (ItemT))
+ and then Is_Entity_Name (Prefix (ItemT))
+ and then Is_Type (Entity (Prefix (ItemT)))
+ then
+ return;
+ end if;
+
+ -- If the expressions for the discriminants are identical
+ -- and it is side-effect free (for now just an entity),
+ -- this may be a shared constraint, e.g. from a subtype
+ -- without a constraint introduced as a generic actual.
+ -- Examine other discriminants if any.
+
+ if ItemS = ItemT
+ and then Is_Entity_Name (ItemS)
+ then
+ null;
+
+ elsif not Is_OK_Static_Expression (ItemS)
+ or else not Is_OK_Static_Expression (ItemT)
+ then
+ exit;
- if Expr_Value (ItemS) /= Expr_Value (ItemT) then
+ elsif Expr_Value (ItemS) /= Expr_Value (ItemT) then
if Do_Access then -- needs run-time check.
exit;
else
LOK : Boolean;
Rlo : Uint;
Rhi : Uint;
- ROK : Boolean;
+ ROK : Boolean;
+
+ pragma Warnings (Off, Lhi);
+ -- Don't actually use this value
begin
if Expander_Active
- and not Backend_Divide_Checks_On_Target
+ 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.
Make_Raise_Constraint_Error (Loc,
Condition =>
Make_Op_Eq (Loc,
- Left_Opnd => Duplicate_Subexpr_Move_Checks (Right),
+ Left_Opnd => Duplicate_Subexpr_Move_Checks (Right),
Right_Opnd => Make_Integer_Literal (Loc, 0)),
Reason => CE_Divide_By_Zero));
end if;
-- Test for extremely annoying case of xxx'First divided by -1
if Do_Overflow_Check (N) then
-
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))
-- Apply_Float_Conversion_Check --
----------------------------------
- -- Let F and I be the source and target types of the conversion.
- -- The Ada standard specifies that a floating-point value X is rounded
- -- to the nearest integer, with halfway cases being rounded away from
- -- zero. The rounded value of X is checked against I'Range.
+ -- Let F and I be the source and target types of the conversion. The RM
+ -- specifies that a floating-point value X is rounded to the nearest
+ -- integer, with halfway cases being rounded away from zero. The rounded
+ -- value of X is checked against I'Range.
+
+ -- The catch in the above paragraph is that there is no good way to know
+ -- whether the round-to-integer operation resulted in overflow. A remedy is
+ -- to perform a range check in the floating-point domain instead, however:
- -- The catch in the above paragraph is that there is no good way
- -- to know whether the round-to-integer operation resulted in
- -- overflow. A remedy is to perform a range check in the floating-point
- -- domain instead, however:
-- (1) The bounds may not be known at compile time
- -- (2) The check must take into account possible rounding.
+ -- (2) The check must take into account rounding or truncation.
-- (3) The range of type I may not be exactly representable in F.
- -- (4) The end-points I'First - 0.5 and I'Last + 0.5 may or may
- -- not be in range, depending on the sign of I'First and I'Last.
+ -- (4) For the rounding case, The end-points I'First - 0.5 and
+ -- I'Last + 0.5 may or may not be in range, depending on the
+ -- sign of I'First and I'Last.
-- (5) X may be a NaN, which will fail any comparison
- -- The following steps take care of these issues converting X:
+ -- The following steps correctly convert X with rounding:
+
-- (1) If either I'First or I'Last is not known at compile time, use
-- I'Base instead of I in the next three steps and perform a
-- regular range check against I'Range after conversion.
-- (2) If I'First - 0.5 is representable in F then let Lo be that
-- value and define Lo_OK as (I'First > 0). Otherwise, let Lo be
- -- F'Machine (T) and let Lo_OK be (Lo >= I'First). In other words,
- -- take one of the closest floating-point numbers to T, and see if
- -- it is in range or not.
+ -- F'Machine (I'First) and let Lo_OK be (Lo >= I'First).
+ -- In other words, take one of the closest floating-point numbers
+ -- (which is an integer value) to I'First, and see if it is in
+ -- range or not.
-- (3) If I'Last + 0.5 is representable in F then let Hi be that value
-- and define Hi_OK as (I'Last < 0). Otherwise, let Hi be
- -- F'Rounding (T) and let Hi_OK be (Hi <= I'Last).
+ -- F'Machine (I'Last) and let Hi_OK be (Hi <= I'Last).
-- (4) Raise CE when (Lo_OK and X < Lo) or (not Lo_OK and X <= Lo)
-- or (Hi_OK and X > Hi) or (not Hi_OK and X >= Hi)
+ -- For the truncating case, replace steps (2) and (3) as follows:
+ -- (2) If I'First > 0, then let Lo be F'Pred (I'First) and let Lo_OK
+ -- be False. Otherwise, let Lo be F'Succ (I'First - 1) and let
+ -- Lo_OK be True.
+ -- (3) If I'Last < 0, then let Hi be F'Succ (I'Last) and let Hi_OK
+ -- be False. Otherwise let Hi be F'Pred (I'Last + 1) and let
+ -- Hi_OK be False
+
procedure Apply_Float_Conversion_Check
(Ck_Node : Node_Id;
Target_Typ : Entity_Id)
is
- LB : constant Node_Id := Type_Low_Bound (Target_Typ);
- HB : constant Node_Id := Type_High_Bound (Target_Typ);
+ LB : constant Node_Id := Type_Low_Bound (Target_Typ);
+ HB : constant Node_Id := Type_High_Bound (Target_Typ);
Loc : constant Source_Ptr := Sloc (Ck_Node);
Expr_Type : constant Entity_Id := Base_Type (Etype (Ck_Node));
- Target_Base : constant Entity_Id := Implementation_Base_Type
- (Target_Typ);
- Max_Bound : constant Uint := UI_Expon
- (Machine_Radix (Expr_Type),
- Machine_Mantissa (Expr_Type) - 1) - 1;
+ Target_Base : constant Entity_Id :=
+ Implementation_Base_Type (Target_Typ);
+
+ Par : constant Node_Id := Parent (Ck_Node);
+ pragma Assert (Nkind (Par) = N_Type_Conversion);
+ -- Parent of check node, must be a type conversion
+
+ Truncate : constant Boolean := Float_Truncate (Par);
+ Max_Bound : constant Uint :=
+ UI_Expon
+ (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
- Ifirst,
- Ilast : Uint; -- Bounds of integer type
- Lo, Hi : Ureal; -- Bounds to check in floating-point domain
- Lo_OK,
- Hi_OK : Boolean; -- True iff Lo resp. Hi belongs to I'Range
+ Ifirst, Ilast : Uint;
+ -- Bounds of integer type
- Lo_Chk,
- Hi_Chk : Node_Id; -- Expressions that are False iff check fails
+ Lo, Hi : Ureal;
+ -- Bounds to check in floating-point domain
- Reason : RT_Exception_Code;
+ Lo_OK, Hi_OK : Boolean;
+ -- True iff Lo resp. Hi belongs to I'Range
+
+ Lo_Chk, Hi_Chk : Node_Id;
+ -- Expressions that are False iff check fails
+
+ Reason : RT_Exception_Code;
begin
if not Compile_Time_Known_Value (LB)
or not Compile_Time_Known_Value (HB)
then
declare
- -- First check that the value falls in the range of the base
- -- type, to prevent overflow during conversion and then
- -- perform a regular range check against the (dynamic) bounds.
-
- Par : constant Node_Id := Parent (Ck_Node);
+ -- First check that the value falls in the range of the base type,
+ -- to prevent overflow during conversion and then perform a
+ -- regular range check against the (dynamic) bounds.
pragma Assert (Target_Base /= Target_Typ);
- pragma Assert (Nkind (Par) = N_Type_Conversion);
- 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);
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 abs (Ifirst) < Max_Bound then
+ if Truncate and then Ifirst > 0 then
+ Lo := Pred (Expr_Type, UR_From_Uint (Ifirst));
+ Lo_OK := False;
+
+ elsif Truncate then
+ Lo := Succ (Expr_Type, UR_From_Uint (Ifirst - 1));
+ Lo_OK := True;
+
+ elsif abs (Ifirst) < Max_Bound then
Lo := UR_From_Uint (Ifirst) - Ureal_Half;
Lo_OK := (Ifirst > 0);
+
else
Lo := Machine (Expr_Type, UR_From_Uint (Ifirst), Round_Even, Ck_Node);
Lo_OK := (Lo >= UR_From_Uint (Ifirst));
-- Check against higher bound
- if abs (Ilast) < Max_Bound then
+ if Truncate and then Ilast < 0 then
+ Hi := Succ (Expr_Type, UR_From_Uint (Ilast));
+ Lo_OK := False;
+
+ elsif Truncate then
+ Hi := Pred (Expr_Type, UR_From_Uint (Ilast + 1));
+ Hi_OK := True;
+
+ elsif abs (Ilast) < Max_Bound then
Hi := UR_From_Uint (Ilast) + Ureal_Half;
Hi_OK := (Ilast < 0);
else
Right_Opnd => Make_Real_Literal (Loc, Hi));
end if;
- -- If the bounds of the target type are the same as those of the
- -- base type, the check is an overflow check as a range check is
- -- not performed in these cases.
+ -- If the bounds of the target type are the same as those of the base
+ -- type, the check is an overflow check as a range check is not
+ -- performed in these cases.
if Expr_Value (Type_Low_Bound (Target_Base)) = Ifirst
and then Expr_Value (Type_High_Bound (Target_Base)) = Ilast
(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 --
-----------------------
-- Apply_Scalar_Range_Check --
------------------------------
- -- Note that Apply_Scalar_Range_Check never turns the Do_Range_Check
- -- flag off if it is already set on.
+ -- Note that Apply_Scalar_Range_Check never turns the Do_Range_Check flag
+ -- off if it is already set on.
procedure Apply_Scalar_Range_Check
(Expr : Node_Id;
-- range of the subscript, since we don't know the actual subtype.
Int_Real : Boolean;
- -- Set to True if Expr should be regarded as a real value
- -- even though the type of Expr might be discrete.
+ -- Set to True if Expr should be regarded as a real value even though
+ -- the type of Expr might be discrete.
procedure Bad_Value;
-- Procedure called if value is determined to be out of range
-- Start of processing for Apply_Scalar_Range_Check
begin
- if Inside_A_Generic then
- return;
+ -- Return if check obviously not needed
- -- Return if check obviously not needed. Note that we do not check
- -- for the expander being inactive, since this routine does not
- -- insert any code, but it does generate useful warnings sometimes,
- -- which we would like even if we are in semantics only mode.
+ if
+ -- Not needed inside generic
- elsif Target_Typ = Any_Type
- or else not Is_Scalar_Type (Target_Typ)
- or else Raises_Constraint_Error (Expr)
+ Inside_A_Generic
+
+ -- Not needed if previous error
+
+ or else Target_Typ = Any_Type
+ or else Nkind (Expr) = N_Error
+
+ -- Not needed for non-scalar type
+
+ or else not Is_Scalar_Type (Target_Typ)
+
+ -- Not needed if we know node raises CE already
+
+ or else Raises_Constraint_Error (Expr)
then
return;
end if;
then
return;
- -- If Expr is part of an assignment statement, then check
- -- left side of assignment if it is an entity name.
+ -- If Expr is part of an assignment statement, then check left
+ -- side of assignment if it is an entity name.
elsif Nkind (Parnt) = N_Assignment_Statement
and then Is_Entity_Name (Name (Parnt))
Is_Unconstrained_Subscr_Ref :=
Is_Subscr_Ref and then not Is_Constrained (Arr_Typ);
- -- Always do a range check if the source type includes infinities
- -- and the target type does not include infinities. We do not do
- -- this if range checks are killed.
+ -- Always do a range check if the source type includes infinities and
+ -- the target type does not include infinities. We do not do this if
+ -- range checks are killed.
if Is_Floating_Point_Type (S_Typ)
and then Has_Infinities (S_Typ)
Enable_Range_Check (Expr);
end if;
- -- Return if we know expression is definitely in the range of
- -- the target type as determined by Determine_Range. Right now
- -- we only do this for discrete types, and not fixed-point or
- -- floating-point types.
+ -- Return if we know expression is definitely in the range of the target
+ -- type as determined by Determine_Range. Right now we only do this for
+ -- discrete types, and not fixed-point or floating-point types.
-- The additional less-precise tests below catch these cases
- -- Note: skip this if we are given a source_typ, since the point
- -- of supplying a Source_Typ is to stop us looking at the expression.
- -- could sharpen this test to be out parameters only ???
+ -- Note: skip this if we are given a source_typ, since the point of
+ -- supplying a Source_Typ is to stop us looking at the expression.
+ -- We could sharpen this test to be out parameters only ???
if Is_Discrete_Type (Target_Typ)
and then Is_Discrete_Type (Etype (Expr))
-- 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;
- -- In the floating-point case, we only do range checks if the
- -- type is constrained. We definitely do NOT want range checks
- -- for unconstrained types, since we want to have infinities
+ -- In the floating-point case, we only do range checks if the type is
+ -- constrained. We definitely do NOT want range checks for unconstrained
+ -- types, since we want to have infinities
elsif Is_Floating_Point_Type (S_Typ) then
if Is_Constrained (S_Typ) then
end if;
end if;
- -- If the item is a conditional raise of constraint error,
- -- then have a look at what check is being performed and
- -- ???
+ -- If the item is a conditional raise of constraint error, then have
+ -- a look at what check is being performed and ???
if Nkind (R_Cno) = N_Raise_Constraint_Error
and then Present (Condition (R_Cno))
then
Cond := Condition (R_Cno);
- if not Has_Dynamic_Length_Check (Ck_Node)
- and then Checks_On
- then
- Insert_Action (Ck_Node, R_Cno);
+ -- Case where node does not now have a dynamic check
- if not Do_Static then
- Set_Has_Dynamic_Length_Check (Ck_Node);
+ if not Has_Dynamic_Length_Check (Ck_Node) then
+
+ -- If checks are on, just insert the check
+
+ if Checks_On then
+ Insert_Action (Ck_Node, R_Cno);
+
+ if not Do_Static then
+ Set_Has_Dynamic_Length_Check (Ck_Node);
+ end if;
+
+ -- If checks are off, then analyze the length check after
+ -- temporarily attaching it to the tree in case the relevant
+ -- condition can be evaluted at compile time. We still want a
+ -- compile time warning in this case.
+
+ else
+ Set_Parent (R_Cno, Ck_Node);
+ Analyze (R_Cno);
end if;
end if;
-- We do this by replacing the if statement by a null statement
elsif Do_Static or else not Checks_On then
+ Remove_Warning_Messages (R_Cno);
Rewrite (R_Cno, Make_Null_Statement (Loc));
end if;
else
Install_Static_Check (R_Cno, Loc);
end if;
-
end loop;
-
end Apply_Selected_Length_Checks;
---------------------------------
R_Cno := R_Result (J);
exit when No (R_Cno);
- -- If the item is a conditional raise of constraint error,
- -- then have a look at what check is being performed and
- -- ???
+ -- If the item is a conditional raise of constraint error, then have
+ -- a look at what check is being performed and ???
if Nkind (R_Cno) = N_Raise_Constraint_Error
and then Present (Condition (R_Cno))
if Is_Entity_Name (Cond)
and then Entity (Cond) = Standard_True
then
- -- Since an N_Range is technically not an expression, we
- -- have to set one of the bounds to C_E and then just flag
- -- the N_Range. The warning message will point to the
- -- lower bound and complain about a range, which seems OK.
+ -- Since an N_Range is technically not an expression, we have
+ -- to set one of the bounds to C_E and then just flag the
+ -- N_Range. The warning message will point to the lower bound
+ -- and complain about a range, which seems OK.
if Nkind (Ck_Node) = N_Range then
Apply_Compile_Time_Constraint_Error
-- We do this by replacing the if statement by a null statement
elsif Do_Static or else not Checks_On then
+ Remove_Warning_Messages (R_Cno);
Rewrite (R_Cno, Make_Null_Statement (Loc));
end if;
Sub := First (Expressions (Expr));
while Present (Sub) loop
- -- Check one subscript. Note that we do not worry about
- -- enumeration type with holes, since we will convert the
- -- value to a Pos value for the subscript, and that convert
- -- will do the necessary validity check.
+ -- Check one subscript. Note that we do not worry about enumeration
+ -- type with holes, since we will convert the value to a Pos value
+ -- for the subscript, and that convert will do the necessary validity
+ -- check.
Ensure_Valid (Sub, Holes_OK => True);
elsif Serious_Errors_Detected > 0 then
return;
- -- Scalar type conversions of the form Target_Type (Expr) require
- -- a range check if we cannot be sure that Expr is in the base type
- -- of Target_Typ and also that Expr is in the range of Target_Typ.
- -- These are not quite the same condition from an implementation
- -- point of view, but clearly the second includes the first.
+ -- Scalar type conversions of the form Target_Type (Expr) require a
+ -- range check if we cannot be sure that Expr is in the base type of
+ -- Target_Typ and also that Expr is in the range of Target_Typ. These
+ -- are not quite the same condition from an implementation point of
+ -- view, but clearly the second includes the first.
elsif Is_Scalar_Type (Target_Type) then
declare
Conv_OK : constant Boolean := Conversion_OK (N);
- -- If the Conversion_OK flag on the type conversion is set
- -- and no floating point type is involved in the type conversion
- -- then fixed point values must be read as integral values.
+ -- If the Conversion_OK flag on the type conversion is set and no
+ -- floating point type is involved in the type conversion then
+ -- fixed point values must be read as integral values.
Float_To_Int : constant Boolean :=
Is_Floating_Point_Type (Expr_Type)
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
- Set_Do_Overflow_Check (N);
+ Activate_Overflow_Check (N);
end if;
if not Range_Checks_Suppressed (Target_Type)
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)
begin
Constraint := First_Elmt (Stored_Constraint (Target_Type));
-
while Present (Constraint) loop
Discr_Value := Node (Constraint);
and then Scope (Discr) = Base_Type (Expr_Type)
then
-- Parent is constrained by new discriminant. Obtain
- -- Value of original discriminant in expression. If
- -- the new discriminant has been used to constrain more
- -- than one of the stored discriminants, this will
- -- provide the required consistency check.
-
- Append_Elmt (
- Make_Selected_Component (Loc,
- Prefix =>
+ -- Value of original discriminant in expression. If the
+ -- new discriminant has been used to constrain more than
+ -- one of the stored discriminants, this will provide the
+ -- required consistency check.
+
+ 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 ???
return;
end if;
- -- Derived type definition has an explicit value for
- -- this stored discriminant.
+ -- Derived type definition has an explicit value for this
+ -- stored discriminant.
else
Append_Elmt
Reason => CE_Discriminant_Check_Failed));
end;
- -- For arrays, conversions are applied during expansion, to take
- -- into accounts changes of representation. The checks become range
- -- checks on the base type or length checks on the subtype, depending
- -- on whether the target type is unconstrained or constrained.
+ -- For arrays, conversions are applied during expansion, to take into
+ -- accounts changes of representation. The checks become range checks on
+ -- the base type or length checks on the subtype, depending on whether
+ -- the target type is unconstrained or constrained.
else
null;
then
Set_Etype (N, Base_Type (Typ));
- -- Otherwise, replace the attribute node with a type conversion
- -- node whose expression is the attribute, retyped to universal
- -- integer, and whose subtype mark is the target type. The call
- -- to analyze this conversion will set range and overflow checks
- -- as required for proper detection of an out of range value.
+ -- Otherwise, replace the attribute node with a type conversion node
+ -- whose expression is the attribute, retyped to universal integer, and
+ -- whose subtype mark is the target type. The call to analyze this
+ -- conversion will set range and overflow checks as required for proper
+ -- detection of an out of range value.
else
Set_Etype (N, Universal_Integer);
Analyze_And_Resolve (N, Typ);
return;
end if;
-
end Apply_Universal_Integer_Attribute_Checks;
-------------------------------
Dref : Node_Id;
Dval : Node_Id;
+ function Aggregate_Discriminant_Val (Disc : Entity_Id) return Node_Id;
+
+ ----------------------------------
+ -- Aggregate_Discriminant_Value --
+ ----------------------------------
+
+ function Aggregate_Discriminant_Val (Disc : Entity_Id) return Node_Id is
+ Assoc : Node_Id;
+
+ begin
+ -- The aggregate has been normalized with named associations. We use
+ -- the Chars field to locate the discriminant to take into account
+ -- discriminants in derived types, which carry the same name as those
+ -- in the parent.
+
+ Assoc := First (Component_Associations (N));
+ while Present (Assoc) loop
+ if Chars (First (Choices (Assoc))) = Chars (Disc) then
+ return Expression (Assoc);
+ else
+ Next (Assoc);
+ end if;
+ end loop;
+
+ -- Discriminant must have been found in the loop above
+
+ raise Program_Error;
+ end Aggregate_Discriminant_Val;
+
+ -- Start of processing for Build_Discriminant_Checks
+
begin
+ -- Loop through discriminants evolving the condition
+
Cond := Empty;
Disc := First_Elmt (Discriminant_Constraint (T_Typ));
T_Typ,
Stored_Constraint (T_Typ)));
+ elsif Nkind (N) = N_Aggregate then
+ Dref :=
+ Duplicate_Subexpr_No_Checks
+ (Aggregate_Discriminant_Val (Disc_Ent));
+
else
Dref :=
Make_Selected_Component (Loc,
return Cond;
end Build_Discriminant_Checks;
+ ------------------
+ -- Check_Needed --
+ ------------------
+
+ function Check_Needed (Nod : Node_Id; Check : Check_Type) return Boolean is
+ N : Node_Id;
+ P : Node_Id;
+ K : Node_Kind;
+ L : Node_Id;
+ R : Node_Id;
+
+ begin
+ -- Always check if not simple entity
+
+ if Nkind (Nod) not in N_Has_Entity
+ or else not Comes_From_Source (Nod)
+ then
+ return True;
+ end if;
+
+ -- Look up tree for short circuit
+
+ N := Nod;
+ loop
+ P := Parent (N);
+ K := Nkind (P);
+
+ -- Done if out of subexpression (note that we allow generated stuff
+ -- such as itype declarations in this context, to keep the loop going
+ -- since we may well have generated such stuff in complex situations.
+ -- Also done if no parent (probably an error condition, but no point
+ -- in behaving nasty if we find it!)
+
+ if No (P)
+ or else (K not in N_Subexpr and then Comes_From_Source (P))
+ then
+ return True;
+
+ -- Or/Or Else case, where test is part of the right operand, or is
+ -- part of one of the actions associated with the right operand, and
+ -- the left operand is an equality test.
+
+ elsif K = N_Op_Or then
+ exit when N = Right_Opnd (P)
+ and then Nkind (Left_Opnd (P)) = N_Op_Eq;
+
+ elsif K = N_Or_Else then
+ exit when (N = Right_Opnd (P)
+ or else
+ (Is_List_Member (N)
+ and then List_Containing (N) = Actions (P)))
+ and then Nkind (Left_Opnd (P)) = N_Op_Eq;
+
+ -- Similar test for the And/And then case, where the left operand
+ -- is an inequality test.
+
+ elsif K = N_Op_And then
+ exit when N = Right_Opnd (P)
+ and then Nkind (Left_Opnd (P)) = N_Op_Ne;
+
+ elsif K = N_And_Then then
+ exit when (N = Right_Opnd (P)
+ or else
+ (Is_List_Member (N)
+ and then List_Containing (N) = Actions (P)))
+ and then Nkind (Left_Opnd (P)) = N_Op_Ne;
+ end if;
+
+ N := P;
+ end loop;
+
+ -- If we fall through the loop, then we have a conditional with an
+ -- appropriate test as its left operand. So test further.
+
+ L := Left_Opnd (P);
+ R := Right_Opnd (L);
+ L := Left_Opnd (L);
+
+ -- Left operand of test must match original variable
+
+ if Nkind (L) not in N_Has_Entity
+ or else Entity (L) /= Entity (Nod)
+ then
+ return True;
+ end if;
+
+ -- Right operand of test must be key value (zero or null)
+
+ case Check is
+ when Access_Check =>
+ if not Known_Null (R) then
+ return True;
+ end if;
+
+ when Division_Check =>
+ if not Compile_Time_Known_Value (R)
+ or else Expr_Value (R) /= Uint_0
+ then
+ return True;
+ end if;
+
+ when others =>
+ raise Program_Error;
+ end case;
+
+ -- Here we have the optimizable case, warn if not short-circuited
+
+ if K = N_Op_And or else K = N_Op_Or then
+ case Check is
+ when Access_Check =>
+ Error_Msg_N
+ ("Constraint_Error may be raised (access check)?",
+ Parent (Nod));
+ when Division_Check =>
+ Error_Msg_N
+ ("Constraint_Error may be raised (zero divide)?",
+ Parent (Nod));
+
+ when others =>
+ raise Program_Error;
+ end case;
+
+ if K = N_Op_And then
+ Error_Msg_N -- CODEFIX
+ ("use `AND THEN` instead of AND?", P);
+ else
+ Error_Msg_N -- CODEFIX
+ ("use `OR ELSE` instead of OR?", P);
+ end if;
+
+ -- If not short-circuited, we need the ckeck
+
+ return True;
+
+ -- If short-circuited, we can omit the check
+
+ else
+ return False;
+ end if;
+ end Check_Needed;
+
-----------------------------------
-- Check_Valid_Lvalue_Subscripts --
-----------------------------------
if Range_Checks_Suppressed (Etype (Expr)) then
return;
- -- Only do this check for expressions that come from source. We
- -- assume that expander generated assignments explicitly include
- -- any necessary checks. Note that this is not just an optimization,
- -- it avoids infinite recursions!
+ -- Only do this check for expressions that come from source. We assume
+ -- that expander generated assignments explicitly include any necessary
+ -- checks. Note that this is not just an optimization, it avoids
+ -- infinite recursions!
elsif not Comes_From_Source (Expr) then
return;
elsif Nkind (Expr) = N_Indexed_Component then
Apply_Subscript_Validity_Checks (Expr);
- -- Prefix may itself be or contain an indexed component, and
- -- these subscripts need checking as well
+ -- Prefix may itself be or contain an indexed component, and these
+ -- subscripts need checking as well.
Check_Valid_Lvalue_Subscripts (Prefix (Expr));
end if;
----------------------------------
procedure Null_Exclusion_Static_Checks (N : Node_Id) is
- K : constant Node_Kind := Nkind (N);
- Typ : Entity_Id;
- Related_Nod : Node_Id;
- Has_Null_Exclusion : Boolean := False;
-
- type Msg_Kind is (Components, Formals, Objects);
- Msg_K : Msg_Kind := Objects;
- -- Used by local subprograms to generate precise error messages
-
- procedure Check_Must_Be_Access
- (Typ : Entity_Id;
- Has_Null_Exclusion : Boolean);
- -- ??? local subprograms must have comment on spec
-
- procedure Check_Already_Null_Excluding_Type
- (Typ : Entity_Id;
- Has_Null_Exclusion : Boolean;
- Related_Nod : Node_Id);
- -- ??? local subprograms must have comment on spec
-
- procedure Check_Must_Be_Initialized
- (N : Node_Id;
- Related_Nod : Node_Id);
- -- ??? local subprograms must have comment on spec
-
- procedure Check_Null_Not_Allowed (N : Node_Id);
- -- ??? local subprograms must have comment on spec
-
- -- ??? following bodies lack comments
-
- --------------------------
- -- Check_Must_Be_Access --
- --------------------------
-
- procedure Check_Must_Be_Access
- (Typ : Entity_Id;
- Has_Null_Exclusion : Boolean)
- is
- begin
- if Has_Null_Exclusion
- and then not Is_Access_Type (Typ)
- then
- Error_Msg_N ("(Ada 2005) must be an access type", Related_Nod);
- end if;
- end Check_Must_Be_Access;
-
- ---------------------------------------
- -- Check_Already_Null_Excluding_Type --
- ---------------------------------------
+ Error_Node : Node_Id;
+ Expr : Node_Id;
+ Has_Null : constant Boolean := Has_Null_Exclusion (N);
+ K : constant Node_Kind := Nkind (N);
+ Typ : Entity_Id;
- procedure Check_Already_Null_Excluding_Type
- (Typ : Entity_Id;
- Has_Null_Exclusion : Boolean;
- Related_Nod : Node_Id)
- is
- begin
- if Has_Null_Exclusion
- and then Can_Never_Be_Null (Typ)
- then
- Error_Msg_N
- ("(Ada 2005) already a null-excluding type", Related_Nod);
- end if;
- end Check_Already_Null_Excluding_Type;
+ begin
+ pragma Assert
+ (K = N_Component_Declaration
+ or else K = N_Discriminant_Specification
+ or else K = N_Function_Specification
+ or else K = N_Object_Declaration
+ or else K = N_Parameter_Specification);
+
+ if K = N_Function_Specification then
+ Typ := Etype (Defining_Entity (N));
+ else
+ Typ := Etype (Defining_Identifier (N));
+ end if;
- -------------------------------
- -- Check_Must_Be_Initialized --
- -------------------------------
+ case K is
+ when N_Component_Declaration =>
+ if Present (Access_Definition (Component_Definition (N))) then
+ Error_Node := Component_Definition (N);
+ else
+ Error_Node := Subtype_Indication (Component_Definition (N));
+ end if;
- procedure Check_Must_Be_Initialized
- (N : Node_Id;
- Related_Nod : Node_Id)
- is
- Expr : constant Node_Id := Expression (N);
+ when N_Discriminant_Specification =>
+ Error_Node := Discriminant_Type (N);
- begin
- pragma Assert (Nkind (N) = N_Component_Declaration
- or else Nkind (N) = N_Object_Declaration);
-
- if not Present (Expr) then
- case Msg_K is
- when Components =>
- Error_Msg_N
- ("(Ada 2005) null-excluding components must be " &
- "initialized", Related_Nod);
-
- when Formals =>
- Error_Msg_N
- ("(Ada 2005) null-excluding formals must be initialized",
- Related_Nod);
-
- when Objects =>
- Error_Msg_N
- ("(Ada 2005) null-excluding objects must be initialized",
- Related_Nod);
- end case;
- end if;
- end Check_Must_Be_Initialized;
+ when N_Function_Specification =>
+ Error_Node := Result_Definition (N);
- ----------------------------
- -- Check_Null_Not_Allowed --
- ----------------------------
+ when N_Object_Declaration =>
+ Error_Node := Object_Definition (N);
- procedure Check_Null_Not_Allowed (N : Node_Id) is
- Expr : constant Node_Id := Expression (N);
+ when N_Parameter_Specification =>
+ Error_Node := Parameter_Type (N);
- begin
- if Present (Expr)
- and then Nkind (Expr) = N_Null
- then
- case Msg_K is
- when Components =>
- Apply_Compile_Time_Constraint_Error
- (N => Expr,
- Msg => "(Ada 2005) NULL not allowed in"
- & " null-excluding components?",
- Reason => CE_Null_Not_Allowed,
- Rep => False);
+ when others =>
+ raise Program_Error;
+ end case;
- when Formals =>
- Apply_Compile_Time_Constraint_Error
- (N => Expr,
- Msg => "(Ada 2005) NULL not allowed in"
- & " null-excluding formals?",
- Reason => CE_Null_Not_Allowed,
- Rep => False);
+ if Has_Null then
- when Objects =>
- Apply_Compile_Time_Constraint_Error
- (N => Expr,
- Msg => "(Ada 2005) NULL not allowed in"
- & " null-excluding objects?",
- Reason => CE_Null_Not_Allowed,
- Rep => False);
- end case;
- end if;
- end Check_Null_Not_Allowed;
+ -- Enforce legality rule 3.10 (13): A null exclusion can only be
+ -- applied to an access [sub]type.
- -- Start of processing for Null_Exclusion_Static_Checks
+ if not Is_Access_Type (Typ) then
+ Error_Msg_N
+ ("`NOT NULL` allowed only for an access type", Error_Node);
- begin
- pragma Assert (K = N_Component_Declaration
- or else K = N_Parameter_Specification
- or else K = N_Object_Declaration
- or else K = N_Discriminant_Specification
- or else K = N_Allocator);
+ -- Enforce legality rule RM 3.10(14/1): A null exclusion can only
+ -- be applied to a [sub]type that does not exclude null already.
- case K is
- when N_Component_Declaration =>
- Msg_K := Components;
-
- if not Present (Access_Definition (Component_Definition (N))) then
- Has_Null_Exclusion := Null_Exclusion_Present
- (Component_Definition (N));
- Typ := Etype (Subtype_Indication (Component_Definition (N)));
- Related_Nod := Subtype_Indication (Component_Definition (N));
- Check_Must_Be_Access (Typ, Has_Null_Exclusion);
- Check_Already_Null_Excluding_Type
- (Typ, Has_Null_Exclusion, Related_Nod);
- Check_Must_Be_Initialized (N, Related_Nod);
- end if;
+ elsif Can_Never_Be_Null (Typ)
+ and then Comes_From_Source (Typ)
+ then
+ Error_Msg_NE
+ ("`NOT NULL` not allowed (& already excludes null)",
+ Error_Node, Typ);
+ end if;
+ end if;
- Check_Null_Not_Allowed (N);
+ -- Check that null-excluding objects are always initialized, except for
+ -- deferred constants, for which the expression will appear in the full
+ -- declaration.
- when N_Parameter_Specification =>
- Msg_K := Formals;
- Has_Null_Exclusion := Null_Exclusion_Present (N);
- Typ := Entity (Parameter_Type (N));
- Related_Nod := Parameter_Type (N);
- Check_Must_Be_Access (Typ, Has_Null_Exclusion);
- Check_Already_Null_Excluding_Type
- (Typ, Has_Null_Exclusion, Related_Nod);
- Check_Null_Not_Allowed (N);
+ if K = N_Object_Declaration
+ and then No (Expression (N))
+ and then not Constant_Present (N)
+ and then not No_Initialization (N)
+ then
+ -- Add an expression that assigns null. This node is needed by
+ -- Apply_Compile_Time_Constraint_Error, which will replace this with
+ -- a Constraint_Error node.
- when N_Object_Declaration =>
- Msg_K := Objects;
-
- if Nkind (Object_Definition (N)) /= N_Access_Definition then
- Has_Null_Exclusion := Null_Exclusion_Present (N);
- Typ := Entity (Object_Definition (N));
- Related_Nod := Object_Definition (N);
- Check_Must_Be_Access (Typ, Has_Null_Exclusion);
- Check_Already_Null_Excluding_Type
- (Typ, Has_Null_Exclusion, Related_Nod);
- Check_Must_Be_Initialized (N, Related_Nod);
- end if;
+ Set_Expression (N, Make_Null (Sloc (N)));
+ Set_Etype (Expression (N), Etype (Defining_Identifier (N)));
- Check_Null_Not_Allowed (N);
+ Apply_Compile_Time_Constraint_Error
+ (N => Expression (N),
+ Msg => "(Ada 2005) null-excluding objects must be initialized?",
+ Reason => CE_Null_Not_Allowed);
+ end if;
- when N_Discriminant_Specification =>
- Msg_K := Components;
-
- if Nkind (Discriminant_Type (N)) /= N_Access_Definition then
- Has_Null_Exclusion := Null_Exclusion_Present (N);
- Typ := Etype (Defining_Identifier (N));
- Related_Nod := Discriminant_Type (N);
- Check_Must_Be_Access (Typ, Has_Null_Exclusion);
- Check_Already_Null_Excluding_Type
- (Typ, Has_Null_Exclusion, Related_Nod);
- end if;
+ -- 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_Constraint_Error node.
- Check_Null_Not_Allowed (N);
+ if K /= N_Function_Specification then
+ Expr := Expression (N);
- when N_Allocator =>
- Msg_K := Objects;
- Has_Null_Exclusion := Null_Exclusion_Present (N);
- Typ := Etype (Expression (N));
+ if Present (Expr) and then Known_Null (Expr) then
+ case K is
+ when N_Component_Declaration |
+ N_Discriminant_Specification =>
+ Apply_Compile_Time_Constraint_Error
+ (N => Expr,
+ Msg => "(Ada 2005) null not allowed " &
+ "in null-excluding components?",
+ Reason => CE_Null_Not_Allowed);
- if Nkind (Expression (N)) = N_Qualified_Expression then
- Related_Nod := Subtype_Mark (Expression (N));
- else
- Related_Nod := Expression (N);
- end if;
+ when N_Object_Declaration =>
+ Apply_Compile_Time_Constraint_Error
+ (N => Expr,
+ Msg => "(Ada 2005) null not allowed " &
+ "in null-excluding objects?",
+ Reason => CE_Null_Not_Allowed);
- Check_Must_Be_Access (Typ, Has_Null_Exclusion);
- Check_Already_Null_Excluding_Type
- (Typ, Has_Null_Exclusion, Related_Nod);
- Check_Null_Not_Allowed (N);
+ when N_Parameter_Specification =>
+ Apply_Compile_Time_Constraint_Error
+ (N => Expr,
+ Msg => "(Ada 2005) null not allowed " &
+ "in null-excluding formals?",
+ Reason => CE_Null_Not_Allowed);
- when others =>
- raise Program_Error;
- end case;
+ when others =>
+ null;
+ end case;
+ end if;
+ end if;
end Null_Exclusion_Static_Checks;
----------------------------------
begin
Saved_Checks_TOS := Saved_Checks_TOS + 1;
- -- If stack overflows, kill all checks, that way we know to
- -- simply reset the number of saved checks to zero on return.
- -- This should never occur in practice.
+ -- If stack overflows, kill all checks, that way we know to simply reset
+ -- the number of saved checks to zero on return. This should never occur
+ -- in practice.
if Saved_Checks_TOS > Saved_Checks_Stack'Last then
Kill_All_Checks;
- -- In the normal case, we just make a new stack entry saving
- -- the current number of saved checks for a later restore.
+ -- In the normal case, we just make a new stack entry saving the current
+ -- number of saved checks for a later restore.
else
Saved_Checks_Stack (Saved_Checks_TOS) := Num_Saved_Checks;
begin
pragma Assert (Saved_Checks_TOS > 0);
- -- If the saved checks stack overflowed, then we killed all
- -- checks, so setting the number of saved checks back to
- -- zero is correct. This should never occur in practice.
+ -- If the saved checks stack overflowed, then we killed all checks, so
+ -- setting the number of saved checks back to zero is correct. This
+ -- should never occur in practice.
if Saved_Checks_TOS > Saved_Checks_Stack'Last then
Num_Saved_Checks := 0;
- -- In the normal case, restore the number of saved checks
- -- from the top stack entry.
+ -- In the normal case, restore the number of saved checks from the top
+ -- stack entry.
else
Num_Saved_Checks := Saved_Checks_Stack (Saved_Checks_TOS);
-- 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 Determine_Range calls. Because of the way Determine_Range
- -- recursively traces subexpressions, and because overflow checking
- -- calls the routine 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.
+ -- The above arrays are used to implement a small direct cache for
+ -- Determine_Range calls. Because of the way Determine_Range recursively
+ -- traces subexpressions, and because overflow checking calls the routine
+ -- 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. 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;
OK := True;
- -- If value is compile time known, then the possible range is the
- -- one value that we know this expression definitely has!
+ -- If value is compile time known, then the possible range is the one
+ -- value that we know this expression definitely has!
if Compile_Time_Known_Value (N) then
Lo := Expr_Value (N);
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;
end if;
- -- Otherwise, start by finding the bounds of the type of the
- -- expression, the value cannot be outside this range (if it
- -- is, then we have an overflow situation, which is a separate
- -- check, we are talking here only about the expression value).
+ -- Otherwise, start by finding the bounds of the type of the expression,
+ -- the value cannot be outside this range (if it is, then we have an
+ -- overflow situation, which is a separate check, we are talking here
+ -- only about the expression value).
- -- 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 perhaps cannot happen, but there is no
- -- point in bombing in this optimization circuit.
+ -- 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
+ -- perhaps cannot happen, but there is no point in bombing in this
+ -- optimization circuit.
-- First the low bound
return;
end if;
- -- If we have a static subtype, then that may have a tighter bound
- -- so use the upper bound of the subtype instead in this case.
+ -- If we have a static subtype, then that may have a tighter bound so
+ -- use the upper bound of the subtype instead in this case.
if Compile_Time_Known_Value (Bound) then
Hi := Expr_Value (Bound);
end if;
- -- We may be able to refine this value in certain situations. If
- -- refinement is possible, then Lor and Hir are set to possibly
- -- tighter bounds, and OK1 is set to True.
+ -- We may be able to refine this value in certain situations. If any
+ -- refinement is possible, then Lor and Hir are set to possibly tighter
+ -- bounds, and OK1 is set to True.
case Nkind (N) is
-- 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;
Hir := Hi_Left + Hi_Right;
end if;
- -- Division is tricky. The only case we consider is where the
- -- right operand is a positive constant, and in this case we
- -- simply divide the bounds of the left operand
+ -- Division is tricky. The only case we consider is where the right
+ -- operand is a positive constant, and in this case we simply divide
+ -- the bounds of the left operand
when N_Op_Divide =>
if OK_Operands then
end if;
end if;
- -- For binary subtraction, get range of each operand and do
- -- the worst case subtraction to get the result range.
+ -- For binary subtraction, get range of each operand and do the worst
+ -- case subtraction to get the result range.
when N_Op_Subtract =>
if OK_Operands then
Hir := Hi_Left - Lo_Right;
end if;
- -- For MOD, if right operand is a positive constant, then
- -- result must be in the allowable range of mod results.
+ -- For MOD, if right operand is a positive constant, then result must
+ -- be in the allowable range of mod results.
when N_Op_Mod =>
if OK_Operands then
end if;
end if;
- -- For REM, if right operand is a positive constant, then
- -- result must be in the allowable range of mod results.
+ -- For REM, if right operand is a positive constant, then result must
+ -- be in the allowable range of mod results.
when N_Op_Rem =>
if OK_Operands then
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.
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);
+ (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
- -- 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);
+ Lor := UI_Max (Uint_0, UL - LU + 1);
-- For an unconstrained array, the minimum value
-- for length is always zero.
end;
-- No special handling for other attributes
- -- Probably more opportunities exist here ???
+ -- Probably more opportunities exist here???
when others =>
OK1 := False;
end case;
- -- For type conversion from one discrete type to another, we
- -- can refine the range using the converted value.
+ -- For type conversion from one discrete type to another, we can
+ -- 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
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;
-- 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;
- -- 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.
function Elaboration_Checks_Suppressed (E : Entity_Id) return Boolean is
begin
+ -- The complication in this routine is that if we are in the dynamic
+ -- model of elaboration, we also check All_Checks, since All_Checks
+ -- does not set Elaboration_Check explicitly.
+
if Present (E) then
if Kill_Elaboration_Checks (E) then
return True;
+
elsif Checks_May_Be_Suppressed (E) then
- return Is_Check_Suppressed (E, Elaboration_Check);
+ if Is_Check_Suppressed (E, Elaboration_Check) then
+ return True;
+ elsif Dynamic_Elaboration_Checks then
+ return Is_Check_Suppressed (E, All_Checks);
+ else
+ return False;
+ end if;
end if;
end if;
- return Scope_Suppress (Elaboration_Check);
+ if Scope_Suppress (Elaboration_Check) then
+ return True;
+ elsif Dynamic_Elaboration_Checks then
+ return Scope_Suppress (All_Checks);
+ else
+ return False;
+ end if;
end Elaboration_Checks_Suppressed;
---------------------------
w ("Enable_Overflow_Check for node ", Int (N));
Write_Str (" Source location = ");
wl (Sloc (N));
- pg (N);
+ pg (Union_Id (N));
end if;
- -- 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 in any case.
+ -- 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 if a bound of the
- -- range is equal to that of the type. That's not quite accurate
- -- but we do this for the following reasons:
+ -- 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
+ -- quite accurate but we do this for the following reasons:
-- a) The way that Determine_Range works, it will typically report
-- the bounds of the value as being equal to the bounds of the
-- b) It is very unusual to have a situation in which this would
-- generate an unnecessary overflow check (an example would be
-- a subtype with a range 0 .. Integer'Last - 1 to which the
- -- literal value one is added.
+ -- literal value one is added).
-- c) The alternative is a lot of special casing in this routine
-- which would partially duplicate Determine_Range processing.
end if;
end if;
- -- If not in optimizing mode, set flag and we are done. We are also
- -- done (and just set the flag) if the type is not a discrete type,
- -- since it is not worth the effort to eliminate checks for other
- -- than discrete types. In addition, we take this same path if we
- -- have stored the maximum number of checks possible already (a
- -- very unlikely situation, but we do not want to blow up!)
+ -- If not in optimizing mode, set flag and we are done. We are also done
+ -- (and just set the flag) if the type is not a discrete type, since it
+ -- is not worth the effort to eliminate checks for other than discrete
+ -- types. In addition, we take this same path if we have stored the
+ -- maximum number of checks possible already (a very unlikely situation,
+ -- but we do not want to blow up!)
if Optimization_Level = 0
or else not Is_Discrete_Type (Etype (N))
or else Num_Saved_Checks = Saved_Checks'Last
then
- Set_Do_Overflow_Check (N, True);
+ Activate_Overflow_Check (N);
if Debug_Flag_CC then
w ("Optimization off");
-- If check is not of form to optimize, then set flag and we are done
if not OK then
- Set_Do_Overflow_Check (N, True);
+ Activate_Overflow_Check (N);
return;
end if;
-- Here we will make a new entry for the new check
- Set_Do_Overflow_Check (N, True);
+ Activate_Overflow_Check (N);
Num_Saved_Checks := Num_Saved_Checks + 1;
Saved_Checks (Num_Saved_Checks) :=
(Killed => False,
w (" Target_Type = Empty");
end if;
- -- If we get an exception, then something went wrong, probably because
- -- of an error in the structure of the tree due to an incorrect program.
- -- Or it may be a bug in the optimization circuit. In either case the
- -- safest thing is simply to set the check flag unconditionally.
+ -- If we get an exception, then something went wrong, probably because of
+ -- an error in the structure of the tree due to an incorrect program. Or it
+ -- may be a bug in the optimization circuit. In either case the safest
+ -- thing is simply to set the check flag unconditionally.
exception
when others =>
- Set_Do_Overflow_Check (N, True);
+ Activate_Overflow_Check (N);
if Debug_Flag_CC then
w (" exception occurred, overflow flag set");
P : Node_Id;
begin
- -- Return if unchecked type conversion with range check killed.
- -- In this case we never set the flag (that's what Kill_Range_Check
- -- is all about!)
+ -- Return if unchecked type conversion with range check killed. In this
+ -- case we never set the flag (that's what Kill_Range_Check is about!)
if Nkind (N) = N_Unchecked_Type_Conversion
and then Kill_Range_Check (N)
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
+
+ if Present (Etype (N))
+ and then Range_Checks_Suppressed (Etype (N))
+ then
+ return;
+
+ -- No check if node is an entity name, and range checks are suppressed
+ -- for this entity, or for the type of this entity.
+
+ elsif Is_Entity_Name (N)
+ and then (Range_Checks_Suppressed (Entity (N))
+ or else Range_Checks_Suppressed (Etype (Entity (N))))
+ then
+ return;
+
+ -- No checks if index of array, and index checks are suppressed for
+ -- the array object or the type of the array.
+
+ elsif Nkind (Parent (N)) = N_Indexed_Component then
+ declare
+ Pref : constant Node_Id := Prefix (Parent (N));
+ begin
+ if Is_Entity_Name (Pref)
+ and then Index_Checks_Suppressed (Entity (Pref))
+ then
+ return;
+ elsif Index_Checks_Suppressed (Etype (Pref)) then
+ return;
+ end if;
+ end;
+ end if;
+
-- Debug trace output
if Debug_Flag_CC then
w ("Enable_Range_Check for node ", Int (N));
Write_Str (" Source location = ");
wl (Sloc (N));
- pg (N);
+ pg (Union_Id (N));
end if;
- -- If not in optimizing mode, set flag and we are done. We are also
- -- done (and just set the flag) if the type is not a discrete type,
- -- since it is not worth the effort to eliminate checks for other
- -- than discrete types. In addition, we take this same path if we
- -- have stored the maximum number of checks possible already (a
- -- very unlikely situation, but we do not want to blow up!)
+ -- If not in optimizing mode, set flag and we are done. We are also done
+ -- (and just set the flag) if the type is not a discrete type, since it
+ -- is not worth the effort to eliminate checks for other than discrete
+ -- types. In addition, we take this same path if we have stored the
+ -- maximum number of checks possible already (a very unlikely situation,
+ -- but we do not want to blow up!)
if Optimization_Level = 0
or else No (Etype (N))
or else not Is_Discrete_Type (Etype (N))
or else Num_Saved_Checks = Saved_Checks'Last
then
- Set_Do_Range_Check (N, True);
+ Activate_Range_Check (N);
if Debug_Flag_CC then
w ("Optimization off");
Atyp := Designated_Type (Atyp);
-- If the prefix is an access to an unconstrained array,
- -- perform check unconditionally: it depends on the bounds
- -- of an object and we cannot currently recognize whether
- -- the test may be redundant.
+ -- perform check unconditionally: it depends on the bounds of
+ -- an object and we cannot currently recognize whether the test
+ -- may be redundant.
if not Is_Constrained (Atyp) then
- Set_Do_Range_Check (N, True);
+ Activate_Range_Check (N);
return;
end if;
- -- Ditto if the prefix is an explicit dereference whose
- -- designated type is unconstrained.
+ -- Ditto if the prefix is an explicit dereference whose designated
+ -- type is unconstrained.
elsif Nkind (Prefix (P)) = N_Explicit_Dereference
and then not Is_Constrained (Atyp)
then
- Set_Do_Range_Check (N, True);
+ Activate_Range_Check (N);
return;
end if;
w (" target type not found, flag set");
end if;
- Set_Do_Range_Check (N, True);
+ Activate_Range_Check (N);
return;
end if;
w (" expression not of optimizable type, flag set");
end if;
- Set_Do_Range_Check (N, True);
+ Activate_Range_Check (N);
return;
end if;
-- Here we will make a new entry for the new check
- Set_Do_Range_Check (N, True);
+ Activate_Range_Check (N);
Num_Saved_Checks := Num_Saved_Checks + 1;
Saved_Checks (Num_Saved_Checks) :=
(Killed => False,
pid (Ofs);
w (" Check_Type = R");
w (" Target_Type = ", Int (Ttyp));
- pg (Ttyp);
+ pg (Union_Id (Ttyp));
end if;
- -- If we get an exception, then something went wrong, probably because
- -- of an error in the structure of the tree due to an incorrect program.
- -- Or it may be a bug in the optimization circuit. In either case the
- -- safest thing is simply to set the check flag unconditionally.
+ -- If we get an exception, then something went wrong, probably because of
+ -- an error in the structure of the tree due to an incorrect program. Or
+ -- it may be a bug in the optimization circuit. In either case the safest
+ -- thing is simply to set the check flag unconditionally.
exception
when others =>
- Set_Do_Range_Check (N, True);
+ Activate_Range_Check (N);
if Debug_Flag_CC then
w (" exception occurred, range flag set");
if not Validity_Checks_On then
return;
- -- Ignore call if range checks suppressed on entity in question
+ -- Ignore call if range or validity checks suppressed on entity or type
- elsif Is_Entity_Name (Expr)
- and then Range_Checks_Suppressed (Entity (Expr))
- then
+ elsif Range_Or_Validity_Checks_Suppressed (Expr) then
return;
- -- No check required if expression is from the expander, we assume
- -- the expander will generate whatever checks are needed. Note that
- -- this is not just an optimization, it avoids infinite recursions!
+ -- No check required if expression is from the expander, we assume the
+ -- expander will generate whatever checks are needed. Note that this is
+ -- not just an optimization, it avoids infinite recursions!
-- Unchecked conversions must be checked, unless they are initialized
-- scalar values, as in a component assignment in an init proc.
elsif Expr_Known_Valid (Expr) then
return;
- -- No check required if checks off
-
- elsif Range_Checks_Suppressed (Typ) then
- return;
-
- -- Ignore case of enumeration with holes where the flag is set not
- -- to worry about holes, since no special validity check is needed
+ -- Ignore case of enumeration with holes where the flag is set not to
+ -- worry about holes, since no special validity check is needed
elsif Is_Enumeration_Type (Typ)
and then Has_Non_Standard_Rep (Typ)
then
return;
+ -- No check on a univeral real constant. The context will eventually
+ -- convert it to a machine number for some target type, or report an
+ -- illegality.
+
+ elsif Nkind (Expr) = N_Real_Literal
+ and then Etype (Expr) = Universal_Real
+ then
+ return;
+
+ -- If the expression denotes a component of a packed boolean arrray,
+ -- no possible check applies. We ignore the old ACATS chestnuts that
+ -- involve Boolean range True..True.
+
+ -- Note: validity checks are generated for expressions that yield a
+ -- scalar type, when it is possible to create a value that is outside of
+ -- the type. If this is a one-bit boolean no such value exists. This is
+ -- an optimization, and it also prevents compiler blowing up during the
+ -- elaboration of improperly expanded packed array references.
+
+ elsif Nkind (Expr) = N_Indexed_Component
+ and then Is_Bit_Packed_Array (Etype (Prefix (Expr)))
+ and then Root_Type (Etype (Expr)) = Standard_Boolean
+ then
+ return;
+
-- An annoying special case. If this is an out parameter of a scalar
-- type, then the value is not going to be accessed, therefore it is
-- inappropriate to do any validity check at the call site.
P := Parent (N);
end if;
- -- Only need to worry if we are argument of a procedure
- -- call since functions don't have out parameters. If this
- -- is an indirect or dispatching call, get signature from
- -- the subprogram type.
+ -- Only need to worry if we are argument of a procedure call
+ -- since functions don't have out parameters. If this is an
+ -- indirect or dispatching call, get signature from the
+ -- subprogram type.
if Nkind (P) = N_Procedure_Call_Statement then
L := Parameter_Associations (P);
E := Etype (Name (P));
end if;
- -- Only need to worry if there are indeed actuals, and
- -- if this could be a procedure call, otherwise we cannot
- -- get a match (either we are not an argument, or the
- -- mode of the formal is not OUT). This test also filters
- -- out the generic case.
+ -- Only need to worry if there are indeed actuals, and if
+ -- this could be a procedure call, otherwise we cannot get a
+ -- match (either we are not an argument, or the mode of the
+ -- formal is not OUT). This test also filters out the
+ -- generic case.
if Is_Non_Empty_List (L)
and then Is_Subprogram (E)
then
- -- This is the loop through parameters, looking to
- -- see if there is an OUT parameter for which we are
- -- the argument.
+ -- This is the loop through parameters, looking for an
+ -- OUT parameter for which we are the argument.
F := First_Formal (E);
A := First (L);
-
while Present (F) loop
if Ekind (F) = E_Out_Parameter and then A = N then
return;
end if;
end if;
- -- If we fall through, a validity check is required. Note that it would
- -- not be good to set Do_Range_Check, even in contexts where this is
- -- permissible, since this flag causes checking against the target type,
- -- not the source type in contexts such as assignments
+ -- 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);
+
+ if Is_Entity_Name (Expr)
+ and then Safe_To_Capture_Value (Expr, Entity (Expr))
+ then
+ Set_Is_Known_Valid (Entity (Expr));
+ end if;
end Ensure_Valid;
----------------------
Typ : constant Entity_Id := Etype (Expr);
begin
- -- Non-scalar types are always considered valid, since they never
- -- give rise to the issues of erroneous or bounded error behavior
- -- that are the concern. In formal reference manual terms the
- -- notion of validity only applies to scalar types. Note that
- -- even when packed arrays are represented using modular types,
- -- they are still arrays semantically, so they are also always
- -- valid (in particular, the unused bits can be random rubbish
- -- without affecting the validity of the array value).
+ -- Non-scalar types are always considered valid, since they never give
+ -- rise to the issues of erroneous or bounded error behavior that are
+ -- the concern. In formal reference manual terms the notion of validity
+ -- only applies to scalar types. Note that even when packed arrays are
+ -- represented using modular types, they are still arrays semantically,
+ -- so they are also always valid (in particular, the unused bits can be
+ -- random rubbish without affecting the validity of the array value).
if not Is_Scalar_Type (Typ) or else Is_Packed_Array_Type (Typ) then
return True;
then
return True;
- -- If the expression is the value of an object that is known to
- -- be valid, then clearly the expression value itself is valid.
+ -- If the expression is the value of an object that is known to be
+ -- valid, then clearly the expression value itself is valid.
elsif Is_Entity_Name (Expr)
and then Is_Known_Valid (Entity (Expr))
then
return True;
- -- If the type is one for which all values are known valid, then
- -- we are sure that the value is valid except in the slightly odd
- -- case where the expression is a reference to a variable whose size
- -- has been explicitly set to a value greater than the object size.
+ -- References to discriminants are always considered valid. The value
+ -- of a discriminant gets checked when the object is built. Within the
+ -- record, we consider it valid, and it is important to do so, since
+ -- otherwise we can try to generate bogus validity checks which
+ -- reference discriminants out of scope. Discriminants of concurrent
+ -- types are excluded for the same reason.
+
+ elsif Is_Entity_Name (Expr)
+ and then Denotes_Discriminant (Expr, Check_Concurrent => True)
+ then
+ return True;
+
+ -- If the type is one for which all values are known valid, then we are
+ -- sure that the value is valid except in the slightly odd case where
+ -- the expression is a reference to a variable whose size has been
+ -- explicitly set to a value greater than the object size.
elsif Is_Known_Valid (Typ) then
if Is_Entity_Name (Expr)
then
return Expr_Known_Valid (Expression (Expr));
- -- The result of any function call or operator is always considered
- -- valid, since we assume the necessary checks are done by the call.
- -- For operators on floating-point operations, we must also check
- -- when the operation is the right-hand side of an assignment, or
- -- is an actual in a call.
+ -- The result of any operator is always considered valid, since we
+ -- assume the necessary checks are done by the operator. For operators
+ -- on floating-point operations, we must also check when the operation
+ -- is the right-hand side of an assignment, or is an actual in a call.
- elsif
- Nkind (Expr) in N_Binary_Op or else Nkind (Expr) in N_Unary_Op
- then
+ elsif Nkind (Expr) in N_Op then
if Is_Floating_Point_Type (Typ)
and then Validity_Check_Floating_Point
and then
return True;
end if;
- elsif Nkind (Expr) = N_Function_Call then
+ -- The result of a membership test is always valid, since it is true or
+ -- false, there are no other possibilities.
+
+ elsif Nkind (Expr) in N_Membership_Test then
return True;
-- For all other cases, we do not know the expression is valid
-- 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;
return;
end if;
- -- Come here with expression of appropriate form, check if
- -- entity is an appropriate one for our purposes.
+ -- Come here with expression of appropriate form, check if entity is an
+ -- appropriate one for our purposes.
if (Ekind (Ent) = E_Variable
- or else
- Ekind (Ent) = E_Constant
- or else
- Ekind (Ent) = E_Loop_Parameter
- or else
- Ekind (Ent) = E_In_Parameter)
+ or else Is_Constant_Object (Ent))
and then not Is_Library_Level_Entity (Ent)
then
Entry_OK := True;
-- If we fall through entry was not found
- Check_Num := 0;
return;
end Find_Check;
---------------------------------
-- Note: the code for this procedure is derived from the
- -- emit_discriminant_check routine a-trans.c v1.659.
+ -- Emit_Discriminant_Check Routine in trans.c.
procedure Generate_Discriminant_Check (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
-- List of arguments for function call
Formal : Entity_Id;
- -- Keep track of the formal corresponding to the actual we build
- -- for each discriminant, in order to be able to perform the
- -- necessary type conversions.
+ -- Keep track of the formal corresponding to the actual we build for
+ -- each discriminant, in order to be able to perform the necessary type
+ -- conversions.
Scomp : Node_Id;
-- Selected component reference for checking function argument
if Is_Tagged_Type (Scope (Orig_Comp)) then
Pref_Type := Scope (Orig_Comp);
- -- For an untagged derived type, use the discriminants of the
- -- parent which have been renamed in the derivation, possibly
- -- by a one-to-many discriminant constraint.
- -- For non-tagged type, initially get the Etype of the prefix
+ -- For an untagged derived type, use the discriminants of the parent
+ -- which have been renamed in the derivation, possibly by a one-to-many
+ -- discriminant constraint. For non-tagged type, initially get the Etype
+ -- of the prefix
else
if Is_Derived_Type (Pref_Type)
-- Manually analyze and resolve this selected component. We really
-- want it just as it appears above, and do not want the expander
- -- playing discriminal games etc with this reference. Then we
- -- append the argument to the list we are gathering.
+ -- playing discriminal games etc with this reference. Then we append
+ -- the argument to the list we are gathering.
Set_Etype (Scomp, Etype (Real_Discr));
Set_Analyzed (Scomp, True);
Num : List_Id;
begin
+ -- Ignore call if index checks suppressed for array object or type
+
+ if (Is_Entity_Name (A) and then Index_Checks_Suppressed (Entity (A)))
+ or else Index_Checks_Suppressed (Etype (A))
+ then
+ return;
+ end if;
+
+ -- Generate the checks
+
Sub := First (Expressions (N));
Ind := 1;
while Present (Sub) loop
if Do_Range_Check (Sub) then
Set_Do_Range_Check (Sub, False);
- -- Force evaluation except for the case of a simple name of
- -- a non-volatile entity.
+ -- Force evaluation except for the case of a simple name of a
+ -- non-volatile entity.
if not Is_Entity_Name (Sub)
or else Treat_As_Volatile (Entity (Sub))
-- Base_Type(Sub) not in array'range (subscript)
- -- Note that the reason we generate the conversion to the
- -- base type here is that we definitely want the range check
- -- to take place, even if it looks like the subtype is OK.
- -- Optimization considerations that allow us to omit the
- -- check have already been taken into account in the setting
- -- of the Do_Range_Check flag earlier on.
+ -- Note that the reason we generate the conversion to the base
+ -- type here is that we definitely want the range check to take
+ -- place, even if it looks like the subtype is OK. Optimization
+ -- considerations that allow us to omit the check have already
+ -- been taken into account in the setting of the Do_Range_Check
+ -- flag earlier on.
if Ind = 1 then
Num := No_List;
Duplicate_Subexpr_Move_Checks (Sub)),
Right_Opnd =>
Make_Attribute_Reference (Loc,
- Prefix => Duplicate_Subexpr_Move_Checks (A),
+ Prefix =>
+ Duplicate_Subexpr_Move_Checks (A, Name_Req => True),
Attribute_Name => Name_Range,
Expressions => Num)),
Reason => CE_Index_Check_Failed));
Target_Base_Type : constant Entity_Id := Base_Type (Target_Type);
begin
- -- First special case, if the source type is already within the
- -- range of the target type, then no check is needed (probably we
- -- should have stopped Do_Range_Check from being set in the first
- -- place, but better late than later in preventing junk code!
+ -- First special case, if the source type is already within the range
+ -- of the target type, then no check is needed (probably we should have
+ -- stopped Do_Range_Check from being set in the first place, but better
+ -- late than later in preventing junk code!
- -- We do NOT apply this if the source node is a literal, since in
- -- this case the literal has already been labeled as having the
- -- subtype of the target.
+ -- We do NOT apply this if the source node is a literal, since in this
+ -- case the literal has already been labeled as having the subtype of
+ -- the target.
if In_Subrange_Of (Source_Type, Target_Type)
and then not
Force_Evaluation (N);
end if;
- -- The easiest case is when Source_Base_Type and Target_Base_Type
- -- are the same since in this case we can simply do a direct
- -- check of the value of N against the bounds of Target_Type.
+ -- The easiest case is when Source_Base_Type and Target_Base_Type are
+ -- the same since in this case we can simply do a direct check of the
+ -- value of N against the bounds of Target_Type.
-- [constraint_error when N not in Target_Type]
-- 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),
Attribute_Name => Name_Last)))),
Reason => Reason));
- -- Note that at this stage we now that the Target_Base_Type is
- -- not in the range of the Source_Base_Type (since even the
- -- Target_Type itself is not in this range). It could still be
- -- the case that the Source_Type is in range of the target base
- -- type, since we have not checked that case.
+ -- Note that at this stage we now that the Target_Base_Type is not in
+ -- the range of the Source_Base_Type (since even the Target_Type itself
+ -- is not in this range). It could still be the case that Source_Type is
+ -- in range of the target base type since we have not checked that case.
- -- If that is the case, we can freely convert the source to the
- -- target, and then test the target result against the bounds.
+ -- 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) 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 this temporary.
+ -- 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
+ -- this temporary.
-- Tnn : constant Target_Base_Type := Target_Base_Type (N);
-- [constraint_error when Tnn not in Target_Type]
-- 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 (
Reason => Reason)));
Rewrite (N, New_Occurrence_Of (Tnn, Loc));
+
+ -- Set the type of N, because the declaration for Tnn might not
+ -- be analyzed yet, as is the case if N appears within a record
+ -- declaration, as a discriminant constraint or expression.
+
+ Set_Etype (N, Target_Base_Type);
end;
-- At this stage, we know that we have two scalar types, which are
-- know that the source is not shorter than the target (otherwise
-- the source base type would be in the target base type range).
- -- In other words, the unsigned type is either the same size
- -- as the target, or it is larger. It cannot be smaller.
+ -- In other words, the unsigned type is either the same size as
+ -- the target, or it is larger. It cannot be smaller.
pragma Assert
(Esize (Source_Base_Type) >= Esize (Target_Base_Type));
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)
and then Is_Unsigned_Type (Target_Base_Type));
- -- If the source is signed and the target is unsigned, then
- -- we know that the target is not shorter than the source
- -- (otherwise the target base type would be in the source
- -- base type range).
+ -- If the source is signed and the target is unsigned, then we
+ -- know that the target is not shorter than the source (otherwise
+ -- the target base type would be in the source base type range).
- -- In other words, the unsigned type is either the same size
- -- as the target, or it is larger. It cannot be smaller.
+ -- In other words, the unsigned type is either the same size as
+ -- the target, or it is larger. It cannot be smaller.
- -- Clearly we have an error if the source value is negative
- -- since no unsigned type can have negative values. If the
- -- source type is non-negative, then the check can be done
- -- using the target type.
+ -- Clearly we have an error if the source value is negative since
+ -- no unsigned type can have negative values. If the source type
+ -- is non-negative, then the check can be done using the target
+ -- type.
-- Tnn : constant Target_Base_Type (N) := Target_Type;
-- [constraint_error
-- when N < 0 or else Tnn not in Target_Type];
- -- We turn off all checks for the conversion of N to the
- -- target base type, since we generate the explicit check
- -- to ensure that the value is non-negative
+ -- We turn off all checks for the conversion of N to the target
+ -- base type, since we generate the explicit check to ensure that
+ -- 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))),
Reason => Reason)),
Suppress => All_Checks);
- -- Set the Etype explicitly, because Insert_Actions may
- -- have placed the declaration in the freeze list for an
- -- enclosing construct, and thus it is not analyzed yet.
+ -- Set the Etype explicitly, because Insert_Actions may have
+ -- placed the declaration in the freeze list for an enclosing
+ -- construct, and thus it is not analyzed yet.
Set_Etype (Tnn, Target_Base_Type);
Rewrite (N, New_Occurrence_Of (Tnn, Loc));
end if;
end Generate_Range_Check;
+ ------------------
+ -- Get_Check_Id --
+ ------------------
+
+ function Get_Check_Id (N : Name_Id) return Check_Id is
+ begin
+ -- For standard check name, we can do a direct computation
+
+ if N in First_Check_Name .. Last_Check_Name then
+ return Check_Id (N - (First_Check_Name - 1));
+
+ -- For non-standard names added by pragma Check_Name, search table
+
+ else
+ for J in All_Checks + 1 .. Check_Names.Last loop
+ if Check_Names.Table (J) = N then
+ return J;
+ end if;
+ end loop;
+ end if;
+
+ -- No matching name found
+
+ return No_Check_Id;
+ end Get_Check_Id;
+
---------------------
-- Get_Discriminal --
---------------------
Sc : Entity_Id;
begin
- -- The entity E is the type of a private component of the protected
- -- type, or the type of a renaming of that component within a protected
- -- operation of that type.
+ -- The bound can be a bona fide parameter of a protected operation,
+ -- rather than a prival encoded as an in-parameter.
- Sc := Scope (E);
+ if No (Discriminal_Link (Entity (Bound))) then
+ return Bound;
+ end if;
- if Ekind (Sc) /= E_Protected_Type then
- Sc := Scope (Sc);
+ -- Climb the scope stack looking for an enclosing protected type. If
+ -- we run out of scopes, return the bound itself.
- if Ekind (Sc) /= E_Protected_Type then
+ Sc := Scope (E);
+ while Present (Sc) loop
+ if Sc = Standard_Standard then
return Bound;
+
+ elsif Ekind (Sc) = E_Protected_Type then
+ exit;
end if;
- end if;
+
+ Sc := Scope (Sc);
+ end loop;
D := First_Discriminant (Sc);
+ while Present (D) loop
+ if Chars (D) = Chars (Bound) then
+ return New_Occurrence_Of (Discriminal (D), Loc);
+ end if;
- while Present (D)
- and then Chars (D) /= Chars (Bound)
- loop
Next_Discriminant (D);
end loop;
- return New_Occurrence_Of (Discriminal (D), Loc);
+ return Bound;
end Get_Discriminal;
+ ----------------------
+ -- Get_Range_Checks --
+ ----------------------
+
+ function Get_Range_Checks
+ (Ck_Node : Node_Id;
+ Target_Typ : Entity_Id;
+ Source_Typ : Entity_Id := Empty;
+ Warn_Node : Node_Id := Empty) return Check_Result
+ is
+ begin
+ return Selected_Range_Checks
+ (Ck_Node, Target_Typ, Source_Typ, Warn_Node);
+ end Get_Range_Checks;
+
------------------
-- Guard_Access --
------------------
for J in Determine_Range_Cache_N'Range loop
Determine_Range_Cache_N (J) := Empty;
end loop;
+
+ Check_Names.Init;
+
+ for J in Int range 1 .. All_Checks loop
+ Check_Names.Append (Name_Id (Int (First_Check_Name) + J - 1));
+ end loop;
end Initialize;
-------------------------
(not Range_Checks_Suppressed (Suppress_Typ));
begin
- -- For now we just return if Checks_On is false, however this should
- -- be enhanced to check for an always True value in the condition
- -- and to generate a compilation warning???
+ -- For now we just return if Checks_On is false, however this should be
+ -- enhanced to check for an always True value in the condition and to
+ -- generate a compilation warning???
if not Expander_Active or else not Checks_On then
return;
Internal_Flag_Node := Node;
end if;
- for J in 1 .. 2 loop
- exit when No (Checks (J));
+ for J in 1 .. 2 loop
+ exit when No (Checks (J));
+
+ if Nkind (Checks (J)) = N_Raise_Constraint_Error
+ and then Present (Condition (Checks (J)))
+ then
+ if not Has_Dynamic_Range_Check (Internal_Flag_Node) then
+ Check_Node := Checks (J);
+ Mark_Rewrite_Insertion (Check_Node);
+
+ if Do_Before then
+ Insert_Before_And_Analyze (Node, Check_Node);
+ else
+ Insert_After_And_Analyze (Node, Check_Node);
+ end if;
+
+ Set_Has_Dynamic_Range_Check (Internal_Flag_Node);
+ end if;
+
+ else
+ Check_Node :=
+ Make_Raise_Constraint_Error (Internal_Static_Sloc,
+ Reason => CE_Range_Check_Failed);
+ Mark_Rewrite_Insertion (Check_Node);
+
+ if Do_Before then
+ Insert_Before_And_Analyze (Node, Check_Node);
+ else
+ Insert_After_And_Analyze (Node, Check_Node);
+ end if;
+ end if;
+ end loop;
+ end Insert_Range_Checks;
+
+ ------------------------
+ -- Insert_Valid_Check --
+ ------------------------
+
+ procedure Insert_Valid_Check (Expr : Node_Id) is
+ Loc : constant Source_Ptr := Sloc (Expr);
+ Exp : Node_Id;
+
+ begin
+ -- 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;
+
+ -- If we have a checked conversion, then validity check applies to
+ -- the expression inside the conversion, not the result, since if
+ -- the expression inside is valid, then so is the conversion result.
+
+ Exp := Expr;
+ while Nkind (Exp) = N_Type_Conversion loop
+ Exp := Expression (Exp);
+ end loop;
+
+ -- We are about to insert the validity check for Exp. We save and
+ -- reset the Do_Range_Check flag over this validity check, and then
+ -- put it back for the final original reference (Exp may be rewritten).
+
+ declare
+ DRC : constant Boolean := Do_Range_Check (Exp);
+
+ 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!
+
+ Insert_Action
+ (Expr,
+ Make_Raise_Constraint_Error (Loc,
+ Condition =>
+ Make_Op_Not (Loc,
+ Right_Opnd =>
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ Duplicate_Subexpr_No_Checks (Exp, Name_Req => True),
+ Attribute_Name => Name_Valid)),
+ Reason => CE_Invalid_Data),
+ Suppress => Validity_Check);
+
+ -- If the expression is a a reference to an element of a bit-packed
+ -- array, then it is rewritten as a renaming declaration. If the
+ -- expression is an actual in a call, it has not been expanded,
+ -- waiting for the proper point at which to do it. The same happens
+ -- with renamings, so that we have to force the expansion now. This
+ -- non-local complication is due to code in exp_ch2,adb, exp_ch4.adb
+ -- and exp_ch6.adb.
+
+ if Is_Entity_Name (Exp)
+ and then Nkind (Parent (Entity (Exp))) =
+ N_Object_Renaming_Declaration
+ then
+ declare
+ Old_Exp : constant Node_Id := Name (Parent (Entity (Exp)));
+ begin
+ if Nkind (Old_Exp) = N_Indexed_Component
+ and then Is_Bit_Packed_Array (Etype (Prefix (Old_Exp)))
+ then
+ Expand_Packed_Element_Reference (Old_Exp);
+ end if;
+ end;
+ end if;
+
+ -- Put back the Do_Range_Check flag on the resulting (possibly
+ -- rewritten) expression.
+
+ -- Note: it might be thought that a validity check is not required
+ -- when a range check is present, but that's not the case, because
+ -- the back end is allowed to assume for the range check that the
+ -- operand is within its declared range (an assumption that validity
+ -- checking is all about NOT assuming!)
+
+ -- Note: no need to worry about Possible_Local_Raise here, it will
+ -- already have been called if original node has Do_Range_Check set.
+
+ Set_Do_Range_Check (Exp, DRC);
+ end;
+ end Insert_Valid_Check;
+
+ ----------------------------------
+ -- Install_Null_Excluding_Check --
+ ----------------------------------
+
+ procedure Install_Null_Excluding_Check (N : Node_Id) is
+ Loc : constant Source_Ptr := Sloc (Parent (N));
+ Typ : constant Entity_Id := Etype (N);
+
+ 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.
+
+ 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
+ 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)
+ or else Scope (E) /= S
+ then
+ return False;
+ end if;
+
+ S_Par := Parent (Parent (S));
+
+ if Nkind (S_Par) /= N_Subprogram_Body
+ or else No (Declarations (S_Par))
+ then
+ return False;
+ end if;
+
+ declare
+ N_Decl : Node_Id;
+ P : Node_Id;
+
+ begin
+ -- Retrieve the declaration node of N (if any). Note that N
+ -- may be a part of a complex initialization expression.
+
+ P := Parent (N);
+ 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.
+
+ if Nkind (P) in N_Statement_Other_Than_Procedure_Call
+ or else Nkind (P) = N_Procedure_Call_Statement
+ then
+ 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
+ N_Decl := P;
+ exit;
+ end if;
+
+ P := Parent (P);
+ end loop;
+
+ if No (N_Decl) then
+ return False;
+ end if;
+
+ return List_Containing (N_Decl) = Declarations (S_Par);
+ end;
+ end Safe_To_Capture_In_Parameter_Value;
+
+ -------------------
+ -- Mark_Non_Null --
+ -------------------
+
+ procedure Mark_Non_Null is
+ begin
+ -- Only case of interest is if node N is an entity name
- if Nkind (Checks (J)) = N_Raise_Constraint_Error
- and then Present (Condition (Checks (J)))
- then
- if not Has_Dynamic_Range_Check (Internal_Flag_Node) then
- Check_Node := Checks (J);
- Mark_Rewrite_Insertion (Check_Node);
+ if Is_Entity_Name (N) then
- if Do_Before then
- Insert_Before_And_Analyze (Node, Check_Node);
- else
- Insert_After_And_Analyze (Node, Check_Node);
- end if;
+ -- For sure, we want to clear an indication that this is known to
+ -- be null, since if we get past this check, it definitely is not!
- Set_Has_Dynamic_Range_Check (Internal_Flag_Node);
- end if;
+ Set_Is_Known_Null (Entity (N), False);
- else
- Check_Node :=
- Make_Raise_Constraint_Error (Internal_Static_Sloc,
- Reason => CE_Range_Check_Failed);
- Mark_Rewrite_Insertion (Check_Node);
+ -- We can mark the entity as known to be non-null if either it is
+ -- 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 if the expression
+ -- is sure to be elaborated, since we know we have to elaborate
+ -- all declarations before executing the body.
- if Do_Before then
- Insert_Before_And_Analyze (Node, Check_Node);
- else
- Insert_After_And_Analyze (Node, Check_Node);
+ -- Couldn't this always be part of Safe_To_Capture_Value ???
+
+ if Safe_To_Capture_Value (N, Entity (N))
+ or else Safe_To_Capture_In_Parameter_Value
+ then
+ Set_Is_Known_Non_Null (Entity (N));
end if;
end if;
- end loop;
- end Insert_Range_Checks;
-
- ------------------------
- -- Insert_Valid_Check --
- ------------------------
+ end Mark_Non_Null;
- procedure Insert_Valid_Check (Expr : Node_Id) is
- Loc : constant Source_Ptr := Sloc (Expr);
- Exp : Node_Id;
+ -- Start of processing for Install_Null_Excluding_Check
begin
- -- Do not insert if checks off, or if not checking validity
+ pragma Assert (Is_Access_Type (Typ));
- if Range_Checks_Suppressed (Etype (Expr))
- or else (not Validity_Checks_On)
- then
+ -- No check inside a generic (why not???)
+
+ if Inside_A_Generic then
return;
end if;
- -- If we have a checked conversion, then validity check applies to
- -- the expression inside the conversion, not the result, since if
- -- the expression inside is valid, then so is the conversion result.
-
- Exp := Expr;
- while Nkind (Exp) = N_Type_Conversion loop
- Exp := Expression (Exp);
- end loop;
+ -- No check needed if known to be non-null
- -- 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!
-
- Validity_Checks_On := False;
- Insert_Action
- (Expr,
- Make_Raise_Constraint_Error (Loc,
- Condition =>
- Make_Op_Not (Loc,
- Right_Opnd =>
- Make_Attribute_Reference (Loc,
- Prefix =>
- Duplicate_Subexpr_No_Checks (Exp, Name_Req => True),
- Attribute_Name => Name_Valid)),
- Reason => CE_Invalid_Data),
- Suppress => All_Checks);
-
- -- If the expression is a a reference to an element of a bit-packed
- -- array, it is rewritten as a renaming declaration. If the expression
- -- is an actual in a call, it has not been expanded, waiting for the
- -- proper point at which to do it. The same happens with renamings, so
- -- that we have to force the expansion now. This non-local complication
- -- is due to code in exp_ch2,adb, exp_ch4.adb and exp_ch6.adb.
-
- if Is_Entity_Name (Exp)
- and then Nkind (Parent (Entity (Exp))) = N_Object_Renaming_Declaration
- then
- declare
- Old_Exp : constant Node_Id := Name (Parent (Entity (Exp)));
- begin
- if Nkind (Old_Exp) = N_Indexed_Component
- and then Is_Bit_Packed_Array (Etype (Prefix (Old_Exp)))
- then
- Expand_Packed_Element_Reference (Old_Exp);
- end if;
- end;
+ if Known_Non_Null (N) then
+ return;
end if;
- Validity_Checks_On := True;
- end Insert_Valid_Check;
+ -- If known to be null, here is where we generate a compile time check
- ----------------------------------
- -- Install_Null_Excluding_Check --
- ----------------------------------
+ if Known_Null (N) then
- procedure Install_Null_Excluding_Check (N : Node_Id) is
- Loc : constant Source_Ptr := Sloc (N);
- Etyp : constant Entity_Id := Etype (N);
+ -- Avoid generating warning message inside init procs
- begin
- pragma Assert (Is_Access_Type (Etyp));
+ 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;
- -- Don't need access check if:
- -- 1) we are analyzing a generic
- -- 2) it is known to be non-null
- -- 3) the check was suppressed on the type
- -- 4) This is an attribute reference that returns an access type.
+ -- If entity is never assigned, for sure a warning is appropriate
- if Inside_A_Generic
- or else Access_Checks_Suppressed (Etyp)
- then
+ if Is_Entity_Name (N) then
+ Check_Unset_Reference (N);
+ end if;
+
+ -- No check needed if checks are suppressed on the range. Note that we
+ -- don't set Is_Known_Non_Null in this case (we could legitimately do
+ -- so, since the program is erroneous, but we don't like to casually
+ -- propagate such conclusions from erroneosity).
+
+ if Access_Checks_Suppressed (Typ) then
return;
- elsif Nkind (N) = N_Attribute_Reference
- and then
- (Attribute_Name (N) = Name_Access
- or else
- Attribute_Name (N) = Name_Unchecked_Access
- or else
- Attribute_Name (N) = Name_Unrestricted_Access)
+ end if;
+
+ -- No check needed for access to concurrent record types generated by
+ -- the expander. This is not just an optimization (though it does indeed
+ -- remove junk checks). It also avoids generation of junk warnings.
+
+ if Nkind (N) in N_Has_Chars
+ and then Chars (N) = Name_uObject
+ and then Is_Concurrent_Record_Type
+ (Directly_Designated_Type (Etype (N)))
then
return;
- -- Otherwise install access check
-
- else
- Insert_Action (N,
- Make_Raise_Constraint_Error (Loc,
- Condition =>
- Make_Op_Eq (Loc,
- Left_Opnd => Duplicate_Subexpr_Move_Checks (N),
- Right_Opnd => Make_Null (Loc)),
- Reason => CE_Access_Check_Failed));
end if;
+
+ -- Otherwise install access check
+
+ Insert_Action (N,
+ Make_Raise_Constraint_Error (Loc,
+ Condition =>
+ Make_Op_Eq (Loc,
+ Left_Opnd => Duplicate_Subexpr_Move_Checks (N),
+ Right_Opnd => Make_Null (Loc)),
+ Reason => CE_Access_Check_Failed));
+
+ Mark_Non_Null;
end Install_Null_Excluding_Check;
--------------------------
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;
---------------------
w ("Kill_All_Checks");
end if;
- -- We reset the number of saved checks to zero, and also modify
- -- all stack entries for statement ranges to indicate that the
- -- number of checks at each level is now zero.
+ -- We reset the number of saved checks to zero, and also modify all
+ -- stack entries for statement ranges to indicate that the number of
+ -- checks at each level is now zero.
Num_Saved_Checks := 0;
- for J in 1 .. Saved_Checks_TOS loop
+ -- Note: the Int'Min here avoids any possibility of J being out of
+ -- range when called from e.g. Conditional_Statements_Begin.
+
+ for J in 1 .. Int'Min (Saved_Checks_TOS, Saved_Checks_Stack'Last) loop
Saved_Checks_Stack (J) := 0;
end loop;
end Kill_All_Checks;
end if;
end Overflow_Checks_Suppressed;
- -----------------
- -- Range_Check --
- -----------------
-
- function Range_Check
- (Ck_Node : Node_Id;
- Target_Typ : Entity_Id;
- Source_Typ : Entity_Id := Empty;
- Warn_Node : Node_Id := Empty) return Check_Result
- is
- begin
- return Selected_Range_Checks
- (Ck_Node, Target_Typ, Source_Typ, Warn_Node);
- end Range_Check;
-
-----------------------------
-- Range_Checks_Suppressed --
-----------------------------
return Scope_Suppress (Range_Check);
end Range_Checks_Suppressed;
+ -----------------------------------------
+ -- Range_Or_Validity_Checks_Suppressed --
+ -----------------------------------------
+
+ -- Note: the coding would be simpler here if we simply made appropriate
+ -- calls to Range/Validity_Checks_Suppressed, but that would result in
+ -- duplicated checks which we prefer to avoid.
+
+ function Range_Or_Validity_Checks_Suppressed
+ (Expr : Node_Id) return Boolean
+ is
+ begin
+ -- Immediate return if scope checks suppressed for either check
+
+ if Scope_Suppress (Range_Check) or Scope_Suppress (Validity_Check) then
+ return True;
+ end if;
+
+ -- If no expression, that's odd, decide that checks are suppressed,
+ -- since we don't want anyone trying to do checks in this case, which
+ -- is most likely the result of some other error.
+
+ if No (Expr) then
+ return True;
+ end if;
+
+ -- Expression is present, so perform suppress checks on type
+
+ declare
+ Typ : constant Entity_Id := Etype (Expr);
+ begin
+ if Vax_Float (Typ) then
+ return True;
+ elsif Checks_May_Be_Suppressed (Typ)
+ and then (Is_Check_Suppressed (Typ, Range_Check)
+ or else
+ Is_Check_Suppressed (Typ, Validity_Check))
+ then
+ return True;
+ end if;
+ end;
+
+ -- If expression is an entity name, perform checks on this entity
+
+ if Is_Entity_Name (Expr) then
+ declare
+ Ent : constant Entity_Id := Entity (Expr);
+ begin
+ if Checks_May_Be_Suppressed (Ent) then
+ return Is_Check_Suppressed (Ent, Range_Check)
+ or else Is_Check_Suppressed (Ent, Validity_Check);
+ end if;
+ end;
+ end if;
+
+ -- If we fall through, no checks suppressed
+
+ return False;
+ end Range_Or_Validity_Checks_Suppressed;
+
-------------------
-- Remove_Checks --
-------------------
procedure Remove_Checks (Expr : Node_Id) is
- Discard : Traverse_Result;
- pragma Warnings (Off, Discard);
-
function Process (N : Node_Id) return Traverse_Result;
-- Process a single node during the traversal
- function Traverse is new Traverse_Func (Process);
- -- The traversal function itself
+ procedure Traverse is new Traverse_Proc (Process);
+ -- The traversal procedure itself
-------------
-- Process --
case Nkind (N) is
when N_And_Then =>
- Discard := Traverse (Left_Opnd (N));
+ Traverse (Left_Opnd (N));
return Skip;
when N_Attribute_Reference =>
end case;
when N_Or_Else =>
- Discard := Traverse (Left_Opnd (N));
+ Traverse (Left_Opnd (N));
return Skip;
when N_Selected_Component =>
-- Start of processing for Remove_Checks
begin
- Discard := Traverse (Expr);
+ Traverse (Expr);
end Remove_Checks;
----------------------------
------------------
function Get_E_Length (E : Entity_Id; Indx : Nat) return Node_Id is
- Pt : constant Entity_Id := Scope (Scope (E));
+ SE : constant Entity_Id := Scope (E);
N : Node_Id;
E1 : Entity_Id := E;
Make_Integer_Literal (Loc,
Intval => String_Literal_Length (E1));
- elsif Ekind (Pt) = E_Protected_Type
- and then Has_Discriminants (Pt)
- and then Has_Completion (Pt)
+ elsif SE /= Standard_Standard
+ and then Ekind (Scope (SE)) = E_Protected_Type
+ and then Has_Discriminants (Scope (SE))
+ and then Has_Completion (Scope (SE))
and then not Inside_Init_Proc
then
-
-- If the type whose length is needed is a private component
-- constrained by a discriminant, we must expand the 'Length
-- attribute into an explicit computation, using the discriminal
Next_Index (Indx_Type);
end loop;
- Get_Index_Bounds (Indx_Type, Lo, Hi);
+ Get_Index_Bounds (Indx_Type, Lo, Hi);
if Nkind (Lo) = N_Identifier
and then Ekind (Entity (Lo)) = E_In_Parameter
end if;
return N;
-
end if;
end Get_E_Length;
Duplicate_Subexpr_No_Checks (N, Name_Req => True),
Expressions => New_List (
Make_Integer_Literal (Loc, Indx)));
-
end Get_N_Length;
-------------------
Make_Op_Ne (Loc,
Left_Opnd => Get_E_Length (Typ, Indx),
Right_Opnd => Get_E_Length (Exptyp, Indx));
-
end Length_E_Cond;
-------------------
Make_Op_Ne (Loc,
Left_Opnd => Get_E_Length (Typ, Indx),
Right_Opnd => Get_N_Length (Expr, Indx));
-
end Length_N_Cond;
+ -----------------
+ -- Same_Bounds --
+ -----------------
+
function Same_Bounds (L : Node_Id; R : Node_Id) return Boolean is
begin
return
T_Typ := Designated_Type (T_Typ);
Do_Access := True;
- -- A simple optimization
+ -- A simple optimization for the null case
- if Nkind (Ck_Node) = N_Null then
+ if Known_Null (Ck_Node) then
return Ret_Result;
end if;
end if;
Freeze_Before (Ck_Node, T_Typ);
Expr_Actual := Get_Referenced_Object (Ck_Node);
- Exptyp := Get_Actual_Subtype (Expr_Actual);
+ Exptyp := Get_Actual_Subtype (Ck_Node);
if Is_Access_Type (Exptyp) then
Exptyp := Designated_Type (Exptyp);
Ref_Node : Node_Id;
begin
-
- -- At the library level, we need to ensure that the
- -- type of the object is elaborated before the check
- -- itself is emitted. This is only done if the object
- -- is in the current compilation unit, otherwise the
- -- type is frozen and elaborated in its unit.
+ -- At the library level, we need to ensure that the type of
+ -- the object is elaborated before the check itself is
+ -- emitted. This is only done if the object is in the
+ -- current compilation unit, otherwise the type is frozen
+ -- and elaborated in its unit.
if Is_Itype (Exptyp)
and then
-- do not evaluate it more than once.
-- Here Ck_Node is the original expression, or more properly the
- -- result of applying Duplicate_Expr to the original tree,
- -- forcing the result to be a name.
+ -- result of applying Duplicate_Expr to the original tree, forcing
+ -- the result to be a name.
else
declare
-- 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;
-------------------------
begin
if Nkind (LB) = N_Identifier
- and then Ekind (Entity (LB)) = E_Discriminant then
+ and then Ekind (Entity (LB)) = E_Discriminant
+ then
LB := New_Occurrence_Of (Discriminal (Entity (LB)), Loc);
end if;
if Nkind (HB) = N_Identifier
- and then Ekind (Entity (HB)) = E_Discriminant then
+ and then Ekind (Entity (HB)) = E_Discriminant
+ then
HB := New_Occurrence_Of (Discriminal (Entity (HB)), Loc);
end if;
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;
-
- else
- N := Scalar_Range (E);
- 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));
-
+ if Indx > 0 then
+ Exprs := New_List (Make_Integer_Literal (Loc, UI_From_Int (Indx)));
else
- LB := Low_Bound (N);
- HB := High_Bound (N);
+ Exprs := No_List;
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 that has been rewritten to an
- -- N_Raise_Constraint_Error node because it is an out-of-range
- -- value. We may not call Duplicate_Subexpr 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
T_Typ := Designated_Type (T_Typ);
Do_Access := True;
- -- A simple optimization
+ -- A simple optimization for the null case
- if Nkind (Ck_Node) = N_Null then
+ if Known_Null (Ck_Node) then
return Ret_Result;
end if;
end if;
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
HB : Node_Id := High_Bound (Ck_Node);
begin
-
- -- If either bound is a discriminant and we are within
- -- the record declaration, it is a use of the discriminant
- -- in a constraint of a component, and nothing can be
- -- checked here. The check will be emitted within the
- -- init proc. Before then, the discriminal has no real
- -- meaning.
+ -- If either bound is a discriminant and we are within the
+ -- record declaration, it is a use of the discriminant in a
+ -- constraint of a component, and nothing can be checked
+ -- here. The check will be emitted within the init proc.
+ -- Before then, the discriminal has no real meaning.
+ -- Similarly, if the entity is a discriminal, there is no
+ -- check to perform yet.
+
+ -- The same holds within a discriminated synchronized type,
+ -- where the discriminant may constrain a component or an
+ -- entry family.
if Nkind (LB) = N_Identifier
- and then Ekind (Entity (LB)) = E_Discriminant
+ and then Denotes_Discriminant (LB, True)
then
- if Current_Scope = Scope (Entity (LB)) then
+ if Current_Scope = Scope (Entity (LB))
+ or else Is_Concurrent_Type (Current_Scope)
+ or else Ekind (Entity (LB)) /= E_Discriminant
+ then
return Ret_Result;
else
LB :=
end if;
if Nkind (HB) = N_Identifier
- and then Ekind (Entity (HB)) = E_Discriminant
+ and then Denotes_Discriminant (HB, True)
then
- if Current_Scope = Scope (Entity (HB)) then
+ if Current_Scope = Scope (Entity (HB))
+ or else Is_Concurrent_Type (Current_Scope)
+ or else Ekind (Entity (HB)) /= E_Discriminant
+ then
return Ret_Result;
else
HB :=
Right_Opnd => Duplicate_Subexpr_No_Checks (LB)),
Right_Opnd => Cond);
end;
-
end if;
end;
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
L_Index : Node_Id;
R_Index : Node_Id;
- L_Low : Node_Id;
- L_High : Node_Id;
- R_Low : Node_Id;
- R_High : Node_Id;
begin
L_Index := First_Index (T_Typ);
or else
Nkind (R_Index) = N_Raise_Constraint_Error)
then
- Get_Index_Bounds (L_Index, L_Low, L_High);
- Get_Index_Bounds (R_Index, R_Low, R_High);
-
-- Deal with compile time length check. Note that we
-- skip this in the access case, because the access
-- value may be null, so we cannot know statically.
Evolve_Or_Else
(Cond,
Range_Equal_E_Cond (Exptyp, T_Typ, Indx));
-
else
Evolve_Or_Else
(Cond, Range_E_Cond (Exptyp, T_Typ, Indx));
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
- -- Generate an Action to check that the bounds of the
- -- source value are within the constraints imposed by the
- -- target type for a conversion to an unconstrained type.
- -- Rule is 4.6(38).
-
- if Nkind (Parent (Ck_Node)) = N_Type_Conversion then
+ -- For a conversion to an unconstrained array type, generate an
+ -- Action to check that the bounds of the source value are within
+ -- the constraints imposed by the target type (RM 4.6(38)). No
+ -- check is needed for a conversion to an access to unconstrained
+ -- array type, as 4.6(24.15/2) requires the designated subtypes
+ -- of the two access types to statically match.
+
+ if Nkind (Parent (Ck_Node)) = N_Type_Conversion
+ and then not Do_Access
+ then
declare
Opnd_Index : Node_Id;
Targ_Index : Node_Id;
+ Opnd_Range : Node_Id;
begin
- Opnd_Index
- := First_Index (Get_Actual_Subtype (Ck_Node));
+ 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
+ -- entity (as will be the case if it is a named subtype
+ -- or an itype created for a slice) retrieve its range.
+
+ if Is_Entity_Name (Opnd_Index)
+ and then Is_Type (Entity (Opnd_Index))
+ then
+ Opnd_Range := Scalar_Range (Entity (Opnd_Index));
+ else
+ Opnd_Range := Opnd_Index;
+ end if;
- while Opnd_Index /= Empty loop
- if Nkind (Opnd_Index) = N_Range then
- if Is_In_Range
- (Low_Bound (Opnd_Index), Etype (Targ_Index))
+ if Nkind (Opnd_Range) = N_Range then
+ if Is_In_Range
+ (Low_Bound (Opnd_Range), Etype (Targ_Index),
+ Assume_Valid => True)
and then
Is_In_Range
- (High_Bound (Opnd_Index), Etype (Targ_Index))
+ (High_Bound (Opnd_Range), Etype (Targ_Index),
+ Assume_Valid => True)
then
null;
- -- If null range, no check needed
+ -- If null range, no check needed
elsif
- Compile_Time_Known_Value (High_Bound (Opnd_Index))
+ Compile_Time_Known_Value (High_Bound (Opnd_Range))
and then
- Compile_Time_Known_Value (Low_Bound (Opnd_Index))
+ Compile_Time_Known_Value (Low_Bound (Opnd_Range))
and then
- Expr_Value (High_Bound (Opnd_Index)) <
- Expr_Value (Low_Bound (Opnd_Index))
+ Expr_Value (High_Bound (Opnd_Range)) <
+ Expr_Value (Low_Bound (Opnd_Range))
then
null;
elsif Is_Out_Of_Range
- (Low_Bound (Opnd_Index), Etype (Targ_Index))
+ (Low_Bound (Opnd_Range), Etype (Targ_Index),
+ Assume_Valid => True)
or else
Is_Out_Of_Range
- (High_Bound (Opnd_Index), Etype (Targ_Index))
+ (High_Bound (Opnd_Range), Etype (Targ_Index),
+ Assume_Valid => True)
then
Add_Check
(Compile_Time_Constraint_Error
Evolve_Or_Else
(Cond,
Discrete_Range_Cond
- (Opnd_Index, Etype (Targ_Index)));
+ (Opnd_Range, Etype (Targ_Index)));
end if;
end if;
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;
return Scope_Suppress (Tag_Check);
end Tag_Checks_Suppressed;
+ --------------------------
+ -- Validity_Check_Range --
+ --------------------------
+
+ procedure Validity_Check_Range (N : Node_Id) is
+ begin
+ if Validity_Checks_On and Validity_Check_Operands then
+ if Nkind (N) = N_Range then
+ Ensure_Valid (Low_Bound (N));
+ Ensure_Valid (High_Bound (N));
+ end if;
+ end if;
+ end Validity_Check_Range;
+
+ --------------------------------
+ -- Validity_Checks_Suppressed --
+ --------------------------------
+
+ function Validity_Checks_Suppressed (E : Entity_Id) return Boolean is
+ begin
+ if Present (E) and then Checks_May_Be_Suppressed (E) then
+ return Is_Check_Suppressed (E, Validity_Check);
+ else
+ return Scope_Suppress (Validity_Check);
+ end if;
+ end Validity_Checks_Suppressed;
+
end Checks;
OSDN Git Service
