Set_Analyzed (Opnd, True);
Set_Right_Opnd (Opnod, Opnd);
- -- The type of the operation changes to the base type of the check
- -- type, and we reset the overflow check indication, since clearly
- -- no overflow is possible now that we are using a double length
- -- type. We also set the Analyzed flag to avoid a recursive attempt
- -- to expand the node.
+ -- 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.
Set_Etype (Opnod, Base_Type (Ctyp));
Set_Do_Overflow_Check (Opnod, False);
Analyze (Opnd);
Set_Etype (Opnd, Typ);
- -- In the discrete type case, we directly generate the range check
- -- for the outer operand. This range check will implement the required
+ -- In the discrete type case, we directly generate the range check for
+ -- the outer operand. This range check will implement the required
-- overflow check.
if Is_Discrete_Type (Typ) then
-- 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.
+ -- 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.
- -- 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.
+ -- 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.
procedure Apply_Array_Size_Check (N : Node_Id; Typ : Entity_Id) is
Loc : constant Source_Ptr := Sloc (N);
-- 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.
+ -- 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
declare
F : constant Node_Id :=
First (Pragma_Argument_Associations (Decl));
-
begin
return
Present (F)
-- Start of processing for Apply_Array_Size_Check
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.
+ -- 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.
+
+ -- Shouldn't we remove GCC 2 crud at this stage ???
if Opt.GCC_Version >= 3 then
return;
return;
end if;
- -- 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.
+ -- 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.
Decl := N;
for Ctr in 1 .. 20 loop
end if;
end loop;
- -- 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.
+ -- 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.
Siz := Uint_1;
Indx := First_Index (Typ);
Lo := Type_Low_Bound (Xtyp);
Hi := Type_High_Bound (Xtyp);
- -- If any bound raises constraint error, we will never get this
- -- far, so there is no need to generate any kind of check.
+ -- If any bound raises constraint error, we will never get this far,
+ -- so there is no need to generate any kind of check.
if Raises_Constraint_Error (Lo)
or else
Check_Siz := Uint_2 ** 31;
end if;
- -- 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
+ -- If we have all static bounds and Siz is too large, then we know we
+ -- have a storage error right now, so generate message
if Static and then Siz >= Check_Siz then
Insert_Action (N,
return;
end if;
- -- Case of component size known at compile time. If the array
- -- size is definitely in range, then we do not need a check.
+ -- Case of component size known at compile time. If the array size is
+ -- definitely in range, then we do not need a check.
if Known_Esize (Ctyp)
and then Siz * Esize (Ctyp) < Check_Siz
-- Here if a dynamic check is required
- -- 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.
+ -- 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.
Uintp.Release (Umark);
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
return;
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;
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);
-- 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.
-- (3) The range of type I may not be exactly representable in F.
-- (5) X may be a NaN, which will fail any comparison
-- The following steps take care of these issues converting X:
+
-- (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.
(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);
+ 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;
-- 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, Hi : Ureal;
+ -- Bounds to check in floating-point domain
- Lo_Chk,
- Hi_Chk : Node_Id; -- Expressions that are False iff check fails
+ Lo_OK, Hi_OK : Boolean;
+ -- True iff Lo resp. Hi belongs to I'Range
- Reason : RT_Exception_Code;
+ 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.
+ -- 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);
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
-- 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
if Inside_A_Generic then
return;
- -- 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.
+ -- 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.
elsif Target_Typ = Any_Type
or else not Is_Scalar_Type (Target_Typ)
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))
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))
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
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
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.
+ -- 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,
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);
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.
+ -- 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 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;
("null-exclusion must be applied to an access type",
Error_Node);
- -- Enforce legality rule 3.10 (14/1): A null exclusion can only
+ -- 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.
elsif Can_Never_Be_Null (Typ)
if K = N_Object_Declaration
and then No (Expression (N))
+ and then not No_Initialization (N)
then
- -- Add a an expression that assignates null. This node is needed
- -- by Apply_Compile_Time_Constraint_Error, that will replace this
- -- node by a Constraint_Error node.
+ -- 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.
Set_Expression (N, Make_Null (Sloc (N)));
Set_Etype (Expression (N), Etype (Defining_Identifier (N)));
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_Range_Cache_N : array (Cache_Index) of Node_Id;
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.
procedure Determine_Range
(N : Node_Id;
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 the type is not discrete, or is undefined, then we can't do
+ -- anything about determining the range.
if No (Typ) or else not Is_Discrete_Type (Typ)
or else Error_Posted (N)
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);
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.
+ -- 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
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
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);
pg (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.
+ -- 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.
if Nkind (N) /= N_Type_Conversion then
Determine_Range (N, OK, Lo, Hi);
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))
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 =>
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)
pg (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))
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);
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)
pg (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 =>
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;
- -- 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)
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);
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))
-- 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.
+ -- reference discriminants out of scope. Discriminants of concurrent
+ -- types are excluded for the same reason.
elsif Is_Entity_Name (Expr)
- and then Ekind (Entity (Expr)) = E_Discriminant
+ 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.
+ -- 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)
return True;
end if;
- -- The result of a membership test is always valid, since it is true
- -- or false, there are no other possibilities.
+ -- 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;
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
---------------------------------
-- 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);
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;
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]
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]
-- 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));
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 :=
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));
(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;
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;
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
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
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;
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.
+ -- Case of a bound rewritten to an N_Raise_Constraint_Error node
+ -- because it is an out-of-range value. Duplicate_Subexpr cannot be
+ -- called on this node because an N_Raise_Constraint_Error is not
+ -- side effect free, and we may not assume that we are in the proper
+ -- context to remove side effects on it at the point of reference.
elsif Nkind (Bound) = N_Raise_Constraint_Error then
return New_Copy_Tree (Bound);
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)));
-
end Range_E_Cond;
------------------------
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. 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 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 Denotes_Discriminant (LB, True)
Right_Opnd => Duplicate_Subexpr_No_Checks (LB)),
Right_Opnd => Cond);
end;
-
end if;
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;
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 Opnd_Index /= Empty loop
if Nkind (Opnd_Index) = N_Range then
if Is_In_Range
then
null;
- -- If null range, no check needed
+ -- If null range, no check needed
elsif
Compile_Time_Known_Value (High_Bound (Opnd_Index))
projects / gcc.git / commitdiff