Google Git
Sign in
gnu / gcc / refs/tags/basepoints/gcc-13 / . / gcc / ada / sem_eval.adb
blob: 2881a148c31f9027c6a4763033e7c90a0d802374 [file] [log] [blame]
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- S E M _ E V A L --
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2022, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING3. If not, go to --
-- http://www.gnu.org/licenses for a complete copy of the license. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
with Aspects; use Aspects;
with Atree; use Atree;
with Checks; use Checks;
with Debug; use Debug;
with Einfo; use Einfo;
with Einfo.Entities; use Einfo.Entities;
with Einfo.Utils; use Einfo.Utils;
with Elists; use Elists;
with Errout; use Errout;
with Eval_Fat; use Eval_Fat;
with Exp_Util; use Exp_Util;
with Freeze; use Freeze;
with Lib; use Lib;
with Namet; use Namet;
with Nmake; use Nmake;
with Nlists; use Nlists;
with Opt; use Opt;
with Par_SCO; use Par_SCO;
with Rtsfind; use Rtsfind;
with Sem; use Sem;
with Sem_Aux; use Sem_Aux;
with Sem_Cat; use Sem_Cat;
with Sem_Ch3; use Sem_Ch3;
with Sem_Ch6; use Sem_Ch6;
with Sem_Ch8; use Sem_Ch8;
with Sem_Elab; use Sem_Elab;
with Sem_Res; use Sem_Res;
with Sem_Util; use Sem_Util;
with Sem_Type; use Sem_Type;
with Sem_Warn; use Sem_Warn;
with Sinfo; use Sinfo;
with Sinfo.Nodes; use Sinfo.Nodes;
with Sinfo.Utils; use Sinfo.Utils;
with Snames; use Snames;
with Stand; use Stand;
with Stringt; use Stringt;
with Tbuild; use Tbuild;
package body Sem_Eval is
-----------------------------------------
-- Handling of Compile Time Evaluation --
-----------------------------------------
-- The compile time evaluation of expressions is distributed over several
-- Eval_xxx procedures. These procedures are called immediately after
-- a subexpression is resolved and is therefore accomplished in a bottom
-- up fashion. The flags are synthesized using the following approach.
-- Is_Static_Expression is determined by following the rules in
-- RM-4.9. This involves testing the Is_Static_Expression flag of
-- the operands in many cases.
-- Raises_Constraint_Error is usually set if any of the operands have
-- the flag set or if an attempt to compute the value of the current
-- expression results in Constraint_Error.
-- The general approach is as follows. First compute Is_Static_Expression.
-- If the node is not static, then the flag is left off in the node and
-- we are all done. Otherwise for a static node, we test if any of the
-- operands will raise Constraint_Error, and if so, propagate the flag
-- Raises_Constraint_Error to the result node and we are done (since the
-- error was already posted at a lower level).
-- For the case of a static node whose operands do not raise constraint
-- error, we attempt to evaluate the node. If this evaluation succeeds,
-- then the node is replaced by the result of this computation. If the
-- evaluation raises Constraint_Error, then we rewrite the node with
-- Apply_Compile_Time_Constraint_Error to raise the exception and also
-- to post appropriate error messages.
----------------
-- Local Data --
----------------
type Bits is array (Nat range <>) of Boolean;
-- Used to convert unsigned (modular) values for folding logical ops
-- The following declarations are used to maintain a cache of nodes that
-- have compile-time-known values. The cache is maintained only for
-- discrete types (the most common case), and is populated by calls to
-- Compile_Time_Known_Value and Expr_Value, but only used by Expr_Value
-- since it is possible for the status to change (in particular it is
-- possible for a node to get replaced by a Constraint_Error node).
CV_Bits : constant := 5;
-- Number of low order bits of Node_Id value used to reference entries
-- in the cache table.
CV_Cache_Size : constant Nat := 2 ** CV_Bits;
-- Size of cache for compile time values
subtype CV_Range is Nat range 0 .. CV_Cache_Size;
type CV_Entry is record
N : Node_Id'Base;
-- We use 'Base here, in case we want to add a predicate to Node_Id
V : Uint;
end record;
type Match_Result is (Match, No_Match, Non_Static);
-- Result returned from functions that test for a matching result. If the
-- operands are not OK_Static then Non_Static will be returned. Otherwise
-- Match/No_Match is returned depending on whether the match succeeds.
type CV_Cache_Array is array (CV_Range) of CV_Entry;
CV_Cache : CV_Cache_Array;
-- This is the actual cache, with entries consisting of node/value pairs,
-- and the impossible value Node_High_Bound used for unset entries.
type Range_Membership is (In_Range, Out_Of_Range, Unknown);
-- Range membership may either be statically known to be in range or out
-- of range, or not statically known. Used for Test_In_Range below.
Checking_For_Potentially_Static_Expression : Boolean := False;
-- Global flag that is set True during Analyze_Static_Expression_Function
-- in order to verify that the result expression of a static expression
-- function is a potentially static function (see RM2022 6.8(5.3)).
-----------------------
-- Local Subprograms --
-----------------------
procedure Check_Non_Static_Context_For_Overflow
(N : Node_Id;
Stat : Boolean;
Result : Uint);
-- For a signed integer type, check non-static overflow in Result when
-- Stat is False. This applies also inside inlined code, where the static
-- property may be an effect of the inlining, which should not be allowed
-- to remove run-time checks (whether during compilation, or even more
-- crucially in the special inlining-for-proof in GNATprove mode).
function Choice_Matches
(Expr : Node_Id;
Choice : Node_Id) return Match_Result;
-- Determines whether given value Expr matches the given Choice. The Expr
-- can be of discrete, real, or string type and must be a compile time
-- known value (it is an error to make the call if these conditions are
-- not met). The choice can be a range, subtype name, subtype indication,
-- or expression. The returned result is Non_Static if Choice is not
-- OK_Static, otherwise either Match or No_Match is returned depending
-- on whether Choice matches Expr. This is used for case expression
-- alternatives, and also for membership tests. In each case, more
-- possibilities are tested than the syntax allows (e.g. membership allows
-- subtype indications and non-discrete types, and case allows an OTHERS
-- choice), but it does not matter, since we have already done a full
-- semantic and syntax check of the construct, so the extra possibilities
-- just will not arise for correct expressions.
--
-- Note: if Choice_Matches finds that a choice raises Constraint_Error, e.g
-- a reference to a type, one of whose bounds raises Constraint_Error, then
-- it also sets the Raises_Constraint_Error flag on the Choice itself.
function Choices_Match
(Expr : Node_Id;
Choices : List_Id) return Match_Result;
-- This function applies Choice_Matches to each element of Choices. If the
-- result is No_Match, then it continues and checks the next element. If
-- the result is Match or Non_Static, this result is immediately given
-- as the result without checking the rest of the list. Expr can be of
-- discrete, real, or string type and must be a compile-time-known value
-- (it is an error to make the call if these conditions are not met).
procedure Eval_Intrinsic_Call (N : Node_Id; E : Entity_Id);
-- Evaluate a call N to an intrinsic subprogram E.
function Find_Universal_Operator_Type (N : Node_Id) return Entity_Id;
-- Check whether an arithmetic operation with universal operands which is a
-- rewritten function call with an explicit scope indication is ambiguous:
-- P."+" (1, 2) will be ambiguous if there is more than one visible numeric
-- type declared in P and the context does not impose a type on the result
-- (e.g. in the expression of a type conversion). If ambiguous, emit an
-- error and return Empty, else return the result type of the operator.
procedure Fold_Dummy (N : Node_Id; Typ : Entity_Id);
-- Rewrite N as a constant dummy value in the relevant type if possible.
procedure Fold_Shift
(N : Node_Id;
Left : Node_Id;
Right : Node_Id;
Op : Node_Kind;
Static : Boolean := False;
Check_Elab : Boolean := False);
-- Rewrite N as the result of evaluating Left <shift op> Right if possible.
-- Op represents the shift operation.
-- Static indicates whether the resulting node should be marked static.
-- Check_Elab indicates whether checks for elaboration calls should be
-- inserted when relevant.
function From_Bits (B : Bits; T : Entity_Id) return Uint;
-- Converts a bit string of length B'Length to a Uint value to be used for
-- a target of type T, which is a modular type. This procedure includes the
-- necessary reduction by the modulus in the case of a nonbinary modulus
-- (for a binary modulus, the bit string is the right length any way so all
-- is well).
function Get_String_Val (N : Node_Id) return Node_Id;
-- Given a tree node for a folded string or character value, returns the
-- corresponding string literal or character literal (one of the two must
-- be available, or the operand would not have been marked as foldable in
-- the earlier analysis of the operation).
function Is_OK_Static_Choice (Choice : Node_Id) return Boolean;
-- Given a choice (from a case expression or membership test), returns
-- True if the choice is static and does not raise a Constraint_Error.
function Is_OK_Static_Choice_List (Choices : List_Id) return Boolean;
-- Given a choice list (from a case expression or membership test), return
-- True if all choices are static in the sense of Is_OK_Static_Choice.
function Is_Static_Choice (Choice : Node_Id) return Boolean;
-- Given a choice (from a case expression or membership test), returns
-- True if the choice is static. No test is made for raising of constraint
-- error, so this function is used only for legality tests.
function Is_Static_Choice_List (Choices : List_Id) return Boolean;
-- Given a choice list (from a case expression or membership test), return
-- True if all choices are static in the sense of Is_Static_Choice.
function Is_Static_Range (N : Node_Id) return Boolean;
-- Determine if range is static, as defined in RM 4.9(26). The only allowed
-- argument is an N_Range node (but note that the semantic analysis of
-- equivalent range attribute references already turned them into the
-- equivalent range). This differs from Is_OK_Static_Range (which is what
-- must be used by clients) in that it does not care whether the bounds
-- raise Constraint_Error or not. Used for checking whether expressions are
-- static in the 4.9 sense (without worrying about exceptions).
function OK_Bits (N : Node_Id; Bits : Uint) return Boolean;
-- Bits represents the number of bits in an integer value to be computed
-- (but the value has not been computed yet). If this value in Bits is
-- reasonable, a result of True is returned, with the implication that the
-- caller should go ahead and complete the calculation. If the value in
-- Bits is unreasonably large, then an error is posted on node N, and
-- False is returned (and the caller skips the proposed calculation).
procedure Out_Of_Range (N : Node_Id);
-- This procedure is called if it is determined that node N, which appears
-- in a non-static context, is a compile-time-known value which is outside
-- its range, i.e. the range of Etype. This is used in contexts where
-- this is an illegality if N is static, and should generate a warning
-- otherwise.
function Real_Or_String_Static_Predicate_Matches
(Val : Node_Id;
Typ : Entity_Id) return Boolean;
-- This is the function used to evaluate real or string static predicates.
-- Val is an unanalyzed N_Real_Literal or N_String_Literal node, which
-- represents the value to be tested against the predicate. Typ is the
-- type with the predicate, from which the predicate expression can be
-- extracted. The result returned is True if the given value satisfies
-- the predicate.
procedure Rewrite_In_Raise_CE (N : Node_Id; Exp : Node_Id);
-- N and Exp are nodes representing an expression, Exp is known to raise
-- CE. N is rewritten in term of Exp in the optimal way.
function String_Type_Len (Stype : Entity_Id) return Uint;
-- Given a string type, determines the length of the index type, or, if
-- this index type is non-static, the length of the base type of this index
-- type. Note that if the string type is itself static, then the index type
-- is static, so the second case applies only if the string type passed is
-- non-static.
function Test (Cond : Boolean) return Uint;
pragma Inline (Test);
-- This function simply returns the appropriate Boolean'Pos value
-- corresponding to the value of Cond as a universal integer. It is
-- used for producing the result of the static evaluation of the
-- logical operators
procedure Test_Expression_Is_Foldable
(N : Node_Id;
Op1 : Node_Id;
Stat : out Boolean;
Fold : out Boolean);
-- Tests to see if expression N whose single operand is Op1 is foldable,
-- i.e. the operand value is known at compile time. If the operation is
-- foldable, then Fold is True on return, and Stat indicates whether the
-- result is static (i.e. the operand was static). Note that it is quite
-- possible for Fold to be True, and Stat to be False, since there are
-- cases in which we know the value of an operand even though it is not
-- technically static (e.g. the static lower bound of a range whose upper
-- bound is non-static).
--
-- If Stat is set False on return, then Test_Expression_Is_Foldable makes
-- a call to Check_Non_Static_Context on the operand. If Fold is False on
-- return, then all processing is complete, and the caller should return,
-- since there is nothing else to do.
--
-- If Stat is set True on return, then Is_Static_Expression is also set
-- true in node N. There are some cases where this is over-enthusiastic,
-- e.g. in the two operand case below, for string comparison, the result is
-- not static even though the two operands are static. In such cases, the
-- caller must reset the Is_Static_Expression flag in N.
--
-- If Fold and Stat are both set to False then this routine performs also
-- the following extra actions:
--
-- If either operand is Any_Type then propagate it to result to prevent
-- cascaded errors.
--
-- If some operand raises Constraint_Error, then replace the node N
-- with the raise Constraint_Error node. This replacement inherits the
-- Is_Static_Expression flag from the operands.
procedure Test_Expression_Is_Foldable
(N : Node_Id;
Op1 : Node_Id;
Op2 : Node_Id;
Stat : out Boolean;
Fold : out Boolean;
CRT_Safe : Boolean := False);
-- Same processing, except applies to an expression N with two operands
-- Op1 and Op2. The result is static only if both operands are static. If
-- CRT_Safe is set True, then CRT_Safe_Compile_Time_Known_Value is used
-- for the tests that the two operands are known at compile time. See
-- spec of this routine for further details.
function Test_In_Range
(N : Node_Id;
Typ : Entity_Id;
Assume_Valid : Boolean;
Fixed_Int : Boolean;
Int_Real : Boolean) return Range_Membership;
-- Common processing for Is_In_Range and Is_Out_Of_Range: Returns In_Range
-- or Out_Of_Range if it can be guaranteed at compile time that expression
-- N is known to be in or out of range of the subtype Typ. If not compile
-- time known, Unknown is returned. See documentation of Is_In_Range for
-- complete description of parameters.
procedure To_Bits (U : Uint; B : out Bits);
-- Converts a Uint value to a bit string of length B'Length
-----------------------------------------------
-- Check_Expression_Against_Static_Predicate --
-----------------------------------------------
procedure Check_Expression_Against_Static_Predicate
(Expr : Node_Id;
Typ : Entity_Id;
Static_Failure_Is_Error : Boolean := False)
is
begin
-- Nothing to do if expression is not known at compile time, or the
-- type has no static predicate set (will be the case for all non-scalar
-- types, so no need to make a special test for that).
if not (Has_Static_Predicate (Typ)
and then Compile_Time_Known_Value (Expr))
then
return;
end if;
-- Here we have a static predicate (note that it could have arisen from
-- an explicitly specified Dynamic_Predicate whose expression met the
-- rules for being predicate-static). If the expression is known at
-- compile time and obeys the predicate, then it is static and must be
-- labeled as such, which matters e.g. for case statements. The original
-- expression may be a type conversion of a variable with a known value,
-- which might otherwise not be marked static.
-- Case of real static predicate
if Is_Real_Type (Typ) then
if Real_Or_String_Static_Predicate_Matches
(Val => Make_Real_Literal (Sloc (Expr), Expr_Value_R (Expr)),
Typ => Typ)
then
Set_Is_Static_Expression (Expr);
return;
end if;
-- Case of string static predicate
elsif Is_String_Type (Typ) then
if Real_Or_String_Static_Predicate_Matches
(Val => Expr_Value_S (Expr), Typ => Typ)
then
Set_Is_Static_Expression (Expr);
return;
end if;
-- Case of discrete static predicate
else
pragma Assert (Is_Discrete_Type (Typ));
-- If static predicate matches, nothing to do
if Choices_Match (Expr, Static_Discrete_Predicate (Typ)) = Match then
Set_Is_Static_Expression (Expr);
return;
end if;
end if;
-- Here we know that the predicate will fail
-- Special case of static expression failing a predicate (other than one
-- that was explicitly specified with a Dynamic_Predicate aspect). If
-- the expression comes from a qualified_expression or type_conversion
-- this is an error (Static_Failure_Is_Error); otherwise we only issue
-- a warning and the expression is no longer considered static.
if Is_Static_Expression (Expr)
and then not Has_Dynamic_Predicate_Aspect (Typ)
then
if Static_Failure_Is_Error then
Error_Msg_NE
("static expression fails static predicate check on &",
Expr, Typ);
else
Error_Msg_NE
("??static expression fails static predicate check on &",
Expr, Typ);
Error_Msg_N
("\??expression is no longer considered static", Expr);
Set_Is_Static_Expression (Expr, False);
end if;
-- In all other cases, this is just a warning that a test will fail.
-- It does not matter if the expression is static or not, or if the
-- predicate comes from a dynamic predicate aspect or not.
else
Error_Msg_NE
("??expression fails predicate check on &", Expr, Typ);
-- Force a check here, which is potentially a redundant check, but
-- this ensures a check will be done in cases where the expression
-- is folded, and since this is definitely a failure, extra checks
-- are OK.
if Predicate_Enabled (Typ) then
Insert_Action (Expr,
Make_Predicate_Check
(Typ, Duplicate_Subexpr (Expr)), Suppress => All_Checks);
end if;
end if;
end Check_Expression_Against_Static_Predicate;
------------------------------
-- Check_Non_Static_Context --
------------------------------
procedure Check_Non_Static_Context (N : Node_Id) is
T : constant Entity_Id := Etype (N);
Checks_On : constant Boolean :=
not Index_Checks_Suppressed (T)
and not Range_Checks_Suppressed (T);
begin
-- Ignore cases of non-scalar types, error types, or universal real
-- types that have no usable bounds.
if T = Any_Type
or else not Is_Scalar_Type (T)
or else T = Universal_Fixed
or else T = Universal_Real
then
return;
end if;
-- At this stage we have a scalar type. If we have an expression that
-- raises CE, then we already issued a warning or error msg so there is
-- nothing more to be done in this routine.
if Raises_Constraint_Error (N) then
return;
end if;
-- Now we have a scalar type which is not marked as raising a constraint
-- error exception. The main purpose of this routine is to deal with
-- static expressions appearing in a non-static context. That means
-- that if we do not have a static expression then there is not much
-- to do. The one case that we deal with here is that if we have a
-- floating-point value that is out of range, then we post a warning
-- that an infinity will result.
if not Is_Static_Expression (N) then
if Is_Floating_Point_Type (T) then
if Is_Out_Of_Range (N, Base_Type (T), Assume_Valid => True) then
Error_Msg_N
("??float value out of range, infinity will be generated", N);
-- The literal may be the result of constant-folding of a non-
-- static subexpression of a larger expression (e.g. a conversion
-- of a non-static variable whose value happens to be known). At
-- this point we must reduce the value of the subexpression to a
-- machine number (RM 4.9 (38/2)).
elsif Nkind (N) = N_Real_Literal
and then Nkind (Parent (N)) in N_Subexpr
then
Rewrite (N, New_Copy (N));
Set_Realval (N, Machine_Number (Base_Type (T), Realval (N), N));
Set_Is_Machine_Number (N);
end if;
end if;
return;
end if;
-- Here we have the case of outer level static expression of scalar
-- type, where the processing of this procedure is needed.
-- For real types, this is where we convert the value to a machine
-- number (see RM 4.9(38)). Also see ACVC test C490001. We should only
-- need to do this if the parent is a constant declaration, since in
-- other cases, gigi should do the necessary conversion correctly, but
-- experimentation shows that this is not the case on all machines, in
-- particular if we do not convert all literals to machine values in
-- non-static contexts, then ACVC test C490001 fails on Sparc/Solaris
-- and SGI/Irix.
-- This conversion is always done by GNATprove on real literals in
-- non-static expressions, by calling Check_Non_Static_Context from
-- gnat2why, as GNATprove cannot do the conversion later contrary
-- to gigi. The frontend computes the information about which
-- expressions are static, which is used by gnat2why to call
-- Check_Non_Static_Context on exactly those real literals that are
-- not subexpressions of static expressions.
if Nkind (N) = N_Real_Literal
and then not Is_Machine_Number (N)
and then not Is_Generic_Type (Etype (N))
and then Etype (N) /= Universal_Real
then
-- Check that value is in bounds before converting to machine
-- number, so as not to lose case where value overflows in the
-- least significant bit or less. See B490001.
if Is_Out_Of_Range (N, Base_Type (T), Assume_Valid => True) then
Out_Of_Range (N);
return;
end if;
-- Note: we have to copy the node, to avoid problems with conformance
-- of very similar numbers (see ACVC tests B4A010C and B63103A).
Rewrite (N, New_Copy (N));
if not Is_Floating_Point_Type (T) then
Set_Realval
(N, Corresponding_Integer_Value (N) * Small_Value (T));
elsif not UR_Is_Zero (Realval (N)) then
Set_Realval (N, Machine_Number (Base_Type (T), Realval (N), N));
Set_Is_Machine_Number (N);
end if;
end if;
-- Check for out of range universal integer. This is a non-static
-- context, so the integer value must be in range of the runtime
-- representation of universal integers.
-- We do this only within an expression, because that is the only
-- case in which non-static universal integer values can occur, and
-- furthermore, Check_Non_Static_Context is currently (incorrectly???)
-- called in contexts like the expression of a number declaration where
-- we certainly want to allow out of range values.
-- We inhibit the warning when expansion is disabled, because the
-- preanalysis of a range of a 64-bit modular type may appear to
-- violate the constraint on non-static Universal_Integer. If there
-- is a true overflow it will be diagnosed during full analysis.
if Etype (N) = Universal_Integer
and then Nkind (N) = N_Integer_Literal
and then Nkind (Parent (N)) in N_Subexpr
and then Expander_Active
and then
(Intval (N) < Expr_Value (Type_Low_Bound (Universal_Integer))
or else
Intval (N) > Expr_Value (Type_High_Bound (Universal_Integer)))
then
Apply_Compile_Time_Constraint_Error
(N, "non-static universal integer value out of range<<",
CE_Range_Check_Failed);
-- Check out of range of base type
elsif Is_Out_Of_Range (N, Base_Type (T), Assume_Valid => True) then
Out_Of_Range (N);
-- Give a warning or error on the value outside the subtype. A warning
-- is omitted if the expression appears in a range that could be null
-- (warnings are handled elsewhere for this case).
elsif T /= Base_Type (T) and then Nkind (Parent (N)) /= N_Range then
if Is_In_Range (N, T, Assume_Valid => True) then
null;
elsif Is_Out_Of_Range (N, T, Assume_Valid => True) then
-- Ignore out of range values for System.Priority in CodePeer
-- mode since the actual target compiler may provide a wider
-- range.
if CodePeer_Mode and then Is_RTE (T, RE_Priority) then
Set_Do_Range_Check (N, False);
-- Determine if the out-of-range violation constitutes a warning
-- or an error based on context, according to RM 4.9 (34/3).
elsif Nkind (Original_Node (N)) in
N_Type_Conversion | N_Qualified_Expression
and then Comes_From_Source (Original_Node (N))
then
Apply_Compile_Time_Constraint_Error
(N, "value not in range of}", CE_Range_Check_Failed);
else
Apply_Compile_Time_Constraint_Error
(N, "value not in range of}<<", CE_Range_Check_Failed);
end if;
elsif Checks_On then
Enable_Range_Check (N);
else
Set_Do_Range_Check (N, False);
end if;
end if;
end Check_Non_Static_Context;
-------------------------------------------
-- Check_Non_Static_Context_For_Overflow --
-------------------------------------------
procedure Check_Non_Static_Context_For_Overflow
(N : Node_Id;
Stat : Boolean;
Result : Uint)
is
begin
if (not Stat or else In_Inlined_Body)
and then Is_Signed_Integer_Type (Etype (N))
then
declare
BT : constant Entity_Id := Base_Type (Etype (N));
Lo : constant Uint := Expr_Value (Type_Low_Bound (BT));
Hi : constant Uint := Expr_Value (Type_High_Bound (BT));
begin
if Result < Lo or else Result > Hi then
Apply_Compile_Time_Constraint_Error
(N, "value not in range of }??",
CE_Overflow_Check_Failed,
Ent => BT);
end if;
end;
end if;
end Check_Non_Static_Context_For_Overflow;
---------------------------------
-- Check_String_Literal_Length --
---------------------------------
procedure Check_String_Literal_Length (N : Node_Id; Ttype : Entity_Id) is
begin
if not Raises_Constraint_Error (N) and then Is_Constrained (Ttype) then
if UI_From_Int (String_Length (Strval (N))) /= String_Type_Len (Ttype)
then
Apply_Compile_Time_Constraint_Error
(N, "string length wrong for}??",
CE_Length_Check_Failed,
Ent => Ttype,
Typ => Ttype);
end if;
end if;
end Check_String_Literal_Length;
--------------------------------------------
-- Checking_Potentially_Static_Expression --
--------------------------------------------
function Checking_Potentially_Static_Expression return Boolean is
begin
return Checking_For_Potentially_Static_Expression;
end Checking_Potentially_Static_Expression;
--------------------
-- Choice_Matches --
--------------------
function Choice_Matches
(Expr : Node_Id;
Choice : Node_Id) return Match_Result
is
Etyp : constant Entity_Id := Etype (Expr);
Val : Uint;
ValR : Ureal;
ValS : Node_Id;
begin
pragma Assert (Compile_Time_Known_Value (Expr));
pragma Assert (Is_Scalar_Type (Etyp) or else Is_String_Type (Etyp));
if not Is_OK_Static_Choice (Choice) then
Set_Raises_Constraint_Error (Choice);
return Non_Static;
-- When the choice denotes a subtype with a static predictate, check the
-- expression against the predicate values. Different procedures apply
-- to discrete and non-discrete types.
elsif (Nkind (Choice) = N_Subtype_Indication
or else (Is_Entity_Name (Choice)
and then Is_Type (Entity (Choice))))
and then Has_Predicates (Etype (Choice))
and then Has_Static_Predicate (Etype (Choice))
then
if Is_Discrete_Type (Etype (Choice)) then
return
Choices_Match
(Expr, Static_Discrete_Predicate (Etype (Choice)));
elsif Real_Or_String_Static_Predicate_Matches (Expr, Etype (Choice))
then
return Match;
else
return No_Match;
end if;
-- Discrete type case only
elsif Is_Discrete_Type (Etyp) then
Val := Expr_Value (Expr);
if Nkind (Choice) = N_Range then
if Val >= Expr_Value (Low_Bound (Choice))
and then
Val <= Expr_Value (High_Bound (Choice))
then
return Match;
else
return No_Match;
end if;
elsif Nkind (Choice) = N_Subtype_Indication
or else (Is_Entity_Name (Choice) and then Is_Type (Entity (Choice)))
then
if Val >= Expr_Value (Type_Low_Bound (Etype (Choice)))
and then
Val <= Expr_Value (Type_High_Bound (Etype (Choice)))
then
return Match;
else
return No_Match;
end if;
elsif Nkind (Choice) = N_Others_Choice then
return Match;
else
if Val = Expr_Value (Choice) then
return Match;
else
return No_Match;
end if;
end if;
-- Real type case
elsif Is_Real_Type (Etyp) then
ValR := Expr_Value_R (Expr);
if Nkind (Choice) = N_Range then
if ValR >= Expr_Value_R (Low_Bound (Choice))
and then
ValR <= Expr_Value_R (High_Bound (Choice))
then
return Match;
else
return No_Match;
end if;
elsif Nkind (Choice) = N_Subtype_Indication
or else (Is_Entity_Name (Choice) and then Is_Type (Entity (Choice)))
then
if ValR >= Expr_Value_R (Type_Low_Bound (Etype (Choice)))
and then
ValR <= Expr_Value_R (Type_High_Bound (Etype (Choice)))
then
return Match;
else
return No_Match;
end if;
else
if ValR = Expr_Value_R (Choice) then
return Match;
else
return No_Match;
end if;
end if;
-- String type cases
else
pragma Assert (Is_String_Type (Etyp));
ValS := Expr_Value_S (Expr);
if Nkind (Choice) = N_Subtype_Indication
or else (Is_Entity_Name (Choice) and then Is_Type (Entity (Choice)))
then
if not Is_Constrained (Etype (Choice)) then
return Match;
else
declare
Typlen : constant Uint :=
String_Type_Len (Etype (Choice));
Strlen : constant Uint :=
UI_From_Int (String_Length (Strval (ValS)));
begin
if Typlen = Strlen then
return Match;
else
return No_Match;
end if;
end;
end if;
else
if String_Equal (Strval (ValS), Strval (Expr_Value_S (Choice)))
then
return Match;
else
return No_Match;
end if;
end if;
end if;
end Choice_Matches;
-------------------
-- Choices_Match --
-------------------
function Choices_Match
(Expr : Node_Id;
Choices : List_Id) return Match_Result
is
Choice : Node_Id;
Result : Match_Result;
begin
Choice := First (Choices);
while Present (Choice) loop
Result := Choice_Matches (Expr, Choice);
if Result /= No_Match then
return Result;
end if;
Next (Choice);
end loop;
return No_Match;
end Choices_Match;
--------------------------
-- Compile_Time_Compare --
--------------------------
function Compile_Time_Compare
(L, R : Node_Id;
Assume_Valid : Boolean) return Compare_Result
is
Discard : aliased Uint;
begin
return Compile_Time_Compare (L, R, Discard'Access, Assume_Valid);
end Compile_Time_Compare;
function Compile_Time_Compare
(L, R : Node_Id;
Diff : access Uint;
Assume_Valid : Boolean;
Rec : Boolean := False) return Compare_Result
is
Ltyp : Entity_Id := Etype (L);
Rtyp : Entity_Id := Etype (R);
Discard : aliased Uint;
procedure Compare_Decompose
(N : Node_Id;
R : out Node_Id;
V : out Uint);
-- This procedure decomposes the node N into an expression node and a
-- signed offset, so that the value of N is equal to the value of R plus
-- the value V (which may be negative). If no such decomposition is
-- possible, then on return R is a copy of N, and V is set to zero.
function Compare_Fixup (N : Node_Id) return Node_Id;
-- This function deals with replacing 'Last and 'First references with
-- their corresponding type bounds, which we then can compare. The
-- argument is the original node, the result is the identity, unless we
-- have a 'Last/'First reference in which case the value returned is the
-- appropriate type bound.
function Is_Known_Valid_Operand (Opnd : Node_Id) return Boolean;
-- Even if the context does not assume that values are valid, some
-- simple cases can be recognized.
function Is_Same_Value (L, R : Node_Id) return Boolean;
-- Returns True iff L and R represent expressions that definitely have
-- identical (but not necessarily compile-time-known) values Indeed the
-- caller is expected to have already dealt with the cases of compile
-- time known values, so these are not tested here.
-----------------------
-- Compare_Decompose --
-----------------------
procedure Compare_Decompose
(N : Node_Id;
R : out Node_Id;
V : out Uint)
is
begin
if Nkind (N) = N_Op_Add
and then Nkind (Right_Opnd (N)) = N_Integer_Literal
then
R := Left_Opnd (N);
V := Intval (Right_Opnd (N));
return;
elsif Nkind (N) = N_Op_Subtract
and then Nkind (Right_Opnd (N)) = N_Integer_Literal
then
R := Left_Opnd (N);
V := UI_Negate (Intval (Right_Opnd (N)));
return;
elsif Nkind (N) = N_Attribute_Reference then
if Attribute_Name (N) = Name_Succ then
R := First (Expressions (N));
V := Uint_1;
return;
elsif Attribute_Name (N) = Name_Pred then
R := First (Expressions (N));
V := Uint_Minus_1;
return;
end if;
end if;
R := N;
V := Uint_0;
end Compare_Decompose;
-------------------
-- Compare_Fixup --
-------------------
function Compare_Fixup (N : Node_Id) return Node_Id is
Indx : Node_Id;
Xtyp : Entity_Id;
Subs : Nat;
begin
-- Fixup only required for First/Last attribute reference
if Nkind (N) = N_Attribute_Reference
and then Attribute_Name (N) in Name_First | Name_Last
then
Xtyp := Etype (Prefix (N));
-- If we have no type, then just abandon the attempt to do
-- a fixup, this is probably the result of some other error.
if No (Xtyp) then
return N;
end if;
-- Dereference an access type
if Is_Access_Type (Xtyp) then
Xtyp := Designated_Type (Xtyp);
end if;
-- If we don't have an array type at this stage, something is
-- peculiar, e.g. another error, and we abandon the attempt at
-- a fixup.
if not Is_Array_Type (Xtyp) then
return N;
end if;
-- Ignore unconstrained array, since bounds are not meaningful
if not Is_Constrained (Xtyp) then
return N;
end if;
if Ekind (Xtyp) = E_String_Literal_Subtype then
if Attribute_Name (N) = Name_First then
return String_Literal_Low_Bound (Xtyp);
else
return
Make_Integer_Literal (Sloc (N),
Intval => Intval (String_Literal_Low_Bound (Xtyp)) +
String_Literal_Length (Xtyp));
end if;
end if;
-- Find correct index type
Indx := First_Index (Xtyp);
if Present (Expressions (N)) then
Subs := UI_To_Int (Expr_Value (First (Expressions (N))));
for J in 2 .. Subs loop
Next_Index (Indx);
end loop;
end if;
Xtyp := Etype (Indx);
if Attribute_Name (N) = Name_First then
return Type_Low_Bound (Xtyp);
else
return Type_High_Bound (Xtyp);
end if;
end if;
return N;
end Compare_Fixup;
----------------------------
-- Is_Known_Valid_Operand --
----------------------------
function Is_Known_Valid_Operand (Opnd : Node_Id) return Boolean is
begin
return (Is_Entity_Name (Opnd)
and then
(Is_Known_Valid (Entity (Opnd))
or else Ekind (Entity (Opnd)) = E_In_Parameter
or else
(Is_Object (Entity (Opnd))
and then Present (Current_Value (Entity (Opnd))))))
or else Is_OK_Static_Expression (Opnd);
end Is_Known_Valid_Operand;
-------------------
-- Is_Same_Value --
-------------------
function Is_Same_Value (L, R : Node_Id) return Boolean is
Lf : constant Node_Id := Compare_Fixup (L);
Rf : constant Node_Id := Compare_Fixup (R);
function Is_Rewritten_Loop_Entry (N : Node_Id) return Boolean;
-- An attribute reference to Loop_Entry may have been rewritten into
-- its prefix as a way to avoid generating a constant for that
-- attribute when the corresponding pragma is ignored. These nodes
-- should be ignored when deciding if they can be equal to one
-- another.
function Is_Same_Subscript (L, R : List_Id) return Boolean;
-- L, R are the Expressions values from two attribute nodes for First
-- or Last attributes. Either may be set to No_List if no expressions
-- are present (indicating subscript 1). The result is True if both
-- expressions represent the same subscript (note one case is where
-- one subscript is missing and the other is explicitly set to 1).
-----------------------------
-- Is_Rewritten_Loop_Entry --
-----------------------------
function Is_Rewritten_Loop_Entry (N : Node_Id) return Boolean is
Orig_N : constant Node_Id := Original_Node (N);
begin
return Orig_N /= N
and then Nkind (Orig_N) = N_Attribute_Reference
and then Get_Attribute_Id (Attribute_Name (Orig_N)) =
Attribute_Loop_Entry;
end Is_Rewritten_Loop_Entry;
-----------------------
-- Is_Same_Subscript --
-----------------------
function Is_Same_Subscript (L, R : List_Id) return Boolean is
begin
if L = No_List then
if R = No_List then
return True;
else
return Expr_Value (First (R)) = Uint_1;
end if;
else
if R = No_List then
return Expr_Value (First (L)) = Uint_1;
else
return Expr_Value (First (L)) = Expr_Value (First (R));
end if;
end if;
end Is_Same_Subscript;
-- Start of processing for Is_Same_Value
begin
-- Loop_Entry nodes rewritten into their prefix inside ignored
-- pragmas should never lead to a decision of equality.
if Is_Rewritten_Loop_Entry (Lf)
or else Is_Rewritten_Loop_Entry (Rf)
then
return False;
-- Values are the same if they refer to the same entity and the
-- entity is nonvolatile.
elsif Nkind (Lf) in N_Identifier | N_Expanded_Name
and then Nkind (Rf) in N_Identifier | N_Expanded_Name
and then Entity (Lf) = Entity (Rf)
-- If the entity is a discriminant, the two expressions may be
-- bounds of components of objects of the same discriminated type.
-- The values of the discriminants are not static, and therefore
-- the result is unknown.
and then Ekind (Entity (Lf)) /= E_Discriminant
and then Present (Entity (Lf))
-- This does not however apply to Float types, since we may have
-- two NaN values and they should never compare equal.
and then not Is_Floating_Point_Type (Etype (L))
and then not Is_Volatile_Reference (L)
and then not Is_Volatile_Reference (R)
then
return True;
-- Or if they are compile-time-known and identical
elsif Compile_Time_Known_Value (Lf)
and then
Compile_Time_Known_Value (Rf)
and then Expr_Value (Lf) = Expr_Value (Rf)
then
return True;
-- False if Nkind of the two nodes is different for remaining cases
elsif Nkind (Lf) /= Nkind (Rf) then
return False;
-- True if both 'First or 'Last values applying to the same entity
-- (first and last don't change even if value does). Note that we
-- need this even with the calls to Compare_Fixup, to handle the
-- case of unconstrained array attributes where Compare_Fixup
-- cannot find useful bounds.
elsif Nkind (Lf) = N_Attribute_Reference
and then Attribute_Name (Lf) = Attribute_Name (Rf)
and then Attribute_Name (Lf) in Name_First | Name_Last
and then Nkind (Prefix (Lf)) in N_Identifier | N_Expanded_Name
and then Nkind (Prefix (Rf)) in N_Identifier | N_Expanded_Name
and then Entity (Prefix (Lf)) = Entity (Prefix (Rf))
and then Is_Same_Subscript (Expressions (Lf), Expressions (Rf))
then
return True;
-- True if the same selected component from the same record
elsif Nkind (Lf) = N_Selected_Component
and then Selector_Name (Lf) = Selector_Name (Rf)
and then Is_Same_Value (Prefix (Lf), Prefix (Rf))
then
return True;
-- True if the same unary operator applied to the same operand
elsif Nkind (Lf) in N_Unary_Op
and then Is_Same_Value (Right_Opnd (Lf), Right_Opnd (Rf))
then
return True;
-- True if the same binary operator applied to the same operands
elsif Nkind (Lf) in N_Binary_Op
and then Is_Same_Value (Left_Opnd (Lf), Left_Opnd (Rf))
and then Is_Same_Value (Right_Opnd (Lf), Right_Opnd (Rf))
then
return True;
-- All other cases, we can't tell, so return False
else
return False;
end if;
end Is_Same_Value;
-- Start of processing for Compile_Time_Compare
begin
Diff.all := No_Uint;
-- In preanalysis mode, always return Unknown unless the expression
-- is static. It is too early to be thinking we know the result of a
-- comparison, save that judgment for the full analysis. This is
-- particularly important in the case of pre and postconditions, which
-- otherwise can be prematurely collapsed into having True or False
-- conditions when this is inappropriate.
if not (Full_Analysis
or else (Is_OK_Static_Expression (L)
and then
Is_OK_Static_Expression (R)))
then
return Unknown;
end if;
-- If either operand could raise Constraint_Error, then we cannot
-- know the result at compile time (since CE may be raised).
if not (Cannot_Raise_Constraint_Error (L)
and then
Cannot_Raise_Constraint_Error (R))
then
return Unknown;
end if;
-- Identical operands are most certainly equal
if L = R then
return EQ;
end if;
-- If expressions have no types, then do not attempt to determine if
-- they are the same, since something funny is going on. One case in
-- which this happens is during generic template analysis, when bounds
-- are not fully analyzed.
if No (Ltyp) or else No (Rtyp) then
return Unknown;
end if;
-- These get reset to the base type for the case of entities where
-- Is_Known_Valid is not set. This takes care of handling possible
-- invalid representations using the value of the base type, in
-- accordance with RM 13.9.1(10).
Ltyp := Underlying_Type (Ltyp);
Rtyp := Underlying_Type (Rtyp);
-- Same rationale as above, but for Underlying_Type instead of Etype
if No (Ltyp) or else No (Rtyp) then
return Unknown;
end if;
-- We do not attempt comparisons for packed arrays represented as
-- modular types, where the semantics of comparison is quite different.
if Is_Packed_Array_Impl_Type (Ltyp)
and then Is_Modular_Integer_Type (Ltyp)
then
return Unknown;
-- For access types, the only time we know the result at compile time
-- (apart from identical operands, which we handled already) is if we
-- know one operand is null and the other is not, or both operands are
-- known null.
elsif Is_Access_Type (Ltyp) then
if Known_Null (L) then
if Known_Null (R) then
return EQ;
elsif Known_Non_Null (R) then
return NE;
else
return Unknown;
end if;
elsif Known_Non_Null (L) and then Known_Null (R) then
return NE;
else
return Unknown;
end if;
-- Case where comparison involves two compile-time-known values
elsif Compile_Time_Known_Value (L)
and then
Compile_Time_Known_Value (R)
then
-- For the floating-point case, we have to be a little careful, since
-- at compile time we are dealing with universal exact values, but at
-- runtime, these will be in non-exact target form. That's why the
-- returned results are LE and GE below instead of LT and GT.
if Is_Floating_Point_Type (Ltyp)
or else
Is_Floating_Point_Type (Rtyp)
then
declare
Lo : constant Ureal := Expr_Value_R (L);
Hi : constant Ureal := Expr_Value_R (R);
begin
if Lo < Hi then
return LE;
elsif Lo = Hi then
return EQ;
else
return GE;
end if;
end;
-- For string types, we have two string literals and we proceed to
-- compare them using the Ada style dictionary string comparison.
elsif not Is_Scalar_Type (Ltyp) then
declare
Lstring : constant String_Id := Strval (Expr_Value_S (L));
Rstring : constant String_Id := Strval (Expr_Value_S (R));
Llen : constant Nat := String_Length (Lstring);
Rlen : constant Nat := String_Length (Rstring);
begin
for J in 1 .. Nat'Min (Llen, Rlen) loop
declare
LC : constant Char_Code := Get_String_Char (Lstring, J);
RC : constant Char_Code := Get_String_Char (Rstring, J);
begin
if LC < RC then
return LT;
elsif LC > RC then
return GT;
end if;
end;
end loop;
if Llen < Rlen then
return LT;
elsif Llen > Rlen then
return GT;
else
return EQ;
end if;
end;
-- For remaining scalar cases we know exactly (note that this does
-- include the fixed-point case, where we know the run time integer
-- values now).
else
declare
Lo : constant Uint := Expr_Value (L);
Hi : constant Uint := Expr_Value (R);
begin
if Lo < Hi then
Diff.all := Hi - Lo;
return LT;
elsif Lo = Hi then
return EQ;
else
Diff.all := Lo - Hi;
return GT;
end if;
end;
end if;
-- Cases where at least one operand is not known at compile time
else
-- Remaining checks apply only for discrete types
if not Is_Discrete_Type (Ltyp)
or else
not Is_Discrete_Type (Rtyp)
then
return Unknown;
end if;
-- Defend against generic types, or actually any expressions that
-- contain a reference to a generic type from within a generic
-- template. We don't want to do any range analysis of such
-- expressions for two reasons. First, the bounds of a generic type
-- itself are junk and cannot be used for any kind of analysis.
-- Second, we may have a case where the range at run time is indeed
-- known, but we don't want to do compile time analysis in the
-- template based on that range since in an instance the value may be
-- static, and able to be elaborated without reference to the bounds
-- of types involved. As an example, consider:
-- (F'Pos (F'Last) + 1) > Integer'Last
-- The expression on the left side of > is Universal_Integer and thus
-- acquires the type Integer for evaluation at run time, and at run
-- time it is true that this condition is always False, but within
-- an instance F may be a type with a static range greater than the
-- range of Integer, and the expression statically evaluates to True.
if References_Generic_Formal_Type (L)
or else
References_Generic_Formal_Type (R)
then
return Unknown;
end if;
-- Replace types by base types for the case of values which are not
-- known to have valid representations. This takes care of properly
-- dealing with invalid representations.
if not Assume_Valid then
if not (Is_Entity_Name (L)
and then (Is_Known_Valid (Entity (L))
or else Assume_No_Invalid_Values))
then
Ltyp := Underlying_Type (Base_Type (Ltyp));
end if;
if not (Is_Entity_Name (R)
and then (Is_Known_Valid (Entity (R))
or else Assume_No_Invalid_Values))
then
Rtyp := Underlying_Type (Base_Type (Rtyp));
end if;
end if;
-- First attempt is to decompose the expressions to extract a
-- constant offset resulting from the use of any of the forms:
-- expr + literal
-- expr - literal
-- typ'Succ (expr)
-- typ'Pred (expr)
-- Then we see if the two expressions are the same value, and if so
-- the result is obtained by comparing the offsets.
-- Note: the reason we do this test first is that it returns only
-- decisive results (with diff set), where other tests, like the
-- range test, may not be as so decisive. Consider for example
-- J .. J + 1. This code can conclude LT with a difference of 1,
-- even if the range of J is not known.
declare
Lnode : Node_Id;
Loffs : Uint;
Rnode : Node_Id;
Roffs : Uint;
begin
Compare_Decompose (L, Lnode, Loffs);
Compare_Decompose (R, Rnode, Roffs);
if Is_Same_Value (Lnode, Rnode) then
if Loffs = Roffs then
return EQ;
end if;
-- When the offsets are not equal, we can go farther only if
-- the types are not modular (e.g. X < X + 1 is False if X is
-- the largest number).
if not Is_Modular_Integer_Type (Ltyp)
and then not Is_Modular_Integer_Type (Rtyp)
then
if Loffs < Roffs then
Diff.all := Roffs - Loffs;
return LT;
else
Diff.all := Loffs - Roffs;
return GT;
end if;
end if;
end if;
end;
-- Next, try range analysis and see if operand ranges are disjoint
declare
LOK, ROK : Boolean;
LLo, LHi : Uint;
RLo, RHi : Uint;
Single : Boolean;
-- True if each range is a single point
begin
Determine_Range (L, LOK, LLo, LHi, Assume_Valid);
Determine_Range (R, ROK, RLo, RHi, Assume_Valid);
if LOK and ROK then
Single := (LLo = LHi) and then (RLo = RHi);
if LHi < RLo then
if Single and Assume_Valid then
Diff.all := RLo - LLo;
end if;
return LT;
elsif RHi < LLo then
if Single and Assume_Valid then
Diff.all := LLo - RLo;
end if;
return GT;
elsif Single and then LLo = RLo then
-- If the range includes a single literal and we can assume
-- validity then the result is known even if an operand is
-- not static.
if Assume_Valid then
return EQ;
else
return Unknown;
end if;
elsif LHi = RLo then
return LE;
elsif RHi = LLo then
return GE;
elsif not Is_Known_Valid_Operand (L)
and then not Assume_Valid
then
if Is_Same_Value (L, R) then
return EQ;
else
return Unknown;
end if;
end if;
-- If the range of either operand cannot be determined, nothing
-- further can be inferred.
else
return Unknown;
end if;
end;
-- Here is where we check for comparisons against maximum bounds of
-- types, where we know that no value can be outside the bounds of
-- the subtype. Note that this routine is allowed to assume that all
-- expressions are within their subtype bounds. Callers wishing to
-- deal with possibly invalid values must in any case take special
-- steps (e.g. conversions to larger types) to avoid this kind of
-- optimization, which is always considered to be valid. We do not
-- attempt this optimization with generic types, since the type
-- bounds may not be meaningful in this case.
-- We are in danger of an infinite recursion here. It does not seem
-- useful to go more than one level deep, so the parameter Rec is
-- used to protect ourselves against this infinite recursion.
if not Rec then
-- See if we can get a decisive check against one operand and a
-- bound of the other operand (four possible tests here). Note
-- that we avoid testing junk bounds of a generic type.
if not Is_Generic_Type (Rtyp) then
case Compile_Time_Compare (L, Type_Low_Bound (Rtyp),
Discard'Access,
Assume_Valid, Rec => True)
is
when LT => return LT;
when LE => return LE;
when EQ => return LE;
when others => null;
end case;
case Compile_Time_Compare (L, Type_High_Bound (Rtyp),
Discard'Access,
Assume_Valid, Rec => True)
is
when GT => return GT;
when GE => return GE;
when EQ => return GE;
when others => null;
end case;
end if;
if not Is_Generic_Type (Ltyp) then
case Compile_Time_Compare (Type_Low_Bound (Ltyp), R,
Discard'Access,
Assume_Valid, Rec => True)
is
when GT => return GT;
when GE => return GE;
when EQ => return GE;
when others => null;
end case;
case Compile_Time_Compare (Type_High_Bound (Ltyp), R,
Discard'Access,
Assume_Valid, Rec => True)
is
when LT => return LT;
when LE => return LE;
when EQ => return LE;
when others => null;
end case;
end if;
end if;
-- Next attempt is to see if we have an entity compared with a
-- compile-time-known value, where there is a current value
-- conditional for the entity which can tell us the result.
declare
Var : Node_Id;
-- Entity variable (left operand)
Val : Uint;
-- Value (right operand)
Inv : Boolean;
-- If False, we have reversed the operands
Op : Node_Kind;
-- Comparison operator kind from Get_Current_Value_Condition call
Opn : Node_Id;
-- Value from Get_Current_Value_Condition call
Opv : Uint;
-- Value of Opn
Result : Compare_Result;
-- Known result before inversion
begin
if Is_Entity_Name (L)
and then Compile_Time_Known_Value (R)
then
Var := L;
Val := Expr_Value (R);
Inv := False;
elsif Is_Entity_Name (R)
and then Compile_Time_Known_Value (L)
then
Var := R;
Val := Expr_Value (L);
Inv := True;
-- That was the last chance at finding a compile time result
else
return Unknown;
end if;
Get_Current_Value_Condition (Var, Op, Opn);
-- That was the last chance, so if we got nothing return
if No (Opn) then
return Unknown;
end if;
Opv := Expr_Value (Opn);
-- We got a comparison, so we might have something interesting
-- Convert LE to LT and GE to GT, just so we have fewer cases
if Op = N_Op_Le then
Op := N_Op_Lt;
Opv := Opv + 1;
elsif Op = N_Op_Ge then
Op := N_Op_Gt;
Opv := Opv - 1;
end if;
-- Deal with equality case
if Op = N_Op_Eq then
if Val = Opv then
Result := EQ;
elsif Opv < Val then
Result := LT;
else
Result := GT;
end if;
-- Deal with inequality case
elsif Op = N_Op_Ne then
if Val = Opv then
Result := NE;
else
return Unknown;
end if;
-- Deal with greater than case
elsif Op = N_Op_Gt then
if Opv >= Val then
Result := GT;
elsif Opv = Val - 1 then
Result := GE;
else
return Unknown;
end if;
-- Deal with less than case
else pragma Assert (Op = N_Op_Lt);
if Opv <= Val then
Result := LT;
elsif Opv = Val + 1 then
Result := LE;
else
return Unknown;
end if;
end if;
-- Deal with inverting result
if Inv then
case Result is
when GT => return LT;
when GE => return LE;
when LT => return GT;
when LE => return GE;
when others => return Result;
end case;
end if;
return Result;
end;
end if;
end Compile_Time_Compare;
-------------------------------
-- Compile_Time_Known_Bounds --
-------------------------------
function Compile_Time_Known_Bounds (T : Entity_Id) return Boolean is
Indx : Node_Id;
Typ : Entity_Id;
begin
if T = Any_Composite or else not Is_Array_Type (T) then
return False;
end if;
Indx := First_Index (T);
while Present (Indx) loop
Typ := Underlying_Type (Etype (Indx));
-- Never look at junk bounds of a generic type
if Is_Generic_Type (Typ) then
return False;
end if;
-- Otherwise check bounds for compile-time-known
if not Compile_Time_Known_Value (Type_Low_Bound (Typ)) then
return False;
elsif not Compile_Time_Known_Value (Type_High_Bound (Typ)) then
return False;
else
Next_Index (Indx);
end if;
end loop;
return True;
end Compile_Time_Known_Bounds;
------------------------------
-- Compile_Time_Known_Value --
------------------------------
function Compile_Time_Known_Value (Op : Node_Id) return Boolean is
K : constant Node_Kind := Nkind (Op);
CV_Ent : CV_Entry renames CV_Cache (Nat (Op) mod CV_Cache_Size);
begin
-- Never known at compile time if bad type or raises Constraint_Error
-- or empty (latter case occurs only as a result of a previous error).
if No (Op) then
Check_Error_Detected;
return False;
elsif Op = Error
or else Etype (Op) = Any_Type
or else Raises_Constraint_Error (Op)
then
return False;
end if;
-- If we have an entity name, then see if it is the name of a constant
-- and if so, test the corresponding constant value, or the name of an
-- enumeration literal, which is always a constant.
if Present (Etype (Op)) and then Is_Entity_Name (Op) then
declare
Ent : constant Entity_Id := Entity (Op);
Val : Node_Id;
begin
-- Never known at compile time if it is a packed array value. We
-- might want to try to evaluate these at compile time one day,
-- but we do not make that attempt now.
if Is_Packed_Array_Impl_Type (Etype (Op)) then
return False;
elsif Ekind (Ent) = E_Enumeration_Literal then
return True;
elsif Ekind (Ent) = E_Constant then
Val := Constant_Value (Ent);
if Present (Val) then
-- Guard against an illegal deferred constant whose full
-- view is initialized with a reference to itself. Treat
-- this case as a value not known at compile time.
if Is_Entity_Name (Val) and then Entity (Val) = Ent then
return False;
else
return Compile_Time_Known_Value (Val);
end if;
-- Otherwise, the constant does not have a compile-time-known
-- value.
else
return False;
end if;
end if;
end;
-- We have a value, see if it is compile-time-known
else
-- Integer literals are worth storing in the cache
if K = N_Integer_Literal then
CV_Ent.N := Op;
CV_Ent.V := Intval (Op);
return True;
-- Other literals and NULL are known at compile time
elsif K in
N_Character_Literal | N_Real_Literal | N_String_Literal | N_Null
then
return True;
-- Evaluate static discriminants, to eliminate dead paths and
-- redundant discriminant checks.
elsif Is_Static_Discriminant_Component (Op) then
return True;
end if;
end if;
-- If we fall through, not known at compile time
return False;
-- If we get an exception while trying to do this test, then some error
-- has occurred, and we simply say that the value is not known after all
exception
when others =>
-- With debug flag K we will get an exception unless an error has
-- already occurred (useful for debugging).
if Debug_Flag_K then
Check_Error_Detected;
end if;
return False;
end Compile_Time_Known_Value;
---------------------------------------
-- CRT_Safe_Compile_Time_Known_Value --
---------------------------------------
function CRT_Safe_Compile_Time_Known_Value (Op : Node_Id) return Boolean is
begin
if (Configurable_Run_Time_Mode or No_Run_Time_Mode)
and then not Is_OK_Static_Expression (Op)
then
return False;
else
return Compile_Time_Known_Value (Op);
end if;
end CRT_Safe_Compile_Time_Known_Value;
-----------------
-- Eval_Actual --
-----------------
-- This is only called for actuals of functions that are not predefined
-- operators (which have already been rewritten as operators at this
-- stage), so the call can never be folded, and all that needs doing for
-- the actual is to do the check for a non-static context.
procedure Eval_Actual (N : Node_Id) is
begin
Check_Non_Static_Context (N);
end Eval_Actual;
--------------------
-- Eval_Allocator --
--------------------
-- Allocators are never static, so all we have to do is to do the
-- check for a non-static context if an expression is present.
procedure Eval_Allocator (N : Node_Id) is
Expr : constant Node_Id := Expression (N);
begin
if Nkind (Expr) = N_Qualified_Expression then
Check_Non_Static_Context (Expression (Expr));
end if;
end Eval_Allocator;
------------------------
-- Eval_Arithmetic_Op --
------------------------
-- Arithmetic operations are static functions, so the result is static
-- if both operands are static (RM 4.9(7), 4.9(20)).
procedure Eval_Arithmetic_Op (N : Node_Id) is
Left : constant Node_Id := Left_Opnd (N);
Right : constant Node_Id := Right_Opnd (N);
Ltype : constant Entity_Id := Etype (Left);
Rtype : constant Entity_Id := Etype (Right);
Otype : Entity_Id := Empty;
Stat : Boolean;
Fold : Boolean;
begin
-- If not foldable we are done
Test_Expression_Is_Foldable (N, Left, Right, Stat, Fold);
if not Fold then
return;
end if;
-- Otherwise attempt to fold
if Is_Universal_Numeric_Type (Etype (Left))
and then
Is_Universal_Numeric_Type (Etype (Right))
then
Otype := Find_Universal_Operator_Type (N);
end if;
-- Fold for cases where both operands are of integer type
if Is_Integer_Type (Ltype) and then Is_Integer_Type (Rtype) then
declare
Left_Int : constant Uint := Expr_Value (Left);
Right_Int : constant Uint := Expr_Value (Right);
Result : Uint;
begin
case Nkind (N) is
when N_Op_Add =>
Result := Left_Int + Right_Int;
when N_Op_Subtract =>
Result := Left_Int - Right_Int;
when N_Op_Multiply =>
if OK_Bits
(N, UI_From_Int
(Num_Bits (Left_Int) + Num_Bits (Right_Int)))
then
Result := Left_Int * Right_Int;
else
Result := Left_Int;
end if;
when N_Op_Divide =>
-- The exception Constraint_Error is raised by integer
-- division, rem and mod if the right operand is zero.
if Right_Int = 0 then
-- When SPARK_Mode is On, force a warning instead of
-- an error in that case, as this likely corresponds
-- to deactivated code.
Apply_Compile_Time_Constraint_Error
(N, "division by zero", CE_Divide_By_Zero,
Loc => Sloc (Right),
Warn => not Stat or SPARK_Mode = On);
return;
-- Otherwise we can do the division
else
Result := Left_Int / Right_Int;
end if;
when N_Op_Mod =>
-- The exception Constraint_Error is raised by integer
-- division, rem and mod if the right operand is zero.
if Right_Int = 0 then
-- When SPARK_Mode is On, force a warning instead of
-- an error in that case, as this likely corresponds
-- to deactivated code.
Apply_Compile_Time_Constraint_Error
(N, "mod with zero divisor", CE_Divide_By_Zero,
Loc => Sloc (Right),
Warn => not Stat or SPARK_Mode = On);
return;
else
Result := Left_Int mod Right_Int;
end if;
when N_Op_Rem =>
-- The exception Constraint_Error is raised by integer
-- division, rem and mod if the right operand is zero.
if Right_Int = 0 then
-- When SPARK_Mode is On, force a warning instead of
-- an error in that case, as this likely corresponds
-- to deactivated code.
Apply_Compile_Time_Constraint_Error
(N, "rem with zero divisor", CE_Divide_By_Zero,
Loc => Sloc (Right),
Warn => not Stat or SPARK_Mode = On);
return;
else
Result := Left_Int rem Right_Int;
end if;
when others =>
raise Program_Error;
end case;
-- Adjust the result by the modulus if the type is a modular type
if Is_Modular_Integer_Type (Ltype) then
Result := Result mod Modulus (Ltype);
end if;
Check_Non_Static_Context_For_Overflow (N, Stat, Result);
-- If we get here we can fold the result
Fold_Uint (N, Result, Stat);
end;
-- Cases where at least one operand is a real. We handle the cases of
-- both reals, or mixed/real integer cases (the latter happen only for
-- divide and multiply, and the result is always real).
elsif Is_Real_Type (Ltype) or else Is_Real_Type (Rtype) then
declare
Left_Real : Ureal;
Right_Real : Ureal;
Result : Ureal;
begin
if Is_Real_Type (Ltype) then
Left_Real := Expr_Value_R (Left);
else
Left_Real := UR_From_Uint (Expr_Value (Left));
end if;
if Is_Real_Type (Rtype) then
Right_Real := Expr_Value_R (Right);
else
Right_Real := UR_From_Uint (Expr_Value (Right));
end if;
if Nkind (N) = N_Op_Add then
Result := Left_Real + Right_Real;
elsif Nkind (N) = N_Op_Subtract then
Result := Left_Real - Right_Real;
elsif Nkind (N) = N_Op_Multiply then
Result := Left_Real * Right_Real;
else pragma Assert (Nkind (N) = N_Op_Divide);
if UR_Is_Zero (Right_Real) then
Apply_Compile_Time_Constraint_Error
(N, "division by zero", CE_Divide_By_Zero,
Loc => Sloc (Right));
return;
end if;
Result := Left_Real / Right_Real;
end if;
Fold_Ureal (N, Result, Stat);
end;
end if;
-- If the operator was resolved to a specific type, make sure that type
-- is frozen even if the expression is folded into a literal (which has
-- a universal type).
if Present (Otype) then
Freeze_Before (N, Otype);
end if;
end Eval_Arithmetic_Op;
----------------------------
-- Eval_Character_Literal --
----------------------------
-- Nothing to be done
procedure Eval_Character_Literal (N : Node_Id) is
pragma Warnings (Off, N);
begin
null;
end Eval_Character_Literal;
---------------
-- Eval_Call --
---------------
-- Static function calls are either calls to predefined operators
-- with static arguments, or calls to functions that rename a literal.
-- Only the latter case is handled here, predefined operators are
-- constant-folded elsewhere.
-- If the function is itself inherited the literal of the parent type must
-- be explicitly converted to the return type of the function.
procedure Eval_Call (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
Typ : constant Entity_Id := Etype (N);
Lit : Entity_Id;
begin
if Nkind (N) = N_Function_Call
and then No (Parameter_Associations (N))
and then Is_Entity_Name (Name (N))
and then Present (Alias (Entity (Name (N))))
and then Is_Enumeration_Type (Base_Type (Typ))
then
Lit := Ultimate_Alias (Entity (Name (N)));
if Ekind (Lit) = E_Enumeration_Literal then
if Base_Type (Etype (Lit)) /= Base_Type (Typ) then
Rewrite
(N, Convert_To (Typ, New_Occurrence_Of (Lit, Loc)));
else
Rewrite (N, New_Occurrence_Of (Lit, Loc));
end if;
Resolve (N, Typ);
end if;
elsif Nkind (N) = N_Function_Call
and then Is_Entity_Name (Name (N))
and then Is_Intrinsic_Subprogram (Entity (Name (N)))
then
Eval_Intrinsic_Call (N, Entity (Name (N)));
-- Ada 2022 (AI12-0075): If checking for potentially static expressions
-- is enabled and we have a call to a static function, substitute a
-- static value for the call, to allow folding the expression. This
-- supports checking the requirement of RM 6.8(5.3/5) in
-- Analyze_Expression_Function.
elsif Checking_Potentially_Static_Expression
and then Is_Static_Function_Call (N)
then
Fold_Dummy (N, Typ);
end if;
end Eval_Call;
--------------------------
-- Eval_Case_Expression --
--------------------------
-- A conditional expression is static if all its conditions and dependent
-- expressions are static. Note that we do not care if the dependent
-- expressions raise CE, except for the one that will be selected.
procedure Eval_Case_Expression (N : Node_Id) is
Alt : Node_Id;
Choice : Node_Id;
begin
Set_Is_Static_Expression (N, False);
if Error_Posted (Expression (N))
or else not Is_Static_Expression (Expression (N))
then
Check_Non_Static_Context (Expression (N));
return;
end if;
-- First loop, make sure all the alternatives are static expressions
-- none of which raise Constraint_Error. We make the Constraint_Error
-- check because part of the legality condition for a correct static
-- case expression is that the cases are covered, like any other case
-- expression. And we can't do that if any of the conditions raise an
-- exception, so we don't even try to evaluate if that is the case.
Alt := First (Alternatives (N));
while Present (Alt) loop
-- The expression must be static, but we don't care at this stage
-- if it raises Constraint_Error (the alternative might not match,
-- in which case the expression is statically unevaluated anyway).
if not Is_Static_Expression (Expression (Alt)) then
Check_Non_Static_Context (Expression (Alt));
return;
end if;
-- The choices of a case always have to be static, and cannot raise
-- an exception. If this condition is not met, then the expression
-- is plain illegal, so just abandon evaluation attempts. No need
-- to check non-static context when we have something illegal anyway.
if not Is_OK_Static_Choice_List (Discrete_Choices (Alt)) then
return;
end if;
Next (Alt);
end loop;
-- OK, if the above loop gets through it means that all choices are OK
-- static (don't raise exceptions), so the whole case is static, and we
-- can find the matching alternative.
Set_Is_Static_Expression (N);
-- Now to deal with propagating a possible Constraint_Error
-- If the selecting expression raises CE, propagate and we are done
if Raises_Constraint_Error (Expression (N)) then
Set_Raises_Constraint_Error (N);
-- Otherwise we need to check the alternatives to find the matching
-- one. CE's in other than the matching one are not relevant. But we
-- do need to check the matching one. Unlike the first loop, we do not
-- have to go all the way through, when we find the matching one, quit.
else
Alt := First (Alternatives (N));
Search : loop
-- We must find a match among the alternatives. If not, this must
-- be due to other errors, so just ignore, leaving as non-static.
if No (Alt) then
Set_Is_Static_Expression (N, False);
return;
end if;
-- Otherwise loop through choices of this alternative
Choice := First (Discrete_Choices (Alt));
while Present (Choice) loop
-- If we find a matching choice, then the Expression of this
-- alternative replaces N (Raises_Constraint_Error flag is
-- included, so we don't have to special case that).
if Choice_Matches (Expression (N), Choice) = Match then
Rewrite (N, Relocate_Node (Expression (Alt)));
return;
end if;
Next (Choice);
end loop;
Next (Alt);
end loop Search;
end if;
end Eval_Case_Expression;
------------------------
-- Eval_Concatenation --
------------------------
-- Concatenation is a static function, so the result is static if both
-- operands are static (RM 4.9(7), 4.9(21)).
procedure Eval_Concatenation (N : Node_Id) is
Left : constant Node_Id := Left_Opnd (N);
Right : constant Node_Id := Right_Opnd (N);
C_Typ : constant Entity_Id := Root_Type (Component_Type (Etype (N)));
Stat : Boolean;
Fold : Boolean;
begin
-- Concatenation is never static in Ada 83, so if Ada 83 check operand
-- non-static context.
if Ada_Version = Ada_83
and then Comes_From_Source (N)
then
Check_Non_Static_Context (Left);
Check_Non_Static_Context (Right);
return;
end if;
-- If not foldable we are done. In principle concatenation that yields
-- any string type is static (i.e. an array type of character types).
-- However, character types can include enumeration literals, and
-- concatenation in that case cannot be described by a literal, so we
-- only consider the operation static if the result is an array of
-- (a descendant of) a predefined character type.
Test_Expression_Is_Foldable (N, Left, Right, Stat, Fold);
if not (Is_Standard_Character_Type (C_Typ) and then Fold) then
Set_Is_Static_Expression (N, False);
return;
end if;
-- Compile time string concatenation
-- ??? Note that operands that are aggregates can be marked as static,
-- so we should attempt at a later stage to fold concatenations with
-- such aggregates.
declare
Left_Str : constant Node_Id := Get_String_Val (Left);
Left_Len : Nat;
Right_Str : constant Node_Id := Get_String_Val (Right);
Folded_Val : String_Id := No_String;
begin
-- Establish new string literal, and store left operand. We make
-- sure to use the special Start_String that takes an operand if
-- the left operand is a string literal. Since this is optimized
-- in the case where that is the most recently created string
-- literal, we ensure efficient time/space behavior for the
-- case of a concatenation of a series of string literals.
if Nkind (Left_Str) = N_String_Literal then
Left_Len := String_Length (Strval (Left_Str));
-- If the left operand is the empty string, and the right operand
-- is a string literal (the case of "" & "..."), the result is the
-- value of the right operand. This optimization is important when
-- Is_Folded_In_Parser, to avoid copying an enormous right
-- operand.
if Left_Len = 0 and then Nkind (Right_Str) = N_String_Literal then
Folded_Val := Strval (Right_Str);
else
Start_String (Strval (Left_Str));
end if;
else
Start_String;
Store_String_Char (UI_To_CC (Char_Literal_Value (Left_Str)));
Left_Len := 1;
end if;
-- Now append the characters of the right operand, unless we
-- optimized the "" & "..." case above.
if Nkind (Right_Str) = N_String_Literal then
if Left_Len /= 0 then
Store_String_Chars (Strval (Right_Str));
Folded_Val := End_String;
end if;
else
Store_String_Char (UI_To_CC (Char_Literal_Value (Right_Str)));
Folded_Val := End_String;
end if;
Set_Is_Static_Expression (N, Stat);
-- If left operand is the empty string, the result is the
-- right operand, including its bounds if anomalous.
if Left_Len = 0
and then Is_Array_Type (Etype (Right))
and then Etype (Right) /= Any_String
then
Set_Etype (N, Etype (Right));
end if;
Fold_Str (N, Folded_Val, Static => Stat);
end;
end Eval_Concatenation;
----------------------
-- Eval_Entity_Name --
----------------------
-- This procedure is used for identifiers and expanded names other than
-- named numbers (see Eval_Named_Integer, Eval_Named_Real. These are
-- static if they denote a static constant (RM 4.9(6)) or if the name
-- denotes an enumeration literal (RM 4.9(22)).
procedure Eval_Entity_Name (N : Node_Id) is
Def_Id : constant Entity_Id := Entity (N);
Val : Node_Id;
begin
-- Enumeration literals are always considered to be constants
-- and cannot raise Constraint_Error (RM 4.9(22)).
if Ekind (Def_Id) = E_Enumeration_Literal then
Set_Is_Static_Expression (N);
return;
-- A name is static if it denotes a static constant (RM 4.9(5)), and
-- we also copy Raise_Constraint_Error. Notice that even if non-static,
-- it does not violate 10.2.1(8) here, since this is not a variable.
elsif Ekind (Def_Id) = E_Constant then
-- Deferred constants must always be treated as nonstatic outside the
-- scope of their full view.
if Present (Full_View (Def_Id))
and then not In_Open_Scopes (Scope (Def_Id))
then
Val := Empty;
else
Val := Constant_Value (Def_Id);
end if;
if Present (Val) then
Set_Is_Static_Expression
(N, Is_Static_Expression (Val)
and then Is_Static_Subtype (Etype (Def_Id)));
Set_Raises_Constraint_Error (N, Raises_Constraint_Error (Val));
if not Is_Static_Expression (N)
and then not Is_Generic_Type (Etype (N))
then
Validate_Static_Object_Name (N);
end if;
-- Mark constant condition in SCOs
if Generate_SCO
and then Comes_From_Source (N)
and then Is_Boolean_Type (Etype (Def_Id))
and then Compile_Time_Known_Value (N)
then
Set_SCO_Condition (N, Expr_Value_E (N) = Standard_True);
end if;
return;
end if;
-- Ada 2022 (AI12-0075): If checking for potentially static expressions
-- is enabled and we have a reference to a formal parameter of mode in,
-- substitute a static value for the reference, to allow folding the
-- expression. This supports checking the requirement of RM 6.8(5.3/5)
-- in Analyze_Expression_Function.
elsif Ekind (Def_Id) = E_In_Parameter
and then Checking_Potentially_Static_Expression
and then Is_Static_Function (Scope (Def_Id))
then
Fold_Dummy (N, Etype (Def_Id));
end if;
-- Fall through if the name is not static
Validate_Static_Object_Name (N);
end Eval_Entity_Name;
------------------------
-- Eval_If_Expression --
------------------------
-- We can fold to a static expression if the condition and both dependent
-- expressions are static. Otherwise, the only required processing is to do
-- the check for non-static context for the then and else expressions.
procedure Eval_If_Expression (N : Node_Id) is
Condition : constant Node_Id := First (Expressions (N));
Then_Expr : constant Node_Id := Next (Condition);
Else_Expr : constant Node_Id := Next (Then_Expr);
Result : Node_Id;
Non_Result : Node_Id;
Rstat : constant Boolean :=
Is_Static_Expression (Condition)
and then
Is_Static_Expression (Then_Expr)
and then
Is_Static_Expression (Else_Expr);
-- True if result is static
begin
-- If result not static, nothing to do, otherwise set static result
if not Rstat then
return;
else
Set_Is_Static_Expression (N);
end if;
-- If any operand is Any_Type, just propagate to result and do not try
-- to fold, this prevents cascaded errors.
if Etype (Condition) = Any_Type or else
Etype (Then_Expr) = Any_Type or else
Etype (Else_Expr) = Any_Type
then
Set_Etype (N, Any_Type);
Set_Is_Static_Expression (N, False);
return;
end if;
-- If condition raises Constraint_Error then we have already signaled
-- an error, and we just propagate to the result and do not fold.
if Raises_Constraint_Error (Condition) then
Set_Raises_Constraint_Error (N);
return;
end if;
-- Static case where we can fold. Note that we don't try to fold cases
-- where the condition is known at compile time, but the result is
-- non-static. This avoids possible cases of infinite recursion where
-- the expander puts in a redundant test and we remove it. Instead we
-- deal with these cases in the expander.
-- Select result operand
if Is_True (Expr_Value (Condition)) then
Result := Then_Expr;
Non_Result := Else_Expr;
else
Result := Else_Expr;
Non_Result := Then_Expr;
end if;
-- Note that it does not matter if the non-result operand raises a
-- Constraint_Error, but if the result raises Constraint_Error then we
-- replace the node with a raise Constraint_Error. This will properly
-- propagate Raises_Constraint_Error since this flag is set in Result.
if Raises_Constraint_Error (Result) then
Rewrite_In_Raise_CE (N, Result);
Check_Non_Static_Context (Non_Result);
-- Otherwise the result operand replaces the original node
else
Rewrite (N, Relocate_Node (Result));
Set_Is_Static_Expression (N);
end if;
end Eval_If_Expression;
----------------------------
-- Eval_Indexed_Component --
----------------------------
-- Indexed components are never static, so we need to perform the check
-- for non-static context on the index values. Then, we check if the
-- value can be obtained at compile time, even though it is non-static.
procedure Eval_Indexed_Component (N : Node_Id) is
Expr : Node_Id;
begin
-- Check for non-static context on index values
Expr := First (Expressions (N));
while Present (Expr) loop
Check_Non_Static_Context (Expr);
Next (Expr);
end loop;
-- If the indexed component appears in an object renaming declaration
-- then we do not want to try to evaluate it, since in this case we
-- need the identity of the array element.
if Nkind (Parent (N)) = N_Object_Renaming_Declaration then
return;
-- Similarly if the indexed component appears as the prefix of an
-- attribute we don't want to evaluate it, because at least for
-- some cases of attributes we need the identify (e.g. Access, Size).
elsif Nkind (Parent (N)) = N_Attribute_Reference then
return;
end if;
-- Note: there are other cases, such as the left side of an assignment,
-- or an OUT parameter for a call, where the replacement results in the
-- illegal use of a constant, But these cases are illegal in the first
-- place, so the replacement, though silly, is harmless.
-- Now see if this is a constant array reference
if List_Length (Expressions (N)) = 1
and then Is_Entity_Name (Prefix (N))
and then Ekind (Entity (Prefix (N))) = E_Constant
and then Present (Constant_Value (Entity (Prefix (N))))
then
declare
Loc : constant Source_Ptr := Sloc (N);
Arr : constant Node_Id := Constant_Value (Entity (Prefix (N)));
Sub : constant Node_Id := First (Expressions (N));
Atyp : Entity_Id;
-- Type of array
Lin : Nat;
-- Linear one's origin subscript value for array reference
Lbd : Node_Id;
-- Lower bound of the first array index
Elm : Node_Id;
-- Value from constant array
begin
Atyp := Etype (Arr);
if Is_Access_Type (Atyp) then
Atyp := Designated_Type (Atyp);
end if;
-- If we have an array type (we should have but perhaps there are
-- error cases where this is not the case), then see if we can do
-- a constant evaluation of the array reference.
if Is_Array_Type (Atyp) and then Atyp /= Any_Composite then
if Ekind (Atyp) = E_String_Literal_Subtype then
Lbd := String_Literal_Low_Bound (Atyp);
else
Lbd := Type_Low_Bound (Etype (First_Index (Atyp)));
end if;
if Compile_Time_Known_Value (Sub)
and then Nkind (Arr) = N_Aggregate
and then Compile_Time_Known_Value (Lbd)
and then Is_Discrete_Type (Component_Type (Atyp))
then
Lin := UI_To_Int (Expr_Value (Sub) - Expr_Value (Lbd)) + 1;
if List_Length (Expressions (Arr)) >= Lin then
Elm := Pick (Expressions (Arr), Lin);
-- If the resulting expression is compile-time-known,
-- then we can rewrite the indexed component with this
-- value, being sure to mark the result as non-static.
-- We also reset the Sloc, in case this generates an
-- error later on (e.g. 136'Access).
if Compile_Time_Known_Value (Elm) then
Rewrite (N, Duplicate_Subexpr_No_Checks (Elm));
Set_Is_Static_Expression (N, False);
Set_Sloc (N, Loc);
end if;
end if;
-- We can also constant-fold if the prefix is a string literal.
-- This will be useful in an instantiation or an inlining.
elsif Compile_Time_Known_Value (Sub)
and then Nkind (Arr) = N_String_Literal
and then Compile_Time_Known_Value (Lbd)
and then Expr_Value (Lbd) = 1
and then Expr_Value (Sub) <=
String_Literal_Length (Etype (Arr))
then
declare
C : constant Char_Code :=
Get_String_Char (Strval (Arr),
UI_To_Int (Expr_Value (Sub)));
begin
Set_Character_Literal_Name (C);
Elm :=
Make_Character_Literal (Loc,
Chars => Name_Find,
Char_Literal_Value => UI_From_CC (C));
Set_Etype (Elm, Component_Type (Atyp));
Rewrite (N, Duplicate_Subexpr_No_Checks (Elm));
Set_Is_Static_Expression (N, False);
end;
end if;
end if;
end;
end if;
end Eval_Indexed_Component;
--------------------------
-- Eval_Integer_Literal --
--------------------------
-- Numeric literals are static (RM 4.9(1)), and have already been marked
-- as static by the analyzer. The reason we did it that early is to allow
-- the possibility of turning off the Is_Static_Expression flag after
-- analysis, but before resolution, when integer literals are generated in
-- the expander that do not correspond to static expressions.
procedure Eval_Integer_Literal (N : Node_Id) is
function In_Any_Integer_Context (K : Node_Kind) return Boolean;
-- If the literal is resolved with a specific type in a context where
-- the expected type is Any_Integer, there are no range checks on the
-- literal. By the time the literal is evaluated, it carries the type
-- imposed by the enclosing expression, and we must recover the context
-- to determine that Any_Integer is meant.
----------------------------
-- In_Any_Integer_Context --
----------------------------
function In_Any_Integer_Context (K : Node_Kind) return Boolean is
begin
-- Any_Integer also appears in digits specifications for real types,
-- but those have bounds smaller that those of any integer base type,
-- so we can safely ignore these cases.
return K in N_Attribute_Definition_Clause
| N_Modular_Type_Definition
| N_Number_Declaration
| N_Signed_Integer_Type_Definition;
end In_Any_Integer_Context;
-- Local variables
PK : constant Node_Kind := Nkind (Parent (N));
Typ : constant Entity_Id := Etype (N);
-- Start of processing for Eval_Integer_Literal
begin
-- If the literal appears in a non-expression context, then it is
-- certainly appearing in a non-static context, so check it. This is
-- actually a redundant check, since Check_Non_Static_Context would
-- check it, but it seems worthwhile to optimize out the call.
-- Additionally, when the literal appears within an if or case
-- expression it must be checked as well. However, due to the literal
-- appearing within a conditional statement, expansion greatly changes
-- the nature of its context and performing some of the checks within
-- Check_Non_Static_Context on an expanded literal may lead to spurious
-- and misleading warnings.
if (PK not in N_Subexpr
or else (PK in N_Case_Expression_Alternative | N_If_Expression
and then
Comes_From_Source (N)))
and then not In_Any_Integer_Context (PK)
then
Check_Non_Static_Context (N);
end if;
-- Modular integer literals must be in their base range
if Is_Modular_Integer_Type (Typ)
and then Is_Out_Of_Range (N, Base_Type (Typ), Assume_Valid => True)
then
Out_Of_Range (N);
end if;
end Eval_Integer_Literal;
-------------------------
-- Eval_Intrinsic_Call --
-------------------------
procedure Eval_Intrinsic_Call (N : Node_Id; E : Entity_Id) is
procedure Eval_Shift (N : Node_Id; E : Entity_Id; Op : Node_Kind);
-- Evaluate an intrinsic shift call N on the given subprogram E.
-- Op is the kind for the shift node.
----------------
-- Eval_Shift --
----------------
procedure Eval_Shift (N : Node_Id; E : Entity_Id; Op : Node_Kind) is
Left : constant Node_Id := First_Actual (N);
Right : constant Node_Id := Next_Actual (Left);
Static : constant Boolean := Is_Static_Function (E);
begin
if Static then
if Checking_Potentially_Static_Expression then
Fold_Dummy (N, Etype (N));
return;
end if;
end if;
Fold_Shift
(N, Left, Right, Op, Static => Static, Check_Elab => not Static);
end Eval_Shift;
Nam : Name_Id;
begin
-- Nothing to do if the intrinsic is handled by the back end.
if Present (Interface_Name (E)) then
return;
end if;
-- Intrinsic calls as part of a static function is a language extension.
if Checking_Potentially_Static_Expression
and then not Extensions_Allowed
then
return;
end if;
-- If we have a renaming, expand the call to the original operation,
-- which must itself be intrinsic, since renaming requires matching
-- conventions and this has already been checked.
if Present (Alias (E)) then
Eval_Intrinsic_Call (N, Alias (E));
return;
end if;
-- If the intrinsic subprogram is generic, gets its original name
if Present (Parent (E))
and then Present (Generic_Parent (Parent (E)))
then
Nam := Chars (Generic_Parent (Parent (E)));
else
Nam := Chars (E);
end if;
case Nam is
when Name_Shift_Left =>
Eval_Shift (N, E, N_Op_Shift_Left);
when Name_Shift_Right =>
Eval_Shift (N, E, N_Op_Shift_Right);
when Name_Shift_Right_Arithmetic =>
Eval_Shift (N, E, N_Op_Shift_Right_Arithmetic);
when others =>
null;
end case;
end Eval_Intrinsic_Call;
---------------------
-- Eval_Logical_Op --
---------------------
-- Logical operations are static functions, so the result is potentially
-- static if both operands are potentially static (RM 4.9(7), 4.9(20)).
procedure Eval_Logical_Op (N : Node_Id) is
Left : constant Node_Id := Left_Opnd (N);
Right : constant Node_Id := Right_Opnd (N);
Left_Int : Uint := No_Uint;
Right_Int : Uint := No_Uint;
Stat : Boolean;
Fold : Boolean;
begin
-- If not foldable we are done
Test_Expression_Is_Foldable (N, Left, Right, Stat, Fold);
if not Fold then
return;
end if;
-- Compile time evaluation of logical operation
if Is_Modular_Integer_Type (Etype (N)) then
Left_Int := Expr_Value (Left);
Right_Int := Expr_Value (Right);
declare
Left_Bits : Bits (0 .. UI_To_Int (Esize (Etype (N))) - 1);
Right_Bits : Bits (0 .. UI_To_Int (Esize (Etype (N))) - 1);
begin
To_Bits (Left_Int, Left_Bits);
To_Bits (Right_Int, Right_Bits);
-- Note: should really be able to use array ops instead of
-- these loops, but they break the build with a cryptic error
-- during the bind of gnat1 likely due to a wrong computation
-- of a date or checksum.
if Nkind (N) = N_Op_And then
for J in Left_Bits'Range loop
Left_Bits (J) := Left_Bits (J) and Right_Bits (J);
end loop;
elsif Nkind (N) = N_Op_Or then
for J in Left_Bits'Range loop
Left_Bits (J) := Left_Bits (J) or Right_Bits (J);
end loop;
else
pragma Assert (Nkind (N) = N_Op_Xor);
for J in Left_Bits'Range loop
Left_Bits (J) := Left_Bits (J) xor Right_Bits (J);
end loop;
end if;
Fold_Uint (N, From_Bits (Left_Bits, Etype (N)), Stat);
end;
else
pragma Assert (Is_Boolean_Type (Etype (N)));
if Compile_Time_Known_Value (Left)
and then Compile_Time_Known_Value (Right)
then
Right_Int := Expr_Value (Right);
Left_Int := Expr_Value (Left);
end if;
if Nkind (N) = N_Op_And then
-- If Left or Right are not compile time known values it means
-- that the result is always False as per
-- Test_Expression_Is_Foldable.
-- Note that in this case, both Right_Int and Left_Int are set
-- to No_Uint, so need to test for both.
if No (Right_Int) then
Fold_Uint (N, Uint_0, Stat);
else
Fold_Uint (N,
Test (Is_True (Left_Int) and then Is_True (Right_Int)), Stat);
end if;
elsif Nkind (N) = N_Op_Or then
-- If Left or Right are not compile time known values it means
-- that the result is always True. as per
-- Test_Expression_Is_Foldable.
-- Note that in this case, both Right_Int and Left_Int are set
-- to No_Uint, so need to test for both.
if No (Right_Int) then
Fold_Uint (N, Uint_1, Stat);
else
Fold_Uint (N,
Test (Is_True (Left_Int) or else Is_True (Right_Int)), Stat);
end if;
else
pragma Assert (Nkind (N) = N_Op_Xor);
Fold_Uint (N,
Test (Is_True (Left_Int) xor Is_True (Right_Int)), Stat);
end if;
end if;
end Eval_Logical_Op;
------------------------
-- Eval_Membership_Op --
------------------------
-- A membership test is potentially static if the expression is static, and
-- the range is a potentially static range, or is a subtype mark denoting a
-- static subtype (RM 4.9(12)).
procedure Eval_Membership_Op (N : Node_Id) is
Alts : constant List_Id := Alternatives (N);
Choice : constant Node_Id := Right_Opnd (N);
Expr : constant Node_Id := Left_Opnd (N);
Result : Match_Result;
begin
-- Ignore if error in either operand, except to make sure that Any_Type
-- is properly propagated to avoid junk cascaded errors.
if Etype (Expr) = Any_Type
or else (Present (Choice) and then Etype (Choice) = Any_Type)
then
Set_Etype (N, Any_Type);
return;
end if;
-- If left operand non-static, then nothing to do
if not Is_Static_Expression (Expr) then
return;
end if;
-- If choice is non-static, left operand is in non-static context
if (Present (Choice) and then not Is_Static_Choice (Choice))
or else (Present (Alts) and then not Is_Static_Choice_List (Alts))
then
Check_Non_Static_Context (Expr);
return;
end if;
-- Otherwise we definitely have a static expression
Set_Is_Static_Expression (N);
-- If left operand raises Constraint_Error, propagate and we are done
if Raises_Constraint_Error (Expr) then
Set_Raises_Constraint_Error (N, True);
-- See if we match
else
if Present (Choice) then
Result := Choice_Matches (Expr, Choice);
else
Result := Choices_Match (Expr, Alts);
end if;
-- If result is Non_Static, it means that we raise Constraint_Error,
-- since we already tested that the operands were themselves static.
if Result = Non_Static then
Set_Raises_Constraint_Error (N);
-- Otherwise we have our result (flipped if NOT IN case)
else
Fold_Uint
(N, Test ((Result = Match) xor (Nkind (N) = N_Not_In)), True);
Warn_On_Known_Condition (N);
end if;
end if;
end Eval_Membership_Op;
------------------------
-- Eval_Named_Integer --
------------------------
procedure Eval_Named_Integer (N : Node_Id) is
begin
Fold_Uint (N,
Expr_Value (Expression (Declaration_Node (Entity (N)))), True);
end Eval_Named_Integer;
---------------------
-- Eval_Named_Real --
---------------------
procedure Eval_Named_Real (N : Node_Id) is
begin
Fold_Ureal (N,
Expr_Value_R (Expression (Declaration_Node (Entity (N)))), True);
end Eval_Named_Real;
-------------------
-- Eval_Op_Expon --
-------------------
-- Exponentiation is a static functions, so the result is potentially
-- static if both operands are potentially static (RM 4.9(7), 4.9(20)).
procedure Eval_Op_Expon (N : Node_Id) is
Left : constant Node_Id := Left_Opnd (N);
Right : constant Node_Id := Right_Opnd (N);
Stat : Boolean;
Fold : Boolean;
begin
-- If not foldable we are done
Test_Expression_Is_Foldable
(N, Left, Right, Stat, Fold, CRT_Safe => True);
-- Return if not foldable
if not Fold then
return;
end if;
if Configurable_Run_Time_Mode and not Stat then
return;
end if;
-- Fold exponentiation operation
declare
Right_Int : constant Uint := Expr_Value (Right);
begin
-- Integer case
if Is_Integer_Type (Etype (Left)) then
declare
Left_Int : constant Uint := Expr_Value (Left);
Result : Uint;
begin
-- Exponentiation of an integer raises Constraint_Error for a
-- negative exponent (RM 4.5.6).
if Right_Int < 0 then
Apply_Compile_Time_Constraint_Error
(N, "integer exponent negative", CE_Range_Check_Failed,
Warn => not Stat);
return;
else
if OK_Bits (N, Num_Bits (Left_Int) * Right_Int) then
Result := Left_Int ** Right_Int;
else
Result := Left_Int;
end if;
if Is_Modular_Integer_Type (Etype (N)) then
Result := Result mod Modulus (Etype (N));
end if;
Check_Non_Static_Context_For_Overflow (N, Stat, Result);
Fold_Uint (N, Result, Stat);
end if;
end;
-- Real case
else
declare
Left_Real : constant Ureal := Expr_Value_R (Left);
begin
-- Cannot have a zero base with a negative exponent
if UR_Is_Zero (Left_Real) then
if Right_Int < 0 then
Apply_Compile_Time_Constraint_Error
(N, "zero ** negative integer", CE_Range_Check_Failed,
Warn => not Stat);
return;
else
Fold_Ureal (N, Ureal_0, Stat);
end if;
else
Fold_Ureal (N, Left_Real ** Right_Int, Stat);
end if;
end;
end if;
end;
end Eval_Op_Expon;
-----------------
-- Eval_Op_Not --
-----------------
-- The not operation is a static function, so the result is potentially
-- static if the operand is potentially static (RM 4.9(7), 4.9(20)).
procedure Eval_Op_Not (N : Node_Id) is
Right : constant Node_Id := Right_Opnd (N);
Stat : Boolean;
Fold : Boolean;
begin
-- If not foldable we are done
Test_Expression_Is_Foldable (N, Right, Stat, Fold);
if not Fold then
return;
end if;
-- Fold not operation
declare
Rint : constant Uint := Expr_Value (Right);
Typ : constant Entity_Id := Etype (N);
begin
-- Negation is equivalent to subtracting from the modulus minus one.
-- For a binary modulus this is equivalent to the ones-complement of
-- the original value. For a nonbinary modulus this is an arbitrary
-- but consistent definition.
if Is_Modular_Integer_Type (Typ) then
Fold_Uint (N, Modulus (Typ) - 1 - Rint, Stat);
else pragma Assert (Is_Boolean_Type (Typ));
Fold_Uint (N, Test (not Is_True (Rint)), Stat);
end if;
Set_Is_Static_Expression (N, Stat);
end;
end Eval_Op_Not;
-------------------------------
-- Eval_Qualified_Expression --
-------------------------------
-- A qualified expression is potentially static if its subtype mark denotes
-- a static subtype and its expression is potentially static (RM 4.9 (10)).
procedure Eval_Qualified_Expression (N : Node_Id) is
Operand : constant Node_Id := Expression (N);
Target_Type : constant Entity_Id := Entity (Subtype_Mark (N));
Stat : Boolean;
Fold : Boolean;
Hex : Boolean;
begin
-- Can only fold if target is string or scalar and subtype is static.
-- Also, do not fold if our parent is an allocator (this is because the
-- qualified expression is really part of the syntactic structure of an
-- allocator, and we do not want to end up with something that
-- corresponds to "new 1" where the 1 is the result of folding a
-- qualified expression).
if not Is_Static_Subtype (Target_Type)
or else Nkind (Parent (N)) = N_Allocator
then
Check_Non_Static_Context (Operand);
-- If operand is known to raise Constraint_Error, set the flag on the
-- expression so it does not get optimized away.
if Nkind (Operand) = N_Raise_Constraint_Error then
Set_Raises_Constraint_Error (N);
end if;
return;
-- Also return if a semantic error has been posted on the node, as we
-- don't want to fold in that case (for GNATprove, the node might lead
-- to Constraint_Error but won't have been replaced with a raise node
-- or marked as raising CE).
elsif Error_Posted (N) then
return;
end if;
-- If not foldable we are done
Test_Expression_Is_Foldable (N, Operand, Stat, Fold);
if not Fold then
return;
-- Don't try fold if target type has Constraint_Error bounds
elsif not Is_OK_Static_Subtype (Target_Type) then
Set_Raises_Constraint_Error (N);
return;
end if;
-- Fold the result of qualification
if Is_Discrete_Type (Target_Type) then
-- Save Print_In_Hex indication
Hex := Nkind (Operand) = N_Integer_Literal
and then Print_In_Hex (Operand);
Fold_Uint (N, Expr_Value (Operand), Stat);
-- Preserve Print_In_Hex indication
if Hex and then Nkind (N) = N_Integer_Literal then
Set_Print_In_Hex (N);
end if;
elsif Is_Real_Type (Target_Type) then
Fold_Ureal (N, Expr_Value_R (Operand), Stat);
else
Fold_Str (N, Strval (Get_String_Val (Operand)), Stat);
if not Stat then
Set_Is_Static_Expression (N, False);
else
Check_String_Literal_Length (N, Target_Type);
end if;
return;
end if;
-- The expression may be foldable but not static
Set_Is_Static_Expression (N, Stat);
if Is_Out_Of_Range (N, Etype (N), Assume_Valid => True) then
Out_Of_Range (N);
end if;
end Eval_Qualified_Expression;
-----------------------
-- Eval_Real_Literal --
-----------------------
-- Numeric literals are static (RM 4.9(1)), and have already been marked
-- as static by the analyzer. The reason we did it that early is to allow
-- the possibility of turning off the Is_Static_Expression flag after
-- analysis, but before resolution, when integer literals are generated
-- in the expander that do not correspond to static expressions.
procedure Eval_Real_Literal (N : Node_Id) is
PK : constant Node_Kind := Nkind (Parent (N));
begin
-- If the literal appears in a non-expression context and not as part of
-- a number declaration, then it is appearing in a non-static context,
-- so check it.
if PK not in N_Subexpr and then PK /= N_Number_Declaration then
Check_Non_Static_Context (N);
end if;
end Eval_Real_Literal;
------------------------
-- Eval_Relational_Op --
------------------------
-- Relational operations are static functions, so the result is static if
-- both operands are static (RM 4.9(7), 4.9(20)), except that up to Ada
-- 2012, for strings the result is never static, even if the operands are.
-- The string case was relaxed in Ada 2022, see AI12-0201.
-- However, for internally generated nodes, we allow string equality and
-- inequality to be static. This is because we rewrite A in "ABC" as an
-- equality test A = "ABC", and the former is definitely static.
procedure Eval_Relational_Op (N : Node_Id) is
Left : constant Node_Id := Left_Opnd (N);
Right : constant Node_Id := Right_Opnd (N);
procedure Decompose_Expr
(Expr : Node_Id;
Ent : out Entity_Id;
Kind : out Character;
Cons : out Uint;
Orig : Boolean := True);
-- Given expression Expr, see if it is of the form X [+/- K]. If so, Ent
-- is set to the entity in X, Kind is 'F','L','E' for 'First or 'Last or
-- simple entity, and Cons is the value of K. If the expression is not
-- of the required form, Ent is set to Empty.
--
-- Orig indicates whether Expr is the original expression to consider,
-- or if we are handling a subexpression (e.g. recursive call to
-- Decompose_Expr).
procedure Fold_General_Op (Is_Static : Boolean);
-- Attempt to fold arbitrary relational operator N. Flag Is_Static must
-- be set when the operator denotes a static expression.
procedure Fold_Static_Real_Op;
-- Attempt to fold static real type relational operator N
function Static_Length (Expr : Node_Id) return Uint;
-- If Expr is an expression for a constrained array whose length is
-- known at compile time, return the non-negative length, otherwise
-- return -1.
--------------------
-- Decompose_Expr --
--------------------
procedure Decompose_Expr
(Expr : Node_Id;
Ent : out Entity_Id;
Kind : out Character;
Cons : out Uint;
Orig : Boolean := True)
is
Exp : Node_Id;
begin
-- Assume that the expression does not meet the expected form
Cons := No_Uint;
Ent := Empty;
Kind := '?';
if Nkind (Expr) = N_Op_Add
and then Compile_Time_Known_Value (Right_Opnd (Expr))
then
Exp := Left_Opnd (Expr);
Cons := Expr_Value (Right_Opnd (Expr));
elsif Nkind (Expr) = N_Op_Subtract
and then Compile_Time_Known_Value (Right_Opnd (Expr))
then
Exp := Left_Opnd (Expr);
Cons := -Expr_Value (Right_Opnd (Expr));
-- If the bound is a constant created to remove side effects, recover
-- the original expression to see if it has one of the recognizable
-- forms.
elsif Nkind (Expr) = N_Identifier
and then not Comes_From_Source (Entity (Expr))
and then Ekind (Entity (Expr)) = E_Constant
and then Nkind (Parent (Entity (Expr))) = N_Object_Declaration
then
Exp := Expression (Parent (Entity (Expr)));
Decompose_Expr (Exp, Ent, Kind, Cons, Orig => False);
-- If original expression includes an entity, create a reference
-- to it for use below.
if Present (Ent) then
Exp := New_Occurrence_Of (Ent, Sloc (Ent));
else
return;
end if;
else
-- Only consider the case of X + 0 for a full expression, and
-- not when recursing, otherwise we may end up with evaluating
-- expressions not known at compile time to 0.
if Orig then
Exp := Expr;
Cons := Uint_0;
else
return;
end if;
end if;
-- At this stage Exp is set to the potential X
if Nkind (Exp) = N_Attribute_Reference then
if Attribute_Name (Exp) = Name_First then
Kind := 'F';
elsif Attribute_Name (Exp) = Name_Last then
Kind := 'L';
else
return;
end if;
Exp := Prefix (Exp);
else
Kind := 'E';
end if;
if Is_Entity_Name (Exp) and then Present (Entity (Exp)) then
Ent := Entity (Exp);
end if;
end Decompose_Expr;
---------------------
-- Fold_General_Op --
---------------------
procedure Fold_General_Op (Is_Static : Boolean) is
CR : constant Compare_Result :=
Compile_Time_Compare (Left, Right, Assume_Valid => False);
Result : Boolean;
begin
if CR = Unknown then
return;
end if;
case Nkind (N) is
when N_Op_Eq =>
if CR = EQ then
Result := True;
elsif CR = NE or else CR = GT or else CR = LT then
Result := False;
else
return;
end if;
when N_Op_Ge =>
if CR = GT or else CR = EQ or else CR = GE then
Result := True;
elsif CR = LT then
Result := False;
else
return;
end if;
when N_Op_Gt =>
if CR = GT then
Result := True;
elsif CR = EQ or else CR = LT or else CR = LE then
Result := False;
else
return;
end if;
when N_Op_Le =>
if CR = LT or else CR = EQ or else CR = LE then
Result := True;
elsif CR = GT then
Result := False;
else
return;
end if;
when N_Op_Lt =>
if CR = LT then
Result := True;
elsif CR = EQ or else CR = GT or else CR = GE then
Result := False;
else
return;
end if;
when N_Op_Ne =>
if CR = NE or else CR = GT or else CR = LT then
Result := True;
elsif CR = EQ then
Result := False;
else
return;
end if;
when others =>
raise Program_Error;
end case;
-- Determine the potential outcome of the relation assuming the
-- operands are valid and emit a warning when the relation yields
-- True or False only in the presence of invalid values.
Warn_On_Constant_Valid_Condition (N);
Fold_Uint (N, Test (Result), Is_Static);
end Fold_General_Op;
-------------------------
-- Fold_Static_Real_Op --
-------------------------
procedure Fold_Static_Real_Op is
Left_Real : constant Ureal := Expr_Value_R (Left);
Right_Real : constant Ureal := Expr_Value_R (Right);
Result : Boolean;
begin
case Nkind (N) is
when N_Op_Eq => Result := (Left_Real = Right_Real);
when N_Op_Ge => Result := (Left_Real >= Right_Real);
when N_Op_Gt => Result := (Left_Real > Right_Real);
when N_Op_Le => Result := (Left_Real <= Right_Real);
when N_Op_Lt => Result := (Left_Real < Right_Real);
when N_Op_Ne => Result := (Left_Real /= Right_Real);
when others => raise Program_Error;
end case;
Fold_Uint (N, Test (Result), True);
end Fold_Static_Real_Op;
-------------------
-- Static_Length --
-------------------
function Static_Length (Expr : Node_Id) return Uint is
Cons1 : Uint;
Cons2 : Uint;
Ent1 : Entity_Id;
Ent2 : Entity_Id;
Kind1 : Character;
Kind2 : Character;
Typ : Entity_Id;
begin
-- First easy case string literal
if Nkind (Expr) = N_String_Literal then
return UI_From_Int (String_Length (Strval (Expr)));
-- With frontend inlining as performed in GNATprove mode, a variable
-- may be inserted that has a string literal subtype. Deal with this
-- specially as for the previous case.
elsif Ekind (Etype (Expr)) = E_String_Literal_Subtype then
return String_Literal_Length (Etype (Expr));
-- Second easy case, not constrained subtype, so no length
elsif not Is_Constrained (Etype (Expr)) then
return Uint_Minus_1;
end if;
-- General case
Typ := Etype (First_Index (Etype (Expr)));
-- The simple case, both bounds are known at compile time
if Is_Discrete_Type (Typ)
and then Compile_Time_Known_Value (Type_Low_Bound (Typ))
and then Compile_Time_Known_Value (Type_High_Bound (Typ))
then
return
UI_Max (Uint_0, Expr_Value (Type_High_Bound (Typ)) -
Expr_Value (Type_Low_Bound (Typ)) + 1);
end if;
-- A more complex case, where the bounds are of the form X [+/- K1]
-- .. X [+/- K2]), where X is an expression that is either A'First or
-- A'Last (with A an entity name), or X is an entity name, and the
-- two X's are the same and K1 and K2 are known at compile time, in
-- this case, the length can also be computed at compile time, even
-- though the bounds are not known. A common case of this is e.g.
-- (X'First .. X'First+5).
Decompose_Expr
(Original_Node (Type_Low_Bound (Typ)), Ent1, Kind1, Cons1);
Decompose_Expr
(Original_Node (Type_High_Bound (Typ)), Ent2, Kind2, Cons2);
if Present (Ent1) and then Ent1 = Ent2 and then Kind1 = Kind2 then
return Cons2 - Cons1 + 1;
else
return Uint_Minus_1;
end if;
end Static_Length;
-- Local variables
Left_Typ : constant Entity_Id := Etype (Left);
Right_Typ : constant Entity_Id := Etype (Right);
Fold : Boolean;
Left_Len : Uint;
Op_Typ : Entity_Id := Empty;
Right_Len : Uint;
Is_Static_Expression : Boolean;
-- Start of processing for Eval_Relational_Op
begin
-- One special case to deal with first. If we can tell that the result
-- will be false because the lengths of one or more index subtypes are
-- compile-time known and different, then we can replace the entire
-- result by False. We only do this for one-dimensional arrays, because
-- the case of multidimensional arrays is rare and too much trouble. If
-- one of the operands is an illegal aggregate, its type might still be
-- an arbitrary composite type, so nothing to do.
if Is_Array_Type (Left_Typ)
and then Left_Typ /= Any_Composite
and then Number_Dimensions (Left_Typ) = 1
and then Nkind (N) in N_Op_Eq | N_Op_Ne
then
if Raises_Constraint_Error (Left)
or else
Raises_Constraint_Error (Right)
then
return;
end if;
-- OK, we have the case where we may be able to do this fold
Left_Len := Static_Length (Left);
Right_Len := Static_Length (Right);
if Left_Len /= Uint_Minus_1
and then Right_Len /= Uint_Minus_1
and then Left_Len /= Right_Len
then
-- AI12-0201: comparison of string is static in Ada 2022
Fold_Uint
(N,
Test (Nkind (N) = N_Op_Ne),
Static => Ada_Version >= Ada_2022
and then Is_String_Type (Left_Typ));
Warn_On_Known_Condition (N);
return;
end if;
end if;
-- General case
-- Initialize the value of Is_Static_Expression. The value of Fold
-- returned by Test_Expression_Is_Foldable is not needed since, even
-- when some operand is a variable, we can still perform the static
-- evaluation of the expression in some cases (for example, for a
-- variable of a subtype of Integer we statically know that any value
-- stored in such variable is smaller than Integer'Last).
Test_Expression_Is_Foldable
(N, Left, Right, Is_Static_Expression, Fold);
-- Comparisons of scalars can give static results.
-- In addition starting with Ada 2022 (AI12-0201), comparison of strings
-- can also give static results, and as noted above, we also allow for
-- earlier Ada versions internally generated equality and inequality for
-- strings.
-- The Comes_From_Source test below isn't correct and will accept
-- some cases that are illegal in Ada 2012 and before. Now that Ada
-- 2022 has relaxed the rules, this doesn't really matter.
if Is_String_Type (Left_Typ) then
if Ada_Version < Ada_2022
and then (Comes_From_Source (N)
or else Nkind (N) not in N_Op_Eq | N_Op_Ne)
then
Is_Static_Expression := False;
Set_Is_Static_Expression (N, False);
end if;
elsif not Is_Scalar_Type (Left_Typ) then
Is_Static_Expression := False;
Set_Is_Static_Expression (N, False);
end if;
-- For operators on universal numeric types called as functions with an
-- explicit scope, determine appropriate specific numeric type, and
-- diagnose possible ambiguity.
if Is_Universal_Numeric_Type (Left_Typ)
and then
Is_Universal_Numeric_Type (Right_Typ)
then
Op_Typ := Find_Universal_Operator_Type (N);
end if;
-- Attempt to fold the relational operator
if Is_Static_Expression and then Is_Real_Type (Left_Typ) then
Fold_Static_Real_Op;
else
Fold_General_Op (Is_Static_Expression);
end if;
-- For the case of a folded relational operator on a specific numeric
-- type, freeze the operand type now.
if Present (Op_Typ) then
Freeze_Before (N, Op_Typ);
end if;
Warn_On_Known_Condition (N);
end Eval_Relational_Op;
-----------------------------
-- Eval_Selected_Component --
-----------------------------
procedure Eval_Selected_Component (N : Node_Id) is
Node : Node_Id;
Comp : Node_Id;
C : Node_Id;
Nam : Name_Id;
begin
-- If an attribute reference or a LHS, nothing to do.
-- Also do not fold if N is an [in] out subprogram parameter.
-- Fold will perform the other relevant tests.
if Nkind (Parent (N)) /= N_Attribute_Reference
and then not Known_To_Be_Assigned (N)
and then not Is_Actual_Out_Or_In_Out_Parameter (N)
then
-- Simplify a selected_component on an aggregate by extracting
-- the field directly.
Node := Unqualify (Prefix (N));
if Nkind (Node) = N_Aggregate
and then Compile_Time_Known_Aggregate (Node)
then
Comp := First (Component_Associations (Node));
Nam := Chars (Selector_Name (N));
while Present (Comp) loop
C := First (Choices (Comp));
while Present (C) loop
if Chars (C) = Nam then
Rewrite (N, Relocate_Node (Expression (Comp)));
return;
end if;
Next (C);
end loop;
Next (Comp);
end loop;
else
Fold (N);
end if;
end if;
end Eval_Selected_Component;
----------------
-- Eval_Shift --
----------------
procedure Eval_Shift (N : Node_Id) is
begin
-- This procedure is only called for compiler generated code (e.g.
-- packed arrays), so there is nothing to do except attempting to fold
-- the expression.
Fold_Shift (N, Left_Opnd (N), Right_Opnd (N), Nkind (N));
end Eval_Shift;
------------------------
-- Eval_Short_Circuit --
------------------------
-- A short circuit operation is potentially static if both operands are
-- potentially static (RM 4.9 (13)).
procedure Eval_Short_Circuit (N : Node_Id) is
Kind : constant Node_Kind := Nkind (N);
Left : constant Node_Id := Left_Opnd (N);
Right : constant Node_Id := Right_Opnd (N);
Left_Int : Uint;
Rstat : constant Boolean :=
Is_Static_Expression (Left)
and then
Is_Static_Expression (Right);
begin
-- Short circuit operations are never static in Ada 83
if Ada_Version = Ada_83 and then Comes_From_Source (N) then
Check_Non_Static_Context (Left);
Check_Non_Static_Context (Right);
return;
end if;
-- Now look at the operands, we can't quite use the normal call to
-- Test_Expression_Is_Foldable here because short circuit operations
-- are a special case, they can still be foldable, even if the right
-- operand raises Constraint_Error.
-- If either operand is Any_Type, just propagate to result and do not
-- try to fold, this prevents cascaded errors.
if Etype (Left) = Any_Type or else Etype (Right) = Any_Type then
Set_Etype (N, Any_Type);
return;
-- If left operand raises Constraint_Error, then replace node N with
-- the raise Constraint_Error node, and we are obviously not foldable.
-- Is_Static_Expression is set from the two operands in the normal way,
-- and we check the right operand if it is in a non-static context.
elsif Raises_Constraint_Error (Left) then
if not Rstat then
Check_Non_Static_Context (Right);
end if;
Rewrite_In_Raise_CE (N, Left);
Set_Is_Static_Expression (N, Rstat);
return;
-- If the result is not static, then we won't in any case fold
elsif not Rstat then
Check_Non_Static_Context (Left);
Check_Non_Static_Context (Right);
return;
end if;
-- Here the result is static, note that, unlike the normal processing
-- in Test_Expression_Is_Foldable, we did *not* check above to see if
-- the right operand raises Constraint_Error, that's because it is not
-- significant if the left operand is decisive.
Set_Is_Static_Expression (N);
-- It does not matter if the right operand raises Constraint_Error if
-- it will not be evaluated. So deal specially with the cases where
-- the right operand is not evaluated. Note that we will fold these
-- cases even if the right operand is non-static, which is fine, but
-- of course in these cases the result is not potentially static.
Left_Int := Expr_Value (Left);
if (Kind = N_And_Then and then Is_False (Left_Int))
or else
(Kind = N_Or_Else and then Is_True (Left_Int))
then
Fold_Uint (N, Left_Int, Rstat);
return;
end if;
-- If first operand not decisive, then it does matter if the right
-- operand raises Constraint_Error, since it will be evaluated, so
-- we simply replace the node with the right operand. Note that this
-- properly propagates Is_Static_Expression and Raises_Constraint_Error
-- (both are set to True in Right).
if Raises_Constraint_Error (Right) then
Rewrite_In_Raise_CE (N, Right);
Check_Non_Static_Context (Left);
return;
end if;
-- Otherwise the result depends on the right operand
Fold_Uint (N, Expr_Value (Right), Rstat);
return;
end Eval_Short_Circuit;
----------------
-- Eval_Slice --
----------------
-- Slices can never be static, so the only processing required is to check
-- for non-static context if an explicit range is given.
procedure Eval_Slice (N : Node_Id) is
Drange : constant Node_Id := Discrete_Range (N);
Name : constant Node_Id := Prefix (N);
begin
if Nkind (Drange) = N_Range then
Check_Non_Static_Context (Low_Bound (Drange));
Check_Non_Static_Context (High_Bound (Drange));
end if;
-- A slice of the form A (subtype), when the subtype is the index of
-- the type of A, is redundant, the slice can be replaced with A, and
-- this is worth a warning.
if Is_Entity_Name (Name) then
declare
E : constant Entity_Id := Entity (Name);
T : constant Entity_Id := Etype (E);
begin
if Is_Object (E)
and then Is_Array_Type (T)
and then Is_Entity_Name (Drange)
then
if Is_Entity_Name (Original_Node (First_Index (T)))
and then Entity (Original_Node (First_Index (T)))
= Entity (Drange)
then
if Warn_On_Redundant_Constructs then
Error_Msg_N ("redundant slice denotes whole array?r?", N);
end if;
-- The following might be a useful optimization???
-- Rewrite (N, New_Occurrence_Of (E, Sloc (N)));
end if;
end if;
end;
end if;
end Eval_Slice;
-------------------------
-- Eval_String_Literal --
-------------------------
procedure Eval_String_Literal (N : Node_Id) is
Typ : constant Entity_Id := Etype (N);
Bas : constant Entity_Id := Base_Type (Typ);
Xtp : Entity_Id;
Len : Nat;
Lo : Node_Id;
begin
-- Nothing to do if error type (handles cases like default expressions
-- or generics where we have not yet fully resolved the type).
if Bas = Any_Type or else Bas = Any_String then
return;
end if;
-- String literals are static if the subtype is static (RM 4.9(2)), so
-- reset the static expression flag (it was set unconditionally in
-- Analyze_String_Literal) if the subtype is non-static. We tell if
-- the subtype is static by looking at the lower bound.
if Ekind (Typ) = E_String_Literal_Subtype then
if not Is_OK_Static_Expression (String_Literal_Low_Bound (Typ)) then
Set_Is_Static_Expression (N, False);
return;
end if;
-- Here if Etype of string literal is normal Etype (not yet possible,
-- but may be possible in future).
elsif not Is_OK_Static_Expression
(Type_Low_Bound (Etype (First_Index (Typ))))
then
Set_Is_Static_Expression (N, False);
return;
end if;
-- If original node was a type conversion, then result if non-static
-- up to Ada 2012. AI12-0201 changes that with Ada 2022.
if Nkind (Original_Node (N)) = N_Type_Conversion
and then Ada_Version <= Ada_2012
then
Set_Is_Static_Expression (N, False);
return;
end if;
-- Test for illegal Ada 95 cases. A string literal is illegal in Ada 95
-- if its bounds are outside the index base type and this index type is
-- static. This can happen in only two ways. Either the string literal
-- is too long, or it is null, and the lower bound is type'First. Either
-- way it is the upper bound that is out of range of the index type.
if Ada_Version >= Ada_95 then
if Is_Standard_String_Type (Bas) then
Xtp := Standard_Positive;
else
Xtp := Etype (First_Index (Bas));
end if;
if Ekind (Typ) = E_String_Literal_Subtype then
Lo := String_Literal_Low_Bound (Typ);
else
Lo := Type_Low_Bound (Etype (First_Index (Typ)));
end if;
-- Check for string too long
Len := String_Length (Strval (N));
if Len > String_Type_Len (Bas) then
-- Issue message. Note that this message is a warning if the
-- string literal is not marked as static (happens in some cases
-- of folding strings known at compile time, but not static).
-- Furthermore in such cases, we reword the message, since there
-- is no string literal in the source program.
if Is_Static_Expression (N) then
Apply_Compile_Time_Constraint_Error
(N, "string literal too long for}", CE_Length_Check_Failed,
Ent => Bas,
Typ => First_Subtype (Bas));
else
Apply_Compile_Time_Constraint_Error
(N, "string value too long for}", CE_Length_Check_Failed,
Ent => Bas,
Typ => First_Subtype (Bas),
Warn => True);
end if;
-- Test for null string not allowed
elsif Len = 0
and then not Is_Generic_Type (Xtp)
and then
Expr_Value (Lo) = Expr_Value (Type_Low_Bound (Base_Type (Xtp)))
then
-- Same specialization of message
if Is_Static_Expression (N) then
Apply_Compile_Time_Constraint_Error
(N, "null string literal not allowed for}",
CE_Length_Check_Failed,
Ent => Bas,
Typ => First_Subtype (Bas));
else
Apply_Compile_Time_Constraint_Error
(N, "null string value not allowed for}",
CE_Length_Check_Failed,
Ent => Bas,
Typ => First_Subtype (Bas),
Warn => True);
end if;
end if;
end if;
end Eval_String_Literal;
--------------------------
-- Eval_Type_Conversion --
--------------------------
-- A type conversion is potentially static if its subtype mark is for a
-- static scalar subtype, and its operand expression is potentially static
-- (RM 4.9(10)).
-- Also add support for static string types.
procedure Eval_Type_Conversion (N : Node_Id) is
Operand : constant Node_Id := Expression (N);
Source_Type : constant Entity_Id := Etype (Operand);
Target_Type : constant Entity_Id := Etype (N);
function To_Be_Treated_As_Integer (T : Entity_Id) return Boolean;
-- Returns true if type T is an integer type, or if it is a fixed-point
-- type to be treated as an integer (i.e. the flag Conversion_OK is set
-- on the conversion node).
function To_Be_Treated_As_Real (T : Entity_Id) return Boolean;
-- Returns true if type T is a floating-point type, or if it is a
-- fixed-point type that is not to be treated as an integer (i.e. the
-- flag Conversion_OK is not set on the conversion node).
------------------------------
-- To_Be_Treated_As_Integer --
------------------------------
function To_Be_Treated_As_Integer (T : Entity_Id) return Boolean is
begin
return
Is_Integer_Type (T)
or else (Is_Fixed_Point_Type (T) and then Conversion_OK (N));
end To_Be_Treated_As_Integer;
---------------------------
-- To_Be_Treated_As_Real --
---------------------------
function To_Be_Treated_As_Real (T : Entity_Id) return Boolean is
begin
return
Is_Floating_Point_Type (T)
or else (Is_Fixed_Point_Type (T) and then not Conversion_OK (N));
end To_Be_Treated_As_Real;
-- Local variables
Fold : Boolean;
Stat : Boolean;
-- Start of processing for Eval_Type_Conversion
begin
-- Cannot fold if target type is non-static or if semantic error
if not Is_Static_Subtype (Target_Type) then
Check_Non_Static_Context (Operand);
return;
elsif Error_Posted (N) then
return;
end if;
-- If not foldable we are done
Test_Expression_Is_Foldable (N, Operand, Stat, Fold);
if not Fold then
return;
-- Don't try fold if target type has Constraint_Error bounds
elsif not Is_OK_Static_Subtype (Target_Type) then
Set_Raises_Constraint_Error (N);
return;
end if;
-- Remaining processing depends on operand types. Note that in the
-- following type test, fixed-point counts as real unless the flag
-- Conversion_OK is set, in which case it counts as integer.
-- Fold conversion, case of string type. The result is static starting
-- with Ada 2022 (AI12-0201).
if Is_String_Type (Target_Type) then
Fold_Str
(N,
Strval (Get_String_Val (Operand)),
Static => Ada_Version >= Ada_2022);
return;
-- Fold conversion, case of integer target type
elsif To_Be_Treated_As_Integer (Target_Type) then
declare
Result : Uint;
begin
-- Integer to integer conversion
if To_Be_Treated_As_Integer (Source_Type) then
Result := Expr_Value (Operand);
-- Real to integer conversion
elsif To_Be_Treated_As_Real (Source_Type) then
Result := UR_To_Uint (Expr_Value_R (Operand));
-- Enumeration to integer conversion, aka 'Enum_Rep
else
Result := Expr_Rep_Value (Operand);
end if;
-- If fixed-point type (Conversion_OK must be set), then the
-- result is logically an integer, but we must replace the
-- conversion with the corresponding real literal, since the
-- type from a semantic point of view is still fixed-point.
if Is_Fixed_Point_Type (Target_Type) then
Fold_Ureal
(N, UR_From_Uint (Result) * Small_Value (Target_Type), Stat);
-- Otherwise result is integer literal
else
Fold_Uint (N, Result, Stat);
end if;
end;
-- Fold conversion, case of real target type
elsif To_Be_Treated_As_Real (Target_Type) then
declare
Result : Ureal;
begin
if To_Be_Treated_As_Real (Source_Type) then
Result := Expr_Value_R (Operand);
else
Result := UR_From_Uint (Expr_Value (Operand));
end if;
Fold_Ureal (N, Result, Stat);
end;
-- Enumeration types
else
Fold_Uint (N, Expr_Value (Operand), Stat);
end if;
-- If the target is a static floating-point subtype, then its bounds
-- are machine numbers so we must consider the machine-rounded value.
if Is_Floating_Point_Type (Target_Type)
and then Nkind (N) = N_Real_Literal
and then not Is_Machine_Number (N)
then
declare
Lo : constant Node_Id := Type_Low_Bound (Target_Type);
Hi : constant Node_Id := Type_High_Bound (Target_Type);
Valr : constant Ureal :=
Machine_Number (Target_Type, Expr_Value_R (N), N);
begin
if Valr < Expr_Value_R (Lo) or else Valr > Expr_Value_R (Hi) then
Out_Of_Range (N);
end if;
end;
elsif Is_Out_Of_Range (N, Etype (N), Assume_Valid => True) then
Out_Of_Range (N);
end if;
end Eval_Type_Conversion;
-------------------
-- Eval_Unary_Op --
-------------------