Google Git
Sign in
gnu / gcc / 926d9947847a0683cf34de6fc231209747576088 / . / gcc / ada / checks.adb
blob: e869605c2de5a9eea2598ff56afaedeeec377eb9 [file] [log] [blame]
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- C H E C K S --
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2015, 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 Casing; use Casing;
with Debug; use Debug;
with Einfo; use Einfo;
with Elists; use Elists;
with Eval_Fat; use Eval_Fat;
with Exp_Ch11; use Exp_Ch11;
with Exp_Ch2; use Exp_Ch2;
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_Eval; use Sem_Eval;
with Sem_Res; use Sem_Res;
with Sem_Util; use Sem_Util;
with Sem_Warn; use Sem_Warn;
with Sinfo; use Sinfo;
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 warning 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
(Ck_Node : 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
(Ck_Node : 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 Apply_Selected_Range_Checks
(Ck_Node : Node_Id;
Target_Typ : Entity_Id;
Source_Typ : Entity_Id;
Do_Static : Boolean);
-- This is the subprogram that does all the work for Apply_Range_Check.
-- Expr, Target_Typ and Source_Typ are as described for the above
-- routine. The Do_Static flag indicates that only a static check is
-- to be done.
type Check_Type is new Check_Id range Access_Check .. Division_Check;
function Check_Needed (Nod : Node_Id; Check : Check_Type) return Boolean;
-- This function is used to see if an access or division by zero check is
-- needed. The check is to be applied to a single variable appearing in the
-- source, and N is the node for the reference. If N is not of this form,
-- True is returned with no further processing. If N is of the right form,
-- then further processing determines if the given Check is needed.
--
-- The particular circuit is to see if we have the case of a check that is
-- not needed because it appears in the right operand of a short circuited
-- conditional where the left operand guards the check. For example:
--
-- if Var = 0 or else Q / Var > 12 then
-- ...
-- end if;
--
-- In this example, the division check is not required. At the same time
-- we can issue warnings for suspicious use of non-short-circuited forms,
-- such as:
--
-- if Var = 0 or Q / Var > 12 then
-- ...
-- end if;
procedure Find_Check
(Expr : Node_Id;
Check_Type : Character;
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;
Ck_Node : 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
(Ck_Node : 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.
function Selected_Range_Checks
(Ck_Node : Node_Id;
Target_Typ : Entity_Id;
Source_Typ : Entity_Id;
Warn_Node : Node_Id) return Check_Result;
-- Like Apply_Selected_Range_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.
------------------------------
-- 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 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_In (N, 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, True);
Possible_Local_Raise (N, Standard_Constraint_Error);
end Activate_Overflow_Check;
--------------------------
-- Activate_Range_Check --
--------------------------
procedure Activate_Range_Check (N : Node_Id) is
begin
Set_Do_Range_Check (N, True);
Possible_Local_Raise (N, Standard_Constraint_Error);
end Activate_Range_Check;
---------------------------------
-- Alignment_Checks_Suppressed --
---------------------------------
function Alignment_Checks_Suppressed (E : Entity_Id) return Boolean is
begin
if Present (E) and then Checks_May_Be_Suppressed (E) then
return Is_Check_Suppressed (E, Alignment_Check);
else
return Scope_Suppress.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;
Flag_Node : Node_Id)
is
Internal_Flag_Node : constant Node_Id := Flag_Node;
Internal_Static_Sloc : constant Source_Ptr := Static_Sloc;
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 should
-- 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
if not Has_Dynamic_Range_Check (Internal_Flag_Node) then
Append_To (Stmts, Checks (J));
Set_Has_Dynamic_Range_Check (Internal_Flag_Node);
end if;
else
Append_To
(Stmts,
Make_Raise_Constraint_Error (Internal_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 RTU_Loaded (Ada_Tags)
and then RTE_Available (RE_Offset_To_Top_Ptr)
and then Etype (P) = RTE (RE_Offset_To_Top_Ptr)
then
return;
end if;
-- 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);
Param_Ent : Entity_Id := Param_Entity (N);
Param_Level : Node_Id;
Type_Level : Node_Id;
begin
if Ada_Version >= Ada_2012
and then not Present (Param_Ent)
and then Is_Entity_Name (N)
and then Ekind_In (Entity (N), 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 the level of the
-- type is less deep than the level of the access parameter, and
-- accessibility checks are not suppressed.
elsif Present (Param_Ent)
and then Present (Extra_Accessibility (Param_Ent))
and then UI_Gt (Object_Access_Level (N),
Deepest_Type_Access_Level (Typ))
and then not Accessibility_Checks_Suppressed (Param_Ent)
and then not Accessibility_Checks_Suppressed (Typ)
then
Param_Level :=
New_Occurrence_Of (Extra_Accessibility (Param_Ent), Loc);
Type_Level :=
Make_Integer_Literal (Loc, Deepest_Type_Access_Level (Typ));
-- Raise Program_Error if the accessibility level of the access
-- parameter is deeper than the level of the target access type.
Insert_Action (Insert_Node,
Make_Raise_Program_Error (Loc,
Condition =>
Make_Op_Gt (Loc,
Left_Opnd => Param_Level,
Right_Opnd => Type_Level),
Reason => PE_Accessibility_Check_Failed));
Analyze_And_Resolve (N);
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);
Aexp : constant Node_Id := Expression (AC);
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).
procedure Compile_Time_Bad_Alignment;
-- Post error warnings when alignment is known to be incompatible. Note
-- that we do not go as far as inserting a raise of Program_Error since
-- this is an erroneous case, and it may happen that we are lucky and an
-- underaligned address turns out to be OK after all.
--------------------------------
-- Compile_Time_Bad_Alignment --
--------------------------------
procedure Compile_Time_Bad_Alignment is
begin
if Address_Clause_Overlay_Warnings then
Error_Msg_FE
("?o?specified address for& may be inconsistent with alignment",
Aexp, E);
Error_Msg_FE
("\?o?program execution may be erroneous (RM 13.3(27))",
Aexp, E);
Set_Address_Warning_Posted (AC);
end if;
end Compile_Time_Bad_Alignment;
-- Start of processing for Apply_Address_Clause_Check
begin
-- See if 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 := Expression (AC);
-- The following loop digs for the real expression to use in the check
loop
-- For constant, get constant expression
if Is_Entity_Name (Expr)
and then Ekind (Entity (Expr)) = E_Constant
then
Expr := Constant_Value (Entity (Expr));
-- For unchecked conversion, get result to convert
elsif Nkind (Expr) = N_Unchecked_Type_Conversion then
Expr := Expression (Expr);
-- For (common case) of To_Address call, get argument
elsif Nkind (Expr) = N_Function_Call
and then Is_Entity_Name (Name (Expr))
and then Is_RTE (Entity (Name (Expr)), RE_To_Address)
then
Expr := First (Parameter_Associations (Expr));
if Nkind (Expr) = N_Parameter_Association then
Expr := Explicit_Actual_Parameter (Expr);
end if;
-- We finally have the real expression
else
exit;
end if;
end loop;
-- See if we know that Expr has a bad alignment at compile time
if Compile_Time_Known_Value (Expr)
and then (Known_Alignment (E) or else Known_Alignment (Typ))
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
Compile_Time_Bad_Alignment;
else
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)) = 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 non-static constant, use the
-- name of the constant itself rather than duplicating its
-- defining 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 address clause 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), W => Warning_Msg));
end if;
-- Add explanation of the warning that is generated by the check
Error_Msg_N
("\address value may be incompatible with alignment "
& "of object?X?", AC);
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 a
-- software arithmetic overflow check may be needed for op (add, subtract,
-- or multiply). This check is performed only if Software_Overflow_Checking
-- is enabled and Do_Overflow_Check is set. In this case we expand the
-- operation into a more complex sequence of tests that ensures that
-- overflow is properly caught.
-- 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
Siz : constant Int := UI_To_Int (Esize (Rtyp));
Dsiz : constant Int := Siz * 2;
Opnod : Node_Id;
Ctyp : Entity_Id;
Opnd : Node_Id;
Cent : RE_Id;
begin
-- Skip check if back end does overflow checks, or the overflow flag
-- is not set anyway, or we are not doing code expansion, or the
-- parent node is a type conversion whose operand is an arithmetic
-- operation on signed integers on which the expander can promote
-- later the operands to type Integer (see Expand_N_Type_Conversion).
-- Special case CLI target, where arithmetic overflow checks can be
-- performed for integer and long_integer
if Backend_Overflow_Checks_On_Target
or else not Do_Overflow_Check (N)
or else not Expander_Active
or else (Present (Parent (N))
and then Nkind (Parent (N)) = N_Type_Conversion
and then Integer_Promotion_Possible (Parent (N)))
or else
(VM_Target = CLI_Target and then Siz >= Standard_Integer_Size)
then
return;
end if;
-- 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 check type exceeds the size of Long_Long_Integer,
-- we use a different approach, expanding to:
-- typ (xxx_With_Ovflo_Check (Integer_64 (x), Integer (y)))
-- where xxx is Add, Multiply or Subtract as appropriate
-- Find check type if one exists
if Dsiz <= Standard_Integer_Size then
Ctyp := Standard_Integer;
elsif Dsiz <= Standard_Long_Long_Integer_Size then
Ctyp := Standard_Long_Long_Integer;
-- No check type exists, use runtime call
else
if Nkind (N) = N_Op_Add then
Cent := RE_Add_With_Ovflo_Check;
elsif Nkind (N) = N_Op_Multiply then
Cent := RE_Multiply_With_Ovflo_Check;
else
pragma Assert (Nkind (N) = N_Op_Subtract);
Cent := RE_Subtract_With_Ovflo_Check;
end if;
Rewrite (N,
OK_Convert_To (Typ,
Make_Function_Call (Loc,
Name => New_Occurrence_Of (RTE (Cent), Loc),
Parameter_Associations => New_List (
OK_Convert_To (RTE (RE_Integer_64), Left_Opnd (N)),
OK_Convert_To (RTE (RE_Integer_64), Right_Opnd (N))))));
Analyze_And_Resolve (N, Typ);
return;
end if;
-- 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
return;
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.
-- A special case arises if our parent is a conversion node. In this
-- case no point in generating a conversion to Result_Type, we will
-- 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, of 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 (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);
elsif Has_Discriminants (Base_Type (Desig_Typ))
and then Is_Constrained (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;
-- Nothing to do if discriminant checks are suppressed or else no code
-- is to be generated
if not Expander_Active
or else Discriminant_Checks_Suppressed (T_Typ)
then
return;
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;
-- 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
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);
begin
if Expander_Active
and then not Backend_Divide_Checks_On_Target
and then Check_Needed (Right, Division_Check)
then
-- 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.
if Do_Division_Check (N) then
Set_Do_Division_Check (N, False);
if (not ROK) or else (Rlo <= 0 and then 0 <= Rhi) then
Insert_Action (N,
Make_Raise_Constraint_Error (Loc,
Condition =>
Make_Op_Eq (Loc,
Left_Opnd => Duplicate_Subexpr_Move_Checks (Right),
Right_Opnd => Make_Integer_Literal (Loc, 0)),
Reason => CE_Divide_By_Zero));
end if;
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
(Ck_Node : Node_Id;
Target_Typ : Entity_Id)
is
LB : constant Node_Id := Type_Low_Bound (Target_Typ);
HB : constant Node_Id := Type_High_Bound (Target_Typ);
Loc : constant Source_Ptr := Sloc (Ck_Node);
Expr_Type : constant Entity_Id := Base_Type (Etype (Ck_Node));
Target_Base : constant Entity_Id :=
Implementation_Base_Type (Target_Typ);
Par : constant Node_Id := Parent (Ck_Node);
pragma Assert (Nkind (Par) = N_Type_Conversion);
-- Parent of check node, must be a type conversion
Truncate : constant Boolean := Float_Truncate (Par);
Max_Bound : constant Uint :=
UI_Expon
(Machine_Radix_Value (Expr_Type),
Machine_Mantissa_Value (Expr_Type) - 1) - 1;
-- Largest bound, so bound plus or minus half is a machine number of F
Ifirst, Ilast : Uint;
-- Bounds of integer type
Lo, Hi : Ureal;
-- Bounds to check in floating-point domain
Lo_OK, Hi_OK : Boolean;
-- True iff Lo resp. Hi belongs to I'Range
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;
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 (Ck_Node, Target_Base);
Set_Etype (Temp, Target_Base);
Insert_Action (Parent (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 (Ck_Node) = N_Real_Literal
and then Etype (Ck_Node) = Universal_Real
and then Is_Integer_Type (Target_Typ)
and then Nkind (Parent (Ck_Node)) = N_Type_Conversion
then
declare
Int_Val : constant Uint := UR_To_Uint (Realval (Ck_Node));
begin
if Int_Val <= Ilast and then Int_Val >= Ifirst then
-- Conversion is safe
Rewrite (Parent (Ck_Node),
Make_Integer_Literal (Loc, UI_To_Int (Int_Val)));
Analyze_And_Resolve (Parent (Ck_Node), Target_Typ);
return;
end if;
end;
end if;
-- Check against lower bound
if Truncate and then Ifirst > 0 then
Lo := Pred (Expr_Type, UR_From_Uint (Ifirst));
Lo_OK := False;
elsif Truncate then
Lo := Succ (Expr_Type, UR_From_Uint (Ifirst - 1));
Lo_OK := True;
elsif abs (Ifirst) < Max_Bound then
Lo := UR_From_Uint (Ifirst) - Ureal_Half;
Lo_OK := (Ifirst > 0);
else
Lo := Machine (Expr_Type, UR_From_Uint (Ifirst), Round_Even, Ck_Node);
Lo_OK := (Lo >= UR_From_Uint (Ifirst));
end if;
if Lo_OK then
-- Lo_Chk := (X >= Lo)
Lo_Chk := Make_Op_Ge (Loc,
Left_Opnd => Duplicate_Subexpr_No_Checks (Ck_Node),
Right_Opnd => Make_Real_Literal (Loc, Lo));
else
-- Lo_Chk := (X > Lo)
Lo_Chk := Make_Op_Gt (Loc,
Left_Opnd => Duplicate_Subexpr_No_Checks (Ck_Node),
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 (Expr_Type, UR_From_Uint (Ilast), Round_Even, Ck_Node);
Hi_OK := (Hi <= UR_From_Uint (Ilast));
end if;
if Hi_OK then
-- Hi_Chk := (X <= Hi)
Hi_Chk := Make_Op_Le (Loc,
Left_Opnd => Duplicate_Subexpr_No_Checks (Ck_Node),
Right_Opnd => Make_Real_Literal (Loc, Hi));
else
-- Hi_Chk := (X < Hi)
Hi_Chk := Make_Op_Lt (Loc,
Left_Opnd => Duplicate_Subexpr_No_Checks (Ck_Node),
Right_Opnd => Make_Real_Literal (Loc, Hi));
end if;
-- If the bounds of the target type are the same as those of the base
-- type, the check is an overflow check as a range check is not
-- performed in these cases.
if 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 (Ck_Node,
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
(Ck_Node : Node_Id;
Target_Typ : Entity_Id;
Source_Typ : Entity_Id := Empty)
is
begin
Apply_Selected_Length_Checks
(Ck_Node, Target_Typ, Source_Typ, Do_Static => False);
end Apply_Length_Check;
-------------------------------------
-- Apply_Parameter_Aliasing_Checks --
-------------------------------------
procedure Apply_Parameter_Aliasing_Checks
(Call : Node_Id;
Subp : Entity_Id)
is
Loc : constant Source_Ptr := Sloc (Call);
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.
------------------------
-- 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;
ID_Casing : constant Casing_Type :=
Identifier_Casing (Source_Index (Current_Sem_Unit));
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 """);
Get_Name_String (Chars (Formal_1));
Set_Casing (ID_Casing);
Store_String_Chars (Name_Buffer (1 .. Name_Len));
Store_String_Chars (""" and """);
Get_Name_String (Chars (Formal_2));
Set_Casing (ID_Casing);
Store_String_Chars (Name_Buffer (1 .. Name_Len));
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;
-- 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
-- Ensure that the actual is an object that is not passed by value.
-- Elementary types are always passed by value, therefore actuals of
-- such types cannot lead to aliasing.
if Is_Object_Reference (Original_Actual (Actual_1))
and then not Is_Elementary_Type (Etype (Original_Actual (Actual_1)))
then
Actual_2 := Next_Actual (Actual_1);
Formal_2 := Next_Formal (Formal_1);
while Present (Actual_2) and then Present (Formal_2) loop
-- The other actual we are testing against must also denote
-- a non pass-by-value object. Generate the check only when
-- the mode of the two formals may lead to aliasing.
if Is_Object_Reference (Original_Actual (Actual_2))
and then not
Is_Elementary_Type (Etype (Original_Actual (Actual_2)))
and then May_Cause_Aliasing (Formal_1, Formal_2)
then
Overlap_Check
(Actual_1 => Actual_1,
Actual_2 => Actual_2,
Formal_1 => Formal_1,
Formal_2 => Formal_2,
Check => Check);
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[_Scalar] 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,
Pragma_Identifier =>
Make_Identifier (Loc, 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 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 Check_Validity_Of_Parameters then
if Ekind_In (Formal, E_In_Parameter, E_In_Out_Parameter) then
Add_Validity_Check (Formal, Name_Precondition, False);
end if;
if Ekind_In (Formal, E_In_Out_Parameter, E_Out_Parameter) then
Add_Validity_Check (Formal, Name_Postcondition, False);
end if;
end if;
Next_Formal (Formal);
end loop;
-- Generate following scalar initialization check for function result:
-- Post => Subp'Result'Valid[_Scalars]
if Check_Validity_Of_Parameters and then 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) is
S : Entity_Id;
begin
if Present (Predicate_Function (Typ)) then
S := Current_Scope;
while Present (S) and then not Is_Subprogram (S) loop
S := Scope (S);
end loop;
-- A predicate check does not apply within internally generated
-- subprograms, such as TSS functions.
if Within_Internal_Subprogram then
return;
-- 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.
elsif Present (S) and then S = Predicate_Function (Typ) then
Error_Msg_N
("predicate check includes a function call that "
& "requires a predicate check??", Parent (N));
Error_Msg_N
("\this will result in infinite recursion??", Parent (N));
Insert_Action (N,
Make_Raise_Storage_Error (Sloc (N),
Reason => SE_Infinite_Recursion));
-- Here for normal case of predicate active
else
-- 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);
Insert_Action (N,
Make_Predicate_Check (Typ, Duplicate_Subexpr (N)));
end if;
end if;
end Apply_Predicate_Check;
-----------------------
-- Apply_Range_Check --
-----------------------
procedure Apply_Range_Check
(Ck_Node : Node_Id;
Target_Typ : Entity_Id;
Source_Typ : Entity_Id := Empty)
is
begin
Apply_Selected_Range_Checks
(Ck_Node, Target_Typ, Source_Typ, Do_Static => False);
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
OK : Boolean;
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;
-- Procedure called if value is determined to be out of range
---------------
-- Bad_Value --
---------------
procedure Bad_Value is
begin
Apply_Compile_Time_Constraint_Error
(Expr, "value not in range of}??", CE_Range_Check_Failed,
Ent => Target_Typ,
Typ => Target_Typ);
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 Has_Infinities (S_Typ)
and then not Has_Infinities (Target_Typ)
then
Enable_Range_Check (Expr);
end if;
end if;
-- Return if we know expression is definitely in the range of the target
-- type as determined by Determine_Range. Right now we only do this for
-- discrete types, and not fixed-point or floating-point types.
-- 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 Is_Discrete_Type (Etype (Expr))
and then not Is_Unconstrained_Subscr_Ref
and then No (Source_Typ)
then
declare
Tlo : constant Node_Id := Type_Low_Bound (Target_Typ);
Thi : constant Node_Id := Type_High_Bound (Target_Typ);
Lo : Uint;
Hi : Uint;
begin
if Compile_Time_Known_Value (Tlo)
and then Compile_Time_Known_Value (Thi)
then
declare
Lov : constant Uint := Expr_Value (Tlo);
Hiv : constant Uint := Expr_Value (Thi);
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
-- In GNATprove mode, do not issue a message in that case
-- (which would be an error stopping analysis), as this
-- likely corresponds to deactivated code based on a
-- given configuration (say, dead code inside a loop over
-- the empty range). Instead, we enable the range check
-- so that GNATprove will issue a message if it cannot be
-- proved.
if GNATprove_Mode then
Enable_Range_Check (Expr);
else
Bad_Value;
end if;
return;
end if;
-- Otherwise determine range of value
Determine_Range (Expr, OK, Lo, Hi, 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
Bad_Value;
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.
if not Is_Unconstrained_Subscr_Ref
and then Is_Discrete_Type (S_Typ) = 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
elsif Is_Floating_Point_Type (S_Typ) then
-- Normally, we only do range checks if the type is constrained. We do
-- NOT want range checks for unconstrained types, since we want to have
-- infinities.
if Is_Constrained (S_Typ) 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
(Ck_Node : Node_Id;
Target_Typ : Entity_Id;
Source_Typ : Entity_Id;
Do_Static : Boolean)
is
Cond : Node_Id;
R_Result : Check_Result;
R_Cno : Node_Id;
Loc : constant Source_Ptr := Sloc (Ck_Node);
Checks_On : constant Boolean :=
(not Index_Checks_Suppressed (Target_Typ))
or else (not Length_Checks_Suppressed (Target_Typ));
begin
-- Note: this means that we lose some useful warnings if the expander
-- is not active, and we also lose these warnings in SPARK mode ???
if not Expander_Active then
return;
end if;
R_Result :=
Selected_Length_Checks (Ck_Node, 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, Ck_Node);
if Present (Source_Typ) then
Ensure_Defined (Source_Typ, Ck_Node);
elsif Is_Itype (Etype (Ck_Node)) then
Ensure_Defined (Etype (Ck_Node), Ck_Node);
end if;
end if;
-- If the item is a conditional raise of constraint error, then have
-- a look at what check is being performed and ???
if 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 (Ck_Node) then
-- If checks are on, just insert the check
if Checks_On then
Insert_Action (Ck_Node, R_Cno);
if not Do_Static then
Set_Has_Dynamic_Length_Check (Ck_Node);
end if;
-- If checks are off, then analyze the length check after
-- temporarily attaching it to the tree in case the relevant
-- condition can be evaluated at compile time. We still want a
-- compile time warning in this case.
else
Set_Parent (R_Cno, Ck_Node);
Analyze (R_Cno);
end if;
end if;
-- 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
(Ck_Node, "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_Selected_Range_Checks --
---------------------------------
procedure Apply_Selected_Range_Checks
(Ck_Node : Node_Id;
Target_Typ : Entity_Id;
Source_Typ : Entity_Id;
Do_Static : Boolean)
is
Loc : constant Source_Ptr := Sloc (Ck_Node);
Checks_On : constant Boolean :=
not Index_Checks_Suppressed (Target_Typ)
or else
not Range_Checks_Suppressed (Target_Typ);
Cond : Node_Id;
R_Cno : Node_Id;
R_Result : Check_Result;
begin
if not Expander_Active or not Checks_On then
return;
end if;
R_Result :=
Selected_Range_Checks (Ck_Node, Target_Typ, Source_Typ, Empty);
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.
Insert_Action (Ck_Node, R_Cno);
-- This old code doesn't make sense, why is the context flagged as
-- requiring dynamic range checks now in the middle of generating
-- them ???
if not Do_Static then
Set_Has_Dynamic_Range_Check (Ck_Node);
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 (Ck_Node) = N_Range then
Apply_Compile_Time_Constraint_Error
(Low_Bound (Ck_Node),
"static range out of bounds of}??",
CE_Range_Check_Failed,
Ent => Target_Typ,
Typ => Target_Typ);
Set_Raises_Constraint_Error (Ck_Node);
else
Apply_Compile_Time_Constraint_Error
(Ck_Node,
"static value out of range of}??",
CE_Range_Check_Failed,
Ent => Target_Typ,
Typ => Target_Typ);
end if;
-- 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
-- Why are we even generating checks if checks are turned off ???
elsif Do_Static or else not Checks_On then
Remove_Warning_Messages (R_Cno);
Rewrite (R_Cno, Make_Null_Statement (Loc));
end if;
-- The range check raises Constrant_Error explicitly
else
Install_Static_Check (R_Cno, Loc);
end if;
end loop;
end Apply_Selected_Range_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) is
Sub : Node_Id;
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.
Ensure_Valid (Sub, Holes_OK => True);
-- Move to next subscript
Sub := Next (Sub);
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.
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
Activate_Overflow_Check (N);
end if;
if not Range_Checks_Suppressed (Target_Type)
and then not Range_Checks_Suppressed (Expr_Type)
then
if Float_To_Int then
Apply_Float_Conversion_Check (Expr, Target_Type);
else
Apply_Scalar_Range_Check
(Expr, Target_Type, Fixed_Int => Conv_OK);
-- 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;
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
-- An unconstrained derived type may have inherited discriminant.
-- 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.
declare
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
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.
Set_Discriminant_Constraint (Expr_Type, New_Constraints);
Cond := Build_Discriminant_Checks (Expr, Expr_Type);
Set_Discriminant_Constraint (Expr_Type, Old_Constraints);
Insert_Action (N,
Make_Raise_Constraint_Error (Loc,
Condition => Cond,
Reason => CE_Discriminant_Check_Failed));
end;
-- 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 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;
----------------------------------
-- Aggregate_Discriminant_Value --
----------------------------------
function Aggregate_Discriminant_Val (Disc : Entity_Id) return Node_Id is
Assoc : Node_Id;
begin
-- The aggregate has been normalized with named associations. We use
-- the Chars field to locate the discriminant to take into account
-- discriminants in derived types, which carry the same name as those
-- in the parent.
Assoc := First (Component_Associations (N));
while Present (Assoc) loop
if Chars (First (Choices (Assoc))) = Chars (Disc) then
return Expression (Assoc);
else
Next (Assoc);
end if;
end loop;
-- Discriminant must have been found in the loop above
raise Program_Error;
end Aggregate_Discriminant_Val;
-- Start of processing for Build_Discriminant_Checks
begin
-- Loop through discriminants evolving the condition
Cond := Empty;
Disc := First_Elmt (Discriminant_Constraint (T_Typ));
-- 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;
-- 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));
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_In (LE, 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
("Constraint_Error may be raised (access check)??",
Parent (Nod));
end if;
when Division_Check =>
if GNATprove_Mode then
Error_Msg_N
("Constraint_Error might have been raised (zero divide)",
Parent (Nod));
else
Error_Msg_N
("Constraint_Error may be raised (zero divide)??",
Parent (Nod));
end if;
when others =>
raise Program_Error;
end case;
if K = N_Op_And then
Error_Msg_N -- CODEFIX
("use `AND THEN` instead of AND??", P);
else
Error_Msg_N -- CODEFIX
("use `OR ELSE` instead of OR??", P);
end if;
-- If not short-circuited, we need the check
return True;
-- If short-circuited, we can omit the check
else
return False;
end if;
end Check_Needed;
-----------------------------------
-- Check_Valid_Lvalue_Subscripts --
-----------------------------------
procedure Check_Valid_Lvalue_Subscripts (Expr : Node_Id) is
begin
-- Skip this if range checks are suppressed
if Range_Checks_Suppressed (Etype (Expr)) then
return;
-- Only do this check for expressions that come from source. We assume
-- that expander generated assignments explicitly include any necessary
-- checks. Note that this is not just an optimization, it avoids
-- infinite recursions.
elsif not Comes_From_Source (Expr) then
return;
-- For a selected component, check the prefix
elsif Nkind (Expr) = N_Selected_Component then
Check_Valid_Lvalue_Subscripts (Prefix (Expr));
return;
-- Case of indexed component
elsif Nkind (Expr) = N_Indexed_Component then
Apply_Subscript_Validity_Checks (Expr);
-- Prefix may itself be or contain an indexed component, and these
-- subscripts need checking as well.
Check_Valid_Lvalue_Subscripts (Prefix (Expr));
end if;
end Check_Valid_Lvalue_Subscripts;
----------------------------------
-- Null_Exclusion_Static_Checks --
----------------------------------
procedure Null_Exclusion_Static_Checks (N : Node_Id) is
Error_Node : Node_Id;
Expr : Node_Id;
Has_Null : constant Boolean := Has_Null_Exclusion (N);
K : constant Node_Kind := Nkind (N);
Typ : Entity_Id;
begin
pragma Assert
(Nkind_In (K, N_Component_Declaration,
N_Discriminant_Specification,
N_Function_Specification,
N_Object_Declaration,
N_Parameter_Specification));
if K = N_Function_Specification then
Typ := Etype (Defining_Entity (N));
else
Typ := Etype (Defining_Identifier (N));
end if;
case K is
when N_Component_Declaration =>
if Present (Access_Definition (Component_Definition (N))) then
Error_Node := Component_Definition (N);
else
Error_Node := Subtype_Indication (Component_Definition (N));
end if;
when N_Discriminant_Specification =>
Error_Node := Discriminant_Type (N);
when N_Function_Specification =>
Error_Node := Result_Definition (N);
when N_Object_Declaration =>
Error_Node := Object_Definition (N);
when N_Parameter_Specification =>
Error_Node := Parameter_Type (N);
when others =>
raise Program_Error;
end case;
if Has_Null then
-- Enforce legality rule 3.10 (13): A null exclusion can only be
-- applied to an access [sub]type.
if not Is_Access_Type (Typ) then
Error_Msg_N
("`NOT NULL` allowed only for an access type", Error_Node);
-- Enforce legality rule RM 3.10(14/1): A null exclusion can only
-- be applied to a [sub]type that does not exclude null already.
elsif Can_Never_Be_Null (Typ)
and then Comes_From_Source (Typ)
then
Error_Msg_NE
("`NOT NULL` not allowed (& already excludes null)",
Error_Node, Typ);
end if;
end if;
-- Check that null-excluding objects are always initialized, except for
-- deferred constants, for which the expression will appear in the full
-- declaration.
if K = N_Object_Declaration
and then No (Expression (N))
and then not Constant_Present (N)
and then not No_Initialization (N)
then
-- Add an expression that assigns null. This node is needed by
-- Apply_Compile_Time_Constraint_Error, which will replace this with
-- a Constraint_Error node.
Set_Expression (N, Make_Null (Sloc (N)));
Set_Etype (Expression (N), Etype (Defining_Identifier (N)));
Apply_Compile_Time_Constraint_Error
(N => Expression (N),
Msg =>
"(Ada 2005) null-excluding objects must be initialized??",
Reason => CE_Null_Not_Allowed);
end if;
-- Check that a null-excluding component, formal or object is not being
-- assigned a null value. Otherwise generate a warning message and
-- replace Expression (N) by an N_Constraint_Error node.
if K /= N_Function_Specification then
Expr := Expression (N);
if Present (Expr) and then Known_Null (Expr) then
case K is
when N_Component_Declaration |
N_Discriminant_Specification =>
Apply_Compile_Time_Constraint_Error
(N => Expr,
Msg => "(Ada 2005) null not allowed "
& "in null-excluding components??",
Reason => CE_Null_Not_Allowed);
when N_Object_Declaration =>
Apply_Compile_Time_Constraint_Error
(N => Expr,
Msg => "(Ada 2005) null not allowed "
& "in null-excluding objects??",
Reason => CE_Null_Not_Allowed);
when N_Parameter_Specification =>
Apply_Compile_Time_Constraint_Error
(N => Expr,
Msg => "(Ada 2005) null not allowed "
& "in null-excluding formals??",
Reason => CE_Null_Not_Allowed);
when others =>
null;
end case;
end if;
end if;
end Null_Exclusion_Static_Checks;
----------------------------------
-- Conditional_Statements_Begin --
----------------------------------
procedure Conditional_Statements_Begin is
begin
Saved_Checks_TOS := Saved_Checks_TOS + 1;
-- If stack overflows, kill all checks, that way we know to simply reset
-- the number of saved checks to zero on return. This should never occur
-- in practice.
if Saved_Checks_TOS > Saved_Checks_Stack'Last then
Kill_All_Checks;
-- In the normal case, we just make a new stack entry saving the current
-- number of saved checks for a later restore.
else
Saved_Checks_Stack (Saved_Checks_TOS) := Num_Saved_Checks;
if Debug_Flag_CC then
w ("Conditional_Statements_Begin: Num_Saved_Checks = ",
Num_Saved_Checks);
end if;
end if;
end Conditional_Statements_Begin;
--------------------------------
-- Conditional_Statements_End --
--------------------------------
procedure Conditional_Statements_End is
begin
pragma Assert (Saved_Checks_TOS > 0);
-- If the saved checks stack overflowed, then we killed all checks, so
-- setting the number of saved checks back to zero is correct. This
-- should never occur in practice.
if Saved_Checks_TOS > Saved_Checks_Stack'Last then
Num_Saved_Checks := 0;
-- In the normal case, restore the number of saved checks from the top
-- stack entry.
else
Num_Saved_Checks := Saved_Checks_Stack (Saved_Checks_TOS);
if Debug_Flag_CC then
w ("Conditional_Statements_End: Num_Saved_Checks = ",
Num_Saved_Checks);
end if;
end if;
Saved_Checks_TOS := Saved_Checks_TOS - 1;
end Conditional_Statements_End;
-------------------------
-- Convert_From_Bignum --
-------------------------
function Convert_From_Bignum (N : Node_Id) return Node_Id is
Loc : constant Source_Ptr := Sloc (N);
begin
pragma Assert (Is_RTE (Etype (N), RE_Bignum));
-- Construct call From Bignum
return
Make_Function_Call (Loc,
Name =>
New_Occurrence_Of (RTE (RE_From_Bignum), Loc),
Parameter_Associations => New_List (Relocate_Node (N)));
end Convert_From_Bignum;
-----------------------
-- Convert_To_Bignum --
-----------------------
function Convert_To_Bignum (N : Node_Id) return Node_Id is
Loc : constant Source_Ptr := Sloc (N);
begin
-- Nothing to do if Bignum already except call Relocate_Node
if Is_RTE (Etype (N), RE_Bignum) then
return Relocate_Node (N);
-- Otherwise construct call to To_Bignum, converting the operand to the
-- required Long_Long_Integer form.
else
pragma Assert (Is_Signed_Integer_Type (Etype (N)));
return
Make_Function_Call (Loc,
Name =>
New_Occurrence_Of (RTE (RE_To_Bignum), Loc),
Parameter_Associations => New_List (
Convert_To (Standard_Long_Long_Integer, Relocate_Node (N))));
end if;
end Convert_To_Bignum;
---------------------
-- Determine_Range --
---------------------
Cache_Size : constant := 2 ** 10;
type Cache_Index is range 0 .. Cache_Size - 1;
-- Determine size of below cache (power of 2 is more efficient)
Determine_Range_Cache_N : array (Cache_Index) of Node_Id;
Determine_Range_Cache_V : array (Cache_Index) of Boolean;
Determine_Range_Cache_Lo : array (Cache_Index) of Uint;
Determine_Range_Cache_Hi : array (Cache_Index) of Uint;
Determine_Range_Cache_Lo_R : array (Cache_Index) of Ureal;
Determine_Range_Cache_Hi_R : array (Cache_Index) of Ureal;
-- The above arrays are used to implement a small direct cache for
-- Determine_Range and Determine_Range_R calls. Because of the way these
-- subprograms recursively traces subexpressions, and because overflow
-- checking calls the routine on the way up the tree, a quadratic behavior
-- can otherwise be encountered in large expressions. The cache entry for
-- node N is stored in the (N mod Cache_Size) entry, and can be validated
-- by checking the actual node value stored there. The Range_Cache_V array
-- records the setting of Assume_Valid for the cache entry.
procedure Determine_Range
(N : Node_Id;
OK : out Boolean;
Lo : out Uint;
Hi : out Uint;
Assume_Valid : Boolean := False)
is
Typ : Entity_Id := Etype (N);
-- Type to use, may get reset to base type for possibly invalid entity
Lo_Left : Uint;
Hi_Left : Uint;
-- Lo and Hi bounds of left operand
Lo_Right : Uint;
Hi_Right : Uint;
-- Lo and Hi bounds of right (or only) operand
Bound : Node_Id;
-- Temp variable used to hold a bound node
Hbound : Uint;
-- High bound of base type of expression
Lor : Uint;
Hir : Uint;
-- Refined values for low and high bounds, after tightening
OK1 : Boolean;
-- Used in lower level calls to indicate if call succeeded
Cindex : Cache_Index;
-- Used to search cache
Btyp : Entity_Id;
-- Base type
function OK_Operands return Boolean;
-- Used for binary operators. Determines the ranges of the left and
-- right operands, and if they are both OK, returns True, and puts
-- the results in Lo_Right, Hi_Right, Lo_Left, Hi_Left.
-----------------
-- OK_Operands --
-----------------
function OK_Operands return Boolean is
begin
Determine_Range
(Left_Opnd (N), OK1, Lo_Left, Hi_Left, Assume_Valid);
if not OK1 then
return False;
end if;
Determine_Range
(Right_Opnd (N), OK1, Lo_Right, Hi_Right, Assume_Valid);
return OK1;
end OK_Operands;
-- Start of processing for Determine_Range
begin
-- Prevent junk warnings by initializing range variables
Lo := No_Uint;
Hi := No_Uint;
Lor := No_Uint;
Hir := No_Uint;
-- For temporary constants internally generated to remove side effects
-- we must use the corresponding expression to determine the range of
-- the expression. But note that the expander can also generate
-- constants in other cases, including deferred constants.
if Is_Entity_Name (N)
and then Nkind (Parent (Entity (N))) = N_Object_Declaration
and then Ekind (Entity (N)) = E_Constant
and then Is_Internal_Name (Chars (Entity (N)))
then
if Present (Expression (Parent (Entity (N)))) then
Determine_Range
(Expression (Parent (Entity (N))), OK, Lo, Hi, Assume_Valid);
elsif Present (Full_View (Entity (N))) then
Determine_Range
(Expression (Parent (Full_View (Entity (N)))),
OK, Lo, Hi, Assume_Valid);
else
OK := False;
end if;
return;
end if;
-- If type is not defined, we can't determine its range
if No (Typ)
-- We don't deal with anything except discrete types
or else not Is_Discrete_Type (Typ)
-- Ignore type for which an error has been posted, since range in
-- this case may well be a bogosity deriving from the error. Also
-- ignore if error posted on the reference node.
or else Error_Posted (N) or else Error_Posted (Typ)
then
OK := False;
return;
end if;
-- For all other cases, we can determine the range
OK := True;
-- If value is compile time known, then the possible range is the one
-- value that we know this expression definitely has.
if Compile_Time_Known_Value (N) then
Lo := Expr_Value (N);
Hi := Lo;
return;
end if;
-- Return if already in the cache
Cindex := Cache_Index (N mod Cache_Size);
if Determine_Range_Cache_N (Cindex) = N
and then
Determine_Range_Cache_V (Cindex) = Assume_Valid
then
Lo := Determine_Range_Cache_Lo (Cindex);
Hi := Determine_Range_Cache_Hi (Cindex);
return;
end if;
-- Otherwise, start by finding the bounds of the type of the expression,
-- the value cannot be outside this range (if it is, then we have an
-- overflow situation, which is a separate check, we are talking here
-- only about the expression value).
-- First a check, never try to find the bounds of a generic type, since
-- these bounds are always junk values, and it is only valid to look at
-- the bounds in an instance.
if Is_Generic_Type (Typ) then
OK := False;
return;
end if;
</