Mercurial > hg > CbC > CbC_gcc
diff gcc/ada/sem_eval.adb @ 111:04ced10e8804
gcc 7
| author | kono |
|---|---|
| date | Fri, 27 Oct 2017 22:46:09 +0900 |
| parents | |
| children | 84e7813d76e9 |
line wrap: on
line diff
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/gcc/ada/sem_eval.adb Fri Oct 27 22:46:09 2017 +0900 @@ -0,0 +1,6881 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S E M _ E V A L -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, 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 Elists; use Elists; +with Errout; use Errout; +with Eval_Fat; use Eval_Fat; +with Exp_Util; use Exp_Util; +with Freeze; use Freeze; +with Lib; use Lib; +with Namet; use Namet; +with Nmake; use Nmake; +with Nlists; use Nlists; +with Opt; use Opt; +with Par_SCO; use Par_SCO; +with Rtsfind; use Rtsfind; +with Sem; use Sem; +with Sem_Aux; use Sem_Aux; +with Sem_Cat; use Sem_Cat; +with Sem_Ch6; use Sem_Ch6; +with Sem_Ch8; use Sem_Ch8; +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 Snames; use Snames; +with Stand; use Stand; +with Stringt; use Stringt; +with Tbuild; use Tbuild; + +package body Sem_Eval is + + ----------------------------------------- + -- Handling of Compile Time Evaluation -- + ----------------------------------------- + + -- The compile time evaluation of expressions is distributed over several + -- Eval_xxx procedures. These procedures are called immediately after + -- a subexpression is resolved and is therefore accomplished in a bottom + -- up fashion. The flags are synthesized using the following approach. + + -- Is_Static_Expression is determined by following the detailed rules + -- in RM 4.9(4-14). This involves testing the Is_Static_Expression + -- flag of the operands in many cases. + + -- Raises_Constraint_Error is set if any of the operands have the flag + -- set or if an attempt to compute the value of the current expression + -- results in detection of a runtime constraint error. + + -- As described in the spec, the requirement is that Is_Static_Expression + -- be accurately set, and in addition for nodes for which this flag is set, + -- Raises_Constraint_Error must also be set. Furthermore a node which has + -- Is_Static_Expression set, and Raises_Constraint_Error clear, then the + -- requirement is that the expression value must be precomputed, and the + -- node is either a literal, or the name of a constant entity whose value + -- is a static expression. + + -- 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; + 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 := (others => (Node_High_Bound, Uint_0)); + -- 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. + + ----------------------- + -- Local Subprograms -- + ----------------------- + + 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). + + 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. + + 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) + 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). This + -- is the case where the expression is no longer considered static. + + if Is_Static_Expression (Expr) + and then not Has_Dynamic_Predicate_Aspect (Typ) + then + 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); + + -- 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); + 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 (Base_Type (T), Realval (N), Round_Even, 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 + + -- Note: even though RM 4.9(38) specifies biased rounding, this + -- has been modified by AI-100 in order to prevent confusing + -- differences in rounding between static and non-static + -- expressions. AI-100 specifies that the effect of such rounding + -- is implementation dependent, and in GNAT we round to nearest + -- even to match the run-time behavior. Note that this applies + -- to floating point literals, not fixed points ones, even though + -- their compiler representation is also as a universal real. + + Set_Realval + (N, Machine (Base_Type (T), Realval (N), Round_Even, 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. + + if Etype (N) = Universal_Integer + and then Nkind (N) = N_Integer_Literal + and then Nkind (Parent (N)) in N_Subexpr + 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 warning if outside subtype (where one or both of the bounds of + -- the subtype is static). This 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 + Apply_Compile_Time_Constraint_Error + (N, "value not in range of}<<", CE_Range_Check_Failed); + + 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_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; + + -------------------- + -- 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 Nam_In (Attribute_Name (N), 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 + Indx := 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 + (Ekind (Entity (Opnd)) in Object_Kind + 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_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_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 + -- Values are the same if they refer to the same entity and the + -- entity is non-volatile. This does not however apply to Float + -- types, since we may have two NaN values and they should never + -- compare equal. + + -- 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. + + -- It would be better to comment individual branches of this test ??? + + if Nkind_In (Lf, N_Identifier, N_Expanded_Name) + and then Nkind_In (Rf, N_Identifier, N_Expanded_Name) + and then Entity (Lf) = Entity (Rf) + and then Ekind (Entity (Lf)) /= E_Discriminant + and then Present (Entity (Lf)) + 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 Nam_In (Attribute_Name (Lf), Name_First, Name_Last) + and then Nkind_In (Prefix (Lf), N_Identifier, N_Expanded_Name) + and then Nkind_In (Prefix (Rf), N_Identifier, N_Expanded_Name) + and then Entity (Prefix (Lf)) = Entity (Prefix (Rf)) + and then Is_Same_Subscript (Expressions (Lf), Expressions (Rf)) + then + return True; + + -- True if the same selected component from the same record + + elsif Nkind (Lf) = N_Selected_Component + and then Selector_Name (Lf) = Selector_Name (Rf) + and then Is_Same_Value (Prefix (Lf), Prefix (Rf)) + then + return True; + + -- True if the same unary operator applied to the same operand + + elsif Nkind (Lf) in N_Unary_Op + and then Is_Same_Value (Right_Opnd (Lf), Right_Opnd (Rf)) + then + return True; + + -- True if the same binary operator applied to the same operands + + elsif Nkind (Lf) in N_Binary_Op + and then Is_Same_Value (Left_Opnd (Lf), Left_Opnd (Rf)) + and then Is_Same_Value (Right_Opnd (Lf), Right_Opnd (Rf)) + then + return True; + + -- All other cases, we can't tell, so return False + + else + return False; + end if; + end Is_Same_Value; + + -- Start of processing for Compile_Time_Compare + + begin + Diff.all := No_Uint; + + -- In preanalysis mode, always return Unknown unless the expression + -- is static. It is too early to be thinking we know the result of a + -- comparison, save that judgment for the full analysis. This is + -- particularly important in the case of pre and postconditions, which + -- otherwise can be prematurely collapsed into having True or False + -- conditions when this is inappropriate. + + if not (Full_Analysis + or else (Is_OK_Static_Expression (L) + and then + Is_OK_Static_Expression (R))) + then + return Unknown; + end if; + + -- If either operand could raise constraint error, then we cannot + -- know the result at compile time (since CE may be raised). + + if not (Cannot_Raise_Constraint_Error (L) + and then + Cannot_Raise_Constraint_Error (R)) + then + return Unknown; + end if; + + -- Identical operands are most certainly equal + + if L = R then + return EQ; + end if; + + -- If expressions have no types, then do not attempt to determine if + -- they are the same, since something funny is going on. One case in + -- which this happens is during generic template analysis, when bounds + -- are not fully analyzed. + + if No (Ltyp) or else No (Rtyp) then + return Unknown; + end if; + + -- These get reset to the base type for the case of entities where + -- Is_Known_Valid is not set. This takes care of handling possible + -- invalid representations using the value of the base type, in + -- accordance with RM 13.9.1(10). + + Ltyp := Underlying_Type (Ltyp); + Rtyp := Underlying_Type (Rtyp); + + -- Same rationale as above, but for Underlying_Type instead of Etype + + if No (Ltyp) or else No (Rtyp) then + return Unknown; + end if; + + -- We do not attempt comparisons for packed arrays represented as + -- modular types, where the semantics of comparison is quite different. + + if Is_Packed_Array_Impl_Type (Ltyp) + and then Is_Modular_Integer_Type (Ltyp) + then + return Unknown; + + -- For access types, the only time we know the result at compile time + -- (apart from identical operands, which we handled already) is if we + -- know one operand is null and the other is not, or both operands are + -- known null. + + elsif Is_Access_Type (Ltyp) then + if Known_Null (L) then + if Known_Null (R) then + return EQ; + elsif Known_Non_Null (R) then + return NE; + else + return Unknown; + end if; + + elsif Known_Non_Null (L) and then Known_Null (R) then + return NE; + + else + return Unknown; + end if; + + -- Case where comparison involves two compile time known values + + elsif Compile_Time_Known_Value (L) + and then + Compile_Time_Known_Value (R) + then + -- For the floating-point case, we have to be a little careful, since + -- at compile time we are dealing with universal exact values, but at + -- runtime, these will be in non-exact target form. That's why the + -- returned results are LE and GE below instead of LT and GT. + + if Is_Floating_Point_Type (Ltyp) + or else + Is_Floating_Point_Type (Rtyp) + then + declare + Lo : constant Ureal := Expr_Value_R (L); + Hi : constant Ureal := Expr_Value_R (R); + begin + if Lo < Hi then + return LE; + elsif Lo = Hi then + return EQ; + else + return GE; + end if; + end; + + -- For string types, we have two string literals and we proceed to + -- compare them using the Ada style dictionary string comparison. + + elsif not Is_Scalar_Type (Ltyp) then + declare + Lstring : constant String_Id := Strval (Expr_Value_S (L)); + Rstring : constant String_Id := Strval (Expr_Value_S (R)); + Llen : constant Nat := String_Length (Lstring); + Rlen : constant Nat := String_Length (Rstring); + + begin + for J in 1 .. Nat'Min (Llen, Rlen) loop + declare + LC : constant Char_Code := Get_String_Char (Lstring, J); + RC : constant Char_Code := Get_String_Char (Rstring, J); + begin + if LC < RC then + return LT; + elsif LC > RC then + return GT; + end if; + end; + end loop; + + if Llen < Rlen then + return LT; + elsif Llen > Rlen then + return GT; + else + return EQ; + end if; + end; + + -- For remaining scalar cases we know exactly (note that this does + -- include the fixed-point case, where we know the run time integer + -- values now). + + else + declare + Lo : constant Uint := Expr_Value (L); + Hi : constant Uint := Expr_Value (R); + begin + if Lo < Hi then + Diff.all := Hi - Lo; + return LT; + elsif Lo = Hi then + return EQ; + else + Diff.all := Lo - Hi; + return GT; + end if; + end; + end if; + + -- Cases where at least one operand is not known at compile time + + else + -- Remaining checks apply only for discrete types + + if not Is_Discrete_Type (Ltyp) + or else + not Is_Discrete_Type (Rtyp) + then + return Unknown; + end if; + + -- Defend against generic types, or actually any expressions that + -- contain a reference to a generic type from within a generic + -- template. We don't want to do any range analysis of such + -- expressions for two reasons. First, the bounds of a generic type + -- itself are junk and cannot be used for any kind of analysis. + -- Second, we may have a case where the range at run time is indeed + -- known, but we don't want to do compile time analysis in the + -- template based on that range since in an instance the value may be + -- static, and able to be elaborated without reference to the bounds + -- of types involved. As an example, consider: + + -- (F'Pos (F'Last) + 1) > Integer'Last + + -- The expression on the left side of > is Universal_Integer and thus + -- acquires the type Integer for evaluation at run time, and at run + -- time it is true that this condition is always False, but within + -- an instance F may be a type with a static range greater than the + -- range of Integer, and the expression statically evaluates to True. + + if References_Generic_Formal_Type (L) + or else + References_Generic_Formal_Type (R) + then + return Unknown; + end if; + + -- Replace types by base types for the case of values which are not + -- known to have valid representations. This takes care of properly + -- dealing with invalid representations. + + if not Assume_Valid then + if not (Is_Entity_Name (L) + and then (Is_Known_Valid (Entity (L)) + or else Assume_No_Invalid_Values)) + then + Ltyp := Underlying_Type (Base_Type (Ltyp)); + end if; + + if not (Is_Entity_Name (R) + and then (Is_Known_Valid (Entity (R)) + or else Assume_No_Invalid_Values)) + then + Rtyp := Underlying_Type (Base_Type (Rtyp)); + end if; + end if; + + -- First attempt is to decompose the expressions to extract a + -- constant offset resulting from the use of any of the forms: + + -- expr + literal + -- expr - literal + -- typ'Succ (expr) + -- typ'Pred (expr) + + -- Then we see if the two expressions are the same value, and if so + -- the result is obtained by comparing the offsets. + + -- Note: the reason we do this test first is that it returns only + -- decisive results (with diff set), where other tests, like the + -- range test, may not be as so decisive. Consider for example + -- J .. J + 1. This code can conclude LT with a difference of 1, + -- even if the range of J is not known. + + declare + Lnode : Node_Id; + Loffs : Uint; + Rnode : Node_Id; + Roffs : Uint; + + begin + Compare_Decompose (L, Lnode, Loffs); + Compare_Decompose (R, Rnode, Roffs); + + if Is_Same_Value (Lnode, Rnode) then + if Loffs = Roffs then + return EQ; + end if; + + -- When the offsets are not equal, we can go farther only if + -- the types are not modular (e.g. X < X + 1 is False if X is + -- the largest number). + + if not Is_Modular_Integer_Type (Ltyp) + and then not Is_Modular_Integer_Type (Rtyp) + then + if Loffs < Roffs then + Diff.all := Roffs - Loffs; + return LT; + else + Diff.all := Loffs - Roffs; + return GT; + end if; + end if; + end if; + end; + + -- Next, try range analysis and see if operand ranges are disjoint + + declare + LOK, ROK : Boolean; + LLo, LHi : Uint; + RLo, RHi : Uint; + + Single : Boolean; + -- True if each range is a single point + + begin + Determine_Range (L, LOK, LLo, LHi, Assume_Valid); + Determine_Range (R, ROK, RLo, RHi, Assume_Valid); + + if LOK and ROK then + Single := (LLo = LHi) and then (RLo = RHi); + + if LHi < RLo then + if Single and Assume_Valid then + Diff.all := RLo - LLo; + end if; + + return LT; + + elsif RHi < LLo then + if Single and Assume_Valid then + Diff.all := LLo - RLo; + end if; + + return GT; + + elsif Single and then LLo = RLo then + + -- If the range includes a single literal and we can assume + -- validity then the result is known even if an operand is + -- not static. + + if Assume_Valid then + return EQ; + else + return Unknown; + end if; + + elsif LHi = RLo then + return LE; + + elsif RHi = LLo then + return GE; + + elsif not Is_Known_Valid_Operand (L) + and then not Assume_Valid + then + if Is_Same_Value (L, R) then + return EQ; + else + return Unknown; + end if; + end if; + + -- If the range of either operand cannot be determined, nothing + -- further can be inferred. + + else + return Unknown; + end if; + end; + + -- Here is where we check for comparisons against maximum bounds of + -- types, where we know that no value can be outside the bounds of + -- the subtype. Note that this routine is allowed to assume that all + -- expressions are within their subtype bounds. Callers wishing to + -- deal with possibly invalid values must in any case take special + -- steps (e.g. conversions to larger types) to avoid this kind of + -- optimization, which is always considered to be valid. We do not + -- attempt this optimization with generic types, since the type + -- bounds may not be meaningful in this case. + + -- We are in danger of an infinite recursion here. It does not seem + -- useful to go more than one level deep, so the parameter Rec is + -- used to protect ourselves against this infinite recursion. + + if not Rec then + + -- See if we can get a decisive check against one operand and a + -- bound of the other operand (four possible tests here). Note + -- that we avoid testing junk bounds of a generic type. + + if not Is_Generic_Type (Rtyp) then + case Compile_Time_Compare (L, Type_Low_Bound (Rtyp), + Discard'Access, + Assume_Valid, Rec => True) + is + when LT => return LT; + when LE => return LE; + when EQ => return LE; + when others => null; + end case; + + case Compile_Time_Compare (L, Type_High_Bound (Rtyp), + Discard'Access, + Assume_Valid, Rec => True) + is + when GT => return GT; + when GE => return GE; + when EQ => return GE; + when others => null; + end case; + end if; + + if not Is_Generic_Type (Ltyp) then + case Compile_Time_Compare (Type_Low_Bound (Ltyp), R, + Discard'Access, + Assume_Valid, Rec => True) + is + when GT => return GT; + when GE => return GE; + when EQ => return GE; + when others => null; + end case; + + case Compile_Time_Compare (Type_High_Bound (Ltyp), R, + Discard'Access, + Assume_Valid, Rec => True) + is + when LT => return LT; + when LE => return LE; + when EQ => return LE; + when others => null; + end case; + end if; + end if; + + -- Next attempt is to see if we have an entity compared with a + -- compile time known value, where there is a current value + -- conditional for the entity which can tell us the result. + + declare + Var : Node_Id; + -- Entity variable (left operand) + + Val : Uint; + -- Value (right operand) + + Inv : Boolean; + -- If False, we have reversed the operands + + Op : Node_Kind; + -- Comparison operator kind from Get_Current_Value_Condition call + + Opn : Node_Id; + -- Value from Get_Current_Value_Condition call + + Opv : Uint; + -- Value of Opn + + Result : Compare_Result; + -- Known result before inversion + + begin + if Is_Entity_Name (L) + and then Compile_Time_Known_Value (R) + then + Var := L; + Val := Expr_Value (R); + Inv := False; + + elsif Is_Entity_Name (R) + and then Compile_Time_Known_Value (L) + then + Var := R; + Val := Expr_Value (L); + Inv := True; + + -- That was the last chance at finding a compile time result + + else + return Unknown; + end if; + + Get_Current_Value_Condition (Var, Op, Opn); + + -- That was the last chance, so if we got nothing return + + if No (Opn) then + return Unknown; + end if; + + Opv := Expr_Value (Opn); + + -- We got a comparison, so we might have something interesting + + -- Convert LE to LT and GE to GT, just so we have fewer cases + + if Op = N_Op_Le then + Op := N_Op_Lt; + Opv := Opv + 1; + + elsif Op = N_Op_Ge then + Op := N_Op_Gt; + Opv := Opv - 1; + end if; + + -- Deal with equality case + + if Op = N_Op_Eq then + if Val = Opv then + Result := EQ; + elsif Opv < Val then + Result := LT; + else + Result := GT; + end if; + + -- Deal with inequality case + + elsif Op = N_Op_Ne then + if Val = Opv then + Result := NE; + else + return Unknown; + end if; + + -- Deal with greater than case + + elsif Op = N_Op_Gt then + if Opv >= Val then + Result := GT; + elsif Opv = Val - 1 then + Result := GE; + else + return Unknown; + end if; + + -- Deal with less than case + + else pragma Assert (Op = N_Op_Lt); + if Opv <= Val then + Result := LT; + elsif Opv = Val + 1 then + Result := LE; + else + return Unknown; + end if; + end if; + + -- Deal with inverting result + + if Inv then + case Result is + when GT => return LT; + when GE => return LE; + when LT => return GT; + when LE => return GE; + when others => return Result; + end case; + end if; + + return Result; + end; + end if; + end Compile_Time_Compare; + + ------------------------------- + -- Compile_Time_Known_Bounds -- + ------------------------------- + + function Compile_Time_Known_Bounds (T : Entity_Id) return Boolean is + Indx : Node_Id; + Typ : Entity_Id; + + begin + if T = Any_Composite or else not Is_Array_Type (T) then + return False; + end if; + + Indx := First_Index (T); + while Present (Indx) loop + Typ := Underlying_Type (Etype (Indx)); + + -- Never look at junk bounds of a generic type + + if Is_Generic_Type (Typ) then + return False; + end if; + + -- Otherwise check bounds for compile time known + + if not Compile_Time_Known_Value (Type_Low_Bound (Typ)) then + return False; + elsif not Compile_Time_Known_Value (Type_High_Bound (Typ)) then + return False; + else + Next_Index (Indx); + end if; + end loop; + + return True; + end Compile_Time_Known_Bounds; + + ------------------------------ + -- Compile_Time_Known_Value -- + ------------------------------ + + function Compile_Time_Known_Value (Op : Node_Id) return Boolean is + K : constant Node_Kind := Nkind (Op); + CV_Ent : CV_Entry renames CV_Cache (Nat (Op) mod CV_Cache_Size); + + begin + -- Never known at compile time if bad type or raises constraint error + -- or empty (latter case occurs only as a result of a previous error). + + if No (Op) then + Check_Error_Detected; + return False; + + elsif Op = Error + or else Etype (Op) = Any_Type + or else Raises_Constraint_Error (Op) + then + return False; + end if; + + -- If we have an entity name, then see if it is the name of a constant + -- and if so, test the corresponding constant value, or the name of + -- an enumeration literal, which is always a constant. + + if Present (Etype (Op)) and then Is_Entity_Name (Op) then + declare + E : constant Entity_Id := Entity (Op); + V : 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; + end if; + + if Ekind (E) = E_Enumeration_Literal then + return True; + + elsif Ekind (E) = E_Constant then + V := Constant_Value (E); + return Present (V) and then Compile_Time_Known_Value (V); + 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 + Nkind_In (K, N_Character_Literal, + N_Real_Literal, + N_String_Literal, + N_Null) + 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 => + return False; + end Compile_Time_Known_Value; + + -------------------------------------- + -- Compile_Time_Known_Value_Or_Aggr -- + -------------------------------------- + + function Compile_Time_Known_Value_Or_Aggr (Op : Node_Id) return Boolean is + begin + -- 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 Is_Entity_Name (Op) then + declare + E : constant Entity_Id := Entity (Op); + V : Node_Id; + + begin + if Ekind (E) = E_Enumeration_Literal then + return True; + + elsif Ekind (E) /= E_Constant then + return False; + + else + V := Constant_Value (E); + return Present (V) + and then Compile_Time_Known_Value_Or_Aggr (V); + end if; + end; + + -- We have a value, see if it is compile time known + + else + if Compile_Time_Known_Value (Op) then + return True; + + elsif Nkind (Op) = N_Aggregate then + + if Present (Expressions (Op)) then + declare + Expr : Node_Id; + begin + Expr := First (Expressions (Op)); + while Present (Expr) loop + if not Compile_Time_Known_Value_Or_Aggr (Expr) then + return False; + else + Next (Expr); + end if; + end loop; + end; + end if; + + if Present (Component_Associations (Op)) then + declare + Cass : Node_Id; + + begin + Cass := First (Component_Associations (Op)); + while Present (Cass) loop + if not + Compile_Time_Known_Value_Or_Aggr (Expression (Cass)) + then + return False; + end if; + + Next (Cass); + end loop; + end; + end if; + + return True; + + elsif Nkind (Op) = N_Qualified_Expression then + return Compile_Time_Known_Value_Or_Aggr (Expression (Op)); + + -- All other types of values are not known at compile time + + else + return False; + end if; + + end if; + end Compile_Time_Known_Value_Or_Aggr; + + --------------------------------------- + -- 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, + Warn => not Stat or SPARK_Mode = On); + Set_Raises_Constraint_Error (N); + 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, + 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, + 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); + + -- For a signed integer type, check non-static overflow + + elsif (not Stat) and then Is_Signed_Integer_Type (Ltype) then + declare + BT : constant Entity_Id := Base_Type (Ltype); + 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); + return; + end if; + end; + end if; + + -- 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); + 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 (see 7423-001) 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; + 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; + + 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; + 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 + T : constant Entity_Id := Etype (N); + + function In_Any_Integer_Context 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 return Boolean is + Par : constant Node_Id := Parent (N); + K : constant Node_Kind := Nkind (Par); + + 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 Nkind_In (K, N_Number_Declaration, + N_Attribute_Reference, + N_Attribute_Definition_Clause, + N_Modular_Type_Definition, + N_Signed_Integer_Type_Definition); + end In_Any_Integer_Context; + + -- 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. + + -- An exception is made for a literal in an if or case expression + + if (Nkind_In (Parent (N), N_If_Expression, N_Case_Expression_Alternative) + or else Nkind (Parent (N)) not in N_Subexpr) + and then not In_Any_Integer_Context + then + Check_Non_Static_Context (N); + end if; + + -- Modular integer literals must be in their base range + + if Is_Modular_Integer_Type (T) + and then Is_Out_Of_Range (N, Base_Type (T), Assume_Valid => True) + then + Out_Of_Range (N); + end if; + end Eval_Integer_Literal; + + --------------------- + -- 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); + 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 + + declare + Left_Int : constant Uint := Expr_Value (Left); + Right_Int : constant Uint := Expr_Value (Right); + + begin + if Is_Modular_Integer_Type (Etype (N)) then + 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 weren't working at the time ??? + + 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 Nkind (N) = N_Op_And then + Fold_Uint (N, + Test (Is_True (Left_Int) and then Is_True (Right_Int)), Stat); + + elsif Nkind (N) = N_Op_Or then + Fold_Uint (N, + Test (Is_True (Left_Int) or else Is_True (Right_Int)), Stat); + + 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; + 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; + + 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 functions, 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 (11)). + + 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; + 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; + + -- Here we will fold, save Print_In_Hex indication + + Hex := Nkind (Operand) = N_Integer_Literal + and then Print_In_Hex (Operand); + + -- Fold the result of qualification + + if Is_Discrete_Type (Target_Type) then + 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 for strings, + -- the result is never static, even if the operands are. + + -- 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))); + + -- 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_In (N, N_Op_Eq, N_Op_Ne) + then + if Raises_Constraint_Error (Left) + or else + Raises_Constraint_Error (Right) + then + return; + + -- OK, we have the case where we may be able to do this fold + + else + 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 + Fold_Uint (N, Test (Nkind (N) = N_Op_Ne), False); + Warn_On_Known_Condition (N); + return; + end if; + end if; + + -- General case + + else + -- 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); + + -- Only comparisons of scalars can give static results. A comparison + -- of strings never yields a static result, even if both operands are + -- static strings, except that as noted above, we allow equality and + -- inequality for strings. + + if Is_String_Type (Left_Typ) + and then not Comes_From_Source (N) + and then Nkind_In (N, N_Op_Eq, N_Op_Ne) + then + null; + + 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; + 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_Shift -- + ---------------- + + -- Shift operations are intrinsic operations that can never be static, so + -- the only processing required is to perform the required check for a non + -- static context for the two operands. + + -- Actually we could do some compile time evaluation here some time ??? + + procedure Eval_Shift (N : Node_Id) is + begin + Check_Non_Static_Context (Left_Opnd (N)); + Check_Non_Static_Context (Right_Opnd (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); + + 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 (Prefix (N)) then + declare + E : constant Entity_Id := Entity (Prefix (N)); + T : constant Entity_Id := Etype (E); + + begin + if Ekind (E) = E_Constant + 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 + + if Nkind (Original_Node (N)) = N_Type_Conversion 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 UI_From_Int (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)). + + 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 not static + + if Is_String_Type (Target_Type) then + Fold_Str (N, Strval (Get_String_Val (Operand)), Static => False); + 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 + + else + Result := UR_To_Uint (Expr_Value_R (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 Is_Out_Of_Range (N, Etype (N), Assume_Valid => True) then + Out_Of_Range (N); + end if; + + end Eval_Type_Conversion; + + ------------------- + -- Eval_Unary_Op -- + ------------------- + + -- Predefined unary operators are static functions (RM 4.9(20)) and thus + -- are potentially static if the operand is potentially static (RM 4.9(7)). + + procedure Eval_Unary_Op (N : Node_Id) is + Right : constant Node_Id := Right_Opnd (N); + Otype : Entity_Id := Empty; + 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; + + if Etype (Right) = Universal_Integer + or else + Etype (Right) = Universal_Real + then + Otype := Find_Universal_Operator_Type (N); + end if; + + -- Fold for integer case + + if Is_Integer_Type (Etype (N)) then + declare + Rint : constant Uint := Expr_Value (Right); + Result : Uint; + + begin + -- In the case of modular unary plus and abs there is no need + -- to adjust the result of the operation since if the original + -- operand was in bounds the result will be in the bounds of the + -- modular type. However, in the case of modular unary minus the + -- result may go out of the bounds of the modular type and needs + -- adjustment. + + if Nkind (N) = N_Op_Plus then + Result := Rint; + + elsif Nkind (N) = N_Op_Minus then + if Is_Modular_Integer_Type (Etype (N)) then + Result := (-Rint) mod Modulus (Etype (N)); + else + Result := (-Rint); + end if; + + else + pragma Assert (Nkind (N) = N_Op_Abs); + Result := abs Rint; + end if; + + Fold_Uint (N, Result, Stat); + end; + + -- Fold for real case + + elsif Is_Real_Type (Etype (N)) then + declare + Rreal : constant Ureal := Expr_Value_R (Right); + Result : Ureal; + + begin + if Nkind (N) = N_Op_Plus then + Result := Rreal; + elsif Nkind (N) = N_Op_Minus then + Result := UR_Negate (Rreal); + else + pragma Assert (Nkind (N) = N_Op_Abs); + Result := abs Rreal; + 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_Unary_Op; + + ------------------------------- + -- Eval_Unchecked_Conversion -- + ------------------------------- + + -- Unchecked conversions can never be static, so the only required + -- processing is to check for a non-static context for the operand. + + procedure Eval_Unchecked_Conversion (N : Node_Id) is + begin + Check_Non_Static_Context (Expression (N)); + end Eval_Unchecked_Conversion; + + -------------------- + -- Expr_Rep_Value -- + -------------------- + + function Expr_Rep_Value (N : Node_Id) return Uint is + Kind : constant Node_Kind := Nkind (N); + Ent : Entity_Id; + + begin + if Is_Entity_Name (N) then + Ent := Entity (N); + + -- An enumeration literal that was either in the source or created + -- as a result of static evaluation. + + if Ekind (Ent) = E_Enumeration_Literal then + return Enumeration_Rep (Ent); + + -- A user defined static constant + + else + pragma Assert (Ekind (Ent) = E_Constant); + return Expr_Rep_Value (Constant_Value (Ent)); + end if; + + -- An integer literal that was either in the source or created as a + -- result of static evaluation. + + elsif Kind = N_Integer_Literal then + return Intval (N); + + -- A real literal for a fixed-point type. This must be the fixed-point + -- case, either the literal is of a fixed-point type, or it is a bound + -- of a fixed-point type, with type universal real. In either case we + -- obtain the desired value from Corresponding_Integer_Value. + + elsif Kind = N_Real_Literal then + pragma Assert (Is_Fixed_Point_Type (Underlying_Type (Etype (N)))); + return Corresponding_Integer_Value (N); + + -- Otherwise must be character literal + + else + pragma Assert (Kind = N_Character_Literal); + Ent := Entity (N); + + -- Since Character literals of type Standard.Character don't have any + -- defining character literals built for them, they do not have their + -- Entity set, so just use their Char code. Otherwise for user- + -- defined character literals use their Pos value as usual which is + -- the same as the Rep value. + + if No (Ent) then + return Char_Literal_Value (N); + else + return Enumeration_Rep (Ent); + end if; + end if; + end Expr_Rep_Value; + + ---------------- + -- Expr_Value -- + ---------------- + + function Expr_Value (N : Node_Id) return Uint is + Kind : constant Node_Kind := Nkind (N); + CV_Ent : CV_Entry renames CV_Cache (Nat (N) mod CV_Cache_Size); + Ent : Entity_Id; + Val : Uint; + + begin + -- If already in cache, then we know it's compile time known and we can + -- return the value that was previously stored in the cache since + -- compile time known values cannot change. + + if CV_Ent.N = N then + return CV_Ent.V; + end if; + + -- Otherwise proceed to test value + + if Is_Entity_Name (N) then + Ent := Entity (N); + + -- An enumeration literal that was either in the source or created as + -- a result of static evaluation. + + if Ekind (Ent) = E_Enumeration_Literal then + Val := Enumeration_Pos (Ent); + + -- A user defined static constant + + else + pragma Assert (Ekind (Ent) = E_Constant); + Val := Expr_Value (Constant_Value (Ent)); + end if; + + -- An integer literal that was either in the source or created as a + -- result of static evaluation. + + elsif Kind = N_Integer_Literal then + Val := Intval (N); + + -- A real literal for a fixed-point type. This must be the fixed-point + -- case, either the literal is of a fixed-point type, or it is a bound + -- of a fixed-point type, with type universal real. In either case we + -- obtain the desired value from Corresponding_Integer_Value. + + elsif Kind = N_Real_Literal then + pragma Assert (Is_Fixed_Point_Type (Underlying_Type (Etype (N)))); + Val := Corresponding_Integer_Value (N); + + -- The NULL access value + + elsif Kind = N_Null then + pragma Assert (Is_Access_Type (Underlying_Type (Etype (N)))); + Val := Uint_0; + + -- Otherwise must be character literal + + else + pragma Assert (Kind = N_Character_Literal); + Ent := Entity (N); + + -- Since Character literals of type Standard.Character don't + -- have any defining character literals built for them, they + -- do not have their Entity set, so just use their Char + -- code. Otherwise for user-defined character literals use + -- their Pos value as usual. + + if No (Ent) then + Val := Char_Literal_Value (N); + else + Val := Enumeration_Pos (Ent); + end if; + end if; + + -- Come here with Val set to value to be returned, set cache + + CV_Ent.N := N; + CV_Ent.V := Val; + return Val; + end Expr_Value; + + ------------------ + -- Expr_Value_E -- + ------------------ + + function Expr_Value_E (N : Node_Id) return Entity_Id is + Ent : constant Entity_Id := Entity (N); + begin + if Ekind (Ent) = E_Enumeration_Literal then + return Ent; + else + pragma Assert (Ekind (Ent) = E_Constant); + return Expr_Value_E (Constant_Value (Ent)); + end if; + end Expr_Value_E; + + ------------------ + -- Expr_Value_R -- + ------------------ + + function Expr_Value_R (N : Node_Id) return Ureal is + Kind : constant Node_Kind := Nkind (N); + Ent : Entity_Id; + + begin + if Kind = N_Real_Literal then + return Realval (N); + + elsif Kind = N_Identifier or else Kind = N_Expanded_Name then + Ent := Entity (N); + pragma Assert (Ekind (Ent) = E_Constant); + return Expr_Value_R (Constant_Value (Ent)); + + elsif Kind = N_Integer_Literal then + return UR_From_Uint (Expr_Value (N)); + + -- Here, we have a node that cannot be interpreted as a compile time + -- constant. That is definitely an error. + + else + raise Program_Error; + end if; + end Expr_Value_R; + + ------------------ + -- Expr_Value_S -- + ------------------ + + function Expr_Value_S (N : Node_Id) return Node_Id is + begin + if Nkind (N) = N_String_Literal then + return N; + else + pragma Assert (Ekind (Entity (N)) = E_Constant); + return Expr_Value_S (Constant_Value (Entity (N))); + end if; + end Expr_Value_S; + + ---------------------------------- + -- Find_Universal_Operator_Type -- + ---------------------------------- + + function Find_Universal_Operator_Type (N : Node_Id) return Entity_Id is + PN : constant Node_Id := Parent (N); + Call : constant Node_Id := Original_Node (N); + Is_Int : constant Boolean := Is_Integer_Type (Etype (N)); + + Is_Fix : constant Boolean := + Nkind (N) in N_Binary_Op + and then Nkind (Right_Opnd (N)) /= Nkind (Left_Opnd (N)); + -- A mixed-mode operation in this context indicates the presence of + -- fixed-point type in the designated package. + + Is_Relational : constant Boolean := Etype (N) = Standard_Boolean; + -- Case where N is a relational (or membership) operator (else it is an + -- arithmetic one). + + In_Membership : constant Boolean := + Nkind (PN) in N_Membership_Test + and then + Nkind (Right_Opnd (PN)) = N_Range + and then + Is_Universal_Numeric_Type (Etype (Left_Opnd (PN))) + and then + Is_Universal_Numeric_Type + (Etype (Low_Bound (Right_Opnd (PN)))) + and then + Is_Universal_Numeric_Type + (Etype (High_Bound (Right_Opnd (PN)))); + -- Case where N is part of a membership test with a universal range + + E : Entity_Id; + Pack : Entity_Id; + Typ1 : Entity_Id := Empty; + Priv_E : Entity_Id; + + function Is_Mixed_Mode_Operand (Op : Node_Id) return Boolean; + -- Check whether one operand is a mixed-mode operation that requires the + -- presence of a fixed-point type. Given that all operands are universal + -- and have been constant-folded, retrieve the original function call. + + --------------------------- + -- Is_Mixed_Mode_Operand -- + --------------------------- + + function Is_Mixed_Mode_Operand (Op : Node_Id) return Boolean is + Onod : constant Node_Id := Original_Node (Op); + begin + return Nkind (Onod) = N_Function_Call + and then Present (Next_Actual (First_Actual (Onod))) + and then Etype (First_Actual (Onod)) /= + Etype (Next_Actual (First_Actual (Onod))); + end Is_Mixed_Mode_Operand; + + -- Start of processing for Find_Universal_Operator_Type + + begin + if Nkind (Call) /= N_Function_Call + or else Nkind (Name (Call)) /= N_Expanded_Name + then + return Empty; + + -- There are several cases where the context does not imply the type of + -- the operands: + -- - the universal expression appears in a type conversion; + -- - the expression is a relational operator applied to universal + -- operands; + -- - the expression is a membership test with a universal operand + -- and a range with universal bounds. + + elsif Nkind (Parent (N)) = N_Type_Conversion + or else Is_Relational + or else In_Membership + then + Pack := Entity (Prefix (Name (Call))); + + -- If the prefix is a package declared elsewhere, iterate over its + -- visible entities, otherwise iterate over all declarations in the + -- designated scope. + + if Ekind (Pack) = E_Package + and then not In_Open_Scopes (Pack) + then + Priv_E := First_Private_Entity (Pack); + else + Priv_E := Empty; + end if; + + Typ1 := Empty; + E := First_Entity (Pack); + while Present (E) and then E /= Priv_E loop + if Is_Numeric_Type (E) + and then Nkind (Parent (E)) /= N_Subtype_Declaration + and then Comes_From_Source (E) + and then Is_Integer_Type (E) = Is_Int + and then (Nkind (N) in N_Unary_Op + or else Is_Relational + or else Is_Fixed_Point_Type (E) = Is_Fix) + then + if No (Typ1) then + Typ1 := E; + + -- Before emitting an error, check for the presence of a + -- mixed-mode operation that specifies a fixed point type. + + elsif Is_Relational + and then + (Is_Mixed_Mode_Operand (Left_Opnd (N)) + or else Is_Mixed_Mode_Operand (Right_Opnd (N))) + and then Is_Fixed_Point_Type (E) /= Is_Fixed_Point_Type (Typ1) + + then + if Is_Fixed_Point_Type (E) then + Typ1 := E; + end if; + + else + -- More than one type of the proper class declared in P + + Error_Msg_N ("ambiguous operation", N); + Error_Msg_Sloc := Sloc (Typ1); + Error_Msg_N ("\possible interpretation (inherited)#", N); + Error_Msg_Sloc := Sloc (E); + Error_Msg_N ("\possible interpretation (inherited)#", N); + return Empty; + end if; + end if; + + Next_Entity (E); + end loop; + end if; + + return Typ1; + end Find_Universal_Operator_Type; + + -------------------------- + -- Flag_Non_Static_Expr -- + -------------------------- + + procedure Flag_Non_Static_Expr (Msg : String; Expr : Node_Id) is + begin + if Error_Posted (Expr) and then not All_Errors_Mode then + return; + else + Error_Msg_F (Msg, Expr); + Why_Not_Static (Expr); + end if; + end Flag_Non_Static_Expr; + + -------------- + -- Fold_Str -- + -------------- + + procedure Fold_Str (N : Node_Id; Val : String_Id; Static : Boolean) is + Loc : constant Source_Ptr := Sloc (N); + Typ : constant Entity_Id := Etype (N); + + begin + if Raises_Constraint_Error (N) then + Set_Is_Static_Expression (N, Static); + return; + end if; + + Rewrite (N, Make_String_Literal (Loc, Strval => Val)); + + -- We now have the literal with the right value, both the actual type + -- and the expected type of this literal are taken from the expression + -- that was evaluated. So now we do the Analyze and Resolve. + + -- Note that we have to reset Is_Static_Expression both after the + -- analyze step (because Resolve will evaluate the literal, which + -- will cause semantic errors if it is marked as static), and after + -- the Resolve step (since Resolve in some cases resets this flag). + + Analyze (N); + Set_Is_Static_Expression (N, Static); + Set_Etype (N, Typ); + Resolve (N); + Set_Is_Static_Expression (N, Static); + end Fold_Str; + + --------------- + -- Fold_Uint -- + --------------- + + procedure Fold_Uint (N : Node_Id; Val : Uint; Static : Boolean) is + Loc : constant Source_Ptr := Sloc (N); + Typ : Entity_Id := Etype (N); + Ent : Entity_Id; + + begin + if Raises_Constraint_Error (N) then + Set_Is_Static_Expression (N, Static); + return; + end if; + + -- If we are folding a named number, retain the entity in the literal, + -- for ASIS use. + + if Is_Entity_Name (N) and then Ekind (Entity (N)) = E_Named_Integer then + Ent := Entity (N); + else + Ent := Empty; + end if; + + if Is_Private_Type (Typ) then + Typ := Full_View (Typ); + end if; + + -- For a result of type integer, substitute an N_Integer_Literal node + -- for the result of the compile time evaluation of the expression. + -- For ASIS use, set a link to the original named number when not in + -- a generic context. + + if Is_Integer_Type (Typ) then + Rewrite (N, Make_Integer_Literal (Loc, Val)); + Set_Original_Entity (N, Ent); + + -- Otherwise we have an enumeration type, and we substitute either + -- an N_Identifier or N_Character_Literal to represent the enumeration + -- literal corresponding to the given value, which must always be in + -- range, because appropriate tests have already been made for this. + + else pragma Assert (Is_Enumeration_Type (Typ)); + Rewrite (N, Get_Enum_Lit_From_Pos (Etype (N), Val, Loc)); + end if; + + -- We now have the literal with the right value, both the actual type + -- and the expected type of this literal are taken from the expression + -- that was evaluated. So now we do the Analyze and Resolve. + + -- Note that we have to reset Is_Static_Expression both after the + -- analyze step (because Resolve will evaluate the literal, which + -- will cause semantic errors if it is marked as static), and after + -- the Resolve step (since Resolve in some cases sets this flag). + + Analyze (N); + Set_Is_Static_Expression (N, Static); + Set_Etype (N, Typ); + Resolve (N); + Set_Is_Static_Expression (N, Static); + end Fold_Uint; + + ---------------- + -- Fold_Ureal -- + ---------------- + + procedure Fold_Ureal (N : Node_Id; Val : Ureal; Static : Boolean) is + Loc : constant Source_Ptr := Sloc (N); + Typ : constant Entity_Id := Etype (N); + Ent : Entity_Id; + + begin + if Raises_Constraint_Error (N) then + Set_Is_Static_Expression (N, Static); + return; + end if; + + -- If we are folding a named number, retain the entity in the literal, + -- for ASIS use. + + if Is_Entity_Name (N) and then Ekind (Entity (N)) = E_Named_Real then + Ent := Entity (N); + else + Ent := Empty; + end if; + + Rewrite (N, Make_Real_Literal (Loc, Realval => Val)); + + -- Set link to original named number, for ASIS use + + Set_Original_Entity (N, Ent); + + -- We now have the literal with the right value, both the actual type + -- and the expected type of this literal are taken from the expression + -- that was evaluated. So now we do the Analyze and Resolve. + + -- Note that we have to reset Is_Static_Expression both after the + -- analyze step (because Resolve will evaluate the literal, which + -- will cause semantic errors if it is marked as static), and after + -- the Resolve step (since Resolve in some cases sets this flag). + + Analyze (N); + Set_Is_Static_Expression (N, Static); + Set_Etype (N, Typ); + Resolve (N); + Set_Is_Static_Expression (N, Static); + end Fold_Ureal; + + --------------- + -- From_Bits -- + --------------- + + function From_Bits (B : Bits; T : Entity_Id) return Uint is + V : Uint := Uint_0; + + begin + for J in 0 .. B'Last loop + if B (J) then + V := V + 2 ** J; + end if; + end loop; + + if Non_Binary_Modulus (T) then + V := V mod Modulus (T); + end if; + + return V; + end From_Bits; + + -------------------- + -- Get_String_Val -- + -------------------- + + function Get_String_Val (N : Node_Id) return Node_Id is + begin + if Nkind_In (N, N_String_Literal, N_Character_Literal) then + return N; + else + pragma Assert (Is_Entity_Name (N)); + return Get_String_Val (Constant_Value (Entity (N))); + end if; + end Get_String_Val; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize is + begin + CV_Cache := (others => (Node_High_Bound, Uint_0)); + end Initialize; + + -------------------- + -- In_Subrange_Of -- + -------------------- + + function In_Subrange_Of + (T1 : Entity_Id; + T2 : Entity_Id; + Fixed_Int : Boolean := False) return Boolean + is + L1 : Node_Id; + H1 : Node_Id; + + L2 : Node_Id; + H2 : Node_Id; + + begin + if T1 = T2 or else Is_Subtype_Of (T1, T2) then + return True; + + -- Never in range if both types are not scalar. Don't know if this can + -- actually happen, but just in case. + + elsif not Is_Scalar_Type (T1) or else not Is_Scalar_Type (T2) then + return False; + + -- If T1 has infinities but T2 doesn't have infinities, then T1 is + -- definitely not compatible with T2. + + elsif Is_Floating_Point_Type (T1) + and then Has_Infinities (T1) + and then Is_Floating_Point_Type (T2) + and then not Has_Infinities (T2) + then + return False; + + else + L1 := Type_Low_Bound (T1); + H1 := Type_High_Bound (T1); + + L2 := Type_Low_Bound (T2); + H2 := Type_High_Bound (T2); + + -- Check bounds to see if comparison possible at compile time + + if Compile_Time_Compare (L1, L2, Assume_Valid => True) in Compare_GE + and then + Compile_Time_Compare (H1, H2, Assume_Valid => True) in Compare_LE + then + return True; + end if; + + -- If bounds not comparable at compile time, then the bounds of T2 + -- must be compile time known or we cannot answer the query. + + if not Compile_Time_Known_Value (L2) + or else not Compile_Time_Known_Value (H2) + then + return False; + end if; + + -- If the bounds of T1 are know at compile time then use these + -- ones, otherwise use the bounds of the base type (which are of + -- course always static). + + if not Compile_Time_Known_Value (L1) then + L1 := Type_Low_Bound (Base_Type (T1)); + end if; + + if not Compile_Time_Known_Value (H1) then + H1 := Type_High_Bound (Base_Type (T1)); + end if; + + -- Fixed point types should be considered as such only if + -- flag Fixed_Int is set to False. + + if Is_Floating_Point_Type (T1) or else Is_Floating_Point_Type (T2) + or else (Is_Fixed_Point_Type (T1) and then not Fixed_Int) + or else (Is_Fixed_Point_Type (T2) and then not Fixed_Int) + then + return + Expr_Value_R (L2) <= Expr_Value_R (L1) + and then + Expr_Value_R (H2) >= Expr_Value_R (H1); + + else + return + Expr_Value (L2) <= Expr_Value (L1) + and then + Expr_Value (H2) >= Expr_Value (H1); + + end if; + end if; + + -- If any exception occurs, it means that we have some bug in the compiler + -- possibly triggered by a previous error, or by some unforeseen peculiar + -- occurrence. However, this is only an optimization attempt, so there is + -- really no point in crashing the compiler. Instead we just decide, too + -- bad, we can't figure out the answer in this case after all. + + exception + when others => + + -- Debug flag K disables this behavior (useful for debugging) + + if Debug_Flag_K then + raise; + else + return False; + end if; + end In_Subrange_Of; + + ----------------- + -- Is_In_Range -- + ----------------- + + function Is_In_Range + (N : Node_Id; + Typ : Entity_Id; + Assume_Valid : Boolean := False; + Fixed_Int : Boolean := False; + Int_Real : Boolean := False) return Boolean + is + begin + return + Test_In_Range (N, Typ, Assume_Valid, Fixed_Int, Int_Real) = In_Range; + end Is_In_Range; + + ------------------- + -- Is_Null_Range -- + ------------------- + + function Is_Null_Range (Lo : Node_Id; Hi : Node_Id) return Boolean is + Typ : constant Entity_Id := Etype (Lo); + + begin + if not Compile_Time_Known_Value (Lo) + or else not Compile_Time_Known_Value (Hi) + then + return False; + end if; + + if Is_Discrete_Type (Typ) then + return Expr_Value (Lo) > Expr_Value (Hi); + else pragma Assert (Is_Real_Type (Typ)); + return Expr_Value_R (Lo) > Expr_Value_R (Hi); + end if; + end Is_Null_Range; + + ------------------------- + -- Is_OK_Static_Choice -- + ------------------------- + + function Is_OK_Static_Choice (Choice : Node_Id) return Boolean is + begin + -- Check various possibilities for choice + + -- Note: for membership tests, we test more cases than are possible + -- (in particular subtype indication), but it doesn't matter because + -- it just won't occur (we have already done a syntax check). + + if Nkind (Choice) = N_Others_Choice then + return True; + + elsif Nkind (Choice) = N_Range then + return Is_OK_Static_Range (Choice); + + elsif Nkind (Choice) = N_Subtype_Indication + or else (Is_Entity_Name (Choice) and then Is_Type (Entity (Choice))) + then + return Is_OK_Static_Subtype (Etype (Choice)); + + else + return Is_OK_Static_Expression (Choice); + end if; + end Is_OK_Static_Choice; + + ------------------------------ + -- Is_OK_Static_Choice_List -- + ------------------------------ + + function Is_OK_Static_Choice_List (Choices : List_Id) return Boolean is + Choice : Node_Id; + + begin + if not Is_Static_Choice_List (Choices) then + return False; + end if; + + Choice := First (Choices); + while Present (Choice) loop + if not Is_OK_Static_Choice (Choice) then + Set_Raises_Constraint_Error (Choice); + return False; + end if; + + Next (Choice); + end loop; + + return True; + end Is_OK_Static_Choice_List; + + ----------------------------- + -- Is_OK_Static_Expression -- + ----------------------------- + + function Is_OK_Static_Expression (N : Node_Id) return Boolean is + begin + return Is_Static_Expression (N) and then not Raises_Constraint_Error (N); + end Is_OK_Static_Expression; + + ------------------------ + -- Is_OK_Static_Range -- + ------------------------ + + -- A static range is a range whose bounds are static expressions, or a + -- Range_Attribute_Reference equivalent to such a range (RM 4.9(26)). + -- We have already converted range attribute references, so we get the + -- "or" part of this rule without needing a special test. + + function Is_OK_Static_Range (N : Node_Id) return Boolean is + begin + return Is_OK_Static_Expression (Low_Bound (N)) + and then Is_OK_Static_Expression (High_Bound (N)); + end Is_OK_Static_Range; + + -------------------------- + -- Is_OK_Static_Subtype -- + -------------------------- + + -- Determines if Typ is a static subtype as defined in (RM 4.9(26)) where + -- neither bound raises constraint error when evaluated. + + function Is_OK_Static_Subtype (Typ : Entity_Id) return Boolean is + Base_T : constant Entity_Id := Base_Type (Typ); + Anc_Subt : Entity_Id; + + begin + -- First a quick check on the non static subtype flag. As described + -- in further detail in Einfo, this flag is not decisive in all cases, + -- but if it is set, then the subtype is definitely non-static. + + if Is_Non_Static_Subtype (Typ) then + return False; + end if; + + Anc_Subt := Ancestor_Subtype (Typ); + + if Anc_Subt = Empty then + Anc_Subt := Base_T; + end if; + + if Is_Generic_Type (Root_Type (Base_T)) + or else Is_Generic_Actual_Type (Base_T) + then + return False; + + elsif Has_Dynamic_Predicate_Aspect (Typ) then + return False; + + -- String types + + elsif Is_String_Type (Typ) then + return + Ekind (Typ) = E_String_Literal_Subtype + or else + (Is_OK_Static_Subtype (Component_Type (Typ)) + and then Is_OK_Static_Subtype (Etype (First_Index (Typ)))); + + -- Scalar types + + elsif Is_Scalar_Type (Typ) then + if Base_T = Typ then + return True; + + else + -- Scalar_Range (Typ) might be an N_Subtype_Indication, so use + -- Get_Type_{Low,High}_Bound. + + return Is_OK_Static_Subtype (Anc_Subt) + and then Is_OK_Static_Expression (Type_Low_Bound (Typ)) + and then Is_OK_Static_Expression (Type_High_Bound (Typ)); + end if; + + -- Types other than string and scalar types are never static + + else + return False; + end if; + end Is_OK_Static_Subtype; + + --------------------- + -- Is_Out_Of_Range -- + --------------------- + + function Is_Out_Of_Range + (N : Node_Id; + Typ : Entity_Id; + Assume_Valid : Boolean := False; + Fixed_Int : Boolean := False; + Int_Real : Boolean := False) return Boolean + is + begin + return Test_In_Range (N, Typ, Assume_Valid, Fixed_Int, Int_Real) = + Out_Of_Range; + end Is_Out_Of_Range; + + ---------------------- + -- Is_Static_Choice -- + ---------------------- + + function Is_Static_Choice (Choice : Node_Id) return Boolean is + begin + -- Check various possibilities for choice + + -- Note: for membership tests, we test more cases than are possible + -- (in particular subtype indication), but it doesn't matter because + -- it just won't occur (we have already done a syntax check). + + if Nkind (Choice) = N_Others_Choice then + return True; + + elsif Nkind (Choice) = N_Range then + return Is_Static_Range (Choice); + + elsif Nkind (Choice) = N_Subtype_Indication + or else (Is_Entity_Name (Choice) and then Is_Type (Entity (Choice))) + then + return Is_Static_Subtype (Etype (Choice)); + + else + return Is_Static_Expression (Choice); + end if; + end Is_Static_Choice; + + --------------------------- + -- Is_Static_Choice_List -- + --------------------------- + + function Is_Static_Choice_List (Choices : List_Id) return Boolean is + Choice : Node_Id; + + begin + Choice := First (Choices); + while Present (Choice) loop + if not Is_Static_Choice (Choice) then + return False; + end if; + + Next (Choice); + end loop; + + return True; + end Is_Static_Choice_List; + + --------------------- + -- Is_Static_Range -- + --------------------- + + -- A static range is a range whose bounds are static expressions, or a + -- Range_Attribute_Reference equivalent to such a range (RM 4.9(26)). + -- We have already converted range attribute references, so we get the + -- "or" part of this rule without needing a special test. + + function Is_Static_Range (N : Node_Id) return Boolean is + begin + return Is_Static_Expression (Low_Bound (N)) + and then + Is_Static_Expression (High_Bound (N)); + end Is_Static_Range; + + ----------------------- + -- Is_Static_Subtype -- + ----------------------- + + -- Determines if Typ is a static subtype as defined in (RM 4.9(26)) + + function Is_Static_Subtype (Typ : Entity_Id) return Boolean is + Base_T : constant Entity_Id := Base_Type (Typ); + Anc_Subt : Entity_Id; + + begin + -- First a quick check on the non static subtype flag. As described + -- in further detail in Einfo, this flag is not decisive in all cases, + -- but if it is set, then the subtype is definitely non-static. + + if Is_Non_Static_Subtype (Typ) then + return False; + end if; + + Anc_Subt := Ancestor_Subtype (Typ); + + if Anc_Subt = Empty then + Anc_Subt := Base_T; + end if; + + if Is_Generic_Type (Root_Type (Base_T)) + or else Is_Generic_Actual_Type (Base_T) + then + return False; + + -- If there is a dynamic predicate for the type (declared or inherited) + -- the expression is not static. + + elsif Has_Dynamic_Predicate_Aspect (Typ) + or else (Is_Derived_Type (Typ) + and then Has_Aspect (Typ, Aspect_Dynamic_Predicate)) + then + return False; + + -- String types + + elsif Is_String_Type (Typ) then + return + Ekind (Typ) = E_String_Literal_Subtype + or else (Is_Static_Subtype (Component_Type (Typ)) + and then Is_Static_Subtype (Etype (First_Index (Typ)))); + + -- Scalar types + + elsif Is_Scalar_Type (Typ) then + if Base_T = Typ then + return True; + + else + return Is_Static_Subtype (Anc_Subt) + and then Is_Static_Expression (Type_Low_Bound (Typ)) + and then Is_Static_Expression (Type_High_Bound (Typ)); + end if; + + -- Types other than string and scalar types are never static + + else + return False; + end if; + end Is_Static_Subtype; + + ------------------------------- + -- Is_Statically_Unevaluated -- + ------------------------------- + + function Is_Statically_Unevaluated (Expr : Node_Id) return Boolean is + function Check_Case_Expr_Alternative + (CEA : Node_Id) return Match_Result; + -- We have a message emanating from the Expression of a case expression + -- alternative. We examine this alternative, as follows: + -- + -- If the selecting expression of the parent case is non-static, or + -- if any of the discrete choices of the given case alternative are + -- non-static or raise Constraint_Error, return Non_Static. + -- + -- Otherwise check if the selecting expression matches any of the given + -- discrete choices. If so, the alternative is executed and we return + -- Match, otherwise, the alternative can never be executed, and so we + -- return No_Match. + + --------------------------------- + -- Check_Case_Expr_Alternative -- + --------------------------------- + + function Check_Case_Expr_Alternative + (CEA : Node_Id) return Match_Result + is + Case_Exp : constant Node_Id := Parent (CEA); + Choice : Node_Id; + Prev_CEA : Node_Id; + + begin + pragma Assert (Nkind (Case_Exp) = N_Case_Expression); + + -- Check that selecting expression is static + + if not Is_OK_Static_Expression (Expression (Case_Exp)) then + return Non_Static; + end if; + + if not Is_OK_Static_Choice_List (Discrete_Choices (CEA)) then + return Non_Static; + end if; + + -- All choices are now known to be static. Now see if alternative + -- matches one of the choices. + + Choice := First (Discrete_Choices (CEA)); + while Present (Choice) loop + + -- Check various possibilities for choice, returning Match if we + -- find the selecting value matches any of the choices. Note that + -- we know we are the last choice, so we don't have to keep going. + + if Nkind (Choice) = N_Others_Choice then + + -- Others choice is a bit annoying, it matches if none of the + -- previous alternatives matches (note that we know we are the + -- last alternative in this case, so we can just go backwards + -- from us to see if any previous one matches). + + Prev_CEA := Prev (CEA); + while Present (Prev_CEA) loop + if Check_Case_Expr_Alternative (Prev_CEA) = Match then + return No_Match; + end if; + + Prev (Prev_CEA); + end loop; + + return Match; + + -- Else we have a normal static choice + + elsif Choice_Matches (Expression (Case_Exp), Choice) = Match then + return Match; + end if; + + -- If we fall through, it means that the discrete choice did not + -- match the selecting expression, so continue. + + Next (Choice); + end loop; + + -- If we get through that loop then all choices were static, and none + -- of them matched the selecting expression. So return No_Match. + + return No_Match; + end Check_Case_Expr_Alternative; + + -- Local variables + + P : Node_Id; + OldP : Node_Id; + Choice : Node_Id; + + -- Start of processing for Is_Statically_Unevaluated + + begin + -- The (32.x) references here are from RM section 4.9 + + -- (32.1) An expression is statically unevaluated if it is part of ... + + -- This means we have to climb the tree looking for one of the cases + + P := Expr; + loop + OldP := P; + P := Parent (P); + + -- (32.2) The right operand of a static short-circuit control form + -- whose value is determined by its left operand. + + -- AND THEN with False as left operand + + if Nkind (P) = N_And_Then + and then Compile_Time_Known_Value (Left_Opnd (P)) + and then Is_False (Expr_Value (Left_Opnd (P))) + then + return True; + + -- OR ELSE with True as left operand + + elsif Nkind (P) = N_Or_Else + and then Compile_Time_Known_Value (Left_Opnd (P)) + and then Is_True (Expr_Value (Left_Opnd (P))) + then + return True; + + -- (32.3) A dependent_expression of an if_expression whose associated + -- condition is static and equals False. + + elsif Nkind (P) = N_If_Expression then + declare + Cond : constant Node_Id := First (Expressions (P)); + Texp : constant Node_Id := Next (Cond); + Fexp : constant Node_Id := Next (Texp); + + begin + if Compile_Time_Known_Value (Cond) then + + -- Condition is True and we are in the right operand + + if Is_True (Expr_Value (Cond)) and then OldP = Fexp then + return True; + + -- Condition is False and we are in the left operand + + elsif Is_False (Expr_Value (Cond)) and then OldP = Texp then + return True; + end if; + end if; + end; + + -- (32.4) A condition or dependent_expression of an if_expression + -- where the condition corresponding to at least one preceding + -- dependent_expression of the if_expression is static and equals + -- True. + + -- This refers to cases like + + -- (if True then 1 elsif 1/0=2 then 2 else 3) + + -- But we expand elsif's out anyway, so the above looks like: + + -- (if True then 1 else (if 1/0=2 then 2 else 3)) + + -- So for us this is caught by the above check for the 32.3 case. + + -- (32.5) A dependent_expression of a case_expression whose + -- selecting_expression is static and whose value is not covered + -- by the corresponding discrete_choice_list. + + elsif Nkind (P) = N_Case_Expression_Alternative then + + -- First, we have to be in the expression to suppress messages. + -- If we are within one of the choices, we want the message. + + if OldP = Expression (P) then + + -- Statically unevaluated if alternative does not match + + if Check_Case_Expr_Alternative (P) = No_Match then + return True; + end if; + end if; + + -- (32.6) A choice_expression (or a simple_expression of a range + -- that occurs as a membership_choice of a membership_choice_list) + -- of a static membership test that is preceded in the enclosing + -- membership_choice_list by another item whose individual + -- membership test (see (RM 4.5.2)) statically yields True. + + elsif Nkind (P) in N_Membership_Test then + + -- Only possibly unevaluated if simple expression is static + + if not Is_OK_Static_Expression (Left_Opnd (P)) then + null; + + -- All members of the choice list must be static + + elsif (Present (Right_Opnd (P)) + and then not Is_OK_Static_Choice (Right_Opnd (P))) + or else (Present (Alternatives (P)) + and then + not Is_OK_Static_Choice_List (Alternatives (P))) + then + null; + + -- If expression is the one and only alternative, then it is + -- definitely not statically unevaluated, so we only have to + -- test the case where there are alternatives present. + + elsif Present (Alternatives (P)) then + + -- Look for previous matching Choice + + Choice := First (Alternatives (P)); + while Present (Choice) loop + + -- If we reached us and no previous choices matched, this + -- is not the case where we are statically unevaluated. + + exit when OldP = Choice; + + -- If a previous choice matches, then that is the case where + -- we know our choice is statically unevaluated. + + if Choice_Matches (Left_Opnd (P), Choice) = Match then + return True; + end if; + + Next (Choice); + end loop; + + -- If we fall through the loop, we were not one of the choices, + -- we must have been the expression, so that is not covered by + -- this rule, and we keep going. + + null; + end if; + end if; + + -- OK, not statically unevaluated at this level, see if we should + -- keep climbing to look for a higher level reason. + + -- Special case for component association in aggregates, where + -- we want to keep climbing up to the parent aggregate. + + if Nkind (P) = N_Component_Association + and then Nkind (Parent (P)) = N_Aggregate + then + null; + + -- All done if not still within subexpression + + else + exit when Nkind (P) not in N_Subexpr; + end if; + end loop; + + -- If we fall through the loop, not one of the cases covered! + + return False; + end Is_Statically_Unevaluated; + + -------------------- + -- Not_Null_Range -- + -------------------- + + function Not_Null_Range (Lo : Node_Id; Hi : Node_Id) return Boolean is + Typ : constant Entity_Id := Etype (Lo); + + begin + if not Compile_Time_Known_Value (Lo) + or else not Compile_Time_Known_Value (Hi) + then + return False; + end if; + + if Is_Discrete_Type (Typ) then + return Expr_Value (Lo) <= Expr_Value (Hi); + else pragma Assert (Is_Real_Type (Typ)); + return Expr_Value_R (Lo) <= Expr_Value_R (Hi); + end if; + end Not_Null_Range; + + ------------- + -- OK_Bits -- + ------------- + + function OK_Bits (N : Node_Id; Bits : Uint) return Boolean is + begin + -- We allow a maximum of 500,000 bits which seems a reasonable limit + + if Bits < 500_000 then + return True; + + -- Error if this maximum is exceeded + + else + Error_Msg_N ("static value too large, capacity exceeded", N); + return False; + end if; + end OK_Bits; + + ------------------ + -- Out_Of_Range -- + ------------------ + + procedure Out_Of_Range (N : Node_Id) is + begin + -- If we have the static expression case, then this is an illegality + -- in Ada 95 mode, except that in an instance, we never generate an + -- error (if the error is legitimate, it was already diagnosed in the + -- template). + + if Is_Static_Expression (N) + and then not In_Instance + and then not In_Inlined_Body + and then Ada_Version >= Ada_95 + then + -- No message if we are statically unevaluated + + if Is_Statically_Unevaluated (N) then + null; + + -- The expression to compute the length of a packed array is attached + -- to the array type itself, and deserves a separate message. + + elsif Nkind (Parent (N)) = N_Defining_Identifier + and then Is_Array_Type (Parent (N)) + and then Present (Packed_Array_Impl_Type (Parent (N))) + and then Present (First_Rep_Item (Parent (N))) + then + Error_Msg_N + ("length of packed array must not exceed Integer''Last", + First_Rep_Item (Parent (N))); + Rewrite (N, Make_Integer_Literal (Sloc (N), Uint_1)); + + -- All cases except the special array case + + else + Apply_Compile_Time_Constraint_Error + (N, "value not in range of}", CE_Range_Check_Failed); + end if; + + -- Here we generate a warning for the Ada 83 case, or when we are in an + -- instance, or when we have a non-static expression case. + + else + Apply_Compile_Time_Constraint_Error + (N, "value not in range of}??", CE_Range_Check_Failed); + end if; + end Out_Of_Range; + + ---------------------- + -- Predicates_Match -- + ---------------------- + + function Predicates_Match (T1, T2 : Entity_Id) return Boolean is + Pred1 : Node_Id; + Pred2 : Node_Id; + + begin + if Ada_Version < Ada_2012 then + return True; + + -- Both types must have predicates or lack them + + elsif Has_Predicates (T1) /= Has_Predicates (T2) then + return False; + + -- Check matching predicates + + else + Pred1 := + Get_Rep_Item + (T1, Name_Static_Predicate, Check_Parents => False); + Pred2 := + Get_Rep_Item + (T2, Name_Static_Predicate, Check_Parents => False); + + -- Subtypes statically match if the predicate comes from the + -- same declaration, which can only happen if one is a subtype + -- of the other and has no explicit predicate. + + -- Suppress warnings on order of actuals, which is otherwise + -- triggered by one of the two calls below. + + pragma Warnings (Off); + return Pred1 = Pred2 + or else (No (Pred1) and then Is_Subtype_Of (T1, T2)) + or else (No (Pred2) and then Is_Subtype_Of (T2, T1)); + pragma Warnings (On); + end if; + end Predicates_Match; + + --------------------------------------------- + -- Real_Or_String_Static_Predicate_Matches -- + --------------------------------------------- + + function Real_Or_String_Static_Predicate_Matches + (Val : Node_Id; + Typ : Entity_Id) return Boolean + is + Expr : constant Node_Id := Static_Real_Or_String_Predicate (Typ); + -- The predicate expression from the type + + Pfun : constant Entity_Id := Predicate_Function (Typ); + -- The entity for the predicate function + + Ent_Name : constant Name_Id := Chars (First_Formal (Pfun)); + -- The name of the formal of the predicate function. Occurrences of the + -- type name in Expr have been rewritten as references to this formal, + -- and it has a unique name, so we can identify references by this name. + + Copy : Node_Id; + -- Copy of the predicate function tree + + function Process (N : Node_Id) return Traverse_Result; + -- Function used to process nodes during the traversal in which we will + -- find occurrences of the entity name, and replace such occurrences + -- by a real literal with the value to be tested. + + procedure Traverse is new Traverse_Proc (Process); + -- The actual traversal procedure + + ------------- + -- Process -- + ------------- + + function Process (N : Node_Id) return Traverse_Result is + begin + if Nkind (N) = N_Identifier and then Chars (N) = Ent_Name then + declare + Nod : constant Node_Id := New_Copy (Val); + begin + Set_Sloc (Nod, Sloc (N)); + Rewrite (N, Nod); + return Skip; + end; + + -- The predicate function may contain string-comparison operations + -- that have been converted into calls to run-time array-comparison + -- routines. To evaluate the predicate statically, we recover the + -- original comparison operation and replace the occurrence of the + -- formal by the static string value. The actuals of the generated + -- call are of the form X'Address. + + elsif Nkind (N) in N_Op_Compare + and then Nkind (Left_Opnd (N)) = N_Function_Call + then + declare + C : constant Node_Id := Left_Opnd (N); + F : constant Node_Id := First (Parameter_Associations (C)); + L : constant Node_Id := Prefix (F); + R : constant Node_Id := Prefix (Next (F)); + + begin + -- If an operand is an entity name, it is the formal of the + -- predicate function, so replace it with the string value. + -- It may be either operand in the call. The other operand + -- is a static string from the original predicate. + + if Is_Entity_Name (L) then + Rewrite (Left_Opnd (N), New_Copy (Val)); + Rewrite (Right_Opnd (N), New_Copy (R)); + + else + Rewrite (Left_Opnd (N), New_Copy (L)); + Rewrite (Right_Opnd (N), New_Copy (Val)); + end if; + + return Skip; + end; + + else + return OK; + end if; + end Process; + + -- Start of processing for Real_Or_String_Static_Predicate_Matches + + begin + -- First deal with special case of inherited predicate, where the + -- predicate expression looks like: + + -- xxPredicate (typ (Ent)) and then Expr + + -- where Expr is the predicate expression for this level, and the + -- left operand is the call to evaluate the inherited predicate. + + if Nkind (Expr) = N_And_Then + and then Nkind (Left_Opnd (Expr)) = N_Function_Call + and then Is_Predicate_Function (Entity (Name (Left_Opnd (Expr)))) + then + -- OK we have the inherited case, so make a call to evaluate the + -- inherited predicate. If that fails, so do we! + + if not + Real_Or_String_Static_Predicate_Matches + (Val => Val, + Typ => Etype (First_Formal (Entity (Name (Left_Opnd (Expr)))))) + then + return False; + end if; + + -- Use the right operand for the continued processing + + Copy := Copy_Separate_Tree (Right_Opnd (Expr)); + + -- Case where call to predicate function appears on its own (this means + -- that the predicate at this level is just inherited from the parent). + + elsif Nkind (Expr) = N_Function_Call then + declare + Typ : constant Entity_Id := + Etype (First_Formal (Entity (Name (Expr)))); + + begin + -- If the inherited predicate is dynamic, just ignore it. We can't + -- go trying to evaluate a dynamic predicate as a static one! + + if Has_Dynamic_Predicate_Aspect (Typ) then + return True; + + -- Otherwise inherited predicate is static, check for match + + else + return Real_Or_String_Static_Predicate_Matches (Val, Typ); + end if; + end; + + -- If not just an inherited predicate, copy whole expression + + else + Copy := Copy_Separate_Tree (Expr); + end if; + + -- Now we replace occurrences of the entity by the value + + Traverse (Copy); + + -- And analyze the resulting static expression to see if it is True + + Analyze_And_Resolve (Copy, Standard_Boolean); + return Is_True (Expr_Value (Copy)); + end Real_Or_String_Static_Predicate_Matches; + + ------------------------- + -- Rewrite_In_Raise_CE -- + ------------------------- + + procedure Rewrite_In_Raise_CE (N : Node_Id; Exp : Node_Id) is + Typ : constant Entity_Id := Etype (N); + Stat : constant Boolean := Is_Static_Expression (N); + + begin + -- If we want to raise CE in the condition of a N_Raise_CE node, we + -- can just clear the condition if the reason is appropriate. We do + -- not do this operation if the parent has a reason other than range + -- check failed, because otherwise we would change the reason. + + if Present (Parent (N)) + and then Nkind (Parent (N)) = N_Raise_Constraint_Error + and then Reason (Parent (N)) = + UI_From_Int (RT_Exception_Code'Pos (CE_Range_Check_Failed)) + then + Set_Condition (Parent (N), Empty); + + -- Else build an explicit N_Raise_CE + + else + Rewrite (N, + Make_Raise_Constraint_Error (Sloc (Exp), + Reason => CE_Range_Check_Failed)); + Set_Raises_Constraint_Error (N); + Set_Etype (N, Typ); + end if; + + -- Set proper flags in result + + Set_Raises_Constraint_Error (N, True); + Set_Is_Static_Expression (N, Stat); + end Rewrite_In_Raise_CE; + + --------------------- + -- String_Type_Len -- + --------------------- + + function String_Type_Len (Stype : Entity_Id) return Uint is + NT : constant Entity_Id := Etype (First_Index (Stype)); + T : Entity_Id; + + begin + if Is_OK_Static_Subtype (NT) then + T := NT; + else + T := Base_Type (NT); + end if; + + return Expr_Value (Type_High_Bound (T)) - + Expr_Value (Type_Low_Bound (T)) + 1; + end String_Type_Len; + + ------------------------------------ + -- Subtypes_Statically_Compatible -- + ------------------------------------ + + function Subtypes_Statically_Compatible + (T1 : Entity_Id; + T2 : Entity_Id; + Formal_Derived_Matching : Boolean := False) return Boolean + is + begin + -- Scalar types + + if Is_Scalar_Type (T1) then + + -- Definitely compatible if we match + + if Subtypes_Statically_Match (T1, T2) then + return True; + + -- If either subtype is nonstatic then they're not compatible + + elsif not Is_OK_Static_Subtype (T1) + or else + not Is_OK_Static_Subtype (T2) + then + return False; + + -- Base types must match, but we don't check that (should we???) but + -- we do at least check that both types are real, or both types are + -- not real. + + elsif Is_Real_Type (T1) /= Is_Real_Type (T2) then + return False; + + -- Here we check the bounds + + else + declare + LB1 : constant Node_Id := Type_Low_Bound (T1); + HB1 : constant Node_Id := Type_High_Bound (T1); + LB2 : constant Node_Id := Type_Low_Bound (T2); + HB2 : constant Node_Id := Type_High_Bound (T2); + + begin + if Is_Real_Type (T1) then + return + Expr_Value_R (LB1) > Expr_Value_R (HB1) + or else + (Expr_Value_R (LB2) <= Expr_Value_R (LB1) + and then Expr_Value_R (HB1) <= Expr_Value_R (HB2)); + + else + return + Expr_Value (LB1) > Expr_Value (HB1) + or else + (Expr_Value (LB2) <= Expr_Value (LB1) + and then Expr_Value (HB1) <= Expr_Value (HB2)); + end if; + end; + end if; + + -- Access types + + elsif Is_Access_Type (T1) then + return + (not Is_Constrained (T2) + or else Subtypes_Statically_Match + (Designated_Type (T1), Designated_Type (T2))) + and then not (Can_Never_Be_Null (T2) + and then not Can_Never_Be_Null (T1)); + + -- All other cases + + else + return + (Is_Composite_Type (T1) and then not Is_Constrained (T2)) + or else Subtypes_Statically_Match + (T1, T2, Formal_Derived_Matching); + end if; + end Subtypes_Statically_Compatible; + + ------------------------------- + -- Subtypes_Statically_Match -- + ------------------------------- + + -- Subtypes statically match if they have statically matching constraints + -- (RM 4.9.1(2)). Constraints statically match if there are none, or if + -- they are the same identical constraint, or if they are static and the + -- values match (RM 4.9.1(1)). + + -- In addition, in GNAT, the object size (Esize) values of the types must + -- match if they are set (unless checking an actual for a formal derived + -- type). The use of 'Object_Size can cause this to be false even if the + -- types would otherwise match in the RM sense. + + function Subtypes_Statically_Match + (T1 : Entity_Id; + T2 : Entity_Id; + Formal_Derived_Matching : Boolean := False) return Boolean + is + begin + -- A type always statically matches itself + + if T1 = T2 then + return True; + + -- No match if sizes different (from use of 'Object_Size). This test + -- is excluded if Formal_Derived_Matching is True, as the base types + -- can be different in that case and typically have different sizes. + -- ??? Frontend_Layout_On_Target used to set Esizes but this is no + -- longer the case, consider removing the last test below. + + elsif not Formal_Derived_Matching + and then Known_Static_Esize (T1) + and then Known_Static_Esize (T2) + and then Esize (T1) /= Esize (T2) + then + return False; + + -- No match if predicates do not match + + elsif not Predicates_Match (T1, T2) then + return False; + + -- Scalar types + + elsif Is_Scalar_Type (T1) then + + -- Base types must be the same + + if Base_Type (T1) /= Base_Type (T2) then + return False; + end if; + + -- A constrained numeric subtype never matches an unconstrained + -- subtype, i.e. both types must be constrained or unconstrained. + + -- To understand the requirement for this test, see RM 4.9.1(1). + -- As is made clear in RM 3.5.4(11), type Integer, for example is + -- a constrained subtype with constraint bounds matching the bounds + -- of its corresponding unconstrained base type. In this situation, + -- Integer and Integer'Base do not statically match, even though + -- they have the same bounds. + + -- We only apply this test to types in Standard and types that appear + -- in user programs. That way, we do not have to be too careful about + -- setting Is_Constrained right for Itypes. + + if Is_Numeric_Type (T1) + and then (Is_Constrained (T1) /= Is_Constrained (T2)) + and then (Scope (T1) = Standard_Standard + or else Comes_From_Source (T1)) + and then (Scope (T2) = Standard_Standard + or else Comes_From_Source (T2)) + then + return False; + + -- A generic scalar type does not statically match its base type + -- (AI-311). In this case we make sure that the formals, which are + -- first subtypes of their bases, are constrained. + + elsif Is_Generic_Type (T1) + and then Is_Generic_Type (T2) + and then (Is_Constrained (T1) /= Is_Constrained (T2)) + then + return False; + end if; + + -- If there was an error in either range, then just assume the types + -- statically match to avoid further junk errors. + + if No (Scalar_Range (T1)) or else No (Scalar_Range (T2)) + or else Error_Posted (Scalar_Range (T1)) + or else Error_Posted (Scalar_Range (T2)) + then + return True; + end if; + + -- Otherwise both types have bounds that can be compared + + declare + LB1 : constant Node_Id := Type_Low_Bound (T1); + HB1 : constant Node_Id := Type_High_Bound (T1); + LB2 : constant Node_Id := Type_Low_Bound (T2); + HB2 : constant Node_Id := Type_High_Bound (T2); + + begin + -- If the bounds are the same tree node, then match (common case) + + if LB1 = LB2 and then HB1 = HB2 then + return True; + + -- Otherwise bounds must be static and identical value + + else + if not Is_OK_Static_Subtype (T1) + or else + not Is_OK_Static_Subtype (T2) + then + return False; + + elsif Is_Real_Type (T1) then + return + Expr_Value_R (LB1) = Expr_Value_R (LB2) + and then + Expr_Value_R (HB1) = Expr_Value_R (HB2); + + else + return + Expr_Value (LB1) = Expr_Value (LB2) + and then + Expr_Value (HB1) = Expr_Value (HB2); + end if; + end if; + end; + + -- Type with discriminants + + elsif Has_Discriminants (T1) or else Has_Discriminants (T2) then + + -- Because of view exchanges in multiple instantiations, conformance + -- checking might try to match a partial view of a type with no + -- discriminants with a full view that has defaulted discriminants. + -- In such a case, use the discriminant constraint of the full view, + -- which must exist because we know that the two subtypes have the + -- same base type. + + if Has_Discriminants (T1) /= Has_Discriminants (T2) then + -- A generic actual type is declared through a subtype declaration + -- and may have an inconsistent indication of the presence of + -- discriminants, so check the type it renames. + + if Is_Generic_Actual_Type (T1) + and then not Has_Discriminants (Etype (T1)) + and then not Has_Discriminants (T2) + then + return True; + + elsif In_Instance then + if Is_Private_Type (T2) + and then Present (Full_View (T2)) + and then Has_Discriminants (Full_View (T2)) + then + return Subtypes_Statically_Match (T1, Full_View (T2)); + + elsif Is_Private_Type (T1) + and then Present (Full_View (T1)) + and then Has_Discriminants (Full_View (T1)) + then + return Subtypes_Statically_Match (Full_View (T1), T2); + + else + return False; + end if; + else + return False; + end if; + end if; + + declare + DL1 : constant Elist_Id := Discriminant_Constraint (T1); + DL2 : constant Elist_Id := Discriminant_Constraint (T2); + + DA1 : Elmt_Id; + DA2 : Elmt_Id; + + begin + if DL1 = DL2 then + return True; + elsif Is_Constrained (T1) /= Is_Constrained (T2) then + return False; + end if; + + -- Now loop through the discriminant constraints + + -- Note: the guard here seems necessary, since it is possible at + -- least for DL1 to be No_Elist. Not clear this is reasonable ??? + + if Present (DL1) and then Present (DL2) then + DA1 := First_Elmt (DL1); + DA2 := First_Elmt (DL2); + while Present (DA1) loop + declare + Expr1 : constant Node_Id := Node (DA1); + Expr2 : constant Node_Id := Node (DA2); + + begin + if not Is_OK_Static_Expression (Expr1) + or else not Is_OK_Static_Expression (Expr2) + then + return False; + + -- If either expression raised a constraint error, + -- consider the expressions as matching, since this + -- helps to prevent cascading errors. + + elsif Raises_Constraint_Error (Expr1) + or else Raises_Constraint_Error (Expr2) + then + null; + + elsif Expr_Value (Expr1) /= Expr_Value (Expr2) then + return False; + end if; + end; + + Next_Elmt (DA1); + Next_Elmt (DA2); + end loop; + end if; + end; + + return True; + + -- A definite type does not match an indefinite or classwide type. + -- However, a generic type with unknown discriminants may be + -- instantiated with a type with no discriminants, and conformance + -- checking on an inherited operation may compare the actual with the + -- subtype that renames it in the instance. + + elsif Has_Unknown_Discriminants (T1) /= Has_Unknown_Discriminants (T2) + then + return + Is_Generic_Actual_Type (T1) or else Is_Generic_Actual_Type (T2); + + -- Array type + + elsif Is_Array_Type (T1) then + + -- If either subtype is unconstrained then both must be, and if both + -- are unconstrained then no further checking is needed. + + if not Is_Constrained (T1) or else not Is_Constrained (T2) then + return not (Is_Constrained (T1) or else Is_Constrained (T2)); + end if; + + -- Both subtypes are constrained, so check that the index subtypes + -- statically match. + + declare + Index1 : Node_Id := First_Index (T1); + Index2 : Node_Id := First_Index (T2); + + begin + while Present (Index1) loop + if not + Subtypes_Statically_Match (Etype (Index1), Etype (Index2)) + then + return False; + end if; + + Next_Index (Index1); + Next_Index (Index2); + end loop; + + return True; + end; + + elsif Is_Access_Type (T1) then + if Can_Never_Be_Null (T1) /= Can_Never_Be_Null (T2) then + return False; + + elsif Ekind_In (T1, E_Access_Subprogram_Type, + E_Anonymous_Access_Subprogram_Type) + then + return + Subtype_Conformant + (Designated_Type (T1), + Designated_Type (T2)); + else + return + Subtypes_Statically_Match + (Designated_Type (T1), + Designated_Type (T2)) + and then Is_Access_Constant (T1) = Is_Access_Constant (T2); + end if; + + -- All other types definitely match + + else + return True; + end if; + end Subtypes_Statically_Match; + + ---------- + -- Test -- + ---------- + + function Test (Cond : Boolean) return Uint is + begin + if Cond then + return Uint_1; + else + return Uint_0; + end if; + end Test; + + --------------------- + -- Test_Comparison -- + --------------------- + + procedure Test_Comparison + (Op : Node_Id; + Assume_Valid : Boolean; + True_Result : out Boolean; + False_Result : out Boolean) + is + Left : constant Node_Id := Left_Opnd (Op); + Left_Typ : constant Entity_Id := Etype (Left); + Orig_Op : constant Node_Id := Original_Node (Op); + + procedure Replacement_Warning (Msg : String); + -- Emit a warning on a comparison that can be replaced by '=' + + ------------------------- + -- Replacement_Warning -- + ------------------------- + + procedure Replacement_Warning (Msg : String) is + begin + if Constant_Condition_Warnings + and then Comes_From_Source (Orig_Op) + and then Is_Integer_Type (Left_Typ) + and then not Error_Posted (Op) + and then not Has_Warnings_Off (Left_Typ) + and then not In_Instance + then + Error_Msg_N (Msg, Op); + end if; + end Replacement_Warning; + + -- Local variables + + Res : constant Compare_Result := + Compile_Time_Compare (Left, Right_Opnd (Op), Assume_Valid); + + -- Start of processing for Test_Comparison + + begin + case N_Op_Compare (Nkind (Op)) is + when N_Op_Eq => + True_Result := Res = EQ; + False_Result := Res = LT or else Res = GT or else Res = NE; + + when N_Op_Ge => + True_Result := Res in Compare_GE; + False_Result := Res = LT; + + if Res = LE and then Nkind (Orig_Op) = N_Op_Ge then + Replacement_Warning + ("can never be greater than, could replace by ""'=""?c?"); + end if; + + when N_Op_Gt => + True_Result := Res = GT; + False_Result := Res in Compare_LE; + + when N_Op_Le => + True_Result := Res in Compare_LE; + False_Result := Res = GT; + + if Res = GE and then Nkind (Orig_Op) = N_Op_Le then + Replacement_Warning + ("can never be less than, could replace by ""'=""?c?"); + end if; + + when N_Op_Lt => + True_Result := Res = LT; + False_Result := Res in Compare_GE; + + when N_Op_Ne => + True_Result := Res = NE or else Res = GT or else Res = LT; + False_Result := Res = EQ; + end case; + end Test_Comparison; + + --------------------------------- + -- Test_Expression_Is_Foldable -- + --------------------------------- + + -- One operand case + + procedure Test_Expression_Is_Foldable + (N : Node_Id; + Op1 : Node_Id; + Stat : out Boolean; + Fold : out Boolean) + is + begin + Stat := False; + Fold := False; + + if Debug_Flag_Dot_F and then In_Extended_Main_Source_Unit (N) then + return; + end if; + + -- If operand is Any_Type, just propagate to result and do not + -- try to fold, this prevents cascaded errors. + + if Etype (Op1) = Any_Type then + Set_Etype (N, Any_Type); + return; + + -- If operand raises constraint error, then replace node N with the + -- raise constraint error node, and we are obviously not foldable. + -- Note that this replacement inherits the Is_Static_Expression flag + -- from the operand. + + elsif Raises_Constraint_Error (Op1) then + Rewrite_In_Raise_CE (N, Op1); + return; + + -- If the operand is not static, then the result is not static, and + -- all we have to do is to check the operand since it is now known + -- to appear in a non-static context. + + elsif not Is_Static_Expression (Op1) then + Check_Non_Static_Context (Op1); + Fold := Compile_Time_Known_Value (Op1); + return; + + -- An expression of a formal modular type is not foldable because + -- the modulus is unknown. + + elsif Is_Modular_Integer_Type (Etype (Op1)) + and then Is_Generic_Type (Etype (Op1)) + then + Check_Non_Static_Context (Op1); + return; + + -- Here we have the case of an operand whose type is OK, which is + -- static, and which does not raise constraint error, we can fold. + + else + Set_Is_Static_Expression (N); + Fold := True; + Stat := True; + end if; + end Test_Expression_Is_Foldable; + + -- Two operand case + + procedure Test_Expression_Is_Foldable + (N : Node_Id; + Op1 : Node_Id; + Op2 : Node_Id; + Stat : out Boolean; + Fold : out Boolean; + CRT_Safe : Boolean := False) + is + Rstat : constant Boolean := Is_Static_Expression (Op1) + and then + Is_Static_Expression (Op2); + + begin + Stat := False; + Fold := False; + + -- Inhibit folding if -gnatd.f flag set + + if Debug_Flag_Dot_F and then In_Extended_Main_Source_Unit (N) then + return; + end if; + + -- If either operand is Any_Type, just propagate to result and + -- do not try to fold, this prevents cascaded errors. + + if Etype (Op1) = Any_Type or else Etype (Op2) = 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 (Op1) then + if not Rstat then + Check_Non_Static_Context (Op2); + end if; + + Rewrite_In_Raise_CE (N, Op1); + Set_Is_Static_Expression (N, Rstat); + return; + + -- Similar processing for the case of the right operand. Note that we + -- don't use this routine for the short-circuit case, so we do not have + -- to worry about that special case here. + + elsif Raises_Constraint_Error (Op2) then + if not Rstat then + Check_Non_Static_Context (Op1); + end if; + + Rewrite_In_Raise_CE (N, Op2); + Set_Is_Static_Expression (N, Rstat); + return; + + -- Exclude expressions of a generic modular type, as above + + elsif Is_Modular_Integer_Type (Etype (Op1)) + and then Is_Generic_Type (Etype (Op1)) + then + Check_Non_Static_Context (Op1); + return; + + -- If result is not static, then check non-static contexts on operands + -- since one of them may be static and the other one may not be static. + + elsif not Rstat then + Check_Non_Static_Context (Op1); + Check_Non_Static_Context (Op2); + + if CRT_Safe then + Fold := CRT_Safe_Compile_Time_Known_Value (Op1) + and then CRT_Safe_Compile_Time_Known_Value (Op2); + else + Fold := Compile_Time_Known_Value (Op1) + and then Compile_Time_Known_Value (Op2); + end if; + + return; + + -- Else result is static and foldable. Both operands are static, and + -- neither raises constraint error, so we can definitely fold. + + else + Set_Is_Static_Expression (N); + Fold := True; + Stat := True; + return; + end if; + end Test_Expression_Is_Foldable; + + ------------------- + -- Test_In_Range -- + ------------------- + + function Test_In_Range + (N : Node_Id; + Typ : Entity_Id; + Assume_Valid : Boolean; + Fixed_Int : Boolean; + Int_Real : Boolean) return Range_Membership + is + Val : Uint; + Valr : Ureal; + + pragma Warnings (Off, Assume_Valid); + -- For now Assume_Valid is unreferenced since the current implementation + -- always returns Unknown if N is not a compile time known value, but we + -- keep the parameter to allow for future enhancements in which we try + -- to get the information in the variable case as well. + + begin + -- If an error was posted on expression, then return Unknown, we do not + -- want cascaded errors based on some false analysis of a junk node. + + if Error_Posted (N) then + return Unknown; + + -- Expression that raises constraint error is an odd case. We certainly + -- do not want to consider it to be in range. It might make sense to + -- consider it always out of range, but this causes incorrect error + -- messages about static expressions out of range. So we just return + -- Unknown, which is always safe. + + elsif Raises_Constraint_Error (N) then + return Unknown; + + -- Universal types have no range limits, so always in range + + elsif Typ = Universal_Integer or else Typ = Universal_Real then + return In_Range; + + -- Never known if not scalar type. Don't know if this can actually + -- happen, but our spec allows it, so we must check. + + elsif not Is_Scalar_Type (Typ) then + return Unknown; + + -- Never known if this is a generic type, since the bounds of generic + -- types are junk. Note that if we only checked for static expressions + -- (instead of compile time known values) below, we would not need this + -- check, because values of a generic type can never be static, but they + -- can be known at compile time. + + elsif Is_Generic_Type (Typ) then + return Unknown; + + -- Case of a known compile time value, where we can check if it is in + -- the bounds of the given type. + + elsif Compile_Time_Known_Value (N) then + declare + Lo : Node_Id; + Hi : Node_Id; + + LB_Known : Boolean; + HB_Known : Boolean; + + begin + Lo := Type_Low_Bound (Typ); + Hi := Type_High_Bound (Typ); + + LB_Known := Compile_Time_Known_Value (Lo); + HB_Known := Compile_Time_Known_Value (Hi); + + -- Fixed point types should be considered as such only if flag + -- Fixed_Int is set to False. + + if Is_Floating_Point_Type (Typ) + or else (Is_Fixed_Point_Type (Typ) and then not Fixed_Int) + or else Int_Real + then + Valr := Expr_Value_R (N); + + if LB_Known and HB_Known then + if Valr >= Expr_Value_R (Lo) + and then + Valr <= Expr_Value_R (Hi) + then + return In_Range; + else + return Out_Of_Range; + end if; + + elsif (LB_Known and then Valr < Expr_Value_R (Lo)) + or else + (HB_Known and then Valr > Expr_Value_R (Hi)) + then + return Out_Of_Range; + + else + return Unknown; + end if; + + else + Val := Expr_Value (N); + + if LB_Known and HB_Known then + if Val >= Expr_Value (Lo) and then Val <= Expr_Value (Hi) + then + return In_Range; + else + return Out_Of_Range; + end if; + + elsif (LB_Known and then Val < Expr_Value (Lo)) + or else + (HB_Known and then Val > Expr_Value (Hi)) + then + return Out_Of_Range; + + else + return Unknown; + end if; + end if; + end; + + -- Here for value not known at compile time. Case of expression subtype + -- is Typ or is a subtype of Typ, and we can assume expression is valid. + -- In this case we know it is in range without knowing its value. + + elsif Assume_Valid + and then (Etype (N) = Typ or else Is_Subtype_Of (Etype (N), Typ)) + then + return In_Range; + + -- Another special case. For signed integer types, if the target type + -- has Is_Known_Valid set, and the source type does not have a larger + -- size, then the source value must be in range. We exclude biased + -- types, because they bizarrely can generate out of range values. + + elsif Is_Signed_Integer_Type (Etype (N)) + and then Is_Known_Valid (Typ) + and then Esize (Etype (N)) <= Esize (Typ) + and then not Has_Biased_Representation (Etype (N)) + then + return In_Range; + + -- For all other cases, result is unknown + + else + return Unknown; + end if; + end Test_In_Range; + + -------------- + -- To_Bits -- + -------------- + + procedure To_Bits (U : Uint; B : out Bits) is + begin + for J in 0 .. B'Last loop + B (J) := (U / (2 ** J)) mod 2 /= 0; + end loop; + end To_Bits; + + -------------------- + -- Why_Not_Static -- + -------------------- + + procedure Why_Not_Static (Expr : Node_Id) is + N : constant Node_Id := Original_Node (Expr); + Typ : Entity_Id := Empty; + E : Entity_Id; + Alt : Node_Id; + Exp : Node_Id; + + procedure Why_Not_Static_List (L : List_Id); + -- A version that can be called on a list of expressions. Finds all + -- non-static violations in any element of the list. + + ------------------------- + -- Why_Not_Static_List -- + ------------------------- + + procedure Why_Not_Static_List (L : List_Id) is + N : Node_Id; + begin + if Is_Non_Empty_List (L) then + N := First (L); + while Present (N) loop + Why_Not_Static (N); + Next (N); + end loop; + end if; + end Why_Not_Static_List; + + -- Start of processing for Why_Not_Static + + begin + -- Ignore call on error or empty node + + if No (Expr) or else Nkind (Expr) = N_Error then + return; + end if; + + -- Preprocessing for sub expressions + + if Nkind (Expr) in N_Subexpr then + + -- Nothing to do if expression is static + + if Is_OK_Static_Expression (Expr) then + return; + end if; + + -- Test for constraint error raised + + if Raises_Constraint_Error (Expr) then + + -- Special case membership to find out which piece to flag + + if Nkind (N) in N_Membership_Test then + if Raises_Constraint_Error (Left_Opnd (N)) then + Why_Not_Static (Left_Opnd (N)); + return; + + elsif Present (Right_Opnd (N)) + and then Raises_Constraint_Error (Right_Opnd (N)) + then + Why_Not_Static (Right_Opnd (N)); + return; + + else + pragma Assert (Present (Alternatives (N))); + + Alt := First (Alternatives (N)); + while Present (Alt) loop + if Raises_Constraint_Error (Alt) then + Why_Not_Static (Alt); + return; + else + Next (Alt); + end if; + end loop; + end if; + + -- Special case a range to find out which bound to flag + + elsif Nkind (N) = N_Range then + if Raises_Constraint_Error (Low_Bound (N)) then + Why_Not_Static (Low_Bound (N)); + return; + + elsif Raises_Constraint_Error (High_Bound (N)) then + Why_Not_Static (High_Bound (N)); + return; + end if; + + -- Special case attribute to see which part to flag + + elsif Nkind (N) = N_Attribute_Reference then + if Raises_Constraint_Error (Prefix (N)) then + Why_Not_Static (Prefix (N)); + return; + end if; + + if Present (Expressions (N)) then + Exp := First (Expressions (N)); + while Present (Exp) loop + if Raises_Constraint_Error (Exp) then + Why_Not_Static (Exp); + return; + end if; + + Next (Exp); + end loop; + end if; + + -- Special case a subtype name + + elsif Is_Entity_Name (Expr) and then Is_Type (Entity (Expr)) then + Error_Msg_NE + ("!& is not a static subtype (RM 4.9(26))", N, Entity (Expr)); + return; + end if; + + -- End of special cases + + Error_Msg_N + ("!expression raises exception, cannot be static (RM 4.9(34))", + N); + return; + end if; + + -- If no type, then something is pretty wrong, so ignore + + Typ := Etype (Expr); + + if No (Typ) then + return; + end if; + + -- Type must be scalar or string type (but allow Bignum, since this + -- is really a scalar type from our point of view in this diagnosis). + + if not Is_Scalar_Type (Typ) + and then not Is_String_Type (Typ) + and then not Is_RTE (Typ, RE_Bignum) + then + Error_Msg_N + ("!static expression must have scalar or string type " & + "(RM 4.9(2))", N); + return; + end if; + end if; + + -- If we got through those checks, test particular node kind + + case Nkind (N) is + + -- Entity name + + when N_Expanded_Name + | N_Identifier + | N_Operator_Symbol + => + E := Entity (N); + + if Is_Named_Number (E) then + null; + + elsif Ekind (E) = E_Constant then + + -- One case we can give a metter message is when we have a + -- string literal created by concatenating an aggregate with + -- an others expression. + + Entity_Case : declare + CV : constant Node_Id := Constant_Value (E); + CO : constant Node_Id := Original_Node (CV); + + function Is_Aggregate (N : Node_Id) return Boolean; + -- See if node N came from an others aggregate, if so + -- return True and set Error_Msg_Sloc to aggregate. + + ------------------ + -- Is_Aggregate -- + ------------------ + + function Is_Aggregate (N : Node_Id) return Boolean is + begin + if Nkind (Original_Node (N)) = N_Aggregate then + Error_Msg_Sloc := Sloc (Original_Node (N)); + return True; + + elsif Is_Entity_Name (N) + and then Ekind (Entity (N)) = E_Constant + and then + Nkind (Original_Node (Constant_Value (Entity (N)))) = + N_Aggregate + then + Error_Msg_Sloc := + Sloc (Original_Node (Constant_Value (Entity (N)))); + return True; + + else + return False; + end if; + end Is_Aggregate; + + -- Start of processing for Entity_Case + + begin + if Is_Aggregate (CV) + or else (Nkind (CO) = N_Op_Concat + and then (Is_Aggregate (Left_Opnd (CO)) + or else + Is_Aggregate (Right_Opnd (CO)))) + then + Error_Msg_N ("!aggregate (#) is never static", N); + + elsif No (CV) or else not Is_Static_Expression (CV) then + Error_Msg_NE + ("!& is not a static constant (RM 4.9(5))", N, E); + end if; + end Entity_Case; + + elsif Is_Type (E) then + Error_Msg_NE + ("!& is not a static subtype (RM 4.9(26))", N, E); + + else + Error_Msg_NE + ("!& is not static constant or named number " + & "(RM 4.9(5))", N, E); + end if; + + -- Binary operator + + when N_Binary_Op + | N_Membership_Test + | N_Short_Circuit + => + if Nkind (N) in N_Op_Shift then + Error_Msg_N + ("!shift functions are never static (RM 4.9(6,18))", N); + else + Why_Not_Static (Left_Opnd (N)); + Why_Not_Static (Right_Opnd (N)); + end if; + + -- Unary operator + + when N_Unary_Op => + Why_Not_Static (Right_Opnd (N)); + + -- Attribute reference + + when N_Attribute_Reference => + Why_Not_Static_List (Expressions (N)); + + E := Etype (Prefix (N)); + + if E = Standard_Void_Type then + return; + end if; + + -- Special case non-scalar'Size since this is a common error + + if Attribute_Name (N) = Name_Size then + Error_Msg_N + ("!size attribute is only static for static scalar type " + & "(RM 4.9(7,8))", N); + + -- Flag array cases + + elsif Is_Array_Type (E) then + if not Nam_In (Attribute_Name (N), Name_First, + Name_Last, + Name_Length) + then + Error_Msg_N + ("!static array attribute must be Length, First, or Last " + & "(RM 4.9(8))", N); + + -- Since we know the expression is not-static (we already + -- tested for this, must mean array is not static). + + else + Error_Msg_N + ("!prefix is non-static array (RM 4.9(8))", Prefix (N)); + end if; + + return; + + -- Special case generic types, since again this is a common source + -- of confusion. + + elsif Is_Generic_Actual_Type (E) or else Is_Generic_Type (E) then + Error_Msg_N + ("!attribute of generic type is never static " + & "(RM 4.9(7,8))", N); + + elsif Is_OK_Static_Subtype (E) then + null; + + elsif Is_Scalar_Type (E) then + Error_Msg_N + ("!prefix type for attribute is not static scalar subtype " + & "(RM 4.9(7))", N); + + else + Error_Msg_N + ("!static attribute must apply to array/scalar type " + & "(RM 4.9(7,8))", N); + end if; + + -- String literal + + when N_String_Literal => + Error_Msg_N + ("!subtype of string literal is non-static (RM 4.9(4))", N); + + -- Explicit dereference + + when N_Explicit_Dereference => + Error_Msg_N + ("!explicit dereference is never static (RM 4.9)", N); + + -- Function call + + when N_Function_Call => + Why_Not_Static_List (Parameter_Associations (N)); + + -- Complain about non-static function call unless we have Bignum + -- which means that the underlying expression is really some + -- scalar arithmetic operation. + + if not Is_RTE (Typ, RE_Bignum) then + Error_Msg_N ("!non-static function call (RM 4.9(6,18))", N); + end if; + + -- Parameter assocation (test actual parameter) + + when N_Parameter_Association => + Why_Not_Static (Explicit_Actual_Parameter (N)); + + -- Indexed component + + when N_Indexed_Component => + Error_Msg_N ("!indexed component is never static (RM 4.9)", N); + + -- Procedure call + + when N_Procedure_Call_Statement => + Error_Msg_N ("!procedure call is never static (RM 4.9)", N); + + -- Qualified expression (test expression) + + when N_Qualified_Expression => + Why_Not_Static (Expression (N)); + + -- Aggregate + + when N_Aggregate + | N_Extension_Aggregate + => + Error_Msg_N ("!an aggregate is never static (RM 4.9)", N); + + -- Range + + when N_Range => + Why_Not_Static (Low_Bound (N)); + Why_Not_Static (High_Bound (N)); + + -- Range constraint, test range expression + + when N_Range_Constraint => + Why_Not_Static (Range_Expression (N)); + + -- Subtype indication, test constraint + + when N_Subtype_Indication => + Why_Not_Static (Constraint (N)); + + -- Selected component + + when N_Selected_Component => + Error_Msg_N ("!selected component is never static (RM 4.9)", N); + + -- Slice + + when N_Slice => + Error_Msg_N ("!slice is never static (RM 4.9)", N); + + when N_Type_Conversion => + Why_Not_Static (Expression (N)); + + if not Is_Scalar_Type (Entity (Subtype_Mark (N))) + or else not Is_OK_Static_Subtype (Entity (Subtype_Mark (N))) + then + Error_Msg_N + ("!static conversion requires static scalar subtype result " + & "(RM 4.9(9))", N); + end if; + + -- Unchecked type conversion + + when N_Unchecked_Type_Conversion => + Error_Msg_N + ("!unchecked type conversion is never static (RM 4.9)", N); + + -- All other cases, no reason to give + + when others => + null; + end case; + end Why_Not_Static; + +end Sem_Eval;