Google Git
Sign in
gnu / gcc / refs/tags/basepoints/gcc-13 / . / gcc / ada / checks.adb
blob: e1a1b0cfec1b62b80d7623a5bc87c99e0a7df5b8 [file] [log] [blame]
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- C H E C K S --
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2022, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING3. If not, go to --
-- http://www.gnu.org/licenses for a complete copy of the license. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
with Atree; use Atree;
with Debug; use Debug;
with Einfo; use Einfo;
with Einfo.Entities; use Einfo.Entities;
with Einfo.Utils; use Einfo.Utils;
with Elists; use Elists;
with Eval_Fat; use Eval_Fat;
with Exp_Ch11; use Exp_Ch11;
with Exp_Ch4; use Exp_Ch4;
with Exp_Pakd; use Exp_Pakd;
with Exp_Util; use Exp_Util;
with Expander; use Expander;
with Freeze; use Freeze;
with Lib; use Lib;
with Nlists; use Nlists;
with Nmake; use Nmake;
with Opt; use Opt;
with Output; use Output;
with Restrict; use Restrict;
with Rident; use Rident;
with Rtsfind; use Rtsfind;
with Sem; use Sem;
with Sem_Aux; use Sem_Aux;
with Sem_Ch3; use Sem_Ch3;
with Sem_Ch8; use Sem_Ch8;
with Sem_Cat; use Sem_Cat;
with Sem_Disp; use Sem_Disp;
with Sem_Eval; use Sem_Eval;
with Sem_Mech; use Sem_Mech;
with Sem_Res; use Sem_Res;
with Sem_Util; use Sem_Util;
with Sem_Warn; use Sem_Warn;
with Sinfo; use Sinfo;
with Sinfo.Nodes; use Sinfo.Nodes;
with Sinfo.Utils; use Sinfo.Utils;
with Sinput; use Sinput;
with Snames; use Snames;
with Sprint; use Sprint;
with Stand; use Stand;
with Stringt; use Stringt;
with Targparm; use Targparm;
with Tbuild; use Tbuild;
with Ttypes; use Ttypes;
with Validsw; use Validsw;
package body Checks is
-- General note: many of these routines are concerned with generating
-- checking code to make sure that constraint error is raised at runtime.
-- Clearly this code is only needed if the expander is active, since
-- otherwise we will not be generating code or going into the runtime
-- execution anyway.
-- We therefore disconnect most of these checks if the expander is
-- inactive. This has the additional benefit that we do not need to
-- worry about the tree being messed up by previous errors (since errors
-- turn off expansion anyway).
-- There are a few exceptions to the above rule. For instance routines
-- such as Apply_Scalar_Range_Check that do not insert any code can be
-- safely called even when the Expander is inactive (but Errors_Detected
-- is 0). The benefit of executing this code when expansion is off, is
-- the ability to emit constraint error warnings for static expressions
-- even when we are not generating code.
-- The above is modified in gnatprove mode to ensure that proper check
-- flags are always placed, even if expansion is off.
-------------------------------------
-- Suppression of Redundant Checks --
-------------------------------------
-- This unit implements a limited circuit for removal of redundant
-- checks. The processing is based on a tracing of simple sequential
-- flow. For any sequence of statements, we save expressions that are
-- marked to be checked, and then if the same expression appears later
-- with the same check, then under certain circumstances, the second
-- check can be suppressed.
-- Basically, we can suppress the check if we know for certain that
-- the previous expression has been elaborated (together with its
-- check), and we know that the exception frame is the same, and that
-- nothing has happened to change the result of the exception.
-- Let us examine each of these three conditions in turn to describe
-- how we ensure that this condition is met.
-- First, we need to know for certain that the previous expression has
-- been executed. This is done principally by the mechanism of calling
-- Conditional_Statements_Begin at the start of any statement sequence
-- and Conditional_Statements_End at the end. The End call causes all
-- checks remembered since the Begin call to be discarded. This does
-- miss a few cases, notably the case of a nested BEGIN-END block with
-- no exception handlers. But the important thing is to be conservative.
-- The other protection is that all checks are discarded if a label
-- is encountered, since then the assumption of sequential execution
-- is violated, and we don't know enough about the flow.
-- Second, we need to know that the exception frame is the same. We
-- do this by killing all remembered checks when we enter a new frame.
-- Again, that's over-conservative, but generally the cases we can help
-- with are pretty local anyway (like the body of a loop for example).
-- Third, we must be sure to forget any checks which are no longer valid.
-- This is done by two mechanisms, first the Kill_Checks_Variable call is
-- used to note any changes to local variables. We only attempt to deal
-- with checks involving local variables, so we do not need to worry
-- about global variables. Second, a call to any non-global procedure
-- causes us to abandon all stored checks, since such a all may affect
-- the values of any local variables.
-- The following define the data structures used to deal with remembering
-- checks so that redundant checks can be eliminated as described above.
-- Right now, the only expressions that we deal with are of the form of
-- simple local objects (either declared locally, or IN parameters) or
-- such objects plus/minus a compile time known constant. We can do
-- more later on if it seems worthwhile, but this catches many simple
-- cases in practice.
-- The following record type reflects a single saved check. An entry
-- is made in the stack of saved checks if and only if the expression
-- has been elaborated with the indicated checks.
type Saved_Check is record
Killed : Boolean;
-- Set True if entry is killed by Kill_Checks
Entity : Entity_Id;
-- The entity involved in the expression that is checked
Offset : Uint;
-- A compile time value indicating the result of adding or
-- subtracting a compile time value. This value is to be
-- added to the value of the Entity. A value of zero is
-- used for the case of a simple entity reference.
Check_Type : Character;
-- This is set to 'R' for a range check (in which case Target_Type
-- is set to the target type for the range check) or to 'O' for an
-- overflow check (in which case Target_Type is set to Empty).
Target_Type : Entity_Id;
-- Used only if Do_Range_Check is set. Records the target type for
-- the check. We need this, because a check is a duplicate only if
-- it has the same target type (or more accurately one with a
-- range that is smaller or equal to the stored target type of a
-- saved check).
end record;
-- The following table keeps track of saved checks. Rather than use an
-- extensible table, we just use a table of fixed size, and we discard
-- any saved checks that do not fit. That's very unlikely to happen and
-- this is only an optimization in any case.
Saved_Checks : array (Int range 1 .. 200) of Saved_Check;
-- Array of saved checks
Num_Saved_Checks : Nat := 0;
-- Number of saved checks
-- The following stack keeps track of statement ranges. It is treated
-- as a stack. When Conditional_Statements_Begin is called, an entry
-- is pushed onto this stack containing the value of Num_Saved_Checks
-- at the time of the call. Then when Conditional_Statements_End is
-- called, this value is popped off and used to reset Num_Saved_Checks.
-- Note: again, this is a fixed length stack with a size that should
-- always be fine. If the value of the stack pointer goes above the
-- limit, then we just forget all saved checks.
Saved_Checks_Stack : array (Int range 1 .. 100) of Nat;
Saved_Checks_TOS : Nat := 0;
-----------------------
-- Local Subprograms --
-----------------------
procedure Apply_Arithmetic_Overflow_Strict (N : Node_Id);
-- Used to apply arithmetic overflow checks for all cases except operators
-- on signed arithmetic types in MINIMIZED/ELIMINATED case (for which we
-- call Apply_Arithmetic_Overflow_Minimized_Eliminated below). N can be a
-- signed integer arithmetic operator (but not an if or case expression).
-- It is also called for types other than signed integers.
procedure Apply_Arithmetic_Overflow_Minimized_Eliminated (Op : Node_Id);
-- Used to apply arithmetic overflow checks for the case where the overflow
-- checking mode is MINIMIZED or ELIMINATED and we have a signed integer
-- arithmetic op (which includes the case of if and case expressions). Note
-- that Do_Overflow_Check may or may not be set for node Op. In these modes
-- we have work to do even if overflow checking is suppressed.
procedure Apply_Division_Check
(N : Node_Id;
Rlo : Uint;
Rhi : Uint;
ROK : Boolean);
-- N is an N_Op_Div, N_Op_Rem, or N_Op_Mod node. This routine applies
-- division checks as required if the Do_Division_Check flag is set.
-- Rlo and Rhi give the possible range of the right operand, these values
-- can be referenced and trusted only if ROK is set True.
procedure Apply_Float_Conversion_Check
(Expr : Node_Id;
Target_Typ : Entity_Id);
-- The checks on a conversion from a floating-point type to an integer
-- type are delicate. They have to be performed before conversion, they
-- have to raise an exception when the operand is a NaN, and rounding must
-- be taken into account to determine the safe bounds of the operand.
procedure Apply_Selected_Length_Checks
(Expr : Node_Id;
Target_Typ : Entity_Id;
Source_Typ : Entity_Id;
Do_Static : Boolean);
-- This is the subprogram that does all the work for Apply_Length_Check
-- and Apply_Static_Length_Check. Expr, Target_Typ and Source_Typ are as
-- described for the above routines. The Do_Static flag indicates that
-- only a static check is to be done.
procedure Compute_Range_For_Arithmetic_Op
(Op : Node_Kind;
Lo_Left : Uint;
Hi_Left : Uint;
Lo_Right : Uint;
Hi_Right : Uint;
OK : out Boolean;
Lo : out Uint;
Hi : out Uint);
-- Given an integer arithmetical operation Op and the range of values of
-- its operand(s), try to compute a conservative estimate of the possible
-- range of values for the result of the operation. Thus if OK is True on
-- return, the result is known to lie in the range Lo .. Hi (inclusive).
-- If OK is false, both Lo and Hi are set to No_Uint.
type Check_Type is new Check_Id range Access_Check .. Division_Check;
function Check_Needed (Nod : Node_Id; Check : Check_Type) return Boolean;
-- This function is used to see if an access or division by zero check is
-- needed. The check is to be applied to a single variable appearing in the
-- source, and N is the node for the reference. If N is not of this form,
-- True is returned with no further processing. If N is of the right form,
-- then further processing determines if the given Check is needed.
--
-- The particular circuit is to see if we have the case of a check that is
-- not needed because it appears in the right operand of a short circuited
-- conditional where the left operand guards the check. For example:
--
-- if Var = 0 or else Q / Var > 12 then
-- ...
-- end if;
--
-- In this example, the division check is not required. At the same time
-- we can issue warnings for suspicious use of non-short-circuited forms,
-- such as:
--
-- if Var = 0 or Q / Var > 12 then
-- ...
-- end if;
procedure Find_Check
(Expr : Node_Id;
Check_Type : Character;
Target_Type : Entity_Id;
Entry_OK : out Boolean;
Check_Num : out Nat;
Ent : out Entity_Id;
Ofs : out Uint);
-- This routine is used by Enable_Range_Check and Enable_Overflow_Check
-- to see if a check is of the form for optimization, and if so, to see
-- if it has already been performed. Expr is the expression to check,
-- and Check_Type is 'R' for a range check, 'O' for an overflow check.
-- Target_Type is the target type for a range check, and Empty for an
-- overflow check. If the entry is not of the form for optimization,
-- then Entry_OK is set to False, and the remaining out parameters
-- are undefined. If the entry is OK, then Ent/Ofs are set to the
-- entity and offset from the expression. Check_Num is the number of
-- a matching saved entry in Saved_Checks, or zero if no such entry
-- is located.
function Get_Discriminal (E : Entity_Id; Bound : Node_Id) return Node_Id;
-- If a discriminal is used in constraining a prival, Return reference
-- to the discriminal of the protected body (which renames the parameter
-- of the enclosing protected operation). This clumsy transformation is
-- needed because privals are created too late and their actual subtypes
-- are not available when analysing the bodies of the protected operations.
-- This function is called whenever the bound is an entity and the scope
-- indicates a protected operation. If the bound is an in-parameter of
-- a protected operation that is not a prival, the function returns the
-- bound itself.
-- To be cleaned up???
function Guard_Access
(Cond : Node_Id;
Loc : Source_Ptr;
Expr : Node_Id) return Node_Id;
-- In the access type case, guard the test with a test to ensure
-- that the access value is non-null, since the checks do not
-- not apply to null access values.
procedure Install_Static_Check (R_Cno : Node_Id; Loc : Source_Ptr);
-- Called by Apply_{Length,Range}_Checks to rewrite the tree with the
-- Constraint_Error node.
function Is_Signed_Integer_Arithmetic_Op (N : Node_Id) return Boolean;
-- Returns True if node N is for an arithmetic operation with signed
-- integer operands. This includes unary and binary operators, and also
-- if and case expression nodes where the dependent expressions are of
-- a signed integer type. These are the kinds of nodes for which special
-- handling applies in MINIMIZED or ELIMINATED overflow checking mode.
function Range_Or_Validity_Checks_Suppressed
(Expr : Node_Id) return Boolean;
-- Returns True if either range or validity checks or both are suppressed
-- for the type of the given expression, or, if the expression is the name
-- of an entity, if these checks are suppressed for the entity.
function Selected_Length_Checks
(Expr : Node_Id;
Target_Typ : Entity_Id;
Source_Typ : Entity_Id;
Warn_Node : Node_Id) return Check_Result;
-- Like Apply_Selected_Length_Checks, except it doesn't modify
-- anything, just returns a list of nodes as described in the spec of
-- this package for the Range_Check function.
-- ??? In fact it does construct the test and insert it into the tree,
-- and insert actions in various ways (calling Insert_Action directly
-- in particular) so we do not call it in GNATprove mode, contrary to
-- Selected_Range_Checks.
function Selected_Range_Checks
(Expr : Node_Id;
Target_Typ : Entity_Id;
Source_Typ : Entity_Id;
Warn_Node : Node_Id) return Check_Result;
-- Like Apply_Range_Check, except it does not modify anything, just
-- returns a list of nodes as described in the spec of this package
-- for the Range_Check function.
------------------------------
-- Access_Checks_Suppressed --
------------------------------
function Access_Checks_Suppressed (E : Entity_Id) return Boolean is
begin
if Present (E) and then Checks_May_Be_Suppressed (E) then
return Is_Check_Suppressed (E, Access_Check);
else
return Scope_Suppress.Suppress (Access_Check);
end if;
end Access_Checks_Suppressed;
-------------------------------------
-- Accessibility_Checks_Suppressed --
-------------------------------------
function Accessibility_Checks_Suppressed (E : Entity_Id) return Boolean is
begin
if No_Dynamic_Accessibility_Checks_Enabled (E) then
return True;
elsif Present (E) and then Checks_May_Be_Suppressed (E) then
return Is_Check_Suppressed (E, Accessibility_Check);
else
return Scope_Suppress.Suppress (Accessibility_Check);
end if;
end Accessibility_Checks_Suppressed;
-----------------------------
-- Activate_Division_Check --
-----------------------------
procedure Activate_Division_Check (N : Node_Id) is
begin
Set_Do_Division_Check (N, True);
Possible_Local_Raise (N, Standard_Constraint_Error);
end Activate_Division_Check;
-----------------------------
-- Activate_Overflow_Check --
-----------------------------
procedure Activate_Overflow_Check (N : Node_Id) is
Typ : constant Entity_Id := Etype (N);
begin
-- Floating-point case. If Etype is not set (this can happen when we
-- activate a check on a node that has not yet been analyzed), then
-- we assume we do not have a floating-point type (as per our spec).
if Present (Typ) and then Is_Floating_Point_Type (Typ) then
-- Ignore call if we have no automatic overflow checks on the target
-- and Check_Float_Overflow mode is not set. These are the cases in
-- which we expect to generate infinities and NaN's with no check.
if not (Machine_Overflows_On_Target or Check_Float_Overflow) then
return;
-- Ignore for unary operations ("+", "-", abs) since these can never
-- result in overflow for floating-point cases.
elsif Nkind (N) in N_Unary_Op then
return;
-- Otherwise we will set the flag
else
null;
end if;
-- Discrete case
else
-- Nothing to do for Rem/Mod/Plus (overflow not possible, the check
-- for zero-divide is a divide check, not an overflow check).
if Nkind (N) in N_Op_Rem | N_Op_Mod | N_Op_Plus then
return;
end if;
end if;
-- Fall through for cases where we do set the flag
Set_Do_Overflow_Check (N);
Possible_Local_Raise (N, Standard_Constraint_Error);
end Activate_Overflow_Check;
--------------------------
-- Activate_Range_Check --
--------------------------
procedure Activate_Range_Check (N : Node_Id) is
begin
Set_Do_Range_Check (N);
Possible_Local_Raise (N, Standard_Constraint_Error);
end Activate_Range_Check;
---------------------------------
-- Alignment_Checks_Suppressed --
---------------------------------
function Alignment_Checks_Suppressed (E : Entity_Id) return Boolean is
begin
if Present (E) and then Checks_May_Be_Suppressed (E) then
return Is_Check_Suppressed (E, Alignment_Check);
else
return Scope_Suppress.Suppress (Alignment_Check);
end if;
end Alignment_Checks_Suppressed;
----------------------------------
-- Allocation_Checks_Suppressed --
----------------------------------
-- Note: at the current time there are no calls to this function, because
-- the relevant check is in the run-time, so it is not a check that the
-- compiler can suppress anyway, but we still have to recognize the check
-- name Allocation_Check since it is part of the standard.
function Allocation_Checks_Suppressed (E : Entity_Id) return Boolean is
begin
if Present (E) and then Checks_May_Be_Suppressed (E) then
return Is_Check_Suppressed (E, Allocation_Check);
else
return Scope_Suppress.Suppress (Allocation_Check);
end if;
end Allocation_Checks_Suppressed;
-------------------------
-- Append_Range_Checks --
-------------------------
procedure Append_Range_Checks
(Checks : Check_Result;
Stmts : List_Id;
Suppress_Typ : Entity_Id;
Static_Sloc : Source_Ptr)
is
Checks_On : constant Boolean :=
not Index_Checks_Suppressed (Suppress_Typ)
or else
not Range_Checks_Suppressed (Suppress_Typ);
begin
-- For now we just return if Checks_On is false, however this could be
-- enhanced to check for an always True value in the condition and to
-- generate a compilation warning.
if not Checks_On then
return;
end if;
for J in 1 .. 2 loop
exit when No (Checks (J));
if Nkind (Checks (J)) = N_Raise_Constraint_Error
and then Present (Condition (Checks (J)))
then
Append_To (Stmts, Checks (J));
else
Append_To
(Stmts,
Make_Raise_Constraint_Error (Static_Sloc,
Reason => CE_Range_Check_Failed));
end if;
end loop;
end Append_Range_Checks;
------------------------
-- Apply_Access_Check --
------------------------
procedure Apply_Access_Check (N : Node_Id) is
P : constant Node_Id := Prefix (N);
begin
-- We do not need checks if we are not generating code (i.e. the
-- expander is not active). This is not just an optimization, there
-- are cases (e.g. with pragma Debug) where generating the checks
-- can cause real trouble.
if not Expander_Active then
return;
end if;
-- No check if short circuiting makes check unnecessary
if not Check_Needed (P, Access_Check) then
return;
end if;
-- No check if accessing the Offset_To_Top component of a dispatch
-- table. They are safe by construction.
if Tagged_Type_Expansion
and then Present (Etype (P))
and then Is_RTE (Etype (P), RE_Offset_To_Top_Ptr)
then
return;
end if;
-- Otherwise go ahead and install the check
Install_Null_Excluding_Check (P);
end Apply_Access_Check;
-------------------------------
-- Apply_Accessibility_Check --
-------------------------------
procedure Apply_Accessibility_Check
(N : Node_Id;
Typ : Entity_Id;
Insert_Node : Node_Id)
is
Loc : constant Source_Ptr := Sloc (N);
Check_Cond : Node_Id;
Param_Ent : Entity_Id := Param_Entity (N);
Param_Level : Node_Id;
Type_Level : Node_Id;
begin
-- Verify we haven't tried to add a dynamic accessibility check when we
-- shouldn't.
pragma Assert (not No_Dynamic_Accessibility_Checks_Enabled (N));
if Ada_Version >= Ada_2012
and then not Present (Param_Ent)
and then Is_Entity_Name (N)
and then Ekind (Entity (N)) in E_Constant | E_Variable
and then Present (Effective_Extra_Accessibility (Entity (N)))
then
Param_Ent := Entity (N);
while Present (Renamed_Object (Param_Ent)) loop
-- Renamed_Object must return an Entity_Name here
-- because of preceding "Present (E_E_A (...))" test.
Param_Ent := Entity (Renamed_Object (Param_Ent));
end loop;
end if;
if Inside_A_Generic then
return;
-- Only apply the run-time check if the access parameter has an
-- associated extra access level parameter and when accessibility checks
-- are enabled.
elsif Present (Param_Ent)
and then Present (Get_Dynamic_Accessibility (Param_Ent))
and then not Accessibility_Checks_Suppressed (Param_Ent)
and then not Accessibility_Checks_Suppressed (Typ)
then
-- Obtain the parameter's accessibility level
Param_Level :=
New_Occurrence_Of (Get_Dynamic_Accessibility (Param_Ent), Loc);
-- Use the dynamic accessibility parameter for the function's result
-- when one has been created instead of statically referring to the
-- deepest type level so as to appropriatly handle the rules for
-- RM 3.10.2 (10.1/3).
if Ekind (Scope (Param_Ent)) = E_Function
and then In_Return_Value (N)
and then Ekind (Typ) = E_Anonymous_Access_Type
then
-- Associate the level of the result type to the extra result
-- accessibility parameter belonging to the current function.
if Present (Extra_Accessibility_Of_Result (Scope (Param_Ent))) then
Type_Level :=
New_Occurrence_Of
(Extra_Accessibility_Of_Result (Scope (Param_Ent)), Loc);
-- In Ada 2005 and earlier modes, a result extra accessibility
-- parameter is not generated and no dynamic check is performed.
else
return;
end if;
-- Otherwise get the type's accessibility level normally
else
Type_Level :=
Make_Integer_Literal (Loc, Deepest_Type_Access_Level (Typ));
end if;
-- Raise Program_Error if the accessibility level of the access
-- parameter is deeper than the level of the target access type.
Check_Cond :=
Make_Op_Gt (Loc,
Left_Opnd => Param_Level,
Right_Opnd => Type_Level);
Insert_Action (Insert_Node,
Make_Raise_Program_Error (Loc,
Condition => Check_Cond,
Reason => PE_Accessibility_Check_Failed));
Analyze_And_Resolve (N);
-- If constant folding has happened on the condition for the
-- generated error, then warn about it being unconditional.
if Nkind (Check_Cond) = N_Identifier
and then Entity (Check_Cond) = Standard_True
then
Error_Msg_Warn := SPARK_Mode /= On;
Error_Msg_N ("accessibility check fails<<", N);
Error_Msg_N ("\Program_Error [<<", N);
end if;
end if;
end Apply_Accessibility_Check;
--------------------------------
-- Apply_Address_Clause_Check --
--------------------------------
procedure Apply_Address_Clause_Check (E : Entity_Id; N : Node_Id) is
pragma Assert (Nkind (N) = N_Freeze_Entity);
AC : constant Node_Id := Address_Clause (E);
Loc : constant Source_Ptr := Sloc (AC);
Typ : constant Entity_Id := Etype (E);
Expr : Node_Id;
-- Address expression (not necessarily the same as Aexp, for example
-- when Aexp is a reference to a constant, in which case Expr gets
-- reset to reference the value expression of the constant).
begin
-- See if alignment check needed. Note that we never need a check if the
-- maximum alignment is one, since the check will always succeed.
-- Note: we do not check for checks suppressed here, since that check
-- was done in Sem_Ch13 when the address clause was processed. We are
-- only called if checks were not suppressed. The reason for this is
-- that we have to delay the call to Apply_Alignment_Check till freeze
-- time (so that all types etc are elaborated), but we have to check
-- the status of check suppressing at the point of the address clause.
if No (AC)
or else not Check_Address_Alignment (AC)
or else Maximum_Alignment = 1
then
return;
end if;
-- Obtain expression from address clause
Expr := Address_Value (Expression (AC));
-- See if we know that Expr has an acceptable value at compile time. If
-- it hasn't or we don't know, we defer issuing the warning until the
-- end of the compilation to take into account back end annotations.
if Compile_Time_Known_Value (Expr)
and then (Known_Alignment (E) or else Known_Alignment (Typ))
then
declare
AL : Uint := Alignment (Typ);
begin
-- The object alignment might be more restrictive than the type
-- alignment.
if Known_Alignment (E) then
AL := Alignment (E);
end if;
if Expr_Value (Expr) mod AL = 0 then
return;
end if;
end;
-- If the expression has the form X'Address, then we can find out if the
-- object X has an alignment that is compatible with the object E. If it
-- hasn't or we don't know, we defer issuing the warning until the end
-- of the compilation to take into account back end annotations.
elsif Nkind (Expr) = N_Attribute_Reference
and then Attribute_Name (Expr) = Name_Address
and then
Has_Compatible_Alignment (E, Prefix (Expr), False) = Known_Compatible
then
return;
end if;
-- Here we do not know if the value is acceptable. Strictly we don't
-- have to do anything, since if the alignment is bad, we have an
-- erroneous program. However we are allowed to check for erroneous
-- conditions and we decide to do this by default if the check is not
-- suppressed.
-- However, don't do the check if elaboration code is unwanted
if Restriction_Active (No_Elaboration_Code) then
return;
-- Generate a check to raise PE if alignment may be inappropriate
else
-- If the original expression is a nonstatic constant, use the name
-- of the constant itself rather than duplicating its initialization
-- expression, which was extracted above.
-- Note: Expr is empty if the address-clause is applied to in-mode
-- actuals (allowed by 13.1(22)).
if not Present (Expr)
or else
(Is_Entity_Name (Expression (AC))
and then Ekind (Entity (Expression (AC))) = E_Constant
and then Nkind (Parent (Entity (Expression (AC)))) =
N_Object_Declaration)
then
Expr := New_Copy_Tree (Expression (AC));
else
Remove_Side_Effects (Expr);
end if;
if No (Actions (N)) then
Set_Actions (N, New_List);
end if;
Prepend_To (Actions (N),
Make_Raise_Program_Error (Loc,
Condition =>
Make_Op_Ne (Loc,
Left_Opnd =>
Make_Op_Mod (Loc,
Left_Opnd =>
Unchecked_Convert_To
(RTE (RE_Integer_Address), Expr),
Right_Opnd =>
Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (E, Loc),
Attribute_Name => Name_Alignment)),
Right_Opnd => Make_Integer_Literal (Loc, Uint_0)),
Reason => PE_Misaligned_Address_Value));
Warning_Msg := No_Error_Msg;
Analyze (First (Actions (N)), Suppress => All_Checks);
-- If the above raise action generated a warning message (for example
-- from Warn_On_Non_Local_Exception mode with the active restriction
-- No_Exception_Propagation).
if Warning_Msg /= No_Error_Msg then
-- If the expression has a known at compile time value, then
-- once we know the alignment of the type, we can check if the
-- exception will be raised or not, and if not, we don't need
-- the warning so we will kill the warning later on.
if Compile_Time_Known_Value (Expr) then
Alignment_Warnings.Append
((E => E,
A => Expr_Value (Expr),
P => Empty,
W => Warning_Msg));
-- Likewise if the expression is of the form X'Address
elsif Nkind (Expr) = N_Attribute_Reference
and then Attribute_Name (Expr) = Name_Address
then
Alignment_Warnings.Append
((E => E,
A => No_Uint,
P => Prefix (Expr),
W => Warning_Msg));
-- Add explanation of the warning generated by the check
else
Error_Msg_N
("\address value may be incompatible with alignment of "
& "object?.x?", AC);
end if;
end if;
return;
end if;
exception
-- If we have some missing run time component in configurable run time
-- mode then just skip the check (it is not required in any case).
when RE_Not_Available =>
return;
end Apply_Address_Clause_Check;
-------------------------------------
-- Apply_Arithmetic_Overflow_Check --
-------------------------------------
procedure Apply_Arithmetic_Overflow_Check (N : Node_Id) is
begin
-- Use old routine in almost all cases (the only case we are treating
-- specially is the case of a signed integer arithmetic op with the
-- overflow checking mode set to MINIMIZED or ELIMINATED).
if Overflow_Check_Mode = Strict
or else not Is_Signed_Integer_Arithmetic_Op (N)
then
Apply_Arithmetic_Overflow_Strict (N);
-- Otherwise use the new routine for the case of a signed integer
-- arithmetic op, with Do_Overflow_Check set to True, and the checking
-- mode is MINIMIZED or ELIMINATED.
else
Apply_Arithmetic_Overflow_Minimized_Eliminated (N);
end if;
end Apply_Arithmetic_Overflow_Check;
--------------------------------------
-- Apply_Arithmetic_Overflow_Strict --
--------------------------------------
-- This routine is called only if the type is an integer type and an
-- arithmetic overflow check may be needed for op (add, subtract, or
-- multiply). This check is performed if Backend_Overflow_Checks_On_Target
-- is not enabled and Do_Overflow_Check is set. In this case we expand the
-- operation into a more complex sequence of tests that ensures that
-- overflow is properly caught.
-- This is used in CHECKED modes. It is identical to the code for this
-- cases before the big overflow earthquake, thus ensuring that in this
-- modes we have compatible behavior (and reliability) to what was there
-- before. It is also called for types other than signed integers, and if
-- the Do_Overflow_Check flag is off.
-- Note: we also call this routine if we decide in the MINIMIZED case
-- to give up and just generate an overflow check without any fuss.
procedure Apply_Arithmetic_Overflow_Strict (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
Typ : constant Entity_Id := Etype (N);
Rtyp : constant Entity_Id := Root_Type (Typ);
begin
-- Nothing to do if Do_Overflow_Check not set or overflow checks
-- suppressed.
if not Do_Overflow_Check (N) then
return;
end if;
-- An interesting special case. If the arithmetic operation appears as
-- the operand of a type conversion:
-- type1 (x op y)
-- and all the following conditions apply:
-- arithmetic operation is for a signed integer type
-- target type type1 is a static integer subtype
-- range of x and y are both included in the range of type1
-- range of x op y is included in the range of type1
-- size of type1 is at least twice the result size of op
-- then we don't do an overflow check in any case. Instead, we transform
-- the operation so that we end up with:
-- type1 (type1 (x) op type1 (y))
-- This avoids intermediate overflow before the conversion. It is
-- explicitly permitted by RM 3.5.4(24):
-- For the execution of a predefined operation of a signed integer
-- type, the implementation need not raise Constraint_Error if the
-- result is outside the base range of the type, so long as the
-- correct result is produced.
-- It's hard to imagine that any programmer counts on the exception
-- being raised in this case, and in any case it's wrong coding to
-- have this expectation, given the RM permission. Furthermore, other
-- Ada compilers do allow such out of range results.
-- Note that we do this transformation even if overflow checking is
-- off, since this is precisely about giving the "right" result and
-- avoiding the need for an overflow check.
-- Note: this circuit is partially redundant with respect to the similar
-- processing in Exp_Ch4.Expand_N_Type_Conversion, but the latter deals
-- with cases that do not come through here. We still need the following
-- processing even with the Exp_Ch4 code in place, since we want to be
-- sure not to generate the arithmetic overflow check in these cases
-- (Exp_Ch4 would have a hard time removing them once generated).
if Is_Signed_Integer_Type (Typ)
and then Nkind (Parent (N)) = N_Type_Conversion
then
Conversion_Optimization : declare
Target_Type : constant Entity_Id :=
Base_Type (Entity (Subtype_Mark (Parent (N))));
Llo, Lhi : Uint;
Rlo, Rhi : Uint;
LOK, ROK : Boolean;
Vlo : Uint;
Vhi : Uint;
VOK : Boolean;
Tlo : Uint;
Thi : Uint;
begin
if Is_Integer_Type (Target_Type)
and then RM_Size (Root_Type (Target_Type)) >= 2 * RM_Size (Rtyp)
then
Tlo := Expr_Value (Type_Low_Bound (Target_Type));
Thi := Expr_Value (Type_High_Bound (Target_Type));
Determine_Range
(Left_Opnd (N), LOK, Llo, Lhi, Assume_Valid => True);
Determine_Range
(Right_Opnd (N), ROK, Rlo, Rhi, Assume_Valid => True);
if (LOK and ROK)
and then Tlo <= Llo and then Lhi <= Thi
and then Tlo <= Rlo and then Rhi <= Thi
then
Determine_Range (N, VOK, Vlo, Vhi, Assume_Valid => True);
if VOK and then Tlo <= Vlo and then Vhi <= Thi then
Rewrite (Left_Opnd (N),
Make_Type_Conversion (Loc,
Subtype_Mark => New_Occurrence_Of (Target_Type, Loc),
Expression => Relocate_Node (Left_Opnd (N))));
Rewrite (Right_Opnd (N),
Make_Type_Conversion (Loc,
Subtype_Mark => New_Occurrence_Of (Target_Type, Loc),
Expression => Relocate_Node (Right_Opnd (N))));
-- Rewrite the conversion operand so that the original
-- node is retained, in order to avoid the warning for
-- redundant conversions in Resolve_Type_Conversion.
Rewrite (N, Relocate_Node (N));
Set_Etype (N, Target_Type);
Analyze_And_Resolve (Left_Opnd (N), Target_Type);
Analyze_And_Resolve (Right_Opnd (N), Target_Type);
-- Given that the target type is twice the size of the
-- source type, overflow is now impossible, so we can
-- safely kill the overflow check and return.
Set_Do_Overflow_Check (N, False);
return;
end if;
end if;
end if;
end Conversion_Optimization;
end if;
-- Now see if an overflow check is required
declare
Dsiz : constant Uint := 2 * Esize (Rtyp);
Opnod : Node_Id;
Ctyp : Entity_Id;
Opnd : Node_Id;
Cent : RE_Id;
begin
-- Skip check if back end does overflow checks, or the overflow flag
-- is not set anyway, or we are not doing code expansion, or the
-- parent node is a type conversion whose operand is an arithmetic
-- operation on signed integers on which the expander can promote
-- later the operands to type Integer (see Expand_N_Type_Conversion).
if Backend_Overflow_Checks_On_Target
or else not Do_Overflow_Check (N)
or else not Expander_Active
or else (Present (Parent (N))
and then Nkind (Parent (N)) = N_Type_Conversion
and then Integer_Promotion_Possible (Parent (N)))
then
return;
end if;
-- Otherwise, generate the full general code for front end overflow
-- detection, which works by doing arithmetic in a larger type:
-- x op y
-- is expanded into
-- Typ (Checktyp (x) op Checktyp (y));
-- where Typ is the type of the original expression, and Checktyp is
-- an integer type of sufficient length to hold the largest possible
-- result.
-- If the size of the check type exceeds the maximum integer size,
-- we use a different approach, expanding to:
-- typ (xxx_With_Ovflo_Check (Integer_NN (x), Integer_NN (y)))
-- where xxx is Add, Multiply or Subtract as appropriate
-- Find check type if one exists
if Dsiz <= System_Max_Integer_Size then
Ctyp := Integer_Type_For (Dsiz, Uns => False);
-- No check type exists, use runtime call
else
if System_Max_Integer_Size = 64 then
Ctyp := RTE (RE_Integer_64);
else
Ctyp := RTE (RE_Integer_128);
end if;
if Nkind (N) = N_Op_Add then
if System_Max_Integer_Size = 64 then
Cent := RE_Add_With_Ovflo_Check64;
else
Cent := RE_Add_With_Ovflo_Check128;
end if;
elsif Nkind (N) = N_Op_Subtract then
if System_Max_Integer_Size = 64 then
Cent := RE_Subtract_With_Ovflo_Check64;
else
Cent := RE_Subtract_With_Ovflo_Check128;
end if;
else pragma Assert (Nkind (N) = N_Op_Multiply);
if System_Max_Integer_Size = 64 then
Cent := RE_Multiply_With_Ovflo_Check64;
else
Cent := RE_Multiply_With_Ovflo_Check128;
end if;
end if;
Rewrite (N,
OK_Convert_To (Typ,
Make_Function_Call (Loc,
Name => New_Occurrence_Of (RTE (Cent), Loc),
Parameter_Associations => New_List (
OK_Convert_To (Ctyp, Left_Opnd (N)),
OK_Convert_To (Ctyp, Right_Opnd (N))))));
Analyze_And_Resolve (N, Typ);
return;
end if;
-- If we fall through, we have the case where we do the arithmetic
-- in the next higher type and get the check by conversion. In these
-- cases Ctyp is set to the type to be used as the check type.
Opnod := Relocate_Node (N);
Opnd := OK_Convert_To (Ctyp, Left_Opnd (Opnod));
Analyze (Opnd);
Set_Etype (Opnd, Ctyp);
Set_Analyzed (Opnd, True);
Set_Left_Opnd (Opnod, Opnd);
Opnd := OK_Convert_To (Ctyp, Right_Opnd (Opnod));
Analyze (Opnd);
Set_Etype (Opnd, Ctyp);
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.
Set_Etype (Opnod, Base_Type (Ctyp));
Set_Do_Overflow_Check (Opnod, False);
Set_Analyzed (Opnod, True);
-- Now build the outer conversion
Opnd := OK_Convert_To (Typ, Opnod);
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 overflow check.
if Is_Discrete_Type (Typ) then
Rewrite (N, Opnd);
Generate_Range_Check
(Expression (N), Typ, CE_Overflow_Check_Failed);
-- For other types, we enable overflow checking on the conversion,
-- after setting the node as analyzed to prevent recursive attempts
-- to expand the conversion node.
else
Set_Analyzed (Opnd, True);
Enable_Overflow_Check (Opnd);
Rewrite (N, Opnd);
end if;
exception
when RE_Not_Available =>
return;
end;
end Apply_Arithmetic_Overflow_Strict;
----------------------------------------------------
-- Apply_Arithmetic_Overflow_Minimized_Eliminated --
----------------------------------------------------
procedure Apply_Arithmetic_Overflow_Minimized_Eliminated (Op : Node_Id) is
pragma Assert (Is_Signed_Integer_Arithmetic_Op (Op));
Loc : constant Source_Ptr := Sloc (Op);
P : constant Node_Id := Parent (Op);
LLIB : constant Entity_Id := Base_Type (Standard_Long_Long_Integer);
-- Operands and results are of this type when we convert
Result_Type : constant Entity_Id := Etype (Op);
-- Original result type
Check_Mode : constant Overflow_Mode_Type := Overflow_Check_Mode;
pragma Assert (Check_Mode in Minimized_Or_Eliminated);
Lo, Hi : Uint;
-- Ranges of values for result
begin
-- Nothing to do if our parent is one of the following:
-- Another signed integer arithmetic op
-- A membership operation
-- A comparison operation
-- In all these cases, we will process at the higher level (and then
-- this node will be processed during the downwards recursion that
-- is part of the processing in Minimize_Eliminate_Overflows).
if Is_Signed_Integer_Arithmetic_Op (P)
or else Nkind (P) in N_Membership_Test
or else Nkind (P) in N_Op_Compare
-- This is also true for an alternative in a case expression
or else Nkind (P) = N_Case_Expression_Alternative
-- This is also true for a range operand in a membership test
or else (Nkind (P) = N_Range
and then Nkind (Parent (P)) in N_Membership_Test)
then
-- If_Expressions and Case_Expressions are treated as arithmetic
-- ops, but if they appear in an assignment or similar contexts
-- there is no overflow check that starts from that parent node,
-- so apply check now.
if Nkind (P) in N_If_Expression | N_Case_Expression
and then not Is_Signed_Integer_Arithmetic_Op (Parent (P))
then
null;
else
return;
end if;
end if;
-- Otherwise, we have a top level arithmetic operation node, and this
-- is where we commence the special processing for MINIMIZED/ELIMINATED
-- modes. This is the case where we tell the machinery not to move into
-- Bignum mode at this top level (of course the top level operation
-- will still be in Bignum mode if either of its operands are of type
-- Bignum).
Minimize_Eliminate_Overflows (Op, Lo, Hi, Top_Level => True);
-- That call may but does not necessarily change the result type of Op.
-- It is the job of this routine to undo such changes, so that at the
-- top level, we have the proper type. This "undoing" is a point at
-- which a final overflow check may be applied.
-- If the result type was not fiddled we are all set. We go to base
-- types here because things may have been rewritten to generate the
-- base type of the operand types.
if Base_Type (Etype (Op)) = Base_Type (Result_Type) then
return;
-- Bignum case
elsif Is_RTE (Etype (Op), RE_Bignum) then
-- We need a sequence that looks like:
-- Rnn : Result_Type;
-- declare
-- M : Mark_Id := SS_Mark;
-- begin
-- Rnn := Long_Long_Integer'Base (From_Bignum (Op));
-- SS_Release (M);
-- end;
-- This block is inserted (using Insert_Actions), and then the node
-- is replaced with a reference to Rnn.
-- If our parent is a conversion node then there is no point in
-- generating a conversion to Result_Type. Instead, we let the parent
-- handle this. Note that this special case is not just about
-- optimization. Consider
-- A,B,C : Integer;
-- ...
-- X := Long_Long_Integer'Base (A * (B ** C));
-- Now the product may fit in Long_Long_Integer but not in Integer.
-- In MINIMIZED/ELIMINATED mode, we don't want to introduce an
-- overflow exception for this intermediate value.
declare
Blk : constant Node_Id := Make_Bignum_Block (Loc);
Rnn : constant Entity_Id := Make_Temporary (Loc, 'R', Op);
RHS : Node_Id;
Rtype : Entity_Id;
begin
RHS := Convert_From_Bignum (Op);
if Nkind (P) /= N_Type_Conversion then
Convert_To_And_Rewrite (Result_Type, RHS);
Rtype := Result_Type;
-- Interesting question, do we need a check on that conversion
-- operation. Answer, not if we know the result is in range.
-- At the moment we are not taking advantage of this. To be
-- looked at later ???
else
Rtype := LLIB;
end if;
Insert_Before
(First (Statements (Handled_Statement_Sequence (Blk))),
Make_Assignment_Statement (Loc,
Name => New_Occurrence_Of (Rnn, Loc),
Expression => RHS));
Insert_Actions (Op, New_List (
Make_Object_Declaration (Loc,
Defining_Identifier => Rnn,
Object_Definition => New_Occurrence_Of (Rtype, Loc)),
Blk));
Rewrite (Op, New_Occurrence_Of (Rnn, Loc));
Analyze_And_Resolve (Op);
end;
-- Here we know the result is Long_Long_Integer'Base, or that it has
-- been rewritten because the parent operation is a conversion. See
-- Apply_Arithmetic_Overflow_Strict.Conversion_Optimization.
else
pragma Assert
(Etype (Op) = LLIB or else Nkind (Parent (Op)) = N_Type_Conversion);
-- All we need to do here is to convert the result to the proper
-- result type. As explained above for the Bignum case, we can
-- omit this if our parent is a type conversion.
if Nkind (P) /= N_Type_Conversion then
Convert_To_And_Rewrite (Result_Type, Op);
end if;
Analyze_And_Resolve (Op);
end if;
end Apply_Arithmetic_Overflow_Minimized_Eliminated;
----------------------------
-- Apply_Constraint_Check --
----------------------------
procedure Apply_Constraint_Check
(N : Node_Id;
Typ : Entity_Id;
No_Sliding : Boolean := False)
is
Desig_Typ : Entity_Id;
begin
-- No checks inside a generic (check the instantiations)
if Inside_A_Generic then
return;
end if;
-- Apply required constraint checks
if Is_Scalar_Type (Typ) then
Apply_Scalar_Range_Check (N, Typ);
elsif Is_Array_Type (Typ) then
-- A useful optimization: an aggregate with only an others clause
-- always has the right bounds.
if Nkind (N) = N_Aggregate
and then No (Expressions (N))
and then Nkind (First (Component_Associations (N))) =
N_Component_Association
and then Nkind
(First (Choices (First (Component_Associations (N)))))
= N_Others_Choice
then
return;
end if;
if Is_Constrained (Typ) then
Apply_Length_Check (N, Typ);
if No_Sliding then
Apply_Range_Check (N, Typ);
end if;
else
Apply_Range_Check (N, Typ);
end if;
elsif (Is_Record_Type (Typ) or else Is_Private_Type (Typ))
and then Has_Discriminants (Base_Type (Typ))
and then Is_Constrained (Typ)
then
Apply_Discriminant_Check (N, Typ);
elsif Is_Access_Type (Typ) then
Desig_Typ := Designated_Type (Typ);
-- No checks necessary if expression statically null
if Known_Null (N) then
if Can_Never_Be_Null (Typ) then
Install_Null_Excluding_Check (N);
end if;
-- No sliding possible on access to arrays
elsif Is_Array_Type (Desig_Typ) then
if Is_Constrained (Desig_Typ) then
Apply_Length_Check (N, Typ);
end if;
Apply_Range_Check (N, Typ);
-- Do not install a discriminant check for a constrained subtype
-- created for an unconstrained nominal type because the subtype
-- has the correct constraints by construction.
elsif Has_Discriminants (Base_Type (Desig_Typ))
and then Is_Constrained (Desig_Typ)
and then not Is_Constr_Subt_For_U_Nominal (Desig_Typ)
then
Apply_Discriminant_Check (N, Typ);
end if;
-- Apply the 2005 Null_Excluding check. Note that we do not apply
-- this check if the constraint node is illegal, as shown by having
-- an error posted. This additional guard prevents cascaded errors
-- and compiler aborts on illegal programs involving Ada 2005 checks.
if Can_Never_Be_Null (Typ)
and then not Can_Never_Be_Null (Etype (N))
and then not Error_Posted (N)
then
Install_Null_Excluding_Check (N);
end if;
end if;
end Apply_Constraint_Check;
------------------------------
-- Apply_Discriminant_Check --
------------------------------
procedure Apply_Discriminant_Check
(N : Node_Id;
Typ : Entity_Id;
Lhs : Node_Id := Empty)
is
Loc : constant Source_Ptr := Sloc (N);
Do_Access : constant Boolean := Is_Access_Type (Typ);
S_Typ : Entity_Id := Etype (N);
Cond : Node_Id;
T_Typ : Entity_Id;
function Denotes_Explicit_Dereference (Obj : Node_Id) return Boolean;
-- A heap object with an indefinite subtype is constrained by its
-- initial value, and assigning to it requires a constraint_check.
-- The target may be an explicit dereference, or a renaming of one.
function Is_Aliased_Unconstrained_Component return Boolean;
-- It is possible for an aliased component to have a nominal
-- unconstrained subtype (through instantiation). If this is a
-- discriminated component assigned in the expansion of an aggregate
-- in an initialization, the check must be suppressed. This unusual
-- situation requires a predicate of its own.
----------------------------------
-- Denotes_Explicit_Dereference --
----------------------------------
function Denotes_Explicit_Dereference (Obj : Node_Id) return Boolean is
begin
return
Nkind (Obj) = N_Explicit_Dereference
or else
(Is_Entity_Name (Obj)
and then Present (Renamed_Object (Entity (Obj)))
and then Nkind (Renamed_Object (Entity (Obj))) =
N_Explicit_Dereference);
end Denotes_Explicit_Dereference;
----------------------------------------
-- Is_Aliased_Unconstrained_Component --
----------------------------------------
function Is_Aliased_Unconstrained_Component return Boolean is
Comp : Entity_Id;
Pref : Node_Id;
begin
if Nkind (Lhs) /= N_Selected_Component then
return False;
else
Comp := Entity (Selector_Name (Lhs));
Pref := Prefix (Lhs);
end if;
if Ekind (Comp) /= E_Component
or else not Is_Aliased (Comp)
then
return False;
end if;
return not Comes_From_Source (Pref)
and then In_Instance
and then not Is_Constrained (Etype (Comp));
end Is_Aliased_Unconstrained_Component;
-- Start of processing for Apply_Discriminant_Check
begin
if Do_Access then
T_Typ := Designated_Type (Typ);
else
T_Typ := Typ;
end if;
-- If the expression is a function call that returns a limited object
-- it cannot be copied. It is not clear how to perform the proper
-- discriminant check in this case because the discriminant value must
-- be retrieved from the constructed object itself.
if Nkind (N) = N_Function_Call
and then Is_Limited_Type (Typ)
and then Is_Entity_Name (Name (N))
and then Returns_By_Ref (Entity (Name (N)))
then
return;
end if;
-- Only apply checks when generating code and discriminant checks are
-- not suppressed. In GNATprove mode, we do not apply the checks, but we
-- still analyze the expression to possibly issue errors on SPARK code
-- when a run-time error can be detected at compile time.
if not GNATprove_Mode then
if not Expander_Active
or else Discriminant_Checks_Suppressed (T_Typ)
then
return;
end if;
end if;
-- 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.
if Known_Null (N) then
return;
elsif Is_Access_Type (S_Typ) then
S_Typ := Designated_Type (S_Typ);
if Ekind (S_Typ) = E_Incomplete_Type then
return;
end if;
end if;
-- If an assignment target is present, then we need to generate the
-- actual subtype if the target is a parameter or aliased object with
-- an unconstrained nominal subtype.
-- Ada 2005 (AI-363): For Ada 2005, we limit the building of the actual
-- subtype to the parameter and dereference cases, since other aliased
-- objects are unconstrained (unless the nominal subtype is explicitly
-- constrained).
if Present (Lhs)
and then (Present (Param_Entity (Lhs))
or else (Ada_Version < Ada_2005
and then not Is_Constrained (T_Typ)
and then Is_Aliased_View (Lhs)
and then not Is_Aliased_Unconstrained_Component)
or else (Ada_Version >= Ada_2005
and then not Is_Constrained (T_Typ)
and then Denotes_Explicit_Dereference (Lhs)
and then Nkind (Original_Node (Lhs)) /=
N_Function_Call))
then
T_Typ := Get_Actual_Subtype (Lhs);
end if;
-- Nothing to do if the type is unconstrained (this is the case where
-- the actual subtype in the RM sense of N is unconstrained and no check
-- is required).
if not Is_Constrained (T_Typ) then
return;
-- Ada 2005: nothing to do if the type is one for which there is a
-- partial view that is constrained.
elsif Ada_Version >= Ada_2005
and then Object_Type_Has_Constrained_Partial_View
(Typ => Base_Type (T_Typ),
Scop => Current_Scope)
then
return;
end if;
-- Nothing to do if the type is an Unchecked_Union
if Is_Unchecked_Union (Base_Type (T_Typ)) then
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.
if Nkind (Original_Node (N)) /= N_Allocator
and then (No (Lhs)
or else not Is_Entity_Name (Lhs)
or else No (Param_Entity (Lhs)))
then
if (Etype (N) = Typ
or else (Do_Access and then Designated_Type (Typ) = S_Typ))
and then not Is_Aliased_View (Lhs)
then
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).
elsif Nkind (Original_Node (N)) = N_Allocator
and then Is_Entity_Name (Expression (Original_Node (N)))
then
declare
Alloc_Typ : constant Entity_Id :=
Entity (Expression (Original_Node (N)));
begin
if Alloc_Typ = T_Typ
or else (Nkind (Parent (T_Typ)) = N_Subtype_Declaration
and then Is_Entity_Name (
Subtype_Indication (Parent (T_Typ)))
and then Alloc_Typ = Base_Type (T_Typ))
then
return;
end if;
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.
-- We skip this check for the case where the node is rewritten as
-- an allocator, because it already carries the context subtype,
-- and extracting the discriminants from the aggregate is messy.
if Is_Constrained (S_Typ)
and then Nkind (Original_Node (N)) /= N_Allocator
then
declare
DconT : Elmt_Id;
Discr : Entity_Id;
DconS : Elmt_Id;
ItemS : Node_Id;
ItemT : Node_Id;
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.
if Has_Discriminants (S_Typ) then
Discr := First_Discriminant (S_Typ);
DconS := First_Elmt (Discriminant_Constraint (S_Typ));
else
Discr := First_Discriminant (Underlying_Type (S_Typ));
DconS :=
First_Elmt
(Discriminant_Constraint (Underlying_Type (S_Typ)));
if No (DconS) then
return;
end if;
-- A further optimization: if T_Typ is derived from S_Typ
-- without imposing a constraint, no check is needed.
if Nkind (Original_Node (Parent (T_Typ))) =
N_Full_Type_Declaration
then
declare
Type_Def : constant Node_Id :=
Type_Definition (Original_Node (Parent (T_Typ)));
begin
if Nkind (Type_Def) = N_Derived_Type_Definition
and then Is_Entity_Name (Subtype_Indication (Type_Def))
and then Entity (Subtype_Indication (Type_Def)) = S_Typ
then
return;
end if;
end;
end if;
end if;
-- Constraint may appear in full view of type
if Ekind (T_Typ) = E_Private_Subtype
and then Present (Full_View (T_Typ))
then
DconT :=
First_Elmt (Discriminant_Constraint (Full_View (T_Typ)));
else
DconT :=
First_Elmt (Discriminant_Constraint (T_Typ));
end if;
while Present (Discr) loop
ItemS := Node (DconS);
ItemT := Node (DconT);
-- For a discriminated component type constrained by the
-- current instance of an enclosing type, there is no
-- applicable discriminant check.
if Nkind (ItemT) = N_Attribute_Reference
and then Is_Access_Type (Etype (ItemT))
and then Is_Entity_Name (Prefix (ItemT))
and then Is_Type (Entity (Prefix (ItemT)))
then
return;
end if;
-- If the expressions for the discriminants are identical
-- and it is side-effect free (for now just an entity),
-- this may be a shared constraint, e.g. from a subtype
-- without a constraint introduced as a generic actual.
-- Examine other discriminants if any.
if ItemS = ItemT
and then Is_Entity_Name (ItemS)
then
null;
elsif not Is_OK_Static_Expression (ItemS)
or else not Is_OK_Static_Expression (ItemT)
then
exit;
elsif Expr_Value (ItemS) /= Expr_Value (ItemT) then
if Do_Access then -- needs run-time check.
exit;
else
Apply_Compile_Time_Constraint_Error
(N, "incorrect value for discriminant&??",
CE_Discriminant_Check_Failed, Ent => Discr);
return;
end if;
end if;
Next_Elmt (DconS);
Next_Elmt (DconT);
Next_Discriminant (Discr);
end loop;
if No (Discr) then
return;
end if;
end;
end if;
-- In GNATprove mode, we do not apply the checks
if GNATprove_Mode then
return;
end if;
-- Here we need a discriminant check. First build the expression
-- for the comparisons of the discriminants:
-- (n.disc1 /= typ.disc1) or else
-- (n.disc2 /= typ.disc2) or else
-- ...
-- (n.discn /= typ.discn)
Cond := Build_Discriminant_Checks (N, T_Typ);
-- If Lhs is set and is a parameter, then the condition is guarded by:
-- lhs'constrained and then (condition built above)
if Present (Param_Entity (Lhs)) then
Cond :=
Make_And_Then (Loc,
Left_Opnd =>
Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (Param_Entity (Lhs), Loc),
Attribute_Name => Name_Constrained),
Right_Opnd => Cond);
end if;
if Do_Access then
Cond := Guard_Access (Cond, Loc, N);
end if;
Insert_Action (N,
Make_Raise_Constraint_Error (Loc,
Condition => Cond,
Reason => CE_Discriminant_Check_Failed));
end Apply_Discriminant_Check;
-------------------------
-- Apply_Divide_Checks --
-------------------------
procedure Apply_Divide_Checks (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
Typ : constant Entity_Id := Etype (N);
Left : constant Node_Id := Left_Opnd (N);
Right : constant Node_Id := Right_Opnd (N);
Mode : constant Overflow_Mode_Type := Overflow_Check_Mode;
-- Current overflow checking mode
LLB : Uint;
Llo : Uint;
Lhi : Uint;
LOK : Boolean;
Rlo : Uint;
Rhi : Uint;
ROK : Boolean;
pragma Warnings (Off, Lhi);
-- Don't actually use this value
begin
-- If we are operating in MINIMIZED or ELIMINATED mode, and we are
-- operating on signed integer types, then the only thing this routine
-- does is to call Apply_Arithmetic_Overflow_Minimized_Eliminated. That
-- procedure will (possibly later on during recursive downward calls),
-- ensure that any needed overflow/division checks are properly applied.
if Mode in Minimized_Or_Eliminated
and then Is_Signed_Integer_Type (Typ)
then
Apply_Arithmetic_Overflow_Minimized_Eliminated (N);
return;
end if;
-- Proceed here in SUPPRESSED or CHECKED modes
if Expander_Active
and then not Backend_Divide_Checks_On_Target
and then Check_Needed (Right, Division_Check)
then
Determine_Range (Right, ROK, Rlo, Rhi, Assume_Valid => True);
-- Deal with division check
if Do_Division_Check (N)
and then not Division_Checks_Suppressed (Typ)
then
Apply_Division_Check (N, Rlo, Rhi, ROK);
end if;
-- Deal with overflow check
if Do_Overflow_Check (N)
and then not Overflow_Checks_Suppressed (Etype (N))
then
Set_Do_Overflow_Check (N, False);
-- Test for extremely annoying case of xxx'First divided by -1
-- for division of signed integer types (only overflow case).
if Nkind (N) = N_Op_Divide
and then Is_Signed_Integer_Type (Typ)
then
Determine_Range (Left, LOK, Llo, Lhi, Assume_Valid => True);
LLB := Expr_Value (Type_Low_Bound (Base_Type (Typ)));
if ((not ROK) or else (Rlo <= (-1) and then (-1) <= Rhi))
and then
((not LOK) or else (Llo = LLB))
then
-- Ensure that expressions are not evaluated twice (once
-- for their runtime checks and once for their regular
-- computation).
Force_Evaluation (Left, Mode => Strict);
Force_Evaluation (Right, Mode => Strict);
Insert_Action (N,
Make_Raise_Constraint_Error (Loc,
Condition =>
Make_And_Then (Loc,
Left_Opnd =>
Make_Op_Eq (Loc,
Left_Opnd =>
Duplicate_Subexpr_Move_Checks (Left),
Right_Opnd => Make_Integer_Literal (Loc, LLB)),
Right_Opnd =>
Make_Op_Eq (Loc,
Left_Opnd => Duplicate_Subexpr (Right),
Right_Opnd => Make_Integer_Literal (Loc, -1))),
Reason => CE_Overflow_Check_Failed));
end if;
end if;
end if;
end if;
end Apply_Divide_Checks;
--------------------------
-- Apply_Division_Check --
--------------------------
procedure Apply_Division_Check
(N : Node_Id;
Rlo : Uint;
Rhi : Uint;
ROK : Boolean)
is
pragma Assert (Do_Division_Check (N));
Loc : constant Source_Ptr := Sloc (N);
Right : constant Node_Id := Right_Opnd (N);
Opnd : Node_Id;
begin
if Expander_Active
and then not Backend_Divide_Checks_On_Target
and then Check_Needed (Right, Division_Check)
-- See if division by zero possible, and if so generate test. This
-- part of the test is not controlled by the -gnato switch, since it
-- is a Division_Check and not an Overflow_Check.
and then Do_Division_Check (N)
then
Set_Do_Division_Check (N, False);
if (not ROK) or else (Rlo <= 0 and then 0 <= Rhi) then
if Is_Floating_Point_Type (Etype (N)) then
Opnd := Make_Real_Literal (Loc, Ureal_0);
else
Opnd := Make_Integer_Literal (Loc, 0);
end if;
Insert_Action (N,
Make_Raise_Constraint_Error (Loc,
Condition =>
Make_Op_Eq (Loc,
Left_Opnd => Duplicate_Subexpr_Move_Checks (Right),
Right_Opnd => Opnd),
Reason => CE_Divide_By_Zero));
end if;
end if;
end Apply_Division_Check;
----------------------------------
-- Apply_Float_Conversion_Check --
----------------------------------
-- 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:
-- (1) The bounds may not be known at compile time
-- (2) The check must take into account rounding or truncation.
-- (3) The range of type I may not be exactly representable in F.
-- (4) For the rounding case, the end-points I'First - 0.5 and
-- I'Last + 0.5 may or may not be in range, depending on the
-- sign of I'First and I'Last.
-- (5) X may be a NaN, which will fail any comparison
-- The following steps correctly convert X with rounding:
-- (1) If either I'First or I'Last is not known at compile time, use
-- I'Base instead of I in the next three steps and perform a
-- regular range check against I'Range after conversion.
-- (2) If I'First - 0.5 is representable in F then let Lo be that
-- value and define Lo_OK as (I'First > 0). Otherwise, let Lo be
-- F'Machine (I'First) and let Lo_OK be (Lo >= I'First).
-- In other words, take one of the closest floating-point numbers
-- (which is an integer value) to I'First, and see if it is in
-- range or not.
-- (3) If I'Last + 0.5 is representable in F then let Hi be that value
-- and define Hi_OK as (I'Last < 0). Otherwise, let Hi be
-- F'Machine (I'Last) and let Hi_OK be (Hi <= I'Last).
-- (4) Raise CE when (Lo_OK and X < Lo) or (not Lo_OK and X <= Lo)
-- or (Hi_OK and X > Hi) or (not Hi_OK and X >= Hi)
-- For the truncating case, replace steps (2) and (3) as follows:
-- (2) If I'First > 0, then let Lo be F'Pred (I'First) and let Lo_OK
-- be False. Otherwise, let Lo be F'Succ (I'First - 1) and let
-- Lo_OK be True.
-- (3) If I'Last < 0, then let Hi be F'Succ (I'Last) and let Hi_OK
-- be False. Otherwise let Hi be F'Pred (I'Last + 1) and let
-- Hi_OK be True.
procedure Apply_Float_Conversion_Check
(Expr : Node_Id;
Target_Typ : Entity_Id)
is
LB : constant Node_Id := Type_Low_Bound (Target_Typ);
HB : constant Node_Id := Type_High_Bound (Target_Typ);
Loc : constant Source_Ptr := Sloc (Expr);
Expr_Type : constant Entity_Id := Base_Type (Etype (Expr));
Target_Base : constant Entity_Id :=
Implementation_Base_Type (Target_Typ);
Par : constant Node_Id := Parent (Expr);
pragma Assert (Nkind (Par) = N_Type_Conversion);
-- Parent of check node, must be a type conversion
Truncate : constant Boolean := Float_Truncate (Par);
Max_Bound : constant Uint :=
UI_Expon
(Machine_Radix_Value (Expr_Type),
Machine_Mantissa_Value (Expr_Type) - 1) - 1;
-- Largest bound, so bound plus or minus half is a machine number of F
Ifirst, Ilast : Uint;
-- Bounds of integer type
Lo, Hi : Ureal;
-- Bounds to check in floating-point domain
Lo_OK, Hi_OK : Boolean;
-- True iff Lo resp. Hi belongs to I'Range
Lo_Chk, Hi_Chk : Node_Id;
-- Expressions that are False iff check fails
Reason : RT_Exception_Code;
begin
-- We do not need checks if we are not generating code (i.e. the full
-- expander is not active). In SPARK mode, we specifically don't want
-- the frontend to expand these checks, which are dealt with directly
-- in the formal verification backend.
if not Expander_Active then
return;
end if;
-- Here we will generate an explicit range check, so we don't want to
-- set the Do_Range check flag, since the range check is taken care of
-- by the code we will generate.
Set_Do_Range_Check (Expr, False);
if not Compile_Time_Known_Value (LB)
or not Compile_Time_Known_Value (HB)
then
declare
-- First check that the value falls in the range of the base type,
-- to prevent overflow during conversion and then perform a
-- regular range check against the (dynamic) bounds.
pragma Assert (Target_Base /= Target_Typ);
Temp : constant Entity_Id := Make_Temporary (Loc, 'T', Par);
begin
Apply_Float_Conversion_Check (Expr, Target_Base);
Set_Etype (Temp, Target_Base);
-- Note: Previously the declaration was inserted above the parent
-- of the conversion, apparently as a small optimization for the
-- subequent traversal in Insert_Actions. Unfortunately a similar
-- optimization takes place in Insert_Actions, assuming that the
-- insertion point must be above the expression that creates
-- actions. This is not correct in the presence of conditional
-- expressions, where the insertion must be in the list of actions
-- attached to the current alternative.
Insert_Action (Par,
Make_Object_Declaration (Loc,
Defining_Identifier => Temp,
Object_Definition => New_Occurrence_Of (Target_Typ, Loc),
Expression => New_Copy_Tree (Par)),
Suppress => All_Checks);
Insert_Action (Par,
Make_Raise_Constraint_Error (Loc,
Condition =>
Make_Not_In (Loc,
Left_Opnd => New_Occurrence_Of (Temp, Loc),
Right_Opnd => New_Occurrence_Of (Target_Typ, Loc)),
Reason => CE_Range_Check_Failed));
Rewrite (Par, New_Occurrence_Of (Temp, Loc));
return;
end;
end if;
-- Get the (static) bounds of the target type
Ifirst := Expr_Value (LB);
Ilast := Expr_Value (HB);
-- A simple optimization: if the expression is a universal literal,
-- we can do the comparison with the bounds and the conversion to
-- an integer type statically. The range checks are unchanged.
if Nkind (Expr) = N_Real_Literal
and then Etype (Expr) = Universal_Real
and then Is_Integer_Type (Target_Typ)
then
declare
Int_Val : constant Uint := UR_To_Uint (Realval (Expr));
begin
if Int_Val <= Ilast and then Int_Val >= Ifirst then
-- Conversion is safe
Rewrite (Parent (Expr),
Make_Integer_Literal (Loc, UI_To_Int (Int_Val)));
Analyze_And_Resolve (Parent (Expr), Target_Typ);
return;
end if;
end;
end if;
-- Check against lower bound
if Truncate and then Ifirst > 0 then
Lo := Pred (Expr_Type, UR_From_Uint (Ifirst));
Lo_OK := False;
elsif Truncate then
Lo := Succ (Expr_Type, UR_From_Uint (Ifirst - 1));
Lo_OK := True;
elsif abs (Ifirst) < Max_Bound then
Lo := UR_From_Uint (Ifirst) - Ureal_Half;
Lo_OK := (Ifirst > 0);
else
Lo := Machine_Number (Expr_Type, UR_From_Uint (Ifirst), Expr);
Lo_OK := (Lo >= UR_From_Uint (Ifirst));
end if;
-- Saturate the lower bound to that of the expression's type, because
-- we do not want to create an out-of-range value but we still need to
-- do a comparison to catch NaNs.
if Lo < Expr_Value_R (Type_Low_Bound (Expr_Type)) then
Lo := Expr_Value_R (Type_Low_Bound (Expr_Type));
Lo_OK := True;
end if;
if Lo_OK then
-- Lo_Chk := (X >= Lo)
Lo_Chk := Make_Op_Ge (Loc,
Left_Opnd => Duplicate_Subexpr_No_Checks (Expr),
Right_Opnd => Make_Real_Literal (Loc, Lo));
else
-- Lo_Chk := (X > Lo)
Lo_Chk := Make_Op_Gt (Loc,
Left_Opnd => Duplicate_Subexpr_No_Checks (Expr),
Right_Opnd => Make_Real_Literal (Loc, Lo));
end if;
-- Check against higher bound
if Truncate and then Ilast < 0 then
Hi := Succ (Expr_Type, UR_From_Uint (Ilast));
Hi_OK := False;
elsif Truncate then
Hi := Pred (Expr_Type, UR_From_Uint (Ilast + 1));
Hi_OK := True;
elsif abs (Ilast) < Max_Bound then
Hi := UR_From_Uint (Ilast) + Ureal_Half;
Hi_OK := (Ilast < 0);
else
Hi := Machine_Number (Expr_Type, UR_From_Uint (Ilast), Expr);
Hi_OK := (Hi <= UR_From_Uint (Ilast));
end if;
-- Saturate the higher bound to that of the expression's type, because
-- we do not want to create an out-of-range value but we still need to
-- do a comparison to catch NaNs.
if Hi > Expr_Value_R (Type_High_Bound (Expr_Type)) then
Hi := Expr_Value_R (Type_High_Bound (Expr_Type));
Hi_OK := True;
end if;
if Hi_OK then
-- Hi_Chk := (X <= Hi)
Hi_Chk := Make_Op_Le (Loc,
Left_Opnd => Duplicate_Subexpr_No_Checks (Expr),
Right_Opnd => Make_Real_Literal (Loc, Hi));
else
-- Hi_Chk := (X < Hi)
Hi_Chk := Make_Op_Lt (Loc,
Left_Opnd => Duplicate_Subexpr_No_Checks (Expr),
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 Expr_Value (Type_Low_Bound (Target_Base)) = Ifirst
and then Expr_Value (Type_High_Bound (Target_Base)) = Ilast
then
Reason := CE_Overflow_Check_Failed;
else
Reason := CE_Range_Check_Failed;
end if;
-- Raise CE if either conditions does not hold
Insert_Action (Expr,
Make_Raise_Constraint_Error (Loc,
Condition => Make_Op_Not (Loc, Make_And_Then (Loc, Lo_Chk, Hi_Chk)),
Reason => Reason));
end Apply_Float_Conversion_Check;
------------------------
-- Apply_Length_Check --
------------------------
procedure Apply_Length_Check
(Expr : Node_Id;
Target_Typ : Entity_Id;
Source_Typ : Entity_Id := Empty)
is
begin
Apply_Selected_Length_Checks
(Expr, Target_Typ, Source_Typ, Do_Static => False);
end Apply_Length_Check;
--------------------------------------
-- Apply_Length_Check_On_Assignment --
--------------------------------------
procedure Apply_Length_Check_On_Assignment
(Expr : Node_Id;
Target_Typ : Entity_Id;
Target : Node_Id;
Source_Typ : Entity_Id := Empty)
is
Assign : constant Node_Id := Parent (Target);
begin
-- No check is needed for the initialization of an object whose
-- nominal subtype is unconstrained.
if Is_Constr_Subt_For_U_Nominal (Target_Typ)
and then Nkind (Parent (Assign)) = N_Freeze_Entity
and then Is_Entity_Name (Target)
and then Entity (Target) = Entity (Parent (Assign))
then
return;
end if;
Apply_Selected_Length_Checks
(Expr, Target_Typ, Source_Typ, Do_Static => False);
end Apply_Length_Check_On_Assignment;
-------------------------------------
-- Apply_Parameter_Aliasing_Checks --
-------------------------------------
procedure Apply_Parameter_Aliasing_Checks
(Call : Node_Id;
Subp : Entity_Id)
is
Loc : constant Source_Ptr := Sloc (Call);
function Parameter_Passing_Mechanism_Specified
(Typ : Entity_Id)
return Boolean;
-- Returns True if parameter-passing mechanism is specified for type Typ
function May_Cause_Aliasing
(Formal_1 : Entity_Id;
Formal_2 : Entity_Id) return Boolean;
-- Determine whether two formal parameters can alias each other
-- depending on their modes.
function Original_Actual (N : Node_Id) return Node_Id;
-- The expander may replace an actual with a temporary for the sake of
-- side effect removal. The temporary may hide a potential aliasing as
-- it does not share the address of the actual. This routine attempts
-- to retrieve the original actual.
procedure Overlap_Check
(Actual_1 : Node_Id;
Actual_2 : Node_Id;
Formal_1 : Entity_Id;
Formal_2 : Entity_Id;
Check : in out Node_Id);
-- Create a check to determine whether Actual_1 overlaps with Actual_2.
-- If detailed exception messages are enabled, the check is augmented to
-- provide information about the names of the corresponding formals. See
-- the body for details. Actual_1 and Actual_2 denote the two actuals to
-- be tested. Formal_1 and Formal_2 denote the corresponding formals.
-- Check contains all and-ed simple tests generated so far or remains
-- unchanged in the case of detailed exception messaged.
-------------------------------------------
-- Parameter_Passing_Mechanism_Specified --
-------------------------------------------
function Parameter_Passing_Mechanism_Specified
(Typ : Entity_Id)
return Boolean
is
begin
return Is_Elementary_Type (Typ)
or else Is_By_Reference_Type (Typ);
end Parameter_Passing_Mechanism_Specified;
------------------------
-- May_Cause_Aliasing --
------------------------
function May_Cause_Aliasing
(Formal_1 : Entity_Id;
Formal_2 : Entity_Id) return Boolean
is
begin
-- The following combination cannot lead to aliasing
-- Formal 1 Formal 2
-- IN IN
if Ekind (Formal_1) = E_In_Parameter
and then
Ekind (Formal_2) = E_In_Parameter
then
return False;
-- The following combinations may lead to aliasing
-- Formal 1 Formal 2
-- IN OUT
-- IN IN OUT
-- OUT IN
-- OUT IN OUT
-- OUT OUT
else
return True;
end if;
end May_Cause_Aliasing;
---------------------
-- Original_Actual --
---------------------
function Original_Actual (N : Node_Id) return Node_Id is
begin
if Nkind (N) = N_Type_Conversion then
return Expression (N);
-- The expander created a temporary to capture the result of a type
-- conversion where the expression is the real actual.
elsif Nkind (N) = N_Identifier
and then Present (Original_Node (N))
and then Nkind (Original_Node (N)) = N_Type_Conversion
then
return Expression (Original_Node (N));
end if;
return N;
end Original_Actual;
-------------------
-- Overlap_Check --
-------------------
procedure Overlap_Check
(Actual_1 : Node_Id;
Actual_2 : Node_Id;
Formal_1 : Entity_Id;
Formal_2 : Entity_Id;
Check : in out Node_Id)
is
Cond : Node_Id;
Formal_Name : Bounded_String;
begin
-- Generate:
-- Actual_1'Overlaps_Storage (Actual_2)
Cond :=
Make_Attribute_Reference (Loc,
Prefix => New_Copy_Tree (Original_Actual (Actual_1)),
Attribute_Name => Name_Overlaps_Storage,
Expressions =>
New_List (New_Copy_Tree (Original_Actual (Actual_2))));
-- Generate the following check when detailed exception messages are
-- enabled:
-- if Actual_1'Overlaps_Storage (Actual_2) then
-- raise Program_Error with <detailed message>;
-- end if;
if Exception_Extra_Info then
Start_String;
-- Do not generate location information for internal calls
if Comes_From_Source (Call) then
Store_String_Chars (Build_Location_String (Loc));
Store_String_Char (' ');
end if;
Store_String_Chars ("aliased parameters, actuals for """);
Append (Formal_Name, Chars (Formal_1));
Adjust_Name_Case (Formal_Name, Sloc (Formal_1));
Store_String_Chars (To_String (Formal_Name));
Store_String_Chars (""" and """);
Formal_Name.Length := 0;
Append (Formal_Name, Chars (Formal_2));
Adjust_Name_Case (Formal_Name, Sloc (Formal_2));
Store_String_Chars (To_String (Formal_Name));
Store_String_Chars (""" overlap");
Insert_Action (Call,
Make_If_Statement (Loc,
Condition => Cond,
Then_Statements => New_List (
Make_Raise_Statement (Loc,
Name =>
New_Occurrence_Of (Standard_Program_Error, Loc),
Expression => Make_String_Literal (Loc, End_String)))));
-- Create a sequence of overlapping checks by and-ing them all
-- together.
else
if No (Check) then
Check := Cond;
else
Check :=
Make_And_Then (Loc,
Left_Opnd => Check,
Right_Opnd => Cond);
end if;
end if;
end Overlap_Check;
-- Local variables
Actual_1 : Node_Id;
Actual_2 : Node_Id;
Check : Node_Id;
Formal_1 : Entity_Id;
Formal_2 : Entity_Id;
Orig_Act_1 : Node_Id;
Orig_Act_2 : Node_Id;
-- Start of processing for Apply_Parameter_Aliasing_Checks
begin
Check := Empty;
Actual_1 := First_Actual (Call);
Formal_1 := First_Formal (Subp);
while Present (Actual_1) and then Present (Formal_1) loop
Orig_Act_1 := Original_Actual (Actual_1);
if Is_Name_Reference (Orig_Act_1) then
Actual_2 := Next_Actual (Actual_1);
Formal_2 := Next_Formal (Formal_1);
while Present (Actual_2) and then Present (Formal_2) loop
Orig_Act_2 := Original_Actual (Actual_2);
-- Generate the check only when the mode of the two formals may
-- lead to aliasing.
if Is_Name_Reference (Orig_Act_2)
and then May_Cause_Aliasing (Formal_1, Formal_2)
then
-- The aliasing check only applies when some of the formals
-- have their passing mechanism unspecified; RM 6.2 (12/3).
if Parameter_Passing_Mechanism_Specified (Etype (Orig_Act_1))
and then
Parameter_Passing_Mechanism_Specified (Etype (Orig_Act_2))
then
null;
else
Remove_Side_Effects (Actual_1);
Remove_Side_Effects (Actual_2);
Overlap_Check
(Actual_1 => Actual_1,
Actual_2 => Actual_2,
Formal_1 => Formal_1,
Formal_2 => Formal_2,
Check => Check);
end if;
end if;
Next_Actual (Actual_2);
Next_Formal (Formal_2);
end loop;
end if;
Next_Actual (Actual_1);
Next_Formal (Formal_1);
end loop;
-- Place a simple check right before the call
if Present (Check) and then not Exception_Extra_Info then
Insert_Action (Call,
Make_Raise_Program_Error (Loc,
Condition => Check,
Reason => PE_Aliased_Parameters));
end if;
end Apply_Parameter_Aliasing_Checks;
-------------------------------------
-- Apply_Parameter_Validity_Checks --
-------------------------------------
procedure Apply_Parameter_Validity_Checks (Subp : Entity_Id) is
Subp_Decl : Node_Id;
procedure Add_Validity_Check
(Formal : Entity_Id;
Prag_Nam : Name_Id;
For_Result : Boolean := False);
-- Add a single 'Valid[_Scalars] check which verifies the initialization
-- of Formal. Prag_Nam denotes the pre or post condition pragma name.
-- Set flag For_Result when to verify the result of a function.
------------------------
-- Add_Validity_Check --
------------------------
procedure Add_Validity_Check
(Formal : Entity_Id;
Prag_Nam : Name_Id;
For_Result : Boolean := False)
is
procedure Build_Pre_Post_Condition (Expr : Node_Id);
-- Create a pre/postcondition pragma that tests expression Expr
------------------------------
-- Build_Pre_Post_Condition --
------------------------------
procedure Build_Pre_Post_Condition (Expr : Node_Id) is
Loc : constant Source_Ptr := Sloc (Subp);
Decls : List_Id;
Prag : Node_Id;
begin
Prag :=
Make_Pragma (Loc,
Chars => Prag_Nam,
Pragma_Argument_Associations => New_List (
Make_Pragma_Argument_Association (Loc,
Chars => Name_Check,
Expression => Expr)));
-- Add a message unless exception messages are suppressed
if not Exception_Locations_Suppressed then
Append_To (Pragma_Argument_Associations (Prag),
Make_Pragma_Argument_Association (Loc,
Chars => Name_Message,
Expression =>
Make_String_Literal (Loc,
Strval => "failed "
& Get_Name_String (Prag_Nam)
& " from "
& Build_Location_String (Loc))));
end if;
-- Insert the pragma in the tree
if Nkind (Parent (Subp_Decl)) = N_Compilation_Unit then
Add_Global_Declaration (Prag);
Analyze (Prag);
-- PPC pragmas associated with subprogram bodies must be inserted
-- in the declarative part of the body.
elsif Nkind (Subp_Decl) = N_Subprogram_Body then
Decls := Declarations (Subp_Decl);
if No (Decls) then
Decls := New_List;
Set_Declarations (Subp_Decl, Decls);
end if;
Prepend_To (Decls, Prag);
Analyze (Prag);
-- For subprogram declarations insert the PPC pragma right after
-- the declarative node.
else
Insert_After_And_Analyze (Subp_Decl, Prag);
end if;
end Build_Pre_Post_Condition;
-- Local variables
Loc : constant Source_Ptr := Sloc (Subp);
Typ : constant Entity_Id := Etype (Formal);
Check : Node_Id;
Nam : Name_Id;
-- Start of processing for Add_Validity_Check
begin
-- For scalars, generate 'Valid test
if Is_Scalar_Type (Typ) then
Nam := Name_Valid;
-- For any non-scalar with scalar parts, generate 'Valid_Scalars test
elsif Scalar_Part_Present (Typ) then
Nam := Name_Valid_Scalars;
-- No test needed for other cases (no scalars to test)
else
return;
end if;
-- Step 1: Create the expression to verify the validity of the
-- context.
Check := New_Occurrence_Of (Formal, Loc);
-- When processing a function result, use 'Result. Generate
-- Context'Result
if For_Result then
Check :=
Make_Attribute_Reference (Loc,
Prefix => Check,
Attribute_Name => Name_Result);
end if;
-- Generate:
-- Context['Result]'Valid[_Scalars]
Check :=
Make_Attribute_Reference (Loc,
Prefix => Check,
Attribute_Name => Nam);
-- Step 2: Create a pre or post condition pragma
Build_Pre_Post_Condition (Check);
end Add_Validity_Check;
-- Local variables
Formal : Entity_Id;
Subp_Spec : Node_Id;
-- Start of processing for Apply_Parameter_Validity_Checks
begin
-- Extract the subprogram specification and declaration nodes
Subp_Spec := Parent (Subp);
if No (Subp_Spec) then
return;
end if;
if Nkind (Subp_Spec) = N_Defining_Program_Unit_Name then
Subp_Spec := Parent (Subp_Spec);
end if;
Subp_Decl := Parent (Subp_Spec);
if not Comes_From_Source (Subp)
-- Do not process formal subprograms because the corresponding actual
-- will receive the proper checks when the instance is analyzed.
or else Is_Formal_Subprogram (Subp)
-- Do not process imported subprograms since pre and postconditions
-- are never verified on routines coming from a different language.
or else Is_Imported (Subp)
or else Is_Intrinsic_Subprogram (Subp)
-- The PPC pragmas generated by this routine do not correspond to
-- source aspects, therefore they cannot be applied to abstract
-- subprograms.
or else Nkind (Subp_Decl) = N_Abstract_Subprogram_Declaration
-- Do not consider subprogram renaminds because the renamed entity
-- already has the proper PPC pragmas.
or else Nkind (Subp_Decl) = N_Subprogram_Renaming_Declaration
-- Do not process null procedures because there is no benefit of
-- adding the checks to a no action routine.
or else (Nkind (Subp_Spec) = N_Procedure_Specification
and then Null_Present (Subp_Spec))
then
return;
end if;
-- Inspect all the formals applying aliasing and scalar initialization
-- checks where applicable.
Formal := First_Formal (Subp);
while Present (Formal) loop
-- Generate the following scalar initialization checks for each
-- formal parameter:
-- mode IN - Pre => Formal'Valid[_Scalars]
-- mode IN OUT - Pre, Post => Formal'Valid[_Scalars]
-- mode OUT - Post => Formal'Valid[_Scalars]
if Ekind (Formal) in E_In_Parameter | E_In_Out_Parameter then
Add_Validity_Check (Formal, Name_Precondition, False);
end if;
if Ekind (Formal) in E_In_Out_Parameter | E_Out_Parameter then
Add_Validity_Check (Formal, Name_Postcondition, False);
end if;
Next_Formal (Formal);
end loop;
-- Generate following scalar initialization check for function result:
-- Post => Subp'Result'Valid[_Scalars]
if Ekind (Subp) = E_Function then
Add_Validity_Check (Subp, Name_Postcondition, True);
end if;
end Apply_Parameter_Validity_Checks;
---------------------------
-- Apply_Predicate_Check --
---------------------------
procedure Apply_Predicate_Check
(N : Node_Id;
Typ : Entity_Id;
Fun : Entity_Id := Empty)
is
Par : Node_Id;
S : Entity_Id;
Check_Disabled : constant Boolean := (not Predicate_Enabled (Typ))
or else not Predicate_Check_In_Scope (N);
begin
S := Current_Scope;
while Present (S) and then not Is_Subprogram (S) loop
S := Scope (S);
end loop;
-- If the check appears within the predicate function itself, it means
-- that the user specified a check whose formal is the predicated
-- subtype itself, rather than some covering type. This is likely to be
-- a common error, and thus deserves a warning. We want to emit this
-- warning even if predicate checking is disabled (in which case the
-- warning is still useful even if it is not strictly accurate).
if Present (S) and then S = Predicate_Function (Typ) then
Error_Msg_NE
("predicate check includes a call to& that requires a "
& "predicate check??", Parent (N), Fun);
Error_Msg_N
("\this will result in infinite recursion??", Parent (N));
if Is_First_Subtype (Typ) then
Error_Msg_NE
("\use an explicit subtype of& to carry the predicate",
Parent (N), Typ);
end if;
if not Check_Disabled then
Insert_Action (N,
Make_Raise_Storage_Error (Sloc (N),
Reason => SE_Infinite_Recursion));
return;
end if;
end if;
if Check_Disabled then
return;
end if;
-- Normal case of predicate active
-- If the expression is an IN parameter, the predicate will have
-- been applied at the point of call. An additional check would
-- be redundant, or will lead to out-of-scope references if the
-- call appears within an aspect specification for a precondition.
-- However, if the reference is within the body of the subprogram
-- that declares the formal, the predicate can safely be applied,
-- which may be necessary for a nested call whose formal has a
-- different predicate.
if Is_Entity_Name (N)
and then Ekind (Entity (N)) = E_In_Parameter
then
declare
In_Body : Boolean := False;
P : Node_Id := Parent (N);
begin
while Present (P) loop
if Nkind (P) = N_Subprogram_Body
and then
((Present (Corresponding_Spec (P))
and then
Corresponding_Spec (P) = Scope (Entity (N)))
or else
Defining_Unit_Name (Specification (P)) =
Scope (Entity (N)))
then
In_Body := True;
exit;
end if;
P := Parent (P);
end loop;
if not In_Body then
return;
end if;
end;
end if;
-- If the type has a static predicate and the expression is known
-- at compile time, see if the expression satisfies the predicate.
Check_Expression_Against_Static_Predicate (N, Typ);
if not Expander_Active then
return;
end if;
Par := Parent (N);
if Nkind (Par) = N_Qualified_Expression then
Par := Parent (Par);
end if;
-- For an entity of the type, generate a call to the predicate
-- function, unless its type is an actual subtype, which is not
-- visible outside of the enclosing subprogram.
if Is_Entity_Name (N)
and then not Is_Actual_Subtype (Typ)
then
Insert_Action (N,
Make_Predicate_Check
(Typ, New_Occurrence_Of (Entity (N), Sloc (N))));
return;
elsif Nkind (N) in N_Aggregate | N_Extension_Aggregate then
-- If the expression is an aggregate in an assignment, apply the
-- check to the LHS after the assignment, rather than create a
-- redundant temporary. This is only necessary in rare cases
-- of array types (including strings) initialized with an
-- aggregate with an "others" clause, either coming from source
-- or generated by an Initialize_Scalars pragma.
if Nkind (Par) = N_Assignment_Statement then
Insert_Action_After (Par,
Make_Predicate_Check
(Typ, Duplicate_Subexpr (Name (Par))));
return;
-- Similarly, if the expression is an aggregate in an object
-- declaration, apply it to the object after the declaration.
-- This is only necessary in rare cases of tagged extensions
-- initialized with an aggregate with an "others => <>" clause.
elsif Nkind (Par) = N_Object_Declaration then
Insert_Action_After (Par,
Make_Predicate_Check (Typ,
New_Occurrence_Of (Defining_Identifier (Par), Sloc (N))));
return;
end if;
end if;
-- If the expression is not an entity it may have side effects,
-- and the following call will create an object declaration for
-- it. We disable checks during its analysis, to prevent an
-- infinite recursion.
Insert_Action (N,
Make_Predicate_Check
(Typ, Duplicate_Subexpr (N)), Suppress => All_Checks);
end Apply_Predicate_Check;
-----------------------
-- Apply_Range_Check --
-----------------------
procedure Apply_Range_Check
(Expr : Node_Id;
Target_Typ : Entity_Id;
Source_Typ : Entity_Id := Empty;
Insert_Node : Node_Id := Empty)
is
Checks_On : constant Boolean :=
not Index_Checks_Suppressed (Target_Typ)
or else
not Range_Checks_Suppressed (Target_Typ);
Loc : constant Source_Ptr := Sloc (Expr);
Cond : Node_Id;
R_Cno : Node_Id;
R_Result : Check_Result;
begin
-- Only apply checks when generating code. In GNATprove mode, we do not
-- apply the checks, but we still call Selected_Range_Checks to possibly
-- issue errors on SPARK code when a run-time error can be detected at
-- compile time.
if not GNATprove_Mode then
if not Expander_Active or not Checks_On then
return;
end if;
end if;
R_Result :=
Selected_Range_Checks (Expr, Target_Typ, Source_Typ, Insert_Node);
if GNATprove_Mode then
return;
end if;
for J in 1 .. 2 loop
R_Cno := R_Result (J);
exit when No (R_Cno);
-- The range check requires runtime evaluation. Depending on what its
-- triggering condition is, the check may be converted into a compile
-- time constraint check.
if Nkind (R_Cno) = N_Raise_Constraint_Error
and then Present (Condition (R_Cno))
then
Cond := Condition (R_Cno);
-- Insert the range check before the related context. Note that
-- this action analyses the triggering condition.
if Present (Insert_Node) then
Insert_Action (Insert_Node, R_Cno);
else
Insert_Action (Expr, R_Cno);
end if;
-- The triggering condition evaluates to True, the range check
-- can be converted into a compile time constraint check.
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.
if Nkind (Expr) = N_Range then
Apply_Compile_Time_Constraint_Error
(Low_Bound (Expr),
"static range out of bounds of}??",
CE_Range_Check_Failed,
Ent => Target_Typ,
Typ => Target_Typ);
Set_Raises_Constraint_Error (Expr);
else
Apply_Compile_Time_Constraint_Error
(Expr,
"static value out of range of}??",
CE_Range_Check_Failed,
Ent => Target_Typ,
Typ => Target_Typ);
end if;
end if;
-- The range check raises Constraint_Error explicitly
elsif Present (Insert_Node) then
R_Cno :=
Make_Raise_Constraint_Error (Sloc (Insert_Node),
Reason => CE_Range_Check_Failed);
Insert_Action (Insert_Node, R_Cno);
else
Install_Static_Check (R_Cno, Loc);
end if;
end loop;
end Apply_Range_Check;
------------------------------
-- Apply_Scalar_Range_Check --
------------------------------
-- Note that Apply_Scalar_Range_Check never turns the Do_Range_Check flag
-- off if it is already set on.
procedure Apply_Scalar_Range_Check
(Expr : Node_Id;
Target_Typ : Entity_Id;
Source_Typ : Entity_Id := Empty;
Fixed_Int : Boolean := False)
is
Parnt : constant Node_Id := Parent (Expr);
S_Typ : Entity_Id;
Arr : Node_Id := Empty; -- initialize to prevent warning
Arr_Typ : Entity_Id := Empty; -- initialize to prevent warning
Is_Subscr_Ref : Boolean;
-- Set true if Expr is a subscript
Is_Unconstrained_Subscr_Ref : Boolean;
-- Set true if Expr is a subscript of an unconstrained array. In this
-- case we do not attempt to do an analysis of the value against the
-- 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.
procedure Bad_Value (Warn : Boolean := False);
-- Procedure called if value is determined to be out of range. Warn is
-- True to force a warning instead of an error, even when SPARK_Mode is
-- On.
---------------
-- Bad_Value --
---------------
procedure Bad_Value (Warn : Boolean := False) is
begin
Apply_Compile_Time_Constraint_Error
(Expr, "value not in range of}??", CE_Range_Check_Failed,
Ent => Target_Typ,
Typ => Target_Typ,
Warn => Warn);
end Bad_Value;
-- Start of processing for Apply_Scalar_Range_Check
begin
-- Return if check obviously not needed
if
-- Not needed inside generic
Inside_A_Generic
-- Not needed if previous error
or else Target_Typ = Any_Type
or else Nkind (Expr) = N_Error
-- Not needed for non-scalar type
or else not Is_Scalar_Type (Target_Typ)
-- Not needed if we know node raises CE already
or else Raises_Constraint_Error (Expr)
then
return;
end if;
-- Now, see if checks are suppressed
Is_Subscr_Ref :=
Is_List_Member (Expr) and then Nkind (Parnt) = N_Indexed_Component;
if Is_Subscr_Ref then
Arr := Prefix (Parnt);
Arr_Typ := Get_Actual_Subtype_If_Available (Arr);
if Is_Access_Type (Arr_Typ) then
Arr_Typ := Designated_Type (Arr_Typ);
end if;
end if;
if not Do_Range_Check (Expr) then
-- Subscript reference. Check for Index_Checks suppressed
if Is_Subscr_Ref then
-- Check array type and its base type
if Index_Checks_Suppressed (Arr_Typ)
or else Index_Checks_Suppressed (Base_Type (Arr_Typ))
then
return;
-- Check array itself if it is an entity name
elsif Is_Entity_Name (Arr)
and then Index_Checks_Suppressed (Entity (Arr))
then
return;
-- Check expression itself if it is an entity name
elsif Is_Entity_Name (Expr)
and then Index_Checks_Suppressed (Entity (Expr))
then
return;
end if;
-- All other cases, check for Range_Checks suppressed
else
-- Check target type and its base type
if Range_Checks_Suppressed (Target_Typ)
or else Range_Checks_Suppressed (Base_Type (Target_Typ))
then
return;
-- Check expression itself if it is an entity name
elsif Is_Entity_Name (Expr)
and then Range_Checks_Suppressed (Entity (Expr))
then
return;
-- 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))
and then Range_Checks_Suppressed (Entity (Name (Parnt)))
then
return;
end if;
end if;
end if;
-- Do not set range checks if they are killed
if Nkind (Expr) = N_Unchecked_Type_Conversion
and then Kill_Range_Check (Expr)
then
return;
end if;
-- Do not set range checks for any values from System.Scalar_Values
-- since the whole idea of such values is to avoid checking them.
if Is_Entity_Name (Expr)
and then Is_RTU (Scope (Entity (Expr)), System_Scalar_Values)
then
return;
end if;
-- Now see if we need a check
if No (Source_Typ) then
S_Typ := Etype (Expr);
else
S_Typ := Source_Typ;
end if;
if not Is_Scalar_Type (S_Typ) or else S_Typ = Any_Type then
return;
end if;
Is_Unconstrained_Subscr_Ref :=
Is_Subscr_Ref and then not Is_Constrained (Arr_Typ);
-- Special checks for floating-point type
if Is_Floating_Point_Type (S_Typ) then
-- 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 the expression is a literal and the bounds of the type are
-- static constants it may be possible to optimize the check.
if Has_Infinities (S_Typ)
and then not Has_Infinities (Target_Typ)
then
-- If the expression is a literal and the bounds of the type are
-- static constants it may be possible to optimize the check.
if Nkind (Expr) = N_Real_Literal then
declare
Tlo : constant Node_Id := Type_Low_Bound (Target_Typ);
Thi : constant Node_Id := Type_High_Bound (Target_Typ);
begin
if Compile_Time_Known_Value (Tlo)
and then Compile_Time_Known_Value (Thi)
and then Expr_Value_R (Expr) >= Expr_Value_R (Tlo)
and then Expr_Value_R (Expr) <= Expr_Value_R (Thi)
then
return;
else
Enable_Range_Check (Expr);
end if;
end;
else
Enable_Range_Check (Expr);
end if;
end if;
end if;
-- Return if we know expression is definitely in the range of the target
-- type as determined by Determine_Range_To_Discrete. Right now we only
-- do this for discrete target types, i.e. neither for fixed-point nor
-- for floating-point types. But 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.
-- We could sharpen this test to be out parameters only ???
if Is_Discrete_Type (Target_Typ)
and then not Is_Unconstrained_Subscr_Ref
and then No (Source_Typ)
then
declare
Thi : constant Node_Id := Type_High_Bound (Target_Typ);
Tlo : constant Node_Id := Type_Low_Bound (Target_Typ);
begin
if Compile_Time_Known_Value (Tlo)
and then Compile_Time_Known_Value (Thi)
then
declare
OK : Boolean := False; -- initialize to prevent warning
Hiv : constant Uint := Expr_Value (Thi);
Lov : constant Uint := Expr_Value (Tlo);
Hi : Uint := No_Uint;
Lo : Uint := No_Uint;
begin
-- If range is null, we for sure have a constraint error (we
-- don't even need to look at the value involved, since all
-- possible values will raise CE).
if Lov > Hiv then
-- When SPARK_Mode is On, force a warning instead of
-- an error in that case, as this likely corresponds
-- to deactivated code.
Bad_Value (Warn => SPARK_Mode = On);
return;
end if;
-- Otherwise determine range of value
Determine_Range_To_Discrete
(Expr, OK, Lo, Hi, Fixed_Int, Assume_Valid => True);
if OK then
-- If definitely in range, all OK
if Lo >= Lov and then Hi <= Hiv then
return;
-- If definitely not in range, warn
elsif Lov > Hi or else Hiv < Lo then
-- Ignore out of range values for System.Priority in
-- CodePeer mode since the actual target compiler may
-- provide a wider range.
if not CodePeer_Mode
or else not Is_RTE (Target_Typ, RE_Priority)
then
Bad_Value;
end if;
return;
-- Otherwise we don't know
else
null;
end if;
end if;
end;
end if;
end;
end if;
Int_Real :=
Is_Floating_Point_Type (S_Typ)
or else (Is_Fixed_Point_Type (S_Typ) and then not Fixed_Int);
-- Check if we can determine at compile time whether Expr is in the
-- range of the target type. Note that if S_Typ is within the bounds
-- of Target_Typ then this must be the case. This check is meaningful
-- only if this is not a conversion between integer and real types,
-- unless for a fixed-point type if Fixed_Int is set.
if not Is_Unconstrained_Subscr_Ref
and then (Is_Discrete_Type (S_Typ) = Is_Discrete_Type (Target_Typ)
or else (Fixed_Int and then Is_Discrete_Type (Target_Typ)))
and then
(In_Subrange_Of (S_Typ, Target_Typ, Fixed_Int)
-- Also check if the expression itself is in the range of the
-- target type if it is a known at compile time value. We skip
-- this test if S_Typ is set since for OUT and IN OUT parameters
-- the Expr itself is not relevant to the checking.
or else
(No (Source_Typ)
and then Is_In_Range (Expr, Target_Typ,
Assume_Valid => True,
Fixed_Int => Fixed_Int,
Int_Real => Int_Real)))
then
return;
elsif Is_Out_Of_Range (Expr, Target_Typ,
Assume_Valid => True,
Fixed_Int => Fixed_Int,
Int_Real => Int_Real)
then
Bad_Value;
return;
-- Floating-point case
-- 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, except when
-- Check_Float_Overflow is set.
elsif Is_Floating_Point_Type (S_Typ) then
if Is_Constrained (S_Typ) or else Check_Float_Overflow then
Enable_Range_Check (Expr);
end if;
-- For all other cases we enable a range check unconditionally
else
Enable_Range_Check (Expr);
return;
end if;
end Apply_Scalar_Range_Check;
----------------------------------
-- Apply_Selected_Length_Checks --
----------------------------------
procedure Apply_Selected_Length_Checks
(Expr : Node_Id;
Target_Typ : Entity_Id;
Source_Typ : Entity_Id;
Do_Static : Boolean)
is
Checks_On : constant Boolean :=
not Index_Checks_Suppressed (Target_Typ)
or else
not Length_Checks_Suppressed (Target_Typ);
Loc : constant Source_Ptr := Sloc (Expr);
Cond : Node_Id;
R_Cno : Node_Id;
R_Result : Check_Result;
begin
-- Only apply checks when generating code
-- Note: this means that we lose some useful warnings if the expander
-- is not active.
if not Expander_Active then
return;
end if;
R_Result :=
Selected_Length_Checks (Expr, Target_Typ, Source_Typ, Empty);
for J in 1 .. 2 loop
R_Cno := R_Result (J);
exit when No (R_Cno);
-- A length check may mention an Itype which is attached to a
-- subsequent node. At the top level in a package this can cause
-- an order-of-elaboration problem, so we make sure that the itype
-- is referenced now.
if Ekind (Current_Scope) = E_Package
and then Is_Compilation_Unit (Current_Scope)
then
Ensure_Defined (Target_Typ, Expr);
if Present (Source_Typ) then
Ensure_Defined (Source_Typ, Expr);
elsif Is_Itype (Etype (Expr)) then
Ensure_Defined (Etype (Expr), Expr);
end if;
end if;
if Nkind (R_Cno) = N_Raise_Constraint_Error
and then Present (Condition (R_Cno))
then
Cond := Condition (R_Cno);
-- Case where node does not now have a dynamic check
if not Has_Dynamic_Length_Check (Expr) then
-- If checks are on, just insert the check
if Checks_On then
Insert_Action (Expr, R_Cno);
if not Do_Static then
Set_Has_Dynamic_Length_Check (Expr);
end if;
-- If checks are off, then analyze the length check after
-- temporarily attaching it to the tree in case the relevant
-- condition can be evaluated at compile time. We still want a
-- compile time warning in this case.
else
Set_Parent (R_Cno, Expr);
Analyze (R_Cno);
end if;
end if;
-- Output a warning if the condition is known to be True
if Is_Entity_Name (Cond)
and then Entity (Cond) = Standard_True
then
Apply_Compile_Time_Constraint_Error
(Expr, "wrong length for array of}??",
CE_Length_Check_Failed,
Ent => Target_Typ,
Typ => Target_Typ);
-- If we were only doing a static check, or if checks are not
-- on, then we want to delete the check, since it is not needed.
-- We do this by replacing the if statement by a null statement
elsif Do_Static or else not Checks_On then
Remove_Warning_Messages (R_Cno);
Rewrite (R_Cno, Make_Null_Statement (Loc));
end if;
else
Install_Static_Check (R_Cno, Loc);
end if;
end loop;
end Apply_Selected_Length_Checks;
-------------------------------
-- Apply_Static_Length_Check --
-------------------------------
procedure Apply_Static_Length_Check
(Expr : Node_Id;
Target_Typ : Entity_Id;
Source_Typ : Entity_Id := Empty)
is
begin
Apply_Selected_Length_Checks
(Expr, Target_Typ, Source_Typ, Do_Static => True);
end Apply_Static_Length_Check;
-------------------------------------
-- Apply_Subscript_Validity_Checks --
-------------------------------------
procedure Apply_Subscript_Validity_Checks
(Expr : Node_Id;
No_Check_Needed : Dimension_Set := Empty_Dimension_Set) is
Sub : Node_Id;
Dimension : Pos := 1;
begin
pragma Assert (Nkind (Expr) = N_Indexed_Component);
-- Loop through subscripts
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.
if (No_Check_Needed = Empty_Dimension_Set)
or else not No_Check_Needed.Elements (Dimension)
then
Ensure_Valid (Sub, Holes_OK => True);
end if;
-- Move to next subscript
Next (Sub);
Dimension := Dimension + 1;
end loop;
end Apply_Subscript_Validity_Checks;
----------------------------------
-- Apply_Type_Conversion_Checks --
----------------------------------
procedure Apply_Type_Conversion_Checks (N : Node_Id) is
Target_Type : constant Entity_Id := Etype (N);
Target_Base : constant Entity_Id := Base_Type (Target_Type);
Expr : constant Node_Id := Expression (N);
Expr_Type : constant Entity_Id := Underlying_Type (Etype (Expr));
-- Note: if Etype (Expr) is a private type without discriminants, its
-- full view might have discriminants with defaults, so we need the
-- full view here to retrieve the constraints.
procedure Make_Discriminant_Constraint_Check
(Target_Type : Entity_Id;
Expr_Type : Entity_Id);
-- Generate a discriminant check based on the target type and expression
-- type for Expr.
----------------------------------------
-- Make_Discriminant_Constraint_Check --
----------------------------------------
procedure Make_Discriminant_Constraint_Check
(Target_Type : Entity_Id;
Expr_Type : Entity_Id)
is
Loc : constant Source_Ptr := Sloc (N);
Cond : Node_Id;
Constraint : Elmt_Id;
Discr_Value : Node_Id;
Discr : Entity_Id;
New_Constraints : constant Elist_Id := New_Elmt_List;
Old_Constraints : constant Elist_Id :=
Discriminant_Constraint (Expr_Type);
begin
-- Build an actual discriminant constraint list using the stored
-- constraint, to verify that the expression of the parent type
-- satisfies the constraints imposed by the (unconstrained) derived
-- type. This applies to value conversions, not to view conversions
-- of tagged types.
Constraint := First_Elmt (Stored_Constraint (Target_Type));
while Present (Constraint) loop
Discr_Value := Node (Constraint);
if Is_Entity_Name (Discr_Value)
and then Ekind (Entity (Discr_Value)) = E_Discriminant
then
Discr := Corresponding_Discriminant (Entity (Discr_Value));
if Present (Discr)
and then Scope (Discr) = Base_Type (Expr_Type)
then
-- Parent is constrained by new discriminant. Obtain
-- Value of original discriminant in expression. If the
-- new discriminant has been used to constrain more than
-- one of the stored discriminants, this will provide the
-- required consistency check.
Append_Elmt
(Make_Selected_Component (Loc,
Prefix =>
Duplicate_Subexpr_No_Checks
(Expr, Name_Req => True),
Selector_Name =>
Make_Identifier (Loc, Chars (Discr))),
New_Constraints);
else
-- Discriminant of more remote ancestor ???
return;
end if;
-- Derived type definition has an explicit value for this
-- stored discriminant.
else
Append_Elmt
(Duplicate_Subexpr_No_Checks (Discr_Value),
New_Constraints);
end if;
Next_Elmt (Constraint);
end loop;
-- Use the unconstrained expression type to retrieve the
-- discriminants of the parent, and apply momentarily the
-- discriminant constraint synthesized above.
-- Note: We use Expr_Type instead of Target_Type since the number of
-- actual discriminants may be different due to the presence of
-- stored discriminants and cause Build_Discriminant_Checks to fail.
Set_Discriminant_Constraint (Expr_Type, New_Constraints);
Cond := Build_Discriminant_Checks (Expr, Expr_Type);
Set_Discriminant_Constraint (Expr_Type, Old_Constraints);
-- Conversion between access types requires that we check for null
-- before checking discriminants.
if Is_Access_Type (Etype (Expr)) then
Cond := Make_And_Then (Loc,
Left_Opnd =>
Make_Op_Ne (Loc,
Left_Opnd =>
Duplicate_Subexpr_No_Checks
(Expr, Name_Req => True),
Right_Opnd => Make_Null (Loc)),
Right_Opnd => Cond);
end if;
Insert_Action (N,
Make_Raise_Constraint_Error (Loc,
Condition => Cond,
Reason => CE_Discriminant_Check_Failed));
end Make_Discriminant_Constraint_Check;
-- Start of processing for Apply_Type_Conversion_Checks
begin
if Inside_A_Generic then
return;
-- Skip these checks if serious errors detected, there are some nasty
-- situations of incomplete trees that blow things up.
elsif Serious_Errors_Detected > 0 then
return;
-- Never generate discriminant checks for Unchecked_Union types
elsif Present (Expr_Type)
and then Is_Unchecked_Union (Expr_Type)
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.
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.
Float_To_Int : constant Boolean :=
Is_Floating_Point_Type (Expr_Type)
and then Is_Integer_Type (Target_Type);
begin
if not Overflow_Checks_Suppressed (Target_Base)
and then not Overflow_Checks_Suppressed (Target_Type)
and then not
In_Subrange_Of (Expr_Type, Target_Base, Fixed_Int => Conv_OK)
and then not Float_To_Int
then
-- A small optimization: the attribute 'Pos applied to an
-- enumeration type has a known range, even though its type is
-- Universal_Integer. So in numeric conversions it is usually
-- within range of the target integer type. Use the static
-- bounds of the base types to check. Disable this optimization
-- in case of a generic formal discrete type, because we don't
-- necessarily know the upper bound yet.
if Nkind (Expr) = N_Attribute_Reference
and then Attribute_Name (Expr) = Name_Pos
and then Is_Enumeration_Type (Etype (Prefix (Expr)))
and then not Is_Generic_Type (Etype (Prefix (Expr)))
and then Is_Integer_Type (Target_Type)
then
declare
Enum_T : constant Entity_Id :=
Root_Type (Etype (Prefix (Expr)));
Int_T : constant Entity_Id := Base_Type (Target_Type);
Last_I : constant Uint :=
Intval (High_Bound (Scalar_Range (Int_T)));
Last_E : Uint;
begin
-- Character types have no explicit literals, so we use
-- the known number of characters in the type.
if Root_Type (Enum_T) = Standard_Character then
Last_E := UI_From_Int (255);
elsif Enum_T = Standard_Wide_Character
or else Enum_T = Standard_Wide_Wide_Character
then
Last_E := UI_From_Int (65535);
else
Last_E :=
Enumeration_Pos
(Entity (High_Bound (Scalar_Range (Enum_T))));
end if;
if Last_E > Last_I then
Activate_Overflow_Check (N);
end if;
end;
else
Activate_Overflow_Check (N);
end if;
end if;
if not Range_Checks_Suppressed (Target_Type)
and then not Range_Checks_Suppressed (Expr_Type)
then
if Float_To_Int
and then not GNATprove_Mode
then
Apply_Float_Conversion_Check (Expr, Target_Type);
else
-- Raw conversions involving fixed-point types are expanded
-- separately and do not need a Range_Check flag yet, except
-- in GNATprove_Mode where this expansion is not performed.
-- This does not apply to conversion where fixed-point types
-- are treated as integers, which are precisely generated by
-- this expansion.
if GNATprove_Mode
or else Conv_OK
or else (not Is_Fixed_Point_Type (Expr_Type)
and then not Is_Fixed_Point_Type (Target_Type))
then
Apply_Scalar_Range_Check
(Expr, Target_Type, Fixed_Int => Conv_OK);
else
Set_Do_Range_Check (Expr, False);
end if;
-- If the target type has predicates, we need to indicate
-- the need for a check, even if Determine_Range finds that
-- the value is within bounds. This may be the case e.g for
-- a division with a constant denominator.
if Has_Predicates (Target_Type) then
Enable_Range_Check (Expr);
end if;
end if;
end if;
end;
-- Generate discriminant constraint checks for access types on the
-- designated target type's stored constraints.
-- Do we need to generate subtype predicate checks here as well ???
elsif Comes_From_Source (N)
and then Ekind (Target_Type) = E_General_Access_Type
-- Check that both of the designated types have known discriminants,
-- and that such checks on the target type are not suppressed.
and then Has_Discriminants (Directly_Designated_Type (Target_Type))
and then Has_Discriminants (Directly_Designated_Type (Expr_Type))
and then not Discriminant_Checks_Suppressed
(Directly_Designated_Type (Target_Type))
-- Verify the designated type of the target has stored constraints
and then Present
(Stored_Constraint (Directly_Designated_Type (Target_Type)))
then
Make_Discriminant_Constraint_Check
(Target_Type => Directly_Designated_Type (Target_Type),
Expr_Type => Directly_Designated_Type (Expr_Type));
-- Create discriminant checks for the Target_Type's stored constraints
elsif Comes_From_Source (N)
and then not Discriminant_Checks_Suppressed (Target_Type)
and then Is_Record_Type (Target_Type)
and then Is_Derived_Type (Target_Type)
and then not Is_Tagged_Type (Target_Type)
and then not Is_Constrained (Target_Type)
and then Present (Stored_Constraint (Target_Type))
then
Make_Discriminant_Constraint_Check (Target_Type, Expr_Type);
-- For arrays, checks are set now, but 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. Note that the range check is put on the expression of a
-- type conversion, while the length check is put on the type conversion
-- itself.
elsif Is_Array_Type (Target_Type) then
if Is_Constrained (Target_Type) then
Set_Do_Length_Check (N);
else
Set_Do_Range_Check (Expr);
end if;
end if;
end Apply_Type_Conversion_Checks;
----------------------------------------------
-- Apply_Universal_Integer_Attribute_Checks --
----------------------------------------------
procedure Apply_Universal_Integer_Attribute_Checks (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
Typ : constant Entity_Id := Etype (N);
begin
if Inside_A_Generic then
return;
-- Nothing to do if the result type is universal integer
elsif Typ = Universal_Integer then
return;
-- Nothing to do if checks are suppressed
elsif Range_Checks_Suppressed (Typ)
and then Overflow_Checks_Suppressed (Typ)
then
return;
-- Nothing to do if the attribute does not come from source. The
-- internal attributes we generate of this type do not need checks,
-- and furthermore the attempt to check them causes some circular
-- elaboration orders when dealing with packed types.
elsif not Comes_From_Source (N) then
return;
-- If the prefix is a selected component that depends on a discriminant
-- the check may improperly expose a discriminant instead of using
-- the bounds of the object itself. Set the type of the attribute to
-- the base type of the context, so that a check will be imposed when
-- needed (e.g. if the node appears as an index).
elsif Nkind (Prefix (N)) = N_Selected_Component
and then Ekind (Typ) = E_Signed_Integer_Subtype
and then Depends_On_Discriminant (Scalar_Range (Typ))
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.
else
Set_Etype (N, Universal_Integer);
Set_Analyzed (N, True);
Rewrite (N,
Make_Type_Conversion (Loc,
Subtype_Mark => New_Occurrence_Of (Typ, Loc),
Expression => Relocate_Node (N)));
Analyze_And_Resolve (N, Typ);
return;
end if;
end Apply_Universal_Integer_Attribute_Checks;
-------------------------------------
-- Atomic_Synchronization_Disabled --
-------------------------------------
-- Note: internally Disable/Enable_Atomic_Synchronization is implemented
-- using a bogus check called Atomic_Synchronization. This is to make it
-- more convenient to get exactly the same semantics as [Un]Suppress.
function Atomic_Synchronization_Disabled (E : Entity_Id) return Boolean is
begin
-- If debug flag d.e is set, always return False, i.e. all atomic sync
-- looks enabled, since it is never disabled.
if Debug_Flag_Dot_E then
return False;
-- If debug flag d.d is set then always return True, i.e. all atomic
-- sync looks disabled, since it always tests True.
elsif Debug_Flag_Dot_D then
return True;
-- If entity present, then check result for that entity
elsif Present (E) and then Checks_May_Be_Suppressed (E) then
return Is_Check_Suppressed (E, Atomic_Synchronization);
-- Otherwise result depends on current scope setting
else
return Scope_Suppress.Suppress (Atomic_Synchronization);
end if;
end Atomic_Synchronization_Disabled;
-------------------------------
-- Build_Discriminant_Checks --
-------------------------------
function Build_Discriminant_Checks
(N : Node_Id;
T_Typ : Entity_Id) return Node_Id
is
Loc : constant Source_Ptr := Sloc (N);
Cond : Node_Id;
Disc : Elmt_Id;
Disc_Ent : Entity_Id;
Dref : Node_Id;
Dval : Node_Id;
function Aggregate_Discriminant_Val (Disc : Entity_Id) return Node_Id;
function Replace_Current_Instance
(N : Node_Id) return Traverse_Result;
-- Replace a reference to the current instance of the type with the
-- corresponding _init formal of the initialization procedure. Note:
-- this function relies on us currently being within the initialization
-- procedure.
--------------------------------
-- Aggregate_Discriminant_Val --
--------------------------------
function Aggregate_Discriminant_Val (Disc : Entity_Id) return Node_Id is
Assoc : Node_Id;
begin
-- The aggregate has been normalized with named associations. We use
-- the Chars field to locate the discriminant to take into account
-- discriminants in derived types, which carry the same name as those
-- in the parent.
Assoc := First (Component_Associations (N));
while Present (Assoc) loop
if Chars (First (Choices (Assoc))) = Chars (Disc) then
return Expression (Assoc);
else
Next (Assoc);
end if;
end loop;
-- Discriminant must have been found in the loop above
raise Program_Error;
end Aggregate_Discriminant_Val;
------------------------------
-- Replace_Current_Instance --
------------------------------
function Replace_Current_Instance
(N : Node_Id) return Traverse_Result is
begin
if Is_Entity_Name (N)
and then Etype (N) = Entity (N)
then
Rewrite (N,
New_Occurrence_Of (First_Formal (Current_Subprogram), Loc));
end if;
return OK;
end Replace_Current_Instance;
procedure Search_And_Replace_Current_Instance is new
Traverse_Proc (Replace_Current_Instance);
-- Start of processing for Build_Discriminant_Checks
begin
-- Loop through discriminants evolving the condition
Cond := Empty;
Disc := First_Elmt (Discriminant_Constraint (T_Typ));
-- For a fully private type, use the discriminants of the parent type
if Is_Private_Type (T_Typ)
and then No (Full_View (T_Typ))
then
Disc_Ent := First_Discriminant (Etype (Base_Type (T_Typ)));
else
Disc_Ent := First_Discriminant (T_Typ);
end if;
while Present (Disc) loop
Dval := Node (Disc);
if Nkind (Dval) = N_Identifier
and then Ekind (Entity (Dval)) = E_Discriminant
then
Dval := New_Occurrence_Of (Discriminal (Entity (Dval)), Loc);
else
Dval := Duplicate_Subexpr_No_Checks (Dval);
end if;
-- Replace references to the current instance of the type with the
-- corresponding _init formal of the initialization procedure.
if Within_Init_Proc then
Search_And_Replace_Current_Instance (Dval);
end if;
-- If we have an Unchecked_Union node, we can infer the discriminants
-- of the node.
if Is_Unchecked_Union (Base_Type (T_Typ)) then
Dref := New_Copy (
Get_Discriminant_Value (
First_Discriminant (T_Typ),
T_Typ,
Stored_Constraint (T_Typ)));
elsif Nkind (N) = N_Aggregate then
Dref :=
Duplicate_Subexpr_No_Checks
(Aggregate_Discriminant_Val (Disc_Ent));
elsif Is_Access_Type (Etype (N)) then
Dref :=
Make_Selected_Component (Loc,
Prefix =>
Make_Explicit_Dereference (Loc,
Duplicate_Subexpr_No_Checks (N, Name_Req => True)),
Selector_Name => Make_Identifier (Loc, Chars (Disc_Ent)));
Set_Is_In_Discriminant_Check (Dref);
else
Dref :=
Make_Selected_Component (Loc,
Prefix =>
Duplicate_Subexpr_No_Checks (N, Name_Req => True),
Selector_Name => Make_Identifier (Loc, Chars (Disc_Ent)));
Set_Is_In_Discriminant_Check (Dref);
end if;
Evolve_Or_Else (Cond,
Make_Op_Ne (Loc,
Left_Opnd => Dref,
Right_Opnd => Dval));
Next_Elmt (Disc);
Next_Discriminant (Disc_Ent);
end loop;
return Cond;
end Build_Discriminant_Checks;
------------------
-- Check_Needed --
------------------
function Check_Needed (Nod : Node_Id; Check : Check_Type) return Boolean is
N : Node_Id;
P : Node_Id;
K : Node_Kind;
L : Node_Id;
R : Node_Id;
function Left_Expression (Op : Node_Id) return Node_Id;
-- Return the relevant expression from the left operand of the given
-- short circuit form: this is LO itself, except if LO is a qualified
-- expression, a type conversion, or an expression with actions, in
-- which case this is Left_Expression (Expression (LO)).
---------------------
-- Left_Expression --
---------------------
function Left_Expression (Op : Node_Id) return Node_Id is
LE : Node_Id := Left_Opnd (Op);
begin
while Nkind (LE) in N_Qualified_Expression
| N_Type_Conversion
| N_Expression_With_Actions
loop
LE := Expression (LE);
end loop;
return LE;
end Left_Expression;
-- Start of processing for Check_Needed
begin
-- Always check if not simple entity
if Nkind (Nod) not in N_Has_Entity
or else not Comes_From_Source (Nod)
then
return True;
end if;
-- Look up tree for short circuit
N := Nod;
loop
P := Parent (N);
K := Nkind (P);
-- Done if out of subexpression (note that we allow generated stuff
-- such as itype declarations in this context, to keep the loop going
-- since we may well have generated such stuff in complex situations.
-- Also done if no parent (probably an error condition, but no point
-- in behaving nasty if we find it).
if No (P)
or else (K not in N_Subexpr and then Comes_From_Source (P))
then
return True;
-- Or/Or Else case, where test is part of the right operand, or is
-- part of one of the actions associated with the right operand, and
-- the left operand is an equality test.
elsif K = N_Op_Or then
exit when N = Right_Opnd (P)
and then Nkind (Left_Expression (P)) = N_Op_Eq;
elsif K = N_Or_Else then
exit when (N = Right_Opnd (P)
or else
(Is_List_Member (N)
and then List_Containing (N) = Actions (P)))
and then Nkind (Left_Expression (P)) = N_Op_Eq;
-- Similar test for the And/And then case, where the left operand
-- is an inequality test.
elsif K = N_Op_And then
exit when N = Right_Opnd (P)
and then Nkind (Left_Expression (P)) = N_Op_Ne;
elsif K = N_And_Then then
exit when (N = Right_Opnd (P)
or else
(Is_List_Member (N)
and then List_Containing (N) = Actions (P)))
and then Nkind (Left_Expression (P)) = N_Op_Ne;
end if;
N := P;
end loop;
-- If we fall through the loop, then we have a conditional with an
-- appropriate test as its left operand, so look further.
L := Left_Expression (P);
-- L is an "=" or "/=" operator: extract its operands
R := Right_Opnd (L);
L := Left_Opnd (L);
-- Left operand of test must match original variable
if Nkind (L) not in N_Has_Entity or else Entity (L) /= Entity (Nod) then
return True;
end if;
-- Right operand of test must be key value (zero or null)
case Check is
when Access_Check =>
if not Known_Null (R) then
return True;
end if;
when Division_Check =>
if not Compile_Time_Known_Value (R)
or else Expr_Value (R) /= Uint_0
then
return True;
end if;
when others =>
raise Program_Error;
end case;
-- Here we have the optimizable case, warn if not short-circuited
if K = N_Op_And or else K = N_Op_Or then
Error_Msg_Warn := SPARK_Mode /= On;
case Check is
when Access_Check =>
if GNATprove_Mode then
Error_Msg_N
("Constraint_Error might have been raised (access check)",
Parent (Nod));
else
Error_Msg_N