1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2017, 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 detailed rules
70 -- in RM 4.9(4-14). This involves testing the Is_Static_Expression
71 -- flag of the operands in many cases.
73 -- Raises_Constraint_Error is set if any of the operands have the flag
74 -- set or if an attempt to compute the value of the current expression
75 -- results in detection of a runtime constraint error.
77 -- As described in the spec, the requirement is that Is_Static_Expression
78 -- be accurately set, and in addition for nodes for which this flag is set,
79 -- Raises_Constraint_Error must also be set. Furthermore a node which has
80 -- Is_Static_Expression set, and Raises_Constraint_Error clear, then the
81 -- requirement is that the expression value must be precomputed, and the
82 -- node is either a literal, or the name of a constant entity whose value
83 -- is a static expression.
85 -- The general approach is as follows. First compute Is_Static_Expression.
86 -- If the node is not static, then the flag is left off in the node and
87 -- we are all done. Otherwise for a static node, we test if any of the
88 -- operands will raise constraint error, and if so, propagate the flag
89 -- Raises_Constraint_Error to the result node and we are done (since the
90 -- error was already posted at a lower level).
92 -- For the case of a static node whose operands do not raise constraint
93 -- error, we attempt to evaluate the node. If this evaluation succeeds,
94 -- then the node is replaced by the result of this computation. If the
95 -- evaluation raises constraint error, then we rewrite the node with
96 -- Apply_Compile_Time_Constraint_Error to raise the exception and also
97 -- to post appropriate error messages.
103 type Bits is array (Nat range <>) of Boolean;
104 -- Used to convert unsigned (modular) values for folding logical ops
106 -- The following declarations are used to maintain a cache of nodes that
107 -- have compile time known values. The cache is maintained only for
108 -- discrete types (the most common case), and is populated by calls to
109 -- Compile_Time_Known_Value and Expr_Value, but only used by Expr_Value
110 -- since it is possible for the status to change (in particular it is
111 -- possible for a node to get replaced by a constraint error node).
113 CV_Bits : constant := 5;
114 -- Number of low order bits of Node_Id value used to reference entries
115 -- in the cache table.
117 CV_Cache_Size : constant Nat := 2 ** CV_Bits;
118 -- Size of cache for compile time values
120 subtype CV_Range is Nat range 0 .. CV_Cache_Size;
122 type CV_Entry is record
127 type Match_Result is (Match, No_Match, Non_Static);
128 -- Result returned from functions that test for a matching result. If the
129 -- operands are not OK_Static then Non_Static will be returned. Otherwise
130 -- Match/No_Match is returned depending on whether the match succeeds.
132 type CV_Cache_Array is array (CV_Range) of CV_Entry;
134 CV_Cache : CV_Cache_Array := (others => (Node_High_Bound, Uint_0));
135 -- This is the actual cache, with entries consisting of node/value pairs,
136 -- and the impossible value Node_High_Bound used for unset entries.
138 type Range_Membership is (In_Range, Out_Of_Range, Unknown);
139 -- Range membership may either be statically known to be in range or out
140 -- of range, or not statically known. Used for Test_In_Range below.
142 -----------------------
143 -- Local Subprograms --
144 -----------------------
146 function Choice_Matches
148 Choice : Node_Id) return Match_Result;
149 -- Determines whether given value Expr matches the given Choice. The Expr
150 -- can be of discrete, real, or string type and must be a compile time
151 -- known value (it is an error to make the call if these conditions are
152 -- not met). The choice can be a range, subtype name, subtype indication,
153 -- or expression. The returned result is Non_Static if Choice is not
154 -- OK_Static, otherwise either Match or No_Match is returned depending
155 -- on whether Choice matches Expr. This is used for case expression
156 -- alternatives, and also for membership tests. In each case, more
157 -- possibilities are tested than the syntax allows (e.g. membership allows
158 -- subtype indications and non-discrete types, and case allows an OTHERS
159 -- choice), but it does not matter, since we have already done a full
160 -- semantic and syntax check of the construct, so the extra possibilities
161 -- just will not arise for correct expressions.
163 -- Note: if Choice_Matches finds that a choice raises Constraint_Error, e.g
164 -- a reference to a type, one of whose bounds raises Constraint_Error, then
165 -- it also sets the Raises_Constraint_Error flag on the Choice itself.
167 function Choices_Match
169 Choices : List_Id) return Match_Result;
170 -- This function applies Choice_Matches to each element of Choices. If the
171 -- result is No_Match, then it continues and checks the next element. If
172 -- the result is Match or Non_Static, this result is immediately given
173 -- as the result without checking the rest of the list. Expr can be of
174 -- discrete, real, or string type and must be a compile time known value
175 -- (it is an error to make the call if these conditions are not met).
177 function Find_Universal_Operator_Type (N : Node_Id) return Entity_Id;
178 -- Check whether an arithmetic operation with universal operands which is a
179 -- rewritten function call with an explicit scope indication is ambiguous:
180 -- P."+" (1, 2) will be ambiguous if there is more than one visible numeric
181 -- type declared in P and the context does not impose a type on the result
182 -- (e.g. in the expression of a type conversion). If ambiguous, emit an
183 -- error and return Empty, else return the result type of the operator.
185 function From_Bits (B : Bits; T : Entity_Id) return Uint;
186 -- Converts a bit string of length B'Length to a Uint value to be used for
187 -- a target of type T, which is a modular type. This procedure includes the
188 -- necessary reduction by the modulus in the case of a nonbinary modulus
189 -- (for a binary modulus, the bit string is the right length any way so all
192 function Get_String_Val (N : Node_Id) return Node_Id;
193 -- Given a tree node for a folded string or character value, returns the
194 -- corresponding string literal or character literal (one of the two must
195 -- be available, or the operand would not have been marked as foldable in
196 -- the earlier analysis of the operation).
198 function Is_OK_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 and does not raise a Constraint_Error.
202 function Is_OK_Static_Choice_List (Choices : List_Id) return Boolean;
203 -- Given a choice list (from a case expression or membership test), return
204 -- True if all choices are static in the sense of Is_OK_Static_Choice.
206 function Is_Static_Choice (Choice : Node_Id) return Boolean;
207 -- Given a choice (from a case expression or membership test), returns
208 -- True if the choice is static. No test is made for raising of constraint
209 -- error, so this function is used only for legality tests.
211 function Is_Static_Choice_List (Choices : List_Id) return Boolean;
212 -- Given a choice list (from a case expression or membership test), return
213 -- True if all choices are static in the sense of Is_Static_Choice.
215 function Is_Static_Range (N : Node_Id) return Boolean;
216 -- Determine if range is static, as defined in RM 4.9(26). The only allowed
217 -- argument is an N_Range node (but note that the semantic analysis of
218 -- equivalent range attribute references already turned them into the
219 -- equivalent range). This differs from Is_OK_Static_Range (which is what
220 -- must be used by clients) in that it does not care whether the bounds
221 -- raise Constraint_Error or not. Used for checking whether expressions are
222 -- static in the 4.9 sense (without worrying about exceptions).
224 function OK_Bits (N : Node_Id; Bits : Uint) return Boolean;
225 -- Bits represents the number of bits in an integer value to be computed
226 -- (but the value has not been computed yet). If this value in Bits is
227 -- reasonable, a result of True is returned, with the implication that the
228 -- caller should go ahead and complete the calculation. If the value in
229 -- Bits is unreasonably large, then an error is posted on node N, and
230 -- False is returned (and the caller skips the proposed calculation).
232 procedure Out_Of_Range (N : Node_Id);
233 -- This procedure is called if it is determined that node N, which appears
234 -- in a non-static context, is a compile time known value which is outside
235 -- its range, i.e. the range of Etype. This is used in contexts where
236 -- this is an illegality if N is static, and should generate a warning
239 function Real_Or_String_Static_Predicate_Matches
241 Typ : Entity_Id) return Boolean;
242 -- This is the function used to evaluate real or string static predicates.
243 -- Val is an unanalyzed N_Real_Literal or N_String_Literal node, which
244 -- represents the value to be tested against the predicate. Typ is the
245 -- type with the predicate, from which the predicate expression can be
246 -- extracted. The result returned is True if the given value satisfies
249 procedure Rewrite_In_Raise_CE (N : Node_Id; Exp : Node_Id);
250 -- N and Exp are nodes representing an expression, Exp is known to raise
251 -- CE. N is rewritten in term of Exp in the optimal way.
253 function String_Type_Len (Stype : Entity_Id) return Uint;
254 -- Given a string type, determines the length of the index type, or, if
255 -- this index type is non-static, the length of the base type of this index
256 -- type. Note that if the string type is itself static, then the index type
257 -- is static, so the second case applies only if the string type passed is
260 function Test (Cond : Boolean) return Uint;
261 pragma Inline (Test);
262 -- This function simply returns the appropriate Boolean'Pos value
263 -- corresponding to the value of Cond as a universal integer. It is
264 -- used for producing the result of the static evaluation of the
267 procedure Test_Expression_Is_Foldable
272 -- Tests to see if expression N whose single operand is Op1 is foldable,
273 -- i.e. the operand value is known at compile time. If the operation is
274 -- foldable, then Fold is True on return, and Stat indicates whether the
275 -- result is static (i.e. the operand was static). Note that it is quite
276 -- possible for Fold to be True, and Stat to be False, since there are
277 -- cases in which we know the value of an operand even though it is not
278 -- technically static (e.g. the static lower bound of a range whose upper
279 -- bound is non-static).
281 -- If Stat is set False on return, then Test_Expression_Is_Foldable makes
282 -- a call to Check_Non_Static_Context on the operand. If Fold is False on
283 -- return, then all processing is complete, and the caller should return,
284 -- since there is nothing else to do.
286 -- If Stat is set True on return, then Is_Static_Expression is also set
287 -- true in node N. There are some cases where this is over-enthusiastic,
288 -- e.g. in the two operand case below, for string comparison, the result is
289 -- not static even though the two operands are static. In such cases, the
290 -- caller must reset the Is_Static_Expression flag in N.
292 -- If Fold and Stat are both set to False then this routine performs also
293 -- the following extra actions:
295 -- If either operand is Any_Type then propagate it to result to prevent
298 -- If some operand raises constraint error, then replace the node N
299 -- with the raise constraint error node. This replacement inherits the
300 -- Is_Static_Expression flag from the operands.
302 procedure Test_Expression_Is_Foldable
308 CRT_Safe : Boolean := False);
309 -- Same processing, except applies to an expression N with two operands
310 -- Op1 and Op2. The result is static only if both operands are static. If
311 -- CRT_Safe is set True, then CRT_Safe_Compile_Time_Known_Value is used
312 -- for the tests that the two operands are known at compile time. See
313 -- spec of this routine for further details.
315 function Test_In_Range
318 Assume_Valid : Boolean;
320 Int_Real : Boolean) return Range_Membership;
321 -- Common processing for Is_In_Range and Is_Out_Of_Range: Returns In_Range
322 -- or Out_Of_Range if it can be guaranteed at compile time that expression
323 -- N is known to be in or out of range of the subtype Typ. If not compile
324 -- time known, Unknown is returned. See documentation of Is_In_Range for
325 -- complete description of parameters.
327 procedure To_Bits (U : Uint; B : out Bits);
328 -- Converts a Uint value to a bit string of length B'Length
330 -----------------------------------------------
331 -- Check_Expression_Against_Static_Predicate --
332 -----------------------------------------------
334 procedure Check_Expression_Against_Static_Predicate
339 -- Nothing to do if expression is not known at compile time, or the
340 -- type has no static predicate set (will be the case for all non-scalar
341 -- types, so no need to make a special test for that).
343 if not (Has_Static_Predicate (Typ)
344 and then Compile_Time_Known_Value (Expr))
349 -- Here we have a static predicate (note that it could have arisen from
350 -- an explicitly specified Dynamic_Predicate whose expression met the
351 -- rules for being predicate-static). If the expression is known at
352 -- compile time and obeys the predicate, then it is static and must be
353 -- labeled as such, which matters e.g. for case statements. The original
354 -- expression may be a type conversion of a variable with a known value,
355 -- which might otherwise not be marked static.
357 -- Case of real static predicate
359 if Is_Real_Type (Typ) then
360 if Real_Or_String_Static_Predicate_Matches
361 (Val => Make_Real_Literal (Sloc (Expr), Expr_Value_R (Expr)),
364 Set_Is_Static_Expression (Expr);
368 -- Case of string static predicate
370 elsif Is_String_Type (Typ) then
371 if Real_Or_String_Static_Predicate_Matches
372 (Val => Expr_Value_S (Expr), Typ => Typ)
374 Set_Is_Static_Expression (Expr);
378 -- Case of discrete static predicate
381 pragma Assert (Is_Discrete_Type (Typ));
383 -- If static predicate matches, nothing to do
385 if Choices_Match (Expr, Static_Discrete_Predicate (Typ)) = Match then
386 Set_Is_Static_Expression (Expr);
391 -- Here we know that the predicate will fail
393 -- Special case of static expression failing a predicate (other than one
394 -- that was explicitly specified with a Dynamic_Predicate aspect). This
395 -- is the case where the expression is no longer considered static.
397 if Is_Static_Expression (Expr)
398 and then not Has_Dynamic_Predicate_Aspect (Typ)
401 ("??static expression fails static predicate check on &",
404 ("\??expression is no longer considered static", Expr);
405 Set_Is_Static_Expression (Expr, False);
407 -- In all other cases, this is just a warning that a test will fail.
408 -- It does not matter if the expression is static or not, or if the
409 -- predicate comes from a dynamic predicate aspect or not.
413 ("??expression fails predicate check on &", Expr, Typ);
415 end Check_Expression_Against_Static_Predicate;
417 ------------------------------
418 -- Check_Non_Static_Context --
419 ------------------------------
421 procedure Check_Non_Static_Context (N : Node_Id) is
422 T : constant Entity_Id := Etype (N);
423 Checks_On : constant Boolean :=
424 not Index_Checks_Suppressed (T)
425 and not Range_Checks_Suppressed (T);
428 -- Ignore cases of non-scalar types, error types, or universal real
429 -- types that have no usable bounds.
432 or else not Is_Scalar_Type (T)
433 or else T = Universal_Fixed
434 or else T = Universal_Real
439 -- At this stage we have a scalar type. If we have an expression that
440 -- raises CE, then we already issued a warning or error msg so there is
441 -- nothing more to be done in this routine.
443 if Raises_Constraint_Error (N) then
447 -- Now we have a scalar type which is not marked as raising a constraint
448 -- error exception. The main purpose of this routine is to deal with
449 -- static expressions appearing in a non-static context. That means
450 -- that if we do not have a static expression then there is not much
451 -- to do. The one case that we deal with here is that if we have a
452 -- floating-point value that is out of range, then we post a warning
453 -- that an infinity will result.
455 if not Is_Static_Expression (N) then
456 if Is_Floating_Point_Type (T) then
457 if Is_Out_Of_Range (N, Base_Type (T), Assume_Valid => True) then
459 ("??float value out of range, infinity will be generated", N);
461 -- The literal may be the result of constant-folding of a non-
462 -- static subexpression of a larger expression (e.g. a conversion
463 -- of a non-static variable whose value happens to be known). At
464 -- this point we must reduce the value of the subexpression to a
465 -- machine number (RM 4.9 (38/2)).
467 elsif Nkind (N) = N_Real_Literal
468 and then Nkind (Parent (N)) in N_Subexpr
470 Rewrite (N, New_Copy (N));
472 (N, Machine (Base_Type (T), Realval (N), Round_Even, N));
479 -- Here we have the case of outer level static expression of scalar
480 -- type, where the processing of this procedure is needed.
482 -- For real types, this is where we convert the value to a machine
483 -- number (see RM 4.9(38)). Also see ACVC test C490001. We should only
484 -- need to do this if the parent is a constant declaration, since in
485 -- other cases, gigi should do the necessary conversion correctly, but
486 -- experimentation shows that this is not the case on all machines, in
487 -- particular if we do not convert all literals to machine values in
488 -- non-static contexts, then ACVC test C490001 fails on Sparc/Solaris
491 -- This conversion is always done by GNATprove on real literals in
492 -- non-static expressions, by calling Check_Non_Static_Context from
493 -- gnat2why, as GNATprove cannot do the conversion later contrary
494 -- to gigi. The frontend computes the information about which
495 -- expressions are static, which is used by gnat2why to call
496 -- Check_Non_Static_Context on exactly those real literals that are
497 -- not subexpressions of static expressions.
499 if Nkind (N) = N_Real_Literal
500 and then not Is_Machine_Number (N)
501 and then not Is_Generic_Type (Etype (N))
502 and then Etype (N) /= Universal_Real
504 -- Check that value is in bounds before converting to machine
505 -- number, so as not to lose case where value overflows in the
506 -- least significant bit or less. See B490001.
508 if Is_Out_Of_Range (N, Base_Type (T), Assume_Valid => True) then
513 -- Note: we have to copy the node, to avoid problems with conformance
514 -- of very similar numbers (see ACVC tests B4A010C and B63103A).
516 Rewrite (N, New_Copy (N));
518 if not Is_Floating_Point_Type (T) then
520 (N, Corresponding_Integer_Value (N) * Small_Value (T));
522 elsif not UR_Is_Zero (Realval (N)) then
524 -- Note: even though RM 4.9(38) specifies biased rounding, this
525 -- has been modified by AI-100 in order to prevent confusing
526 -- differences in rounding between static and non-static
527 -- expressions. AI-100 specifies that the effect of such rounding
528 -- is implementation dependent, and in GNAT we round to nearest
529 -- even to match the run-time behavior. Note that this applies
530 -- to floating point literals, not fixed points ones, even though
531 -- their compiler representation is also as a universal real.
534 (N, Machine (Base_Type (T), Realval (N), Round_Even, N));
535 Set_Is_Machine_Number (N);
540 -- Check for out of range universal integer. This is a non-static
541 -- context, so the integer value must be in range of the runtime
542 -- representation of universal integers.
544 -- We do this only within an expression, because that is the only
545 -- case in which non-static universal integer values can occur, and
546 -- furthermore, Check_Non_Static_Context is currently (incorrectly???)
547 -- called in contexts like the expression of a number declaration where
548 -- we certainly want to allow out of range values.
550 if Etype (N) = Universal_Integer
551 and then Nkind (N) = N_Integer_Literal
552 and then Nkind (Parent (N)) in N_Subexpr
554 (Intval (N) < Expr_Value (Type_Low_Bound (Universal_Integer))
556 Intval (N) > Expr_Value (Type_High_Bound (Universal_Integer)))
558 Apply_Compile_Time_Constraint_Error
559 (N, "non-static universal integer value out of range<<",
560 CE_Range_Check_Failed);
562 -- Check out of range of base type
564 elsif Is_Out_Of_Range (N, Base_Type (T), Assume_Valid => True) then
567 -- Give warning if outside subtype (where one or both of the bounds of
568 -- the subtype is static). This warning is omitted if the expression
569 -- appears in a range that could be null (warnings are handled elsewhere
572 elsif T /= Base_Type (T) and then Nkind (Parent (N)) /= N_Range then
573 if Is_In_Range (N, T, Assume_Valid => True) then
576 elsif Is_Out_Of_Range (N, T, Assume_Valid => True) then
577 Apply_Compile_Time_Constraint_Error
578 (N, "value not in range of}<<", CE_Range_Check_Failed);
581 Enable_Range_Check (N);
584 Set_Do_Range_Check (N, False);
587 end Check_Non_Static_Context;
589 ---------------------------------
590 -- Check_String_Literal_Length --
591 ---------------------------------
593 procedure Check_String_Literal_Length (N : Node_Id; Ttype : Entity_Id) is
595 if not Raises_Constraint_Error (N) and then Is_Constrained (Ttype) then
596 if UI_From_Int (String_Length (Strval (N))) /= String_Type_Len (Ttype)
598 Apply_Compile_Time_Constraint_Error
599 (N, "string length wrong for}??",
600 CE_Length_Check_Failed,
605 end Check_String_Literal_Length;
611 function Choice_Matches
613 Choice : Node_Id) return Match_Result
615 Etyp : constant Entity_Id := Etype (Expr);
621 pragma Assert (Compile_Time_Known_Value (Expr));
622 pragma Assert (Is_Scalar_Type (Etyp) or else Is_String_Type (Etyp));
624 if not Is_OK_Static_Choice (Choice) then
625 Set_Raises_Constraint_Error (Choice);
628 -- When the choice denotes a subtype with a static predictate, check the
629 -- expression against the predicate values. Different procedures apply
630 -- to discrete and non-discrete types.
632 elsif (Nkind (Choice) = N_Subtype_Indication
633 or else (Is_Entity_Name (Choice)
634 and then Is_Type (Entity (Choice))))
635 and then Has_Predicates (Etype (Choice))
636 and then Has_Static_Predicate (Etype (Choice))
638 if Is_Discrete_Type (Etype (Choice)) then
641 (Expr, Static_Discrete_Predicate (Etype (Choice)));
643 elsif Real_Or_String_Static_Predicate_Matches (Expr, Etype (Choice))
651 -- Discrete type case only
653 elsif Is_Discrete_Type (Etyp) then
654 Val := Expr_Value (Expr);
656 if Nkind (Choice) = N_Range then
657 if Val >= Expr_Value (Low_Bound (Choice))
659 Val <= Expr_Value (High_Bound (Choice))
666 elsif Nkind (Choice) = N_Subtype_Indication
667 or else (Is_Entity_Name (Choice) and then Is_Type (Entity (Choice)))
669 if Val >= Expr_Value (Type_Low_Bound (Etype (Choice)))
671 Val <= Expr_Value (Type_High_Bound (Etype (Choice)))
678 elsif Nkind (Choice) = N_Others_Choice then
682 if Val = Expr_Value (Choice) then
691 elsif Is_Real_Type (Etyp) then
692 ValR := Expr_Value_R (Expr);
694 if Nkind (Choice) = N_Range then
695 if ValR >= Expr_Value_R (Low_Bound (Choice))
697 ValR <= Expr_Value_R (High_Bound (Choice))
704 elsif Nkind (Choice) = N_Subtype_Indication
705 or else (Is_Entity_Name (Choice) and then Is_Type (Entity (Choice)))
707 if ValR >= Expr_Value_R (Type_Low_Bound (Etype (Choice)))
709 ValR <= Expr_Value_R (Type_High_Bound (Etype (Choice)))
717 if ValR = Expr_Value_R (Choice) then
727 pragma Assert (Is_String_Type (Etyp));
728 ValS := Expr_Value_S (Expr);
730 if Nkind (Choice) = N_Subtype_Indication
731 or else (Is_Entity_Name (Choice) and then Is_Type (Entity (Choice)))
733 if not Is_Constrained (Etype (Choice)) then
738 Typlen : constant Uint :=
739 String_Type_Len (Etype (Choice));
740 Strlen : constant Uint :=
741 UI_From_Int (String_Length (Strval (ValS)));
743 if Typlen = Strlen then
752 if String_Equal (Strval (ValS), Strval (Expr_Value_S (Choice)))
766 function Choices_Match
768 Choices : List_Id) return Match_Result
771 Result : Match_Result;
774 Choice := First (Choices);
775 while Present (Choice) loop
776 Result := Choice_Matches (Expr, Choice);
778 if Result /= No_Match then
788 --------------------------
789 -- Compile_Time_Compare --
790 --------------------------
792 function Compile_Time_Compare
794 Assume_Valid : Boolean) return Compare_Result
796 Discard : aliased Uint;
798 return Compile_Time_Compare (L, R, Discard'Access, Assume_Valid);
799 end Compile_Time_Compare;
801 function Compile_Time_Compare
804 Assume_Valid : Boolean;
805 Rec : Boolean := False) return Compare_Result
807 Ltyp : Entity_Id := Etype (L);
808 Rtyp : Entity_Id := Etype (R);
810 Discard : aliased Uint;
812 procedure Compare_Decompose
816 -- This procedure decomposes the node N into an expression node and a
817 -- signed offset, so that the value of N is equal to the value of R plus
818 -- the value V (which may be negative). If no such decomposition is
819 -- possible, then on return R is a copy of N, and V is set to zero.
821 function Compare_Fixup (N : Node_Id) return Node_Id;
822 -- This function deals with replacing 'Last and 'First references with
823 -- their corresponding type bounds, which we then can compare. The
824 -- argument is the original node, the result is the identity, unless we
825 -- have a 'Last/'First reference in which case the value returned is the
826 -- appropriate type bound.
828 function Is_Known_Valid_Operand (Opnd : Node_Id) return Boolean;
829 -- Even if the context does not assume that values are valid, some
830 -- simple cases can be recognized.
832 function Is_Same_Value (L, R : Node_Id) return Boolean;
833 -- Returns True iff L and R represent expressions that definitely have
834 -- identical (but not necessarily compile time known) values Indeed the
835 -- caller is expected to have already dealt with the cases of compile
836 -- time known values, so these are not tested here.
838 -----------------------
839 -- Compare_Decompose --
840 -----------------------
842 procedure Compare_Decompose
848 if Nkind (N) = N_Op_Add
849 and then Nkind (Right_Opnd (N)) = N_Integer_Literal
852 V := Intval (Right_Opnd (N));
855 elsif Nkind (N) = N_Op_Subtract
856 and then Nkind (Right_Opnd (N)) = N_Integer_Literal
859 V := UI_Negate (Intval (Right_Opnd (N)));
862 elsif Nkind (N) = N_Attribute_Reference then
863 if Attribute_Name (N) = Name_Succ then
864 R := First (Expressions (N));
868 elsif Attribute_Name (N) = Name_Pred then
869 R := First (Expressions (N));
877 end Compare_Decompose;
883 function Compare_Fixup (N : Node_Id) return Node_Id is
889 -- Fixup only required for First/Last attribute reference
891 if Nkind (N) = N_Attribute_Reference
892 and then Nam_In (Attribute_Name (N), Name_First, Name_Last)
894 Xtyp := Etype (Prefix (N));
896 -- If we have no type, then just abandon the attempt to do
897 -- a fixup, this is probably the result of some other error.
903 -- Dereference an access type
905 if Is_Access_Type (Xtyp) then
906 Xtyp := Designated_Type (Xtyp);
909 -- If we don't have an array type at this stage, something is
910 -- peculiar, e.g. another error, and we abandon the attempt at
913 if not Is_Array_Type (Xtyp) then
917 -- Ignore unconstrained array, since bounds are not meaningful
919 if not Is_Constrained (Xtyp) then
923 if Ekind (Xtyp) = E_String_Literal_Subtype then
924 if Attribute_Name (N) = Name_First then
925 return String_Literal_Low_Bound (Xtyp);
928 Make_Integer_Literal (Sloc (N),
929 Intval => Intval (String_Literal_Low_Bound (Xtyp)) +
930 String_Literal_Length (Xtyp));
934 -- Find correct index type
936 Indx := First_Index (Xtyp);
938 if Present (Expressions (N)) then
939 Subs := UI_To_Int (Expr_Value (First (Expressions (N))));
941 for J in 2 .. Subs loop
942 Indx := Next_Index (Indx);
946 Xtyp := Etype (Indx);
948 if Attribute_Name (N) = Name_First then
949 return Type_Low_Bound (Xtyp);
951 return Type_High_Bound (Xtyp);
958 ----------------------------
959 -- Is_Known_Valid_Operand --
960 ----------------------------
962 function Is_Known_Valid_Operand (Opnd : Node_Id) return Boolean is
964 return (Is_Entity_Name (Opnd)
966 (Is_Known_Valid (Entity (Opnd))
967 or else Ekind (Entity (Opnd)) = E_In_Parameter
969 (Ekind (Entity (Opnd)) in Object_Kind
970 and then Present (Current_Value (Entity (Opnd))))))
971 or else Is_OK_Static_Expression (Opnd);
972 end Is_Known_Valid_Operand;
978 function Is_Same_Value (L, R : Node_Id) return Boolean is
979 Lf : constant Node_Id := Compare_Fixup (L);
980 Rf : constant Node_Id := Compare_Fixup (R);
982 function Is_Same_Subscript (L, R : List_Id) return Boolean;
983 -- L, R are the Expressions values from two attribute nodes for First
984 -- or Last attributes. Either may be set to No_List if no expressions
985 -- are present (indicating subscript 1). The result is True if both
986 -- expressions represent the same subscript (note one case is where
987 -- one subscript is missing and the other is explicitly set to 1).
989 -----------------------
990 -- Is_Same_Subscript --
991 -----------------------
993 function Is_Same_Subscript (L, R : List_Id) return Boolean is
999 return Expr_Value (First (R)) = Uint_1;
1004 return Expr_Value (First (L)) = Uint_1;
1006 return Expr_Value (First (L)) = Expr_Value (First (R));
1009 end Is_Same_Subscript;
1011 -- Start of processing for Is_Same_Value
1014 -- Values are the same if they refer to the same entity and the
1015 -- entity is non-volatile. This does not however apply to Float
1016 -- types, since we may have two NaN values and they should never
1019 -- If the entity is a discriminant, the two expressions may be bounds
1020 -- of components of objects of the same discriminated type. The
1021 -- values of the discriminants are not static, and therefore the
1022 -- result is unknown.
1024 -- It would be better to comment individual branches of this test ???
1026 if Nkind_In (Lf, N_Identifier, N_Expanded_Name)
1027 and then Nkind_In (Rf, N_Identifier, N_Expanded_Name)
1028 and then Entity (Lf) = Entity (Rf)
1029 and then Ekind (Entity (Lf)) /= E_Discriminant
1030 and then Present (Entity (Lf))
1031 and then not Is_Floating_Point_Type (Etype (L))
1032 and then not Is_Volatile_Reference (L)
1033 and then not Is_Volatile_Reference (R)
1037 -- Or if they are compile time known and identical
1039 elsif Compile_Time_Known_Value (Lf)
1041 Compile_Time_Known_Value (Rf)
1042 and then Expr_Value (Lf) = Expr_Value (Rf)
1046 -- False if Nkind of the two nodes is different for remaining cases
1048 elsif Nkind (Lf) /= Nkind (Rf) then
1051 -- True if both 'First or 'Last values applying to the same entity
1052 -- (first and last don't change even if value does). Note that we
1053 -- need this even with the calls to Compare_Fixup, to handle the
1054 -- case of unconstrained array attributes where Compare_Fixup
1055 -- cannot find useful bounds.
1057 elsif Nkind (Lf) = N_Attribute_Reference
1058 and then Attribute_Name (Lf) = Attribute_Name (Rf)
1059 and then Nam_In (Attribute_Name (Lf), Name_First, Name_Last)
1060 and then Nkind_In (Prefix (Lf), N_Identifier, N_Expanded_Name)
1061 and then Nkind_In (Prefix (Rf), N_Identifier, N_Expanded_Name)
1062 and then Entity (Prefix (Lf)) = Entity (Prefix (Rf))
1063 and then Is_Same_Subscript (Expressions (Lf), Expressions (Rf))
1067 -- True if the same selected component from the same record
1069 elsif Nkind (Lf) = N_Selected_Component
1070 and then Selector_Name (Lf) = Selector_Name (Rf)
1071 and then Is_Same_Value (Prefix (Lf), Prefix (Rf))
1075 -- True if the same unary operator applied to the same operand
1077 elsif Nkind (Lf) in N_Unary_Op
1078 and then Is_Same_Value (Right_Opnd (Lf), Right_Opnd (Rf))
1082 -- True if the same binary operator applied to the same operands
1084 elsif Nkind (Lf) in N_Binary_Op
1085 and then Is_Same_Value (Left_Opnd (Lf), Left_Opnd (Rf))
1086 and then Is_Same_Value (Right_Opnd (Lf), Right_Opnd (Rf))
1090 -- All other cases, we can't tell, so return False
1097 -- Start of processing for Compile_Time_Compare
1100 Diff.all := No_Uint;
1102 -- In preanalysis mode, always return Unknown unless the expression
1103 -- is static. It is too early to be thinking we know the result of a
1104 -- comparison, save that judgment for the full analysis. This is
1105 -- particularly important in the case of pre and postconditions, which
1106 -- otherwise can be prematurely collapsed into having True or False
1107 -- conditions when this is inappropriate.
1109 if not (Full_Analysis
1110 or else (Is_OK_Static_Expression (L)
1112 Is_OK_Static_Expression (R)))
1117 -- If either operand could raise constraint error, then we cannot
1118 -- know the result at compile time (since CE may be raised).
1120 if not (Cannot_Raise_Constraint_Error (L)
1122 Cannot_Raise_Constraint_Error (R))
1127 -- Identical operands are most certainly equal
1133 -- If expressions have no types, then do not attempt to determine if
1134 -- they are the same, since something funny is going on. One case in
1135 -- which this happens is during generic template analysis, when bounds
1136 -- are not fully analyzed.
1138 if No (Ltyp) or else No (Rtyp) then
1142 -- These get reset to the base type for the case of entities where
1143 -- Is_Known_Valid is not set. This takes care of handling possible
1144 -- invalid representations using the value of the base type, in
1145 -- accordance with RM 13.9.1(10).
1147 Ltyp := Underlying_Type (Ltyp);
1148 Rtyp := Underlying_Type (Rtyp);
1150 -- Same rationale as above, but for Underlying_Type instead of Etype
1152 if No (Ltyp) or else No (Rtyp) then
1156 -- We do not attempt comparisons for packed arrays represented as
1157 -- modular types, where the semantics of comparison is quite different.
1159 if Is_Packed_Array_Impl_Type (Ltyp)
1160 and then Is_Modular_Integer_Type (Ltyp)
1164 -- For access types, the only time we know the result at compile time
1165 -- (apart from identical operands, which we handled already) is if we
1166 -- know one operand is null and the other is not, or both operands are
1169 elsif Is_Access_Type (Ltyp) then
1170 if Known_Null (L) then
1171 if Known_Null (R) then
1173 elsif Known_Non_Null (R) then
1179 elsif Known_Non_Null (L) and then Known_Null (R) then
1186 -- Case where comparison involves two compile time known values
1188 elsif Compile_Time_Known_Value (L)
1190 Compile_Time_Known_Value (R)
1192 -- For the floating-point case, we have to be a little careful, since
1193 -- at compile time we are dealing with universal exact values, but at
1194 -- runtime, these will be in non-exact target form. That's why the
1195 -- returned results are LE and GE below instead of LT and GT.
1197 if Is_Floating_Point_Type (Ltyp)
1199 Is_Floating_Point_Type (Rtyp)
1202 Lo : constant Ureal := Expr_Value_R (L);
1203 Hi : constant Ureal := Expr_Value_R (R);
1214 -- For string types, we have two string literals and we proceed to
1215 -- compare them using the Ada style dictionary string comparison.
1217 elsif not Is_Scalar_Type (Ltyp) then
1219 Lstring : constant String_Id := Strval (Expr_Value_S (L));
1220 Rstring : constant String_Id := Strval (Expr_Value_S (R));
1221 Llen : constant Nat := String_Length (Lstring);
1222 Rlen : constant Nat := String_Length (Rstring);
1225 for J in 1 .. Nat'Min (Llen, Rlen) loop
1227 LC : constant Char_Code := Get_String_Char (Lstring, J);
1228 RC : constant Char_Code := Get_String_Char (Rstring, J);
1240 elsif Llen > Rlen then
1247 -- For remaining scalar cases we know exactly (note that this does
1248 -- include the fixed-point case, where we know the run time integer
1253 Lo : constant Uint := Expr_Value (L);
1254 Hi : constant Uint := Expr_Value (R);
1257 Diff.all := Hi - Lo;
1262 Diff.all := Lo - Hi;
1268 -- Cases where at least one operand is not known at compile time
1271 -- Remaining checks apply only for discrete types
1273 if not Is_Discrete_Type (Ltyp)
1275 not Is_Discrete_Type (Rtyp)
1280 -- Defend against generic types, or actually any expressions that
1281 -- contain a reference to a generic type from within a generic
1282 -- template. We don't want to do any range analysis of such
1283 -- expressions for two reasons. First, the bounds of a generic type
1284 -- itself are junk and cannot be used for any kind of analysis.
1285 -- Second, we may have a case where the range at run time is indeed
1286 -- known, but we don't want to do compile time analysis in the
1287 -- template based on that range since in an instance the value may be
1288 -- static, and able to be elaborated without reference to the bounds
1289 -- of types involved. As an example, consider:
1291 -- (F'Pos (F'Last) + 1) > Integer'Last
1293 -- The expression on the left side of > is Universal_Integer and thus
1294 -- acquires the type Integer for evaluation at run time, and at run
1295 -- time it is true that this condition is always False, but within
1296 -- an instance F may be a type with a static range greater than the
1297 -- range of Integer, and the expression statically evaluates to True.
1299 if References_Generic_Formal_Type (L)
1301 References_Generic_Formal_Type (R)
1306 -- Replace types by base types for the case of values which are not
1307 -- known to have valid representations. This takes care of properly
1308 -- dealing with invalid representations.
1310 if not Assume_Valid then
1311 if not (Is_Entity_Name (L)
1312 and then (Is_Known_Valid (Entity (L))
1313 or else Assume_No_Invalid_Values))
1315 Ltyp := Underlying_Type (Base_Type (Ltyp));
1318 if not (Is_Entity_Name (R)
1319 and then (Is_Known_Valid (Entity (R))
1320 or else Assume_No_Invalid_Values))
1322 Rtyp := Underlying_Type (Base_Type (Rtyp));
1326 -- First attempt is to decompose the expressions to extract a
1327 -- constant offset resulting from the use of any of the forms:
1334 -- Then we see if the two expressions are the same value, and if so
1335 -- the result is obtained by comparing the offsets.
1337 -- Note: the reason we do this test first is that it returns only
1338 -- decisive results (with diff set), where other tests, like the
1339 -- range test, may not be as so decisive. Consider for example
1340 -- J .. J + 1. This code can conclude LT with a difference of 1,
1341 -- even if the range of J is not known.
1350 Compare_Decompose (L, Lnode, Loffs);
1351 Compare_Decompose (R, Rnode, Roffs);
1353 if Is_Same_Value (Lnode, Rnode) then
1354 if Loffs = Roffs then
1358 -- When the offsets are not equal, we can go farther only if
1359 -- the types are not modular (e.g. X < X + 1 is False if X is
1360 -- the largest number).
1362 if not Is_Modular_Integer_Type (Ltyp)
1363 and then not Is_Modular_Integer_Type (Rtyp)
1365 if Loffs < Roffs then
1366 Diff.all := Roffs - Loffs;
1369 Diff.all := Loffs - Roffs;
1376 -- Next, try range analysis and see if operand ranges are disjoint
1384 -- True if each range is a single point
1387 Determine_Range (L, LOK, LLo, LHi, Assume_Valid);
1388 Determine_Range (R, ROK, RLo, RHi, Assume_Valid);
1391 Single := (LLo = LHi) and then (RLo = RHi);
1394 if Single and Assume_Valid then
1395 Diff.all := RLo - LLo;
1400 elsif RHi < LLo then
1401 if Single and Assume_Valid then
1402 Diff.all := LLo - RLo;
1407 elsif Single and then LLo = RLo then
1409 -- If the range includes a single literal and we can assume
1410 -- validity then the result is known even if an operand is
1413 if Assume_Valid then
1419 elsif LHi = RLo then
1422 elsif RHi = LLo then
1425 elsif not Is_Known_Valid_Operand (L)
1426 and then not Assume_Valid
1428 if Is_Same_Value (L, R) then
1435 -- If the range of either operand cannot be determined, nothing
1436 -- further can be inferred.
1443 -- Here is where we check for comparisons against maximum bounds of
1444 -- types, where we know that no value can be outside the bounds of
1445 -- the subtype. Note that this routine is allowed to assume that all
1446 -- expressions are within their subtype bounds. Callers wishing to
1447 -- deal with possibly invalid values must in any case take special
1448 -- steps (e.g. conversions to larger types) to avoid this kind of
1449 -- optimization, which is always considered to be valid. We do not
1450 -- attempt this optimization with generic types, since the type
1451 -- bounds may not be meaningful in this case.
1453 -- We are in danger of an infinite recursion here. It does not seem
1454 -- useful to go more than one level deep, so the parameter Rec is
1455 -- used to protect ourselves against this infinite recursion.
1459 -- See if we can get a decisive check against one operand and a
1460 -- bound of the other operand (four possible tests here). Note
1461 -- that we avoid testing junk bounds of a generic type.
1463 if not Is_Generic_Type (Rtyp) then
1464 case Compile_Time_Compare (L, Type_Low_Bound (Rtyp),
1466 Assume_Valid, Rec => True)
1468 when LT => return LT;
1469 when LE => return LE;
1470 when EQ => return LE;
1471 when others => null;
1474 case Compile_Time_Compare (L, Type_High_Bound (Rtyp),
1476 Assume_Valid, Rec => True)
1478 when GT => return GT;
1479 when GE => return GE;
1480 when EQ => return GE;
1481 when others => null;
1485 if not Is_Generic_Type (Ltyp) then
1486 case Compile_Time_Compare (Type_Low_Bound (Ltyp), R,
1488 Assume_Valid, Rec => True)
1490 when GT => return GT;
1491 when GE => return GE;
1492 when EQ => return GE;
1493 when others => null;
1496 case Compile_Time_Compare (Type_High_Bound (Ltyp), R,
1498 Assume_Valid, Rec => True)
1500 when LT => return LT;
1501 when LE => return LE;
1502 when EQ => return LE;
1503 when others => null;
1508 -- Next attempt is to see if we have an entity compared with a
1509 -- compile time known value, where there is a current value
1510 -- conditional for the entity which can tell us the result.
1514 -- Entity variable (left operand)
1517 -- Value (right operand)
1520 -- If False, we have reversed the operands
1523 -- Comparison operator kind from Get_Current_Value_Condition call
1526 -- Value from Get_Current_Value_Condition call
1531 Result : Compare_Result;
1532 -- Known result before inversion
1535 if Is_Entity_Name (L)
1536 and then Compile_Time_Known_Value (R)
1539 Val := Expr_Value (R);
1542 elsif Is_Entity_Name (R)
1543 and then Compile_Time_Known_Value (L)
1546 Val := Expr_Value (L);
1549 -- That was the last chance at finding a compile time result
1555 Get_Current_Value_Condition (Var, Op, Opn);
1557 -- That was the last chance, so if we got nothing return
1563 Opv := Expr_Value (Opn);
1565 -- We got a comparison, so we might have something interesting
1567 -- Convert LE to LT and GE to GT, just so we have fewer cases
1569 if Op = N_Op_Le then
1573 elsif Op = N_Op_Ge then
1578 -- Deal with equality case
1580 if Op = N_Op_Eq then
1583 elsif Opv < Val then
1589 -- Deal with inequality case
1591 elsif Op = N_Op_Ne then
1598 -- Deal with greater than case
1600 elsif Op = N_Op_Gt then
1603 elsif Opv = Val - 1 then
1609 -- Deal with less than case
1611 else pragma Assert (Op = N_Op_Lt);
1614 elsif Opv = Val + 1 then
1621 -- Deal with inverting result
1625 when GT => return LT;
1626 when GE => return LE;
1627 when LT => return GT;
1628 when LE => return GE;
1629 when others => return Result;
1636 end Compile_Time_Compare;
1638 -------------------------------
1639 -- Compile_Time_Known_Bounds --
1640 -------------------------------
1642 function Compile_Time_Known_Bounds (T : Entity_Id) return Boolean is
1647 if T = Any_Composite or else not Is_Array_Type (T) then
1651 Indx := First_Index (T);
1652 while Present (Indx) loop
1653 Typ := Underlying_Type (Etype (Indx));
1655 -- Never look at junk bounds of a generic type
1657 if Is_Generic_Type (Typ) then
1661 -- Otherwise check bounds for compile time known
1663 if not Compile_Time_Known_Value (Type_Low_Bound (Typ)) then
1665 elsif not Compile_Time_Known_Value (Type_High_Bound (Typ)) then
1673 end Compile_Time_Known_Bounds;
1675 ------------------------------
1676 -- Compile_Time_Known_Value --
1677 ------------------------------
1679 function Compile_Time_Known_Value (Op : Node_Id) return Boolean is
1680 K : constant Node_Kind := Nkind (Op);
1681 CV_Ent : CV_Entry renames CV_Cache (Nat (Op) mod CV_Cache_Size);
1684 -- Never known at compile time if bad type or raises constraint error
1685 -- or empty (latter case occurs only as a result of a previous error).
1688 Check_Error_Detected;
1692 or else Etype (Op) = Any_Type
1693 or else Raises_Constraint_Error (Op)
1698 -- If we have an entity name, then see if it is the name of a constant
1699 -- and if so, test the corresponding constant value, or the name of
1700 -- an enumeration literal, which is always a constant.
1702 if Present (Etype (Op)) and then Is_Entity_Name (Op) then
1704 E : constant Entity_Id := Entity (Op);
1708 -- Never known at compile time if it is a packed array value.
1709 -- We might want to try to evaluate these at compile time one
1710 -- day, but we do not make that attempt now.
1712 if Is_Packed_Array_Impl_Type (Etype (Op)) then
1716 if Ekind (E) = E_Enumeration_Literal then
1719 elsif Ekind (E) = E_Constant then
1720 V := Constant_Value (E);
1721 return Present (V) and then Compile_Time_Known_Value (V);
1725 -- We have a value, see if it is compile time known
1728 -- Integer literals are worth storing in the cache
1730 if K = N_Integer_Literal then
1732 CV_Ent.V := Intval (Op);
1735 -- Other literals and NULL are known at compile time
1738 Nkind_In (K, N_Character_Literal,
1747 -- If we fall through, not known at compile time
1751 -- If we get an exception while trying to do this test, then some error
1752 -- has occurred, and we simply say that the value is not known after all
1757 end Compile_Time_Known_Value;
1759 --------------------------------------
1760 -- Compile_Time_Known_Value_Or_Aggr --
1761 --------------------------------------
1763 function Compile_Time_Known_Value_Or_Aggr (Op : Node_Id) return Boolean is
1765 -- If we have an entity name, then see if it is the name of a constant
1766 -- and if so, test the corresponding constant value, or the name of
1767 -- an enumeration literal, which is always a constant.
1769 if Is_Entity_Name (Op) then
1771 E : constant Entity_Id := Entity (Op);
1775 if Ekind (E) = E_Enumeration_Literal then
1778 elsif Ekind (E) /= E_Constant then
1782 V := Constant_Value (E);
1784 and then Compile_Time_Known_Value_Or_Aggr (V);
1788 -- We have a value, see if it is compile time known
1791 if Compile_Time_Known_Value (Op) then
1794 elsif Nkind (Op) = N_Aggregate then
1796 if Present (Expressions (Op)) then
1800 Expr := First (Expressions (Op));
1801 while Present (Expr) loop
1802 if not Compile_Time_Known_Value_Or_Aggr (Expr) then
1811 if Present (Component_Associations (Op)) then
1816 Cass := First (Component_Associations (Op));
1817 while Present (Cass) loop
1819 Compile_Time_Known_Value_Or_Aggr (Expression (Cass))
1831 elsif Nkind (Op) = N_Qualified_Expression then
1832 return Compile_Time_Known_Value_Or_Aggr (Expression (Op));
1834 -- All other types of values are not known at compile time
1841 end Compile_Time_Known_Value_Or_Aggr;
1843 ---------------------------------------
1844 -- CRT_Safe_Compile_Time_Known_Value --
1845 ---------------------------------------
1847 function CRT_Safe_Compile_Time_Known_Value (Op : Node_Id) return Boolean is
1849 if (Configurable_Run_Time_Mode or No_Run_Time_Mode)
1850 and then not Is_OK_Static_Expression (Op)
1854 return Compile_Time_Known_Value (Op);
1856 end CRT_Safe_Compile_Time_Known_Value;
1862 -- This is only called for actuals of functions that are not predefined
1863 -- operators (which have already been rewritten as operators at this
1864 -- stage), so the call can never be folded, and all that needs doing for
1865 -- the actual is to do the check for a non-static context.
1867 procedure Eval_Actual (N : Node_Id) is
1869 Check_Non_Static_Context (N);
1872 --------------------
1873 -- Eval_Allocator --
1874 --------------------
1876 -- Allocators are never static, so all we have to do is to do the
1877 -- check for a non-static context if an expression is present.
1879 procedure Eval_Allocator (N : Node_Id) is
1880 Expr : constant Node_Id := Expression (N);
1882 if Nkind (Expr) = N_Qualified_Expression then
1883 Check_Non_Static_Context (Expression (Expr));
1887 ------------------------
1888 -- Eval_Arithmetic_Op --
1889 ------------------------
1891 -- Arithmetic operations are static functions, so the result is static
1892 -- if both operands are static (RM 4.9(7), 4.9(20)).
1894 procedure Eval_Arithmetic_Op (N : Node_Id) is
1895 Left : constant Node_Id := Left_Opnd (N);
1896 Right : constant Node_Id := Right_Opnd (N);
1897 Ltype : constant Entity_Id := Etype (Left);
1898 Rtype : constant Entity_Id := Etype (Right);
1899 Otype : Entity_Id := Empty;
1904 -- If not foldable we are done
1906 Test_Expression_Is_Foldable (N, Left, Right, Stat, Fold);
1912 -- Otherwise attempt to fold
1914 if Is_Universal_Numeric_Type (Etype (Left))
1916 Is_Universal_Numeric_Type (Etype (Right))
1918 Otype := Find_Universal_Operator_Type (N);
1921 -- Fold for cases where both operands are of integer type
1923 if Is_Integer_Type (Ltype) and then Is_Integer_Type (Rtype) then
1925 Left_Int : constant Uint := Expr_Value (Left);
1926 Right_Int : constant Uint := Expr_Value (Right);
1932 Result := Left_Int + Right_Int;
1934 when N_Op_Subtract =>
1935 Result := Left_Int - Right_Int;
1937 when N_Op_Multiply =>
1940 (Num_Bits (Left_Int) + Num_Bits (Right_Int)))
1942 Result := Left_Int * Right_Int;
1949 -- The exception Constraint_Error is raised by integer
1950 -- division, rem and mod if the right operand is zero.
1952 if Right_Int = 0 then
1954 -- When SPARK_Mode is On, force a warning instead of
1955 -- an error in that case, as this likely corresponds
1956 -- to deactivated code.
1958 Apply_Compile_Time_Constraint_Error
1959 (N, "division by zero", CE_Divide_By_Zero,
1960 Warn => not Stat or SPARK_Mode = On);
1961 Set_Raises_Constraint_Error (N);
1964 -- Otherwise we can do the division
1967 Result := Left_Int / Right_Int;
1972 -- The exception Constraint_Error is raised by integer
1973 -- division, rem and mod if the right operand is zero.
1975 if Right_Int = 0 then
1977 -- When SPARK_Mode is On, force a warning instead of
1978 -- an error in that case, as this likely corresponds
1979 -- to deactivated code.
1981 Apply_Compile_Time_Constraint_Error
1982 (N, "mod with zero divisor", CE_Divide_By_Zero,
1983 Warn => not Stat or SPARK_Mode = On);
1987 Result := Left_Int mod Right_Int;
1992 -- The exception Constraint_Error is raised by integer
1993 -- division, rem and mod if the right operand is zero.
1995 if Right_Int = 0 then
1997 -- When SPARK_Mode is On, force a warning instead of
1998 -- an error in that case, as this likely corresponds
1999 -- to deactivated code.
2001 Apply_Compile_Time_Constraint_Error
2002 (N, "rem with zero divisor", CE_Divide_By_Zero,
2003 Warn => not Stat or SPARK_Mode = On);
2007 Result := Left_Int rem Right_Int;
2011 raise Program_Error;
2014 -- Adjust the result by the modulus if the type is a modular type
2016 if Is_Modular_Integer_Type (Ltype) then
2017 Result := Result mod Modulus (Ltype);
2019 -- For a signed integer type, check non-static overflow
2021 elsif (not Stat) and then Is_Signed_Integer_Type (Ltype) then
2023 BT : constant Entity_Id := Base_Type (Ltype);
2024 Lo : constant Uint := Expr_Value (Type_Low_Bound (BT));
2025 Hi : constant Uint := Expr_Value (Type_High_Bound (BT));
2027 if Result < Lo or else Result > Hi then
2028 Apply_Compile_Time_Constraint_Error
2029 (N, "value not in range of }??",
2030 CE_Overflow_Check_Failed,
2037 -- If we get here we can fold the result
2039 Fold_Uint (N, Result, Stat);
2042 -- Cases where at least one operand is a real. We handle the cases of
2043 -- both reals, or mixed/real integer cases (the latter happen only for
2044 -- divide and multiply, and the result is always real).
2046 elsif Is_Real_Type (Ltype) or else Is_Real_Type (Rtype) then
2053 if Is_Real_Type (Ltype) then
2054 Left_Real := Expr_Value_R (Left);
2056 Left_Real := UR_From_Uint (Expr_Value (Left));
2059 if Is_Real_Type (Rtype) then
2060 Right_Real := Expr_Value_R (Right);
2062 Right_Real := UR_From_Uint (Expr_Value (Right));
2065 if Nkind (N) = N_Op_Add then
2066 Result := Left_Real + Right_Real;
2068 elsif Nkind (N) = N_Op_Subtract then
2069 Result := Left_Real - Right_Real;
2071 elsif Nkind (N) = N_Op_Multiply then
2072 Result := Left_Real * Right_Real;
2074 else pragma Assert (Nkind (N) = N_Op_Divide);
2075 if UR_Is_Zero (Right_Real) then
2076 Apply_Compile_Time_Constraint_Error
2077 (N, "division by zero", CE_Divide_By_Zero);
2081 Result := Left_Real / Right_Real;
2084 Fold_Ureal (N, Result, Stat);
2088 -- If the operator was resolved to a specific type, make sure that type
2089 -- is frozen even if the expression is folded into a literal (which has
2090 -- a universal type).
2092 if Present (Otype) then
2093 Freeze_Before (N, Otype);
2095 end Eval_Arithmetic_Op;
2097 ----------------------------
2098 -- Eval_Character_Literal --
2099 ----------------------------
2101 -- Nothing to be done
2103 procedure Eval_Character_Literal (N : Node_Id) is
2104 pragma Warnings (Off, N);
2107 end Eval_Character_Literal;
2113 -- Static function calls are either calls to predefined operators
2114 -- with static arguments, or calls to functions that rename a literal.
2115 -- Only the latter case is handled here, predefined operators are
2116 -- constant-folded elsewhere.
2118 -- If the function is itself inherited (see 7423-001) the literal of
2119 -- the parent type must be explicitly converted to the return type
2122 procedure Eval_Call (N : Node_Id) is
2123 Loc : constant Source_Ptr := Sloc (N);
2124 Typ : constant Entity_Id := Etype (N);
2128 if Nkind (N) = N_Function_Call
2129 and then No (Parameter_Associations (N))
2130 and then Is_Entity_Name (Name (N))
2131 and then Present (Alias (Entity (Name (N))))
2132 and then Is_Enumeration_Type (Base_Type (Typ))
2134 Lit := Ultimate_Alias (Entity (Name (N)));
2136 if Ekind (Lit) = E_Enumeration_Literal then
2137 if Base_Type (Etype (Lit)) /= Base_Type (Typ) then
2139 (N, Convert_To (Typ, New_Occurrence_Of (Lit, Loc)));
2141 Rewrite (N, New_Occurrence_Of (Lit, Loc));
2149 --------------------------
2150 -- Eval_Case_Expression --
2151 --------------------------
2153 -- A conditional expression is static if all its conditions and dependent
2154 -- expressions are static. Note that we do not care if the dependent
2155 -- expressions raise CE, except for the one that will be selected.
2157 procedure Eval_Case_Expression (N : Node_Id) is
2162 Set_Is_Static_Expression (N, False);
2164 if Error_Posted (Expression (N))
2165 or else not Is_Static_Expression (Expression (N))
2167 Check_Non_Static_Context (Expression (N));
2171 -- First loop, make sure all the alternatives are static expressions
2172 -- none of which raise Constraint_Error. We make the constraint error
2173 -- check because part of the legality condition for a correct static
2174 -- case expression is that the cases are covered, like any other case
2175 -- expression. And we can't do that if any of the conditions raise an
2176 -- exception, so we don't even try to evaluate if that is the case.
2178 Alt := First (Alternatives (N));
2179 while Present (Alt) loop
2181 -- The expression must be static, but we don't care at this stage
2182 -- if it raises Constraint_Error (the alternative might not match,
2183 -- in which case the expression is statically unevaluated anyway).
2185 if not Is_Static_Expression (Expression (Alt)) then
2186 Check_Non_Static_Context (Expression (Alt));
2190 -- The choices of a case always have to be static, and cannot raise
2191 -- an exception. If this condition is not met, then the expression
2192 -- is plain illegal, so just abandon evaluation attempts. No need
2193 -- to check non-static context when we have something illegal anyway.
2195 if not Is_OK_Static_Choice_List (Discrete_Choices (Alt)) then
2202 -- OK, if the above loop gets through it means that all choices are OK
2203 -- static (don't raise exceptions), so the whole case is static, and we
2204 -- can find the matching alternative.
2206 Set_Is_Static_Expression (N);
2208 -- Now to deal with propagating a possible constraint error
2210 -- If the selecting expression raises CE, propagate and we are done
2212 if Raises_Constraint_Error (Expression (N)) then
2213 Set_Raises_Constraint_Error (N);
2215 -- Otherwise we need to check the alternatives to find the matching
2216 -- one. CE's in other than the matching one are not relevant. But we
2217 -- do need to check the matching one. Unlike the first loop, we do not
2218 -- have to go all the way through, when we find the matching one, quit.
2221 Alt := First (Alternatives (N));
2224 -- We must find a match among the alternatives. If not, this must
2225 -- be due to other errors, so just ignore, leaving as non-static.
2228 Set_Is_Static_Expression (N, False);
2232 -- Otherwise loop through choices of this alternative
2234 Choice := First (Discrete_Choices (Alt));
2235 while Present (Choice) loop
2237 -- If we find a matching choice, then the Expression of this
2238 -- alternative replaces N (Raises_Constraint_Error flag is
2239 -- included, so we don't have to special case that).
2241 if Choice_Matches (Expression (N), Choice) = Match then
2242 Rewrite (N, Relocate_Node (Expression (Alt)));
2252 end Eval_Case_Expression;
2254 ------------------------
2255 -- Eval_Concatenation --
2256 ------------------------
2258 -- Concatenation is a static function, so the result is static if both
2259 -- operands are static (RM 4.9(7), 4.9(21)).
2261 procedure Eval_Concatenation (N : Node_Id) is
2262 Left : constant Node_Id := Left_Opnd (N);
2263 Right : constant Node_Id := Right_Opnd (N);
2264 C_Typ : constant Entity_Id := Root_Type (Component_Type (Etype (N)));
2269 -- Concatenation is never static in Ada 83, so if Ada 83 check operand
2270 -- non-static context.
2272 if Ada_Version = Ada_83
2273 and then Comes_From_Source (N)
2275 Check_Non_Static_Context (Left);
2276 Check_Non_Static_Context (Right);
2280 -- If not foldable we are done. In principle concatenation that yields
2281 -- any string type is static (i.e. an array type of character types).
2282 -- However, character types can include enumeration literals, and
2283 -- concatenation in that case cannot be described by a literal, so we
2284 -- only consider the operation static if the result is an array of
2285 -- (a descendant of) a predefined character type.
2287 Test_Expression_Is_Foldable (N, Left, Right, Stat, Fold);
2289 if not (Is_Standard_Character_Type (C_Typ) and then Fold) then
2290 Set_Is_Static_Expression (N, False);
2294 -- Compile time string concatenation
2296 -- ??? Note that operands that are aggregates can be marked as static,
2297 -- so we should attempt at a later stage to fold concatenations with
2301 Left_Str : constant Node_Id := Get_String_Val (Left);
2303 Right_Str : constant Node_Id := Get_String_Val (Right);
2304 Folded_Val : String_Id;
2307 -- Establish new string literal, and store left operand. We make
2308 -- sure to use the special Start_String that takes an operand if
2309 -- the left operand is a string literal. Since this is optimized
2310 -- in the case where that is the most recently created string
2311 -- literal, we ensure efficient time/space behavior for the
2312 -- case of a concatenation of a series of string literals.
2314 if Nkind (Left_Str) = N_String_Literal then
2315 Left_Len := String_Length (Strval (Left_Str));
2317 -- If the left operand is the empty string, and the right operand
2318 -- is a string literal (the case of "" & "..."), the result is the
2319 -- value of the right operand. This optimization is important when
2320 -- Is_Folded_In_Parser, to avoid copying an enormous right
2323 if Left_Len = 0 and then Nkind (Right_Str) = N_String_Literal then
2324 Folded_Val := Strval (Right_Str);
2326 Start_String (Strval (Left_Str));
2331 Store_String_Char (UI_To_CC (Char_Literal_Value (Left_Str)));
2335 -- Now append the characters of the right operand, unless we
2336 -- optimized the "" & "..." case above.
2338 if Nkind (Right_Str) = N_String_Literal then
2339 if Left_Len /= 0 then
2340 Store_String_Chars (Strval (Right_Str));
2341 Folded_Val := End_String;
2344 Store_String_Char (UI_To_CC (Char_Literal_Value (Right_Str)));
2345 Folded_Val := End_String;
2348 Set_Is_Static_Expression (N, Stat);
2350 -- If left operand is the empty string, the result is the
2351 -- right operand, including its bounds if anomalous.
2354 and then Is_Array_Type (Etype (Right))
2355 and then Etype (Right) /= Any_String
2357 Set_Etype (N, Etype (Right));
2360 Fold_Str (N, Folded_Val, Static => Stat);
2362 end Eval_Concatenation;
2364 ----------------------
2365 -- Eval_Entity_Name --
2366 ----------------------
2368 -- This procedure is used for identifiers and expanded names other than
2369 -- named numbers (see Eval_Named_Integer, Eval_Named_Real. These are
2370 -- static if they denote a static constant (RM 4.9(6)) or if the name
2371 -- denotes an enumeration literal (RM 4.9(22)).
2373 procedure Eval_Entity_Name (N : Node_Id) is
2374 Def_Id : constant Entity_Id := Entity (N);
2378 -- Enumeration literals are always considered to be constants
2379 -- and cannot raise constraint error (RM 4.9(22)).
2381 if Ekind (Def_Id) = E_Enumeration_Literal then
2382 Set_Is_Static_Expression (N);
2385 -- A name is static if it denotes a static constant (RM 4.9(5)), and
2386 -- we also copy Raise_Constraint_Error. Notice that even if non-static,
2387 -- it does not violate 10.2.1(8) here, since this is not a variable.
2389 elsif Ekind (Def_Id) = E_Constant then
2391 -- Deferred constants must always be treated as nonstatic outside the
2392 -- scope of their full view.
2394 if Present (Full_View (Def_Id))
2395 and then not In_Open_Scopes (Scope (Def_Id))
2399 Val := Constant_Value (Def_Id);
2402 if Present (Val) then
2403 Set_Is_Static_Expression
2404 (N, Is_Static_Expression (Val)
2405 and then Is_Static_Subtype (Etype (Def_Id)));
2406 Set_Raises_Constraint_Error (N, Raises_Constraint_Error (Val));
2408 if not Is_Static_Expression (N)
2409 and then not Is_Generic_Type (Etype (N))
2411 Validate_Static_Object_Name (N);
2414 -- Mark constant condition in SCOs
2417 and then Comes_From_Source (N)
2418 and then Is_Boolean_Type (Etype (Def_Id))
2419 and then Compile_Time_Known_Value (N)
2421 Set_SCO_Condition (N, Expr_Value_E (N) = Standard_True);
2428 -- Fall through if the name is not static
2430 Validate_Static_Object_Name (N);
2431 end Eval_Entity_Name;
2433 ------------------------
2434 -- Eval_If_Expression --
2435 ------------------------
2437 -- We can fold to a static expression if the condition and both dependent
2438 -- expressions are static. Otherwise, the only required processing is to do
2439 -- the check for non-static context for the then and else expressions.
2441 procedure Eval_If_Expression (N : Node_Id) is
2442 Condition : constant Node_Id := First (Expressions (N));
2443 Then_Expr : constant Node_Id := Next (Condition);
2444 Else_Expr : constant Node_Id := Next (Then_Expr);
2446 Non_Result : Node_Id;
2448 Rstat : constant Boolean :=
2449 Is_Static_Expression (Condition)
2451 Is_Static_Expression (Then_Expr)
2453 Is_Static_Expression (Else_Expr);
2454 -- True if result is static
2457 -- If result not static, nothing to do, otherwise set static result
2462 Set_Is_Static_Expression (N);
2465 -- If any operand is Any_Type, just propagate to result and do not try
2466 -- to fold, this prevents cascaded errors.
2468 if Etype (Condition) = Any_Type or else
2469 Etype (Then_Expr) = Any_Type or else
2470 Etype (Else_Expr) = Any_Type
2472 Set_Etype (N, Any_Type);
2473 Set_Is_Static_Expression (N, False);
2477 -- If condition raises constraint error then we have already signaled
2478 -- an error, and we just propagate to the result and do not fold.
2480 if Raises_Constraint_Error (Condition) then
2481 Set_Raises_Constraint_Error (N);
2485 -- Static case where we can fold. Note that we don't try to fold cases
2486 -- where the condition is known at compile time, but the result is
2487 -- non-static. This avoids possible cases of infinite recursion where
2488 -- the expander puts in a redundant test and we remove it. Instead we
2489 -- deal with these cases in the expander.
2491 -- Select result operand
2493 if Is_True (Expr_Value (Condition)) then
2494 Result := Then_Expr;
2495 Non_Result := Else_Expr;
2497 Result := Else_Expr;
2498 Non_Result := Then_Expr;
2501 -- Note that it does not matter if the non-result operand raises a
2502 -- Constraint_Error, but if the result raises constraint error then we
2503 -- replace the node with a raise constraint error. This will properly
2504 -- propagate Raises_Constraint_Error since this flag is set in Result.
2506 if Raises_Constraint_Error (Result) then
2507 Rewrite_In_Raise_CE (N, Result);
2508 Check_Non_Static_Context (Non_Result);
2510 -- Otherwise the result operand replaces the original node
2513 Rewrite (N, Relocate_Node (Result));
2514 Set_Is_Static_Expression (N);
2516 end Eval_If_Expression;
2518 ----------------------------
2519 -- Eval_Indexed_Component --
2520 ----------------------------
2522 -- Indexed components are never static, so we need to perform the check
2523 -- for non-static context on the index values. Then, we check if the
2524 -- value can be obtained at compile time, even though it is non-static.
2526 procedure Eval_Indexed_Component (N : Node_Id) is
2530 -- Check for non-static context on index values
2532 Expr := First (Expressions (N));
2533 while Present (Expr) loop
2534 Check_Non_Static_Context (Expr);
2538 -- If the indexed component appears in an object renaming declaration
2539 -- then we do not want to try to evaluate it, since in this case we
2540 -- need the identity of the array element.
2542 if Nkind (Parent (N)) = N_Object_Renaming_Declaration then
2545 -- Similarly if the indexed component appears as the prefix of an
2546 -- attribute we don't want to evaluate it, because at least for
2547 -- some cases of attributes we need the identify (e.g. Access, Size)
2549 elsif Nkind (Parent (N)) = N_Attribute_Reference then
2553 -- Note: there are other cases, such as the left side of an assignment,
2554 -- or an OUT parameter for a call, where the replacement results in the
2555 -- illegal use of a constant, But these cases are illegal in the first
2556 -- place, so the replacement, though silly, is harmless.
2558 -- Now see if this is a constant array reference
2560 if List_Length (Expressions (N)) = 1
2561 and then Is_Entity_Name (Prefix (N))
2562 and then Ekind (Entity (Prefix (N))) = E_Constant
2563 and then Present (Constant_Value (Entity (Prefix (N))))
2566 Loc : constant Source_Ptr := Sloc (N);
2567 Arr : constant Node_Id := Constant_Value (Entity (Prefix (N)));
2568 Sub : constant Node_Id := First (Expressions (N));
2574 -- Linear one's origin subscript value for array reference
2577 -- Lower bound of the first array index
2580 -- Value from constant array
2583 Atyp := Etype (Arr);
2585 if Is_Access_Type (Atyp) then
2586 Atyp := Designated_Type (Atyp);
2589 -- If we have an array type (we should have but perhaps there are
2590 -- error cases where this is not the case), then see if we can do
2591 -- a constant evaluation of the array reference.
2593 if Is_Array_Type (Atyp) and then Atyp /= Any_Composite then
2594 if Ekind (Atyp) = E_String_Literal_Subtype then
2595 Lbd := String_Literal_Low_Bound (Atyp);
2597 Lbd := Type_Low_Bound (Etype (First_Index (Atyp)));
2600 if Compile_Time_Known_Value (Sub)
2601 and then Nkind (Arr) = N_Aggregate
2602 and then Compile_Time_Known_Value (Lbd)
2603 and then Is_Discrete_Type (Component_Type (Atyp))
2605 Lin := UI_To_Int (Expr_Value (Sub) - Expr_Value (Lbd)) + 1;
2607 if List_Length (Expressions (Arr)) >= Lin then
2608 Elm := Pick (Expressions (Arr), Lin);
2610 -- If the resulting expression is compile time known,
2611 -- then we can rewrite the indexed component with this
2612 -- value, being sure to mark the result as non-static.
2613 -- We also reset the Sloc, in case this generates an
2614 -- error later on (e.g. 136'Access).
2616 if Compile_Time_Known_Value (Elm) then
2617 Rewrite (N, Duplicate_Subexpr_No_Checks (Elm));
2618 Set_Is_Static_Expression (N, False);
2623 -- We can also constant-fold if the prefix is a string literal.
2624 -- This will be useful in an instantiation or an inlining.
2626 elsif Compile_Time_Known_Value (Sub)
2627 and then Nkind (Arr) = N_String_Literal
2628 and then Compile_Time_Known_Value (Lbd)
2629 and then Expr_Value (Lbd) = 1
2630 and then Expr_Value (Sub) <=
2631 String_Literal_Length (Etype (Arr))
2634 C : constant Char_Code :=
2635 Get_String_Char (Strval (Arr),
2636 UI_To_Int (Expr_Value (Sub)));
2638 Set_Character_Literal_Name (C);
2641 Make_Character_Literal (Loc,
2643 Char_Literal_Value => UI_From_CC (C));
2644 Set_Etype (Elm, Component_Type (Atyp));
2645 Rewrite (N, Duplicate_Subexpr_No_Checks (Elm));
2646 Set_Is_Static_Expression (N, False);
2652 end Eval_Indexed_Component;
2654 --------------------------
2655 -- Eval_Integer_Literal --
2656 --------------------------
2658 -- Numeric literals are static (RM 4.9(1)), and have already been marked
2659 -- as static by the analyzer. The reason we did it that early is to allow
2660 -- the possibility of turning off the Is_Static_Expression flag after
2661 -- analysis, but before resolution, when integer literals are generated in
2662 -- the expander that do not correspond to static expressions.
2664 procedure Eval_Integer_Literal (N : Node_Id) is
2665 T : constant Entity_Id := Etype (N);
2667 function In_Any_Integer_Context return Boolean;
2668 -- If the literal is resolved with a specific type in a context where
2669 -- the expected type is Any_Integer, there are no range checks on the
2670 -- literal. By the time the literal is evaluated, it carries the type
2671 -- imposed by the enclosing expression, and we must recover the context
2672 -- to determine that Any_Integer is meant.
2674 ----------------------------
2675 -- In_Any_Integer_Context --
2676 ----------------------------
2678 function In_Any_Integer_Context return Boolean is
2679 Par : constant Node_Id := Parent (N);
2680 K : constant Node_Kind := Nkind (Par);
2683 -- Any_Integer also appears in digits specifications for real types,
2684 -- but those have bounds smaller that those of any integer base type,
2685 -- so we can safely ignore these cases.
2687 return Nkind_In (K, N_Number_Declaration,
2688 N_Attribute_Reference,
2689 N_Attribute_Definition_Clause,
2690 N_Modular_Type_Definition,
2691 N_Signed_Integer_Type_Definition);
2692 end In_Any_Integer_Context;
2694 -- Start of processing for Eval_Integer_Literal
2698 -- If the literal appears in a non-expression context, then it is
2699 -- certainly appearing in a non-static context, so check it. This is
2700 -- actually a redundant check, since Check_Non_Static_Context would
2701 -- check it, but it seems worthwhile to optimize out the call.
2703 -- An exception is made for a literal in an if or case expression
2705 if (Nkind_In (Parent (N), N_If_Expression, N_Case_Expression_Alternative)
2706 or else Nkind (Parent (N)) not in N_Subexpr)
2707 and then not In_Any_Integer_Context
2709 Check_Non_Static_Context (N);
2712 -- Modular integer literals must be in their base range
2714 if Is_Modular_Integer_Type (T)
2715 and then Is_Out_Of_Range (N, Base_Type (T), Assume_Valid => True)
2719 end Eval_Integer_Literal;
2721 ---------------------
2722 -- Eval_Logical_Op --
2723 ---------------------
2725 -- Logical operations are static functions, so the result is potentially
2726 -- static if both operands are potentially static (RM 4.9(7), 4.9(20)).
2728 procedure Eval_Logical_Op (N : Node_Id) is
2729 Left : constant Node_Id := Left_Opnd (N);
2730 Right : constant Node_Id := Right_Opnd (N);
2735 -- If not foldable we are done
2737 Test_Expression_Is_Foldable (N, Left, Right, Stat, Fold);
2743 -- Compile time evaluation of logical operation
2746 Left_Int : constant Uint := Expr_Value (Left);
2747 Right_Int : constant Uint := Expr_Value (Right);
2750 if Is_Modular_Integer_Type (Etype (N)) then
2752 Left_Bits : Bits (0 .. UI_To_Int (Esize (Etype (N))) - 1);
2753 Right_Bits : Bits (0 .. UI_To_Int (Esize (Etype (N))) - 1);
2756 To_Bits (Left_Int, Left_Bits);
2757 To_Bits (Right_Int, Right_Bits);
2759 -- Note: should really be able to use array ops instead of
2760 -- these loops, but they weren't working at the time ???
2762 if Nkind (N) = N_Op_And then
2763 for J in Left_Bits'Range loop
2764 Left_Bits (J) := Left_Bits (J) and Right_Bits (J);
2767 elsif Nkind (N) = N_Op_Or then
2768 for J in Left_Bits'Range loop
2769 Left_Bits (J) := Left_Bits (J) or Right_Bits (J);
2773 pragma Assert (Nkind (N) = N_Op_Xor);
2775 for J in Left_Bits'Range loop
2776 Left_Bits (J) := Left_Bits (J) xor Right_Bits (J);
2780 Fold_Uint (N, From_Bits (Left_Bits, Etype (N)), Stat);
2784 pragma Assert (Is_Boolean_Type (Etype (N)));
2786 if Nkind (N) = N_Op_And then
2788 Test (Is_True (Left_Int) and then Is_True (Right_Int)), Stat);
2790 elsif Nkind (N) = N_Op_Or then
2792 Test (Is_True (Left_Int) or else Is_True (Right_Int)), Stat);
2795 pragma Assert (Nkind (N) = N_Op_Xor);
2797 Test (Is_True (Left_Int) xor Is_True (Right_Int)), Stat);
2801 end Eval_Logical_Op;
2803 ------------------------
2804 -- Eval_Membership_Op --
2805 ------------------------
2807 -- A membership test is potentially static if the expression is static, and
2808 -- the range is a potentially static range, or is a subtype mark denoting a
2809 -- static subtype (RM 4.9(12)).
2811 procedure Eval_Membership_Op (N : Node_Id) is
2812 Alts : constant List_Id := Alternatives (N);
2813 Choice : constant Node_Id := Right_Opnd (N);
2814 Expr : constant Node_Id := Left_Opnd (N);
2815 Result : Match_Result;
2818 -- Ignore if error in either operand, except to make sure that Any_Type
2819 -- is properly propagated to avoid junk cascaded errors.
2821 if Etype (Expr) = Any_Type
2822 or else (Present (Choice) and then Etype (Choice) = Any_Type)
2824 Set_Etype (N, Any_Type);
2828 -- If left operand non-static, then nothing to do
2830 if not Is_Static_Expression (Expr) then
2834 -- If choice is non-static, left operand is in non-static context
2836 if (Present (Choice) and then not Is_Static_Choice (Choice))
2837 or else (Present (Alts) and then not Is_Static_Choice_List (Alts))
2839 Check_Non_Static_Context (Expr);
2843 -- Otherwise we definitely have a static expression
2845 Set_Is_Static_Expression (N);
2847 -- If left operand raises constraint error, propagate and we are done
2849 if Raises_Constraint_Error (Expr) then
2850 Set_Raises_Constraint_Error (N, True);
2855 if Present (Choice) then
2856 Result := Choice_Matches (Expr, Choice);
2858 Result := Choices_Match (Expr, Alts);
2861 -- If result is Non_Static, it means that we raise Constraint_Error,
2862 -- since we already tested that the operands were themselves static.
2864 if Result = Non_Static then
2865 Set_Raises_Constraint_Error (N);
2867 -- Otherwise we have our result (flipped if NOT IN case)
2871 (N, Test ((Result = Match) xor (Nkind (N) = N_Not_In)), True);
2872 Warn_On_Known_Condition (N);
2875 end Eval_Membership_Op;
2877 ------------------------
2878 -- Eval_Named_Integer --
2879 ------------------------
2881 procedure Eval_Named_Integer (N : Node_Id) is
2884 Expr_Value (Expression (Declaration_Node (Entity (N)))), True);
2885 end Eval_Named_Integer;
2887 ---------------------
2888 -- Eval_Named_Real --
2889 ---------------------
2891 procedure Eval_Named_Real (N : Node_Id) is
2894 Expr_Value_R (Expression (Declaration_Node (Entity (N)))), True);
2895 end Eval_Named_Real;
2901 -- Exponentiation is a static functions, so the result is potentially
2902 -- static if both operands are potentially static (RM 4.9(7), 4.9(20)).
2904 procedure Eval_Op_Expon (N : Node_Id) is
2905 Left : constant Node_Id := Left_Opnd (N);
2906 Right : constant Node_Id := Right_Opnd (N);
2911 -- If not foldable we are done
2913 Test_Expression_Is_Foldable
2914 (N, Left, Right, Stat, Fold, CRT_Safe => True);
2916 -- Return if not foldable
2922 if Configurable_Run_Time_Mode and not Stat then
2926 -- Fold exponentiation operation
2929 Right_Int : constant Uint := Expr_Value (Right);
2934 if Is_Integer_Type (Etype (Left)) then
2936 Left_Int : constant Uint := Expr_Value (Left);
2940 -- Exponentiation of an integer raises Constraint_Error for a
2941 -- negative exponent (RM 4.5.6).
2943 if Right_Int < 0 then
2944 Apply_Compile_Time_Constraint_Error
2945 (N, "integer exponent negative", CE_Range_Check_Failed,
2950 if OK_Bits (N, Num_Bits (Left_Int) * Right_Int) then
2951 Result := Left_Int ** Right_Int;
2956 if Is_Modular_Integer_Type (Etype (N)) then
2957 Result := Result mod Modulus (Etype (N));
2960 Fold_Uint (N, Result, Stat);
2968 Left_Real : constant Ureal := Expr_Value_R (Left);
2971 -- Cannot have a zero base with a negative exponent
2973 if UR_Is_Zero (Left_Real) then
2975 if Right_Int < 0 then
2976 Apply_Compile_Time_Constraint_Error
2977 (N, "zero ** negative integer", CE_Range_Check_Failed,
2981 Fold_Ureal (N, Ureal_0, Stat);
2985 Fold_Ureal (N, Left_Real ** Right_Int, Stat);
2996 -- The not operation is a static functions, so the result is potentially
2997 -- static if the operand is potentially static (RM 4.9(7), 4.9(20)).
2999 procedure Eval_Op_Not (N : Node_Id) is
3000 Right : constant Node_Id := Right_Opnd (N);
3005 -- If not foldable we are done
3007 Test_Expression_Is_Foldable (N, Right, Stat, Fold);
3013 -- Fold not operation
3016 Rint : constant Uint := Expr_Value (Right);
3017 Typ : constant Entity_Id := Etype (N);
3020 -- Negation is equivalent to subtracting from the modulus minus one.
3021 -- For a binary modulus this is equivalent to the ones-complement of
3022 -- the original value. For a nonbinary modulus this is an arbitrary
3023 -- but consistent definition.
3025 if Is_Modular_Integer_Type (Typ) then
3026 Fold_Uint (N, Modulus (Typ) - 1 - Rint, Stat);
3027 else pragma Assert (Is_Boolean_Type (Typ));
3028 Fold_Uint (N, Test (not Is_True (Rint)), Stat);
3031 Set_Is_Static_Expression (N, Stat);
3035 -------------------------------
3036 -- Eval_Qualified_Expression --
3037 -------------------------------
3039 -- A qualified expression is potentially static if its subtype mark denotes
3040 -- a static subtype and its expression is potentially static (RM 4.9 (11)).
3042 procedure Eval_Qualified_Expression (N : Node_Id) is
3043 Operand : constant Node_Id := Expression (N);
3044 Target_Type : constant Entity_Id := Entity (Subtype_Mark (N));
3051 -- Can only fold if target is string or scalar and subtype is static.
3052 -- Also, do not fold if our parent is an allocator (this is because the
3053 -- qualified expression is really part of the syntactic structure of an
3054 -- allocator, and we do not want to end up with something that
3055 -- corresponds to "new 1" where the 1 is the result of folding a
3056 -- qualified expression).
3058 if not Is_Static_Subtype (Target_Type)
3059 or else Nkind (Parent (N)) = N_Allocator
3061 Check_Non_Static_Context (Operand);
3063 -- If operand is known to raise constraint_error, set the flag on the
3064 -- expression so it does not get optimized away.
3066 if Nkind (Operand) = N_Raise_Constraint_Error then
3067 Set_Raises_Constraint_Error (N);
3073 -- If not foldable we are done
3075 Test_Expression_Is_Foldable (N, Operand, Stat, Fold);
3080 -- Don't try fold if target type has constraint error bounds
3082 elsif not Is_OK_Static_Subtype (Target_Type) then
3083 Set_Raises_Constraint_Error (N);
3087 -- Here we will fold, save Print_In_Hex indication
3089 Hex := Nkind (Operand) = N_Integer_Literal
3090 and then Print_In_Hex (Operand);
3092 -- Fold the result of qualification
3094 if Is_Discrete_Type (Target_Type) then
3095 Fold_Uint (N, Expr_Value (Operand), Stat);
3097 -- Preserve Print_In_Hex indication
3099 if Hex and then Nkind (N) = N_Integer_Literal then
3100 Set_Print_In_Hex (N);
3103 elsif Is_Real_Type (Target_Type) then
3104 Fold_Ureal (N, Expr_Value_R (Operand), Stat);
3107 Fold_Str (N, Strval (Get_String_Val (Operand)), Stat);
3110 Set_Is_Static_Expression (N, False);
3112 Check_String_Literal_Length (N, Target_Type);
3118 -- The expression may be foldable but not static
3120 Set_Is_Static_Expression (N, Stat);
3122 if Is_Out_Of_Range (N, Etype (N), Assume_Valid => True) then
3125 end Eval_Qualified_Expression;
3127 -----------------------
3128 -- Eval_Real_Literal --
3129 -----------------------
3131 -- Numeric literals are static (RM 4.9(1)), and have already been marked
3132 -- as static by the analyzer. The reason we did it that early is to allow
3133 -- the possibility of turning off the Is_Static_Expression flag after
3134 -- analysis, but before resolution, when integer literals are generated
3135 -- in the expander that do not correspond to static expressions.
3137 procedure Eval_Real_Literal (N : Node_Id) is
3138 PK : constant Node_Kind := Nkind (Parent (N));
3141 -- If the literal appears in a non-expression context and not as part of
3142 -- a number declaration, then it is appearing in a non-static context,
3145 if PK not in N_Subexpr and then PK /= N_Number_Declaration then
3146 Check_Non_Static_Context (N);
3148 end Eval_Real_Literal;
3150 ------------------------
3151 -- Eval_Relational_Op --
3152 ------------------------
3154 -- Relational operations are static functions, so the result is static if
3155 -- both operands are static (RM 4.9(7), 4.9(20)), except that for strings,
3156 -- the result is never static, even if the operands are.
3158 -- However, for internally generated nodes, we allow string equality and
3159 -- inequality to be static. This is because we rewrite A in "ABC" as an
3160 -- equality test A = "ABC", and the former is definitely static.
3162 procedure Eval_Relational_Op (N : Node_Id) is
3163 Left : constant Node_Id := Left_Opnd (N);
3164 Right : constant Node_Id := Right_Opnd (N);
3166 procedure Decompose_Expr
3168 Ent : out Entity_Id;
3169 Kind : out Character;
3171 Orig : Boolean := True);
3172 -- Given expression Expr, see if it is of the form X [+/- K]. If so, Ent
3173 -- is set to the entity in X, Kind is 'F','L','E' for 'First or 'Last or
3174 -- simple entity, and Cons is the value of K. If the expression is not
3175 -- of the required form, Ent is set to Empty.
3177 -- Orig indicates whether Expr is the original expression to consider,
3178 -- or if we are handling a subexpression (e.g. recursive call to
3181 procedure Fold_General_Op (Is_Static : Boolean);
3182 -- Attempt to fold arbitrary relational operator N. Flag Is_Static must
3183 -- be set when the operator denotes a static expression.
3185 procedure Fold_Static_Real_Op;
3186 -- Attempt to fold static real type relational operator N
3188 function Static_Length (Expr : Node_Id) return Uint;
3189 -- If Expr is an expression for a constrained array whose length is
3190 -- known at compile time, return the non-negative length, otherwise
3193 --------------------
3194 -- Decompose_Expr --
3195 --------------------
3197 procedure Decompose_Expr
3199 Ent : out Entity_Id;
3200 Kind : out Character;
3202 Orig : Boolean := True)
3207 -- Assume that the expression does not meet the expected form
3213 if Nkind (Expr) = N_Op_Add
3214 and then Compile_Time_Known_Value (Right_Opnd (Expr))
3216 Exp := Left_Opnd (Expr);
3217 Cons := Expr_Value (Right_Opnd (Expr));
3219 elsif Nkind (Expr) = N_Op_Subtract
3220 and then Compile_Time_Known_Value (Right_Opnd (Expr))
3222 Exp := Left_Opnd (Expr);
3223 Cons := -Expr_Value (Right_Opnd (Expr));
3225 -- If the bound is a constant created to remove side effects, recover
3226 -- the original expression to see if it has one of the recognizable
3229 elsif Nkind (Expr) = N_Identifier
3230 and then not Comes_From_Source (Entity (Expr))
3231 and then Ekind (Entity (Expr)) = E_Constant
3232 and then Nkind (Parent (Entity (Expr))) = N_Object_Declaration
3234 Exp := Expression (Parent (Entity (Expr)));
3235 Decompose_Expr (Exp, Ent, Kind, Cons, Orig => False);
3237 -- If original expression includes an entity, create a reference
3238 -- to it for use below.
3240 if Present (Ent) then
3241 Exp := New_Occurrence_Of (Ent, Sloc (Ent));
3247 -- Only consider the case of X + 0 for a full expression, and
3248 -- not when recursing, otherwise we may end up with evaluating
3249 -- expressions not known at compile time to 0.
3259 -- At this stage Exp is set to the potential X
3261 if Nkind (Exp) = N_Attribute_Reference then
3262 if Attribute_Name (Exp) = Name_First then
3264 elsif Attribute_Name (Exp) = Name_Last then
3270 Exp := Prefix (Exp);
3276 if Is_Entity_Name (Exp) and then Present (Entity (Exp)) then
3277 Ent := Entity (Exp);
3281 ---------------------
3282 -- Fold_General_Op --
3283 ---------------------
3285 procedure Fold_General_Op (Is_Static : Boolean) is
3286 CR : constant Compare_Result :=
3287 Compile_Time_Compare (Left, Right, Assume_Valid => False);
3292 if CR = Unknown then
3300 elsif CR = NE or else CR = GT or else CR = LT then
3307 if CR = GT or else CR = EQ or else CR = GE then
3318 elsif CR = EQ or else CR = LT or else CR = LE then
3325 if CR = LT or else CR = EQ or else CR = LE then
3336 elsif CR = EQ or else CR = GT or else CR = GE then
3343 if CR = NE or else CR = GT or else CR = LT then
3352 raise Program_Error;
3355 -- Determine the potential outcome of the relation assuming the
3356 -- operands are valid and emit a warning when the relation yields
3357 -- True or False only in the presence of invalid values.
3359 Warn_On_Constant_Valid_Condition (N);
3361 Fold_Uint (N, Test (Result), Is_Static);
3362 end Fold_General_Op;
3364 -------------------------
3365 -- Fold_Static_Real_Op --
3366 -------------------------
3368 procedure Fold_Static_Real_Op is
3369 Left_Real : constant Ureal := Expr_Value_R (Left);
3370 Right_Real : constant Ureal := Expr_Value_R (Right);
3375 when N_Op_Eq => Result := (Left_Real = Right_Real);
3376 when N_Op_Ge => Result := (Left_Real >= Right_Real);
3377 when N_Op_Gt => Result := (Left_Real > Right_Real);
3378 when N_Op_Le => Result := (Left_Real <= Right_Real);
3379 when N_Op_Lt => Result := (Left_Real < Right_Real);
3380 when N_Op_Ne => Result := (Left_Real /= Right_Real);
3381 when others => raise Program_Error;
3384 Fold_Uint (N, Test (Result), True);
3385 end Fold_Static_Real_Op;
3391 function Static_Length (Expr : Node_Id) return Uint is
3401 -- First easy case string literal
3403 if Nkind (Expr) = N_String_Literal then
3404 return UI_From_Int (String_Length (Strval (Expr)));
3406 -- Second easy case, not constrained subtype, so no length
3408 elsif not Is_Constrained (Etype (Expr)) then
3409 return Uint_Minus_1;
3414 Typ := Etype (First_Index (Etype (Expr)));
3416 -- The simple case, both bounds are known at compile time
3418 if Is_Discrete_Type (Typ)
3419 and then Compile_Time_Known_Value (Type_Low_Bound (Typ))
3420 and then Compile_Time_Known_Value (Type_High_Bound (Typ))
3423 UI_Max (Uint_0, Expr_Value (Type_High_Bound (Typ)) -
3424 Expr_Value (Type_Low_Bound (Typ)) + 1);
3427 -- A more complex case, where the bounds are of the form X [+/- K1]
3428 -- .. X [+/- K2]), where X is an expression that is either A'First or
3429 -- A'Last (with A an entity name), or X is an entity name, and the
3430 -- two X's are the same and K1 and K2 are known at compile time, in
3431 -- this case, the length can also be computed at compile time, even
3432 -- though the bounds are not known. A common case of this is e.g.
3433 -- (X'First .. X'First+5).
3436 (Original_Node (Type_Low_Bound (Typ)), Ent1, Kind1, Cons1);
3438 (Original_Node (Type_High_Bound (Typ)), Ent2, Kind2, Cons2);
3440 if Present (Ent1) and then Ent1 = Ent2 and then Kind1 = Kind2 then
3441 return Cons2 - Cons1 + 1;
3443 return Uint_Minus_1;
3449 Left_Typ : constant Entity_Id := Etype (Left);
3450 Right_Typ : constant Entity_Id := Etype (Right);
3453 Op_Typ : Entity_Id := Empty;
3456 Is_Static_Expression : Boolean;
3458 -- Start of processing for Eval_Relational_Op
3461 -- One special case to deal with first. If we can tell that the result
3462 -- will be false because the lengths of one or more index subtypes are
3463 -- compile-time known and different, then we can replace the entire
3464 -- result by False. We only do this for one-dimensional arrays, because
3465 -- the case of multidimensional arrays is rare and too much trouble. If
3466 -- one of the operands is an illegal aggregate, its type might still be
3467 -- an arbitrary composite type, so nothing to do.
3469 if Is_Array_Type (Left_Typ)
3470 and then Left_Typ /= Any_Composite
3471 and then Number_Dimensions (Left_Typ) = 1
3472 and then Nkind_In (N, N_Op_Eq, N_Op_Ne)
3474 if Raises_Constraint_Error (Left)
3476 Raises_Constraint_Error (Right)
3480 -- OK, we have the case where we may be able to do this fold
3483 Left_Len := Static_Length (Left);
3484 Right_Len := Static_Length (Right);
3486 if Left_Len /= Uint_Minus_1
3487 and then Right_Len /= Uint_Minus_1
3488 and then Left_Len /= Right_Len
3490 Fold_Uint (N, Test (Nkind (N) = N_Op_Ne), False);
3491 Warn_On_Known_Condition (N);
3499 -- Initialize the value of Is_Static_Expression. The value of Fold
3500 -- returned by Test_Expression_Is_Foldable is not needed since, even
3501 -- when some operand is a variable, we can still perform the static
3502 -- evaluation of the expression in some cases (for example, for a
3503 -- variable of a subtype of Integer we statically know that any value
3504 -- stored in such variable is smaller than Integer'Last).
3506 Test_Expression_Is_Foldable
3507 (N, Left, Right, Is_Static_Expression, Fold);
3509 -- Only comparisons of scalars can give static results. A comparison
3510 -- of strings never yields a static result, even if both operands are
3511 -- static strings, except that as noted above, we allow equality and
3512 -- inequality for strings.
3514 if Is_String_Type (Left_Typ)
3515 and then not Comes_From_Source (N)
3516 and then Nkind_In (N, N_Op_Eq, N_Op_Ne)
3520 elsif not Is_Scalar_Type (Left_Typ) then
3521 Is_Static_Expression := False;
3522 Set_Is_Static_Expression (N, False);
3525 -- For operators on universal numeric types called as functions with
3526 -- an explicit scope, determine appropriate specific numeric type,
3527 -- and diagnose possible ambiguity.
3529 if Is_Universal_Numeric_Type (Left_Typ)
3531 Is_Universal_Numeric_Type (Right_Typ)
3533 Op_Typ := Find_Universal_Operator_Type (N);
3536 -- Attempt to fold the relational operator
3538 if Is_Static_Expression and then Is_Real_Type (Left_Typ) then
3539 Fold_Static_Real_Op;
3541 Fold_General_Op (Is_Static_Expression);
3545 -- For the case of a folded relational operator on a specific numeric
3546 -- type, freeze the operand type now.
3548 if Present (Op_Typ) then
3549 Freeze_Before (N, Op_Typ);
3552 Warn_On_Known_Condition (N);
3553 end Eval_Relational_Op;
3559 -- Shift operations are intrinsic operations that can never be static, so
3560 -- the only processing required is to perform the required check for a non
3561 -- static context for the two operands.
3563 -- Actually we could do some compile time evaluation here some time ???
3565 procedure Eval_Shift (N : Node_Id) is
3567 Check_Non_Static_Context (Left_Opnd (N));
3568 Check_Non_Static_Context (Right_Opnd (N));
3571 ------------------------
3572 -- Eval_Short_Circuit --
3573 ------------------------
3575 -- A short circuit operation is potentially static if both operands are
3576 -- potentially static (RM 4.9 (13)).
3578 procedure Eval_Short_Circuit (N : Node_Id) is
3579 Kind : constant Node_Kind := Nkind (N);
3580 Left : constant Node_Id := Left_Opnd (N);
3581 Right : constant Node_Id := Right_Opnd (N);
3584 Rstat : constant Boolean :=
3585 Is_Static_Expression (Left)
3587 Is_Static_Expression (Right);
3590 -- Short circuit operations are never static in Ada 83
3592 if Ada_Version = Ada_83 and then Comes_From_Source (N) then
3593 Check_Non_Static_Context (Left);
3594 Check_Non_Static_Context (Right);
3598 -- Now look at the operands, we can't quite use the normal call to
3599 -- Test_Expression_Is_Foldable here because short circuit operations
3600 -- are a special case, they can still be foldable, even if the right
3601 -- operand raises constraint error.
3603 -- If either operand is Any_Type, just propagate to result and do not
3604 -- try to fold, this prevents cascaded errors.
3606 if Etype (Left) = Any_Type or else Etype (Right) = Any_Type then
3607 Set_Etype (N, Any_Type);
3610 -- If left operand raises constraint error, then replace node N with
3611 -- the raise constraint error node, and we are obviously not foldable.
3612 -- Is_Static_Expression is set from the two operands in the normal way,
3613 -- and we check the right operand if it is in a non-static context.
3615 elsif Raises_Constraint_Error (Left) then
3617 Check_Non_Static_Context (Right);
3620 Rewrite_In_Raise_CE (N, Left);
3621 Set_Is_Static_Expression (N, Rstat);
3624 -- If the result is not static, then we won't in any case fold
3626 elsif not Rstat then
3627 Check_Non_Static_Context (Left);
3628 Check_Non_Static_Context (Right);
3632 -- Here the result is static, note that, unlike the normal processing
3633 -- in Test_Expression_Is_Foldable, we did *not* check above to see if
3634 -- the right operand raises constraint error, that's because it is not
3635 -- significant if the left operand is decisive.
3637 Set_Is_Static_Expression (N);
3639 -- It does not matter if the right operand raises constraint error if
3640 -- it will not be evaluated. So deal specially with the cases where
3641 -- the right operand is not evaluated. Note that we will fold these
3642 -- cases even if the right operand is non-static, which is fine, but
3643 -- of course in these cases the result is not potentially static.
3645 Left_Int := Expr_Value (Left);
3647 if (Kind = N_And_Then and then Is_False (Left_Int))
3649 (Kind = N_Or_Else and then Is_True (Left_Int))
3651 Fold_Uint (N, Left_Int, Rstat);
3655 -- If first operand not decisive, then it does matter if the right
3656 -- operand raises constraint error, since it will be evaluated, so
3657 -- we simply replace the node with the right operand. Note that this
3658 -- properly propagates Is_Static_Expression and Raises_Constraint_Error
3659 -- (both are set to True in Right).
3661 if Raises_Constraint_Error (Right) then
3662 Rewrite_In_Raise_CE (N, Right);
3663 Check_Non_Static_Context (Left);
3667 -- Otherwise the result depends on the right operand
3669 Fold_Uint (N, Expr_Value (Right), Rstat);
3671 end Eval_Short_Circuit;
3677 -- Slices can never be static, so the only processing required is to check
3678 -- for non-static context if an explicit range is given.
3680 procedure Eval_Slice (N : Node_Id) is
3681 Drange : constant Node_Id := Discrete_Range (N);
3684 if Nkind (Drange) = N_Range then
3685 Check_Non_Static_Context (Low_Bound (Drange));
3686 Check_Non_Static_Context (High_Bound (Drange));
3689 -- A slice of the form A (subtype), when the subtype is the index of
3690 -- the type of A, is redundant, the slice can be replaced with A, and
3691 -- this is worth a warning.
3693 if Is_Entity_Name (Prefix (N)) then
3695 E : constant Entity_Id := Entity (Prefix (N));
3696 T : constant Entity_Id := Etype (E);
3699 if Ekind (E) = E_Constant
3700 and then Is_Array_Type (T)
3701 and then Is_Entity_Name (Drange)
3703 if Is_Entity_Name (Original_Node (First_Index (T)))
3704 and then Entity (Original_Node (First_Index (T)))
3707 if Warn_On_Redundant_Constructs then
3708 Error_Msg_N ("redundant slice denotes whole array?r?", N);
3711 -- The following might be a useful optimization???
3713 -- Rewrite (N, New_Occurrence_Of (E, Sloc (N)));
3720 -------------------------
3721 -- Eval_String_Literal --
3722 -------------------------
3724 procedure Eval_String_Literal (N : Node_Id) is
3725 Typ : constant Entity_Id := Etype (N);
3726 Bas : constant Entity_Id := Base_Type (Typ);
3732 -- Nothing to do if error type (handles cases like default expressions
3733 -- or generics where we have not yet fully resolved the type).
3735 if Bas = Any_Type or else Bas = Any_String then
3739 -- String literals are static if the subtype is static (RM 4.9(2)), so
3740 -- reset the static expression flag (it was set unconditionally in
3741 -- Analyze_String_Literal) if the subtype is non-static. We tell if
3742 -- the subtype is static by looking at the lower bound.
3744 if Ekind (Typ) = E_String_Literal_Subtype then
3745 if not Is_OK_Static_Expression (String_Literal_Low_Bound (Typ)) then
3746 Set_Is_Static_Expression (N, False);
3750 -- Here if Etype of string literal is normal Etype (not yet possible,
3751 -- but may be possible in future).
3753 elsif not Is_OK_Static_Expression
3754 (Type_Low_Bound (Etype (First_Index (Typ))))
3756 Set_Is_Static_Expression (N, False);
3760 -- If original node was a type conversion, then result if non-static
3762 if Nkind (Original_Node (N)) = N_Type_Conversion then
3763 Set_Is_Static_Expression (N, False);
3767 -- Test for illegal Ada 95 cases. A string literal is illegal in Ada 95
3768 -- if its bounds are outside the index base type and this index type is
3769 -- static. This can happen in only two ways. Either the string literal
3770 -- is too long, or it is null, and the lower bound is type'First. Either
3771 -- way it is the upper bound that is out of range of the index type.
3773 if Ada_Version >= Ada_95 then
3774 if Is_Standard_String_Type (Bas) then
3775 Xtp := Standard_Positive;
3777 Xtp := Etype (First_Index (Bas));
3780 if Ekind (Typ) = E_String_Literal_Subtype then
3781 Lo := String_Literal_Low_Bound (Typ);
3783 Lo := Type_Low_Bound (Etype (First_Index (Typ)));
3786 -- Check for string too long
3788 Len := String_Length (Strval (N));
3790 if UI_From_Int (Len) > String_Type_Len (Bas) then
3792 -- Issue message. Note that this message is a warning if the
3793 -- string literal is not marked as static (happens in some cases
3794 -- of folding strings known at compile time, but not static).
3795 -- Furthermore in such cases, we reword the message, since there
3796 -- is no string literal in the source program.
3798 if Is_Static_Expression (N) then
3799 Apply_Compile_Time_Constraint_Error
3800 (N, "string literal too long for}", CE_Length_Check_Failed,
3802 Typ => First_Subtype (Bas));
3804 Apply_Compile_Time_Constraint_Error
3805 (N, "string value too long for}", CE_Length_Check_Failed,
3807 Typ => First_Subtype (Bas),
3811 -- Test for null string not allowed
3814 and then not Is_Generic_Type (Xtp)
3816 Expr_Value (Lo) = Expr_Value (Type_Low_Bound (Base_Type (Xtp)))
3818 -- Same specialization of message
3820 if Is_Static_Expression (N) then
3821 Apply_Compile_Time_Constraint_Error
3822 (N, "null string literal not allowed for}",
3823 CE_Length_Check_Failed,
3825 Typ => First_Subtype (Bas));
3827 Apply_Compile_Time_Constraint_Error
3828 (N, "null string value not allowed for}",
3829 CE_Length_Check_Failed,
3831 Typ => First_Subtype (Bas),
3836 end Eval_String_Literal;
3838 --------------------------
3839 -- Eval_Type_Conversion --
3840 --------------------------
3842 -- A type conversion is potentially static if its subtype mark is for a
3843 -- static scalar subtype, and its operand expression is potentially static
3846 procedure Eval_Type_Conversion (N : Node_Id) is
3847 Operand : constant Node_Id := Expression (N);
3848 Source_Type : constant Entity_Id := Etype (Operand);
3849 Target_Type : constant Entity_Id := Etype (N);
3851 function To_Be_Treated_As_Integer (T : Entity_Id) return Boolean;
3852 -- Returns true if type T is an integer type, or if it is a fixed-point
3853 -- type to be treated as an integer (i.e. the flag Conversion_OK is set
3854 -- on the conversion node).
3856 function To_Be_Treated_As_Real (T : Entity_Id) return Boolean;
3857 -- Returns true if type T is a floating-point type, or if it is a
3858 -- fixed-point type that is not to be treated as an integer (i.e. the
3859 -- flag Conversion_OK is not set on the conversion node).
3861 ------------------------------
3862 -- To_Be_Treated_As_Integer --
3863 ------------------------------
3865 function To_Be_Treated_As_Integer (T : Entity_Id) return Boolean is
3869 or else (Is_Fixed_Point_Type (T) and then Conversion_OK (N));
3870 end To_Be_Treated_As_Integer;
3872 ---------------------------
3873 -- To_Be_Treated_As_Real --
3874 ---------------------------
3876 function To_Be_Treated_As_Real (T : Entity_Id) return Boolean is
3879 Is_Floating_Point_Type (T)
3880 or else (Is_Fixed_Point_Type (T) and then not Conversion_OK (N));
3881 end To_Be_Treated_As_Real;
3888 -- Start of processing for Eval_Type_Conversion
3891 -- Cannot fold if target type is non-static or if semantic error
3893 if not Is_Static_Subtype (Target_Type) then
3894 Check_Non_Static_Context (Operand);
3896 elsif Error_Posted (N) then
3900 -- If not foldable we are done
3902 Test_Expression_Is_Foldable (N, Operand, Stat, Fold);
3907 -- Don't try fold if target type has constraint error bounds
3909 elsif not Is_OK_Static_Subtype (Target_Type) then
3910 Set_Raises_Constraint_Error (N);
3914 -- Remaining processing depends on operand types. Note that in the
3915 -- following type test, fixed-point counts as real unless the flag
3916 -- Conversion_OK is set, in which case it counts as integer.
3918 -- Fold conversion, case of string type. The result is not static
3920 if Is_String_Type (Target_Type) then
3921 Fold_Str (N, Strval (Get_String_Val (Operand)), Static => False);
3924 -- Fold conversion, case of integer target type
3926 elsif To_Be_Treated_As_Integer (Target_Type) then
3931 -- Integer to integer conversion
3933 if To_Be_Treated_As_Integer (Source_Type) then
3934 Result := Expr_Value (Operand);
3936 -- Real to integer conversion
3939 Result := UR_To_Uint (Expr_Value_R (Operand));
3942 -- If fixed-point type (Conversion_OK must be set), then the
3943 -- result is logically an integer, but we must replace the
3944 -- conversion with the corresponding real literal, since the
3945 -- type from a semantic point of view is still fixed-point.
3947 if Is_Fixed_Point_Type (Target_Type) then
3949 (N, UR_From_Uint (Result) * Small_Value (Target_Type), Stat);
3951 -- Otherwise result is integer literal
3954 Fold_Uint (N, Result, Stat);
3958 -- Fold conversion, case of real target type
3960 elsif To_Be_Treated_As_Real (Target_Type) then
3965 if To_Be_Treated_As_Real (Source_Type) then
3966 Result := Expr_Value_R (Operand);
3968 Result := UR_From_Uint (Expr_Value (Operand));
3971 Fold_Ureal (N, Result, Stat);
3974 -- Enumeration types
3977 Fold_Uint (N, Expr_Value (Operand), Stat);
3980 if Is_Out_Of_Range (N, Etype (N), Assume_Valid => True) then
3984 end Eval_Type_Conversion;
3990 -- Predefined unary operators are static functions (RM 4.9(20)) and thus
3991 -- are potentially static if the operand is potentially static (RM 4.9(7)).
3993 procedure Eval_Unary_Op (N : Node_Id) is
3994 Right : constant Node_Id := Right_Opnd (N);
3995 Otype : Entity_Id := Empty;
4000 -- If not foldable we are done
4002 Test_Expression_Is_Foldable (N, Right, Stat, Fold);
4008 if Etype (Right) = Universal_Integer
4010 Etype (Right) = Universal_Real
4012 Otype := Find_Universal_Operator_Type (N);
4015 -- Fold for integer case
4017 if Is_Integer_Type (Etype (N)) then
4019 Rint : constant Uint := Expr_Value (Right);
4023 -- In the case of modular unary plus and abs there is no need
4024 -- to adjust the result of the operation since if the original
4025 -- operand was in bounds the result will be in the bounds of the
4026 -- modular type. However, in the case of modular unary minus the
4027 -- result may go out of the bounds of the modular type and needs
4030 if Nkind (N) = N_Op_Plus then
4033 elsif Nkind (N) = N_Op_Minus then
4034 if Is_Modular_Integer_Type (Etype (N)) then
4035 Result := (-Rint) mod Modulus (Etype (N));
4041 pragma Assert (Nkind (N) = N_Op_Abs);
4045 Fold_Uint (N, Result, Stat);
4048 -- Fold for real case
4050 elsif Is_Real_Type (Etype (N)) then
4052 Rreal : constant Ureal := Expr_Value_R (Right);
4056 if Nkind (N) = N_Op_Plus then
4058 elsif Nkind (N) = N_Op_Minus then
4059 Result := UR_Negate (Rreal);
4061 pragma Assert (Nkind (N) = N_Op_Abs);
4062 Result := abs Rreal;
4065 Fold_Ureal (N, Result, Stat);
4069 -- If the operator was resolved to a specific type, make sure that type
4070 -- is frozen even if the expression is folded into a literal (which has
4071 -- a universal type).
4073 if Present (Otype) then
4074 Freeze_Before (N, Otype);
4078 -------------------------------
4079 -- Eval_Unchecked_Conversion --
4080 -------------------------------
4082 -- Unchecked conversions can never be static, so the only required
4083 -- processing is to check for a non-static context for the operand.
4085 procedure Eval_Unchecked_Conversion (N : Node_Id) is
4087 Check_Non_Static_Context (Expression (N));
4088 end Eval_Unchecked_Conversion;
4090 --------------------
4091 -- Expr_Rep_Value --
4092 --------------------
4094 function Expr_Rep_Value (N : Node_Id) return Uint is
4095 Kind : constant Node_Kind := Nkind (N);
4099 if Is_Entity_Name (N) then
4102 -- An enumeration literal that was either in the source or created
4103 -- as a result of static evaluation.
4105 if Ekind (Ent) = E_Enumeration_Literal then
4106 return Enumeration_Rep (Ent);
4108 -- A user defined static constant
4111 pragma Assert (Ekind (Ent) = E_Constant);
4112 return Expr_Rep_Value (Constant_Value (Ent));
4115 -- An integer literal that was either in the source or created as a
4116 -- result of static evaluation.
4118 elsif Kind = N_Integer_Literal then
4121 -- A real literal for a fixed-point type. This must be the fixed-point
4122 -- case, either the literal is of a fixed-point type, or it is a bound
4123 -- of a fixed-point type, with type universal real. In either case we
4124 -- obtain the desired value from Corresponding_Integer_Value.
4126 elsif Kind = N_Real_Literal then
4127 pragma Assert (Is_Fixed_Point_Type (Underlying_Type (Etype (N))));
4128 return Corresponding_Integer_Value (N);
4130 -- Otherwise must be character literal
4133 pragma Assert (Kind = N_Character_Literal);
4136 -- Since Character literals of type Standard.Character don't have any
4137 -- defining character literals built for them, they do not have their
4138 -- Entity set, so just use their Char code. Otherwise for user-
4139 -- defined character literals use their Pos value as usual which is
4140 -- the same as the Rep value.
4143 return Char_Literal_Value (N);
4145 return Enumeration_Rep (Ent);
4154 function Expr_Value (N : Node_Id) return Uint is
4155 Kind : constant Node_Kind := Nkind (N);
4156 CV_Ent : CV_Entry renames CV_Cache (Nat (N) mod CV_Cache_Size);
4161 -- If already in cache, then we know it's compile time known and we can
4162 -- return the value that was previously stored in the cache since
4163 -- compile time known values cannot change.
4165 if CV_Ent.N = N then
4169 -- Otherwise proceed to test value
4171 if Is_Entity_Name (N) then
4174 -- An enumeration literal that was either in the source or created as
4175 -- a result of static evaluation.
4177 if Ekind (Ent) = E_Enumeration_Literal then
4178 Val := Enumeration_Pos (Ent);
4180 -- A user defined static constant
4183 pragma Assert (Ekind (Ent) = E_Constant);
4184 Val := Expr_Value (Constant_Value (Ent));
4187 -- An integer literal that was either in the source or created as a
4188 -- result of static evaluation.
4190 elsif Kind = N_Integer_Literal then
4193 -- A real literal for a fixed-point type. This must be the fixed-point
4194 -- case, either the literal is of a fixed-point type, or it is a bound
4195 -- of a fixed-point type, with type universal real. In either case we
4196 -- obtain the desired value from Corresponding_Integer_Value.
4198 elsif Kind = N_Real_Literal then
4199 pragma Assert (Is_Fixed_Point_Type (Underlying_Type (Etype (N))));
4200 Val := Corresponding_Integer_Value (N);
4202 -- Otherwise must be character literal
4205 pragma Assert (Kind = N_Character_Literal);
4208 -- Since Character literals of type Standard.Character don't
4209 -- have any defining character literals built for them, they
4210 -- do not have their Entity set, so just use their Char
4211 -- code. Otherwise for user-defined character literals use
4212 -- their Pos value as usual.
4215 Val := Char_Literal_Value (N);
4217 Val := Enumeration_Pos (Ent);
4221 -- Come here with Val set to value to be returned, set cache
4232 function Expr_Value_E (N : Node_Id) return Entity_Id is
4233 Ent : constant Entity_Id := Entity (N);
4235 if Ekind (Ent) = E_Enumeration_Literal then
4238 pragma Assert (Ekind (Ent) = E_Constant);
4239 return Expr_Value_E (Constant_Value (Ent));
4247 function Expr_Value_R (N : Node_Id) return Ureal is
4248 Kind : constant Node_Kind := Nkind (N);
4252 if Kind = N_Real_Literal then
4255 elsif Kind = N_Identifier or else Kind = N_Expanded_Name then
4257 pragma Assert (Ekind (Ent) = E_Constant);
4258 return Expr_Value_R (Constant_Value (Ent));
4260 elsif Kind = N_Integer_Literal then
4261 return UR_From_Uint (Expr_Value (N));
4263 -- Here, we have a node that cannot be interpreted as a compile time
4264 -- constant. That is definitely an error.
4267 raise Program_Error;
4275 function Expr_Value_S (N : Node_Id) return Node_Id is
4277 if Nkind (N) = N_String_Literal then
4280 pragma Assert (Ekind (Entity (N)) = E_Constant);
4281 return Expr_Value_S (Constant_Value (Entity (N)));
4285 ----------------------------------
4286 -- Find_Universal_Operator_Type --
4287 ----------------------------------
4289 function Find_Universal_Operator_Type (N : Node_Id) return Entity_Id is
4290 PN : constant Node_Id := Parent (N);
4291 Call : constant Node_Id := Original_Node (N);
4292 Is_Int : constant Boolean := Is_Integer_Type (Etype (N));
4294 Is_Fix : constant Boolean :=
4295 Nkind (N) in N_Binary_Op
4296 and then Nkind (Right_Opnd (N)) /= Nkind (Left_Opnd (N));
4297 -- A mixed-mode operation in this context indicates the presence of
4298 -- fixed-point type in the designated package.
4300 Is_Relational : constant Boolean := Etype (N) = Standard_Boolean;
4301 -- Case where N is a relational (or membership) operator (else it is an
4304 In_Membership : constant Boolean :=
4305 Nkind (PN) in N_Membership_Test
4307 Nkind (Right_Opnd (PN)) = N_Range
4309 Is_Universal_Numeric_Type (Etype (Left_Opnd (PN)))
4311 Is_Universal_Numeric_Type
4312 (Etype (Low_Bound (Right_Opnd (PN))))
4314 Is_Universal_Numeric_Type
4315 (Etype (High_Bound (Right_Opnd (PN))));
4316 -- Case where N is part of a membership test with a universal range
4320 Typ1 : Entity_Id := Empty;
4323 function Is_Mixed_Mode_Operand (Op : Node_Id) return Boolean;
4324 -- Check whether one operand is a mixed-mode operation that requires the
4325 -- presence of a fixed-point type. Given that all operands are universal
4326 -- and have been constant-folded, retrieve the original function call.
4328 ---------------------------
4329 -- Is_Mixed_Mode_Operand --
4330 ---------------------------
4332 function Is_Mixed_Mode_Operand (Op : Node_Id) return Boolean is
4333 Onod : constant Node_Id := Original_Node (Op);
4335 return Nkind (Onod) = N_Function_Call
4336 and then Present (Next_Actual (First_Actual (Onod)))
4337 and then Etype (First_Actual (Onod)) /=
4338 Etype (Next_Actual (First_Actual (Onod)));
4339 end Is_Mixed_Mode_Operand;
4341 -- Start of processing for Find_Universal_Operator_Type
4344 if Nkind (Call) /= N_Function_Call
4345 or else Nkind (Name (Call)) /= N_Expanded_Name
4349 -- There are several cases where the context does not imply the type of
4351 -- - the universal expression appears in a type conversion;
4352 -- - the expression is a relational operator applied to universal
4354 -- - the expression is a membership test with a universal operand
4355 -- and a range with universal bounds.
4357 elsif Nkind (Parent (N)) = N_Type_Conversion
4358 or else Is_Relational
4359 or else In_Membership
4361 Pack := Entity (Prefix (Name (Call)));
4363 -- If the prefix is a package declared elsewhere, iterate over its
4364 -- visible entities, otherwise iterate over all declarations in the
4365 -- designated scope.
4367 if Ekind (Pack) = E_Package
4368 and then not In_Open_Scopes (Pack)
4370 Priv_E := First_Private_Entity (Pack);
4376 E := First_Entity (Pack);
4377 while Present (E) and then E /= Priv_E loop
4378 if Is_Numeric_Type (E)
4379 and then Nkind (Parent (E)) /= N_Subtype_Declaration
4380 and then Comes_From_Source (E)
4381 and then Is_Integer_Type (E) = Is_Int
4382 and then (Nkind (N) in N_Unary_Op
4383 or else Is_Relational
4384 or else Is_Fixed_Point_Type (E) = Is_Fix)
4389 -- Before emitting an error, check for the presence of a
4390 -- mixed-mode operation that specifies a fixed point type.
4394 (Is_Mixed_Mode_Operand (Left_Opnd (N))
4395 or else Is_Mixed_Mode_Operand (Right_Opnd (N)))
4396 and then Is_Fixed_Point_Type (E) /= Is_Fixed_Point_Type (Typ1)
4399 if Is_Fixed_Point_Type (E) then
4404 -- More than one type of the proper class declared in P
4406 Error_Msg_N ("ambiguous operation", N);
4407 Error_Msg_Sloc := Sloc (Typ1);
4408 Error_Msg_N ("\possible interpretation (inherited)#", N);
4409 Error_Msg_Sloc := Sloc (E);
4410 Error_Msg_N ("\possible interpretation (inherited)#", N);
4420 end Find_Universal_Operator_Type;
4422 --------------------------
4423 -- Flag_Non_Static_Expr --
4424 --------------------------
4426 procedure Flag_Non_Static_Expr (Msg : String; Expr : Node_Id) is
4428 if Error_Posted (Expr) and then not All_Errors_Mode then
4431 Error_Msg_F (Msg, Expr);
4432 Why_Not_Static (Expr);
4434 end Flag_Non_Static_Expr;
4440 procedure Fold_Str (N : Node_Id; Val : String_Id; Static : Boolean) is
4441 Loc : constant Source_Ptr := Sloc (N);
4442 Typ : constant Entity_Id := Etype (N);
4445 if Raises_Constraint_Error (N) then
4446 Set_Is_Static_Expression (N, Static);
4450 Rewrite (N, Make_String_Literal (Loc, Strval => Val));
4452 -- We now have the literal with the right value, both the actual type
4453 -- and the expected type of this literal are taken from the expression
4454 -- that was evaluated. So now we do the Analyze and Resolve.
4456 -- Note that we have to reset Is_Static_Expression both after the
4457 -- analyze step (because Resolve will evaluate the literal, which
4458 -- will cause semantic errors if it is marked as static), and after
4459 -- the Resolve step (since Resolve in some cases resets this flag).
4462 Set_Is_Static_Expression (N, Static);
4465 Set_Is_Static_Expression (N, Static);
4472 procedure Fold_Uint (N : Node_Id; Val : Uint; Static : Boolean) is
4473 Loc : constant Source_Ptr := Sloc (N);
4474 Typ : Entity_Id := Etype (N);
4478 if Raises_Constraint_Error (N) then
4479 Set_Is_Static_Expression (N, Static);
4483 -- If we are folding a named number, retain the entity in the literal,
4486 if Is_Entity_Name (N) and then Ekind (Entity (N)) = E_Named_Integer then
4492 if Is_Private_Type (Typ) then
4493 Typ := Full_View (Typ);
4496 -- For a result of type integer, substitute an N_Integer_Literal node
4497 -- for the result of the compile time evaluation of the expression.
4498 -- For ASIS use, set a link to the original named number when not in
4499 -- a generic context.
4501 if Is_Integer_Type (Typ) then
4502 Rewrite (N, Make_Integer_Literal (Loc, Val));
4503 Set_Original_Entity (N, Ent);
4505 -- Otherwise we have an enumeration type, and we substitute either
4506 -- an N_Identifier or N_Character_Literal to represent the enumeration
4507 -- literal corresponding to the given value, which must always be in
4508 -- range, because appropriate tests have already been made for this.
4510 else pragma Assert (Is_Enumeration_Type (Typ));
4511 Rewrite (N, Get_Enum_Lit_From_Pos (Etype (N), Val, Loc));
4514 -- We now have the literal with the right value, both the actual type
4515 -- and the expected type of this literal are taken from the expression
4516 -- that was evaluated. So now we do the Analyze and Resolve.
4518 -- Note that we have to reset Is_Static_Expression both after the
4519 -- analyze step (because Resolve will evaluate the literal, which
4520 -- will cause semantic errors if it is marked as static), and after
4521 -- the Resolve step (since Resolve in some cases sets this flag).
4524 Set_Is_Static_Expression (N, Static);
4527 Set_Is_Static_Expression (N, Static);
4534 procedure Fold_Ureal (N : Node_Id; Val : Ureal; Static : Boolean) is
4535 Loc : constant Source_Ptr := Sloc (N);
4536 Typ : constant Entity_Id := Etype (N);
4540 if Raises_Constraint_Error (N) then
4541 Set_Is_Static_Expression (N, Static);
4545 -- If we are folding a named number, retain the entity in the literal,
4548 if Is_Entity_Name (N) and then Ekind (Entity (N)) = E_Named_Real then
4554 Rewrite (N, Make_Real_Literal (Loc, Realval => Val));
4556 -- Set link to original named number, for ASIS use
4558 Set_Original_Entity (N, Ent);
4560 -- We now have the literal with the right value, both the actual type
4561 -- and the expected type of this literal are taken from the expression
4562 -- that was evaluated. So now we do the Analyze and Resolve.
4564 -- Note that we have to reset Is_Static_Expression both after the
4565 -- analyze step (because Resolve will evaluate the literal, which
4566 -- will cause semantic errors if it is marked as static), and after
4567 -- the Resolve step (since Resolve in some cases sets this flag).
4570 Set_Is_Static_Expression (N, Static);
4573 Set_Is_Static_Expression (N, Static);
4580 function From_Bits (B : Bits; T : Entity_Id) return Uint is
4584 for J in 0 .. B'Last loop
4590 if Non_Binary_Modulus (T) then
4591 V := V mod Modulus (T);
4597 --------------------
4598 -- Get_String_Val --
4599 --------------------
4601 function Get_String_Val (N : Node_Id) return Node_Id is
4603 if Nkind_In (N, N_String_Literal, N_Character_Literal) then
4606 pragma Assert (Is_Entity_Name (N));
4607 return Get_String_Val (Constant_Value (Entity (N)));
4615 procedure Initialize is
4617 CV_Cache := (others => (Node_High_Bound, Uint_0));
4620 --------------------
4621 -- In_Subrange_Of --
4622 --------------------
4624 function In_Subrange_Of
4627 Fixed_Int : Boolean := False) return Boolean
4636 if T1 = T2 or else Is_Subtype_Of (T1, T2) then
4639 -- Never in range if both types are not scalar. Don't know if this can
4640 -- actually happen, but just in case.
4642 elsif not Is_Scalar_Type (T1) or else not Is_Scalar_Type (T2) then
4645 -- If T1 has infinities but T2 doesn't have infinities, then T1 is
4646 -- definitely not compatible with T2.
4648 elsif Is_Floating_Point_Type (T1)
4649 and then Has_Infinities (T1)
4650 and then Is_Floating_Point_Type (T2)
4651 and then not Has_Infinities (T2)
4656 L1 := Type_Low_Bound (T1);
4657 H1 := Type_High_Bound (T1);
4659 L2 := Type_Low_Bound (T2);
4660 H2 := Type_High_Bound (T2);
4662 -- Check bounds to see if comparison possible at compile time
4664 if Compile_Time_Compare (L1, L2, Assume_Valid => True) in Compare_GE
4666 Compile_Time_Compare (H1, H2, Assume_Valid => True) in Compare_LE
4671 -- If bounds not comparable at compile time, then the bounds of T2
4672 -- must be compile time known or we cannot answer the query.
4674 if not Compile_Time_Known_Value (L2)
4675 or else not Compile_Time_Known_Value (H2)
4680 -- If the bounds of T1 are know at compile time then use these
4681 -- ones, otherwise use the bounds of the base type (which are of
4682 -- course always static).
4684 if not Compile_Time_Known_Value (L1) then
4685 L1 := Type_Low_Bound (Base_Type (T1));
4688 if not Compile_Time_Known_Value (H1) then
4689 H1 := Type_High_Bound (Base_Type (T1));
4692 -- Fixed point types should be considered as such only if
4693 -- flag Fixed_Int is set to False.
4695 if Is_Floating_Point_Type (T1) or else Is_Floating_Point_Type (T2)
4696 or else (Is_Fixed_Point_Type (T1) and then not Fixed_Int)
4697 or else (Is_Fixed_Point_Type (T2) and then not Fixed_Int)
4700 Expr_Value_R (L2) <= Expr_Value_R (L1)
4702 Expr_Value_R (H2) >= Expr_Value_R (H1);
4706 Expr_Value (L2) <= Expr_Value (L1)
4708 Expr_Value (H2) >= Expr_Value (H1);
4713 -- If any exception occurs, it means that we have some bug in the compiler
4714 -- possibly triggered by a previous error, or by some unforeseen peculiar
4715 -- occurrence. However, this is only an optimization attempt, so there is
4716 -- really no point in crashing the compiler. Instead we just decide, too
4717 -- bad, we can't figure out the answer in this case after all.
4722 -- Debug flag K disables this behavior (useful for debugging)
4724 if Debug_Flag_K then
4735 function Is_In_Range
4738 Assume_Valid : Boolean := False;
4739 Fixed_Int : Boolean := False;
4740 Int_Real : Boolean := False) return Boolean
4744 Test_In_Range (N, Typ, Assume_Valid, Fixed_Int, Int_Real) = In_Range;
4751 function Is_Null_Range (Lo : Node_Id; Hi : Node_Id) return Boolean is
4752 Typ : constant Entity_Id := Etype (Lo);
4755 if not Compile_Time_Known_Value (Lo)
4756 or else not Compile_Time_Known_Value (Hi)
4761 if Is_Discrete_Type (Typ) then
4762 return Expr_Value (Lo) > Expr_Value (Hi);
4763 else pragma Assert (Is_Real_Type (Typ));
4764 return Expr_Value_R (Lo) > Expr_Value_R (Hi);
4768 -------------------------
4769 -- Is_OK_Static_Choice --
4770 -------------------------
4772 function Is_OK_Static_Choice (Choice : Node_Id) return Boolean is
4774 -- Check various possibilities for choice
4776 -- Note: for membership tests, we test more cases than are possible
4777 -- (in particular subtype indication), but it doesn't matter because
4778 -- it just won't occur (we have already done a syntax check).
4780 if Nkind (Choice) = N_Others_Choice then
4783 elsif Nkind (Choice) = N_Range then
4784 return Is_OK_Static_Range (Choice);
4786 elsif Nkind (Choice) = N_Subtype_Indication
4787 or else (Is_Entity_Name (Choice) and then Is_Type (Entity (Choice)))
4789 return Is_OK_Static_Subtype (Etype (Choice));
4792 return Is_OK_Static_Expression (Choice);
4794 end Is_OK_Static_Choice;
4796 ------------------------------
4797 -- Is_OK_Static_Choice_List --
4798 ------------------------------
4800 function Is_OK_Static_Choice_List (Choices : List_Id) return Boolean is
4804 if not Is_Static_Choice_List (Choices) then
4808 Choice := First (Choices);
4809 while Present (Choice) loop
4810 if not Is_OK_Static_Choice (Choice) then
4811 Set_Raises_Constraint_Error (Choice);
4819 end Is_OK_Static_Choice_List;
4821 -----------------------------
4822 -- Is_OK_Static_Expression --
4823 -----------------------------
4825 function Is_OK_Static_Expression (N : Node_Id) return Boolean is
4827 return Is_Static_Expression (N) and then not Raises_Constraint_Error (N);
4828 end Is_OK_Static_Expression;
4830 ------------------------
4831 -- Is_OK_Static_Range --
4832 ------------------------
4834 -- A static range is a range whose bounds are static expressions, or a
4835 -- Range_Attribute_Reference equivalent to such a range (RM 4.9(26)).
4836 -- We have already converted range attribute references, so we get the
4837 -- "or" part of this rule without needing a special test.
4839 function Is_OK_Static_Range (N : Node_Id) return Boolean is
4841 return Is_OK_Static_Expression (Low_Bound (N))
4842 and then Is_OK_Static_Expression (High_Bound (N));
4843 end Is_OK_Static_Range;
4845 --------------------------
4846 -- Is_OK_Static_Subtype --
4847 --------------------------
4849 -- Determines if Typ is a static subtype as defined in (RM 4.9(26)) where
4850 -- neither bound raises constraint error when evaluated.
4852 function Is_OK_Static_Subtype (Typ : Entity_Id) return Boolean is
4853 Base_T : constant Entity_Id := Base_Type (Typ);
4854 Anc_Subt : Entity_Id;
4857 -- First a quick check on the non static subtype flag. As described
4858 -- in further detail in Einfo, this flag is not decisive in all cases,
4859 -- but if it is set, then the subtype is definitely non-static.
4861 if Is_Non_Static_Subtype (Typ) then
4865 Anc_Subt := Ancestor_Subtype (Typ);
4867 if Anc_Subt = Empty then
4871 if Is_Generic_Type (Root_Type (Base_T))
4872 or else Is_Generic_Actual_Type (Base_T)
4876 elsif Has_Dynamic_Predicate_Aspect (Typ) then
4881 elsif Is_String_Type (Typ) then
4883 Ekind (Typ) = E_String_Literal_Subtype
4885 (Is_OK_Static_Subtype (Component_Type (Typ))
4886 and then Is_OK_Static_Subtype (Etype (First_Index (Typ))));
4890 elsif Is_Scalar_Type (Typ) then
4891 if Base_T = Typ then
4895 -- Scalar_Range (Typ) might be an N_Subtype_Indication, so use
4896 -- Get_Type_{Low,High}_Bound.
4898 return Is_OK_Static_Subtype (Anc_Subt)
4899 and then Is_OK_Static_Expression (Type_Low_Bound (Typ))
4900 and then Is_OK_Static_Expression (Type_High_Bound (Typ));
4903 -- Types other than string and scalar types are never static
4908 end Is_OK_Static_Subtype;
4910 ---------------------
4911 -- Is_Out_Of_Range --
4912 ---------------------
4914 function Is_Out_Of_Range
4917 Assume_Valid : Boolean := False;
4918 Fixed_Int : Boolean := False;
4919 Int_Real : Boolean := False) return Boolean
4922 return Test_In_Range (N, Typ, Assume_Valid, Fixed_Int, Int_Real) =
4924 end Is_Out_Of_Range;
4926 ----------------------
4927 -- Is_Static_Choice --
4928 ----------------------
4930 function Is_Static_Choice (Choice : Node_Id) return Boolean is
4932 -- Check various possibilities for choice
4934 -- Note: for membership tests, we test more cases than are possible
4935 -- (in particular subtype indication), but it doesn't matter because
4936 -- it just won't occur (we have already done a syntax check).
4938 if Nkind (Choice) = N_Others_Choice then
4941 elsif Nkind (Choice) = N_Range then
4942 return Is_Static_Range (Choice);
4944 elsif Nkind (Choice) = N_Subtype_Indication
4945 or else (Is_Entity_Name (Choice) and then Is_Type (Entity (Choice)))
4947 return Is_Static_Subtype (Etype (Choice));
4950 return Is_Static_Expression (Choice);
4952 end Is_Static_Choice;
4954 ---------------------------
4955 -- Is_Static_Choice_List --
4956 ---------------------------
4958 function Is_Static_Choice_List (Choices : List_Id) return Boolean is
4962 Choice := First (Choices);
4963 while Present (Choice) loop
4964 if not Is_Static_Choice (Choice) then
4972 end Is_Static_Choice_List;
4974 ---------------------
4975 -- Is_Static_Range --
4976 ---------------------
4978 -- A static range is a range whose bounds are static expressions, or a
4979 -- Range_Attribute_Reference equivalent to such a range (RM 4.9(26)).
4980 -- We have already converted range attribute references, so we get the
4981 -- "or" part of this rule without needing a special test.
4983 function Is_Static_Range (N : Node_Id) return Boolean is
4985 return Is_Static_Expression (Low_Bound (N))
4987 Is_Static_Expression (High_Bound (N));
4988 end Is_Static_Range;
4990 -----------------------
4991 -- Is_Static_Subtype --
4992 -----------------------
4994 -- Determines if Typ is a static subtype as defined in (RM 4.9(26))
4996 function Is_Static_Subtype (Typ : Entity_Id) return Boolean is
4997 Base_T : constant Entity_Id := Base_Type (Typ);
4998 Anc_Subt : Entity_Id;
5001 -- First a quick check on the non static subtype flag. As described
5002 -- in further detail in Einfo, this flag is not decisive in all cases,
5003 -- but if it is set, then the subtype is definitely non-static.
5005 if Is_Non_Static_Subtype (Typ) then
5009 Anc_Subt := Ancestor_Subtype (Typ);
5011 if Anc_Subt = Empty then
5015 if Is_Generic_Type (Root_Type (Base_T))
5016 or else Is_Generic_Actual_Type (Base_T)
5020 -- If there is a dynamic predicate for the type (declared or inherited)
5021 -- the expression is not static.
5023 elsif Has_Dynamic_Predicate_Aspect (Typ)
5024 or else (Is_Derived_Type (Typ)
5025 and then Has_Aspect (Typ, Aspect_Dynamic_Predicate))
5031 elsif Is_String_Type (Typ) then
5033 Ekind (Typ) = E_String_Literal_Subtype
5034 or else (Is_Static_Subtype (Component_Type (Typ))
5035 and then Is_Static_Subtype (Etype (First_Index (Typ))));
5039 elsif Is_Scalar_Type (Typ) then
5040 if Base_T = Typ then
5044 return Is_Static_Subtype (Anc_Subt)
5045 and then Is_Static_Expression (Type_Low_Bound (Typ))
5046 and then Is_Static_Expression (Type_High_Bound (Typ));
5049 -- Types other than string and scalar types are never static
5054 end Is_Static_Subtype;
5056 -------------------------------
5057 -- Is_Statically_Unevaluated --
5058 -------------------------------
5060 function Is_Statically_Unevaluated (Expr : Node_Id) return Boolean is
5061 function Check_Case_Expr_Alternative
5062 (CEA : Node_Id) return Match_Result;
5063 -- We have a message emanating from the Expression of a case expression
5064 -- alternative. We examine this alternative, as follows:
5066 -- If the selecting expression of the parent case is non-static, or
5067 -- if any of the discrete choices of the given case alternative are
5068 -- non-static or raise Constraint_Error, return Non_Static.
5070 -- Otherwise check if the selecting expression matches any of the given
5071 -- discrete choices. If so, the alternative is executed and we return
5072 -- Match, otherwise, the alternative can never be executed, and so we
5075 ---------------------------------
5076 -- Check_Case_Expr_Alternative --
5077 ---------------------------------
5079 function Check_Case_Expr_Alternative
5080 (CEA : Node_Id) return Match_Result
5082 Case_Exp : constant Node_Id := Parent (CEA);
5087 pragma Assert (Nkind (Case_Exp) = N_Case_Expression);
5089 -- Check that selecting expression is static
5091 if not Is_OK_Static_Expression (Expression (Case_Exp)) then
5095 if not Is_OK_Static_Choice_List (Discrete_Choices (CEA)) then
5099 -- All choices are now known to be static. Now see if alternative
5100 -- matches one of the choices.
5102 Choice := First (Discrete_Choices (CEA));
5103 while Present (Choice) loop
5105 -- Check various possibilities for choice, returning Match if we
5106 -- find the selecting value matches any of the choices. Note that
5107 -- we know we are the last choice, so we don't have to keep going.
5109 if Nkind (Choice) = N_Others_Choice then
5111 -- Others choice is a bit annoying, it matches if none of the
5112 -- previous alternatives matches (note that we know we are the
5113 -- last alternative in this case, so we can just go backwards
5114 -- from us to see if any previous one matches).
5116 Prev_CEA := Prev (CEA);
5117 while Present (Prev_CEA) loop
5118 if Check_Case_Expr_Alternative (Prev_CEA) = Match then
5127 -- Else we have a normal static choice
5129 elsif Choice_Matches (Expression (Case_Exp), Choice) = Match then
5133 -- If we fall through, it means that the discrete choice did not
5134 -- match the selecting expression, so continue.
5139 -- If we get through that loop then all choices were static, and none
5140 -- of them matched the selecting expression. So return No_Match.
5143 end Check_Case_Expr_Alternative;
5151 -- Start of processing for Is_Statically_Unevaluated
5154 -- The (32.x) references here are from RM section 4.9
5156 -- (32.1) An expression is statically unevaluated if it is part of ...
5158 -- This means we have to climb the tree looking for one of the cases
5165 -- (32.2) The right operand of a static short-circuit control form
5166 -- whose value is determined by its left operand.
5168 -- AND THEN with False as left operand
5170 if Nkind (P) = N_And_Then
5171 and then Compile_Time_Known_Value (Left_Opnd (P))
5172 and then Is_False (Expr_Value (Left_Opnd (P)))
5176 -- OR ELSE with True as left operand
5178 elsif Nkind (P) = N_Or_Else
5179 and then Compile_Time_Known_Value (Left_Opnd (P))
5180 and then Is_True (Expr_Value (Left_Opnd (P)))
5184 -- (32.3) A dependent_expression of an if_expression whose associated
5185 -- condition is static and equals False.
5187 elsif Nkind (P) = N_If_Expression then
5189 Cond : constant Node_Id := First (Expressions (P));
5190 Texp : constant Node_Id := Next (Cond);
5191 Fexp : constant Node_Id := Next (Texp);
5194 if Compile_Time_Known_Value (Cond) then
5196 -- Condition is True and we are in the right operand
5198 if Is_True (Expr_Value (Cond)) and then OldP = Fexp then
5201 -- Condition is False and we are in the left operand
5203 elsif Is_False (Expr_Value (Cond)) and then OldP = Texp then
5209 -- (32.4) A condition or dependent_expression of an if_expression
5210 -- where the condition corresponding to at least one preceding
5211 -- dependent_expression of the if_expression is static and equals
5214 -- This refers to cases like
5216 -- (if True then 1 elsif 1/0=2 then 2 else 3)
5218 -- But we expand elsif's out anyway, so the above looks like:
5220 -- (if True then 1 else (if 1/0=2 then 2 else 3))
5222 -- So for us this is caught by the above check for the 32.3 case.
5224 -- (32.5) A dependent_expression of a case_expression whose
5225 -- selecting_expression is static and whose value is not covered
5226 -- by the corresponding discrete_choice_list.
5228 elsif Nkind (P) = N_Case_Expression_Alternative then
5230 -- First, we have to be in the expression to suppress messages.
5231 -- If we are within one of the choices, we want the message.
5233 if OldP = Expression (P) then
5235 -- Statically unevaluated if alternative does not match
5237 if Check_Case_Expr_Alternative (P) = No_Match then
5242 -- (32.6) A choice_expression (or a simple_expression of a range
5243 -- that occurs as a membership_choice of a membership_choice_list)
5244 -- of a static membership test that is preceded in the enclosing
5245 -- membership_choice_list by another item whose individual
5246 -- membership test (see (RM 4.5.2)) statically yields True.
5248 elsif Nkind (P) in N_Membership_Test then
5250 -- Only possibly unevaluated if simple expression is static
5252 if not Is_OK_Static_Expression (Left_Opnd (P)) then
5255 -- All members of the choice list must be static
5257 elsif (Present (Right_Opnd (P))
5258 and then not Is_OK_Static_Choice (Right_Opnd (P)))
5259 or else (Present (Alternatives (P))
5261 not Is_OK_Static_Choice_List (Alternatives (P)))
5265 -- If expression is the one and only alternative, then it is
5266 -- definitely not statically unevaluated, so we only have to
5267 -- test the case where there are alternatives present.
5269 elsif Present (Alternatives (P)) then
5271 -- Look for previous matching Choice
5273 Choice := First (Alternatives (P));
5274 while Present (Choice) loop
5276 -- If we reached us and no previous choices matched, this
5277 -- is not the case where we are statically unevaluated.
5279 exit when OldP = Choice;
5281 -- If a previous choice matches, then that is the case where
5282 -- we know our choice is statically unevaluated.
5284 if Choice_Matches (Left_Opnd (P), Choice) = Match then
5291 -- If we fall through the loop, we were not one of the choices,
5292 -- we must have been the expression, so that is not covered by
5293 -- this rule, and we keep going.
5299 -- OK, not statically unevaluated at this level, see if we should
5300 -- keep climbing to look for a higher level reason.
5302 -- Special case for component association in aggregates, where
5303 -- we want to keep climbing up to the parent aggregate.
5305 if Nkind (P) = N_Component_Association
5306 and then Nkind (Parent (P)) = N_Aggregate
5310 -- All done if not still within subexpression
5313 exit when Nkind (P) not in N_Subexpr;
5317 -- If we fall through the loop, not one of the cases covered!
5320 end Is_Statically_Unevaluated;
5322 --------------------
5323 -- Not_Null_Range --
5324 --------------------
5326 function Not_Null_Range (Lo : Node_Id; Hi : Node_Id) return Boolean is
5327 Typ : constant Entity_Id := Etype (Lo);
5330 if not Compile_Time_Known_Value (Lo)
5331 or else not Compile_Time_Known_Value (Hi)
5336 if Is_Discrete_Type (Typ) then
5337 return Expr_Value (Lo) <= Expr_Value (Hi);
5338 else pragma Assert (Is_Real_Type (Typ));
5339 return Expr_Value_R (Lo) <= Expr_Value_R (Hi);
5347 function OK_Bits (N : Node_Id; Bits : Uint) return Boolean is
5349 -- We allow a maximum of 500,000 bits which seems a reasonable limit
5351 if Bits < 500_000 then
5354 -- Error if this maximum is exceeded
5357 Error_Msg_N ("static value too large, capacity exceeded", N);
5366 procedure Out_Of_Range (N : Node_Id) is
5368 -- If we have the static expression case, then this is an illegality
5369 -- in Ada 95 mode, except that in an instance, we never generate an
5370 -- error (if the error is legitimate, it was already diagnosed in the
5373 if Is_Static_Expression (N)
5374 and then not In_Instance
5375 and then not In_Inlined_Body
5376 and then Ada_Version >= Ada_95
5378 -- No message if we are statically unevaluated
5380 if Is_Statically_Unevaluated (N) then
5383 -- The expression to compute the length of a packed array is attached
5384 -- to the array type itself, and deserves a separate message.
5386 elsif Nkind (Parent (N)) = N_Defining_Identifier
5387 and then Is_Array_Type (Parent (N))
5388 and then Present (Packed_Array_Impl_Type (Parent (N)))
5389 and then Present (First_Rep_Item (Parent (N)))
5392 ("length of packed array must not exceed Integer''Last",
5393 First_Rep_Item (Parent (N)));
5394 Rewrite (N, Make_Integer_Literal (Sloc (N), Uint_1));
5396 -- All cases except the special array case
5399 Apply_Compile_Time_Constraint_Error
5400 (N, "value not in range of}", CE_Range_Check_Failed);
5403 -- Here we generate a warning for the Ada 83 case, or when we are in an
5404 -- instance, or when we have a non-static expression case.
5407 Apply_Compile_Time_Constraint_Error
5408 (N, "value not in range of}??", CE_Range_Check_Failed);
5412 ----------------------
5413 -- Predicates_Match --
5414 ----------------------
5416 function Predicates_Match (T1, T2 : Entity_Id) return Boolean is
5421 if Ada_Version < Ada_2012 then
5424 -- Both types must have predicates or lack them
5426 elsif Has_Predicates (T1) /= Has_Predicates (T2) then
5429 -- Check matching predicates
5434 (T1, Name_Static_Predicate, Check_Parents => False);
5437 (T2, Name_Static_Predicate, Check_Parents => False);
5439 -- Subtypes statically match if the predicate comes from the
5440 -- same declaration, which can only happen if one is a subtype
5441 -- of the other and has no explicit predicate.
5443 -- Suppress warnings on order of actuals, which is otherwise
5444 -- triggered by one of the two calls below.
5446 pragma Warnings (Off);
5447 return Pred1 = Pred2
5448 or else (No (Pred1) and then Is_Subtype_Of (T1, T2))
5449 or else (No (Pred2) and then Is_Subtype_Of (T2, T1));
5450 pragma Warnings (On);
5452 end Predicates_Match;
5454 ---------------------------------------------
5455 -- Real_Or_String_Static_Predicate_Matches --
5456 ---------------------------------------------
5458 function Real_Or_String_Static_Predicate_Matches
5460 Typ : Entity_Id) return Boolean
5462 Expr : constant Node_Id := Static_Real_Or_String_Predicate (Typ);
5463 -- The predicate expression from the type
5465 Pfun : constant Entity_Id := Predicate_Function (Typ);
5466 -- The entity for the predicate function
5468 Ent_Name : constant Name_Id := Chars (First_Formal (Pfun));
5469 -- The name of the formal of the predicate function. Occurrences of the
5470 -- type name in Expr have been rewritten as references to this formal,
5471 -- and it has a unique name, so we can identify references by this name.
5474 -- Copy of the predicate function tree
5476 function Process (N : Node_Id) return Traverse_Result;
5477 -- Function used to process nodes during the traversal in which we will
5478 -- find occurrences of the entity name, and replace such occurrences
5479 -- by a real literal with the value to be tested.
5481 procedure Traverse is new Traverse_Proc (Process);
5482 -- The actual traversal procedure
5488 function Process (N : Node_Id) return Traverse_Result is
5490 if Nkind (N) = N_Identifier and then Chars (N) = Ent_Name then
5492 Nod : constant Node_Id := New_Copy (Val);
5494 Set_Sloc (Nod, Sloc (N));
5499 -- The predicate function may contain string-comparison operations
5500 -- that have been converted into calls to run-time array-comparison
5501 -- routines. To evaluate the predicate statically, we recover the
5502 -- original comparison operation and replace the occurrence of the
5503 -- formal by the static string value. The actuals of the generated
5504 -- call are of the form X'Address.
5506 elsif Nkind (N) in N_Op_Compare
5507 and then Nkind (Left_Opnd (N)) = N_Function_Call
5510 C : constant Node_Id := Left_Opnd (N);
5511 F : constant Node_Id := First (Parameter_Associations (C));
5512 L : constant Node_Id := Prefix (F);
5513 R : constant Node_Id := Prefix (Next (F));
5516 -- If an operand is an entity name, it is the formal of the
5517 -- predicate function, so replace it with the string value.
5518 -- It may be either operand in the call. The other operand
5519 -- is a static string from the original predicate.
5521 if Is_Entity_Name (L) then
5522 Rewrite (Left_Opnd (N), New_Copy (Val));
5523 Rewrite (Right_Opnd (N), New_Copy (R));
5526 Rewrite (Left_Opnd (N), New_Copy (L));
5527 Rewrite (Right_Opnd (N), New_Copy (Val));
5538 -- Start of processing for Real_Or_String_Static_Predicate_Matches
5541 -- First deal with special case of inherited predicate, where the
5542 -- predicate expression looks like:
5544 -- xxPredicate (typ (Ent)) and then Expr
5546 -- where Expr is the predicate expression for this level, and the
5547 -- left operand is the call to evaluate the inherited predicate.
5549 if Nkind (Expr) = N_And_Then
5550 and then Nkind (Left_Opnd (Expr)) = N_Function_Call
5551 and then Is_Predicate_Function (Entity (Name (Left_Opnd (Expr))))
5553 -- OK we have the inherited case, so make a call to evaluate the
5554 -- inherited predicate. If that fails, so do we!
5557 Real_Or_String_Static_Predicate_Matches
5559 Typ => Etype (First_Formal (Entity (Name (Left_Opnd (Expr))))))
5564 -- Use the right operand for the continued processing
5566 Copy := Copy_Separate_Tree (Right_Opnd (Expr));
5568 -- Case where call to predicate function appears on its own (this means
5569 -- that the predicate at this level is just inherited from the parent).
5571 elsif Nkind (Expr) = N_Function_Call then
5573 Typ : constant Entity_Id :=
5574 Etype (First_Formal (Entity (Name (Expr))));
5577 -- If the inherited predicate is dynamic, just ignore it. We can't
5578 -- go trying to evaluate a dynamic predicate as a static one!
5580 if Has_Dynamic_Predicate_Aspect (Typ) then
5583 -- Otherwise inherited predicate is static, check for match
5586 return Real_Or_String_Static_Predicate_Matches (Val, Typ);
5590 -- If not just an inherited predicate, copy whole expression
5593 Copy := Copy_Separate_Tree (Expr);
5596 -- Now we replace occurrences of the entity by the value
5600 -- And analyze the resulting static expression to see if it is True
5602 Analyze_And_Resolve (Copy, Standard_Boolean);
5603 return Is_True (Expr_Value (Copy));
5604 end Real_Or_String_Static_Predicate_Matches;
5606 -------------------------
5607 -- Rewrite_In_Raise_CE --
5608 -------------------------
5610 procedure Rewrite_In_Raise_CE (N : Node_Id; Exp : Node_Id) is
5611 Typ : constant Entity_Id := Etype (N);
5612 Stat : constant Boolean := Is_Static_Expression (N);
5615 -- If we want to raise CE in the condition of a N_Raise_CE node, we
5616 -- can just clear the condition if the reason is appropriate. We do
5617 -- not do this operation if the parent has a reason other than range
5618 -- check failed, because otherwise we would change the reason.
5620 if Present (Parent (N))
5621 and then Nkind (Parent (N)) = N_Raise_Constraint_Error
5622 and then Reason (Parent (N)) =
5623 UI_From_Int (RT_Exception_Code'Pos (CE_Range_Check_Failed))
5625 Set_Condition (Parent (N), Empty);
5627 -- Else build an explicit N_Raise_CE
5631 Make_Raise_Constraint_Error (Sloc (Exp),
5632 Reason => CE_Range_Check_Failed));
5633 Set_Raises_Constraint_Error (N);
5637 -- Set proper flags in result
5639 Set_Raises_Constraint_Error (N, True);
5640 Set_Is_Static_Expression (N, Stat);
5641 end Rewrite_In_Raise_CE;
5643 ---------------------
5644 -- String_Type_Len --
5645 ---------------------
5647 function String_Type_Len (Stype : Entity_Id) return Uint is
5648 NT : constant Entity_Id := Etype (First_Index (Stype));
5652 if Is_OK_Static_Subtype (NT) then
5655 T := Base_Type (NT);
5658 return Expr_Value (Type_High_Bound (T)) -
5659 Expr_Value (Type_Low_Bound (T)) + 1;
5660 end String_Type_Len;
5662 ------------------------------------
5663 -- Subtypes_Statically_Compatible --
5664 ------------------------------------
5666 function Subtypes_Statically_Compatible
5669 Formal_Derived_Matching : Boolean := False) return Boolean
5674 if Is_Scalar_Type (T1) then
5676 -- Definitely compatible if we match
5678 if Subtypes_Statically_Match (T1, T2) then
5681 -- If either subtype is nonstatic then they're not compatible
5683 elsif not Is_OK_Static_Subtype (T1)
5685 not Is_OK_Static_Subtype (T2)
5689 -- Base types must match, but we don't check that (should we???) but
5690 -- we do at least check that both types are real, or both types are
5693 elsif Is_Real_Type (T1) /= Is_Real_Type (T2) then
5696 -- Here we check the bounds
5700 LB1 : constant Node_Id := Type_Low_Bound (T1);
5701 HB1 : constant Node_Id := Type_High_Bound (T1);
5702 LB2 : constant Node_Id := Type_Low_Bound (T2);
5703 HB2 : constant Node_Id := Type_High_Bound (T2);
5706 if Is_Real_Type (T1) then
5708 Expr_Value_R (LB1) > Expr_Value_R (HB1)
5710 (Expr_Value_R (LB2) <= Expr_Value_R (LB1)
5711 and then Expr_Value_R (HB1) <= Expr_Value_R (HB2));
5715 Expr_Value (LB1) > Expr_Value (HB1)
5717 (Expr_Value (LB2) <= Expr_Value (LB1)
5718 and then Expr_Value (HB1) <= Expr_Value (HB2));
5725 elsif Is_Access_Type (T1) then
5727 (not Is_Constrained (T2)
5728 or else Subtypes_Statically_Match
5729 (Designated_Type (T1), Designated_Type (T2)))
5730 and then not (Can_Never_Be_Null (T2)
5731 and then not Can_Never_Be_Null (T1));
5737 (Is_Composite_Type (T1) and then not Is_Constrained (T2))
5738 or else Subtypes_Statically_Match
5739 (T1, T2, Formal_Derived_Matching);
5741 end Subtypes_Statically_Compatible;
5743 -------------------------------
5744 -- Subtypes_Statically_Match --
5745 -------------------------------
5747 -- Subtypes statically match if they have statically matching constraints
5748 -- (RM 4.9.1(2)). Constraints statically match if there are none, or if
5749 -- they are the same identical constraint, or if they are static and the
5750 -- values match (RM 4.9.1(1)).
5752 -- In addition, in GNAT, the object size (Esize) values of the types must
5753 -- match if they are set (unless checking an actual for a formal derived
5754 -- type). The use of 'Object_Size can cause this to be false even if the
5755 -- types would otherwise match in the RM sense.
5757 function Subtypes_Statically_Match
5760 Formal_Derived_Matching : Boolean := False) return Boolean
5763 -- A type always statically matches itself
5768 -- No match if sizes different (from use of 'Object_Size). This test
5769 -- is excluded if Formal_Derived_Matching is True, as the base types
5770 -- can be different in that case and typically have different sizes.
5771 -- ??? Frontend_Layout_On_Target used to set Esizes but this is no
5772 -- longer the case, consider removing the last test below.
5774 elsif not Formal_Derived_Matching
5775 and then Known_Static_Esize (T1)
5776 and then Known_Static_Esize (T2)
5777 and then Esize (T1) /= Esize (T2)
5781 -- No match if predicates do not match
5783 elsif not Predicates_Match (T1, T2) then
5788 elsif Is_Scalar_Type (T1) then
5790 -- Base types must be the same
5792 if Base_Type (T1) /= Base_Type (T2) then
5796 -- A constrained numeric subtype never matches an unconstrained
5797 -- subtype, i.e. both types must be constrained or unconstrained.
5799 -- To understand the requirement for this test, see RM 4.9.1(1).
5800 -- As is made clear in RM 3.5.4(11), type Integer, for example is
5801 -- a constrained subtype with constraint bounds matching the bounds
5802 -- of its corresponding unconstrained base type. In this situation,
5803 -- Integer and Integer'Base do not statically match, even though
5804 -- they have the same bounds.
5806 -- We only apply this test to types in Standard and types that appear
5807 -- in user programs. That way, we do not have to be too careful about
5808 -- setting Is_Constrained right for Itypes.
5810 if Is_Numeric_Type (T1)
5811 and then (Is_Constrained (T1) /= Is_Constrained (T2))
5812 and then (Scope (T1) = Standard_Standard
5813 or else Comes_From_Source (T1))
5814 and then (Scope (T2) = Standard_Standard
5815 or else Comes_From_Source (T2))
5819 -- A generic scalar type does not statically match its base type
5820 -- (AI-311). In this case we make sure that the formals, which are
5821 -- first subtypes of their bases, are constrained.
5823 elsif Is_Generic_Type (T1)
5824 and then Is_Generic_Type (T2)
5825 and then (Is_Constrained (T1) /= Is_Constrained (T2))
5830 -- If there was an error in either range, then just assume the types
5831 -- statically match to avoid further junk errors.
5833 if No (Scalar_Range (T1)) or else No (Scalar_Range (T2))
5834 or else Error_Posted (Scalar_Range (T1))
5835 or else Error_Posted (Scalar_Range (T2))
5840 -- Otherwise both types have bounds that can be compared
5843 LB1 : constant Node_Id := Type_Low_Bound (T1);
5844 HB1 : constant Node_Id := Type_High_Bound (T1);
5845 LB2 : constant Node_Id := Type_Low_Bound (T2);
5846 HB2 : constant Node_Id := Type_High_Bound (T2);
5849 -- If the bounds are the same tree node, then match (common case)
5851 if LB1 = LB2 and then HB1 = HB2 then
5854 -- Otherwise bounds must be static and identical value
5857 if not Is_OK_Static_Subtype (T1)
5859 not Is_OK_Static_Subtype (T2)
5863 elsif Is_Real_Type (T1) then
5865 Expr_Value_R (LB1) = Expr_Value_R (LB2)
5867 Expr_Value_R (HB1) = Expr_Value_R (HB2);
5871 Expr_Value (LB1) = Expr_Value (LB2)
5873 Expr_Value (HB1) = Expr_Value (HB2);
5878 -- Type with discriminants
5880 elsif Has_Discriminants (T1) or else Has_Discriminants (T2) then
5882 -- Because of view exchanges in multiple instantiations, conformance
5883 -- checking might try to match a partial view of a type with no
5884 -- discriminants with a full view that has defaulted discriminants.
5885 -- In such a case, use the discriminant constraint of the full view,
5886 -- which must exist because we know that the two subtypes have the
5889 if Has_Discriminants (T1) /= Has_Discriminants (T2) then
5890 -- A generic actual type is declared through a subtype declaration
5891 -- and may have an inconsistent indication of the presence of
5892 -- discriminants, so check the type it renames.
5894 if Is_Generic_Actual_Type (T1)
5895 and then not Has_Discriminants (Etype (T1))
5896 and then not Has_Discriminants (T2)
5900 elsif In_Instance then
5901 if Is_Private_Type (T2)
5902 and then Present (Full_View (T2))
5903 and then Has_Discriminants (Full_View (T2))
5905 return Subtypes_Statically_Match (T1, Full_View (T2));
5907 elsif Is_Private_Type (T1)
5908 and then Present (Full_View (T1))
5909 and then Has_Discriminants (Full_View (T1))
5911 return Subtypes_Statically_Match (Full_View (T1), T2);
5922 DL1 : constant Elist_Id := Discriminant_Constraint (T1);
5923 DL2 : constant Elist_Id := Discriminant_Constraint (T2);
5931 elsif Is_Constrained (T1) /= Is_Constrained (T2) then
5935 -- Now loop through the discriminant constraints
5937 -- Note: the guard here seems necessary, since it is possible at
5938 -- least for DL1 to be No_Elist. Not clear this is reasonable ???
5940 if Present (DL1) and then Present (DL2) then
5941 DA1 := First_Elmt (DL1);
5942 DA2 := First_Elmt (DL2);
5943 while Present (DA1) loop
5945 Expr1 : constant Node_Id := Node (DA1);
5946 Expr2 : constant Node_Id := Node (DA2);
5949 if not Is_OK_Static_Expression (Expr1)
5950 or else not Is_OK_Static_Expression (Expr2)
5954 -- If either expression raised a constraint error,
5955 -- consider the expressions as matching, since this
5956 -- helps to prevent cascading errors.
5958 elsif Raises_Constraint_Error (Expr1)
5959 or else Raises_Constraint_Error (Expr2)
5963 elsif Expr_Value (Expr1) /= Expr_Value (Expr2) then
5976 -- A definite type does not match an indefinite or classwide type.
5977 -- However, a generic type with unknown discriminants may be
5978 -- instantiated with a type with no discriminants, and conformance
5979 -- checking on an inherited operation may compare the actual with the
5980 -- subtype that renames it in the instance.
5982 elsif Has_Unknown_Discriminants (T1) /= Has_Unknown_Discriminants (T2)
5985 Is_Generic_Actual_Type (T1) or else Is_Generic_Actual_Type (T2);
5989 elsif Is_Array_Type (T1) then
5991 -- If either subtype is unconstrained then both must be, and if both
5992 -- are unconstrained then no further checking is needed.
5994 if not Is_Constrained (T1) or else not Is_Constrained (T2) then
5995 return not (Is_Constrained (T1) or else Is_Constrained (T2));
5998 -- Both subtypes are constrained, so check that the index subtypes
5999 -- statically match.
6002 Index1 : Node_Id := First_Index (T1);
6003 Index2 : Node_Id := First_Index (T2);
6006 while Present (Index1) loop
6008 Subtypes_Statically_Match (Etype (Index1), Etype (Index2))
6013 Next_Index (Index1);
6014 Next_Index (Index2);
6020 elsif Is_Access_Type (T1) then
6021 if Can_Never_Be_Null (T1) /= Can_Never_Be_Null (T2) then
6024 elsif Ekind_In (T1, E_Access_Subprogram_Type,
6025 E_Anonymous_Access_Subprogram_Type)
6029 (Designated_Type (T1),
6030 Designated_Type (T2));
6033 Subtypes_Statically_Match
6034 (Designated_Type (T1),
6035 Designated_Type (T2))
6036 and then Is_Access_Constant (T1) = Is_Access_Constant (T2);
6039 -- All other types definitely match
6044 end Subtypes_Statically_Match;
6050 function Test (Cond : Boolean) return Uint is
6059 ---------------------
6060 -- Test_Comparison --
6061 ---------------------
6063 procedure Test_Comparison
6065 Assume_Valid : Boolean;
6066 True_Result : out Boolean;
6067 False_Result : out Boolean)
6069 Left : constant Node_Id := Left_Opnd (Op);
6070 Left_Typ : constant Entity_Id := Etype (Left);
6071 Orig_Op : constant Node_Id := Original_Node (Op);
6073 procedure Replacement_Warning (Msg : String);
6074 -- Emit a warning on a comparison that can be replaced by '='
6076 -------------------------
6077 -- Replacement_Warning --
6078 -------------------------
6080 procedure Replacement_Warning (Msg : String) is
6082 if Constant_Condition_Warnings
6083 and then Comes_From_Source (Orig_Op)
6084 and then Is_Integer_Type (Left_Typ)
6085 and then not Error_Posted (Op)
6086 and then not Has_Warnings_Off (Left_Typ)
6087 and then not In_Instance
6089 Error_Msg_N (Msg, Op);
6091 end Replacement_Warning;
6095 Res : constant Compare_Result :=
6096 Compile_Time_Compare (Left, Right_Opnd (Op), Assume_Valid);
6098 -- Start of processing for Test_Comparison
6101 case N_Op_Compare (Nkind (Op)) is
6103 True_Result := Res = EQ;
6104 False_Result := Res = LT or else Res = GT or else Res = NE;
6107 True_Result := Res in Compare_GE;
6108 False_Result := Res = LT;
6110 if Res = LE and then Nkind (Orig_Op) = N_Op_Ge then
6112 ("can never be greater than, could replace by ""'=""?c?");
6116 True_Result := Res = GT;
6117 False_Result := Res in Compare_LE;
6120 True_Result := Res in Compare_LE;
6121 False_Result := Res = GT;
6123 if Res = GE and then Nkind (Orig_Op) = N_Op_Le then
6125 ("can never be less than, could replace by ""'=""?c?");
6129 True_Result := Res = LT;
6130 False_Result := Res in Compare_GE;
6133 True_Result := Res = NE or else Res = GT or else Res = LT;
6134 False_Result := Res = EQ;
6136 end Test_Comparison;
6138 ---------------------------------
6139 -- Test_Expression_Is_Foldable --
6140 ---------------------------------
6144 procedure Test_Expression_Is_Foldable
6154 if Debug_Flag_Dot_F and then In_Extended_Main_Source_Unit (N) then
6158 -- If operand is Any_Type, just propagate to result and do not
6159 -- try to fold, this prevents cascaded errors.
6161 if Etype (Op1) = Any_Type then
6162 Set_Etype (N, Any_Type);
6165 -- If operand raises constraint error, then replace node N with the
6166 -- raise constraint error node, and we are obviously not foldable.
6167 -- Note that this replacement inherits the Is_Static_Expression flag
6168 -- from the operand.
6170 elsif Raises_Constraint_Error (Op1) then
6171 Rewrite_In_Raise_CE (N, Op1);
6174 -- If the operand is not static, then the result is not static, and
6175 -- all we have to do is to check the operand since it is now known
6176 -- to appear in a non-static context.
6178 elsif not Is_Static_Expression (Op1) then
6179 Check_Non_Static_Context (Op1);
6180 Fold := Compile_Time_Known_Value (Op1);
6183 -- An expression of a formal modular type is not foldable because
6184 -- the modulus is unknown.
6186 elsif Is_Modular_Integer_Type (Etype (Op1))
6187 and then Is_Generic_Type (Etype (Op1))
6189 Check_Non_Static_Context (Op1);
6192 -- Here we have the case of an operand whose type is OK, which is
6193 -- static, and which does not raise constraint error, we can fold.
6196 Set_Is_Static_Expression (N);
6200 end Test_Expression_Is_Foldable;
6204 procedure Test_Expression_Is_Foldable
6210 CRT_Safe : Boolean := False)
6212 Rstat : constant Boolean := Is_Static_Expression (Op1)
6214 Is_Static_Expression (Op2);
6220 -- Inhibit folding if -gnatd.f flag set
6222 if Debug_Flag_Dot_F and then In_Extended_Main_Source_Unit (N) then
6226 -- If either operand is Any_Type, just propagate to result and
6227 -- do not try to fold, this prevents cascaded errors.
6229 if Etype (Op1) = Any_Type or else Etype (Op2) = Any_Type then
6230 Set_Etype (N, Any_Type);
6233 -- If left operand raises constraint error, then replace node N with the
6234 -- Raise_Constraint_Error node, and we are obviously not foldable.
6235 -- Is_Static_Expression is set from the two operands in the normal way,
6236 -- and we check the right operand if it is in a non-static context.
6238 elsif Raises_Constraint_Error (Op1) then
6240 Check_Non_Static_Context (Op2);
6243 Rewrite_In_Raise_CE (N, Op1);
6244 Set_Is_Static_Expression (N, Rstat);
6247 -- Similar processing for the case of the right operand. Note that we
6248 -- don't use this routine for the short-circuit case, so we do not have
6249 -- to worry about that special case here.
6251 elsif Raises_Constraint_Error (Op2) then
6253 Check_Non_Static_Context (Op1);
6256 Rewrite_In_Raise_CE (N, Op2);
6257 Set_Is_Static_Expression (N, Rstat);
6260 -- Exclude expressions of a generic modular type, as above
6262 elsif Is_Modular_Integer_Type (Etype (Op1))
6263 and then Is_Generic_Type (Etype (Op1))
6265 Check_Non_Static_Context (Op1);
6268 -- If result is not static, then check non-static contexts on operands
6269 -- since one of them may be static and the other one may not be static.
6271 elsif not Rstat then
6272 Check_Non_Static_Context (Op1);
6273 Check_Non_Static_Context (Op2);
6276 Fold := CRT_Safe_Compile_Time_Known_Value (Op1)
6277 and then CRT_Safe_Compile_Time_Known_Value (Op2);
6279 Fold := Compile_Time_Known_Value (Op1)
6280 and then Compile_Time_Known_Value (Op2);
6285 -- Else result is static and foldable. Both operands are static, and
6286 -- neither raises constraint error, so we can definitely fold.
6289 Set_Is_Static_Expression (N);
6294 end Test_Expression_Is_Foldable;
6300 function Test_In_Range
6303 Assume_Valid : Boolean;
6304 Fixed_Int : Boolean;
6305 Int_Real : Boolean) return Range_Membership
6310 pragma Warnings (Off, Assume_Valid);
6311 -- For now Assume_Valid is unreferenced since the current implementation
6312 -- always returns Unknown if N is not a compile time known value, but we
6313 -- keep the parameter to allow for future enhancements in which we try
6314 -- to get the information in the variable case as well.
6317 -- If an error was posted on expression, then return Unknown, we do not
6318 -- want cascaded errors based on some false analysis of a junk node.
6320 if Error_Posted (N) then
6323 -- Expression that raises constraint error is an odd case. We certainly
6324 -- do not want to consider it to be in range. It might make sense to
6325 -- consider it always out of range, but this causes incorrect error
6326 -- messages about static expressions out of range. So we just return
6327 -- Unknown, which is always safe.
6329 elsif Raises_Constraint_Error (N) then
6332 -- Universal types have no range limits, so always in range
6334 elsif Typ = Universal_Integer or else Typ = Universal_Real then
6337 -- Never known if not scalar type. Don't know if this can actually
6338 -- happen, but our spec allows it, so we must check.
6340 elsif not Is_Scalar_Type (Typ) then
6343 -- Never known if this is a generic type, since the bounds of generic
6344 -- types are junk. Note that if we only checked for static expressions
6345 -- (instead of compile time known values) below, we would not need this
6346 -- check, because values of a generic type can never be static, but they
6347 -- can be known at compile time.
6349 elsif Is_Generic_Type (Typ) then
6352 -- Case of a known compile time value, where we can check if it is in
6353 -- the bounds of the given type.
6355 elsif Compile_Time_Known_Value (N) then
6364 Lo := Type_Low_Bound (Typ);
6365 Hi := Type_High_Bound (Typ);
6367 LB_Known := Compile_Time_Known_Value (Lo);
6368 HB_Known := Compile_Time_Known_Value (Hi);
6370 -- Fixed point types should be considered as such only if flag
6371 -- Fixed_Int is set to False.
6373 if Is_Floating_Point_Type (Typ)
6374 or else (Is_Fixed_Point_Type (Typ) and then not Fixed_Int)
6377 Valr := Expr_Value_R (N);
6379 if LB_Known and HB_Known then
6380 if Valr >= Expr_Value_R (Lo)
6382 Valr <= Expr_Value_R (Hi)
6386 return Out_Of_Range;
6389 elsif (LB_Known and then Valr < Expr_Value_R (Lo))
6391 (HB_Known and then Valr > Expr_Value_R (Hi))
6393 return Out_Of_Range;
6400 Val := Expr_Value (N);
6402 if LB_Known and HB_Known then
6403 if Val >= Expr_Value (Lo) and then Val <= Expr_Value (Hi)
6407 return Out_Of_Range;
6410 elsif (LB_Known and then Val < Expr_Value (Lo))
6412 (HB_Known and then Val > Expr_Value (Hi))
6414 return Out_Of_Range;
6422 -- Here for value not known at compile time. Case of expression subtype
6423 -- is Typ or is a subtype of Typ, and we can assume expression is valid.
6424 -- In this case we know it is in range without knowing its value.
6427 and then (Etype (N) = Typ or else Is_Subtype_Of (Etype (N), Typ))
6431 -- Another special case. For signed integer types, if the target type
6432 -- has Is_Known_Valid set, and the source type does not have a larger
6433 -- size, then the source value must be in range. We exclude biased
6434 -- types, because they bizarrely can generate out of range values.
6436 elsif Is_Signed_Integer_Type (Etype (N))
6437 and then Is_Known_Valid (Typ)
6438 and then Esize (Etype (N)) <= Esize (Typ)
6439 and then not Has_Biased_Representation (Etype (N))
6443 -- For all other cases, result is unknown
6454 procedure To_Bits (U : Uint; B : out Bits) is
6456 for J in 0 .. B'Last loop
6457 B (J) := (U / (2 ** J)) mod 2 /= 0;
6461 --------------------
6462 -- Why_Not_Static --
6463 --------------------
6465 procedure Why_Not_Static (Expr : Node_Id) is
6466 N : constant Node_Id := Original_Node (Expr);
6467 Typ : Entity_Id := Empty;
6472 procedure Why_Not_Static_List (L : List_Id);
6473 -- A version that can be called on a list of expressions. Finds all
6474 -- non-static violations in any element of the list.
6476 -------------------------
6477 -- Why_Not_Static_List --
6478 -------------------------
6480 procedure Why_Not_Static_List (L : List_Id) is
6483 if Is_Non_Empty_List (L) then
6485 while Present (N) loop
6490 end Why_Not_Static_List;
6492 -- Start of processing for Why_Not_Static
6495 -- Ignore call on error or empty node
6497 if No (Expr) or else Nkind (Expr) = N_Error then
6501 -- Preprocessing for sub expressions
6503 if Nkind (Expr) in N_Subexpr then
6505 -- Nothing to do if expression is static
6507 if Is_OK_Static_Expression (Expr) then
6511 -- Test for constraint error raised
6513 if Raises_Constraint_Error (Expr) then
6515 -- Special case membership to find out which piece to flag
6517 if Nkind (N) in N_Membership_Test then
6518 if Raises_Constraint_Error (Left_Opnd (N)) then
6519 Why_Not_Static (Left_Opnd (N));
6522 elsif Present (Right_Opnd (N))
6523 and then Raises_Constraint_Error (Right_Opnd (N))
6525 Why_Not_Static (Right_Opnd (N));
6529 pragma Assert (Present (Alternatives (N)));
6531 Alt := First (Alternatives (N));
6532 while Present (Alt) loop
6533 if Raises_Constraint_Error (Alt) then
6534 Why_Not_Static (Alt);
6542 -- Special case a range to find out which bound to flag
6544 elsif Nkind (N) = N_Range then
6545 if Raises_Constraint_Error (Low_Bound (N)) then
6546 Why_Not_Static (Low_Bound (N));
6549 elsif Raises_Constraint_Error (High_Bound (N)) then
6550 Why_Not_Static (High_Bound (N));
6554 -- Special case attribute to see which part to flag
6556 elsif Nkind (N) = N_Attribute_Reference then
6557 if Raises_Constraint_Error (Prefix (N)) then
6558 Why_Not_Static (Prefix (N));
6562 if Present (Expressions (N)) then
6563 Exp := First (Expressions (N));
6564 while Present (Exp) loop
6565 if Raises_Constraint_Error (Exp) then
6566 Why_Not_Static (Exp);
6574 -- Special case a subtype name
6576 elsif Is_Entity_Name (Expr) and then Is_Type (Entity (Expr)) then
6578 ("!& is not a static subtype (RM 4.9(26))", N, Entity (Expr));
6582 -- End of special cases
6585 ("!expression raises exception, cannot be static (RM 4.9(34))",
6590 -- If no type, then something is pretty wrong, so ignore
6592 Typ := Etype (Expr);
6598 -- Type must be scalar or string type (but allow Bignum, since this
6599 -- is really a scalar type from our point of view in this diagnosis).
6601 if not Is_Scalar_Type (Typ)
6602 and then not Is_String_Type (Typ)
6603 and then not Is_RTE (Typ, RE_Bignum)
6606 ("!static expression must have scalar or string type " &
6612 -- If we got through those checks, test particular node kind
6618 when N_Expanded_Name
6624 if Is_Named_Number (E) then
6627 elsif Ekind (E) = E_Constant then
6629 -- One case we can give a metter message is when we have a
6630 -- string literal created by concatenating an aggregate with
6631 -- an others expression.
6633 Entity_Case : declare
6634 CV : constant Node_Id := Constant_Value (E);
6635 CO : constant Node_Id := Original_Node (CV);
6637 function Is_Aggregate (N : Node_Id) return Boolean;
6638 -- See if node N came from an others aggregate, if so
6639 -- return True and set Error_Msg_Sloc to aggregate.
6645 function Is_Aggregate (N : Node_Id) return Boolean is
6647 if Nkind (Original_Node (N)) = N_Aggregate then
6648 Error_Msg_Sloc := Sloc (Original_Node (N));
6651 elsif Is_Entity_Name (N)
6652 and then Ekind (Entity (N)) = E_Constant
6654 Nkind (Original_Node (Constant_Value (Entity (N)))) =
6658 Sloc (Original_Node (Constant_Value (Entity (N))));
6666 -- Start of processing for Entity_Case
6669 if Is_Aggregate (CV)
6670 or else (Nkind (CO) = N_Op_Concat
6671 and then (Is_Aggregate (Left_Opnd (CO))
6673 Is_Aggregate (Right_Opnd (CO))))
6675 Error_Msg_N ("!aggregate (#) is never static", N);
6677 elsif No (CV) or else not Is_Static_Expression (CV) then
6679 ("!& is not a static constant (RM 4.9(5))", N, E);
6683 elsif Is_Type (E) then
6685 ("!& is not a static subtype (RM 4.9(26))", N, E);
6689 ("!& is not static constant or named number "
6690 & "(RM 4.9(5))", N, E);
6699 if Nkind (N) in N_Op_Shift then
6701 ("!shift functions are never static (RM 4.9(6,18))", N);
6703 Why_Not_Static (Left_Opnd (N));
6704 Why_Not_Static (Right_Opnd (N));
6710 Why_Not_Static (Right_Opnd (N));
6712 -- Attribute reference
6714 when N_Attribute_Reference =>
6715 Why_Not_Static_List (Expressions (N));
6717 E := Etype (Prefix (N));
6719 if E = Standard_Void_Type then
6723 -- Special case non-scalar'Size since this is a common error
6725 if Attribute_Name (N) = Name_Size then
6727 ("!size attribute is only static for static scalar type "
6728 & "(RM 4.9(7,8))", N);
6732 elsif Is_Array_Type (E) then
6733 if not Nam_In (Attribute_Name (N), Name_First,
6738 ("!static array attribute must be Length, First, or Last "
6739 & "(RM 4.9(8))", N);
6741 -- Since we know the expression is not-static (we already
6742 -- tested for this, must mean array is not static).
6746 ("!prefix is non-static array (RM 4.9(8))", Prefix (N));
6751 -- Special case generic types, since again this is a common source
6754 elsif Is_Generic_Actual_Type (E) or else Is_Generic_Type (E) then
6756 ("!attribute of generic type is never static "
6757 & "(RM 4.9(7,8))", N);
6759 elsif Is_OK_Static_Subtype (E) then
6762 elsif Is_Scalar_Type (E) then
6764 ("!prefix type for attribute is not static scalar subtype "
6765 & "(RM 4.9(7))", N);
6769 ("!static attribute must apply to array/scalar type "
6770 & "(RM 4.9(7,8))", N);
6775 when N_String_Literal =>
6777 ("!subtype of string literal is non-static (RM 4.9(4))", N);
6779 -- Explicit dereference
6781 when N_Explicit_Dereference =>
6783 ("!explicit dereference is never static (RM 4.9)", N);
6787 when N_Function_Call =>
6788 Why_Not_Static_List (Parameter_Associations (N));
6790 -- Complain about non-static function call unless we have Bignum
6791 -- which means that the underlying expression is really some
6792 -- scalar arithmetic operation.
6794 if not Is_RTE (Typ, RE_Bignum) then
6795 Error_Msg_N ("!non-static function call (RM 4.9(6,18))", N);
6798 -- Parameter assocation (test actual parameter)
6800 when N_Parameter_Association =>
6801 Why_Not_Static (Explicit_Actual_Parameter (N));
6803 -- Indexed component
6805 when N_Indexed_Component =>
6806 Error_Msg_N ("!indexed component is never static (RM 4.9)", N);
6810 when N_Procedure_Call_Statement =>
6811 Error_Msg_N ("!procedure call is never static (RM 4.9)", N);
6813 -- Qualified expression (test expression)
6815 when N_Qualified_Expression =>
6816 Why_Not_Static (Expression (N));
6821 | N_Extension_Aggregate
6823 Error_Msg_N ("!an aggregate is never static (RM 4.9)", N);
6828 Why_Not_Static (Low_Bound (N));
6829 Why_Not_Static (High_Bound (N));
6831 -- Range constraint, test range expression
6833 when N_Range_Constraint =>
6834 Why_Not_Static (Range_Expression (N));
6836 -- Subtype indication, test constraint
6838 when N_Subtype_Indication =>
6839 Why_Not_Static (Constraint (N));
6841 -- Selected component
6843 when N_Selected_Component =>
6844 Error_Msg_N ("!selected component is never static (RM 4.9)", N);
6849 Error_Msg_N ("!slice is never static (RM 4.9)", N);
6851 when N_Type_Conversion =>
6852 Why_Not_Static (Expression (N));
6854 if not Is_Scalar_Type (Entity (Subtype_Mark (N)))
6855 or else not Is_OK_Static_Subtype (Entity (Subtype_Mark (N)))
6858 ("!static conversion requires static scalar subtype result "
6859 & "(RM 4.9(9))", N);
6862 -- Unchecked type conversion
6864 when N_Unchecked_Type_Conversion =>
6866 ("!unchecked type conversion is never static (RM 4.9)", N);
6868 -- All other cases, no reason to give