1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 with Aspects; use Aspects;
27 with Atree; use Atree;
28 with Checks; use Checks;
29 with Debug; use Debug;
30 with Einfo; use Einfo;
31 with Elists; use Elists;
32 with Errout; use Errout;
33 with Eval_Fat; use Eval_Fat;
34 with Exp_Util; use Exp_Util;
35 with Freeze; use Freeze;
37 with Namet; use Namet;
38 with Nmake; use Nmake;
39 with Nlists; use Nlists;
41 with Par_SCO; use Par_SCO;
42 with Rtsfind; use Rtsfind;
44 with Sem_Aux; use Sem_Aux;
45 with Sem_Cat; use Sem_Cat;
46 with Sem_Ch6; use Sem_Ch6;
47 with Sem_Ch8; use Sem_Ch8;
48 with Sem_Res; use Sem_Res;
49 with Sem_Util; use Sem_Util;
50 with Sem_Type; use Sem_Type;
51 with Sem_Warn; use Sem_Warn;
52 with Sinfo; use Sinfo;
53 with Snames; use Snames;
54 with Stand; use Stand;
55 with Stringt; use Stringt;
56 with Tbuild; use Tbuild;
58 package body Sem_Eval is
60 -----------------------------------------
61 -- Handling of Compile Time Evaluation --
62 -----------------------------------------
64 -- The compile time evaluation of expressions is distributed over several
65 -- Eval_xxx procedures. These procedures are called immediately after
66 -- a subexpression is resolved and is therefore accomplished in a bottom
67 -- up fashion. The flags are synthesized using the following approach.
69 -- Is_Static_Expression is determined by following the rules in
70 -- RM-4.9. This involves testing the Is_Static_Expression flag of
71 -- the operands in many cases.
73 -- Raises_Constraint_Error is usually set if any of the operands have
74 -- the flag set or if an attempt to compute the value of the current
75 -- expression results in Constraint_Error.
77 -- The general approach is as follows. First compute Is_Static_Expression.
78 -- If the node is not static, then the flag is left off in the node and
79 -- we are all done. Otherwise for a static node, we test if any of the
80 -- operands will raise Constraint_Error, and if so, propagate the flag
81 -- Raises_Constraint_Error to the result node and we are done (since the
82 -- error was already posted at a lower level).
84 -- For the case of a static node whose operands do not raise constraint
85 -- error, we attempt to evaluate the node. If this evaluation succeeds,
86 -- then the node is replaced by the result of this computation. If the
87 -- evaluation raises Constraint_Error, then we rewrite the node with
88 -- Apply_Compile_Time_Constraint_Error to raise the exception and also
89 -- to post appropriate error messages.
95 type Bits is array (Nat range <>) of Boolean;
96 -- Used to convert unsigned (modular) values for folding logical ops
98 -- The following declarations are used to maintain a cache of nodes that
99 -- have compile-time-known values. The cache is maintained only for
100 -- discrete types (the most common case), and is populated by calls to
101 -- Compile_Time_Known_Value and Expr_Value, but only used by Expr_Value
102 -- since it is possible for the status to change (in particular it is
103 -- possible for a node to get replaced by a Constraint_Error node).
105 CV_Bits : constant := 5;
106 -- Number of low order bits of Node_Id value used to reference entries
107 -- in the cache table.
109 CV_Cache_Size : constant Nat := 2 ** CV_Bits;
110 -- Size of cache for compile time values
112 subtype CV_Range is Nat range 0 .. CV_Cache_Size;
114 type CV_Entry is record
119 type Match_Result is (Match, No_Match, Non_Static);
120 -- Result returned from functions that test for a matching result. If the
121 -- operands are not OK_Static then Non_Static will be returned. Otherwise
122 -- Match/No_Match is returned depending on whether the match succeeds.
124 type CV_Cache_Array is array (CV_Range) of CV_Entry;
126 CV_Cache : CV_Cache_Array := (others => (Node_High_Bound, Uint_0));
127 -- This is the actual cache, with entries consisting of node/value pairs,
128 -- and the impossible value Node_High_Bound used for unset entries.
130 type Range_Membership is (In_Range, Out_Of_Range, Unknown);
131 -- Range membership may either be statically known to be in range or out
132 -- of range, or not statically known. Used for Test_In_Range below.
134 -----------------------
135 -- Local Subprograms --
136 -----------------------
138 function Choice_Matches
140 Choice : Node_Id) return Match_Result;
141 -- Determines whether given value Expr matches the given Choice. The Expr
142 -- can be of discrete, real, or string type and must be a compile time
143 -- known value (it is an error to make the call if these conditions are
144 -- not met). The choice can be a range, subtype name, subtype indication,
145 -- or expression. The returned result is Non_Static if Choice is not
146 -- OK_Static, otherwise either Match or No_Match is returned depending
147 -- on whether Choice matches Expr. This is used for case expression
148 -- alternatives, and also for membership tests. In each case, more
149 -- possibilities are tested than the syntax allows (e.g. membership allows
150 -- subtype indications and non-discrete types, and case allows an OTHERS
151 -- choice), but it does not matter, since we have already done a full
152 -- semantic and syntax check of the construct, so the extra possibilities
153 -- just will not arise for correct expressions.
155 -- Note: if Choice_Matches finds that a choice raises Constraint_Error, e.g
156 -- a reference to a type, one of whose bounds raises Constraint_Error, then
157 -- it also sets the Raises_Constraint_Error flag on the Choice itself.
159 function Choices_Match
161 Choices : List_Id) return Match_Result;
162 -- This function applies Choice_Matches to each element of Choices. If the
163 -- result is No_Match, then it continues and checks the next element. If
164 -- the result is Match or Non_Static, this result is immediately given
165 -- as the result without checking the rest of the list. Expr can be of
166 -- discrete, real, or string type and must be a compile-time-known value
167 -- (it is an error to make the call if these conditions are not met).
169 function Find_Universal_Operator_Type (N : Node_Id) return Entity_Id;
170 -- Check whether an arithmetic operation with universal operands which is a
171 -- rewritten function call with an explicit scope indication is ambiguous:
172 -- P."+" (1, 2) will be ambiguous if there is more than one visible numeric
173 -- type declared in P and the context does not impose a type on the result
174 -- (e.g. in the expression of a type conversion). If ambiguous, emit an
175 -- error and return Empty, else return the result type of the operator.
177 function From_Bits (B : Bits; T : Entity_Id) return Uint;
178 -- Converts a bit string of length B'Length to a Uint value to be used for
179 -- a target of type T, which is a modular type. This procedure includes the
180 -- necessary reduction by the modulus in the case of a nonbinary modulus
181 -- (for a binary modulus, the bit string is the right length any way so all
184 function Get_String_Val (N : Node_Id) return Node_Id;
185 -- Given a tree node for a folded string or character value, returns the
186 -- corresponding string literal or character literal (one of the two must
187 -- be available, or the operand would not have been marked as foldable in
188 -- the earlier analysis of the operation).
190 function Is_OK_Static_Choice (Choice : Node_Id) return Boolean;
191 -- Given a choice (from a case expression or membership test), returns
192 -- True if the choice is static and does not raise a Constraint_Error.
194 function Is_OK_Static_Choice_List (Choices : List_Id) return Boolean;
195 -- Given a choice list (from a case expression or membership test), return
196 -- True if all choices are static in the sense of Is_OK_Static_Choice.
198 function Is_Static_Choice (Choice : Node_Id) return Boolean;
199 -- Given a choice (from a case expression or membership test), returns
200 -- True if the choice is static. No test is made for raising of constraint
201 -- error, so this function is used only for legality tests.
203 function Is_Static_Choice_List (Choices : List_Id) return Boolean;
204 -- Given a choice list (from a case expression or membership test), return
205 -- True if all choices are static in the sense of Is_Static_Choice.
207 function Is_Static_Range (N : Node_Id) return Boolean;
208 -- Determine if range is static, as defined in RM 4.9(26). The only allowed
209 -- argument is an N_Range node (but note that the semantic analysis of
210 -- equivalent range attribute references already turned them into the
211 -- equivalent range). This differs from Is_OK_Static_Range (which is what
212 -- must be used by clients) in that it does not care whether the bounds
213 -- raise Constraint_Error or not. Used for checking whether expressions are
214 -- static in the 4.9 sense (without worrying about exceptions).
216 function OK_Bits (N : Node_Id; Bits : Uint) return Boolean;
217 -- Bits represents the number of bits in an integer value to be computed
218 -- (but the value has not been computed yet). If this value in Bits is
219 -- reasonable, a result of True is returned, with the implication that the
220 -- caller should go ahead and complete the calculation. If the value in
221 -- Bits is unreasonably large, then an error is posted on node N, and
222 -- False is returned (and the caller skips the proposed calculation).
224 procedure Out_Of_Range (N : Node_Id);
225 -- This procedure is called if it is determined that node N, which appears
226 -- in a non-static context, is a compile-time-known value which is outside
227 -- its range, i.e. the range of Etype. This is used in contexts where
228 -- this is an illegality if N is static, and should generate a warning
231 function Real_Or_String_Static_Predicate_Matches
233 Typ : Entity_Id) return Boolean;
234 -- This is the function used to evaluate real or string static predicates.
235 -- Val is an unanalyzed N_Real_Literal or N_String_Literal node, which
236 -- represents the value to be tested against the predicate. Typ is the
237 -- type with the predicate, from which the predicate expression can be
238 -- extracted. The result returned is True if the given value satisfies
241 procedure Rewrite_In_Raise_CE (N : Node_Id; Exp : Node_Id);
242 -- N and Exp are nodes representing an expression, Exp is known to raise
243 -- CE. N is rewritten in term of Exp in the optimal way.
245 function String_Type_Len (Stype : Entity_Id) return Uint;
246 -- Given a string type, determines the length of the index type, or, if
247 -- this index type is non-static, the length of the base type of this index
248 -- type. Note that if the string type is itself static, then the index type
249 -- is static, so the second case applies only if the string type passed is
252 function Test (Cond : Boolean) return Uint;
253 pragma Inline (Test);
254 -- This function simply returns the appropriate Boolean'Pos value
255 -- corresponding to the value of Cond as a universal integer. It is
256 -- used for producing the result of the static evaluation of the
259 procedure Test_Expression_Is_Foldable
264 -- Tests to see if expression N whose single operand is Op1 is foldable,
265 -- i.e. the operand value is known at compile time. If the operation is
266 -- foldable, then Fold is True on return, and Stat indicates whether the
267 -- result is static (i.e. the operand was static). Note that it is quite
268 -- possible for Fold to be True, and Stat to be False, since there are
269 -- cases in which we know the value of an operand even though it is not
270 -- technically static (e.g. the static lower bound of a range whose upper
271 -- bound is non-static).
273 -- If Stat is set False on return, then Test_Expression_Is_Foldable makes
274 -- a call to Check_Non_Static_Context on the operand. If Fold is False on
275 -- return, then all processing is complete, and the caller should return,
276 -- since there is nothing else to do.
278 -- If Stat is set True on return, then Is_Static_Expression is also set
279 -- true in node N. There are some cases where this is over-enthusiastic,
280 -- e.g. in the two operand case below, for string comparison, the result is
281 -- not static even though the two operands are static. In such cases, the
282 -- caller must reset the Is_Static_Expression flag in N.
284 -- If Fold and Stat are both set to False then this routine performs also
285 -- the following extra actions:
287 -- If either operand is Any_Type then propagate it to result to prevent
290 -- If some operand raises Constraint_Error, then replace the node N
291 -- with the raise Constraint_Error node. This replacement inherits the
292 -- Is_Static_Expression flag from the operands.
294 procedure Test_Expression_Is_Foldable
300 CRT_Safe : Boolean := False);
301 -- Same processing, except applies to an expression N with two operands
302 -- Op1 and Op2. The result is static only if both operands are static. If
303 -- CRT_Safe is set True, then CRT_Safe_Compile_Time_Known_Value is used
304 -- for the tests that the two operands are known at compile time. See
305 -- spec of this routine for further details.
307 function Test_In_Range
310 Assume_Valid : Boolean;
312 Int_Real : Boolean) return Range_Membership;
313 -- Common processing for Is_In_Range and Is_Out_Of_Range: Returns In_Range
314 -- or Out_Of_Range if it can be guaranteed at compile time that expression
315 -- N is known to be in or out of range of the subtype Typ. If not compile
316 -- time known, Unknown is returned. See documentation of Is_In_Range for
317 -- complete description of parameters.
319 procedure To_Bits (U : Uint; B : out Bits);
320 -- Converts a Uint value to a bit string of length B'Length
322 -----------------------------------------------
323 -- Check_Expression_Against_Static_Predicate --
324 -----------------------------------------------
326 procedure Check_Expression_Against_Static_Predicate
329 Static_Failure_Is_Error : Boolean := False)
332 -- Nothing to do if expression is not known at compile time, or the
333 -- type has no static predicate set (will be the case for all non-scalar
334 -- types, so no need to make a special test for that).
336 if not (Has_Static_Predicate (Typ)
337 and then Compile_Time_Known_Value (Expr))
342 -- Here we have a static predicate (note that it could have arisen from
343 -- an explicitly specified Dynamic_Predicate whose expression met the
344 -- rules for being predicate-static). If the expression is known at
345 -- compile time and obeys the predicate, then it is static and must be
346 -- labeled as such, which matters e.g. for case statements. The original
347 -- expression may be a type conversion of a variable with a known value,
348 -- which might otherwise not be marked static.
350 -- Case of real static predicate
352 if Is_Real_Type (Typ) then
353 if Real_Or_String_Static_Predicate_Matches
354 (Val => Make_Real_Literal (Sloc (Expr), Expr_Value_R (Expr)),
357 Set_Is_Static_Expression (Expr);
361 -- Case of string static predicate
363 elsif Is_String_Type (Typ) then
364 if Real_Or_String_Static_Predicate_Matches
365 (Val => Expr_Value_S (Expr), Typ => Typ)
367 Set_Is_Static_Expression (Expr);
371 -- Case of discrete static predicate
374 pragma Assert (Is_Discrete_Type (Typ));
376 -- If static predicate matches, nothing to do
378 if Choices_Match (Expr, Static_Discrete_Predicate (Typ)) = Match then
379 Set_Is_Static_Expression (Expr);
384 -- Here we know that the predicate will fail
386 -- Special case of static expression failing a predicate (other than one
387 -- that was explicitly specified with a Dynamic_Predicate aspect). If
388 -- the expression comes from a qualified_expression or type_conversion
389 -- this is an error (Static_Failure_Is_Error); otherwise we only issue
390 -- a warning and the expression is no longer considered static.
392 if Is_Static_Expression (Expr)
393 and then not Has_Dynamic_Predicate_Aspect (Typ)
395 if Static_Failure_Is_Error then
397 ("static expression fails static predicate check on &",
402 ("??static expression fails static predicate check on &",
405 ("\??expression is no longer considered static", Expr);
407 Set_Is_Static_Expression (Expr, False);
410 -- In all other cases, this is just a warning that a test will fail.
411 -- It does not matter if the expression is static or not, or if the
412 -- predicate comes from a dynamic predicate aspect or not.
416 ("??expression fails predicate check on &", Expr, Typ);
418 -- Force a check here, which is potentially a redundant check, but
419 -- this ensures a check will be done in cases where the expression
420 -- is folded, and since this is definitely a failure, extra checks
425 (Typ, Duplicate_Subexpr (Expr)), Suppress => All_Checks);
427 end Check_Expression_Against_Static_Predicate;
429 ------------------------------
430 -- Check_Non_Static_Context --
431 ------------------------------
433 procedure Check_Non_Static_Context (N : Node_Id) is
434 T : constant Entity_Id := Etype (N);
435 Checks_On : constant Boolean :=
436 not Index_Checks_Suppressed (T)
437 and not Range_Checks_Suppressed (T);
440 -- Ignore cases of non-scalar types, error types, or universal real
441 -- types that have no usable bounds.
444 or else not Is_Scalar_Type (T)
445 or else T = Universal_Fixed
446 or else T = Universal_Real
451 -- At this stage we have a scalar type. If we have an expression that
452 -- raises CE, then we already issued a warning or error msg so there is
453 -- nothing more to be done in this routine.
455 if Raises_Constraint_Error (N) then
459 -- Now we have a scalar type which is not marked as raising a constraint
460 -- error exception. The main purpose of this routine is to deal with
461 -- static expressions appearing in a non-static context. That means
462 -- that if we do not have a static expression then there is not much
463 -- to do. The one case that we deal with here is that if we have a
464 -- floating-point value that is out of range, then we post a warning
465 -- that an infinity will result.
467 if not Is_Static_Expression (N) then
468 if Is_Floating_Point_Type (T) then
469 if Is_Out_Of_Range (N, Base_Type (T), Assume_Valid => True) then
471 ("??float value out of range, infinity will be generated", N);
473 -- The literal may be the result of constant-folding of a non-
474 -- static subexpression of a larger expression (e.g. a conversion
475 -- of a non-static variable whose value happens to be known). At
476 -- this point we must reduce the value of the subexpression to a
477 -- machine number (RM 4.9 (38/2)).
479 elsif Nkind (N) = N_Real_Literal
480 and then Nkind (Parent (N)) in N_Subexpr
482 Rewrite (N, New_Copy (N));
484 (N, Machine (Base_Type (T), Realval (N), Round_Even, N));
491 -- Here we have the case of outer level static expression of scalar
492 -- type, where the processing of this procedure is needed.
494 -- For real types, this is where we convert the value to a machine
495 -- number (see RM 4.9(38)). Also see ACVC test C490001. We should only
496 -- need to do this if the parent is a constant declaration, since in
497 -- other cases, gigi should do the necessary conversion correctly, but
498 -- experimentation shows that this is not the case on all machines, in
499 -- particular if we do not convert all literals to machine values in
500 -- non-static contexts, then ACVC test C490001 fails on Sparc/Solaris
503 -- This conversion is always done by GNATprove on real literals in
504 -- non-static expressions, by calling Check_Non_Static_Context from
505 -- gnat2why, as GNATprove cannot do the conversion later contrary
506 -- to gigi. The frontend computes the information about which
507 -- expressions are static, which is used by gnat2why to call
508 -- Check_Non_Static_Context on exactly those real literals that are
509 -- not subexpressions of static expressions.
511 if Nkind (N) = N_Real_Literal
512 and then not Is_Machine_Number (N)
513 and then not Is_Generic_Type (Etype (N))
514 and then Etype (N) /= Universal_Real
516 -- Check that value is in bounds before converting to machine
517 -- number, so as not to lose case where value overflows in the
518 -- least significant bit or less. See B490001.
520 if Is_Out_Of_Range (N, Base_Type (T), Assume_Valid => True) then
525 -- Note: we have to copy the node, to avoid problems with conformance
526 -- of very similar numbers (see ACVC tests B4A010C and B63103A).
528 Rewrite (N, New_Copy (N));
530 if not Is_Floating_Point_Type (T) then
532 (N, Corresponding_Integer_Value (N) * Small_Value (T));
534 elsif not UR_Is_Zero (Realval (N)) then
536 -- Note: even though RM 4.9(38) specifies biased rounding, this
537 -- has been modified by AI-100 in order to prevent confusing
538 -- differences in rounding between static and non-static
539 -- expressions. AI-100 specifies that the effect of such rounding
540 -- is implementation dependent, and in GNAT we round to nearest
541 -- even to match the run-time behavior. Note that this applies
542 -- to floating point literals, not fixed points ones, even though
543 -- their compiler representation is also as a universal real.
546 (N, Machine (Base_Type (T), Realval (N), Round_Even, N));
547 Set_Is_Machine_Number (N);
552 -- Check for out of range universal integer. This is a non-static
553 -- context, so the integer value must be in range of the runtime
554 -- representation of universal integers.
556 -- We do this only within an expression, because that is the only
557 -- case in which non-static universal integer values can occur, and
558 -- furthermore, Check_Non_Static_Context is currently (incorrectly???)
559 -- called in contexts like the expression of a number declaration where
560 -- we certainly want to allow out of range values.
562 -- We inhibit the warning when expansion is disabled, because the
563 -- preanalysis of a range of a 64-bit modular type may appear to
564 -- violate the constraint on non-static Universal_Integer. If there
565 -- is a true overflow it will be diagnosed during full analysis.
567 if Etype (N) = Universal_Integer
568 and then Nkind (N) = N_Integer_Literal
569 and then Nkind (Parent (N)) in N_Subexpr
570 and then Expander_Active
572 (Intval (N) < Expr_Value (Type_Low_Bound (Universal_Integer))
574 Intval (N) > Expr_Value (Type_High_Bound (Universal_Integer)))
576 Apply_Compile_Time_Constraint_Error
577 (N, "non-static universal integer value out of range<<",
578 CE_Range_Check_Failed);
580 -- Check out of range of base type
582 elsif Is_Out_Of_Range (N, Base_Type (T), Assume_Valid => True) then
585 -- Give a warning or error on the value outside the subtype. A warning
586 -- is omitted if the expression appears in a range that could be null
587 -- (warnings are handled elsewhere for this case).
589 elsif T /= Base_Type (T) and then Nkind (Parent (N)) /= N_Range then
590 if Is_In_Range (N, T, Assume_Valid => True) then
593 elsif Is_Out_Of_Range (N, T, Assume_Valid => True) then
594 -- Ignore out of range values for System.Priority in CodePeer
595 -- mode since the actual target compiler may provide a wider
598 if CodePeer_Mode and then T = RTE (RE_Priority) then
599 Set_Do_Range_Check (N, False);
601 -- Determine if the out-of-range violation constitutes a warning
602 -- or an error based on context, according to RM 4.9 (34/3).
604 elsif Nkind_In (Original_Node (N), N_Type_Conversion,
605 N_Qualified_Expression)
606 and then Comes_From_Source (Original_Node (N))
608 Apply_Compile_Time_Constraint_Error
609 (N, "value not in range of}", CE_Range_Check_Failed);
611 Apply_Compile_Time_Constraint_Error
612 (N, "value not in range of}<<", CE_Range_Check_Failed);
616 Enable_Range_Check (N);
619 Set_Do_Range_Check (N, False);
622 end Check_Non_Static_Context;
624 ---------------------------------
625 -- Check_String_Literal_Length --
626 ---------------------------------
628 procedure Check_String_Literal_Length (N : Node_Id; Ttype : Entity_Id) is
630 if not Raises_Constraint_Error (N) and then Is_Constrained (Ttype) then
631 if UI_From_Int (String_Length (Strval (N))) /= String_Type_Len (Ttype)
633 Apply_Compile_Time_Constraint_Error
634 (N, "string length wrong for}??",
635 CE_Length_Check_Failed,
640 end Check_String_Literal_Length;
646 function Choice_Matches
648 Choice : Node_Id) return Match_Result
650 Etyp : constant Entity_Id := Etype (Expr);
656 pragma Assert (Compile_Time_Known_Value (Expr));
657 pragma Assert (Is_Scalar_Type (Etyp) or else Is_String_Type (Etyp));
659 if not Is_OK_Static_Choice (Choice) then
660 Set_Raises_Constraint_Error (Choice);
663 -- When the choice denotes a subtype with a static predictate, check the
664 -- expression against the predicate values. Different procedures apply
665 -- to discrete and non-discrete types.
667 elsif (Nkind (Choice) = N_Subtype_Indication
668 or else (Is_Entity_Name (Choice)
669 and then Is_Type (Entity (Choice))))
670 and then Has_Predicates (Etype (Choice))
671 and then Has_Static_Predicate (Etype (Choice))
673 if Is_Discrete_Type (Etype (Choice)) then
676 (Expr, Static_Discrete_Predicate (Etype (Choice)));
678 elsif Real_Or_String_Static_Predicate_Matches (Expr, Etype (Choice))
686 -- Discrete type case only
688 elsif Is_Discrete_Type (Etyp) then
689 Val := Expr_Value (Expr);
691 if Nkind (Choice) = N_Range then
692 if Val >= Expr_Value (Low_Bound (Choice))
694 Val <= Expr_Value (High_Bound (Choice))
701 elsif Nkind (Choice) = N_Subtype_Indication
702 or else (Is_Entity_Name (Choice) and then Is_Type (Entity (Choice)))
704 if Val >= Expr_Value (Type_Low_Bound (Etype (Choice)))
706 Val <= Expr_Value (Type_High_Bound (Etype (Choice)))
713 elsif Nkind (Choice) = N_Others_Choice then
717 if Val = Expr_Value (Choice) then
726 elsif Is_Real_Type (Etyp) then
727 ValR := Expr_Value_R (Expr);
729 if Nkind (Choice) = N_Range then
730 if ValR >= Expr_Value_R (Low_Bound (Choice))
732 ValR <= Expr_Value_R (High_Bound (Choice))
739 elsif Nkind (Choice) = N_Subtype_Indication
740 or else (Is_Entity_Name (Choice) and then Is_Type (Entity (Choice)))
742 if ValR >= Expr_Value_R (Type_Low_Bound (Etype (Choice)))
744 ValR <= Expr_Value_R (Type_High_Bound (Etype (Choice)))
752 if ValR = Expr_Value_R (Choice) then
762 pragma Assert (Is_String_Type (Etyp));
763 ValS := Expr_Value_S (Expr);
765 if Nkind (Choice) = N_Subtype_Indication
766 or else (Is_Entity_Name (Choice) and then Is_Type (Entity (Choice)))
768 if not Is_Constrained (Etype (Choice)) then
773 Typlen : constant Uint :=
774 String_Type_Len (Etype (Choice));
775 Strlen : constant Uint :=
776 UI_From_Int (String_Length (Strval (ValS)));
778 if Typlen = Strlen then
787 if String_Equal (Strval (ValS), Strval (Expr_Value_S (Choice)))
801 function Choices_Match
803 Choices : List_Id) return Match_Result
806 Result : Match_Result;
809 Choice := First (Choices);
810 while Present (Choice) loop
811 Result := Choice_Matches (Expr, Choice);
813 if Result /= No_Match then
823 --------------------------
824 -- Compile_Time_Compare --
825 --------------------------
827 function Compile_Time_Compare
829 Assume_Valid : Boolean) return Compare_Result
831 Discard : aliased Uint;
833 return Compile_Time_Compare (L, R, Discard'Access, Assume_Valid);
834 end Compile_Time_Compare;
836 function Compile_Time_Compare
839 Assume_Valid : Boolean;
840 Rec : Boolean := False) return Compare_Result
842 Ltyp : Entity_Id := Etype (L);
843 Rtyp : Entity_Id := Etype (R);
845 Discard : aliased Uint;
847 procedure Compare_Decompose
851 -- This procedure decomposes the node N into an expression node and a
852 -- signed offset, so that the value of N is equal to the value of R plus
853 -- the value V (which may be negative). If no such decomposition is
854 -- possible, then on return R is a copy of N, and V is set to zero.
856 function Compare_Fixup (N : Node_Id) return Node_Id;
857 -- This function deals with replacing 'Last and 'First references with
858 -- their corresponding type bounds, which we then can compare. The
859 -- argument is the original node, the result is the identity, unless we
860 -- have a 'Last/'First reference in which case the value returned is the
861 -- appropriate type bound.
863 function Is_Known_Valid_Operand (Opnd : Node_Id) return Boolean;
864 -- Even if the context does not assume that values are valid, some
865 -- simple cases can be recognized.
867 function Is_Same_Value (L, R : Node_Id) return Boolean;
868 -- Returns True iff L and R represent expressions that definitely have
869 -- identical (but not necessarily compile-time-known) values Indeed the
870 -- caller is expected to have already dealt with the cases of compile
871 -- time known values, so these are not tested here.
873 -----------------------
874 -- Compare_Decompose --
875 -----------------------
877 procedure Compare_Decompose
883 if Nkind (N) = N_Op_Add
884 and then Nkind (Right_Opnd (N)) = N_Integer_Literal
887 V := Intval (Right_Opnd (N));
890 elsif Nkind (N) = N_Op_Subtract
891 and then Nkind (Right_Opnd (N)) = N_Integer_Literal
894 V := UI_Negate (Intval (Right_Opnd (N)));
897 elsif Nkind (N) = N_Attribute_Reference then
898 if Attribute_Name (N) = Name_Succ then
899 R := First (Expressions (N));
903 elsif Attribute_Name (N) = Name_Pred then
904 R := First (Expressions (N));
912 end Compare_Decompose;
918 function Compare_Fixup (N : Node_Id) return Node_Id is
924 -- Fixup only required for First/Last attribute reference
926 if Nkind (N) = N_Attribute_Reference
927 and then Nam_In (Attribute_Name (N), Name_First, Name_Last)
929 Xtyp := Etype (Prefix (N));
931 -- If we have no type, then just abandon the attempt to do
932 -- a fixup, this is probably the result of some other error.
938 -- Dereference an access type
940 if Is_Access_Type (Xtyp) then
941 Xtyp := Designated_Type (Xtyp);
944 -- If we don't have an array type at this stage, something is
945 -- peculiar, e.g. another error, and we abandon the attempt at
948 if not Is_Array_Type (Xtyp) then
952 -- Ignore unconstrained array, since bounds are not meaningful
954 if not Is_Constrained (Xtyp) then
958 if Ekind (Xtyp) = E_String_Literal_Subtype then
959 if Attribute_Name (N) = Name_First then
960 return String_Literal_Low_Bound (Xtyp);
963 Make_Integer_Literal (Sloc (N),
964 Intval => Intval (String_Literal_Low_Bound (Xtyp)) +
965 String_Literal_Length (Xtyp));
969 -- Find correct index type
971 Indx := First_Index (Xtyp);
973 if Present (Expressions (N)) then
974 Subs := UI_To_Int (Expr_Value (First (Expressions (N))));
976 for J in 2 .. Subs loop
981 Xtyp := Etype (Indx);
983 if Attribute_Name (N) = Name_First then
984 return Type_Low_Bound (Xtyp);
986 return Type_High_Bound (Xtyp);
993 ----------------------------
994 -- Is_Known_Valid_Operand --
995 ----------------------------
997 function Is_Known_Valid_Operand (Opnd : Node_Id) return Boolean is
999 return (Is_Entity_Name (Opnd)
1001 (Is_Known_Valid (Entity (Opnd))
1002 or else Ekind (Entity (Opnd)) = E_In_Parameter
1004 (Ekind (Entity (Opnd)) in Object_Kind
1005 and then Present (Current_Value (Entity (Opnd))))))
1006 or else Is_OK_Static_Expression (Opnd);
1007 end Is_Known_Valid_Operand;
1013 function Is_Same_Value (L, R : Node_Id) return Boolean is
1014 Lf : constant Node_Id := Compare_Fixup (L);
1015 Rf : constant Node_Id := Compare_Fixup (R);
1017 function Is_Rewritten_Loop_Entry (N : Node_Id) return Boolean;
1018 -- An attribute reference to Loop_Entry may have been rewritten into
1019 -- its prefix as a way to avoid generating a constant for that
1020 -- attribute when the corresponding pragma is ignored. These nodes
1021 -- should be ignored when deciding if they can be equal to one
1024 function Is_Same_Subscript (L, R : List_Id) return Boolean;
1025 -- L, R are the Expressions values from two attribute nodes for First
1026 -- or Last attributes. Either may be set to No_List if no expressions
1027 -- are present (indicating subscript 1). The result is True if both
1028 -- expressions represent the same subscript (note one case is where
1029 -- one subscript is missing and the other is explicitly set to 1).
1031 -----------------------------
1032 -- Is_Rewritten_Loop_Entry --
1033 -----------------------------
1035 function Is_Rewritten_Loop_Entry (N : Node_Id) return Boolean is
1036 Orig_N : constant Node_Id := Original_Node (N);
1039 and then Nkind (Orig_N) = N_Attribute_Reference
1040 and then Get_Attribute_Id (Attribute_Name (Orig_N)) =
1041 Attribute_Loop_Entry;
1042 end Is_Rewritten_Loop_Entry;
1044 -----------------------
1045 -- Is_Same_Subscript --
1046 -----------------------
1048 function Is_Same_Subscript (L, R : List_Id) return Boolean is
1054 return Expr_Value (First (R)) = Uint_1;
1059 return Expr_Value (First (L)) = Uint_1;
1061 return Expr_Value (First (L)) = Expr_Value (First (R));
1064 end Is_Same_Subscript;
1066 -- Start of processing for Is_Same_Value
1069 -- Loop_Entry nodes rewritten into their prefix inside ignored
1070 -- pragmas should never lead to a decision of equality.
1072 if Is_Rewritten_Loop_Entry (Lf)
1073 or else Is_Rewritten_Loop_Entry (Rf)
1077 -- Values are the same if they refer to the same entity and the
1078 -- entity is nonvolatile.
1080 elsif Nkind_In (Lf, N_Identifier, N_Expanded_Name)
1081 and then Nkind_In (Rf, N_Identifier, N_Expanded_Name)
1082 and then Entity (Lf) = Entity (Rf)
1084 -- If the entity is a discriminant, the two expressions may be
1085 -- bounds of components of objects of the same discriminated type.
1086 -- The values of the discriminants are not static, and therefore
1087 -- the result is unknown.
1089 and then Ekind (Entity (Lf)) /= E_Discriminant
1090 and then Present (Entity (Lf))
1092 -- This does not however apply to Float types, since we may have
1093 -- two NaN values and they should never compare equal.
1095 and then not Is_Floating_Point_Type (Etype (L))
1096 and then not Is_Volatile_Reference (L)
1097 and then not Is_Volatile_Reference (R)
1101 -- Or if they are compile-time-known and identical
1103 elsif Compile_Time_Known_Value (Lf)
1105 Compile_Time_Known_Value (Rf)
1106 and then Expr_Value (Lf) = Expr_Value (Rf)
1110 -- False if Nkind of the two nodes is different for remaining cases
1112 elsif Nkind (Lf) /= Nkind (Rf) then
1115 -- True if both 'First or 'Last values applying to the same entity
1116 -- (first and last don't change even if value does). Note that we
1117 -- need this even with the calls to Compare_Fixup, to handle the
1118 -- case of unconstrained array attributes where Compare_Fixup
1119 -- cannot find useful bounds.
1121 elsif Nkind (Lf) = N_Attribute_Reference
1122 and then Attribute_Name (Lf) = Attribute_Name (Rf)
1123 and then Nam_In (Attribute_Name (Lf), Name_First, Name_Last)
1124 and then Nkind_In (Prefix (Lf), N_Identifier, N_Expanded_Name)
1125 and then Nkind_In (Prefix (Rf), N_Identifier, N_Expanded_Name)
1126 and then Entity (Prefix (Lf)) = Entity (Prefix (Rf))
1127 and then Is_Same_Subscript (Expressions (Lf), Expressions (Rf))
1131 -- True if the same selected component from the same record
1133 elsif Nkind (Lf) = N_Selected_Component
1134 and then Selector_Name (Lf) = Selector_Name (Rf)
1135 and then Is_Same_Value (Prefix (Lf), Prefix (Rf))
1139 -- True if the same unary operator applied to the same operand
1141 elsif Nkind (Lf) in N_Unary_Op
1142 and then Is_Same_Value (Right_Opnd (Lf), Right_Opnd (Rf))
1146 -- True if the same binary operator applied to the same operands
1148 elsif Nkind (Lf) in N_Binary_Op
1149 and then Is_Same_Value (Left_Opnd (Lf), Left_Opnd (Rf))
1150 and then Is_Same_Value (Right_Opnd (Lf), Right_Opnd (Rf))
1154 -- All other cases, we can't tell, so return False
1161 -- Start of processing for Compile_Time_Compare
1164 Diff.all := No_Uint;
1166 -- In preanalysis mode, always return Unknown unless the expression
1167 -- is static. It is too early to be thinking we know the result of a
1168 -- comparison, save that judgment for the full analysis. This is
1169 -- particularly important in the case of pre and postconditions, which
1170 -- otherwise can be prematurely collapsed into having True or False
1171 -- conditions when this is inappropriate.
1173 if not (Full_Analysis
1174 or else (Is_OK_Static_Expression (L)
1176 Is_OK_Static_Expression (R)))
1181 -- If either operand could raise Constraint_Error, then we cannot
1182 -- know the result at compile time (since CE may be raised).
1184 if not (Cannot_Raise_Constraint_Error (L)
1186 Cannot_Raise_Constraint_Error (R))
1191 -- Identical operands are most certainly equal
1197 -- If expressions have no types, then do not attempt to determine if
1198 -- they are the same, since something funny is going on. One case in
1199 -- which this happens is during generic template analysis, when bounds
1200 -- are not fully analyzed.
1202 if No (Ltyp) or else No (Rtyp) then
1206 -- These get reset to the base type for the case of entities where
1207 -- Is_Known_Valid is not set. This takes care of handling possible
1208 -- invalid representations using the value of the base type, in
1209 -- accordance with RM 13.9.1(10).
1211 Ltyp := Underlying_Type (Ltyp);
1212 Rtyp := Underlying_Type (Rtyp);
1214 -- Same rationale as above, but for Underlying_Type instead of Etype
1216 if No (Ltyp) or else No (Rtyp) then
1220 -- We do not attempt comparisons for packed arrays represented as
1221 -- modular types, where the semantics of comparison is quite different.
1223 if Is_Packed_Array_Impl_Type (Ltyp)
1224 and then Is_Modular_Integer_Type (Ltyp)
1228 -- For access types, the only time we know the result at compile time
1229 -- (apart from identical operands, which we handled already) is if we
1230 -- know one operand is null and the other is not, or both operands are
1233 elsif Is_Access_Type (Ltyp) then
1234 if Known_Null (L) then
1235 if Known_Null (R) then
1237 elsif Known_Non_Null (R) then
1243 elsif Known_Non_Null (L) and then Known_Null (R) then
1250 -- Case where comparison involves two compile-time-known values
1252 elsif Compile_Time_Known_Value (L)
1254 Compile_Time_Known_Value (R)
1256 -- For the floating-point case, we have to be a little careful, since
1257 -- at compile time we are dealing with universal exact values, but at
1258 -- runtime, these will be in non-exact target form. That's why the
1259 -- returned results are LE and GE below instead of LT and GT.
1261 if Is_Floating_Point_Type (Ltyp)
1263 Is_Floating_Point_Type (Rtyp)
1266 Lo : constant Ureal := Expr_Value_R (L);
1267 Hi : constant Ureal := Expr_Value_R (R);
1278 -- For string types, we have two string literals and we proceed to
1279 -- compare them using the Ada style dictionary string comparison.
1281 elsif not Is_Scalar_Type (Ltyp) then
1283 Lstring : constant String_Id := Strval (Expr_Value_S (L));
1284 Rstring : constant String_Id := Strval (Expr_Value_S (R));
1285 Llen : constant Nat := String_Length (Lstring);
1286 Rlen : constant Nat := String_Length (Rstring);
1289 for J in 1 .. Nat'Min (Llen, Rlen) loop
1291 LC : constant Char_Code := Get_String_Char (Lstring, J);
1292 RC : constant Char_Code := Get_String_Char (Rstring, J);
1304 elsif Llen > Rlen then
1311 -- For remaining scalar cases we know exactly (note that this does
1312 -- include the fixed-point case, where we know the run time integer
1317 Lo : constant Uint := Expr_Value (L);
1318 Hi : constant Uint := Expr_Value (R);
1321 Diff.all := Hi - Lo;
1326 Diff.all := Lo - Hi;
1332 -- Cases where at least one operand is not known at compile time
1335 -- Remaining checks apply only for discrete types
1337 if not Is_Discrete_Type (Ltyp)
1339 not Is_Discrete_Type (Rtyp)
1344 -- Defend against generic types, or actually any expressions that
1345 -- contain a reference to a generic type from within a generic
1346 -- template. We don't want to do any range analysis of such
1347 -- expressions for two reasons. First, the bounds of a generic type
1348 -- itself are junk and cannot be used for any kind of analysis.
1349 -- Second, we may have a case where the range at run time is indeed
1350 -- known, but we don't want to do compile time analysis in the
1351 -- template based on that range since in an instance the value may be
1352 -- static, and able to be elaborated without reference to the bounds
1353 -- of types involved. As an example, consider:
1355 -- (F'Pos (F'Last) + 1) > Integer'Last
1357 -- The expression on the left side of > is Universal_Integer and thus
1358 -- acquires the type Integer for evaluation at run time, and at run
1359 -- time it is true that this condition is always False, but within
1360 -- an instance F may be a type with a static range greater than the
1361 -- range of Integer, and the expression statically evaluates to True.
1363 if References_Generic_Formal_Type (L)
1365 References_Generic_Formal_Type (R)
1370 -- Replace types by base types for the case of values which are not
1371 -- known to have valid representations. This takes care of properly
1372 -- dealing with invalid representations.
1374 if not Assume_Valid then
1375 if not (Is_Entity_Name (L)
1376 and then (Is_Known_Valid (Entity (L))
1377 or else Assume_No_Invalid_Values))
1379 Ltyp := Underlying_Type (Base_Type (Ltyp));
1382 if not (Is_Entity_Name (R)
1383 and then (Is_Known_Valid (Entity (R))
1384 or else Assume_No_Invalid_Values))
1386 Rtyp := Underlying_Type (Base_Type (Rtyp));
1390 -- First attempt is to decompose the expressions to extract a
1391 -- constant offset resulting from the use of any of the forms:
1398 -- Then we see if the two expressions are the same value, and if so
1399 -- the result is obtained by comparing the offsets.
1401 -- Note: the reason we do this test first is that it returns only
1402 -- decisive results (with diff set), where other tests, like the
1403 -- range test, may not be as so decisive. Consider for example
1404 -- J .. J + 1. This code can conclude LT with a difference of 1,
1405 -- even if the range of J is not known.
1414 Compare_Decompose (L, Lnode, Loffs);
1415 Compare_Decompose (R, Rnode, Roffs);
1417 if Is_Same_Value (Lnode, Rnode) then
1418 if Loffs = Roffs then
1422 -- When the offsets are not equal, we can go farther only if
1423 -- the types are not modular (e.g. X < X + 1 is False if X is
1424 -- the largest number).
1426 if not Is_Modular_Integer_Type (Ltyp)
1427 and then not Is_Modular_Integer_Type (Rtyp)
1429 if Loffs < Roffs then
1430 Diff.all := Roffs - Loffs;
1433 Diff.all := Loffs - Roffs;
1440 -- Next, try range analysis and see if operand ranges are disjoint
1448 -- True if each range is a single point
1451 Determine_Range (L, LOK, LLo, LHi, Assume_Valid);
1452 Determine_Range (R, ROK, RLo, RHi, Assume_Valid);
1455 Single := (LLo = LHi) and then (RLo = RHi);
1458 if Single and Assume_Valid then
1459 Diff.all := RLo - LLo;
1464 elsif RHi < LLo then
1465 if Single and Assume_Valid then
1466 Diff.all := LLo - RLo;
1471 elsif Single and then LLo = RLo then
1473 -- If the range includes a single literal and we can assume
1474 -- validity then the result is known even if an operand is
1477 if Assume_Valid then
1483 elsif LHi = RLo then
1486 elsif RHi = LLo then
1489 elsif not Is_Known_Valid_Operand (L)
1490 and then not Assume_Valid
1492 if Is_Same_Value (L, R) then
1499 -- If the range of either operand cannot be determined, nothing
1500 -- further can be inferred.
1507 -- Here is where we check for comparisons against maximum bounds of
1508 -- types, where we know that no value can be outside the bounds of
1509 -- the subtype. Note that this routine is allowed to assume that all
1510 -- expressions are within their subtype bounds. Callers wishing to
1511 -- deal with possibly invalid values must in any case take special
1512 -- steps (e.g. conversions to larger types) to avoid this kind of
1513 -- optimization, which is always considered to be valid. We do not
1514 -- attempt this optimization with generic types, since the type
1515 -- bounds may not be meaningful in this case.
1517 -- We are in danger of an infinite recursion here. It does not seem
1518 -- useful to go more than one level deep, so the parameter Rec is
1519 -- used to protect ourselves against this infinite recursion.
1523 -- See if we can get a decisive check against one operand and a
1524 -- bound of the other operand (four possible tests here). Note
1525 -- that we avoid testing junk bounds of a generic type.
1527 if not Is_Generic_Type (Rtyp) then
1528 case Compile_Time_Compare (L, Type_Low_Bound (Rtyp),
1530 Assume_Valid, Rec => True)
1532 when LT => return LT;
1533 when LE => return LE;
1534 when EQ => return LE;
1535 when others => null;
1538 case Compile_Time_Compare (L, Type_High_Bound (Rtyp),
1540 Assume_Valid, Rec => True)
1542 when GT => return GT;
1543 when GE => return GE;
1544 when EQ => return GE;
1545 when others => null;
1549 if not Is_Generic_Type (Ltyp) then
1550 case Compile_Time_Compare (Type_Low_Bound (Ltyp), R,
1552 Assume_Valid, Rec => True)
1554 when GT => return GT;
1555 when GE => return GE;
1556 when EQ => return GE;
1557 when others => null;
1560 case Compile_Time_Compare (Type_High_Bound (Ltyp), R,
1562 Assume_Valid, Rec => True)
1564 when LT => return LT;
1565 when LE => return LE;
1566 when EQ => return LE;
1567 when others => null;
1572 -- Next attempt is to see if we have an entity compared with a
1573 -- compile-time-known value, where there is a current value
1574 -- conditional for the entity which can tell us the result.
1578 -- Entity variable (left operand)
1581 -- Value (right operand)
1584 -- If False, we have reversed the operands
1587 -- Comparison operator kind from Get_Current_Value_Condition call
1590 -- Value from Get_Current_Value_Condition call
1595 Result : Compare_Result;
1596 -- Known result before inversion
1599 if Is_Entity_Name (L)
1600 and then Compile_Time_Known_Value (R)
1603 Val := Expr_Value (R);
1606 elsif Is_Entity_Name (R)
1607 and then Compile_Time_Known_Value (L)
1610 Val := Expr_Value (L);
1613 -- That was the last chance at finding a compile time result
1619 Get_Current_Value_Condition (Var, Op, Opn);
1621 -- That was the last chance, so if we got nothing return
1627 Opv := Expr_Value (Opn);
1629 -- We got a comparison, so we might have something interesting
1631 -- Convert LE to LT and GE to GT, just so we have fewer cases
1633 if Op = N_Op_Le then
1637 elsif Op = N_Op_Ge then
1642 -- Deal with equality case
1644 if Op = N_Op_Eq then
1647 elsif Opv < Val then
1653 -- Deal with inequality case
1655 elsif Op = N_Op_Ne then
1662 -- Deal with greater than case
1664 elsif Op = N_Op_Gt then
1667 elsif Opv = Val - 1 then
1673 -- Deal with less than case
1675 else pragma Assert (Op = N_Op_Lt);
1678 elsif Opv = Val + 1 then
1685 -- Deal with inverting result
1689 when GT => return LT;
1690 when GE => return LE;
1691 when LT => return GT;
1692 when LE => return GE;
1693 when others => return Result;
1700 end Compile_Time_Compare;
1702 -------------------------------
1703 -- Compile_Time_Known_Bounds --
1704 -------------------------------
1706 function Compile_Time_Known_Bounds (T : Entity_Id) return Boolean is
1711 if T = Any_Composite or else not Is_Array_Type (T) then
1715 Indx := First_Index (T);
1716 while Present (Indx) loop
1717 Typ := Underlying_Type (Etype (Indx));
1719 -- Never look at junk bounds of a generic type
1721 if Is_Generic_Type (Typ) then
1725 -- Otherwise check bounds for compile-time-known
1727 if not Compile_Time_Known_Value (Type_Low_Bound (Typ)) then
1729 elsif not Compile_Time_Known_Value (Type_High_Bound (Typ)) then
1737 end Compile_Time_Known_Bounds;
1739 ------------------------------
1740 -- Compile_Time_Known_Value --
1741 ------------------------------
1743 function Compile_Time_Known_Value (Op : Node_Id) return Boolean is
1744 K : constant Node_Kind := Nkind (Op);
1745 CV_Ent : CV_Entry renames CV_Cache (Nat (Op) mod CV_Cache_Size);
1748 -- Never known at compile time if bad type or raises Constraint_Error
1749 -- or empty (latter case occurs only as a result of a previous error).
1752 Check_Error_Detected;
1756 or else Etype (Op) = Any_Type
1757 or else Raises_Constraint_Error (Op)
1762 -- If we have an entity name, then see if it is the name of a constant
1763 -- and if so, test the corresponding constant value, or the name of an
1764 -- enumeration literal, which is always a constant.
1766 if Present (Etype (Op)) and then Is_Entity_Name (Op) then
1768 Ent : constant Entity_Id := Entity (Op);
1772 -- Never known at compile time if it is a packed array value. We
1773 -- might want to try to evaluate these at compile time one day,
1774 -- but we do not make that attempt now.
1776 if Is_Packed_Array_Impl_Type (Etype (Op)) then
1779 elsif Ekind (Ent) = E_Enumeration_Literal then
1782 elsif Ekind (Ent) = E_Constant then
1783 Val := Constant_Value (Ent);
1785 if Present (Val) then
1787 -- Guard against an illegal deferred constant whose full
1788 -- view is initialized with a reference to itself. Treat
1789 -- this case as a value not known at compile time.
1791 if Is_Entity_Name (Val) and then Entity (Val) = Ent then
1794 return Compile_Time_Known_Value (Val);
1797 -- Otherwise, the constant does not have a compile-time-known
1806 -- We have a value, see if it is compile-time-known
1809 -- Integer literals are worth storing in the cache
1811 if K = N_Integer_Literal then
1813 CV_Ent.V := Intval (Op);
1816 -- Other literals and NULL are known at compile time
1819 Nkind_In (K, N_Character_Literal,
1828 -- If we fall through, not known at compile time
1832 -- If we get an exception while trying to do this test, then some error
1833 -- has occurred, and we simply say that the value is not known after all
1838 end Compile_Time_Known_Value;
1840 --------------------------------------
1841 -- Compile_Time_Known_Value_Or_Aggr --
1842 --------------------------------------
1844 function Compile_Time_Known_Value_Or_Aggr (Op : Node_Id) return Boolean is
1846 -- If we have an entity name, then see if it is the name of a constant
1847 -- and if so, test the corresponding constant value, or the name of
1848 -- an enumeration literal, which is always a constant.
1850 if Is_Entity_Name (Op) then
1852 E : constant Entity_Id := Entity (Op);
1856 if Ekind (E) = E_Enumeration_Literal then
1859 elsif Ekind (E) /= E_Constant then
1863 V := Constant_Value (E);
1865 and then Compile_Time_Known_Value_Or_Aggr (V);
1869 -- We have a value, see if it is compile-time-known
1872 if Compile_Time_Known_Value (Op) then
1875 elsif Nkind (Op) = N_Aggregate then
1877 if Present (Expressions (Op)) then
1881 Expr := First (Expressions (Op));
1882 while Present (Expr) loop
1883 if not Compile_Time_Known_Value_Or_Aggr (Expr) then
1892 if Present (Component_Associations (Op)) then
1897 Cass := First (Component_Associations (Op));
1898 while Present (Cass) loop
1900 Compile_Time_Known_Value_Or_Aggr (Expression (Cass))
1912 elsif Nkind (Op) = N_Qualified_Expression then
1913 return Compile_Time_Known_Value_Or_Aggr (Expression (Op));
1915 -- All other types of values are not known at compile time
1922 end Compile_Time_Known_Value_Or_Aggr;
1924 ---------------------------------------
1925 -- CRT_Safe_Compile_Time_Known_Value --
1926 ---------------------------------------
1928 function CRT_Safe_Compile_Time_Known_Value (Op : Node_Id) return Boolean is
1930 if (Configurable_Run_Time_Mode or No_Run_Time_Mode)
1931 and then not Is_OK_Static_Expression (Op)
1935 return Compile_Time_Known_Value (Op);
1937 end CRT_Safe_Compile_Time_Known_Value;
1943 -- This is only called for actuals of functions that are not predefined
1944 -- operators (which have already been rewritten as operators at this
1945 -- stage), so the call can never be folded, and all that needs doing for
1946 -- the actual is to do the check for a non-static context.
1948 procedure Eval_Actual (N : Node_Id) is
1950 Check_Non_Static_Context (N);
1953 --------------------
1954 -- Eval_Allocator --
1955 --------------------
1957 -- Allocators are never static, so all we have to do is to do the
1958 -- check for a non-static context if an expression is present.
1960 procedure Eval_Allocator (N : Node_Id) is
1961 Expr : constant Node_Id := Expression (N);
1963 if Nkind (Expr) = N_Qualified_Expression then
1964 Check_Non_Static_Context (Expression (Expr));
1968 ------------------------
1969 -- Eval_Arithmetic_Op --
1970 ------------------------
1972 -- Arithmetic operations are static functions, so the result is static
1973 -- if both operands are static (RM 4.9(7), 4.9(20)).
1975 procedure Eval_Arithmetic_Op (N : Node_Id) is
1976 Left : constant Node_Id := Left_Opnd (N);
1977 Right : constant Node_Id := Right_Opnd (N);
1978 Ltype : constant Entity_Id := Etype (Left);
1979 Rtype : constant Entity_Id := Etype (Right);
1980 Otype : Entity_Id := Empty;
1985 -- If not foldable we are done
1987 Test_Expression_Is_Foldable (N, Left, Right, Stat, Fold);
1993 -- Otherwise attempt to fold
1995 if Is_Universal_Numeric_Type (Etype (Left))
1997 Is_Universal_Numeric_Type (Etype (Right))
1999 Otype := Find_Universal_Operator_Type (N);
2002 -- Fold for cases where both operands are of integer type
2004 if Is_Integer_Type (Ltype) and then Is_Integer_Type (Rtype) then
2006 Left_Int : constant Uint := Expr_Value (Left);
2007 Right_Int : constant Uint := Expr_Value (Right);
2013 Result := Left_Int + Right_Int;
2015 when N_Op_Subtract =>
2016 Result := Left_Int - Right_Int;
2018 when N_Op_Multiply =>
2021 (Num_Bits (Left_Int) + Num_Bits (Right_Int)))
2023 Result := Left_Int * Right_Int;
2030 -- The exception Constraint_Error is raised by integer
2031 -- division, rem and mod if the right operand is zero.
2033 if Right_Int = 0 then
2035 -- When SPARK_Mode is On, force a warning instead of
2036 -- an error in that case, as this likely corresponds
2037 -- to deactivated code.
2039 Apply_Compile_Time_Constraint_Error
2040 (N, "division by zero", CE_Divide_By_Zero,
2041 Warn => not Stat or SPARK_Mode = On);
2042 Set_Raises_Constraint_Error (N);
2045 -- Otherwise we can do the division
2048 Result := Left_Int / Right_Int;
2053 -- The exception Constraint_Error is raised by integer
2054 -- division, rem and mod if the right operand is zero.
2056 if Right_Int = 0 then
2058 -- When SPARK_Mode is On, force a warning instead of
2059 -- an error in that case, as this likely corresponds
2060 -- to deactivated code.
2062 Apply_Compile_Time_Constraint_Error
2063 (N, "mod with zero divisor", CE_Divide_By_Zero,
2064 Warn => not Stat or SPARK_Mode = On);
2068 Result := Left_Int mod Right_Int;
2073 -- The exception Constraint_Error is raised by integer
2074 -- division, rem and mod if the right operand is zero.
2076 if Right_Int = 0 then
2078 -- When SPARK_Mode is On, force a warning instead of
2079 -- an error in that case, as this likely corresponds
2080 -- to deactivated code.
2082 Apply_Compile_Time_Constraint_Error
2083 (N, "rem with zero divisor", CE_Divide_By_Zero,
2084 Warn => not Stat or SPARK_Mode = On);
2088 Result := Left_Int rem Right_Int;
2092 raise Program_Error;
2095 -- Adjust the result by the modulus if the type is a modular type
2097 if Is_Modular_Integer_Type (Ltype) then
2098 Result := Result mod Modulus (Ltype);
2100 -- For a signed integer type, check non-static overflow
2102 elsif (not Stat) and then Is_Signed_Integer_Type (Ltype) then
2104 BT : constant Entity_Id := Base_Type (Ltype);
2105 Lo : constant Uint := Expr_Value (Type_Low_Bound (BT));
2106 Hi : constant Uint := Expr_Value (Type_High_Bound (BT));
2108 if Result < Lo or else Result > Hi then
2109 Apply_Compile_Time_Constraint_Error
2110 (N, "value not in range of }??",
2111 CE_Overflow_Check_Failed,
2118 -- If we get here we can fold the result
2120 Fold_Uint (N, Result, Stat);
2123 -- Cases where at least one operand is a real. We handle the cases of
2124 -- both reals, or mixed/real integer cases (the latter happen only for
2125 -- divide and multiply, and the result is always real).
2127 elsif Is_Real_Type (Ltype) or else Is_Real_Type (Rtype) then
2134 if Is_Real_Type (Ltype) then
2135 Left_Real := Expr_Value_R (Left);
2137 Left_Real := UR_From_Uint (Expr_Value (Left));
2140 if Is_Real_Type (Rtype) then
2141 Right_Real := Expr_Value_R (Right);
2143 Right_Real := UR_From_Uint (Expr_Value (Right));
2146 if Nkind (N) = N_Op_Add then
2147 Result := Left_Real + Right_Real;
2149 elsif Nkind (N) = N_Op_Subtract then
2150 Result := Left_Real - Right_Real;
2152 elsif Nkind (N) = N_Op_Multiply then
2153 Result := Left_Real * Right_Real;
2155 else pragma Assert (Nkind (N) = N_Op_Divide);
2156 if UR_Is_Zero (Right_Real) then
2157 Apply_Compile_Time_Constraint_Error
2158 (N, "division by zero", CE_Divide_By_Zero);
2162 Result := Left_Real / Right_Real;
2165 Fold_Ureal (N, Result, Stat);
2169 -- If the operator was resolved to a specific type, make sure that type
2170 -- is frozen even if the expression is folded into a literal (which has
2171 -- a universal type).
2173 if Present (Otype) then
2174 Freeze_Before (N, Otype);
2176 end Eval_Arithmetic_Op;
2178 ----------------------------
2179 -- Eval_Character_Literal --
2180 ----------------------------
2182 -- Nothing to be done
2184 procedure Eval_Character_Literal (N : Node_Id) is
2185 pragma Warnings (Off, N);
2188 end Eval_Character_Literal;
2194 -- Static function calls are either calls to predefined operators
2195 -- with static arguments, or calls to functions that rename a literal.
2196 -- Only the latter case is handled here, predefined operators are
2197 -- constant-folded elsewhere.
2199 -- If the function is itself inherited (see 7423-001) the literal of
2200 -- the parent type must be explicitly converted to the return type
2203 procedure Eval_Call (N : Node_Id) is
2204 Loc : constant Source_Ptr := Sloc (N);
2205 Typ : constant Entity_Id := Etype (N);
2209 if Nkind (N) = N_Function_Call
2210 and then No (Parameter_Associations (N))
2211 and then Is_Entity_Name (Name (N))
2212 and then Present (Alias (Entity (Name (N))))
2213 and then Is_Enumeration_Type (Base_Type (Typ))
2215 Lit := Ultimate_Alias (Entity (Name (N)));
2217 if Ekind (Lit) = E_Enumeration_Literal then
2218 if Base_Type (Etype (Lit)) /= Base_Type (Typ) then
2220 (N, Convert_To (Typ, New_Occurrence_Of (Lit, Loc)));
2222 Rewrite (N, New_Occurrence_Of (Lit, Loc));
2230 --------------------------
2231 -- Eval_Case_Expression --
2232 --------------------------
2234 -- A conditional expression is static if all its conditions and dependent
2235 -- expressions are static. Note that we do not care if the dependent
2236 -- expressions raise CE, except for the one that will be selected.
2238 procedure Eval_Case_Expression (N : Node_Id) is
2243 Set_Is_Static_Expression (N, False);
2245 if Error_Posted (Expression (N))
2246 or else not Is_Static_Expression (Expression (N))
2248 Check_Non_Static_Context (Expression (N));
2252 -- First loop, make sure all the alternatives are static expressions
2253 -- none of which raise Constraint_Error. We make the Constraint_Error
2254 -- check because part of the legality condition for a correct static
2255 -- case expression is that the cases are covered, like any other case
2256 -- expression. And we can't do that if any of the conditions raise an
2257 -- exception, so we don't even try to evaluate if that is the case.
2259 Alt := First (Alternatives (N));
2260 while Present (Alt) loop
2262 -- The expression must be static, but we don't care at this stage
2263 -- if it raises Constraint_Error (the alternative might not match,
2264 -- in which case the expression is statically unevaluated anyway).
2266 if not Is_Static_Expression (Expression (Alt)) then
2267 Check_Non_Static_Context (Expression (Alt));
2271 -- The choices of a case always have to be static, and cannot raise
2272 -- an exception. If this condition is not met, then the expression
2273 -- is plain illegal, so just abandon evaluation attempts. No need
2274 -- to check non-static context when we have something illegal anyway.
2276 if not Is_OK_Static_Choice_List (Discrete_Choices (Alt)) then
2283 -- OK, if the above loop gets through it means that all choices are OK
2284 -- static (don't raise exceptions), so the whole case is static, and we
2285 -- can find the matching alternative.
2287 Set_Is_Static_Expression (N);
2289 -- Now to deal with propagating a possible Constraint_Error
2291 -- If the selecting expression raises CE, propagate and we are done
2293 if Raises_Constraint_Error (Expression (N)) then
2294 Set_Raises_Constraint_Error (N);
2296 -- Otherwise we need to check the alternatives to find the matching
2297 -- one. CE's in other than the matching one are not relevant. But we
2298 -- do need to check the matching one. Unlike the first loop, we do not
2299 -- have to go all the way through, when we find the matching one, quit.
2302 Alt := First (Alternatives (N));
2305 -- We must find a match among the alternatives. If not, this must
2306 -- be due to other errors, so just ignore, leaving as non-static.
2309 Set_Is_Static_Expression (N, False);
2313 -- Otherwise loop through choices of this alternative
2315 Choice := First (Discrete_Choices (Alt));
2316 while Present (Choice) loop
2318 -- If we find a matching choice, then the Expression of this
2319 -- alternative replaces N (Raises_Constraint_Error flag is
2320 -- included, so we don't have to special case that).
2322 if Choice_Matches (Expression (N), Choice) = Match then
2323 Rewrite (N, Relocate_Node (Expression (Alt)));
2333 end Eval_Case_Expression;
2335 ------------------------
2336 -- Eval_Concatenation --
2337 ------------------------
2339 -- Concatenation is a static function, so the result is static if both
2340 -- operands are static (RM 4.9(7), 4.9(21)).
2342 procedure Eval_Concatenation (N : Node_Id) is
2343 Left : constant Node_Id := Left_Opnd (N);
2344 Right : constant Node_Id := Right_Opnd (N);
2345 C_Typ : constant Entity_Id := Root_Type (Component_Type (Etype (N)));
2350 -- Concatenation is never static in Ada 83, so if Ada 83 check operand
2351 -- non-static context.
2353 if Ada_Version = Ada_83
2354 and then Comes_From_Source (N)
2356 Check_Non_Static_Context (Left);
2357 Check_Non_Static_Context (Right);
2361 -- If not foldable we are done. In principle concatenation that yields
2362 -- any string type is static (i.e. an array type of character types).
2363 -- However, character types can include enumeration literals, and
2364 -- concatenation in that case cannot be described by a literal, so we
2365 -- only consider the operation static if the result is an array of
2366 -- (a descendant of) a predefined character type.
2368 Test_Expression_Is_Foldable (N, Left, Right, Stat, Fold);
2370 if not (Is_Standard_Character_Type (C_Typ) and then Fold) then
2371 Set_Is_Static_Expression (N, False);
2375 -- Compile time string concatenation
2377 -- ??? Note that operands that are aggregates can be marked as static,
2378 -- so we should attempt at a later stage to fold concatenations with
2382 Left_Str : constant Node_Id := Get_String_Val (Left);
2384 Right_Str : constant Node_Id := Get_String_Val (Right);
2385 Folded_Val : String_Id := No_String;
2388 -- Establish new string literal, and store left operand. We make
2389 -- sure to use the special Start_String that takes an operand if
2390 -- the left operand is a string literal. Since this is optimized
2391 -- in the case where that is the most recently created string
2392 -- literal, we ensure efficient time/space behavior for the
2393 -- case of a concatenation of a series of string literals.
2395 if Nkind (Left_Str) = N_String_Literal then
2396 Left_Len := String_Length (Strval (Left_Str));
2398 -- If the left operand is the empty string, and the right operand
2399 -- is a string literal (the case of "" & "..."), the result is the
2400 -- value of the right operand. This optimization is important when
2401 -- Is_Folded_In_Parser, to avoid copying an enormous right
2404 if Left_Len = 0 and then Nkind (Right_Str) = N_String_Literal then
2405 Folded_Val := Strval (Right_Str);
2407 Start_String (Strval (Left_Str));
2412 Store_String_Char (UI_To_CC (Char_Literal_Value (Left_Str)));
2416 -- Now append the characters of the right operand, unless we
2417 -- optimized the "" & "..." case above.
2419 if Nkind (Right_Str) = N_String_Literal then
2420 if Left_Len /= 0 then
2421 Store_String_Chars (Strval (Right_Str));
2422 Folded_Val := End_String;
2425 Store_String_Char (UI_To_CC (Char_Literal_Value (Right_Str)));
2426 Folded_Val := End_String;
2429 Set_Is_Static_Expression (N, Stat);
2431 -- If left operand is the empty string, the result is the
2432 -- right operand, including its bounds if anomalous.
2435 and then Is_Array_Type (Etype (Right))
2436 and then Etype (Right) /= Any_String
2438 Set_Etype (N, Etype (Right));
2441 Fold_Str (N, Folded_Val, Static => Stat);
2443 end Eval_Concatenation;
2445 ----------------------
2446 -- Eval_Entity_Name --
2447 ----------------------
2449 -- This procedure is used for identifiers and expanded names other than
2450 -- named numbers (see Eval_Named_Integer, Eval_Named_Real. These are
2451 -- static if they denote a static constant (RM 4.9(6)) or if the name
2452 -- denotes an enumeration literal (RM 4.9(22)).
2454 procedure Eval_Entity_Name (N : Node_Id) is
2455 Def_Id : constant Entity_Id := Entity (N);
2459 -- Enumeration literals are always considered to be constants
2460 -- and cannot raise Constraint_Error (RM 4.9(22)).
2462 if Ekind (Def_Id) = E_Enumeration_Literal then
2463 Set_Is_Static_Expression (N);
2466 -- A name is static if it denotes a static constant (RM 4.9(5)), and
2467 -- we also copy Raise_Constraint_Error. Notice that even if non-static,
2468 -- it does not violate 10.2.1(8) here, since this is not a variable.
2470 elsif Ekind (Def_Id) = E_Constant then
2472 -- Deferred constants must always be treated as nonstatic outside the
2473 -- scope of their full view.
2475 if Present (Full_View (Def_Id))
2476 and then not In_Open_Scopes (Scope (Def_Id))
2480 Val := Constant_Value (Def_Id);
2483 if Present (Val) then
2484 Set_Is_Static_Expression
2485 (N, Is_Static_Expression (Val)
2486 and then Is_Static_Subtype (Etype (Def_Id)));
2487 Set_Raises_Constraint_Error (N, Raises_Constraint_Error (Val));
2489 if not Is_Static_Expression (N)
2490 and then not Is_Generic_Type (Etype (N))
2492 Validate_Static_Object_Name (N);
2495 -- Mark constant condition in SCOs
2498 and then Comes_From_Source (N)
2499 and then Is_Boolean_Type (Etype (Def_Id))
2500 and then Compile_Time_Known_Value (N)
2502 Set_SCO_Condition (N, Expr_Value_E (N) = Standard_True);
2509 -- Fall through if the name is not static
2511 Validate_Static_Object_Name (N);
2512 end Eval_Entity_Name;
2514 ------------------------
2515 -- Eval_If_Expression --
2516 ------------------------
2518 -- We can fold to a static expression if the condition and both dependent
2519 -- expressions are static. Otherwise, the only required processing is to do
2520 -- the check for non-static context for the then and else expressions.
2522 procedure Eval_If_Expression (N : Node_Id) is
2523 Condition : constant Node_Id := First (Expressions (N));
2524 Then_Expr : constant Node_Id := Next (Condition);
2525 Else_Expr : constant Node_Id := Next (Then_Expr);
2527 Non_Result : Node_Id;
2529 Rstat : constant Boolean :=
2530 Is_Static_Expression (Condition)
2532 Is_Static_Expression (Then_Expr)
2534 Is_Static_Expression (Else_Expr);
2535 -- True if result is static
2538 -- If result not static, nothing to do, otherwise set static result
2543 Set_Is_Static_Expression (N);
2546 -- If any operand is Any_Type, just propagate to result and do not try
2547 -- to fold, this prevents cascaded errors.
2549 if Etype (Condition) = Any_Type or else
2550 Etype (Then_Expr) = Any_Type or else
2551 Etype (Else_Expr) = Any_Type
2553 Set_Etype (N, Any_Type);
2554 Set_Is_Static_Expression (N, False);
2558 -- If condition raises Constraint_Error then we have already signaled
2559 -- an error, and we just propagate to the result and do not fold.
2561 if Raises_Constraint_Error (Condition) then
2562 Set_Raises_Constraint_Error (N);
2566 -- Static case where we can fold. Note that we don't try to fold cases
2567 -- where the condition is known at compile time, but the result is
2568 -- non-static. This avoids possible cases of infinite recursion where
2569 -- the expander puts in a redundant test and we remove it. Instead we
2570 -- deal with these cases in the expander.
2572 -- Select result operand
2574 if Is_True (Expr_Value (Condition)) then
2575 Result := Then_Expr;
2576 Non_Result := Else_Expr;
2578 Result := Else_Expr;
2579 Non_Result := Then_Expr;
2582 -- Note that it does not matter if the non-result operand raises a
2583 -- Constraint_Error, but if the result raises Constraint_Error then we
2584 -- replace the node with a raise Constraint_Error. This will properly
2585 -- propagate Raises_Constraint_Error since this flag is set in Result.
2587 if Raises_Constraint_Error (Result) then
2588 Rewrite_In_Raise_CE (N, Result);
2589 Check_Non_Static_Context (Non_Result);
2591 -- Otherwise the result operand replaces the original node
2594 Rewrite (N, Relocate_Node (Result));
2595 Set_Is_Static_Expression (N);
2597 end Eval_If_Expression;
2599 ----------------------------
2600 -- Eval_Indexed_Component --
2601 ----------------------------
2603 -- Indexed components are never static, so we need to perform the check
2604 -- for non-static context on the index values. Then, we check if the
2605 -- value can be obtained at compile time, even though it is non-static.
2607 procedure Eval_Indexed_Component (N : Node_Id) is
2611 -- Check for non-static context on index values
2613 Expr := First (Expressions (N));
2614 while Present (Expr) loop
2615 Check_Non_Static_Context (Expr);
2619 -- If the indexed component appears in an object renaming declaration
2620 -- then we do not want to try to evaluate it, since in this case we
2621 -- need the identity of the array element.
2623 if Nkind (Parent (N)) = N_Object_Renaming_Declaration then
2626 -- Similarly if the indexed component appears as the prefix of an
2627 -- attribute we don't want to evaluate it, because at least for
2628 -- some cases of attributes we need the identify (e.g. Access, Size)
2630 elsif Nkind (Parent (N)) = N_Attribute_Reference then
2634 -- Note: there are other cases, such as the left side of an assignment,
2635 -- or an OUT parameter for a call, where the replacement results in the
2636 -- illegal use of a constant, But these cases are illegal in the first
2637 -- place, so the replacement, though silly, is harmless.
2639 -- Now see if this is a constant array reference
2641 if List_Length (Expressions (N)) = 1
2642 and then Is_Entity_Name (Prefix (N))
2643 and then Ekind (Entity (Prefix (N))) = E_Constant
2644 and then Present (Constant_Value (Entity (Prefix (N))))
2647 Loc : constant Source_Ptr := Sloc (N);
2648 Arr : constant Node_Id := Constant_Value (Entity (Prefix (N)));
2649 Sub : constant Node_Id := First (Expressions (N));
2655 -- Linear one's origin subscript value for array reference
2658 -- Lower bound of the first array index
2661 -- Value from constant array
2664 Atyp := Etype (Arr);
2666 if Is_Access_Type (Atyp) then
2667 Atyp := Designated_Type (Atyp);
2670 -- If we have an array type (we should have but perhaps there are
2671 -- error cases where this is not the case), then see if we can do
2672 -- a constant evaluation of the array reference.
2674 if Is_Array_Type (Atyp) and then Atyp /= Any_Composite then
2675 if Ekind (Atyp) = E_String_Literal_Subtype then
2676 Lbd := String_Literal_Low_Bound (Atyp);
2678 Lbd := Type_Low_Bound (Etype (First_Index (Atyp)));
2681 if Compile_Time_Known_Value (Sub)
2682 and then Nkind (Arr) = N_Aggregate
2683 and then Compile_Time_Known_Value (Lbd)
2684 and then Is_Discrete_Type (Component_Type (Atyp))
2686 Lin := UI_To_Int (Expr_Value (Sub) - Expr_Value (Lbd)) + 1;
2688 if List_Length (Expressions (Arr)) >= Lin then
2689 Elm := Pick (Expressions (Arr), Lin);
2691 -- If the resulting expression is compile-time-known,
2692 -- then we can rewrite the indexed component with this
2693 -- value, being sure to mark the result as non-static.
2694 -- We also reset the Sloc, in case this generates an
2695 -- error later on (e.g. 136'Access).
2697 if Compile_Time_Known_Value (Elm) then
2698 Rewrite (N, Duplicate_Subexpr_No_Checks (Elm));
2699 Set_Is_Static_Expression (N, False);
2704 -- We can also constant-fold if the prefix is a string literal.
2705 -- This will be useful in an instantiation or an inlining.
2707 elsif Compile_Time_Known_Value (Sub)
2708 and then Nkind (Arr) = N_String_Literal
2709 and then Compile_Time_Known_Value (Lbd)
2710 and then Expr_Value (Lbd) = 1
2711 and then Expr_Value (Sub) <=
2712 String_Literal_Length (Etype (Arr))
2715 C : constant Char_Code :=
2716 Get_String_Char (Strval (Arr),
2717 UI_To_Int (Expr_Value (Sub)));
2719 Set_Character_Literal_Name (C);
2722 Make_Character_Literal (Loc,
2724 Char_Literal_Value => UI_From_CC (C));
2725 Set_Etype (Elm, Component_Type (Atyp));
2726 Rewrite (N, Duplicate_Subexpr_No_Checks (Elm));
2727 Set_Is_Static_Expression (N, False);
2733 end Eval_Indexed_Component;
2735 --------------------------
2736 -- Eval_Integer_Literal --
2737 --------------------------
2739 -- Numeric literals are static (RM 4.9(1)), and have already been marked
2740 -- as static by the analyzer. The reason we did it that early is to allow
2741 -- the possibility of turning off the Is_Static_Expression flag after
2742 -- analysis, but before resolution, when integer literals are generated in
2743 -- the expander that do not correspond to static expressions.
2745 procedure Eval_Integer_Literal (N : Node_Id) is
2746 function In_Any_Integer_Context (Context : Node_Id) return Boolean;
2747 -- If the literal is resolved with a specific type in a context where
2748 -- the expected type is Any_Integer, there are no range checks on the
2749 -- literal. By the time the literal is evaluated, it carries the type
2750 -- imposed by the enclosing expression, and we must recover the context
2751 -- to determine that Any_Integer is meant.
2753 ----------------------------
2754 -- In_Any_Integer_Context --
2755 ----------------------------
2757 function In_Any_Integer_Context (Context : Node_Id) return Boolean is
2759 -- Any_Integer also appears in digits specifications for real types,
2760 -- but those have bounds smaller that those of any integer base type,
2761 -- so we can safely ignore these cases.
2764 Nkind_In (Context, N_Attribute_Definition_Clause,
2765 N_Attribute_Reference,
2766 N_Modular_Type_Definition,
2767 N_Number_Declaration,
2768 N_Signed_Integer_Type_Definition);
2769 end In_Any_Integer_Context;
2773 Par : constant Node_Id := Parent (N);
2774 Typ : constant Entity_Id := Etype (N);
2776 -- Start of processing for Eval_Integer_Literal
2779 -- If the literal appears in a non-expression context, then it is
2780 -- certainly appearing in a non-static context, so check it. This is
2781 -- actually a redundant check, since Check_Non_Static_Context would
2782 -- check it, but it seems worthwhile to optimize out the call.
2784 -- Additionally, when the literal appears within an if or case
2785 -- expression it must be checked as well. However, due to the literal
2786 -- appearing within a conditional statement, expansion greatly changes
2787 -- the nature of its context and performing some of the checks within
2788 -- Check_Non_Static_Context on an expanded literal may lead to spurious
2789 -- and misleading warnings.
2791 if (Nkind_In (Par, N_Case_Expression_Alternative, N_If_Expression)
2792 or else Nkind (Parent (N)) not in N_Subexpr)
2793 and then (not Nkind_In (Par, N_Case_Expression_Alternative,
2795 or else Comes_From_Source (N))
2796 and then not In_Any_Integer_Context (Par)
2798 Check_Non_Static_Context (N);
2801 -- Modular integer literals must be in their base range
2803 if Is_Modular_Integer_Type (Typ)
2804 and then Is_Out_Of_Range (N, Base_Type (Typ), Assume_Valid => True)
2808 end Eval_Integer_Literal;
2810 ---------------------
2811 -- Eval_Logical_Op --
2812 ---------------------
2814 -- Logical operations are static functions, so the result is potentially
2815 -- static if both operands are potentially static (RM 4.9(7), 4.9(20)).
2817 procedure Eval_Logical_Op (N : Node_Id) is
2818 Left : constant Node_Id := Left_Opnd (N);
2819 Right : constant Node_Id := Right_Opnd (N);
2824 -- If not foldable we are done
2826 Test_Expression_Is_Foldable (N, Left, Right, Stat, Fold);
2832 -- Compile time evaluation of logical operation
2835 Left_Int : constant Uint := Expr_Value (Left);
2836 Right_Int : constant Uint := Expr_Value (Right);
2839 if Is_Modular_Integer_Type (Etype (N)) then
2841 Left_Bits : Bits (0 .. UI_To_Int (Esize (Etype (N))) - 1);
2842 Right_Bits : Bits (0 .. UI_To_Int (Esize (Etype (N))) - 1);
2845 To_Bits (Left_Int, Left_Bits);
2846 To_Bits (Right_Int, Right_Bits);
2848 -- Note: should really be able to use array ops instead of
2849 -- these loops, but they weren't working at the time ???
2851 if Nkind (N) = N_Op_And then
2852 for J in Left_Bits'Range loop
2853 Left_Bits (J) := Left_Bits (J) and Right_Bits (J);
2856 elsif Nkind (N) = N_Op_Or then
2857 for J in Left_Bits'Range loop
2858 Left_Bits (J) := Left_Bits (J) or Right_Bits (J);
2862 pragma Assert (Nkind (N) = N_Op_Xor);
2864 for J in Left_Bits'Range loop
2865 Left_Bits (J) := Left_Bits (J) xor Right_Bits (J);
2869 Fold_Uint (N, From_Bits (Left_Bits, Etype (N)), Stat);
2873 pragma Assert (Is_Boolean_Type (Etype (N)));
2875 if Nkind (N) = N_Op_And then
2877 Test (Is_True (Left_Int) and then Is_True (Right_Int)), Stat);
2879 elsif Nkind (N) = N_Op_Or then
2881 Test (Is_True (Left_Int) or else Is_True (Right_Int)), Stat);
2884 pragma Assert (Nkind (N) = N_Op_Xor);
2886 Test (Is_True (Left_Int) xor Is_True (Right_Int)), Stat);
2890 end Eval_Logical_Op;
2892 ------------------------
2893 -- Eval_Membership_Op --
2894 ------------------------
2896 -- A membership test is potentially static if the expression is static, and
2897 -- the range is a potentially static range, or is a subtype mark denoting a
2898 -- static subtype (RM 4.9(12)).
2900 procedure Eval_Membership_Op (N : Node_Id) is
2901 Alts : constant List_Id := Alternatives (N);
2902 Choice : constant Node_Id := Right_Opnd (N);
2903 Expr : constant Node_Id := Left_Opnd (N);
2904 Result : Match_Result;
2907 -- Ignore if error in either operand, except to make sure that Any_Type
2908 -- is properly propagated to avoid junk cascaded errors.
2910 if Etype (Expr) = Any_Type
2911 or else (Present (Choice) and then Etype (Choice) = Any_Type)
2913 Set_Etype (N, Any_Type);
2917 -- If left operand non-static, then nothing to do
2919 if not Is_Static_Expression (Expr) then
2923 -- If choice is non-static, left operand is in non-static context
2925 if (Present (Choice) and then not Is_Static_Choice (Choice))
2926 or else (Present (Alts) and then not Is_Static_Choice_List (Alts))
2928 Check_Non_Static_Context (Expr);
2932 -- Otherwise we definitely have a static expression
2934 Set_Is_Static_Expression (N);
2936 -- If left operand raises Constraint_Error, propagate and we are done
2938 if Raises_Constraint_Error (Expr) then
2939 Set_Raises_Constraint_Error (N, True);
2944 if Present (Choice) then
2945 Result := Choice_Matches (Expr, Choice);
2947 Result := Choices_Match (Expr, Alts);
2950 -- If result is Non_Static, it means that we raise Constraint_Error,
2951 -- since we already tested that the operands were themselves static.
2953 if Result = Non_Static then
2954 Set_Raises_Constraint_Error (N);
2956 -- Otherwise we have our result (flipped if NOT IN case)
2960 (N, Test ((Result = Match) xor (Nkind (N) = N_Not_In)), True);
2961 Warn_On_Known_Condition (N);
2964 end Eval_Membership_Op;
2966 ------------------------
2967 -- Eval_Named_Integer --
2968 ------------------------
2970 procedure Eval_Named_Integer (N : Node_Id) is
2973 Expr_Value (Expression (Declaration_Node (Entity (N)))), True);
2974 end Eval_Named_Integer;
2976 ---------------------
2977 -- Eval_Named_Real --
2978 ---------------------
2980 procedure Eval_Named_Real (N : Node_Id) is
2983 Expr_Value_R (Expression (Declaration_Node (Entity (N)))), True);
2984 end Eval_Named_Real;
2990 -- Exponentiation is a static functions, so the result is potentially
2991 -- static if both operands are potentially static (RM 4.9(7), 4.9(20)).
2993 procedure Eval_Op_Expon (N : Node_Id) is
2994 Left : constant Node_Id := Left_Opnd (N);
2995 Right : constant Node_Id := Right_Opnd (N);
3000 -- If not foldable we are done
3002 Test_Expression_Is_Foldable
3003 (N, Left, Right, Stat, Fold, CRT_Safe => True);
3005 -- Return if not foldable
3011 if Configurable_Run_Time_Mode and not Stat then
3015 -- Fold exponentiation operation
3018 Right_Int : constant Uint := Expr_Value (Right);
3023 if Is_Integer_Type (Etype (Left)) then
3025 Left_Int : constant Uint := Expr_Value (Left);
3029 -- Exponentiation of an integer raises Constraint_Error for a
3030 -- negative exponent (RM 4.5.6).
3032 if Right_Int < 0 then
3033 Apply_Compile_Time_Constraint_Error
3034 (N, "integer exponent negative", CE_Range_Check_Failed,
3039 if OK_Bits (N, Num_Bits (Left_Int) * Right_Int) then
3040 Result := Left_Int ** Right_Int;
3045 if Is_Modular_Integer_Type (Etype (N)) then
3046 Result := Result mod Modulus (Etype (N));
3049 Fold_Uint (N, Result, Stat);
3057 Left_Real : constant Ureal := Expr_Value_R (Left);
3060 -- Cannot have a zero base with a negative exponent
3062 if UR_Is_Zero (Left_Real) then
3064 if Right_Int < 0 then
3065 Apply_Compile_Time_Constraint_Error
3066 (N, "zero ** negative integer", CE_Range_Check_Failed,
3070 Fold_Ureal (N, Ureal_0, Stat);
3074 Fold_Ureal (N, Left_Real ** Right_Int, Stat);
3085 -- The not operation is a static functions, so the result is potentially
3086 -- static if the operand is potentially static (RM 4.9(7), 4.9(20)).
3088 procedure Eval_Op_Not (N : Node_Id) is
3089 Right : constant Node_Id := Right_Opnd (N);
3094 -- If not foldable we are done
3096 Test_Expression_Is_Foldable (N, Right, Stat, Fold);
3102 -- Fold not operation
3105 Rint : constant Uint := Expr_Value (Right);
3106 Typ : constant Entity_Id := Etype (N);
3109 -- Negation is equivalent to subtracting from the modulus minus one.
3110 -- For a binary modulus this is equivalent to the ones-complement of
3111 -- the original value. For a nonbinary modulus this is an arbitrary
3112 -- but consistent definition.
3114 if Is_Modular_Integer_Type (Typ) then
3115 Fold_Uint (N, Modulus (Typ) - 1 - Rint, Stat);
3116 else pragma Assert (Is_Boolean_Type (Typ));
3117 Fold_Uint (N, Test (not Is_True (Rint)), Stat);
3120 Set_Is_Static_Expression (N, Stat);
3124 -------------------------------
3125 -- Eval_Qualified_Expression --
3126 -------------------------------
3128 -- A qualified expression is potentially static if its subtype mark denotes
3129 -- a static subtype and its expression is potentially static (RM 4.9 (11)).
3131 procedure Eval_Qualified_Expression (N : Node_Id) is
3132 Operand : constant Node_Id := Expression (N);
3133 Target_Type : constant Entity_Id := Entity (Subtype_Mark (N));
3140 -- Can only fold if target is string or scalar and subtype is static.
3141 -- Also, do not fold if our parent is an allocator (this is because the
3142 -- qualified expression is really part of the syntactic structure of an
3143 -- allocator, and we do not want to end up with something that
3144 -- corresponds to "new 1" where the 1 is the result of folding a
3145 -- qualified expression).
3147 if not Is_Static_Subtype (Target_Type)
3148 or else Nkind (Parent (N)) = N_Allocator
3150 Check_Non_Static_Context (Operand);
3152 -- If operand is known to raise constraint_error, set the flag on the
3153 -- expression so it does not get optimized away.
3155 if Nkind (Operand) = N_Raise_Constraint_Error then
3156 Set_Raises_Constraint_Error (N);
3162 -- If not foldable we are done
3164 Test_Expression_Is_Foldable (N, Operand, Stat, Fold);
3169 -- Don't try fold if target type has Constraint_Error bounds
3171 elsif not Is_OK_Static_Subtype (Target_Type) then
3172 Set_Raises_Constraint_Error (N);
3176 -- Here we will fold, save Print_In_Hex indication
3178 Hex := Nkind (Operand) = N_Integer_Literal
3179 and then Print_In_Hex (Operand);
3181 -- Fold the result of qualification
3183 if Is_Discrete_Type (Target_Type) then
3184 Fold_Uint (N, Expr_Value (Operand), Stat);
3186 -- Preserve Print_In_Hex indication
3188 if Hex and then Nkind (N) = N_Integer_Literal then
3189 Set_Print_In_Hex (N);
3192 elsif Is_Real_Type (Target_Type) then
3193 Fold_Ureal (N, Expr_Value_R (Operand), Stat);
3196 Fold_Str (N, Strval (Get_String_Val (Operand)), Stat);
3199 Set_Is_Static_Expression (N, False);
3201 Check_String_Literal_Length (N, Target_Type);
3207 -- The expression may be foldable but not static
3209 Set_Is_Static_Expression (N, Stat);
3211 if Is_Out_Of_Range (N, Etype (N), Assume_Valid => True) then
3214 end Eval_Qualified_Expression;
3216 -----------------------
3217 -- Eval_Real_Literal --
3218 -----------------------
3220 -- Numeric literals are static (RM 4.9(1)), and have already been marked
3221 -- as static by the analyzer. The reason we did it that early is to allow
3222 -- the possibility of turning off the Is_Static_Expression flag after
3223 -- analysis, but before resolution, when integer literals are generated
3224 -- in the expander that do not correspond to static expressions.
3226 procedure Eval_Real_Literal (N : Node_Id) is
3227 PK : constant Node_Kind := Nkind (Parent (N));
3230 -- If the literal appears in a non-expression context and not as part of
3231 -- a number declaration, then it is appearing in a non-static context,
3234 if PK not in N_Subexpr and then PK /= N_Number_Declaration then
3235 Check_Non_Static_Context (N);
3237 end Eval_Real_Literal;
3239 ------------------------
3240 -- Eval_Relational_Op --
3241 ------------------------
3243 -- Relational operations are static functions, so the result is static if
3244 -- both operands are static (RM 4.9(7), 4.9(20)), except that for strings,
3245 -- the result is never static, even if the operands are.
3247 -- However, for internally generated nodes, we allow string equality and
3248 -- inequality to be static. This is because we rewrite A in "ABC" as an
3249 -- equality test A = "ABC", and the former is definitely static.
3251 procedure Eval_Relational_Op (N : Node_Id) is
3252 Left : constant Node_Id := Left_Opnd (N);
3253 Right : constant Node_Id := Right_Opnd (N);
3255 procedure Decompose_Expr
3257 Ent : out Entity_Id;
3258 Kind : out Character;
3260 Orig : Boolean := True);
3261 -- Given expression Expr, see if it is of the form X [+/- K]. If so, Ent
3262 -- is set to the entity in X, Kind is 'F','L','E' for 'First or 'Last or
3263 -- simple entity, and Cons is the value of K. If the expression is not
3264 -- of the required form, Ent is set to Empty.
3266 -- Orig indicates whether Expr is the original expression to consider,
3267 -- or if we are handling a subexpression (e.g. recursive call to
3270 procedure Fold_General_Op (Is_Static : Boolean);
3271 -- Attempt to fold arbitrary relational operator N. Flag Is_Static must
3272 -- be set when the operator denotes a static expression.
3274 procedure Fold_Static_Real_Op;
3275 -- Attempt to fold static real type relational operator N
3277 function Static_Length (Expr : Node_Id) return Uint;
3278 -- If Expr is an expression for a constrained array whose length is
3279 -- known at compile time, return the non-negative length, otherwise
3282 --------------------
3283 -- Decompose_Expr --
3284 --------------------
3286 procedure Decompose_Expr
3288 Ent : out Entity_Id;
3289 Kind : out Character;
3291 Orig : Boolean := True)
3296 -- Assume that the expression does not meet the expected form
3302 if Nkind (Expr) = N_Op_Add
3303 and then Compile_Time_Known_Value (Right_Opnd (Expr))
3305 Exp := Left_Opnd (Expr);
3306 Cons := Expr_Value (Right_Opnd (Expr));
3308 elsif Nkind (Expr) = N_Op_Subtract
3309 and then Compile_Time_Known_Value (Right_Opnd (Expr))
3311 Exp := Left_Opnd (Expr);
3312 Cons := -Expr_Value (Right_Opnd (Expr));
3314 -- If the bound is a constant created to remove side effects, recover
3315 -- the original expression to see if it has one of the recognizable
3318 elsif Nkind (Expr) = N_Identifier
3319 and then not Comes_From_Source (Entity (Expr))
3320 and then Ekind (Entity (Expr)) = E_Constant
3321 and then Nkind (Parent (Entity (Expr))) = N_Object_Declaration
3323 Exp := Expression (Parent (Entity (Expr)));
3324 Decompose_Expr (Exp, Ent, Kind, Cons, Orig => False);
3326 -- If original expression includes an entity, create a reference
3327 -- to it for use below.
3329 if Present (Ent) then
3330 Exp := New_Occurrence_Of (Ent, Sloc (Ent));
3336 -- Only consider the case of X + 0 for a full expression, and
3337 -- not when recursing, otherwise we may end up with evaluating
3338 -- expressions not known at compile time to 0.
3348 -- At this stage Exp is set to the potential X
3350 if Nkind (Exp) = N_Attribute_Reference then
3351 if Attribute_Name (Exp) = Name_First then
3353 elsif Attribute_Name (Exp) = Name_Last then
3359 Exp := Prefix (Exp);
3365 if Is_Entity_Name (Exp) and then Present (Entity (Exp)) then
3366 Ent := Entity (Exp);
3370 ---------------------
3371 -- Fold_General_Op --
3372 ---------------------
3374 procedure Fold_General_Op (Is_Static : Boolean) is
3375 CR : constant Compare_Result :=
3376 Compile_Time_Compare (Left, Right, Assume_Valid => False);
3381 if CR = Unknown then
3389 elsif CR = NE or else CR = GT or else CR = LT then
3396 if CR = GT or else CR = EQ or else CR = GE then
3407 elsif CR = EQ or else CR = LT or else CR = LE then
3414 if CR = LT or else CR = EQ or else CR = LE then
3425 elsif CR = EQ or else CR = GT or else CR = GE then
3432 if CR = NE or else CR = GT or else CR = LT then
3441 raise Program_Error;
3444 -- Determine the potential outcome of the relation assuming the
3445 -- operands are valid and emit a warning when the relation yields
3446 -- True or False only in the presence of invalid values.
3448 Warn_On_Constant_Valid_Condition (N);
3450 Fold_Uint (N, Test (Result), Is_Static);
3451 end Fold_General_Op;
3453 -------------------------
3454 -- Fold_Static_Real_Op --
3455 -------------------------
3457 procedure Fold_Static_Real_Op is
3458 Left_Real : constant Ureal := Expr_Value_R (Left);
3459 Right_Real : constant Ureal := Expr_Value_R (Right);
3464 when N_Op_Eq => Result := (Left_Real = Right_Real);
3465 when N_Op_Ge => Result := (Left_Real >= Right_Real);
3466 when N_Op_Gt => Result := (Left_Real > Right_Real);
3467 when N_Op_Le => Result := (Left_Real <= Right_Real);
3468 when N_Op_Lt => Result := (Left_Real < Right_Real);
3469 when N_Op_Ne => Result := (Left_Real /= Right_Real);
3470 when others => raise Program_Error;
3473 Fold_Uint (N, Test (Result), True);
3474 end Fold_Static_Real_Op;
3480 function Static_Length (Expr : Node_Id) return Uint is
3490 -- First easy case string literal
3492 if Nkind (Expr) = N_String_Literal then
3493 return UI_From_Int (String_Length (Strval (Expr)));
3495 -- With frontend inlining as performed in GNATprove mode, a variable
3496 -- may be inserted that has a string literal subtype. Deal with this
3497 -- specially as for the previous case.
3499 elsif Ekind (Etype (Expr)) = E_String_Literal_Subtype then
3500 return String_Literal_Length (Etype (Expr));
3502 -- Second easy case, not constrained subtype, so no length
3504 elsif not Is_Constrained (Etype (Expr)) then
3505 return Uint_Minus_1;
3510 Typ := Etype (First_Index (Etype (Expr)));
3512 -- The simple case, both bounds are known at compile time
3514 if Is_Discrete_Type (Typ)
3515 and then Compile_Time_Known_Value (Type_Low_Bound (Typ))
3516 and then Compile_Time_Known_Value (Type_High_Bound (Typ))
3519 UI_Max (Uint_0, Expr_Value (Type_High_Bound (Typ)) -
3520 Expr_Value (Type_Low_Bound (Typ)) + 1);
3523 -- A more complex case, where the bounds are of the form X [+/- K1]
3524 -- .. X [+/- K2]), where X is an expression that is either A'First or
3525 -- A'Last (with A an entity name), or X is an entity name, and the
3526 -- two X's are the same and K1 and K2 are known at compile time, in
3527 -- this case, the length can also be computed at compile time, even
3528 -- though the bounds are not known. A common case of this is e.g.
3529 -- (X'First .. X'First+5).
3532 (Original_Node (Type_Low_Bound (Typ)), Ent1, Kind1, Cons1);
3534 (Original_Node (Type_High_Bound (Typ)), Ent2, Kind2, Cons2);
3536 if Present (Ent1) and then Ent1 = Ent2 and then Kind1 = Kind2 then
3537 return Cons2 - Cons1 + 1;
3539 return Uint_Minus_1;
3545 Left_Typ : constant Entity_Id := Etype (Left);
3546 Right_Typ : constant Entity_Id := Etype (Right);
3549 Op_Typ : Entity_Id := Empty;
3552 Is_Static_Expression : Boolean;
3554 -- Start of processing for Eval_Relational_Op
3557 -- One special case to deal with first. If we can tell that the result
3558 -- will be false because the lengths of one or more index subtypes are
3559 -- compile-time known and different, then we can replace the entire
3560 -- result by False. We only do this for one-dimensional arrays, because
3561 -- the case of multidimensional arrays is rare and too much trouble. If
3562 -- one of the operands is an illegal aggregate, its type might still be
3563 -- an arbitrary composite type, so nothing to do.
3565 if Is_Array_Type (Left_Typ)
3566 and then Left_Typ /= Any_Composite
3567 and then Number_Dimensions (Left_Typ) = 1
3568 and then Nkind_In (N, N_Op_Eq, N_Op_Ne)
3570 if Raises_Constraint_Error (Left)
3572 Raises_Constraint_Error (Right)
3576 -- OK, we have the case where we may be able to do this fold
3579 Left_Len := Static_Length (Left);
3580 Right_Len := Static_Length (Right);
3582 if Left_Len /= Uint_Minus_1
3583 and then Right_Len /= Uint_Minus_1
3584 and then Left_Len /= Right_Len
3586 Fold_Uint (N, Test (Nkind (N) = N_Op_Ne), False);
3587 Warn_On_Known_Condition (N);
3595 -- Initialize the value of Is_Static_Expression. The value of Fold
3596 -- returned by Test_Expression_Is_Foldable is not needed since, even
3597 -- when some operand is a variable, we can still perform the static
3598 -- evaluation of the expression in some cases (for example, for a
3599 -- variable of a subtype of Integer we statically know that any value
3600 -- stored in such variable is smaller than Integer'Last).
3602 Test_Expression_Is_Foldable
3603 (N, Left, Right, Is_Static_Expression, Fold);
3605 -- Only comparisons of scalars can give static results. A comparison
3606 -- of strings never yields a static result, even if both operands are
3607 -- static strings, except that as noted above, we allow equality and
3608 -- inequality for strings.
3610 if Is_String_Type (Left_Typ)
3611 and then not Comes_From_Source (N)
3612 and then Nkind_In (N, N_Op_Eq, N_Op_Ne)
3616 elsif not Is_Scalar_Type (Left_Typ) then
3617 Is_Static_Expression := False;
3618 Set_Is_Static_Expression (N, False);
3621 -- For operators on universal numeric types called as functions with
3622 -- an explicit scope, determine appropriate specific numeric type,
3623 -- and diagnose possible ambiguity.
3625 if Is_Universal_Numeric_Type (Left_Typ)
3627 Is_Universal_Numeric_Type (Right_Typ)
3629 Op_Typ := Find_Universal_Operator_Type (N);
3632 -- Attempt to fold the relational operator
3634 if Is_Static_Expression and then Is_Real_Type (Left_Typ) then
3635 Fold_Static_Real_Op;
3637 Fold_General_Op (Is_Static_Expression);
3641 -- For the case of a folded relational operator on a specific numeric
3642 -- type, freeze the operand type now.
3644 if Present (Op_Typ) then
3645 Freeze_Before (N, Op_Typ);
3648 Warn_On_Known_Condition (N);
3649 end Eval_Relational_Op;
3655 -- Shift operations are intrinsic operations that can never be static, so
3656 -- the only processing required is to perform the required check for a non
3657 -- static context for the two operands.
3659 -- Actually we could do some compile time evaluation here some time ???
3661 procedure Eval_Shift (N : Node_Id) is
3663 Check_Non_Static_Context (Left_Opnd (N));
3664 Check_Non_Static_Context (Right_Opnd (N));
3667 ------------------------
3668 -- Eval_Short_Circuit --
3669 ------------------------
3671 -- A short circuit operation is potentially static if both operands are
3672 -- potentially static (RM 4.9 (13)).
3674 procedure Eval_Short_Circuit (N : Node_Id) is
3675 Kind : constant Node_Kind := Nkind (N);
3676 Left : constant Node_Id := Left_Opnd (N);
3677 Right : constant Node_Id := Right_Opnd (N);
3680 Rstat : constant Boolean :=
3681 Is_Static_Expression (Left)
3683 Is_Static_Expression (Right);
3686 -- Short circuit operations are never static in Ada 83
3688 if Ada_Version = Ada_83 and then Comes_From_Source (N) then
3689 Check_Non_Static_Context (Left);
3690 Check_Non_Static_Context (Right);
3694 -- Now look at the operands, we can't quite use the normal call to
3695 -- Test_Expression_Is_Foldable here because short circuit operations
3696 -- are a special case, they can still be foldable, even if the right
3697 -- operand raises Constraint_Error.
3699 -- If either operand is Any_Type, just propagate to result and do not
3700 -- try to fold, this prevents cascaded errors.
3702 if Etype (Left) = Any_Type or else Etype (Right) = Any_Type then
3703 Set_Etype (N, Any_Type);
3706 -- If left operand raises Constraint_Error, then replace node N with
3707 -- the raise Constraint_Error node, and we are obviously not foldable.
3708 -- Is_Static_Expression is set from the two operands in the normal way,
3709 -- and we check the right operand if it is in a non-static context.
3711 elsif Raises_Constraint_Error (Left) then
3713 Check_Non_Static_Context (Right);
3716 Rewrite_In_Raise_CE (N, Left);
3717 Set_Is_Static_Expression (N, Rstat);
3720 -- If the result is not static, then we won't in any case fold
3722 elsif not Rstat then
3723 Check_Non_Static_Context (Left);
3724 Check_Non_Static_Context (Right);
3728 -- Here the result is static, note that, unlike the normal processing
3729 -- in Test_Expression_Is_Foldable, we did *not* check above to see if
3730 -- the right operand raises Constraint_Error, that's because it is not
3731 -- significant if the left operand is decisive.
3733 Set_Is_Static_Expression (N);
3735 -- It does not matter if the right operand raises Constraint_Error if
3736 -- it will not be evaluated. So deal specially with the cases where
3737 -- the right operand is not evaluated. Note that we will fold these
3738 -- cases even if the right operand is non-static, which is fine, but
3739 -- of course in these cases the result is not potentially static.
3741 Left_Int := Expr_Value (Left);
3743 if (Kind = N_And_Then and then Is_False (Left_Int))
3745 (Kind = N_Or_Else and then Is_True (Left_Int))
3747 Fold_Uint (N, Left_Int, Rstat);
3751 -- If first operand not decisive, then it does matter if the right
3752 -- operand raises Constraint_Error, since it will be evaluated, so
3753 -- we simply replace the node with the right operand. Note that this
3754 -- properly propagates Is_Static_Expression and Raises_Constraint_Error
3755 -- (both are set to True in Right).
3757 if Raises_Constraint_Error (Right) then
3758 Rewrite_In_Raise_CE (N, Right);
3759 Check_Non_Static_Context (Left);
3763 -- Otherwise the result depends on the right operand
3765 Fold_Uint (N, Expr_Value (Right), Rstat);
3767 end Eval_Short_Circuit;
3773 -- Slices can never be static, so the only processing required is to check
3774 -- for non-static context if an explicit range is given.
3776 procedure Eval_Slice (N : Node_Id) is
3777 Drange : constant Node_Id := Discrete_Range (N);
3780 if Nkind (Drange) = N_Range then
3781 Check_Non_Static_Context (Low_Bound (Drange));
3782 Check_Non_Static_Context (High_Bound (Drange));
3785 -- A slice of the form A (subtype), when the subtype is the index of
3786 -- the type of A, is redundant, the slice can be replaced with A, and
3787 -- this is worth a warning.
3789 if Is_Entity_Name (Prefix (N)) then
3791 E : constant Entity_Id := Entity (Prefix (N));
3792 T : constant Entity_Id := Etype (E);
3795 if Ekind (E) = E_Constant
3796 and then Is_Array_Type (T)
3797 and then Is_Entity_Name (Drange)
3799 if Is_Entity_Name (Original_Node (First_Index (T)))
3800 and then Entity (Original_Node (First_Index (T)))
3803 if Warn_On_Redundant_Constructs then
3804 Error_Msg_N ("redundant slice denotes whole array?r?", N);
3807 -- The following might be a useful optimization???
3809 -- Rewrite (N, New_Occurrence_Of (E, Sloc (N)));
3816 -------------------------
3817 -- Eval_String_Literal --
3818 -------------------------
3820 procedure Eval_String_Literal (N : Node_Id) is
3821 Typ : constant Entity_Id := Etype (N);
3822 Bas : constant Entity_Id := Base_Type (Typ);
3828 -- Nothing to do if error type (handles cases like default expressions
3829 -- or generics where we have not yet fully resolved the type).
3831 if Bas = Any_Type or else Bas = Any_String then
3835 -- String literals are static if the subtype is static (RM 4.9(2)), so
3836 -- reset the static expression flag (it was set unconditionally in
3837 -- Analyze_String_Literal) if the subtype is non-static. We tell if
3838 -- the subtype is static by looking at the lower bound.
3840 if Ekind (Typ) = E_String_Literal_Subtype then
3841 if not Is_OK_Static_Expression (String_Literal_Low_Bound (Typ)) then
3842 Set_Is_Static_Expression (N, False);
3846 -- Here if Etype of string literal is normal Etype (not yet possible,
3847 -- but may be possible in future).
3849 elsif not Is_OK_Static_Expression
3850 (Type_Low_Bound (Etype (First_Index (Typ))))
3852 Set_Is_Static_Expression (N, False);
3856 -- If original node was a type conversion, then result if non-static
3858 if Nkind (Original_Node (N)) = N_Type_Conversion then
3859 Set_Is_Static_Expression (N, False);
3863 -- Test for illegal Ada 95 cases. A string literal is illegal in Ada 95
3864 -- if its bounds are outside the index base type and this index type is
3865 -- static. This can happen in only two ways. Either the string literal
3866 -- is too long, or it is null, and the lower bound is type'First. Either
3867 -- way it is the upper bound that is out of range of the index type.
3869 if Ada_Version >= Ada_95 then
3870 if Is_Standard_String_Type (Bas) then
3871 Xtp := Standard_Positive;
3873 Xtp := Etype (First_Index (Bas));
3876 if Ekind (Typ) = E_String_Literal_Subtype then
3877 Lo := String_Literal_Low_Bound (Typ);
3879 Lo := Type_Low_Bound (Etype (First_Index (Typ)));
3882 -- Check for string too long
3884 Len := String_Length (Strval (N));
3886 if UI_From_Int (Len) > String_Type_Len (Bas) then
3888 -- Issue message. Note that this message is a warning if the
3889 -- string literal is not marked as static (happens in some cases
3890 -- of folding strings known at compile time, but not static).
3891 -- Furthermore in such cases, we reword the message, since there
3892 -- is no string literal in the source program.
3894 if Is_Static_Expression (N) then
3895 Apply_Compile_Time_Constraint_Error
3896 (N, "string literal too long for}", CE_Length_Check_Failed,
3898 Typ => First_Subtype (Bas));
3900 Apply_Compile_Time_Constraint_Error
3901 (N, "string value too long for}", CE_Length_Check_Failed,
3903 Typ => First_Subtype (Bas),
3907 -- Test for null string not allowed
3910 and then not Is_Generic_Type (Xtp)
3912 Expr_Value (Lo) = Expr_Value (Type_Low_Bound (Base_Type (Xtp)))
3914 -- Same specialization of message
3916 if Is_Static_Expression (N) then
3917 Apply_Compile_Time_Constraint_Error
3918 (N, "null string literal not allowed for}",
3919 CE_Length_Check_Failed,
3921 Typ => First_Subtype (Bas));
3923 Apply_Compile_Time_Constraint_Error
3924 (N, "null string value not allowed for}",
3925 CE_Length_Check_Failed,
3927 Typ => First_Subtype (Bas),
3932 end Eval_String_Literal;
3934 --------------------------
3935 -- Eval_Type_Conversion --
3936 --------------------------
3938 -- A type conversion is potentially static if its subtype mark is for a
3939 -- static scalar subtype, and its operand expression is potentially static
3942 procedure Eval_Type_Conversion (N : Node_Id) is
3943 Operand : constant Node_Id := Expression (N);
3944 Source_Type : constant Entity_Id := Etype (Operand);
3945 Target_Type : constant Entity_Id := Etype (N);
3947 function To_Be_Treated_As_Integer (T : Entity_Id) return Boolean;
3948 -- Returns true if type T is an integer type, or if it is a fixed-point
3949 -- type to be treated as an integer (i.e. the flag Conversion_OK is set
3950 -- on the conversion node).
3952 function To_Be_Treated_As_Real (T : Entity_Id) return Boolean;
3953 -- Returns true if type T is a floating-point type, or if it is a
3954 -- fixed-point type that is not to be treated as an integer (i.e. the
3955 -- flag Conversion_OK is not set on the conversion node).
3957 ------------------------------
3958 -- To_Be_Treated_As_Integer --
3959 ------------------------------
3961 function To_Be_Treated_As_Integer (T : Entity_Id) return Boolean is
3965 or else (Is_Fixed_Point_Type (T) and then Conversion_OK (N));
3966 end To_Be_Treated_As_Integer;
3968 ---------------------------
3969 -- To_Be_Treated_As_Real --
3970 ---------------------------
3972 function To_Be_Treated_As_Real (T : Entity_Id) return Boolean is
3975 Is_Floating_Point_Type (T)
3976 or else (Is_Fixed_Point_Type (T) and then not Conversion_OK (N));
3977 end To_Be_Treated_As_Real;
3984 -- Start of processing for Eval_Type_Conversion
3987 -- Cannot fold if target type is non-static or if semantic error
3989 if not Is_Static_Subtype (Target_Type) then
3990 Check_Non_Static_Context (Operand);
3992 elsif Error_Posted (N) then
3996 -- If not foldable we are done
3998 Test_Expression_Is_Foldable (N, Operand, Stat, Fold);
4003 -- Don't try fold if target type has Constraint_Error bounds
4005 elsif not Is_OK_Static_Subtype (Target_Type) then
4006 Set_Raises_Constraint_Error (N);
4010 -- Remaining processing depends on operand types. Note that in the
4011 -- following type test, fixed-point counts as real unless the flag
4012 -- Conversion_OK is set, in which case it counts as integer.
4014 -- Fold conversion, case of string type. The result is not static
4016 if Is_String_Type (Target_Type) then
4017 Fold_Str (N, Strval (Get_String_Val (Operand)), Static => False);
4020 -- Fold conversion, case of integer target type
4022 elsif To_Be_Treated_As_Integer (Target_Type) then
4027 -- Integer to integer conversion
4029 if To_Be_Treated_As_Integer (Source_Type) then
4030 Result := Expr_Value (Operand);
4032 -- Real to integer conversion
4034 elsif To_Be_Treated_As_Real (Source_Type) then
4035 Result := UR_To_Uint (Expr_Value_R (Operand));
4037 -- Enumeration to integer conversion, aka 'Enum_Rep
4040 Result := Expr_Rep_Value (Operand);
4043 -- If fixed-point type (Conversion_OK must be set), then the
4044 -- result is logically an integer, but we must replace the
4045 -- conversion with the corresponding real literal, since the
4046 -- type from a semantic point of view is still fixed-point.
4048 if Is_Fixed_Point_Type (Target_Type) then
4050 (N, UR_From_Uint (Result) * Small_Value (Target_Type), Stat);
4052 -- Otherwise result is integer literal
4055 Fold_Uint (N, Result, Stat);
4059 -- Fold conversion, case of real target type
4061 elsif To_Be_Treated_As_Real (Target_Type) then
4066 if To_Be_Treated_As_Real (Source_Type) then
4067 Result := Expr_Value_R (Operand);
4069 Result := UR_From_Uint (Expr_Value (Operand));
4072 Fold_Ureal (N, Result, Stat);
4075 -- Enumeration types
4078 Fold_Uint (N, Expr_Value (Operand), Stat);
4081 if Is_Out_Of_Range (N, Etype (N), Assume_Valid => True) then
4084 end Eval_Type_Conversion;
4090 -- Predefined unary operators are static functions (RM 4.9(20)) and thus
4091 -- are potentially static if the operand is potentially static (RM 4.9(7)).
4093 procedure Eval_Unary_Op (N : Node_Id) is
4094 Right : constant Node_Id := Right_Opnd (N);
4095 Otype : Entity_Id := Empty;
4100 -- If not foldable we are done
4102 Test_Expression_Is_Foldable (N, Right, Stat, Fold);
4108 if Etype (Right) = Universal_Integer
4110 Etype (Right) = Universal_Real
4112 Otype := Find_Universal_Operator_Type (N);
4115 -- Fold for integer case
4117 if Is_Integer_Type (Etype (N)) then
4119 Rint : constant Uint := Expr_Value (Right);
4123 -- In the case of modular unary plus and abs there is no need
4124 -- to adjust the result of the operation since if the original
4125 -- operand was in bounds the result will be in the bounds of the
4126 -- modular type. However, in the case of modular unary minus the
4127 -- result may go out of the bounds of the modular type and needs
4130 if Nkind (N) = N_Op_Plus then
4133 elsif Nkind (N) = N_Op_Minus then
4134 if Is_Modular_Integer_Type (Etype (N)) then
4135 Result := (-Rint) mod Modulus (Etype (N));
4141 pragma Assert (Nkind (N) = N_Op_Abs);
4145 Fold_Uint (N, Result, Stat);
4148 -- Fold for real case
4150 elsif Is_Real_Type (Etype (N)) then
4152 Rreal : constant Ureal := Expr_Value_R (Right);
4156 if Nkind (N) = N_Op_Plus then
4158 elsif Nkind (N) = N_Op_Minus then
4159 Result := UR_Negate (Rreal);
4161 pragma Assert (Nkind (N) = N_Op_Abs);
4162 Result := abs Rreal;
4165 Fold_Ureal (N, Result, Stat);
4169 -- If the operator was resolved to a specific type, make sure that type
4170 -- is frozen even if the expression is folded into a literal (which has
4171 -- a universal type).
4173 if Present (Otype) then
4174 Freeze_Before (N, Otype);
4178 -------------------------------
4179 -- Eval_Unchecked_Conversion --
4180 -------------------------------
4182 -- Unchecked conversions can never be static, so the only required
4183 -- processing is to check for a non-static context for the operand.
4185 procedure Eval_Unchecked_Conversion (N : Node_Id) is
4187 Check_Non_Static_Context (Expression (N));
4188 end Eval_Unchecked_Conversion;
4190 --------------------
4191 -- Expr_Rep_Value --
4192 --------------------
4194 function Expr_Rep_Value (N : Node_Id) return Uint is
4195 Kind : constant Node_Kind := Nkind (N);
4199 if Is_Entity_Name (N) then
4202 -- An enumeration literal that was either in the source or created
4203 -- as a result of static evaluation.
4205 if Ekind (Ent) = E_Enumeration_Literal then
4206 return Enumeration_Rep (Ent);
4208 -- A user defined static constant
4211 pragma Assert (Ekind (Ent) = E_Constant);
4212 return Expr_Rep_Value (Constant_Value (Ent));
4215 -- An integer literal that was either in the source or created as a
4216 -- result of static evaluation.
4218 elsif Kind = N_Integer_Literal then
4221 -- A real literal for a fixed-point type. This must be the fixed-point
4222 -- case, either the literal is of a fixed-point type, or it is a bound
4223 -- of a fixed-point type, with type universal real. In either case we
4224 -- obtain the desired value from Corresponding_Integer_Value.
4226 elsif Kind = N_Real_Literal then
4227 pragma Assert (Is_Fixed_Point_Type (Underlying_Type (Etype (N))));
4228 return Corresponding_Integer_Value (N);
4230 -- The NULL access value
4232 elsif Kind = N_Null then
4233 pragma Assert (Is_Access_Type (Underlying_Type (Etype (N)))
4234 or else Error_Posted (N));
4237 -- Character literal
4239 elsif Kind = N_Character_Literal then
4242 -- Since Character literals of type Standard.Character don't have any
4243 -- defining character literals built for them, they do not have their
4244 -- Entity set, so just use their Char code. Otherwise for user-
4245 -- defined character literals use their Pos value as usual which is
4246 -- the same as the Rep value.
4249 return Char_Literal_Value (N);
4251 return Enumeration_Rep (Ent);
4254 -- Unchecked conversion, which can come from System'To_Address (X)
4255 -- where X is a static integer expression. Recursively evaluate X.
4257 elsif Kind = N_Unchecked_Type_Conversion then
4258 return Expr_Rep_Value (Expression (N));
4261 raise Program_Error;
4269 function Expr_Value (N : Node_Id) return Uint is
4270 Kind : constant Node_Kind := Nkind (N);
4271 CV_Ent : CV_Entry renames CV_Cache (Nat (N) mod CV_Cache_Size);
4276 -- If already in cache, then we know it's compile-time-known and we can
4277 -- return the value that was previously stored in the cache since
4278 -- compile-time-known values cannot change.
4280 if CV_Ent.N = N then
4284 -- Otherwise proceed to test value
4286 if Is_Entity_Name (N) then
4289 -- An enumeration literal that was either in the source or created as
4290 -- a result of static evaluation.
4292 if Ekind (Ent) = E_Enumeration_Literal then
4293 Val := Enumeration_Pos (Ent);
4295 -- A user defined static constant
4298 pragma Assert (Ekind (Ent) = E_Constant);
4299 Val := Expr_Value (Constant_Value (Ent));
4302 -- An integer literal that was either in the source or created as a
4303 -- result of static evaluation.
4305 elsif Kind = N_Integer_Literal then
4308 -- A real literal for a fixed-point type. This must be the fixed-point
4309 -- case, either the literal is of a fixed-point type, or it is a bound
4310 -- of a fixed-point type, with type universal real. In either case we
4311 -- obtain the desired value from Corresponding_Integer_Value.
4313 elsif Kind = N_Real_Literal then
4314 pragma Assert (Is_Fixed_Point_Type (Underlying_Type (Etype (N))));
4315 Val := Corresponding_Integer_Value (N);
4317 -- The NULL access value
4319 elsif Kind = N_Null then
4320 pragma Assert (Is_Access_Type (Underlying_Type (Etype (N)))
4321 or else Error_Posted (N));
4324 -- Character literal
4326 elsif Kind = N_Character_Literal then
4329 -- Since Character literals of type Standard.Character don't
4330 -- have any defining character literals built for them, they
4331 -- do not have their Entity set, so just use their Char
4332 -- code. Otherwise for user-defined character literals use
4333 -- their Pos value as usual.
4336 Val := Char_Literal_Value (N);
4338 Val := Enumeration_Pos (Ent);
4341 -- Unchecked conversion, which can come from System'To_Address (X)
4342 -- where X is a static integer expression. Recursively evaluate X.
4344 elsif Kind = N_Unchecked_Type_Conversion then
4345 Val := Expr_Value (Expression (N));
4348 raise Program_Error;
4351 -- Come here with Val set to value to be returned, set cache
4362 function Expr_Value_E (N : Node_Id) return Entity_Id is
4363 Ent : constant Entity_Id := Entity (N);
4365 if Ekind (Ent) = E_Enumeration_Literal then
4368 pragma Assert (Ekind (Ent) = E_Constant);
4370 -- We may be dealing with a enumerated character type constant, so
4371 -- handle that case here.
4373 if Nkind (Constant_Value (Ent)) = N_Character_Literal then
4376 return Expr_Value_E (Constant_Value (Ent));
4385 function Expr_Value_R (N : Node_Id) return Ureal is
4386 Kind : constant Node_Kind := Nkind (N);
4390 if Kind = N_Real_Literal then
4393 elsif Kind = N_Identifier or else Kind = N_Expanded_Name then
4395 pragma Assert (Ekind (Ent) = E_Constant);
4396 return Expr_Value_R (Constant_Value (Ent));
4398 elsif Kind = N_Integer_Literal then
4399 return UR_From_Uint (Expr_Value (N));
4401 -- Here, we have a node that cannot be interpreted as a compile time
4402 -- constant. That is definitely an error.
4405 raise Program_Error;
4413 function Expr_Value_S (N : Node_Id) return Node_Id is
4415 if Nkind (N) = N_String_Literal then
4418 pragma Assert (Ekind (Entity (N)) = E_Constant);
4419 return Expr_Value_S (Constant_Value (Entity (N)));
4423 ----------------------------------
4424 -- Find_Universal_Operator_Type --
4425 ----------------------------------
4427 function Find_Universal_Operator_Type (N : Node_Id) return Entity_Id is
4428 PN : constant Node_Id := Parent (N);
4429 Call : constant Node_Id := Original_Node (N);
4430 Is_Int : constant Boolean := Is_Integer_Type (Etype (N));
4432 Is_Fix : constant Boolean :=
4433 Nkind (N) in N_Binary_Op
4434 and then Nkind (Right_Opnd (N)) /= Nkind (Left_Opnd (N));
4435 -- A mixed-mode operation in this context indicates the presence of
4436 -- fixed-point type in the designated package.
4438 Is_Relational : constant Boolean := Etype (N) = Standard_Boolean;
4439 -- Case where N is a relational (or membership) operator (else it is an
4442 In_Membership : constant Boolean :=
4443 Nkind (PN) in N_Membership_Test
4445 Nkind (Right_Opnd (PN)) = N_Range
4447 Is_Universal_Numeric_Type (Etype (Left_Opnd (PN)))
4449 Is_Universal_Numeric_Type
4450 (Etype (Low_Bound (Right_Opnd (PN))))
4452 Is_Universal_Numeric_Type
4453 (Etype (High_Bound (Right_Opnd (PN))));
4454 -- Case where N is part of a membership test with a universal range
4458 Typ1 : Entity_Id := Empty;
4461 function Is_Mixed_Mode_Operand (Op : Node_Id) return Boolean;
4462 -- Check whether one operand is a mixed-mode operation that requires the
4463 -- presence of a fixed-point type. Given that all operands are universal
4464 -- and have been constant-folded, retrieve the original function call.
4466 ---------------------------
4467 -- Is_Mixed_Mode_Operand --
4468 ---------------------------
4470 function Is_Mixed_Mode_Operand (Op : Node_Id) return Boolean is
4471 Onod : constant Node_Id := Original_Node (Op);
4473 return Nkind (Onod) = N_Function_Call
4474 and then Present (Next_Actual (First_Actual (Onod)))
4475 and then Etype (First_Actual (Onod)) /=
4476 Etype (Next_Actual (First_Actual (Onod)));
4477 end Is_Mixed_Mode_Operand;
4479 -- Start of processing for Find_Universal_Operator_Type
4482 if Nkind (Call) /= N_Function_Call
4483 or else Nkind (Name (Call)) /= N_Expanded_Name
4487 -- There are several cases where the context does not imply the type of
4489 -- - the universal expression appears in a type conversion;
4490 -- - the expression is a relational operator applied to universal
4492 -- - the expression is a membership test with a universal operand
4493 -- and a range with universal bounds.
4495 elsif Nkind (Parent (N)) = N_Type_Conversion
4496 or else Is_Relational
4497 or else In_Membership
4499 Pack := Entity (Prefix (Name (Call)));
4501 -- If the prefix is a package declared elsewhere, iterate over its
4502 -- visible entities, otherwise iterate over all declarations in the
4503 -- designated scope.
4505 if Ekind (Pack) = E_Package
4506 and then not In_Open_Scopes (Pack)
4508 Priv_E := First_Private_Entity (Pack);
4514 E := First_Entity (Pack);
4515 while Present (E) and then E /= Priv_E loop
4516 if Is_Numeric_Type (E)
4517 and then Nkind (Parent (E)) /= N_Subtype_Declaration
4518 and then Comes_From_Source (E)
4519 and then Is_Integer_Type (E) = Is_Int
4520 and then (Nkind (N) in N_Unary_Op
4521 or else Is_Relational
4522 or else Is_Fixed_Point_Type (E) = Is_Fix)
4527 -- Before emitting an error, check for the presence of a
4528 -- mixed-mode operation that specifies a fixed point type.
4532 (Is_Mixed_Mode_Operand (Left_Opnd (N))
4533 or else Is_Mixed_Mode_Operand (Right_Opnd (N)))
4534 and then Is_Fixed_Point_Type (E) /= Is_Fixed_Point_Type (Typ1)
4537 if Is_Fixed_Point_Type (E) then
4542 -- More than one type of the proper class declared in P
4544 Error_Msg_N ("ambiguous operation", N);
4545 Error_Msg_Sloc := Sloc (Typ1);
4546 Error_Msg_N ("\possible interpretation (inherited)#", N);
4547 Error_Msg_Sloc := Sloc (E);
4548 Error_Msg_N ("\possible interpretation (inherited)#", N);
4558 end Find_Universal_Operator_Type;
4560 --------------------------
4561 -- Flag_Non_Static_Expr --
4562 --------------------------
4564 procedure Flag_Non_Static_Expr (Msg : String; Expr : Node_Id) is
4566 if Error_Posted (Expr) and then not All_Errors_Mode then
4569 Error_Msg_F (Msg, Expr);
4570 Why_Not_Static (Expr);
4572 end Flag_Non_Static_Expr;
4578 procedure Fold_Str (N : Node_Id; Val : String_Id; Static : Boolean) is
4579 Loc : constant Source_Ptr := Sloc (N);
4580 Typ : constant Entity_Id := Etype (N);
4583 if Raises_Constraint_Error (N) then
4584 Set_Is_Static_Expression (N, Static);
4588 Rewrite (N, Make_String_Literal (Loc, Strval => Val));
4590 -- We now have the literal with the right value, both the actual type
4591 -- and the expected type of this literal are taken from the expression
4592 -- that was evaluated. So now we do the Analyze and Resolve.
4594 -- Note that we have to reset Is_Static_Expression both after the
4595 -- analyze step (because Resolve will evaluate the literal, which
4596 -- will cause semantic errors if it is marked as static), and after
4597 -- the Resolve step (since Resolve in some cases resets this flag).
4600 Set_Is_Static_Expression (N, Static);
4603 Set_Is_Static_Expression (N, Static);
4610 procedure Fold_Uint (N : Node_Id; Val : Uint; Static : Boolean) is
4611 Loc : constant Source_Ptr := Sloc (N);
4612 Typ : Entity_Id := Etype (N);
4616 if Raises_Constraint_Error (N) then
4617 Set_Is_Static_Expression (N, Static);
4621 -- If we are folding a named number, retain the entity in the literal,
4624 if Is_Entity_Name (N) and then Ekind (Entity (N)) = E_Named_Integer then
4630 if Is_Private_Type (Typ) then
4631 Typ := Full_View (Typ);
4634 -- For a result of type integer, substitute an N_Integer_Literal node
4635 -- for the result of the compile time evaluation of the expression.
4636 -- For ASIS use, set a link to the original named number when not in
4637 -- a generic context.
4639 if Is_Integer_Type (Typ) then
4640 Rewrite (N, Make_Integer_Literal (Loc, Val));
4641 Set_Original_Entity (N, Ent);
4643 -- Otherwise we have an enumeration type, and we substitute either
4644 -- an N_Identifier or N_Character_Literal to represent the enumeration
4645 -- literal corresponding to the given value, which must always be in
4646 -- range, because appropriate tests have already been made for this.
4648 else pragma Assert (Is_Enumeration_Type (Typ));
4649 Rewrite (N, Get_Enum_Lit_From_Pos (Etype (N), Val, Loc));
4652 -- We now have the literal with the right value, both the actual type
4653 -- and the expected type of this literal are taken from the expression
4654 -- that was evaluated. So now we do the Analyze and Resolve.
4656 -- Note that we have to reset Is_Static_Expression both after the
4657 -- analyze step (because Resolve will evaluate the literal, which
4658 -- will cause semantic errors if it is marked as static), and after
4659 -- the Resolve step (since Resolve in some cases sets this flag).
4662 Set_Is_Static_Expression (N, Static);
4665 Set_Is_Static_Expression (N, Static);
4672 procedure Fold_Ureal (N : Node_Id; Val : Ureal; Static : Boolean) is
4673 Loc : constant Source_Ptr := Sloc (N);
4674 Typ : constant Entity_Id := Etype (N);
4678 if Raises_Constraint_Error (N) then
4679 Set_Is_Static_Expression (N, Static);
4683 -- If we are folding a named number, retain the entity in the literal,
4686 if Is_Entity_Name (N) and then Ekind (Entity (N)) = E_Named_Real then
4692 Rewrite (N, Make_Real_Literal (Loc, Realval => Val));
4694 -- Set link to original named number, for ASIS use
4696 Set_Original_Entity (N, Ent);
4698 -- We now have the literal with the right value, both the actual type
4699 -- and the expected type of this literal are taken from the expression
4700 -- that was evaluated. So now we do the Analyze and Resolve.
4702 -- Note that we have to reset Is_Static_Expression both after the
4703 -- analyze step (because Resolve will evaluate the literal, which
4704 -- will cause semantic errors if it is marked as static), and after
4705 -- the Resolve step (since Resolve in some cases sets this flag).
4707 -- We mark the node as analyzed so that its type is not erased by
4708 -- calling Analyze_Real_Literal.
4711 Set_Is_Static_Expression (N, Static);
4715 Set_Is_Static_Expression (N, Static);
4722 function From_Bits (B : Bits; T : Entity_Id) return Uint is
4726 for J in 0 .. B'Last loop
4732 if Non_Binary_Modulus (T) then
4733 V := V mod Modulus (T);
4739 --------------------
4740 -- Get_String_Val --
4741 --------------------
4743 function Get_String_Val (N : Node_Id) return Node_Id is
4745 if Nkind_In (N, N_String_Literal, N_Character_Literal) then
4748 pragma Assert (Is_Entity_Name (N));
4749 return Get_String_Val (Constant_Value (Entity (N)));
4757 procedure Initialize is
4759 CV_Cache := (others => (Node_High_Bound, Uint_0));
4762 --------------------
4763 -- In_Subrange_Of --
4764 --------------------
4766 function In_Subrange_Of
4769 Fixed_Int : Boolean := False) return Boolean
4778 if T1 = T2 or else Is_Subtype_Of (T1, T2) then
4781 -- Never in range if both types are not scalar. Don't know if this can
4782 -- actually happen, but just in case.
4784 elsif not Is_Scalar_Type (T1) or else not Is_Scalar_Type (T2) then
4787 -- If T1 has infinities but T2 doesn't have infinities, then T1 is
4788 -- definitely not compatible with T2.
4790 elsif Is_Floating_Point_Type (T1)
4791 and then Has_Infinities (T1)
4792 and then Is_Floating_Point_Type (T2)
4793 and then not Has_Infinities (T2)
4798 L1 := Type_Low_Bound (T1);
4799 H1 := Type_High_Bound (T1);
4801 L2 := Type_Low_Bound (T2);
4802 H2 := Type_High_Bound (T2);
4804 -- Check bounds to see if comparison possible at compile time
4806 if Compile_Time_Compare (L1, L2, Assume_Valid => True) in Compare_GE
4808 Compile_Time_Compare (H1, H2, Assume_Valid => True) in Compare_LE
4813 -- If bounds not comparable at compile time, then the bounds of T2
4814 -- must be compile-time-known or we cannot answer the query.
4816 if not Compile_Time_Known_Value (L2)
4817 or else not Compile_Time_Known_Value (H2)
4822 -- If the bounds of T1 are know at compile time then use these
4823 -- ones, otherwise use the bounds of the base type (which are of
4824 -- course always static).
4826 if not Compile_Time_Known_Value (L1) then
4827 L1 := Type_Low_Bound (Base_Type (T1));
4830 if not Compile_Time_Known_Value (H1) then
4831 H1 := Type_High_Bound (Base_Type (T1));
4834 -- Fixed point types should be considered as such only if
4835 -- flag Fixed_Int is set to False.
4837 if Is_Floating_Point_Type (T1) or else Is_Floating_Point_Type (T2)
4838 or else (Is_Fixed_Point_Type (T1) and then not Fixed_Int)
4839 or else (Is_Fixed_Point_Type (T2) and then not Fixed_Int)
4842 Expr_Value_R (L2) <= Expr_Value_R (L1)
4844 Expr_Value_R (H2) >= Expr_Value_R (H1);
4848 Expr_Value (L2) <= Expr_Value (L1)
4850 Expr_Value (H2) >= Expr_Value (H1);
4855 -- If any exception occurs, it means that we have some bug in the compiler
4856 -- possibly triggered by a previous error, or by some unforeseen peculiar
4857 -- occurrence. However, this is only an optimization attempt, so there is
4858 -- really no point in crashing the compiler. Instead we just decide, too
4859 -- bad, we can't figure out the answer in this case after all.
4864 -- Debug flag K disables this behavior (useful for debugging)
4866 if Debug_Flag_K then
4877 function Is_In_Range
4880 Assume_Valid : Boolean := False;
4881 Fixed_Int : Boolean := False;
4882 Int_Real : Boolean := False) return Boolean
4886 Test_In_Range (N, Typ, Assume_Valid, Fixed_Int, Int_Real) = In_Range;
4893 function Is_Null_Range (Lo : Node_Id; Hi : Node_Id) return Boolean is
4895 if Compile_Time_Known_Value (Lo)
4896 and then Compile_Time_Known_Value (Hi)
4899 Typ : Entity_Id := Etype (Lo);
4901 -- When called from the frontend, as part of the analysis of
4902 -- potentially static expressions, Typ will be the full view of a
4903 -- type with all the info needed to answer this query. When called
4904 -- from the backend, for example to know whether a range of a loop
4905 -- is null, Typ might be a private type and we need to explicitly
4906 -- switch to its corresponding full view to access the same info.
4908 if Is_Incomplete_Or_Private_Type (Typ)
4909 and then Present (Full_View (Typ))
4911 Typ := Full_View (Typ);
4914 if Is_Discrete_Type (Typ) then
4915 return Expr_Value (Lo) > Expr_Value (Hi);
4916 else pragma Assert (Is_Real_Type (Typ));
4917 return Expr_Value_R (Lo) > Expr_Value_R (Hi);
4925 -------------------------
4926 -- Is_OK_Static_Choice --
4927 -------------------------
4929 function Is_OK_Static_Choice (Choice : Node_Id) return Boolean is
4931 -- Check various possibilities for choice
4933 -- Note: for membership tests, we test more cases than are possible
4934 -- (in particular subtype indication), but it doesn't matter because
4935 -- it just won't occur (we have already done a syntax check).
4937 if Nkind (Choice) = N_Others_Choice then
4940 elsif Nkind (Choice) = N_Range then
4941 return Is_OK_Static_Range (Choice);
4943 elsif Nkind (Choice) = N_Subtype_Indication
4944 or else (Is_Entity_Name (Choice) and then Is_Type (Entity (Choice)))
4946 return Is_OK_Static_Subtype (Etype (Choice));
4949 return Is_OK_Static_Expression (Choice);
4951 end Is_OK_Static_Choice;
4953 ------------------------------
4954 -- Is_OK_Static_Choice_List --
4955 ------------------------------
4957 function Is_OK_Static_Choice_List (Choices : List_Id) return Boolean is
4961 if not Is_Static_Choice_List (Choices) then
4965 Choice := First (Choices);
4966 while Present (Choice) loop
4967 if not Is_OK_Static_Choice (Choice) then
4968 Set_Raises_Constraint_Error (Choice);
4976 end Is_OK_Static_Choice_List;
4978 -----------------------------
4979 -- Is_OK_Static_Expression --
4980 -----------------------------
4982 function Is_OK_Static_Expression (N : Node_Id) return Boolean is
4984 return Is_Static_Expression (N) and then not Raises_Constraint_Error (N);
4985 end Is_OK_Static_Expression;
4987 ------------------------
4988 -- Is_OK_Static_Range --
4989 ------------------------
4991 -- A static range is a range whose bounds are static expressions, or a
4992 -- Range_Attribute_Reference equivalent to such a range (RM 4.9(26)).
4993 -- We have already converted range attribute references, so we get the
4994 -- "or" part of this rule without needing a special test.
4996 function Is_OK_Static_Range (N : Node_Id) return Boolean is
4998 return Is_OK_Static_Expression (Low_Bound (N))
4999 and then Is_OK_Static_Expression (High_Bound (N));
5000 end Is_OK_Static_Range;
5002 --------------------------
5003 -- Is_OK_Static_Subtype --
5004 --------------------------
5006 -- Determines if Typ is a static subtype as defined in (RM 4.9(26)) where
5007 -- neither bound raises Constraint_Error when evaluated.
5009 function Is_OK_Static_Subtype (Typ : Entity_Id) return Boolean is
5010 Base_T : constant Entity_Id := Base_Type (Typ);
5011 Anc_Subt : Entity_Id;
5014 -- First a quick check on the non static subtype flag. As described
5015 -- in further detail in Einfo, this flag is not decisive in all cases,
5016 -- but if it is set, then the subtype is definitely non-static.
5018 if Is_Non_Static_Subtype (Typ) then
5022 Anc_Subt := Ancestor_Subtype (Typ);
5024 if Anc_Subt = Empty then
5028 if Is_Generic_Type (Root_Type (Base_T))
5029 or else Is_Generic_Actual_Type (Base_T)
5033 elsif Has_Dynamic_Predicate_Aspect (Typ) then
5038 elsif Is_String_Type (Typ) then
5040 Ekind (Typ) = E_String_Literal_Subtype
5042 (Is_OK_Static_Subtype (Component_Type (Typ))
5043 and then Is_OK_Static_Subtype (Etype (First_Index (Typ))));
5047 elsif Is_Scalar_Type (Typ) then
5048 if Base_T = Typ then
5052 -- Scalar_Range (Typ) might be an N_Subtype_Indication, so use
5053 -- Get_Type_{Low,High}_Bound.
5055 return Is_OK_Static_Subtype (Anc_Subt)
5056 and then Is_OK_Static_Expression (Type_Low_Bound (Typ))
5057 and then Is_OK_Static_Expression (Type_High_Bound (Typ));
5060 -- Types other than string and scalar types are never static
5065 end Is_OK_Static_Subtype;
5067 ---------------------
5068 -- Is_Out_Of_Range --
5069 ---------------------
5071 function Is_Out_Of_Range
5074 Assume_Valid : Boolean := False;
5075 Fixed_Int : Boolean := False;
5076 Int_Real : Boolean := False) return Boolean
5079 return Test_In_Range (N, Typ, Assume_Valid, Fixed_Int, Int_Real) =
5081 end Is_Out_Of_Range;
5083 ----------------------
5084 -- Is_Static_Choice --
5085 ----------------------
5087 function Is_Static_Choice (Choice : Node_Id) return Boolean is
5089 -- Check various possibilities for choice
5091 -- Note: for membership tests, we test more cases than are possible
5092 -- (in particular subtype indication), but it doesn't matter because
5093 -- it just won't occur (we have already done a syntax check).
5095 if Nkind (Choice) = N_Others_Choice then
5098 elsif Nkind (Choice) = N_Range then
5099 return Is_Static_Range (Choice);
5101 elsif Nkind (Choice) = N_Subtype_Indication
5102 or else (Is_Entity_Name (Choice) and then Is_Type (Entity (Choice)))
5104 return Is_Static_Subtype (Etype (Choice));
5107 return Is_Static_Expression (Choice);
5109 end Is_Static_Choice;
5111 ---------------------------
5112 -- Is_Static_Choice_List --
5113 ---------------------------
5115 function Is_Static_Choice_List (Choices : List_Id) return Boolean is
5119 Choice := First (Choices);
5120 while Present (Choice) loop
5121 if not Is_Static_Choice (Choice) then
5129 end Is_Static_Choice_List;
5131 ---------------------
5132 -- Is_Static_Range --
5133 ---------------------
5135 -- A static range is a range whose bounds are static expressions, or a
5136 -- Range_Attribute_Reference equivalent to such a range (RM 4.9(26)).
5137 -- We have already converted range attribute references, so we get the
5138 -- "or" part of this rule without needing a special test.
5140 function Is_Static_Range (N : Node_Id) return Boolean is
5142 return Is_Static_Expression (Low_Bound (N))
5144 Is_Static_Expression (High_Bound (N));
5145 end Is_Static_Range;
5147 -----------------------
5148 -- Is_Static_Subtype --
5149 -----------------------
5151 -- Determines if Typ is a static subtype as defined in (RM 4.9(26))
5153 function Is_Static_Subtype (Typ : Entity_Id) return Boolean is
5154 Base_T : constant Entity_Id := Base_Type (Typ);
5155 Anc_Subt : Entity_Id;
5158 -- First a quick check on the non static subtype flag. As described
5159 -- in further detail in Einfo, this flag is not decisive in all cases,
5160 -- but if it is set, then the subtype is definitely non-static.
5162 if Is_Non_Static_Subtype (Typ) then
5166 Anc_Subt := Ancestor_Subtype (Typ);
5168 if Anc_Subt = Empty then
5172 if Is_Generic_Type (Root_Type (Base_T))
5173 or else Is_Generic_Actual_Type (Base_T)
5177 -- If there is a dynamic predicate for the type (declared or inherited)
5178 -- the expression is not static.
5180 elsif Has_Dynamic_Predicate_Aspect (Typ)
5181 or else (Is_Derived_Type (Typ)
5182 and then Has_Aspect (Typ, Aspect_Dynamic_Predicate))
5188 elsif Is_String_Type (Typ) then
5190 Ekind (Typ) = E_String_Literal_Subtype
5191 or else (Is_Static_Subtype (Component_Type (Typ))
5192 and then Is_Static_Subtype (Etype (First_Index (Typ))));
5196 elsif Is_Scalar_Type (Typ) then
5197 if Base_T = Typ then
5201 return Is_Static_Subtype (Anc_Subt)
5202 and then Is_Static_Expression (Type_Low_Bound (Typ))
5203 and then Is_Static_Expression (Type_High_Bound (Typ));
5206 -- Types other than string and scalar types are never static
5211 end Is_Static_Subtype;
5213 -------------------------------
5214 -- Is_Statically_Unevaluated --
5215 -------------------------------
5217 function Is_Statically_Unevaluated (Expr : Node_Id) return Boolean is
5218 function Check_Case_Expr_Alternative
5219 (CEA : Node_Id) return Match_Result;
5220 -- We have a message emanating from the Expression of a case expression
5221 -- alternative. We examine this alternative, as follows:
5223 -- If the selecting expression of the parent case is non-static, or
5224 -- if any of the discrete choices of the given case alternative are
5225 -- non-static or raise Constraint_Error, return Non_Static.
5227 -- Otherwise check if the selecting expression matches any of the given
5228 -- discrete choices. If so, the alternative is executed and we return
5229 -- Match, otherwise, the alternative can never be executed, and so we
5232 ---------------------------------
5233 -- Check_Case_Expr_Alternative --
5234 ---------------------------------
5236 function Check_Case_Expr_Alternative
5237 (CEA : Node_Id) return Match_Result
5239 Case_Exp : constant Node_Id := Parent (CEA);
5244 pragma Assert (Nkind (Case_Exp) = N_Case_Expression);
5246 -- Check that selecting expression is static
5248 if not Is_OK_Static_Expression (Expression (Case_Exp)) then
5252 if not Is_OK_Static_Choice_List (Discrete_Choices (CEA)) then
5256 -- All choices are now known to be static. Now see if alternative
5257 -- matches one of the choices.
5259 Choice := First (Discrete_Choices (CEA));
5260 while Present (Choice) loop
5262 -- Check various possibilities for choice, returning Match if we
5263 -- find the selecting value matches any of the choices. Note that
5264 -- we know we are the last choice, so we don't have to keep going.
5266 if Nkind (Choice) = N_Others_Choice then
5268 -- Others choice is a bit annoying, it matches if none of the
5269 -- previous alternatives matches (note that we know we are the
5270 -- last alternative in this case, so we can just go backwards
5271 -- from us to see if any previous one matches).
5273 Prev_CEA := Prev (CEA);
5274 while Present (Prev_CEA) loop
5275 if Check_Case_Expr_Alternative (Prev_CEA) = Match then
5284 -- Else we have a normal static choice
5286 elsif Choice_Matches (Expression (Case_Exp), Choice) = Match then
5290 -- If we fall through, it means that the discrete choice did not
5291 -- match the selecting expression, so continue.
5296 -- If we get through that loop then all choices were static, and none
5297 -- of them matched the selecting expression. So return No_Match.
5300 end Check_Case_Expr_Alternative;
5308 -- Start of processing for Is_Statically_Unevaluated
5311 -- The (32.x) references here are from RM section 4.9
5313 -- (32.1) An expression is statically unevaluated if it is part of ...
5315 -- This means we have to climb the tree looking for one of the cases
5322 -- (32.2) The right operand of a static short-circuit control form
5323 -- whose value is determined by its left operand.
5325 -- AND THEN with False as left operand
5327 if Nkind (P) = N_And_Then
5328 and then Compile_Time_Known_Value (Left_Opnd (P))
5329 and then Is_False (Expr_Value (Left_Opnd (P)))
5333 -- OR ELSE with True as left operand
5335 elsif Nkind (P) = N_Or_Else
5336 and then Compile_Time_Known_Value (Left_Opnd (P))
5337 and then Is_True (Expr_Value (Left_Opnd (P)))
5341 -- (32.3) A dependent_expression of an if_expression whose associated
5342 -- condition is static and equals False.
5344 elsif Nkind (P) = N_If_Expression then
5346 Cond : constant Node_Id := First (Expressions (P));
5347 Texp : constant Node_Id := Next (Cond);
5348 Fexp : constant Node_Id := Next (Texp);
5351 if Compile_Time_Known_Value (Cond) then
5353 -- Condition is True and we are in the right operand
5355 if Is_True (Expr_Value (Cond)) and then OldP = Fexp then
5358 -- Condition is False and we are in the left operand
5360 elsif Is_False (Expr_Value (Cond)) and then OldP = Texp then
5366 -- (32.4) A condition or dependent_expression of an if_expression
5367 -- where the condition corresponding to at least one preceding
5368 -- dependent_expression of the if_expression is static and equals
5371 -- This refers to cases like
5373 -- (if True then 1 elsif 1/0=2 then 2 else 3)
5375 -- But we expand elsif's out anyway, so the above looks like:
5377 -- (if True then 1 else (if 1/0=2 then 2 else 3))
5379 -- So for us this is caught by the above check for the 32.3 case.
5381 -- (32.5) A dependent_expression of a case_expression whose
5382 -- selecting_expression is static and whose value is not covered
5383 -- by the corresponding discrete_choice_list.
5385 elsif Nkind (P) = N_Case_Expression_Alternative then
5387 -- First, we have to be in the expression to suppress messages.
5388 -- If we are within one of the choices, we want the message.
5390 if OldP = Expression (P) then
5392 -- Statically unevaluated if alternative does not match
5394 if Check_Case_Expr_Alternative (P) = No_Match then
5399 -- (32.6) A choice_expression (or a simple_expression of a range
5400 -- that occurs as a membership_choice of a membership_choice_list)
5401 -- of a static membership test that is preceded in the enclosing
5402 -- membership_choice_list by another item whose individual
5403 -- membership test (see (RM 4.5.2)) statically yields True.
5405 elsif Nkind (P) in N_Membership_Test then
5407 -- Only possibly unevaluated if simple expression is static
5409 if not Is_OK_Static_Expression (Left_Opnd (P)) then
5412 -- All members of the choice list must be static
5414 elsif (Present (Right_Opnd (P))
5415 and then not Is_OK_Static_Choice (Right_Opnd (P)))
5416 or else (Present (Alternatives (P))
5418 not Is_OK_Static_Choice_List (Alternatives (P)))
5422 -- If expression is the one and only alternative, then it is
5423 -- definitely not statically unevaluated, so we only have to
5424 -- test the case where there are alternatives present.
5426 elsif Present (Alternatives (P)) then
5428 -- Look for previous matching Choice
5430 Choice := First (Alternatives (P));
5431 while Present (Choice) loop
5433 -- If we reached us and no previous choices matched, this
5434 -- is not the case where we are statically unevaluated.
5436 exit when OldP = Choice;
5438 -- If a previous choice matches, then that is the case where
5439 -- we know our choice is statically unevaluated.
5441 if Choice_Matches (Left_Opnd (P), Choice) = Match then
5448 -- If we fall through the loop, we were not one of the choices,
5449 -- we must have been the expression, so that is not covered by
5450 -- this rule, and we keep going.
5456 -- OK, not statically unevaluated at this level, see if we should
5457 -- keep climbing to look for a higher level reason.
5459 -- Special case for component association in aggregates, where
5460 -- we want to keep climbing up to the parent aggregate.
5462 if Nkind (P) = N_Component_Association
5463 and then Nkind (Parent (P)) = N_Aggregate
5467 -- All done if not still within subexpression
5470 exit when Nkind (P) not in N_Subexpr;
5474 -- If we fall through the loop, not one of the cases covered!
5477 end Is_Statically_Unevaluated;
5479 --------------------
5480 -- Not_Null_Range --
5481 --------------------
5483 function Not_Null_Range (Lo : Node_Id; Hi : Node_Id) return Boolean is
5485 if Compile_Time_Known_Value (Lo)
5486 and then Compile_Time_Known_Value (Hi)
5489 Typ : Entity_Id := Etype (Lo);
5491 -- When called from the frontend, as part of the analysis of
5492 -- potentially static expressions, Typ will be the full view of a
5493 -- type with all the info needed to answer this query. When called
5494 -- from the backend, for example to know whether a range of a loop
5495 -- is null, Typ might be a private type and we need to explicitly
5496 -- switch to its corresponding full view to access the same info.
5498 if Is_Incomplete_Or_Private_Type (Typ)
5499 and then Present (Full_View (Typ))
5501 Typ := Full_View (Typ);
5504 if Is_Discrete_Type (Typ) then
5505 return Expr_Value (Lo) <= Expr_Value (Hi);
5506 else pragma Assert (Is_Real_Type (Typ));
5507 return Expr_Value_R (Lo) <= Expr_Value_R (Hi);
5520 function OK_Bits (N : Node_Id; Bits : Uint) return Boolean is
5522 -- We allow a maximum of 500,000 bits which seems a reasonable limit
5524 if Bits < 500_000 then
5527 -- Error if this maximum is exceeded
5530 Error_Msg_N ("static value too large, capacity exceeded", N);
5539 procedure Out_Of_Range (N : Node_Id) is
5541 -- If we have the static expression case, then this is an illegality
5542 -- in Ada 95 mode, except that in an instance, we never generate an
5543 -- error (if the error is legitimate, it was already diagnosed in the
5546 if Is_Static_Expression (N)
5547 and then not In_Instance
5548 and then not In_Inlined_Body
5549 and then Ada_Version >= Ada_95
5551 -- No message if we are statically unevaluated
5553 if Is_Statically_Unevaluated (N) then
5556 -- The expression to compute the length of a packed array is attached
5557 -- to the array type itself, and deserves a separate message.
5559 elsif Nkind (Parent (N)) = N_Defining_Identifier
5560 and then Is_Array_Type (Parent (N))
5561 and then Present (Packed_Array_Impl_Type (Parent (N)))
5562 and then Present (First_Rep_Item (Parent (N)))
5565 ("length of packed array must not exceed Integer''Last",
5566 First_Rep_Item (Parent (N)));
5567 Rewrite (N, Make_Integer_Literal (Sloc (N), Uint_1));
5569 -- All cases except the special array case.
5570 -- No message if we are dealing with System.Priority values in
5571 -- CodePeer mode where the target runtime may have more priorities.
5573 elsif not CodePeer_Mode or else Etype (N) /= RTE (RE_Priority) then
5574 -- Determine if the out-of-range violation constitutes a warning
5575 -- or an error based on context, according to RM 4.9 (34/3).
5577 if Nkind (Original_Node (N)) = N_Type_Conversion
5578 and then not Comes_From_Source (Original_Node (N))
5580 Apply_Compile_Time_Constraint_Error
5581 (N, "value not in range of}??", CE_Range_Check_Failed);
5583 Apply_Compile_Time_Constraint_Error
5584 (N, "value not in range of}", CE_Range_Check_Failed);
5588 -- Here we generate a warning for the Ada 83 case, or when we are in an
5589 -- instance, or when we have a non-static expression case.
5592 Apply_Compile_Time_Constraint_Error
5593 (N, "value not in range of}??", CE_Range_Check_Failed);
5597 ----------------------
5598 -- Predicates_Match --
5599 ----------------------
5601 function Predicates_Match (T1, T2 : Entity_Id) return Boolean is
5606 if Ada_Version < Ada_2012 then
5609 -- Both types must have predicates or lack them
5611 elsif Has_Predicates (T1) /= Has_Predicates (T2) then
5614 -- Check matching predicates
5619 (T1, Name_Static_Predicate, Check_Parents => False);
5622 (T2, Name_Static_Predicate, Check_Parents => False);
5624 -- Subtypes statically match if the predicate comes from the
5625 -- same declaration, which can only happen if one is a subtype
5626 -- of the other and has no explicit predicate.
5628 -- Suppress warnings on order of actuals, which is otherwise
5629 -- triggered by one of the two calls below.
5631 pragma Warnings (Off);
5632 return Pred1 = Pred2
5633 or else (No (Pred1) and then Is_Subtype_Of (T1, T2))
5634 or else (No (Pred2) and then Is_Subtype_Of (T2, T1));
5635 pragma Warnings (On);
5637 end Predicates_Match;
5639 ---------------------------------------------
5640 -- Real_Or_String_Static_Predicate_Matches --
5641 ---------------------------------------------
5643 function Real_Or_String_Static_Predicate_Matches
5645 Typ : Entity_Id) return Boolean
5647 Expr : constant Node_Id := Static_Real_Or_String_Predicate (Typ);
5648 -- The predicate expression from the type
5650 Pfun : constant Entity_Id := Predicate_Function (Typ);
5651 -- The entity for the predicate function
5653 Ent_Name : constant Name_Id := Chars (First_Formal (Pfun));
5654 -- The name of the formal of the predicate function. Occurrences of the
5655 -- type name in Expr have been rewritten as references to this formal,
5656 -- and it has a unique name, so we can identify references by this name.
5659 -- Copy of the predicate function tree
5661 function Process (N : Node_Id) return Traverse_Result;
5662 -- Function used to process nodes during the traversal in which we will
5663 -- find occurrences of the entity name, and replace such occurrences
5664 -- by a real literal with the value to be tested.
5666 procedure Traverse is new Traverse_Proc (Process);
5667 -- The actual traversal procedure
5673 function Process (N : Node_Id) return Traverse_Result is
5675 if Nkind (N) = N_Identifier and then Chars (N) = Ent_Name then
5677 Nod : constant Node_Id := New_Copy (Val);
5679 Set_Sloc (Nod, Sloc (N));
5684 -- The predicate function may contain string-comparison operations
5685 -- that have been converted into calls to run-time array-comparison
5686 -- routines. To evaluate the predicate statically, we recover the
5687 -- original comparison operation and replace the occurrence of the
5688 -- formal by the static string value. The actuals of the generated
5689 -- call are of the form X'Address.
5691 elsif Nkind (N) in N_Op_Compare
5692 and then Nkind (Left_Opnd (N)) = N_Function_Call
5695 C : constant Node_Id := Left_Opnd (N);
5696 F : constant Node_Id := First (Parameter_Associations (C));
5697 L : constant Node_Id := Prefix (F);
5698 R : constant Node_Id := Prefix (Next (F));
5701 -- If an operand is an entity name, it is the formal of the
5702 -- predicate function, so replace it with the string value.
5703 -- It may be either operand in the call. The other operand
5704 -- is a static string from the original predicate.
5706 if Is_Entity_Name (L) then
5707 Rewrite (Left_Opnd (N), New_Copy (Val));
5708 Rewrite (Right_Opnd (N), New_Copy (R));
5711 Rewrite (Left_Opnd (N), New_Copy (L));
5712 Rewrite (Right_Opnd (N), New_Copy (Val));
5723 -- Start of processing for Real_Or_String_Static_Predicate_Matches
5726 -- First deal with special case of inherited predicate, where the
5727 -- predicate expression looks like:
5729 -- xxPredicate (typ (Ent)) and then Expr
5731 -- where Expr is the predicate expression for this level, and the
5732 -- left operand is the call to evaluate the inherited predicate.
5734 if Nkind (Expr) = N_And_Then
5735 and then Nkind (Left_Opnd (Expr)) = N_Function_Call
5736 and then Is_Predicate_Function (Entity (Name (Left_Opnd (Expr))))
5738 -- OK we have the inherited case, so make a call to evaluate the
5739 -- inherited predicate. If that fails, so do we!
5742 Real_Or_String_Static_Predicate_Matches
5744 Typ => Etype (First_Formal (Entity (Name (Left_Opnd (Expr))))))
5749 -- Use the right operand for the continued processing
5751 Copy := Copy_Separate_Tree (Right_Opnd (Expr));
5753 -- Case where call to predicate function appears on its own (this means
5754 -- that the predicate at this level is just inherited from the parent).
5756 elsif Nkind (Expr) = N_Function_Call then
5758 Typ : constant Entity_Id :=
5759 Etype (First_Formal (Entity (Name (Expr))));
5762 -- If the inherited predicate is dynamic, just ignore it. We can't
5763 -- go trying to evaluate a dynamic predicate as a static one!
5765 if Has_Dynamic_Predicate_Aspect (Typ) then
5768 -- Otherwise inherited predicate is static, check for match
5771 return Real_Or_String_Static_Predicate_Matches (Val, Typ);
5775 -- If not just an inherited predicate, copy whole expression
5778 Copy := Copy_Separate_Tree (Expr);
5781 -- Now we replace occurrences of the entity by the value
5785 -- And analyze the resulting static expression to see if it is True
5787 Analyze_And_Resolve (Copy, Standard_Boolean);
5788 return Is_True (Expr_Value (Copy));
5789 end Real_Or_String_Static_Predicate_Matches;
5791 -------------------------
5792 -- Rewrite_In_Raise_CE --
5793 -------------------------
5795 procedure Rewrite_In_Raise_CE (N : Node_Id; Exp : Node_Id) is
5796 Stat : constant Boolean := Is_Static_Expression (N);
5797 Typ : constant Entity_Id := Etype (N);
5800 -- If we want to raise CE in the condition of a N_Raise_CE node, we
5801 -- can just clear the condition if the reason is appropriate. We do
5802 -- not do this operation if the parent has a reason other than range
5803 -- check failed, because otherwise we would change the reason.
5805 if Present (Parent (N))
5806 and then Nkind (Parent (N)) = N_Raise_Constraint_Error
5807 and then Reason (Parent (N)) =
5808 UI_From_Int (RT_Exception_Code'Pos (CE_Range_Check_Failed))
5810 Set_Condition (Parent (N), Empty);
5812 -- Else build an explicit N_Raise_CE
5815 if Nkind (Exp) = N_Raise_Constraint_Error then
5817 Make_Raise_Constraint_Error (Sloc (Exp),
5818 Reason => Reason (Exp)));
5821 Make_Raise_Constraint_Error (Sloc (Exp),
5822 Reason => CE_Range_Check_Failed));
5825 Set_Raises_Constraint_Error (N);
5829 -- Set proper flags in result
5831 Set_Raises_Constraint_Error (N, True);
5832 Set_Is_Static_Expression (N, Stat);
5833 end Rewrite_In_Raise_CE;
5835 ---------------------
5836 -- String_Type_Len --
5837 ---------------------
5839 function String_Type_Len (Stype : Entity_Id) return Uint is
5840 NT : constant Entity_Id := Etype (First_Index (Stype));
5844 if Is_OK_Static_Subtype (NT) then
5847 T := Base_Type (NT);
5850 return Expr_Value (Type_High_Bound (T)) -
5851 Expr_Value (Type_Low_Bound (T)) + 1;
5852 end String_Type_Len;
5854 ------------------------------------
5855 -- Subtypes_Statically_Compatible --
5856 ------------------------------------
5858 function Subtypes_Statically_Compatible
5861 Formal_Derived_Matching : Boolean := False) return Boolean
5866 if Is_Scalar_Type (T1) then
5868 -- Definitely compatible if we match
5870 if Subtypes_Statically_Match (T1, T2) then
5873 -- If either subtype is nonstatic then they're not compatible
5875 elsif not Is_OK_Static_Subtype (T1)
5877 not Is_OK_Static_Subtype (T2)
5881 -- Base types must match, but we don't check that (should we???) but
5882 -- we do at least check that both types are real, or both types are
5885 elsif Is_Real_Type (T1) /= Is_Real_Type (T2) then
5888 -- Here we check the bounds
5892 LB1 : constant Node_Id := Type_Low_Bound (T1);
5893 HB1 : constant Node_Id := Type_High_Bound (T1);
5894 LB2 : constant Node_Id := Type_Low_Bound (T2);
5895 HB2 : constant Node_Id := Type_High_Bound (T2);
5898 if Is_Real_Type (T1) then
5900 Expr_Value_R (LB1) > Expr_Value_R (HB1)
5902 (Expr_Value_R (LB2) <= Expr_Value_R (LB1)
5903 and then Expr_Value_R (HB1) <= Expr_Value_R (HB2));
5907 Expr_Value (LB1) > Expr_Value (HB1)
5909 (Expr_Value (LB2) <= Expr_Value (LB1)
5910 and then Expr_Value (HB1) <= Expr_Value (HB2));
5917 elsif Is_Access_Type (T1) then
5919 (not Is_Constrained (T2)
5920 or else Subtypes_Statically_Match
5921 (Designated_Type (T1), Designated_Type (T2)))
5922 and then not (Can_Never_Be_Null (T2)
5923 and then not Can_Never_Be_Null (T1));
5929 (Is_Composite_Type (T1) and then not Is_Constrained (T2))
5930 or else Subtypes_Statically_Match
5931 (T1, T2, Formal_Derived_Matching);
5933 end Subtypes_Statically_Compatible;
5935 -------------------------------
5936 -- Subtypes_Statically_Match --
5937 -------------------------------
5939 -- Subtypes statically match if they have statically matching constraints
5940 -- (RM 4.9.1(2)). Constraints statically match if there are none, or if
5941 -- they are the same identical constraint, or if they are static and the
5942 -- values match (RM 4.9.1(1)).
5944 -- In addition, in GNAT, the object size (Esize) values of the types must
5945 -- match if they are set (unless checking an actual for a formal derived
5946 -- type). The use of 'Object_Size can cause this to be false even if the
5947 -- types would otherwise match in the Ada 95 RM sense, but this deviation
5948 -- is adopted by AI12-059 which introduces Object_Size in Ada 2020.
5950 function Subtypes_Statically_Match
5953 Formal_Derived_Matching : Boolean := False) return Boolean
5956 -- A type always statically matches itself
5961 -- No match if sizes different (from use of 'Object_Size). This test
5962 -- is excluded if Formal_Derived_Matching is True, as the base types
5963 -- can be different in that case and typically have different sizes.
5965 elsif not Formal_Derived_Matching
5966 and then Known_Static_Esize (T1)
5967 and then Known_Static_Esize (T2)
5968 and then Esize (T1) /= Esize (T2)
5972 -- No match if predicates do not match
5974 elsif not Predicates_Match (T1, T2) then
5979 elsif Is_Scalar_Type (T1) then
5981 -- Base types must be the same
5983 if Base_Type (T1) /= Base_Type (T2) then
5987 -- A constrained numeric subtype never matches an unconstrained
5988 -- subtype, i.e. both types must be constrained or unconstrained.
5990 -- To understand the requirement for this test, see RM 4.9.1(1).
5991 -- As is made clear in RM 3.5.4(11), type Integer, for example is
5992 -- a constrained subtype with constraint bounds matching the bounds
5993 -- of its corresponding unconstrained base type. In this situation,
5994 -- Integer and Integer'Base do not statically match, even though
5995 -- they have the same bounds.
5997 -- We only apply this test to types in Standard and types that appear
5998 -- in user programs. That way, we do not have to be too careful about
5999 -- setting Is_Constrained right for Itypes.
6001 if Is_Numeric_Type (T1)
6002 and then (Is_Constrained (T1) /= Is_Constrained (T2))
6003 and then (Scope (T1) = Standard_Standard
6004 or else Comes_From_Source (T1))
6005 and then (Scope (T2) = Standard_Standard
6006 or else Comes_From_Source (T2))
6010 -- A generic scalar type does not statically match its base type
6011 -- (AI-311). In this case we make sure that the formals, which are
6012 -- first subtypes of their bases, are constrained.
6014 elsif Is_Generic_Type (T1)
6015 and then Is_Generic_Type (T2)
6016 and then (Is_Constrained (T1) /= Is_Constrained (T2))
6021 -- If there was an error in either range, then just assume the types
6022 -- statically match to avoid further junk errors.
6024 if No (Scalar_Range (T1)) or else No (Scalar_Range (T2))
6025 or else Error_Posted (Scalar_Range (T1))
6026 or else Error_Posted (Scalar_Range (T2))
6031 -- Otherwise both types have bounds that can be compared
6034 LB1 : constant Node_Id := Type_Low_Bound (T1);
6035 HB1 : constant Node_Id := Type_High_Bound (T1);
6036 LB2 : constant Node_Id := Type_Low_Bound (T2);
6037 HB2 : constant Node_Id := Type_High_Bound (T2);
6040 -- If the bounds are the same tree node, then match (common case)
6042 if LB1 = LB2 and then HB1 = HB2 then
6045 -- Otherwise bounds must be static and identical value
6048 if not Is_OK_Static_Subtype (T1)
6050 not Is_OK_Static_Subtype (T2)
6054 elsif Is_Real_Type (T1) then
6056 Expr_Value_R (LB1) = Expr_Value_R (LB2)
6058 Expr_Value_R (HB1) = Expr_Value_R (HB2);
6062 Expr_Value (LB1) = Expr_Value (LB2)
6064 Expr_Value (HB1) = Expr_Value (HB2);
6069 -- Type with discriminants
6071 elsif Has_Discriminants (T1) or else Has_Discriminants (T2) then
6073 -- Because of view exchanges in multiple instantiations, conformance
6074 -- checking might try to match a partial view of a type with no
6075 -- discriminants with a full view that has defaulted discriminants.
6076 -- In such a case, use the discriminant constraint of the full view,
6077 -- which must exist because we know that the two subtypes have the
6080 if Has_Discriminants (T1) /= Has_Discriminants (T2) then
6082 if Is_Private_Type (T2)
6083 and then Present (Full_View (T2))
6084 and then Has_Discriminants (Full_View (T2))
6086 return Subtypes_Statically_Match (T1, Full_View (T2));
6088 elsif Is_Private_Type (T1)
6089 and then Present (Full_View (T1))
6090 and then Has_Discriminants (Full_View (T1))
6092 return Subtypes_Statically_Match (Full_View (T1), T2);
6103 DL1 : constant Elist_Id := Discriminant_Constraint (T1);
6104 DL2 : constant Elist_Id := Discriminant_Constraint (T2);
6112 elsif Is_Constrained (T1) /= Is_Constrained (T2) then
6116 -- Now loop through the discriminant constraints
6118 -- Note: the guard here seems necessary, since it is possible at
6119 -- least for DL1 to be No_Elist. Not clear this is reasonable ???
6121 if Present (DL1) and then Present (DL2) then
6122 DA1 := First_Elmt (DL1);
6123 DA2 := First_Elmt (DL2);
6124 while Present (DA1) loop
6126 Expr1 : constant Node_Id := Node (DA1);
6127 Expr2 : constant Node_Id := Node (DA2);
6130 if not Is_OK_Static_Expression (Expr1)
6131 or else not Is_OK_Static_Expression (Expr2)
6135 -- If either expression raised a Constraint_Error,
6136 -- consider the expressions as matching, since this
6137 -- helps to prevent cascading errors.
6139 elsif Raises_Constraint_Error (Expr1)
6140 or else Raises_Constraint_Error (Expr2)
6144 elsif Expr_Value (Expr1) /= Expr_Value (Expr2) then
6157 -- A definite type does not match an indefinite or classwide type.
6158 -- However, a generic type with unknown discriminants may be
6159 -- instantiated with a type with no discriminants, and conformance
6160 -- checking on an inherited operation may compare the actual with the
6161 -- subtype that renames it in the instance.
6163 elsif Has_Unknown_Discriminants (T1) /= Has_Unknown_Discriminants (T2)
6166 Is_Generic_Actual_Type (T1) or else Is_Generic_Actual_Type (T2);
6170 elsif Is_Array_Type (T1) then
6172 -- If either subtype is unconstrained then both must be, and if both
6173 -- are unconstrained then no further checking is needed.
6175 if not Is_Constrained (T1) or else not Is_Constrained (T2) then
6176 return not (Is_Constrained (T1) or else Is_Constrained (T2));
6179 -- Both subtypes are constrained, so check that the index subtypes
6180 -- statically match.
6183 Index1 : Node_Id := First_Index (T1);
6184 Index2 : Node_Id := First_Index (T2);
6187 while Present (Index1) loop
6189 Subtypes_Statically_Match (Etype (Index1), Etype (Index2))
6194 Next_Index (Index1);
6195 Next_Index (Index2);
6201 elsif Is_Access_Type (T1) then
6202 if Can_Never_Be_Null (T1) /= Can_Never_Be_Null (T2) then
6205 elsif Ekind_In (T1, E_Access_Subprogram_Type,
6206 E_Anonymous_Access_Subprogram_Type)
6210 (Designated_Type (T1),
6211 Designated_Type (T2));
6214 Subtypes_Statically_Match
6215 (Designated_Type (T1),
6216 Designated_Type (T2))
6217 and then Is_Access_Constant (T1) = Is_Access_Constant (T2);
6220 -- All other types definitely match
6225 end Subtypes_Statically_Match;
6231 function Test (Cond : Boolean) return Uint is
6240 ---------------------
6241 -- Test_Comparison --
6242 ---------------------
6244 procedure Test_Comparison
6246 Assume_Valid : Boolean;
6247 True_Result : out Boolean;
6248 False_Result : out Boolean)
6250 Left : constant Node_Id := Left_Opnd (Op);
6251 Left_Typ : constant Entity_Id := Etype (Left);
6252 Orig_Op : constant Node_Id := Original_Node (Op);
6254 procedure Replacement_Warning (Msg : String);
6255 -- Emit a warning on a comparison that can be replaced by '='
6257 -------------------------
6258 -- Replacement_Warning --
6259 -------------------------
6261 procedure Replacement_Warning (Msg : String) is
6263 if Constant_Condition_Warnings
6264 and then Comes_From_Source (Orig_Op)
6265 and then Is_Integer_Type (Left_Typ)
6266 and then not Error_Posted (Op)
6267 and then not Has_Warnings_Off (Left_Typ)
6268 and then not In_Instance
6270 Error_Msg_N (Msg, Op);
6272 end Replacement_Warning;
6276 Res : constant Compare_Result :=
6277 Compile_Time_Compare (Left, Right_Opnd (Op), Assume_Valid);
6279 -- Start of processing for Test_Comparison
6282 case N_Op_Compare (Nkind (Op)) is
6284 True_Result := Res = EQ;
6285 False_Result := Res = LT or else Res = GT or else Res = NE;
6288 True_Result := Res in Compare_GE;
6289 False_Result := Res = LT;
6291 if Res = LE and then Nkind (Orig_Op) = N_Op_Ge then
6293 ("can never be greater than, could replace by ""'=""?c?");
6297 True_Result := Res = GT;
6298 False_Result := Res in Compare_LE;
6301 True_Result := Res in Compare_LE;
6302 False_Result := Res = GT;
6304 if Res = GE and then Nkind (Orig_Op) = N_Op_Le then
6306 ("can never be less than, could replace by ""'=""?c?");
6310 True_Result := Res = LT;
6311 False_Result := Res in Compare_GE;
6314 True_Result := Res = NE or else Res = GT or else Res = LT;
6315 False_Result := Res = EQ;
6317 end Test_Comparison;
6319 ---------------------------------
6320 -- Test_Expression_Is_Foldable --
6321 ---------------------------------
6325 procedure Test_Expression_Is_Foldable
6335 if Debug_Flag_Dot_F and then In_Extended_Main_Source_Unit (N) then
6339 -- If operand is Any_Type, just propagate to result and do not
6340 -- try to fold, this prevents cascaded errors.
6342 if Etype (Op1) = Any_Type then
6343 Set_Etype (N, Any_Type);
6346 -- If operand raises Constraint_Error, then replace node N with the
6347 -- raise Constraint_Error node, and we are obviously not foldable.
6348 -- Note that this replacement inherits the Is_Static_Expression flag
6349 -- from the operand.
6351 elsif Raises_Constraint_Error (Op1) then
6352 Rewrite_In_Raise_CE (N, Op1);
6355 -- If the operand is not static, then the result is not static, and
6356 -- all we have to do is to check the operand since it is now known
6357 -- to appear in a non-static context.
6359 elsif not Is_Static_Expression (Op1) then
6360 Check_Non_Static_Context (Op1);
6361 Fold := Compile_Time_Known_Value (Op1);
6364 -- An expression of a formal modular type is not foldable because
6365 -- the modulus is unknown.
6367 elsif Is_Modular_Integer_Type (Etype (Op1))
6368 and then Is_Generic_Type (Etype (Op1))
6370 Check_Non_Static_Context (Op1);
6373 -- Here we have the case of an operand whose type is OK, which is
6374 -- static, and which does not raise Constraint_Error, we can fold.
6377 Set_Is_Static_Expression (N);
6381 end Test_Expression_Is_Foldable;
6385 procedure Test_Expression_Is_Foldable
6391 CRT_Safe : Boolean := False)
6393 Rstat : constant Boolean := Is_Static_Expression (Op1)
6395 Is_Static_Expression (Op2);
6401 -- Inhibit folding if -gnatd.f flag set
6403 if Debug_Flag_Dot_F and then In_Extended_Main_Source_Unit (N) then
6407 -- If either operand is Any_Type, just propagate to result and
6408 -- do not try to fold, this prevents cascaded errors.
6410 if Etype (Op1) = Any_Type or else Etype (Op2) = Any_Type then
6411 Set_Etype (N, Any_Type);
6414 -- If left operand raises Constraint_Error, then replace node N with the
6415 -- Raise_Constraint_Error node, and we are obviously not foldable.
6416 -- Is_Static_Expression is set from the two operands in the normal way,
6417 -- and we check the right operand if it is in a non-static context.
6419 elsif Raises_Constraint_Error (Op1) then
6421 Check_Non_Static_Context (Op2);
6424 Rewrite_In_Raise_CE (N, Op1);
6425 Set_Is_Static_Expression (N, Rstat);
6428 -- Similar processing for the case of the right operand. Note that we
6429 -- don't use this routine for the short-circuit case, so we do not have
6430 -- to worry about that special case here.
6432 elsif Raises_Constraint_Error (Op2) then
6434 Check_Non_Static_Context (Op1);
6437 Rewrite_In_Raise_CE (N, Op2);
6438 Set_Is_Static_Expression (N, Rstat);
6441 -- Exclude expressions of a generic modular type, as above
6443 elsif Is_Modular_Integer_Type (Etype (Op1))
6444 and then Is_Generic_Type (Etype (Op1))
6446 Check_Non_Static_Context (Op1);
6449 -- If result is not static, then check non-static contexts on operands
6450 -- since one of them may be static and the other one may not be static.
6452 elsif not Rstat then
6453 Check_Non_Static_Context (Op1);
6454 Check_Non_Static_Context (Op2);
6457 Fold := CRT_Safe_Compile_Time_Known_Value (Op1)
6458 and then CRT_Safe_Compile_Time_Known_Value (Op2);
6460 Fold := Compile_Time_Known_Value (Op1)
6461 and then Compile_Time_Known_Value (Op2);
6466 -- Else result is static and foldable. Both operands are static, and
6467 -- neither raises Constraint_Error, so we can definitely fold.
6470 Set_Is_Static_Expression (N);
6475 end Test_Expression_Is_Foldable;
6481 function Test_In_Range
6484 Assume_Valid : Boolean;
6485 Fixed_Int : Boolean;
6486 Int_Real : Boolean) return Range_Membership
6491 pragma Warnings (Off, Assume_Valid);
6492 -- For now Assume_Valid is unreferenced since the current implementation
6493 -- always returns Unknown if N is not a compile-time-known value, but we
6494 -- keep the parameter to allow for future enhancements in which we try
6495 -- to get the information in the variable case as well.
6498 -- If an error was posted on expression, then return Unknown, we do not
6499 -- want cascaded errors based on some false analysis of a junk node.
6501 if Error_Posted (N) then
6504 -- Expression that raises Constraint_Error is an odd case. We certainly
6505 -- do not want to consider it to be in range. It might make sense to
6506 -- consider it always out of range, but this causes incorrect error
6507 -- messages about static expressions out of range. So we just return
6508 -- Unknown, which is always safe.
6510 elsif Raises_Constraint_Error (N) then
6513 -- Universal types have no range limits, so always in range
6515 elsif Typ = Universal_Integer or else Typ = Universal_Real then
6518 -- Never known if not scalar type. Don't know if this can actually
6519 -- happen, but our spec allows it, so we must check.
6521 elsif not Is_Scalar_Type (Typ) then
6524 -- Never known if this is a generic type, since the bounds of generic
6525 -- types are junk. Note that if we only checked for static expressions
6526 -- (instead of compile-time-known values) below, we would not need this
6527 -- check, because values of a generic type can never be static, but they
6528 -- can be known at compile time.
6530 elsif Is_Generic_Type (Typ) then
6533 -- Case of a known compile time value, where we can check if it is in
6534 -- the bounds of the given type.
6536 elsif Compile_Time_Known_Value (N) then
6545 Lo := Type_Low_Bound (Typ);
6546 Hi := Type_High_Bound (Typ);
6548 LB_Known := Compile_Time_Known_Value (Lo);
6549 HB_Known := Compile_Time_Known_Value (Hi);
6551 -- Fixed point types should be considered as such only if flag
6552 -- Fixed_Int is set to False.
6554 if Is_Floating_Point_Type (Typ)
6555 or else (Is_Fixed_Point_Type (Typ) and then not Fixed_Int)
6558 Valr := Expr_Value_R (N);
6560 if LB_Known and HB_Known then
6561 if Valr >= Expr_Value_R (Lo)
6563 Valr <= Expr_Value_R (Hi)
6567 return Out_Of_Range;
6570 elsif (LB_Known and then Valr < Expr_Value_R (Lo))
6572 (HB_Known and then Valr > Expr_Value_R (Hi))
6574 return Out_Of_Range;
6581 Val := Expr_Value (N);
6583 if LB_Known and HB_Known then
6584 if Val >= Expr_Value (Lo) and then Val <= Expr_Value (Hi)
6588 return Out_Of_Range;
6591 elsif (LB_Known and then Val < Expr_Value (Lo))
6593 (HB_Known and then Val > Expr_Value (Hi))
6595 return Out_Of_Range;
6603 -- Here for value not known at compile time. Case of expression subtype
6604 -- is Typ or is a subtype of Typ, and we can assume expression is valid.
6605 -- In this case we know it is in range without knowing its value.
6608 and then (Etype (N) = Typ or else Is_Subtype_Of (Etype (N), Typ))
6612 -- Another special case. For signed integer types, if the target type
6613 -- has Is_Known_Valid set, and the source type does not have a larger
6614 -- size, then the source value must be in range. We exclude biased
6615 -- types, because they bizarrely can generate out of range values.
6617 elsif Is_Signed_Integer_Type (Etype (N))
6618 and then Is_Known_Valid (Typ)
6619 and then Esize (Etype (N)) <= Esize (Typ)
6620 and then not Has_Biased_Representation (Etype (N))
6624 -- For all other cases, result is unknown
6635 procedure To_Bits (U : Uint; B : out Bits) is
6637 for J in 0 .. B'Last loop
6638 B (J) := (U / (2 ** J)) mod 2 /= 0;
6642 --------------------
6643 -- Why_Not_Static --
6644 --------------------
6646 procedure Why_Not_Static (Expr : Node_Id) is
6647 N : constant Node_Id := Original_Node (Expr);
6648 Typ : Entity_Id := Empty;
6653 procedure Why_Not_Static_List (L : List_Id);
6654 -- A version that can be called on a list of expressions. Finds all
6655 -- non-static violations in any element of the list.
6657 -------------------------
6658 -- Why_Not_Static_List --
6659 -------------------------
6661 procedure Why_Not_Static_List (L : List_Id) is
6664 if Is_Non_Empty_List (L) then
6666 while Present (N) loop
6671 end Why_Not_Static_List;
6673 -- Start of processing for Why_Not_Static
6676 -- Ignore call on error or empty node
6678 if No (Expr) or else Nkind (Expr) = N_Error then
6682 -- Preprocessing for sub expressions
6684 if Nkind (Expr) in N_Subexpr then
6686 -- Nothing to do if expression is static
6688 if Is_OK_Static_Expression (Expr) then
6692 -- Test for Constraint_Error raised
6694 if Raises_Constraint_Error (Expr) then
6696 -- Special case membership to find out which piece to flag
6698 if Nkind (N) in N_Membership_Test then
6699 if Raises_Constraint_Error (Left_Opnd (N)) then
6700 Why_Not_Static (Left_Opnd (N));
6703 elsif Present (Right_Opnd (N))
6704 and then Raises_Constraint_Error (Right_Opnd (N))
6706 Why_Not_Static (Right_Opnd (N));
6710 pragma Assert (Present (Alternatives (N)));
6712 Alt := First (Alternatives (N));
6713 while Present (Alt) loop
6714 if Raises_Constraint_Error (Alt) then
6715 Why_Not_Static (Alt);
6723 -- Special case a range to find out which bound to flag
6725 elsif Nkind (N) = N_Range then
6726 if Raises_Constraint_Error (Low_Bound (N)) then
6727 Why_Not_Static (Low_Bound (N));
6730 elsif Raises_Constraint_Error (High_Bound (N)) then
6731 Why_Not_Static (High_Bound (N));
6735 -- Special case attribute to see which part to flag
6737 elsif Nkind (N) = N_Attribute_Reference then
6738 if Raises_Constraint_Error (Prefix (N)) then
6739 Why_Not_Static (Prefix (N));
6743 if Present (Expressions (N)) then
6744 Exp := First (Expressions (N));
6745 while Present (Exp) loop
6746 if Raises_Constraint_Error (Exp) then
6747 Why_Not_Static (Exp);
6755 -- Special case a subtype name
6757 elsif Is_Entity_Name (Expr) and then Is_Type (Entity (Expr)) then
6759 ("!& is not a static subtype (RM 4.9(26))", N, Entity (Expr));
6763 -- End of special cases
6766 ("!expression raises exception, cannot be static (RM 4.9(34))",
6771 -- If no type, then something is pretty wrong, so ignore
6773 Typ := Etype (Expr);
6779 -- Type must be scalar or string type (but allow Bignum, since this
6780 -- is really a scalar type from our point of view in this diagnosis).
6782 if not Is_Scalar_Type (Typ)
6783 and then not Is_String_Type (Typ)
6784 and then not Is_RTE (Typ, RE_Bignum)
6787 ("!static expression must have scalar or string type " &
6793 -- If we got through those checks, test particular node kind
6799 when N_Expanded_Name
6805 if Is_Named_Number (E) then
6808 elsif Ekind (E) = E_Constant then
6810 -- One case we can give a metter message is when we have a
6811 -- string literal created by concatenating an aggregate with
6812 -- an others expression.
6814 Entity_Case : declare
6815 CV : constant Node_Id := Constant_Value (E);
6816 CO : constant Node_Id := Original_Node (CV);
6818 function Is_Aggregate (N : Node_Id) return Boolean;
6819 -- See if node N came from an others aggregate, if so
6820 -- return True and set Error_Msg_Sloc to aggregate.
6826 function Is_Aggregate (N : Node_Id) return Boolean is
6828 if Nkind (Original_Node (N)) = N_Aggregate then
6829 Error_Msg_Sloc := Sloc (Original_Node (N));
6832 elsif Is_Entity_Name (N)
6833 and then Ekind (Entity (N)) = E_Constant
6835 Nkind (Original_Node (Constant_Value (Entity (N)))) =
6839 Sloc (Original_Node (Constant_Value (Entity (N))));
6847 -- Start of processing for Entity_Case
6850 if Is_Aggregate (CV)
6851 or else (Nkind (CO) = N_Op_Concat
6852 and then (Is_Aggregate (Left_Opnd (CO))
6854 Is_Aggregate (Right_Opnd (CO))))
6856 Error_Msg_N ("!aggregate (#) is never static", N);
6858 elsif No (CV) or else not Is_Static_Expression (CV) then
6860 ("!& is not a static constant (RM 4.9(5))", N, E);
6864 elsif Is_Type (E) then
6866 ("!& is not a static subtype (RM 4.9(26))", N, E);
6870 ("!& is not static constant or named number "
6871 & "(RM 4.9(5))", N, E);
6880 if Nkind (N) in N_Op_Shift then
6882 ("!shift functions are never static (RM 4.9(6,18))", N);
6884 Why_Not_Static (Left_Opnd (N));
6885 Why_Not_Static (Right_Opnd (N));
6891 Why_Not_Static (Right_Opnd (N));
6893 -- Attribute reference
6895 when N_Attribute_Reference =>
6896 Why_Not_Static_List (Expressions (N));
6898 E := Etype (Prefix (N));
6900 if E = Standard_Void_Type then
6904 -- Special case non-scalar'Size since this is a common error
6906 if Attribute_Name (N) = Name_Size then
6908 ("!size attribute is only static for static scalar type "
6909 & "(RM 4.9(7,8))", N);
6913 elsif Is_Array_Type (E) then
6914 if not Nam_In (Attribute_Name (N), Name_First,
6919 ("!static array attribute must be Length, First, or Last "
6920 & "(RM 4.9(8))", N);
6922 -- Since we know the expression is not-static (we already
6923 -- tested for this, must mean array is not static).
6927 ("!prefix is non-static array (RM 4.9(8))", Prefix (N));
6932 -- Special case generic types, since again this is a common source
6935 elsif Is_Generic_Actual_Type (E) or else Is_Generic_Type (E) then
6937 ("!attribute of generic type is never static "
6938 & "(RM 4.9(7,8))", N);
6940 elsif Is_OK_Static_Subtype (E) then
6943 elsif Is_Scalar_Type (E) then
6945 ("!prefix type for attribute is not static scalar subtype "
6946 & "(RM 4.9(7))", N);
6950 ("!static attribute must apply to array/scalar type "
6951 & "(RM 4.9(7,8))", N);
6956 when N_String_Literal =>
6958 ("!subtype of string literal is non-static (RM 4.9(4))", N);
6960 -- Explicit dereference
6962 when N_Explicit_Dereference =>
6964 ("!explicit dereference is never static (RM 4.9)", N);
6968 when N_Function_Call =>
6969 Why_Not_Static_List (Parameter_Associations (N));
6971 -- Complain about non-static function call unless we have Bignum
6972 -- which means that the underlying expression is really some
6973 -- scalar arithmetic operation.
6975 if not Is_RTE (Typ, RE_Bignum) then
6976 Error_Msg_N ("!non-static function call (RM 4.9(6,18))", N);
6979 -- Parameter assocation (test actual parameter)
6981 when N_Parameter_Association =>
6982 Why_Not_Static (Explicit_Actual_Parameter (N));
6984 -- Indexed component
6986 when N_Indexed_Component =>
6987 Error_Msg_N ("!indexed component is never static (RM 4.9)", N);
6991 when N_Procedure_Call_Statement =>
6992 Error_Msg_N ("!procedure call is never static (RM 4.9)", N);
6994 -- Qualified expression (test expression)
6996 when N_Qualified_Expression =>
6997 Why_Not_Static (Expression (N));
7002 | N_Extension_Aggregate
7004 Error_Msg_N ("!an aggregate is never static (RM 4.9)", N);
7009 Why_Not_Static (Low_Bound (N));
7010 Why_Not_Static (High_Bound (N));
7012 -- Range constraint, test range expression
7014 when N_Range_Constraint =>
7015 Why_Not_Static (Range_Expression (N));
7017 -- Subtype indication, test constraint
7019 when N_Subtype_Indication =>
7020 Why_Not_Static (Constraint (N));
7022 -- Selected component
7024 when N_Selected_Component =>
7025 Error_Msg_N ("!selected component is never static (RM 4.9)", N);
7030 Error_Msg_N ("!slice is never static (RM 4.9)", N);
7032 when N_Type_Conversion =>
7033 Why_Not_Static (Expression (N));
7035 if not Is_Scalar_Type (Entity (Subtype_Mark (N)))
7036 or else not Is_OK_Static_Subtype (Entity (Subtype_Mark (N)))
7039 ("!static conversion requires static scalar subtype result "
7040 & "(RM 4.9(9))", N);
7043 -- Unchecked type conversion
7045 when N_Unchecked_Type_Conversion =>
7047 ("!unchecked type conversion is never static (RM 4.9)", N);
7049 -- All other cases, no reason to give