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 ...@@ -820,11 +820,10 @@ package body Checks is
Set_Analyzed (Opnd, True); Set_Analyzed (Opnd, True);
Set_Right_Opnd (Opnod, Opnd); Set_Right_Opnd (Opnod, Opnd);
-- The type of the operation changes to the base type of the check -- The type of the operation changes to the base type of the check type,
-- type, and we reset the overflow check indication, since clearly -- and we reset the overflow check indication, since clearly no overflow
-- no overflow is possible now that we are using a double length -- is possible now that we are using a double length type. We also set
-- type. We also set the Analyzed flag to avoid a recursive attempt -- the Analyzed flag to avoid a recursive attempt to expand the node.
-- to expand the node.
Set_Etype (Opnod, Base_Type (Ctyp)); Set_Etype (Opnod, Base_Type (Ctyp));
Set_Do_Overflow_Check (Opnod, False); Set_Do_Overflow_Check (Opnod, False);
...@@ -836,8 +835,8 @@ package body Checks is ...@@ -836,8 +835,8 @@ package body Checks is
Analyze (Opnd); Analyze (Opnd);
Set_Etype (Opnd, Typ); Set_Etype (Opnd, Typ);
-- In the discrete type case, we directly generate the range check -- In the discrete type case, we directly generate the range check for
-- for the outer operand. This range check will implement the required -- the outer operand. This range check will implement the required
-- overflow check. -- overflow check.
if Is_Discrete_Type (Typ) then if Is_Discrete_Type (Typ) then
...@@ -863,16 +862,16 @@ package body Checks is ...@@ -863,16 +862,16 @@ package body Checks is
-- Apply_Array_Size_Check -- -- Apply_Array_Size_Check --
---------------------------- ----------------------------
-- The situation is as follows. In GNAT 3 (GCC 2.x), the size in bits -- The situation is as follows. In GNAT 3 (GCC 2.x), the size in bits is
-- is computed in 32 bits without an overflow check. That's a real -- computed in 32 bits without an overflow check. That's a real problem for
-- problem for Ada. So what we do in GNAT 3 is to approximate the -- Ada. So what we do in GNAT 3 is to approximate the size of an array by
-- size of an array by manually multiplying the element size by the -- manually multiplying the element size by the number of elements, and
-- number of elements, and comparing that against the allowed limits. -- comparing that against the allowed limits.
-- In GNAT 5, the size in byte is still computed in 32 bits without -- In GNAT 5, the size in byte is still computed in 32 bits without an
-- an overflow check in the dynamic case, but the size in bits is -- overflow check in the dynamic case, but the size in bits is computed in
-- computed in 64 bits. We assume that's good enough, and we do not -- 64 bits. We assume that's good enough, and we do not bother to generate
-- bother to generate any front end test. -- any front end test.
procedure Apply_Array_Size_Check (N : Node_Id; Typ : Entity_Id) is procedure Apply_Array_Size_Check (N : Node_Id; Typ : Entity_Id) is
Loc : constant Source_Ptr := Sloc (N); Loc : constant Source_Ptr := Sloc (N);
...@@ -893,8 +892,8 @@ package body Checks is ...@@ -893,8 +892,8 @@ package body Checks is
-- Set false if any index subtye bound is non-static -- Set false if any index subtye bound is non-static
Umark : constant Uintp.Save_Mark := Uintp.Mark; Umark : constant Uintp.Save_Mark := Uintp.Mark;
-- We can throw away all the Uint computations here, since they are -- We can throw away all the Uint computations here, since they are done
-- done only to generate boolean test results. -- only to generate boolean test results.
Check_Siz : Uint; Check_Siz : Uint;
-- Size to check against -- Size to check against
...@@ -929,7 +928,6 @@ package body Checks is ...@@ -929,7 +928,6 @@ package body Checks is
declare declare
F : constant Node_Id := F : constant Node_Id :=
First (Pragma_Argument_Associations (Decl)); First (Pragma_Argument_Associations (Decl));
begin begin
return return
Present (F) Present (F)
...@@ -953,9 +951,11 @@ package body Checks is ...@@ -953,9 +951,11 @@ package body Checks is
-- Start of processing for Apply_Array_Size_Check -- Start of processing for Apply_Array_Size_Check
begin begin
-- Do size check on local arrays. We only need this in the GCC 2 -- Do size check on local arrays. We only need this in the GCC 2 case,
-- case, since in GCC 3, we expect the back end to properly handle -- since in GCC 3, we expect the back end to properly handle things.
-- things. This routine can be removed when we baseline GNAT 3. -- 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 if Opt.GCC_Version >= 3 then
return; return;
...@@ -981,10 +981,10 @@ package body Checks is ...@@ -981,10 +981,10 @@ package body Checks is
return; return;
end if; end if;
-- Look head for pragma interface/import or address clause applying -- Look head for pragma interface/import or address clause applying to
-- to this entity. If found, we suppress the check entirely. For now -- this entity. If found, we suppress the check entirely. For now we
-- we only look ahead 20 declarations to stop this becoming too slow -- only look ahead 20 declarations to stop this becoming too slow Note
-- Note that eventually this whole routine gets moved to gigi. -- that eventually this whole routine gets moved to gigi.
Decl := N; Decl := N;
for Ctr in 1 .. 20 loop for Ctr in 1 .. 20 loop
...@@ -996,10 +996,10 @@ package body Checks is ...@@ -996,10 +996,10 @@ package body Checks is
end if; end if;
end loop; end loop;
-- First step is to calculate the maximum number of elements. For -- First step is to calculate the maximum number of elements. For this
-- this calculation, we use the actual size of the subtype if it is -- calculation, we use the actual size of the subtype if it is static,
-- static, and if a bound of a subtype is non-static, we go to the -- and if a bound of a subtype is non-static, we go to the bound of the
-- bound of the base type. -- base type.
Siz := Uint_1; Siz := Uint_1;
Indx := First_Index (Typ); Indx := First_Index (Typ);
...@@ -1008,8 +1008,8 @@ package body Checks is ...@@ -1008,8 +1008,8 @@ package body Checks is
Lo := Type_Low_Bound (Xtyp); Lo := Type_Low_Bound (Xtyp);
Hi := Type_High_Bound (Xtyp); Hi := Type_High_Bound (Xtyp);
-- If any bound raises constraint error, we will never get this -- If any bound raises constraint error, we will never get this far,
-- far, so there is no need to generate any kind of check. -- so there is no need to generate any kind of check.
if Raises_Constraint_Error (Lo) if Raises_Constraint_Error (Lo)
or else or else
...@@ -1049,8 +1049,8 @@ package body Checks is ...@@ -1049,8 +1049,8 @@ package body Checks is
Check_Siz := Uint_2 ** 31; Check_Siz := Uint_2 ** 31;
end if; end if;
-- If we have all static bounds and Siz is too large, then we know -- If we have all static bounds and Siz is too large, then we know we
-- we know we have a storage error right now, so generate message -- have a storage error right now, so generate message
if Static and then Siz >= Check_Siz then if Static and then Siz >= Check_Siz then
Insert_Action (N, Insert_Action (N,
...@@ -1061,8 +1061,8 @@ package body Checks is ...@@ -1061,8 +1061,8 @@ package body Checks is
return; return;
end if; end if;
-- Case of component size known at compile time. If the array -- Case of component size known at compile time. If the array size is
-- size is definitely in range, then we do not need a check. -- definitely in range, then we do not need a check.
if Known_Esize (Ctyp) if Known_Esize (Ctyp)
and then Siz * Esize (Ctyp) < Check_Siz and then Siz * Esize (Ctyp) < Check_Siz
...@@ -1073,9 +1073,9 @@ package body Checks is ...@@ -1073,9 +1073,9 @@ package body Checks is
-- Here if a dynamic check is required -- Here if a dynamic check is required
-- What we do is to build an expression for the size of the array, -- What we do is to build an expression for the size of the array, which
-- which is computed as the 'Size of the array component, times -- is computed as the 'Size of the array component, times the size of
-- the size of each dimension. -- each dimension.
Uintp.Release (Umark); Uintp.Release (Umark);
...@@ -1266,15 +1266,15 @@ package body Checks is ...@@ -1266,15 +1266,15 @@ package body Checks is
return; return;
end if; end if;
-- No discriminant checks necessary for an access when expression -- No discriminant checks necessary for an access when expression is
-- is statically Null. This is not only an optimization, this is -- statically Null. This is not only an optimization, it is fundamental
-- fundamental because otherwise discriminant checks may be generated -- because otherwise discriminant checks may be generated in init procs
-- in init procs for types containing an access to a not-yet-frozen -- for types containing an access to a not-yet-frozen record, causing a
-- record, causing a deadly forward reference. -- deadly forward reference.
-- Also, if the expression is of an access type whose designated -- Also, if the expression is of an access type whose designated type is
-- type is incomplete, then the access value must be null and -- incomplete, then the access value must be null and we suppress the
-- we suppress the check. -- check.
if Nkind (N) = N_Null then if Nkind (N) = N_Null then
return; return;
...@@ -1311,9 +1311,9 @@ package body Checks is ...@@ -1311,9 +1311,9 @@ package body Checks is
T_Typ := Get_Actual_Subtype (Lhs); T_Typ := Get_Actual_Subtype (Lhs);
end if; end if;
-- Nothing to do if the type is unconstrained (this is the case -- Nothing to do if the type is unconstrained (this is the case where
-- where the actual subtype in the RM sense of N is unconstrained -- the actual subtype in the RM sense of N is unconstrained and no check
-- and no check is required). -- is required).
if not Is_Constrained (T_Typ) then if not Is_Constrained (T_Typ) then
return; return;
...@@ -1333,9 +1333,9 @@ package body Checks is ...@@ -1333,9 +1333,9 @@ package body Checks is
return; return;
end if; end if;
-- Suppress checks if the subtypes are the same. -- Suppress checks if the subtypes are the same. the check must be
-- the check must be preserved in an assignment to a formal, because -- preserved in an assignment to a formal, because the constraint is
-- the constraint is given by the actual. -- given by the actual.
if Nkind (Original_Node (N)) /= N_Allocator if Nkind (Original_Node (N)) /= N_Allocator
and then (No (Lhs) and then (No (Lhs)
...@@ -1349,9 +1349,9 @@ package body Checks is ...@@ -1349,9 +1349,9 @@ package body Checks is
return; return;
end if; end if;
-- We can also eliminate checks on allocators with a subtype mark -- We can also eliminate checks on allocators with a subtype mark that
-- that coincides with the context type. The context type may be a -- coincides with the context type. The context type may be a subtype
-- subtype without a constraint (common case, a generic actual). -- without a constraint (common case, a generic actual).
elsif Nkind (Original_Node (N)) = N_Allocator elsif Nkind (Original_Node (N)) = N_Allocator
and then Is_Entity_Name (Expression (Original_Node (N))) and then Is_Entity_Name (Expression (Original_Node (N)))
...@@ -1373,9 +1373,9 @@ package body Checks is ...@@ -1373,9 +1373,9 @@ package body Checks is
end; end;
end if; end if;
-- See if we have a case where the types are both constrained, and -- See if we have a case where the types are both constrained, and all
-- all the constraints are constants. In this case, we can do the -- the constraints are constants. In this case, we can do the check
-- check successfully at compile time. -- successfully at compile time.
-- We skip this check for the case where the node is a rewritten` -- We skip this check for the case where the node is a rewritten`
-- allocator, because it already carries the context subtype, and -- allocator, because it already carries the context subtype, and
...@@ -1393,10 +1393,10 @@ package body Checks is ...@@ -1393,10 +1393,10 @@ package body Checks is
begin begin
-- S_Typ may not have discriminants in the case where it is a -- S_Typ may not have discriminants in the case where it is a
-- private type completed by a default discriminated type. In -- private type completed by a default discriminated type. In that
-- that case, we need to get the constraints from the -- case, we need to get the constraints from the underlying_type.
-- underlying_type. If the underlying type is unconstrained (i.e. -- If the underlying type is unconstrained (i.e. has no default
-- has no default discriminants) no check is needed. -- discriminants) no check is needed.
if Has_Discriminants (S_Typ) then if Has_Discriminants (S_Typ) then
Discr := First_Discriminant (S_Typ); Discr := First_Discriminant (S_Typ);
...@@ -1578,15 +1578,15 @@ package body Checks is ...@@ -1578,15 +1578,15 @@ package body Checks is
-- Apply_Float_Conversion_Check -- -- Apply_Float_Conversion_Check --
---------------------------------- ----------------------------------
-- Let F and I be the source and target types of the conversion. -- Let F and I be the source and target types of the conversion. The RM
-- The Ada standard specifies that a floating-point value X is rounded -- specifies that a floating-point value X is rounded to the nearest
-- to the nearest integer, with halfway cases being rounded away from -- integer, with halfway cases being rounded away from zero. The rounded
-- zero. The rounded value of X is checked against I'Range. -- 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 -- (1) The bounds may not be known at compile time
-- (2) The check must take into account possible rounding. -- (2) The check must take into account possible rounding.
-- (3) The range of type I may not be exactly representable in F. -- (3) The range of type I may not be exactly representable in F.
...@@ -1595,6 +1595,7 @@ package body Checks is ...@@ -1595,6 +1595,7 @@ package body Checks is
-- (5) X may be a NaN, which will fail any comparison -- (5) X may be a NaN, which will fail any comparison
-- The following steps take care of these issues converting X: -- 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 -- (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 -- I'Base instead of I in the next three steps and perform a
-- regular range check against I'Range after conversion. -- regular range check against I'Range after conversion.
...@@ -1617,21 +1618,25 @@ package body Checks is ...@@ -1617,21 +1618,25 @@ package body Checks is
HB : constant Node_Id := Type_High_Bound (Target_Typ); HB : constant Node_Id := Type_High_Bound (Target_Typ);
Loc : constant Source_Ptr := Sloc (Ck_Node); Loc : constant Source_Ptr := Sloc (Ck_Node);
Expr_Type : constant Entity_Id := Base_Type (Etype (Ck_Node)); Expr_Type : constant Entity_Id := Base_Type (Etype (Ck_Node));
Target_Base : constant Entity_Id := Implementation_Base_Type Target_Base : constant Entity_Id :=
(Target_Typ); Implementation_Base_Type (Target_Typ);
Max_Bound : constant Uint := UI_Expon Max_Bound : constant Uint := UI_Expon
(Machine_Radix (Expr_Type), (Machine_Radix (Expr_Type),
Machine_Mantissa (Expr_Type) - 1) - 1; Machine_Mantissa (Expr_Type) - 1) - 1;
-- Largest bound, so bound plus or minus half is a machine number of F -- Largest bound, so bound plus or minus half is a machine number of F
Ifirst, Ifirst, Ilast : Uint;
Ilast : Uint; -- Bounds of integer type -- Bounds of integer type
Lo, Hi : Ureal; -- Bounds to check in floating-point domain
Lo_OK, Lo, Hi : Ureal;
Hi_OK : Boolean; -- True iff Lo resp. Hi belongs to I'Range -- Bounds to check in floating-point domain
Lo_Chk, Lo_OK, Hi_OK : Boolean;
Hi_Chk : Node_Id; -- Expressions that are False iff check fails -- 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; Reason : RT_Exception_Code;
...@@ -1640,9 +1645,9 @@ package body Checks is ...@@ -1640,9 +1645,9 @@ package body Checks is
or not Compile_Time_Known_Value (HB) or not Compile_Time_Known_Value (HB)
then then
declare declare
-- First check that the value falls in the range of the base -- First check that the value falls in the range of the base type,
-- type, to prevent overflow during conversion and then -- to prevent overflow during conversion and then perform a
-- perform a regular range check against the (dynamic) bounds. -- regular range check against the (dynamic) bounds.
Par : constant Node_Id := Parent (Ck_Node); Par : constant Node_Id := Parent (Ck_Node);
...@@ -1734,9 +1739,9 @@ package body Checks is ...@@ -1734,9 +1739,9 @@ package body Checks is
Right_Opnd => Make_Real_Literal (Loc, Hi)); Right_Opnd => Make_Real_Literal (Loc, Hi));
end if; end if;
-- If the bounds of the target type are the same as those of the -- If the bounds of the target type are the same as those of the base
-- base type, the check is an overflow check as a range check is -- type, the check is an overflow check as a range check is not
-- not performed in these cases. -- performed in these cases.
if Expr_Value (Type_Low_Bound (Target_Base)) = Ifirst if Expr_Value (Type_Low_Bound (Target_Base)) = Ifirst
and then Expr_Value (Type_High_Bound (Target_Base)) = Ilast and then Expr_Value (Type_High_Bound (Target_Base)) = Ilast
...@@ -1786,8 +1791,8 @@ package body Checks is ...@@ -1786,8 +1791,8 @@ package body Checks is
-- Apply_Scalar_Range_Check -- -- Apply_Scalar_Range_Check --
------------------------------ ------------------------------
-- Note that Apply_Scalar_Range_Check never turns the Do_Range_Check -- Note that Apply_Scalar_Range_Check never turns the Do_Range_Check flag
-- flag off if it is already set on. -- off if it is already set on.
procedure Apply_Scalar_Range_Check procedure Apply_Scalar_Range_Check
(Expr : Node_Id; (Expr : Node_Id;
...@@ -1810,8 +1815,8 @@ package body Checks is ...@@ -1810,8 +1815,8 @@ package body Checks is
-- range of the subscript, since we don't know the actual subtype. -- range of the subscript, since we don't know the actual subtype.
Int_Real : Boolean; Int_Real : Boolean;
-- Set to True if Expr should be regarded as a real value -- Set to True if Expr should be regarded as a real value even though
-- even though the type of Expr might be discrete. -- the type of Expr might be discrete.
procedure Bad_Value; procedure Bad_Value;
-- Procedure called if value is determined to be out of range -- Procedure called if value is determined to be out of range
...@@ -1834,10 +1839,10 @@ package body Checks is ...@@ -1834,10 +1839,10 @@ package body Checks is
if Inside_A_Generic then if Inside_A_Generic then
return; return;
-- Return if check obviously not needed. Note that we do not check -- Return if check obviously not needed. Note that we do not check for
-- for the expander being inactive, since this routine does not -- the expander being inactive, since this routine does not insert any
-- insert any code, but it does generate useful warnings sometimes, -- code, but it does generate useful warnings sometimes, which we would
-- which we would like even if we are in semantics only mode. -- like even if we are in semantics only mode.
elsif Target_Typ = Any_Type elsif Target_Typ = Any_Type
or else not Is_Scalar_Type (Target_Typ) or else not Is_Scalar_Type (Target_Typ)
...@@ -1901,8 +1906,8 @@ package body Checks is ...@@ -1901,8 +1906,8 @@ package body Checks is
then then
return; return;
-- If Expr is part of an assignment statement, then check -- If Expr is part of an assignment statement, then check left
-- left side of assignment if it is an entity name. -- side of assignment if it is an entity name.
elsif Nkind (Parnt) = N_Assignment_Statement elsif Nkind (Parnt) = N_Assignment_Statement
and then Is_Entity_Name (Name (Parnt)) and then Is_Entity_Name (Name (Parnt))
...@@ -1945,9 +1950,9 @@ package body Checks is ...@@ -1945,9 +1950,9 @@ package body Checks is
Is_Unconstrained_Subscr_Ref := Is_Unconstrained_Subscr_Ref :=
Is_Subscr_Ref and then not Is_Constrained (Arr_Typ); Is_Subscr_Ref and then not Is_Constrained (Arr_Typ);
-- Always do a range check if the source type includes infinities -- Always do a range check if the source type includes infinities and
-- and the target type does not include infinities. We do not do -- the target type does not include infinities. We do not do this if
-- this if range checks are killed. -- range checks are killed.
if Is_Floating_Point_Type (S_Typ) if Is_Floating_Point_Type (S_Typ)
and then Has_Infinities (S_Typ) and then Has_Infinities (S_Typ)
...@@ -1956,16 +1961,15 @@ package body Checks is ...@@ -1956,16 +1961,15 @@ package body Checks is
Enable_Range_Check (Expr); Enable_Range_Check (Expr);
end if; end if;
-- Return if we know expression is definitely in the range of -- Return if we know expression is definitely in the range of the target
-- the target type as determined by Determine_Range. Right now -- type as determined by Determine_Range. Right now we only do this for
-- we only do this for discrete types, and not fixed-point or -- discrete types, and not fixed-point or floating-point types.
-- floating-point types.
-- The additional less-precise tests below catch these cases -- The additional less-precise tests below catch these cases
-- Note: skip this if we are given a source_typ, since the point -- Note: skip this if we are given a source_typ, since the point of
-- of supplying a Source_Typ is to stop us looking at the expression. -- supplying a Source_Typ is to stop us looking at the expression.
-- could sharpen this test to be out parameters only ??? -- We could sharpen this test to be out parameters only ???
if Is_Discrete_Type (Target_Typ) if Is_Discrete_Type (Target_Typ)
and then Is_Discrete_Type (Etype (Expr)) and then Is_Discrete_Type (Etype (Expr))
...@@ -2047,9 +2051,9 @@ package body Checks is ...@@ -2047,9 +2051,9 @@ package body Checks is
Bad_Value; Bad_Value;
return; return;
-- In the floating-point case, we only do range checks if the -- In the floating-point case, we only do range checks if the type is
-- type is constrained. We definitely do NOT want range checks -- constrained. We definitely do NOT want range checks for unconstrained
-- for unconstrained types, since we want to have infinities -- types, since we want to have infinities
elsif Is_Floating_Point_Type (S_Typ) then elsif Is_Floating_Point_Type (S_Typ) then
if Is_Constrained (S_Typ) then if Is_Constrained (S_Typ) then
...@@ -2114,9 +2118,8 @@ package body Checks is ...@@ -2114,9 +2118,8 @@ package body Checks is
end if; end if;
end if; end if;
-- If the item is a conditional raise of constraint error, -- If the item is a conditional raise of constraint error, then have
-- then have a look at what check is being performed and -- a look at what check is being performed and ???
-- ???
if Nkind (R_Cno) = N_Raise_Constraint_Error if Nkind (R_Cno) = N_Raise_Constraint_Error
and then Present (Condition (R_Cno)) and then Present (Condition (R_Cno))
...@@ -2207,9 +2210,8 @@ package body Checks is ...@@ -2207,9 +2210,8 @@ package body Checks is
R_Cno := R_Result (J); R_Cno := R_Result (J);
exit when No (R_Cno); exit when No (R_Cno);
-- If the item is a conditional raise of constraint error, -- If the item is a conditional raise of constraint error, then have
-- then have a look at what check is being performed and -- a look at what check is being performed and ???
-- ???
if Nkind (R_Cno) = N_Raise_Constraint_Error if Nkind (R_Cno) = N_Raise_Constraint_Error
and then Present (Condition (R_Cno)) and then Present (Condition (R_Cno))
...@@ -2229,10 +2231,10 @@ package body Checks is ...@@ -2229,10 +2231,10 @@ package body Checks is
if Is_Entity_Name (Cond) if Is_Entity_Name (Cond)
and then Entity (Cond) = Standard_True and then Entity (Cond) = Standard_True
then then
-- Since an N_Range is technically not an expression, we -- Since an N_Range is technically not an expression, we have
-- have to set one of the bounds to C_E and then just flag -- to set one of the bounds to C_E and then just flag the
-- the N_Range. The warning message will point to the -- N_Range. The warning message will point to the lower bound
-- lower bound and complain about a range, which seems OK. -- and complain about a range, which seems OK.
if Nkind (Ck_Node) = N_Range then if Nkind (Ck_Node) = N_Range then
Apply_Compile_Time_Constraint_Error Apply_Compile_Time_Constraint_Error
...@@ -2294,10 +2296,10 @@ package body Checks is ...@@ -2294,10 +2296,10 @@ package body Checks is
Sub := First (Expressions (Expr)); Sub := First (Expressions (Expr));
while Present (Sub) loop while Present (Sub) loop
-- Check one subscript. Note that we do not worry about -- Check one subscript. Note that we do not worry about enumeration
-- enumeration type with holes, since we will convert the -- type with holes, since we will convert the value to a Pos value
-- value to a Pos value for the subscript, and that convert -- for the subscript, and that convert will do the necessary validity
-- will do the necessary validity check. -- check.
Ensure_Valid (Sub, Holes_OK => True); Ensure_Valid (Sub, Holes_OK => True);
...@@ -2327,18 +2329,18 @@ package body Checks is ...@@ -2327,18 +2329,18 @@ package body Checks is
elsif Serious_Errors_Detected > 0 then elsif Serious_Errors_Detected > 0 then
return; return;
-- Scalar type conversions of the form Target_Type (Expr) require -- Scalar type conversions of the form Target_Type (Expr) require a
-- a range check if we cannot be sure that Expr is in the base type -- range check if we cannot be sure that Expr is in the base type of
-- of Target_Typ and also that Expr is in the range of Target_Typ. -- Target_Typ and also that Expr is in the range of Target_Typ. These
-- These are not quite the same condition from an implementation -- are not quite the same condition from an implementation point of
-- point of view, but clearly the second includes the first. -- view, but clearly the second includes the first.
elsif Is_Scalar_Type (Target_Type) then elsif Is_Scalar_Type (Target_Type) then
declare declare
Conv_OK : constant Boolean := Conversion_OK (N); Conv_OK : constant Boolean := Conversion_OK (N);
-- If the Conversion_OK flag on the type conversion is set -- If the Conversion_OK flag on the type conversion is set and no
-- and no floating point type is involved in the type conversion -- floating point type is involved in the type conversion then
-- then fixed point values must be read as integral values. -- fixed point values must be read as integral values.
Float_To_Int : constant Boolean := Float_To_Int : constant Boolean :=
Is_Floating_Point_Type (Expr_Type) Is_Floating_Point_Type (Expr_Type)
...@@ -2391,7 +2393,6 @@ package body Checks is ...@@ -2391,7 +2393,6 @@ package body Checks is
begin begin
Constraint := First_Elmt (Stored_Constraint (Target_Type)); Constraint := First_Elmt (Stored_Constraint (Target_Type));
while Present (Constraint) loop while Present (Constraint) loop
Discr_Value := Node (Constraint); Discr_Value := Node (Constraint);
...@@ -2404,10 +2405,10 @@ package body Checks is ...@@ -2404,10 +2405,10 @@ package body Checks is
and then Scope (Discr) = Base_Type (Expr_Type) and then Scope (Discr) = Base_Type (Expr_Type)
then then
-- Parent is constrained by new discriminant. Obtain -- Parent is constrained by new discriminant. Obtain
-- Value of original discriminant in expression. If -- Value of original discriminant in expression. If the
-- the new discriminant has been used to constrain more -- new discriminant has been used to constrain more than
-- than one of the stored discriminants, this will -- one of the stored discriminants, this will provide the
-- provide the required consistency check. -- required consistency check.
Append_Elmt ( Append_Elmt (
Make_Selected_Component (Loc, Make_Selected_Component (Loc,
...@@ -2424,8 +2425,8 @@ package body Checks is ...@@ -2424,8 +2425,8 @@ package body Checks is
return; return;
end if; end if;
-- Derived type definition has an explicit value for -- Derived type definition has an explicit value for this
-- this stored discriminant. -- stored discriminant.
else else
Append_Elmt Append_Elmt
...@@ -2450,10 +2451,10 @@ package body Checks is ...@@ -2450,10 +2451,10 @@ package body Checks is
Reason => CE_Discriminant_Check_Failed)); Reason => CE_Discriminant_Check_Failed));
end; end;
-- For arrays, conversions are applied during expansion, to take -- For arrays, conversions are applied during expansion, to take into
-- into accounts changes of representation. The checks become range -- accounts changes of representation. The checks become range checks on
-- checks on the base type or length checks on the subtype, depending -- the base type or length checks on the subtype, depending on whether
-- on whether the target type is unconstrained or constrained. -- the target type is unconstrained or constrained.
else else
null; null;
...@@ -2499,11 +2500,11 @@ package body Checks is ...@@ -2499,11 +2500,11 @@ package body Checks is
then then
Set_Etype (N, Base_Type (Typ)); Set_Etype (N, Base_Type (Typ));
-- Otherwise, replace the attribute node with a type conversion -- Otherwise, replace the attribute node with a type conversion node
-- node whose expression is the attribute, retyped to universal -- whose expression is the attribute, retyped to universal integer, and
-- integer, and whose subtype mark is the target type. The call -- whose subtype mark is the target type. The call to analyze this
-- to analyze this conversion will set range and overflow checks -- conversion will set range and overflow checks as required for proper
-- as required for proper detection of an out of range value. -- detection of an out of range value.
else else
Set_Etype (N, Universal_Integer); Set_Etype (N, Universal_Integer);
...@@ -2545,10 +2546,10 @@ package body Checks is ...@@ -2545,10 +2546,10 @@ package body Checks is
Assoc : Node_Id; Assoc : Node_Id;
begin begin
-- The aggregate has been normalized with named associations. We -- The aggregate has been normalized with named associations. We use
-- use the Chars field to locate the discriminant to take into -- the Chars field to locate the discriminant to take into account
-- account discriminants in derived types, which carry the same -- discriminants in derived types, which carry the same name as those
-- name as those in the parent. -- in the parent.
Assoc := First (Component_Associations (N)); Assoc := First (Component_Associations (N));
while Present (Assoc) loop while Present (Assoc) loop
...@@ -2755,10 +2756,10 @@ package body Checks is ...@@ -2755,10 +2756,10 @@ package body Checks is
if Range_Checks_Suppressed (Etype (Expr)) then if Range_Checks_Suppressed (Etype (Expr)) then
return; return;
-- Only do this check for expressions that come from source. We -- Only do this check for expressions that come from source. We assume
-- assume that expander generated assignments explicitly include -- that expander generated assignments explicitly include any necessary
-- any necessary checks. Note that this is not just an optimization, -- checks. Note that this is not just an optimization, it avoids
-- it avoids infinite recursions! -- infinite recursions!
elsif not Comes_From_Source (Expr) then elsif not Comes_From_Source (Expr) then
return; return;
...@@ -2774,8 +2775,8 @@ package body Checks is ...@@ -2774,8 +2775,8 @@ package body Checks is
elsif Nkind (Expr) = N_Indexed_Component then elsif Nkind (Expr) = N_Indexed_Component then
Apply_Subscript_Validity_Checks (Expr); Apply_Subscript_Validity_Checks (Expr);
-- Prefix may itself be or contain an indexed component, and -- Prefix may itself be or contain an indexed component, and these
-- these subscripts need checking as well -- subscripts need checking as well.
Check_Valid_Lvalue_Subscripts (Prefix (Expr)); Check_Valid_Lvalue_Subscripts (Prefix (Expr));
end if; end if;
...@@ -2840,7 +2841,7 @@ package body Checks is ...@@ -2840,7 +2841,7 @@ package body Checks is
("null-exclusion must be applied to an access type", ("null-exclusion must be applied to an access type",
Error_Node); 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. -- be applied to a [sub]type that does not exclude null already.
elsif Can_Never_Be_Null (Typ) elsif Can_Never_Be_Null (Typ)
...@@ -2860,10 +2861,11 @@ package body Checks is ...@@ -2860,10 +2861,11 @@ package body Checks is
if K = N_Object_Declaration if K = N_Object_Declaration
and then No (Expression (N)) and then No (Expression (N))
and then not No_Initialization (N)
then then
-- Add a an expression that assignates null. This node is needed -- Add an expression that assigns null. This node is needed by
-- by Apply_Compile_Time_Constraint_Error, that will replace this -- Apply_Compile_Time_Constraint_Error, which will replace this with
-- node by a Constraint_Error node. -- a Constraint_Error node.
Set_Expression (N, Make_Null (Sloc (N))); Set_Expression (N, Make_Null (Sloc (N)));
Set_Etype (Expression (N), Etype (Defining_Identifier (N))); Set_Etype (Expression (N), Etype (Defining_Identifier (N)));
...@@ -2922,15 +2924,15 @@ package body Checks is ...@@ -2922,15 +2924,15 @@ package body Checks is
begin begin
Saved_Checks_TOS := Saved_Checks_TOS + 1; Saved_Checks_TOS := Saved_Checks_TOS + 1;
-- If stack overflows, kill all checks, that way we know to -- If stack overflows, kill all checks, that way we know to simply reset
-- simply reset the number of saved checks to zero on return. -- the number of saved checks to zero on return. This should never occur
-- This should never occur in practice. -- in practice.
if Saved_Checks_TOS > Saved_Checks_Stack'Last then if Saved_Checks_TOS > Saved_Checks_Stack'Last then
Kill_All_Checks; Kill_All_Checks;
-- In the normal case, we just make a new stack entry saving -- In the normal case, we just make a new stack entry saving the current
-- the current number of saved checks for a later restore. -- number of saved checks for a later restore.
else else
Saved_Checks_Stack (Saved_Checks_TOS) := Num_Saved_Checks; Saved_Checks_Stack (Saved_Checks_TOS) := Num_Saved_Checks;
...@@ -2950,15 +2952,15 @@ package body Checks is ...@@ -2950,15 +2952,15 @@ package body Checks is
begin begin
pragma Assert (Saved_Checks_TOS > 0); pragma Assert (Saved_Checks_TOS > 0);
-- If the saved checks stack overflowed, then we killed all -- If the saved checks stack overflowed, then we killed all checks, so
-- checks, so setting the number of saved checks back to -- setting the number of saved checks back to zero is correct. This
-- zero is correct. This should never occur in practice. -- should never occur in practice.
if Saved_Checks_TOS > Saved_Checks_Stack'Last then if Saved_Checks_TOS > Saved_Checks_Stack'Last then
Num_Saved_Checks := 0; Num_Saved_Checks := 0;
-- In the normal case, restore the number of saved checks -- In the normal case, restore the number of saved checks from the top
-- from the top stack entry. -- stack entry.
else else
Num_Saved_Checks := Saved_Checks_Stack (Saved_Checks_TOS); Num_Saved_Checks := Saved_Checks_Stack (Saved_Checks_TOS);
...@@ -2982,13 +2984,13 @@ package body Checks is ...@@ -2982,13 +2984,13 @@ package body Checks is
Determine_Range_Cache_N : array (Cache_Index) of Node_Id; Determine_Range_Cache_N : array (Cache_Index) of Node_Id;
Determine_Range_Cache_Lo : array (Cache_Index) of Uint; Determine_Range_Cache_Lo : array (Cache_Index) of Uint;
Determine_Range_Cache_Hi : 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 -- The above arrays are used to implement a small direct cache for
-- for Determine_Range calls. Because of the way Determine_Range -- Determine_Range calls. Because of the way Determine_Range recursively
-- recursively traces subexpressions, and because overflow checking -- traces subexpressions, and because overflow checking calls the routine
-- calls the routine on the way up the tree, a quadratic behavior -- on the way up the tree, a quadratic behavior can otherwise be
-- can otherwise be encountered in large expressions. The cache -- encountered in large expressions. The cache entry for node N is stored
-- entry for node N is stored in the (N mod Cache_Size) entry, and -- in the (N mod Cache_Size) entry, and can be validated by checking the
-- can be validated by checking the actual node value stored there. -- actual node value stored there.
procedure Determine_Range procedure Determine_Range
(N : Node_Id; (N : Node_Id;
...@@ -3053,8 +3055,8 @@ package body Checks is ...@@ -3053,8 +3055,8 @@ package body Checks is
Lor := No_Uint; Lor := No_Uint;
Hir := No_Uint; Hir := No_Uint;
-- If the type is not discrete, or is undefined, then we can't -- If the type is not discrete, or is undefined, then we can't do
-- do anything about determining the range. -- anything about determining the range.
if No (Typ) or else not Is_Discrete_Type (Typ) if No (Typ) or else not Is_Discrete_Type (Typ)
or else Error_Posted (N) or else Error_Posted (N)
...@@ -3067,8 +3069,8 @@ package body Checks is ...@@ -3067,8 +3069,8 @@ package body Checks is
OK := True; OK := True;
-- If value is compile time known, then the possible range is the -- If value is compile time known, then the possible range is the one
-- one value that we know this expression definitely has! -- value that we know this expression definitely has!
if Compile_Time_Known_Value (N) then if Compile_Time_Known_Value (N) then
Lo := Expr_Value (N); Lo := Expr_Value (N);
...@@ -3086,16 +3088,16 @@ package body Checks is ...@@ -3086,16 +3088,16 @@ package body Checks is
return; return;
end if; end if;
-- Otherwise, start by finding the bounds of the type of the -- Otherwise, start by finding the bounds of the type of the expression,
-- expression, the value cannot be outside this range (if it -- the value cannot be outside this range (if it is, then we have an
-- is, then we have an overflow situation, which is a separate -- overflow situation, which is a separate check, we are talking here
-- check, we are talking here only about the expression value). -- only about the expression value).
-- We use the actual bound unless it is dynamic, in which case -- We use the actual bound unless it is dynamic, in which case use the
-- use the corresponding base type bound if possible. If we can't -- corresponding base type bound if possible. If we can't get a bound
-- get a bound then we figure we can't determine the range (a -- then we figure we can't determine the range (a peculiar case, that
-- peculiar case, that perhaps cannot happen, but there is no -- perhaps cannot happen, but there is no point in bombing in this
-- point in bombing in this optimization circuit. -- optimization circuit.
-- First the low bound -- First the low bound
...@@ -3129,16 +3131,16 @@ package body Checks is ...@@ -3129,16 +3131,16 @@ package body Checks is
return; return;
end if; end if;
-- If we have a static subtype, then that may have a tighter bound -- If we have a static subtype, then that may have a tighter bound so
-- so use the upper bound of the subtype instead in this case. -- use the upper bound of the subtype instead in this case.
if Compile_Time_Known_Value (Bound) then if Compile_Time_Known_Value (Bound) then
Hi := Expr_Value (Bound); Hi := Expr_Value (Bound);
end if; end if;
-- We may be able to refine this value in certain situations. If -- We may be able to refine this value in certain situations. If any
-- refinement is possible, then Lor and Hir are set to possibly -- refinement is possible, then Lor and Hir are set to possibly tighter
-- tighter bounds, and OK1 is set to True. -- bounds, and OK1 is set to True.
case Nkind (N) is case Nkind (N) is
...@@ -3166,9 +3168,9 @@ package body Checks is ...@@ -3166,9 +3168,9 @@ package body Checks is
Hir := Hi_Left + Hi_Right; Hir := Hi_Left + Hi_Right;
end if; end if;
-- Division is tricky. The only case we consider is where the -- Division is tricky. The only case we consider is where the right
-- right operand is a positive constant, and in this case we -- operand is a positive constant, and in this case we simply divide
-- simply divide the bounds of the left operand -- the bounds of the left operand
when N_Op_Divide => when N_Op_Divide =>
if OK_Operands then if OK_Operands then
...@@ -3183,8 +3185,8 @@ package body Checks is ...@@ -3183,8 +3185,8 @@ package body Checks is
end if; end if;
end if; end if;
-- For binary subtraction, get range of each operand and do -- For binary subtraction, get range of each operand and do the worst
-- the worst case subtraction to get the result range. -- case subtraction to get the result range.
when N_Op_Subtract => when N_Op_Subtract =>
if OK_Operands then if OK_Operands then
...@@ -3192,8 +3194,8 @@ package body Checks is ...@@ -3192,8 +3194,8 @@ package body Checks is
Hir := Hi_Left - Lo_Right; Hir := Hi_Left - Lo_Right;
end if; end if;
-- For MOD, if right operand is a positive constant, then -- For MOD, if right operand is a positive constant, then result must
-- result must be in the allowable range of mod results. -- be in the allowable range of mod results.
when N_Op_Mod => when N_Op_Mod =>
if OK_Operands then if OK_Operands then
...@@ -3214,8 +3216,8 @@ package body Checks is ...@@ -3214,8 +3216,8 @@ package body Checks is
end if; end if;
end if; end if;
-- For REM, if right operand is a positive constant, then -- For REM, if right operand is a positive constant, then result must
-- result must be in the allowable range of mod results. -- be in the allowable range of mod results.
when N_Op_Rem => when N_Op_Rem =>
if OK_Operands then if OK_Operands then
...@@ -3340,8 +3342,8 @@ package body Checks is ...@@ -3340,8 +3342,8 @@ package body Checks is
end case; end case;
-- For type conversion from one discrete type to another, we -- For type conversion from one discrete type to another, we can
-- can refine the range using the converted value. -- refine the range using the converted value.
when N_Type_Conversion => when N_Type_Conversion =>
Determine_Range (Expression (N), OK1, Lor, Hir); Determine_Range (Expression (N), OK1, Lor, Hir);
...@@ -3499,10 +3501,10 @@ package body Checks is ...@@ -3499,10 +3501,10 @@ package body Checks is
pg (N); pg (N);
end if; end if;
-- Nothing to do if the range of the result is known OK. We skip -- Nothing to do if the range of the result is known OK. We skip this
-- this for conversions, since the caller already did the check, -- for conversions, since the caller already did the check, and in any
-- and in any case the condition for deleting the check for a -- case the condition for deleting the check for a type conversion is
-- type conversion is different in any case. -- different in any case.
if Nkind (N) /= N_Type_Conversion then if Nkind (N) /= N_Type_Conversion then
Determine_Range (N, OK, Lo, Hi); Determine_Range (N, OK, Lo, Hi);
...@@ -3536,12 +3538,12 @@ package body Checks is ...@@ -3536,12 +3538,12 @@ package body Checks is
end if; end if;
end if; end if;
-- If not in optimizing mode, set flag and we are done. We are also -- If not in optimizing mode, set flag and we are done. We are also done
-- done (and just set the flag) if the type is not a discrete type, -- (and just set the flag) if the type is not a discrete type, since it
-- since it is not worth the effort to eliminate checks for other -- is not worth the effort to eliminate checks for other than discrete
-- than discrete types. In addition, we take this same path if we -- types. In addition, we take this same path if we have stored the
-- have stored the maximum number of checks possible already (a -- maximum number of checks possible already (a very unlikely situation,
-- very unlikely situation, but we do not want to blow up!) -- but we do not want to blow up!)
if Optimization_Level = 0 if Optimization_Level = 0
or else not Is_Discrete_Type (Etype (N)) or else not Is_Discrete_Type (Etype (N))
...@@ -3616,10 +3618,10 @@ package body Checks is ...@@ -3616,10 +3618,10 @@ package body Checks is
w (" Target_Type = Empty"); w (" Target_Type = Empty");
end if; end if;
-- If we get an exception, then something went wrong, probably because -- If we get an exception, then something went wrong, probably because of
-- of an error in the structure of the tree due to an incorrect program. -- an error in the structure of the tree due to an incorrect program. Or it
-- Or it may be a bug in the optimization circuit. In either case the -- may be a bug in the optimization circuit. In either case the safest
-- safest thing is simply to set the check flag unconditionally. -- thing is simply to set the check flag unconditionally.
exception exception
when others => when others =>
...@@ -3645,9 +3647,8 @@ package body Checks is ...@@ -3645,9 +3647,8 @@ package body Checks is
P : Node_Id; P : Node_Id;
begin begin
-- Return if unchecked type conversion with range check killed. -- Return if unchecked type conversion with range check killed. In this
-- In this case we never set the flag (that's what Kill_Range_Check -- case we never set the flag (that's what Kill_Range_Check is about!)
-- is all about!)
if Nkind (N) = N_Unchecked_Type_Conversion if Nkind (N) = N_Unchecked_Type_Conversion
and then Kill_Range_Check (N) and then Kill_Range_Check (N)
...@@ -3699,12 +3700,12 @@ package body Checks is ...@@ -3699,12 +3700,12 @@ package body Checks is
pg (N); pg (N);
end if; end if;
-- If not in optimizing mode, set flag and we are done. We are also -- If not in optimizing mode, set flag and we are done. We are also done
-- done (and just set the flag) if the type is not a discrete type, -- (and just set the flag) if the type is not a discrete type, since it
-- since it is not worth the effort to eliminate checks for other -- is not worth the effort to eliminate checks for other than discrete
-- than discrete types. In addition, we take this same path if we -- types. In addition, we take this same path if we have stored the
-- have stored the maximum number of checks possible already (a -- maximum number of checks possible already (a very unlikely situation,
-- very unlikely situation, but we do not want to blow up!) -- but we do not want to blow up!)
if Optimization_Level = 0 if Optimization_Level = 0
or else No (Etype (N)) or else No (Etype (N))
...@@ -3746,17 +3747,17 @@ package body Checks is ...@@ -3746,17 +3747,17 @@ package body Checks is
Atyp := Designated_Type (Atyp); Atyp := Designated_Type (Atyp);
-- If the prefix is an access to an unconstrained array, -- If the prefix is an access to an unconstrained array,
-- perform check unconditionally: it depends on the bounds -- perform check unconditionally: it depends on the bounds of
-- of an object and we cannot currently recognize whether -- an object and we cannot currently recognize whether the test
-- the test may be redundant. -- may be redundant.
if not Is_Constrained (Atyp) then if not Is_Constrained (Atyp) then
Set_Do_Range_Check (N, True); Set_Do_Range_Check (N, True);
return; return;
end if; end if;
-- Ditto if the prefix is an explicit dereference whose -- Ditto if the prefix is an explicit dereference whose designated
-- designated type is unconstrained. -- type is unconstrained.
elsif Nkind (Prefix (P)) = N_Explicit_Dereference elsif Nkind (Prefix (P)) = N_Explicit_Dereference
and then not Is_Constrained (Atyp) and then not Is_Constrained (Atyp)
...@@ -3855,10 +3856,10 @@ package body Checks is ...@@ -3855,10 +3856,10 @@ package body Checks is
pg (Ttyp); pg (Ttyp);
end if; end if;
-- If we get an exception, then something went wrong, probably because -- If we get an exception, then something went wrong, probably because of
-- of an error in the structure of the tree due to an incorrect program. -- an error in the structure of the tree due to an incorrect program. Or
-- Or it may be a bug in the optimization circuit. In either case the -- it may be a bug in the optimization circuit. In either case the safest
-- safest thing is simply to set the check flag unconditionally. -- thing is simply to set the check flag unconditionally.
exception exception
when others => when others =>
...@@ -3889,9 +3890,9 @@ package body Checks is ...@@ -3889,9 +3890,9 @@ package body Checks is
elsif Range_Or_Validity_Checks_Suppressed (Expr) then elsif Range_Or_Validity_Checks_Suppressed (Expr) then
return; return;
-- No check required if expression is from the expander, we assume -- No check required if expression is from the expander, we assume the
-- the expander will generate whatever checks are needed. Note that -- expander will generate whatever checks are needed. Note that this is
-- this is not just an optimization, it avoids infinite recursions! -- not just an optimization, it avoids infinite recursions!
-- Unchecked conversions must be checked, unless they are initialized -- Unchecked conversions must be checked, unless they are initialized
-- scalar values, as in a component assignment in an init proc. -- scalar values, as in a component assignment in an init proc.
...@@ -3910,8 +3911,8 @@ package body Checks is ...@@ -3910,8 +3911,8 @@ package body Checks is
elsif Expr_Known_Valid (Expr) then elsif Expr_Known_Valid (Expr) then
return; return;
-- Ignore case of enumeration with holes where the flag is set not -- Ignore case of enumeration with holes where the flag is set not to
-- to worry about holes, since no special validity check is needed -- worry about holes, since no special validity check is needed
elsif Is_Enumeration_Type (Typ) elsif Is_Enumeration_Type (Typ)
and then Has_Non_Standard_Rep (Typ) and then Has_Non_Standard_Rep (Typ)
...@@ -3979,10 +3980,10 @@ package body Checks is ...@@ -3979,10 +3980,10 @@ package body Checks is
P := Parent (N); P := Parent (N);
end if; end if;
-- Only need to worry if we are argument of a procedure -- Only need to worry if we are argument of a procedure call
-- call since functions don't have out parameters. If this -- since functions don't have out parameters. If this is an
-- is an indirect or dispatching call, get signature from -- indirect or dispatching call, get signature from the
-- the subprogram type. -- subprogram type.
if Nkind (P) = N_Procedure_Call_Statement then if Nkind (P) = N_Procedure_Call_Statement then
L := Parameter_Associations (P); L := Parameter_Associations (P);
...@@ -3994,18 +3995,17 @@ package body Checks is ...@@ -3994,18 +3995,17 @@ package body Checks is
E := Etype (Name (P)); E := Etype (Name (P));
end if; end if;
-- Only need to worry if there are indeed actuals, and -- Only need to worry if there are indeed actuals, and if
-- if this could be a procedure call, otherwise we cannot -- this could be a procedure call, otherwise we cannot get a
-- get a match (either we are not an argument, or the -- match (either we are not an argument, or the mode of the
-- mode of the formal is not OUT). This test also filters -- formal is not OUT). This test also filters out the
-- out the generic case. -- generic case.
if Is_Non_Empty_List (L) if Is_Non_Empty_List (L)
and then Is_Subprogram (E) and then Is_Subprogram (E)
then then
-- This is the loop through parameters, looking to -- This is the loop through parameters, looking for an
-- see if there is an OUT parameter for which we are -- OUT parameter for which we are the argument.
-- the argument.
F := First_Formal (E); F := First_Formal (E);
A := First (L); A := First (L);
...@@ -4036,14 +4036,13 @@ package body Checks is ...@@ -4036,14 +4036,13 @@ package body Checks is
Typ : constant Entity_Id := Etype (Expr); Typ : constant Entity_Id := Etype (Expr);
begin begin
-- Non-scalar types are always considered valid, since they never -- Non-scalar types are always considered valid, since they never give
-- give rise to the issues of erroneous or bounded error behavior -- rise to the issues of erroneous or bounded error behavior that are
-- that are the concern. In formal reference manual terms the -- the concern. In formal reference manual terms the notion of validity
-- notion of validity only applies to scalar types. Note that -- only applies to scalar types. Note that even when packed arrays are
-- even when packed arrays are represented using modular types, -- represented using modular types, they are still arrays semantically,
-- they are still arrays semantically, so they are also always -- so they are also always valid (in particular, the unused bits can be
-- valid (in particular, the unused bits can be random rubbish -- random rubbish without affecting the validity of the array value).
-- without affecting the validity of the array value).
if not Is_Scalar_Type (Typ) or else Is_Packed_Array_Type (Typ) then if not Is_Scalar_Type (Typ) or else Is_Packed_Array_Type (Typ) then
return True; return True;
...@@ -4061,8 +4060,8 @@ package body Checks is ...@@ -4061,8 +4060,8 @@ package body Checks is
then then
return True; return True;
-- If the expression is the value of an object that is known to -- If the expression is the value of an object that is known to be
-- be valid, then clearly the expression value itself is valid. -- valid, then clearly the expression value itself is valid.
elsif Is_Entity_Name (Expr) elsif Is_Entity_Name (Expr)
and then Is_Known_Valid (Entity (Expr)) and then Is_Known_Valid (Entity (Expr))
...@@ -4073,17 +4072,18 @@ package body Checks is ...@@ -4073,17 +4072,18 @@ package body Checks is
-- of a discriminant gets checked when the object is built. Within the -- 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 -- record, we consider it valid, and it is important to do so, since
-- otherwise we can try to generate bogus validity checks which -- 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) elsif Is_Entity_Name (Expr)
and then Ekind (Entity (Expr)) = E_Discriminant and then Denotes_Discriminant (Expr, Check_Concurrent => True)
then then
return True; return True;
-- If the type is one for which all values are known valid, then -- If the type is one for which all values are known valid, then we are
-- we are sure that the value is valid except in the slightly odd -- sure that the value is valid except in the slightly odd case where
-- case where the expression is a reference to a variable whose size -- the expression is a reference to a variable whose size has been
-- has been explicitly set to a value greater than the object size. -- explicitly set to a value greater than the object size.
elsif Is_Known_Valid (Typ) then elsif Is_Known_Valid (Typ) then
if Is_Entity_Name (Expr) if Is_Entity_Name (Expr)
...@@ -4131,8 +4131,8 @@ package body Checks is ...@@ -4131,8 +4131,8 @@ package body Checks is
return True; return True;
end if; end if;
-- The result of a membership test is always valid, since it is true -- The result of a membership test is always valid, since it is true or
-- or false, there are no other possibilities. -- false, there are no other possibilities.
elsif Nkind (Expr) in N_Membership_Test then elsif Nkind (Expr) in N_Membership_Test then
return True; return True;
...@@ -4247,8 +4247,8 @@ package body Checks is ...@@ -4247,8 +4247,8 @@ package body Checks is
return; return;
end if; end if;
-- Come here with expression of appropriate form, check if -- Come here with expression of appropriate form, check if entity is an
-- entity is an appropriate one for our purposes. -- appropriate one for our purposes.
if (Ekind (Ent) = E_Variable if (Ekind (Ent) = E_Variable
or else or else
...@@ -4295,7 +4295,7 @@ package body Checks is ...@@ -4295,7 +4295,7 @@ package body Checks is
--------------------------------- ---------------------------------
-- Note: the code for this procedure is derived from the -- 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 procedure Generate_Discriminant_Check (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N); Loc : constant Source_Ptr := Sloc (N);
...@@ -4323,9 +4323,9 @@ package body Checks is ...@@ -4323,9 +4323,9 @@ package body Checks is
-- List of arguments for function call -- List of arguments for function call
Formal : Entity_Id; Formal : Entity_Id;
-- Keep track of the formal corresponding to the actual we build -- Keep track of the formal corresponding to the actual we build for
-- for each discriminant, in order to be able to perform the -- each discriminant, in order to be able to perform the necessary type
-- necessary type conversions. -- conversions.
Scomp : Node_Id; Scomp : Node_Id;
-- Selected component reference for checking function argument -- Selected component reference for checking function argument
...@@ -4363,10 +4363,10 @@ package body Checks is ...@@ -4363,10 +4363,10 @@ package body Checks is
if Is_Tagged_Type (Scope (Orig_Comp)) then if Is_Tagged_Type (Scope (Orig_Comp)) then
Pref_Type := Scope (Orig_Comp); Pref_Type := Scope (Orig_Comp);
-- For an untagged derived type, use the discriminants of the -- For an untagged derived type, use the discriminants of the parent
-- parent which have been renamed in the derivation, possibly -- which have been renamed in the derivation, possibly by a one-to-many
-- by a one-to-many discriminant constraint. -- discriminant constraint. For non-tagged type, initially get the Etype
-- For non-tagged type, initially get the Etype of the prefix -- of the prefix
else else
if Is_Derived_Type (Pref_Type) if Is_Derived_Type (Pref_Type)
...@@ -4415,8 +4415,8 @@ package body Checks is ...@@ -4415,8 +4415,8 @@ package body Checks is
-- Manually analyze and resolve this selected component. We really -- Manually analyze and resolve this selected component. We really
-- want it just as it appears above, and do not want the expander -- want it just as it appears above, and do not want the expander
-- playing discriminal games etc with this reference. Then we -- playing discriminal games etc with this reference. Then we append
-- append the argument to the list we are gathering. -- the argument to the list we are gathering.
Set_Etype (Scomp, Etype (Real_Discr)); Set_Etype (Scomp, Etype (Real_Discr));
Set_Analyzed (Scomp, True); Set_Analyzed (Scomp, True);
...@@ -4465,8 +4465,8 @@ package body Checks is ...@@ -4465,8 +4465,8 @@ package body Checks is
if Do_Range_Check (Sub) then if Do_Range_Check (Sub) then
Set_Do_Range_Check (Sub, False); Set_Do_Range_Check (Sub, False);
-- Force evaluation except for the case of a simple name of -- Force evaluation except for the case of a simple name of a
-- a non-volatile entity. -- non-volatile entity.
if not Is_Entity_Name (Sub) if not Is_Entity_Name (Sub)
or else Treat_As_Volatile (Entity (Sub)) or else Treat_As_Volatile (Entity (Sub))
...@@ -4479,12 +4479,12 @@ package body Checks is ...@@ -4479,12 +4479,12 @@ package body Checks is
-- Base_Type(Sub) not in array'range (subscript) -- Base_Type(Sub) not in array'range (subscript)
-- Note that the reason we generate the conversion to the -- Note that the reason we generate the conversion to the base
-- base type here is that we definitely want the range check -- type here is that we definitely want the range check to take
-- to take place, even if it looks like the subtype is OK. -- place, even if it looks like the subtype is OK. Optimization
-- Optimization considerations that allow us to omit the -- considerations that allow us to omit the check have already
-- check have already been taken into account in the setting -- been taken into account in the setting of the Do_Range_Check
-- of the Do_Range_Check flag earlier on. -- flag earlier on.
if Ind = 1 then if Ind = 1 then
Num := No_List; Num := No_List;
...@@ -4527,14 +4527,14 @@ package body Checks is ...@@ -4527,14 +4527,14 @@ package body Checks is
Target_Base_Type : constant Entity_Id := Base_Type (Target_Type); Target_Base_Type : constant Entity_Id := Base_Type (Target_Type);
begin begin
-- First special case, if the source type is already within the -- First special case, if the source type is already within the range
-- range of the target type, then no check is needed (probably we -- of the target type, then no check is needed (probably we should have
-- should have stopped Do_Range_Check from being set in the first -- stopped Do_Range_Check from being set in the first place, but better
-- place, but better late than later in preventing junk code! -- late than later in preventing junk code!
-- We do NOT apply this if the source node is a literal, since in -- We do NOT apply this if the source node is a literal, since in this
-- this case the literal has already been labeled as having the -- case the literal has already been labeled as having the subtype of
-- subtype of the target. -- the target.
if In_Subrange_Of (Source_Type, Target_Type) if In_Subrange_Of (Source_Type, Target_Type)
and then not and then not
...@@ -4561,9 +4561,9 @@ package body Checks is ...@@ -4561,9 +4561,9 @@ package body Checks is
Force_Evaluation (N); Force_Evaluation (N);
end if; end if;
-- The easiest case is when Source_Base_Type and Target_Base_Type -- The easiest case is when Source_Base_Type and Target_Base_Type are
-- are the same since in this case we can simply do a direct -- the same since in this case we can simply do a direct check of the
-- check of the value of N against the bounds of Target_Type. -- value of N against the bounds of Target_Type.
-- [constraint_error when N not in Target_Type] -- [constraint_error when N not in Target_Type]
...@@ -4615,20 +4615,19 @@ package body Checks is ...@@ -4615,20 +4615,19 @@ package body Checks is
Attribute_Name => Name_Last)))), Attribute_Name => Name_Last)))),
Reason => Reason)); Reason => Reason));
-- Note that at this stage we now that the Target_Base_Type is -- Note that at this stage we now that the Target_Base_Type is not in
-- not in the range of the Source_Base_Type (since even the -- the range of the Source_Base_Type (since even the Target_Type itself
-- Target_Type itself is not in this range). It could still be -- is not in this range). It could still be the case that Source_Type is
-- the case that the Source_Type is in range of the target base -- in range of the target base type since we have not checked that case.
-- type, since we have not checked that case.
-- If that is the case, we can freely convert the source to the -- If that is the case, we can freely convert the source to the target,
-- target, and then test the target result against the bounds. -- and then test the target result against the bounds.
elsif In_Subrange_Of (Source_Type, Target_Base_Type) then elsif In_Subrange_Of (Source_Type, Target_Base_Type) then
-- We make a temporary to hold the value of the converted -- We make a temporary to hold the value of the converted value
-- value (converted to the base type), and then we will -- (converted to the base type), and then we will do the test against
-- do the test against this temporary. -- this temporary.
-- Tnn : constant Target_Base_Type := Target_Base_Type (N); -- Tnn : constant Target_Base_Type := Target_Base_Type (N);
-- [constraint_error when Tnn not in Target_Type] -- [constraint_error when Tnn not in Target_Type]
...@@ -4680,8 +4679,8 @@ package body Checks is ...@@ -4680,8 +4679,8 @@ package body Checks is
-- know that the source is not shorter than the target (otherwise -- know that the source is not shorter than the target (otherwise
-- the source base type would be in the target base type range). -- the source base type would be in the target base type range).
-- In other words, the unsigned type is either the same size -- In other words, the unsigned type is either the same size as
-- as the target, or it is larger. It cannot be smaller. -- the target, or it is larger. It cannot be smaller.
pragma Assert pragma Assert
(Esize (Source_Base_Type) >= Esize (Target_Base_Type)); (Esize (Source_Base_Type) >= Esize (Target_Base_Type));
...@@ -4761,27 +4760,26 @@ package body Checks is ...@@ -4761,27 +4760,26 @@ package body Checks is
pragma Assert (not Is_Unsigned_Type (Source_Base_Type) pragma Assert (not Is_Unsigned_Type (Source_Base_Type)
and then Is_Unsigned_Type (Target_Base_Type)); and then Is_Unsigned_Type (Target_Base_Type));
-- If the source is signed and the target is unsigned, then -- If the source is signed and the target is unsigned, then we
-- we know that the target is not shorter than the source -- know that the target is not shorter than the source (otherwise
-- (otherwise the target base type would be in the source -- the target base type would be in the source base type range).
-- base type range).
-- In other words, the unsigned type is either the same size -- In other words, the unsigned type is either the same size as
-- as the target, or it is larger. It cannot be smaller. -- the target, or it is larger. It cannot be smaller.
-- Clearly we have an error if the source value is negative -- Clearly we have an error if the source value is negative since
-- since no unsigned type can have negative values. If the -- no unsigned type can have negative values. If the source type
-- source type is non-negative, then the check can be done -- is non-negative, then the check can be done using the target
-- using the target type. -- type.
-- Tnn : constant Target_Base_Type (N) := Target_Type; -- Tnn : constant Target_Base_Type (N) := Target_Type;
-- [constraint_error -- [constraint_error
-- when N < 0 or else Tnn not in Target_Type]; -- when N < 0 or else Tnn not in Target_Type];
-- We turn off all checks for the conversion of N to the -- We turn off all checks for the conversion of N to the target
-- target base type, since we generate the explicit check -- base type, since we generate the explicit check to ensure that
-- to ensure that the value is non-negative -- the value is non-negative
declare declare
Tnn : constant Entity_Id := Tnn : constant Entity_Id :=
...@@ -4818,9 +4816,9 @@ package body Checks is ...@@ -4818,9 +4816,9 @@ package body Checks is
Reason => Reason)), Reason => Reason)),
Suppress => All_Checks); Suppress => All_Checks);
-- Set the Etype explicitly, because Insert_Actions may -- Set the Etype explicitly, because Insert_Actions may have
-- have placed the declaration in the freeze list for an -- placed the declaration in the freeze list for an enclosing
-- enclosing construct, and thus it is not analyzed yet. -- construct, and thus it is not analyzed yet.
Set_Etype (Tnn, Target_Base_Type); Set_Etype (Tnn, Target_Base_Type);
Rewrite (N, New_Occurrence_Of (Tnn, Loc)); Rewrite (N, New_Occurrence_Of (Tnn, Loc));
...@@ -4944,9 +4942,9 @@ package body Checks is ...@@ -4944,9 +4942,9 @@ package body Checks is
(not Range_Checks_Suppressed (Suppress_Typ)); (not Range_Checks_Suppressed (Suppress_Typ));
begin begin
-- For now we just return if Checks_On is false, however this should -- For now we just return if Checks_On is false, however this should be
-- be enhanced to check for an always True value in the condition -- enhanced to check for an always True value in the condition and to
-- and to generate a compilation warning??? -- generate a compilation warning???
if not Expander_Active or else not Checks_On then if not Expander_Active or else not Checks_On then
return; return;
...@@ -5193,9 +5191,9 @@ package body Checks is ...@@ -5193,9 +5191,9 @@ package body Checks is
w ("Kill_All_Checks"); w ("Kill_All_Checks");
end if; end if;
-- We reset the number of saved checks to zero, and also modify -- We reset the number of saved checks to zero, and also modify all
-- all stack entries for statement ranges to indicate that the -- stack entries for statement ranges to indicate that the number of
-- number of checks at each level is now zero. -- checks at each level is now zero.
Num_Saved_Checks := 0; Num_Saved_Checks := 0;
...@@ -5621,7 +5619,6 @@ package body Checks is ...@@ -5621,7 +5619,6 @@ package body Checks is
end if; end if;
return N; return N;
end if; end if;
end Get_E_Length; end Get_E_Length;
...@@ -5638,7 +5635,6 @@ package body Checks is ...@@ -5638,7 +5635,6 @@ package body Checks is
Duplicate_Subexpr_No_Checks (N, Name_Req => True), Duplicate_Subexpr_No_Checks (N, Name_Req => True),
Expressions => New_List ( Expressions => New_List (
Make_Integer_Literal (Loc, Indx))); Make_Integer_Literal (Loc, Indx)));
end Get_N_Length; end Get_N_Length;
------------------- -------------------
...@@ -5655,7 +5651,6 @@ package body Checks is ...@@ -5655,7 +5651,6 @@ package body Checks is
Make_Op_Ne (Loc, Make_Op_Ne (Loc,
Left_Opnd => Get_E_Length (Typ, Indx), Left_Opnd => Get_E_Length (Typ, Indx),
Right_Opnd => Get_E_Length (Exptyp, Indx)); Right_Opnd => Get_E_Length (Exptyp, Indx));
end Length_E_Cond; end Length_E_Cond;
------------------- -------------------
...@@ -5672,9 +5667,12 @@ package body Checks is ...@@ -5672,9 +5667,12 @@ package body Checks is
Make_Op_Ne (Loc, Make_Op_Ne (Loc,
Left_Opnd => Get_E_Length (Typ, Indx), Left_Opnd => Get_E_Length (Typ, Indx),
Right_Opnd => Get_N_Length (Expr, Indx)); Right_Opnd => Get_N_Length (Expr, Indx));
end Length_N_Cond; end Length_N_Cond;
-----------------
-- Same_Bounds --
-----------------
function Same_Bounds (L : Node_Id; R : Node_Id) return Boolean is function Same_Bounds (L : Node_Id; R : Node_Id) return Boolean is
begin begin
return return
...@@ -5807,12 +5805,11 @@ package body Checks is ...@@ -5807,12 +5805,11 @@ package body Checks is
Ref_Node : Node_Id; Ref_Node : Node_Id;
begin begin
-- At the library level, we need to ensure that the type of
-- At the library level, we need to ensure that the -- the object is elaborated before the check itself is
-- type of the object is elaborated before the check -- emitted. This is only done if the object is in the
-- itself is emitted. This is only done if the object -- current compilation unit, otherwise the type is frozen
-- is in the current compilation unit, otherwise the -- and elaborated in its unit.
-- type is frozen and elaborated in its unit.
if Is_Itype (Exptyp) if Is_Itype (Exptyp)
and then and then
...@@ -5904,8 +5901,8 @@ package body Checks is ...@@ -5904,8 +5901,8 @@ package body Checks is
-- do not evaluate it more than once. -- do not evaluate it more than once.
-- Here Ck_Node is the original expression, or more properly the -- Here Ck_Node is the original expression, or more properly the
-- result of applying Duplicate_Expr to the original tree, -- result of applying Duplicate_Expr to the original tree, forcing
-- forcing the result to be a name. -- the result to be a name.
else else
declare declare
...@@ -6080,12 +6077,14 @@ package body Checks is ...@@ -6080,12 +6077,14 @@ package body Checks is
begin begin
if Nkind (LB) = N_Identifier 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); LB := New_Occurrence_Of (Discriminal (Entity (LB)), Loc);
end if; end if;
if Nkind (HB) = N_Identifier 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); HB := New_Occurrence_Of (Discriminal (Entity (HB)), Loc);
end if; end if;
...@@ -6239,12 +6238,11 @@ package body Checks is ...@@ -6239,12 +6238,11 @@ package body Checks is
elsif Nkind (Bound) = N_Integer_Literal then elsif Nkind (Bound) = N_Integer_Literal then
return Make_Integer_Literal (Loc, Intval (Bound)); return Make_Integer_Literal (Loc, Intval (Bound));
-- Case of a bound that has been rewritten to an -- Case of a bound rewritten to an N_Raise_Constraint_Error node
-- N_Raise_Constraint_Error node because it is an out-of-range -- because it is an out-of-range value. Duplicate_Subexpr cannot be
-- value. We may not call Duplicate_Subexpr on this node because -- called on this node because an N_Raise_Constraint_Error is not
-- an N_Raise_Constraint_Error is not side effect free, and we may -- side effect free, and we may not assume that we are in the proper
-- not assume that we are in the proper context to remove side -- context to remove side effects on it at the point of reference.
-- effects on it at the point of reference.
elsif Nkind (Bound) = N_Raise_Constraint_Error then elsif Nkind (Bound) = N_Raise_Constraint_Error then
return New_Copy_Tree (Bound); return New_Copy_Tree (Bound);
...@@ -6305,7 +6303,6 @@ package body Checks is ...@@ -6305,7 +6303,6 @@ package body Checks is
Make_Op_Gt (Loc, Make_Op_Gt (Loc,
Left_Opnd => Get_E_First_Or_Last (Exptyp, Indx, Name_Last), Left_Opnd => Get_E_First_Or_Last (Exptyp, Indx, Name_Last),
Right_Opnd => Get_E_First_Or_Last (Typ, Indx, Name_Last))); Right_Opnd => Get_E_First_Or_Last (Typ, Indx, Name_Last)));
end Range_E_Cond; end Range_E_Cond;
------------------------ ------------------------
...@@ -6505,18 +6502,17 @@ package body Checks is ...@@ -6505,18 +6502,17 @@ package body Checks is
HB : Node_Id := High_Bound (Ck_Node); HB : Node_Id := High_Bound (Ck_Node);
begin begin
-- If either bound is a discriminant and we are within the
-- If either bound is a discriminant and we are within -- record declaration, it is a use of the discriminant in a
-- the record declaration, it is a use of the discriminant -- constraint of a component, and nothing can be checked
-- in a constraint of a component, and nothing can be -- here. The check will be emitted within the init proc.
-- checked here. The check will be emitted within the -- Before then, the discriminal has no real meaning.
-- init proc. Before then, the discriminal has no real -- Similarly, if the entity is a discriminal, there is no
-- meaning. Similarly, if the entity is a discriminal, -- check to perform yet.
-- there is no check to perform yet.
-- The same holds within a discriminated synchronized type,
-- The same holds within a discriminated synchronized -- where the discriminant may constrain a component or an
-- type, where the discriminant may constrain a component -- entry family.
-- or an entry family.
if Nkind (LB) = N_Identifier if Nkind (LB) = N_Identifier
and then Denotes_Discriminant (LB, True) and then Denotes_Discriminant (LB, True)
...@@ -6557,7 +6553,6 @@ package body Checks is ...@@ -6557,7 +6553,6 @@ package body Checks is
Right_Opnd => Duplicate_Subexpr_No_Checks (LB)), Right_Opnd => Duplicate_Subexpr_No_Checks (LB)),
Right_Opnd => Cond); Right_Opnd => Cond);
end; end;
end if; end if;
end; end;
...@@ -6748,21 +6743,23 @@ package body Checks is ...@@ -6748,21 +6743,23 @@ package body Checks is
end if; end if;
else else
-- Generate an Action to check that the bounds of the -- For a conversion to an unconstrained array type, generate an
-- source value are within the constraints imposed by the -- Action to check that the bounds of the source value are within
-- target type for a conversion to an unconstrained type. -- the constraints imposed by the target type (RM 4.6(38)). No
-- Rule is 4.6(38). -- check is needed for a conversion to an access to unconstrained
-- array type, as 4.6(24.15/2) requires the designated subtypes
if Nkind (Parent (Ck_Node)) = N_Type_Conversion then -- of the two access types to statically match.
if Nkind (Parent (Ck_Node)) = N_Type_Conversion
and then not Do_Access
then
declare declare
Opnd_Index : Node_Id; Opnd_Index : Node_Id;
Targ_Index : Node_Id; Targ_Index : Node_Id;
begin begin
Opnd_Index Opnd_Index := First_Index (Get_Actual_Subtype (Ck_Node));
:= First_Index (Get_Actual_Subtype (Ck_Node));
Targ_Index := First_Index (T_Typ); Targ_Index := First_Index (T_Typ);
while Opnd_Index /= Empty loop while Opnd_Index /= Empty loop
if Nkind (Opnd_Index) = N_Range then if Nkind (Opnd_Index) = N_Range then
if Is_In_Range if Is_In_Range
......
gcc/ada/checks.ads
...@@ -264,6 +264,12 @@ package Checks is ...@@ -264,6 +264,12 @@ package Checks is
-- this node is further examined depends on the setting of -- this node is further examined depends on the setting of
-- the parameter Source_Typ, as described below. -- 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 -- 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 -- example, if we have a scalar range check, then the check
-- is that we are in range of this type. -- is that we are in range of this type.
...@@ -311,7 +317,7 @@ package Checks is ...@@ -311,7 +317,7 @@ package Checks is
(Ck_Node : Node_Id; (Ck_Node : Node_Id;
Target_Typ : Entity_Id; Target_Typ : Entity_Id;
Source_Typ : Entity_Id := Empty); 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 -- first that the range is not null and then that the range is contained in
-- the Target_Typ range. -- 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