Skip to content

R
riscv-gcc-1
Commit 675d6070 by Thomas Quinot Committed by Arnaud Charlet
Options

checks.ads, checks.adb (Selected_Range_Checks): No range check is required for a… 

checks.ads, checks.adb (Selected_Range_Checks): No range check is required for a conversion between two...

2007-04-06  Thomas Quinot  <quinot@adacore.com>
	    Ed Schonberg  <schonberg@adacore.com>
	    Gary Dismukes  <dismukes@adacore.com>

	* checks.ads, checks.adb (Selected_Range_Checks): No range check is
	required for a conversion between two access-to-unconstrained-array
	types.
	(Expr_Known_Valid): Validity checks do not apply to discriminants, but
	to discriminant constraints on discriminant objects. This rule must
	apply as well to discriminants of protected types in private components.
	(Null_Exclusion_Static_Checks): If No_Initialization is set on an
	object of a null-excluding access type then don't require the
	the object declaration to have an expression and don't emit a
	run-time check.

From-SVN: r123554
parent 4cd52f5e
Showing with 385 additions and 382 deletions
gcc/ada/checks.adb
......@@ -820,11 +820,10 @@ package body Checks is
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);
......@@ -836,8 +835,8 @@ package body Checks is
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
......@@ -863,16 +862,16 @@ package body Checks is
-- 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);
......@@ -893,8 +892,8 @@ package body Checks is
-- 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
......@@ -929,7 +928,6 @@ package body Checks is
declare
F : constant Node_Id :=
First (Pragma_Argument_Associations (Decl));
begin
return
Present (F)
......@@ -953,9 +951,11 @@ package body Checks is
-- 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;
......@@ -981,10 +981,10 @@ package body Checks is
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
......@@ -996,10 +996,10 @@ package body Checks is
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);
......@@ -1008,8 +1008,8 @@ package body Checks is
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
......@@ -1049,8 +1049,8 @@ package body Checks is
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,
......@@ -1061,8 +1061,8 @@ package body Checks is
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
......@@ -1073,9 +1073,9 @@ package body Checks is
-- 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);
......@@ -1266,15 +1266,15 @@ package body Checks is
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;
......@@ -1311,9 +1311,9 @@ package body Checks is
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;
......@@ -1333,9 +1333,9 @@ package body Checks is
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)
......@@ -1349,9 +1349,9 @@ package body Checks is
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)))
......@@ -1373,9 +1373,9 @@ package body Checks is
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
......@@ -1393,10 +1393,10 @@ package body Checks is
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);
......@@ -1578,15 +1578,15 @@ package body Checks is
-- 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.
......@@ -1595,6 +1595,7 @@ package body Checks is
-- (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.
......@@ -1617,21 +1618,25 @@ package body Checks is
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
Lo_Chk, Hi_Chk : Node_Id;
-- Expressions that are False iff check fails
Reason : RT_Exception_Code;
......@@ -1640,9 +1645,9 @@ package body Checks is
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);
......@@ -1734,9 +1739,9 @@ package body Checks is
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
......@@ -1786,8 +1791,8 @@ package body Checks is
-- 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;
......@@ -1810,8 +1815,8 @@ package body Checks is
-- 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
......@@ -1834,10 +1839,10 @@ package body Checks is
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)
......@@ -1901,8 +1906,8 @@ package body Checks is
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))
......@@ -1945,9 +1950,9 @@ package body Checks is
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)
......@@ -1956,16 +1961,15 @@ package body Checks is
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))
......@@ -2047,9 +2051,9 @@ package body Checks is
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
......@@ -2114,9 +2118,8 @@ package body Checks is
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))
......@@ -2207,9 +2210,8 @@ package body Checks is
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))
......@@ -2229,10 +2231,10 @@ package body Checks is
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
......@@ -2294,10 +2296,10 @@ package body Checks is
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);
......@@ -2327,18 +2329,18 @@ package body Checks is
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)
......@@ -2391,7 +2393,6 @@ package body Checks is
begin
Constraint := First_Elmt (Stored_Constraint (Target_Type));
while Present (Constraint) loop
Discr_Value := Node (Constraint);
......@@ -2404,10 +2405,10 @@ package body Checks is
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,
......@@ -2424,8 +2425,8 @@ package body Checks is
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
......@@ -2450,10 +2451,10 @@ package body Checks is
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;
......@@ -2499,11 +2500,11 @@ package body Checks is
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);
......@@ -2545,10 +2546,10 @@ package body Checks 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.
-- 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
......@@ -2755,10 +2756,10 @@ package body Checks is
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;
......@@ -2774,8 +2775,8 @@ package body Checks is
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;
......@@ -2840,7 +2841,7 @@ package body Checks is
("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)
......@@ -2860,10 +2861,11 @@ package body Checks is
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)));
......@@ -2922,15 +2924,15 @@ package body Checks is
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;
......@@ -2950,15 +2952,15 @@ package body Checks is
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);
......@@ -2982,13 +2984,13 @@ package body Checks is
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;
......@@ -3053,8 +3055,8 @@ package body Checks is
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)
......@@ -3067,8 +3069,8 @@ package body Checks is
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);
......@@ -3086,16 +3088,16 @@ package body Checks is
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
......@@ -3129,16 +3131,16 @@ package body Checks is
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
......@@ -3166,9 +3168,9 @@ package body Checks 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
......@@ -3183,8 +3185,8 @@ package body Checks is
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
......@@ -3192,8 +3194,8 @@ package body Checks is
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
......@@ -3214,8 +3216,8 @@ package body Checks is
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
......@@ -3340,8 +3342,8 @@ package body Checks is
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);
......@@ -3499,10 +3501,10 @@ package body Checks is
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);
......@@ -3536,12 +3538,12 @@ package body Checks is
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))
......@@ -3616,10 +3618,10 @@ package body Checks is
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 =>
......@@ -3645,9 +3647,8 @@ package body Checks is
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)
......@@ -3699,12 +3700,12 @@ package body Checks is
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))
......@@ -3746,17 +3747,17 @@ package body Checks is
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)
......@@ -3855,10 +3856,10 @@ package body Checks is
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 =>
......@@ -3889,9 +3890,9 @@ package body Checks is
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.
......@@ -3910,8 +3911,8 @@ package body Checks is
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)
......@@ -3979,10 +3980,10 @@ package body Checks is
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);
......@@ -3994,18 +3995,17 @@ package body Checks is
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);
......@@ -4036,14 +4036,13 @@ package body Checks is
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;
......@@ -4061,8 +4060,8 @@ package body Checks is
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))
......@@ -4073,17 +4072,18 @@ package body Checks is
-- 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)
......@@ -4131,8 +4131,8 @@ package body Checks is
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;
......@@ -4247,8 +4247,8 @@ package body Checks is
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
......@@ -4295,7 +4295,7 @@ package body Checks is
---------------------------------
-- 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);
......@@ -4323,9 +4323,9 @@ package body Checks is
-- 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
......@@ -4363,10 +4363,10 @@ package body Checks is
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)
......@@ -4415,8 +4415,8 @@ package body Checks is
-- 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);
......@@ -4465,8 +4465,8 @@ package body Checks is
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))
......@@ -4479,12 +4479,12 @@ package body Checks is
-- 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;
......@@ -4527,14 +4527,14 @@ package body Checks is
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
......@@ -4561,9 +4561,9 @@ package body Checks is
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]
......@@ -4615,20 +4615,19 @@ package body Checks is
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]
......@@ -4680,8 +4679,8 @@ package body Checks is
-- 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));
......@@ -4761,27 +4760,26 @@ package body Checks is
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 :=
......@@ -4818,9 +4816,9 @@ package body Checks is
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));
......@@ -4944,9 +4942,9 @@ package body Checks is
(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;
......@@ -5193,9 +5191,9 @@ package body Checks is
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;
......@@ -5621,7 +5619,6 @@ package body Checks is
end if;
return N;
end if;
end Get_E_Length;
......@@ -5638,7 +5635,6 @@ package body Checks is
Duplicate_Subexpr_No_Checks (N, Name_Req => True),
Expressions => New_List (
Make_Integer_Literal (Loc, Indx)));
end Get_N_Length;
-------------------
......@@ -5655,7 +5651,6 @@ package body Checks is
Make_Op_Ne (Loc,
Left_Opnd => Get_E_Length (Typ, Indx),
Right_Opnd => Get_E_Length (Exptyp, Indx));
end Length_E_Cond;
-------------------
......@@ -5672,9 +5667,12 @@ package body Checks is
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
......@@ -5807,12 +5805,11 @@ package body Checks is
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
......@@ -5904,8 +5901,8 @@ package body Checks is
-- 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
......@@ -6080,12 +6077,14 @@ package body Checks is
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;
......@@ -6239,12 +6238,11 @@ package body Checks is
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);
......@@ -6305,7 +6303,6 @@ package body Checks is
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;
------------------------
......@@ -6505,18 +6502,17 @@ package body Checks is
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)
......@@ -6557,7 +6553,6 @@ package body Checks is
Right_Opnd => Duplicate_Subexpr_No_Checks (LB)),
Right_Opnd => Cond);
end;
end if;
end;
......@@ -6748,21 +6743,23 @@ package body Checks is
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
......
gcc/ada/checks.ads
......@@ -264,6 +264,12 @@ package Checks is
-- this node is further examined depends on the setting of
-- the parameter Source_Typ, as described below.
-- ??? Apply_Length_Check and Apply_Range_Check do not have an Expr
-- formal
-- ??? Apply_Length_Check and Apply_Range_Check have a Ck_Node formal
-- which is undocumented, is it the same as Expr?
-- Target_Typ The target type on which the check is to be based. For
-- example, if we have a scalar range check, then the check
-- is that we are in range of this type.
......@@ -311,7 +317,7 @@ package Checks is
(Ck_Node : Node_Id;
Target_Typ : Entity_Id;
Source_Typ : Entity_Id := Empty);
-- For an Node of kind N_Range, constructs a range check action that tests
-- For a Node of kind N_Range, constructs a range check action that tests
-- first that the range is not null and then that the range is contained in
-- the Target_Typ range.
--
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment