------------------------------------------------------------------------------ | |

-- -- | |

-- 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_Aggr; use Sem_Aggr; | |

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; | |

with Warnsw; use Warnsw; | |

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 (which can occur as a result of a previous error or in the | |

-- case of e.g. an imported constant). | |

if No (Op) then | |

return False; | |

elsif Op = Error | |

or else Nkind (Op) not in N_Has_Etype | |

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_Case_Expression_Alternative | 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 (core) | |

-- language extension. | |

if Checking_Potentially_Static_Expression | |

and then not Core_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; | |