1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 with Aspects; use Aspects;
27 with Atree; use Atree;
28 with Checks; use Checks;
29 with Debug; use Debug;
30 with Einfo; use Einfo;
31 with Elists; use Elists;
32 with Errout; use Errout;
33 with Eval_Fat; use Eval_Fat;
34 with Exp_Util; use Exp_Util;
35 with Freeze; use Freeze;
37 with Namet; use Namet;
38 with Nmake; use Nmake;
39 with Nlists; use Nlists;
41 with Par_SCO; use Par_SCO;
42 with Rtsfind; use Rtsfind;
44 with Sem_Aux; use Sem_Aux;
45 with Sem_Cat; use Sem_Cat;
46 with Sem_Ch6; use Sem_Ch6;
47 with Sem_Ch8; use Sem_Ch8;
48 with Sem_Elab; use Sem_Elab;
49 with Sem_Res; use Sem_Res;
50 with Sem_Util; use Sem_Util;
51 with Sem_Type; use Sem_Type;
52 with Sem_Warn; use Sem_Warn;
53 with Sinfo; use Sinfo;
54 with Snames; use Snames;
55 with Stand; use Stand;
56 with Stringt; use Stringt;
57 with Tbuild; use Tbuild;
59 package body Sem_Eval is
61 -----------------------------------------
62 -- Handling of Compile Time Evaluation --
63 -----------------------------------------
65 -- The compile time evaluation of expressions is distributed over several
66 -- Eval_xxx procedures. These procedures are called immediately after
67 -- a subexpression is resolved and is therefore accomplished in a bottom
68 -- up fashion. The flags are synthesized using the following approach.
70 -- Is_Static_Expression is determined by following the rules in
71 -- RM-4.9. This involves testing the Is_Static_Expression flag of
72 -- the operands in many cases.
74 -- Raises_Constraint_Error is usually set if any of the operands have
75 -- the flag set or if an attempt to compute the value of the current
76 -- expression results in Constraint_Error.
78 -- The general approach is as follows. First compute Is_Static_Expression.
79 -- If the node is not static, then the flag is left off in the node and
80 -- we are all done. Otherwise for a static node, we test if any of the
81 -- operands will raise Constraint_Error, and if so, propagate the flag
82 -- Raises_Constraint_Error to the result node and we are done (since the
83 -- error was already posted at a lower level).
85 -- For the case of a static node whose operands do not raise constraint
86 -- error, we attempt to evaluate the node. If this evaluation succeeds,
87 -- then the node is replaced by the result of this computation. If the
88 -- evaluation raises Constraint_Error, then we rewrite the node with
89 -- Apply_Compile_Time_Constraint_Error to raise the exception and also
90 -- to post appropriate error messages.
96 type Bits is array (Nat range <>) of Boolean;
97 -- Used to convert unsigned (modular) values for folding logical ops
99 -- The following declarations are used to maintain a cache of nodes that
100 -- have compile-time-known values. The cache is maintained only for
101 -- discrete types (the most common case), and is populated by calls to
102 -- Compile_Time_Known_Value and Expr_Value, but only used by Expr_Value
103 -- since it is possible for the status to change (in particular it is
104 -- possible for a node to get replaced by a Constraint_Error node).
106 CV_Bits : constant := 5;
107 -- Number of low order bits of Node_Id value used to reference entries
108 -- in the cache table.
110 CV_Cache_Size : constant Nat := 2 ** CV_Bits;
111 -- Size of cache for compile time values
113 subtype CV_Range is Nat range 0 .. CV_Cache_Size;
115 type CV_Entry is record
120 type Match_Result is (Match, No_Match, Non_Static);
121 -- Result returned from functions that test for a matching result. If the
122 -- operands are not OK_Static then Non_Static will be returned. Otherwise
123 -- Match/No_Match is returned depending on whether the match succeeds.
125 type CV_Cache_Array is array (CV_Range) of CV_Entry;
127 CV_Cache : CV_Cache_Array := (others => (Node_High_Bound, Uint_0));
128 -- This is the actual cache, with entries consisting of node/value pairs,
129 -- and the impossible value Node_High_Bound used for unset entries.
131 type Range_Membership is (In_Range, Out_Of_Range, Unknown);
132 -- Range membership may either be statically known to be in range or out
133 -- of range, or not statically known. Used for Test_In_Range below.
135 Checking_For_Potentially_Static_Expression : Boolean := False;
136 -- Global flag that is set True during Analyze_Static_Expression_Function
137 -- in order to verify that the result expression of a static expression
138 -- function is a potentially static function (see RM202x 6.8(5.3)).
140 -----------------------
141 -- Local Subprograms --
142 -----------------------
144 function Choice_Matches
146 Choice : Node_Id) return Match_Result;
147 -- Determines whether given value Expr matches the given Choice. The Expr
148 -- can be of discrete, real, or string type and must be a compile time
149 -- known value (it is an error to make the call if these conditions are
150 -- not met). The choice can be a range, subtype name, subtype indication,
151 -- or expression. The returned result is Non_Static if Choice is not
152 -- OK_Static, otherwise either Match or No_Match is returned depending
153 -- on whether Choice matches Expr. This is used for case expression
154 -- alternatives, and also for membership tests. In each case, more
155 -- possibilities are tested than the syntax allows (e.g. membership allows
156 -- subtype indications and non-discrete types, and case allows an OTHERS
157 -- choice), but it does not matter, since we have already done a full
158 -- semantic and syntax check of the construct, so the extra possibilities
159 -- just will not arise for correct expressions.
161 -- Note: if Choice_Matches finds that a choice raises Constraint_Error, e.g
162 -- a reference to a type, one of whose bounds raises Constraint_Error, then
163 -- it also sets the Raises_Constraint_Error flag on the Choice itself.
165 function Choices_Match
167 Choices : List_Id) return Match_Result;
168 -- This function applies Choice_Matches to each element of Choices. If the
169 -- result is No_Match, then it continues and checks the next element. If
170 -- the result is Match or Non_Static, this result is immediately given
171 -- as the result without checking the rest of the list. Expr can be of
172 -- discrete, real, or string type and must be a compile-time-known value
173 -- (it is an error to make the call if these conditions are not met).
175 procedure Eval_Intrinsic_Call (N : Node_Id; E : Entity_Id);
176 -- Evaluate a call N to an intrinsic subprogram E.
178 function Find_Universal_Operator_Type (N : Node_Id) return Entity_Id;
179 -- Check whether an arithmetic operation with universal operands which is a
180 -- rewritten function call with an explicit scope indication is ambiguous:
181 -- P."+" (1, 2) will be ambiguous if there is more than one visible numeric
182 -- type declared in P and the context does not impose a type on the result
183 -- (e.g. in the expression of a type conversion). If ambiguous, emit an
184 -- error and return Empty, else return the result type of the operator.
186 procedure Fold_Dummy (N : Node_Id; Typ : Entity_Id);
187 -- Rewrite N as a constant dummy value in the relevant type if possible.
194 Static : Boolean := False;
195 Check_Elab : Boolean := False);
196 -- Rewrite N as the result of evaluating Left <shift op> Right if possible.
197 -- Op represents the shift operation.
198 -- Static indicates whether the resulting node should be marked static.
199 -- Check_Elab indicates whether checks for elaboration calls should be
200 -- inserted when relevant.
202 function From_Bits (B : Bits; T : Entity_Id) return Uint;
203 -- Converts a bit string of length B'Length to a Uint value to be used for
204 -- a target of type T, which is a modular type. This procedure includes the
205 -- necessary reduction by the modulus in the case of a nonbinary modulus
206 -- (for a binary modulus, the bit string is the right length any way so all
209 function Get_String_Val (N : Node_Id) return Node_Id;
210 -- Given a tree node for a folded string or character value, returns the
211 -- corresponding string literal or character literal (one of the two must
212 -- be available, or the operand would not have been marked as foldable in
213 -- the earlier analysis of the operation).
215 function Is_OK_Static_Choice (Choice : Node_Id) return Boolean;
216 -- Given a choice (from a case expression or membership test), returns
217 -- True if the choice is static and does not raise a Constraint_Error.
219 function Is_OK_Static_Choice_List (Choices : List_Id) return Boolean;
220 -- Given a choice list (from a case expression or membership test), return
221 -- True if all choices are static in the sense of Is_OK_Static_Choice.
223 function Is_Static_Choice (Choice : Node_Id) return Boolean;
224 -- Given a choice (from a case expression or membership test), returns
225 -- True if the choice is static. No test is made for raising of constraint
226 -- error, so this function is used only for legality tests.
228 function Is_Static_Choice_List (Choices : List_Id) return Boolean;
229 -- Given a choice list (from a case expression or membership test), return
230 -- True if all choices are static in the sense of Is_Static_Choice.
232 function Is_Static_Range (N : Node_Id) return Boolean;
233 -- Determine if range is static, as defined in RM 4.9(26). The only allowed
234 -- argument is an N_Range node (but note that the semantic analysis of
235 -- equivalent range attribute references already turned them into the
236 -- equivalent range). This differs from Is_OK_Static_Range (which is what
237 -- must be used by clients) in that it does not care whether the bounds
238 -- raise Constraint_Error or not. Used for checking whether expressions are
239 -- static in the 4.9 sense (without worrying about exceptions).
241 function OK_Bits (N : Node_Id; Bits : Uint) return Boolean;
242 -- Bits represents the number of bits in an integer value to be computed
243 -- (but the value has not been computed yet). If this value in Bits is
244 -- reasonable, a result of True is returned, with the implication that the
245 -- caller should go ahead and complete the calculation. If the value in
246 -- Bits is unreasonably large, then an error is posted on node N, and
247 -- False is returned (and the caller skips the proposed calculation).
249 procedure Out_Of_Range (N : Node_Id);
250 -- This procedure is called if it is determined that node N, which appears
251 -- in a non-static context, is a compile-time-known value which is outside
252 -- its range, i.e. the range of Etype. This is used in contexts where
253 -- this is an illegality if N is static, and should generate a warning
256 function Real_Or_String_Static_Predicate_Matches
258 Typ : Entity_Id) return Boolean;
259 -- This is the function used to evaluate real or string static predicates.
260 -- Val is an unanalyzed N_Real_Literal or N_String_Literal node, which
261 -- represents the value to be tested against the predicate. Typ is the
262 -- type with the predicate, from which the predicate expression can be
263 -- extracted. The result returned is True if the given value satisfies
266 procedure Rewrite_In_Raise_CE (N : Node_Id; Exp : Node_Id);
267 -- N and Exp are nodes representing an expression, Exp is known to raise
268 -- CE. N is rewritten in term of Exp in the optimal way.
270 function String_Type_Len (Stype : Entity_Id) return Uint;
271 -- Given a string type, determines the length of the index type, or, if
272 -- this index type is non-static, the length of the base type of this index
273 -- type. Note that if the string type is itself static, then the index type
274 -- is static, so the second case applies only if the string type passed is
277 function Test (Cond : Boolean) return Uint;
278 pragma Inline (Test);
279 -- This function simply returns the appropriate Boolean'Pos value
280 -- corresponding to the value of Cond as a universal integer. It is
281 -- used for producing the result of the static evaluation of the
284 procedure Test_Expression_Is_Foldable
289 -- Tests to see if expression N whose single operand is Op1 is foldable,
290 -- i.e. the operand value is known at compile time. If the operation is
291 -- foldable, then Fold is True on return, and Stat indicates whether the
292 -- result is static (i.e. the operand was static). Note that it is quite
293 -- possible for Fold to be True, and Stat to be False, since there are
294 -- cases in which we know the value of an operand even though it is not
295 -- technically static (e.g. the static lower bound of a range whose upper
296 -- bound is non-static).
298 -- If Stat is set False on return, then Test_Expression_Is_Foldable makes
299 -- a call to Check_Non_Static_Context on the operand. If Fold is False on
300 -- return, then all processing is complete, and the caller should return,
301 -- since there is nothing else to do.
303 -- If Stat is set True on return, then Is_Static_Expression is also set
304 -- true in node N. There are some cases where this is over-enthusiastic,
305 -- e.g. in the two operand case below, for string comparison, the result is
306 -- not static even though the two operands are static. In such cases, the
307 -- caller must reset the Is_Static_Expression flag in N.
309 -- If Fold and Stat are both set to False then this routine performs also
310 -- the following extra actions:
312 -- If either operand is Any_Type then propagate it to result to prevent
315 -- If some operand raises Constraint_Error, then replace the node N
316 -- with the raise Constraint_Error node. This replacement inherits the
317 -- Is_Static_Expression flag from the operands.
319 procedure Test_Expression_Is_Foldable
325 CRT_Safe : Boolean := False);
326 -- Same processing, except applies to an expression N with two operands
327 -- Op1 and Op2. The result is static only if both operands are static. If
328 -- CRT_Safe is set True, then CRT_Safe_Compile_Time_Known_Value is used
329 -- for the tests that the two operands are known at compile time. See
330 -- spec of this routine for further details.
332 function Test_In_Range
335 Assume_Valid : Boolean;
337 Int_Real : Boolean) return Range_Membership;
338 -- Common processing for Is_In_Range and Is_Out_Of_Range: Returns In_Range
339 -- or Out_Of_Range if it can be guaranteed at compile time that expression
340 -- N is known to be in or out of range of the subtype Typ. If not compile
341 -- time known, Unknown is returned. See documentation of Is_In_Range for
342 -- complete description of parameters.
344 procedure To_Bits (U : Uint; B : out Bits);
345 -- Converts a Uint value to a bit string of length B'Length
347 -----------------------------------------------
348 -- Check_Expression_Against_Static_Predicate --
349 -----------------------------------------------
351 procedure Check_Expression_Against_Static_Predicate
354 Static_Failure_Is_Error : Boolean := False)
357 -- Nothing to do if expression is not known at compile time, or the
358 -- type has no static predicate set (will be the case for all non-scalar
359 -- types, so no need to make a special test for that).
361 if not (Has_Static_Predicate (Typ)
362 and then Compile_Time_Known_Value (Expr))
367 -- Here we have a static predicate (note that it could have arisen from
368 -- an explicitly specified Dynamic_Predicate whose expression met the
369 -- rules for being predicate-static). If the expression is known at
370 -- compile time and obeys the predicate, then it is static and must be
371 -- labeled as such, which matters e.g. for case statements. The original
372 -- expression may be a type conversion of a variable with a known value,
373 -- which might otherwise not be marked static.
375 -- Case of real static predicate
377 if Is_Real_Type (Typ) then
378 if Real_Or_String_Static_Predicate_Matches
379 (Val => Make_Real_Literal (Sloc (Expr), Expr_Value_R (Expr)),
382 Set_Is_Static_Expression (Expr);
386 -- Case of string static predicate
388 elsif Is_String_Type (Typ) then
389 if Real_Or_String_Static_Predicate_Matches
390 (Val => Expr_Value_S (Expr), Typ => Typ)
392 Set_Is_Static_Expression (Expr);
396 -- Case of discrete static predicate
399 pragma Assert (Is_Discrete_Type (Typ));
401 -- If static predicate matches, nothing to do
403 if Choices_Match (Expr, Static_Discrete_Predicate (Typ)) = Match then
404 Set_Is_Static_Expression (Expr);
409 -- Here we know that the predicate will fail
411 -- Special case of static expression failing a predicate (other than one
412 -- that was explicitly specified with a Dynamic_Predicate aspect). If
413 -- the expression comes from a qualified_expression or type_conversion
414 -- this is an error (Static_Failure_Is_Error); otherwise we only issue
415 -- a warning and the expression is no longer considered static.
417 if Is_Static_Expression (Expr)
418 and then not Has_Dynamic_Predicate_Aspect (Typ)
420 if Static_Failure_Is_Error then
422 ("static expression fails static predicate check on &",
427 ("??static expression fails static predicate check on &",
430 ("\??expression is no longer considered static", Expr);
432 Set_Is_Static_Expression (Expr, False);
435 -- In all other cases, this is just a warning that a test will fail.
436 -- It does not matter if the expression is static or not, or if the
437 -- predicate comes from a dynamic predicate aspect or not.
441 ("??expression fails predicate check on &", Expr, Typ);
443 -- Force a check here, which is potentially a redundant check, but
444 -- this ensures a check will be done in cases where the expression
445 -- is folded, and since this is definitely a failure, extra checks
448 if Predicate_Enabled (Typ) then
451 (Typ, Duplicate_Subexpr (Expr)), Suppress => All_Checks);
454 end Check_Expression_Against_Static_Predicate;
456 ------------------------------
457 -- Check_Non_Static_Context --
458 ------------------------------
460 procedure Check_Non_Static_Context (N : Node_Id) is
461 T : constant Entity_Id := Etype (N);
462 Checks_On : constant Boolean :=
463 not Index_Checks_Suppressed (T)
464 and not Range_Checks_Suppressed (T);
467 -- Ignore cases of non-scalar types, error types, or universal real
468 -- types that have no usable bounds.
471 or else not Is_Scalar_Type (T)
472 or else T = Universal_Fixed
473 or else T = Universal_Real
478 -- At this stage we have a scalar type. If we have an expression that
479 -- raises CE, then we already issued a warning or error msg so there is
480 -- nothing more to be done in this routine.
482 if Raises_Constraint_Error (N) then
486 -- Now we have a scalar type which is not marked as raising a constraint
487 -- error exception. The main purpose of this routine is to deal with
488 -- static expressions appearing in a non-static context. That means
489 -- that if we do not have a static expression then there is not much
490 -- to do. The one case that we deal with here is that if we have a
491 -- floating-point value that is out of range, then we post a warning
492 -- that an infinity will result.
494 if not Is_Static_Expression (N) then
495 if Is_Floating_Point_Type (T) then
496 if Is_Out_Of_Range (N, Base_Type (T), Assume_Valid => True) then
498 ("??float value out of range, infinity will be generated", N);
500 -- The literal may be the result of constant-folding of a non-
501 -- static subexpression of a larger expression (e.g. a conversion
502 -- of a non-static variable whose value happens to be known). At
503 -- this point we must reduce the value of the subexpression to a
504 -- machine number (RM 4.9 (38/2)).
506 elsif Nkind (N) = N_Real_Literal
507 and then Nkind (Parent (N)) in N_Subexpr
509 Rewrite (N, New_Copy (N));
511 (N, Machine (Base_Type (T), Realval (N), Round_Even, N));
518 -- Here we have the case of outer level static expression of scalar
519 -- type, where the processing of this procedure is needed.
521 -- For real types, this is where we convert the value to a machine
522 -- number (see RM 4.9(38)). Also see ACVC test C490001. We should only
523 -- need to do this if the parent is a constant declaration, since in
524 -- other cases, gigi should do the necessary conversion correctly, but
525 -- experimentation shows that this is not the case on all machines, in
526 -- particular if we do not convert all literals to machine values in
527 -- non-static contexts, then ACVC test C490001 fails on Sparc/Solaris
530 -- This conversion is always done by GNATprove on real literals in
531 -- non-static expressions, by calling Check_Non_Static_Context from
532 -- gnat2why, as GNATprove cannot do the conversion later contrary
533 -- to gigi. The frontend computes the information about which
534 -- expressions are static, which is used by gnat2why to call
535 -- Check_Non_Static_Context on exactly those real literals that are
536 -- not subexpressions of static expressions.
538 if Nkind (N) = N_Real_Literal
539 and then not Is_Machine_Number (N)
540 and then not Is_Generic_Type (Etype (N))
541 and then Etype (N) /= Universal_Real
543 -- Check that value is in bounds before converting to machine
544 -- number, so as not to lose case where value overflows in the
545 -- least significant bit or less. See B490001.
547 if Is_Out_Of_Range (N, Base_Type (T), Assume_Valid => True) then
552 -- Note: we have to copy the node, to avoid problems with conformance
553 -- of very similar numbers (see ACVC tests B4A010C and B63103A).
555 Rewrite (N, New_Copy (N));
557 if not Is_Floating_Point_Type (T) then
559 (N, Corresponding_Integer_Value (N) * Small_Value (T));
561 elsif not UR_Is_Zero (Realval (N)) then
563 -- Note: even though RM 4.9(38) specifies biased rounding, this
564 -- has been modified by AI-100 in order to prevent confusing
565 -- differences in rounding between static and non-static
566 -- expressions. AI-100 specifies that the effect of such rounding
567 -- is implementation dependent, and in GNAT we round to nearest
568 -- even to match the run-time behavior. Note that this applies
569 -- to floating point literals, not fixed points ones, even though
570 -- their compiler representation is also as a universal real.
573 (N, Machine (Base_Type (T), Realval (N), Round_Even, N));
574 Set_Is_Machine_Number (N);
579 -- Check for out of range universal integer. This is a non-static
580 -- context, so the integer value must be in range of the runtime
581 -- representation of universal integers.
583 -- We do this only within an expression, because that is the only
584 -- case in which non-static universal integer values can occur, and
585 -- furthermore, Check_Non_Static_Context is currently (incorrectly???)
586 -- called in contexts like the expression of a number declaration where
587 -- we certainly want to allow out of range values.
589 -- We inhibit the warning when expansion is disabled, because the
590 -- preanalysis of a range of a 64-bit modular type may appear to
591 -- violate the constraint on non-static Universal_Integer. If there
592 -- is a true overflow it will be diagnosed during full analysis.
594 if Etype (N) = Universal_Integer
595 and then Nkind (N) = N_Integer_Literal
596 and then Nkind (Parent (N)) in N_Subexpr
597 and then Expander_Active
599 (Intval (N) < Expr_Value (Type_Low_Bound (Universal_Integer))
601 Intval (N) > Expr_Value (Type_High_Bound (Universal_Integer)))
603 Apply_Compile_Time_Constraint_Error
604 (N, "non-static universal integer value out of range<<",
605 CE_Range_Check_Failed);
607 -- Check out of range of base type
609 elsif Is_Out_Of_Range (N, Base_Type (T), Assume_Valid => True) then
612 -- Give a warning or error on the value outside the subtype. A warning
613 -- is omitted if the expression appears in a range that could be null
614 -- (warnings are handled elsewhere for this case).
616 elsif T /= Base_Type (T) and then Nkind (Parent (N)) /= N_Range then
617 if Is_In_Range (N, T, Assume_Valid => True) then
620 elsif Is_Out_Of_Range (N, T, Assume_Valid => True) then
621 -- Ignore out of range values for System.Priority in CodePeer
622 -- mode since the actual target compiler may provide a wider
625 if CodePeer_Mode and then Is_RTE (T, RE_Priority) then
626 Set_Do_Range_Check (N, False);
628 -- Determine if the out-of-range violation constitutes a warning
629 -- or an error based on context, according to RM 4.9 (34/3).
631 elsif Nkind (Original_Node (N)) in
632 N_Type_Conversion | N_Qualified_Expression
633 and then Comes_From_Source (Original_Node (N))
635 Apply_Compile_Time_Constraint_Error
636 (N, "value not in range of}", CE_Range_Check_Failed);
638 Apply_Compile_Time_Constraint_Error
639 (N, "value not in range of}<<", CE_Range_Check_Failed);
643 Enable_Range_Check (N);
646 Set_Do_Range_Check (N, False);
649 end Check_Non_Static_Context;
651 ---------------------------------
652 -- Check_String_Literal_Length --
653 ---------------------------------
655 procedure Check_String_Literal_Length (N : Node_Id; Ttype : Entity_Id) is
657 if not Raises_Constraint_Error (N) and then Is_Constrained (Ttype) then
658 if UI_From_Int (String_Length (Strval (N))) /= String_Type_Len (Ttype)
660 Apply_Compile_Time_Constraint_Error
661 (N, "string length wrong for}??",
662 CE_Length_Check_Failed,
667 end Check_String_Literal_Length;
669 --------------------------------------------
670 -- Checking_Potentially_Static_Expression --
671 --------------------------------------------
673 function Checking_Potentially_Static_Expression return Boolean is
675 return Checking_For_Potentially_Static_Expression;
676 end Checking_Potentially_Static_Expression;
682 function Choice_Matches
684 Choice : Node_Id) return Match_Result
686 Etyp : constant Entity_Id := Etype (Expr);
692 pragma Assert (Compile_Time_Known_Value (Expr));
693 pragma Assert (Is_Scalar_Type (Etyp) or else Is_String_Type (Etyp));
695 if not Is_OK_Static_Choice (Choice) then
696 Set_Raises_Constraint_Error (Choice);
699 -- When the choice denotes a subtype with a static predictate, check the
700 -- expression against the predicate values. Different procedures apply
701 -- to discrete and non-discrete types.
703 elsif (Nkind (Choice) = N_Subtype_Indication
704 or else (Is_Entity_Name (Choice)
705 and then Is_Type (Entity (Choice))))
706 and then Has_Predicates (Etype (Choice))
707 and then Has_Static_Predicate (Etype (Choice))
709 if Is_Discrete_Type (Etype (Choice)) then
712 (Expr, Static_Discrete_Predicate (Etype (Choice)));
714 elsif Real_Or_String_Static_Predicate_Matches (Expr, Etype (Choice))
722 -- Discrete type case only
724 elsif Is_Discrete_Type (Etyp) then
725 Val := Expr_Value (Expr);
727 if Nkind (Choice) = N_Range then
728 if Val >= Expr_Value (Low_Bound (Choice))
730 Val <= Expr_Value (High_Bound (Choice))
737 elsif Nkind (Choice) = N_Subtype_Indication
738 or else (Is_Entity_Name (Choice) and then Is_Type (Entity (Choice)))
740 if Val >= Expr_Value (Type_Low_Bound (Etype (Choice)))
742 Val <= Expr_Value (Type_High_Bound (Etype (Choice)))
749 elsif Nkind (Choice) = N_Others_Choice then
753 if Val = Expr_Value (Choice) then
762 elsif Is_Real_Type (Etyp) then
763 ValR := Expr_Value_R (Expr);
765 if Nkind (Choice) = N_Range then
766 if ValR >= Expr_Value_R (Low_Bound (Choice))
768 ValR <= Expr_Value_R (High_Bound (Choice))
775 elsif Nkind (Choice) = N_Subtype_Indication
776 or else (Is_Entity_Name (Choice) and then Is_Type (Entity (Choice)))
778 if ValR >= Expr_Value_R (Type_Low_Bound (Etype (Choice)))
780 ValR <= Expr_Value_R (Type_High_Bound (Etype (Choice)))
788 if ValR = Expr_Value_R (Choice) then
798 pragma Assert (Is_String_Type (Etyp));
799 ValS := Expr_Value_S (Expr);
801 if Nkind (Choice) = N_Subtype_Indication
802 or else (Is_Entity_Name (Choice) and then Is_Type (Entity (Choice)))
804 if not Is_Constrained (Etype (Choice)) then
809 Typlen : constant Uint :=
810 String_Type_Len (Etype (Choice));
811 Strlen : constant Uint :=
812 UI_From_Int (String_Length (Strval (ValS)));
814 if Typlen = Strlen then
823 if String_Equal (Strval (ValS), Strval (Expr_Value_S (Choice)))
837 function Choices_Match
839 Choices : List_Id) return Match_Result
842 Result : Match_Result;
845 Choice := First (Choices);
846 while Present (Choice) loop
847 Result := Choice_Matches (Expr, Choice);
849 if Result /= No_Match then
859 --------------------------
860 -- Compile_Time_Compare --
861 --------------------------
863 function Compile_Time_Compare
865 Assume_Valid : Boolean) return Compare_Result
867 Discard : aliased Uint;
869 return Compile_Time_Compare (L, R, Discard'Access, Assume_Valid);
870 end Compile_Time_Compare;
872 function Compile_Time_Compare
875 Assume_Valid : Boolean;
876 Rec : Boolean := False) return Compare_Result
878 Ltyp : Entity_Id := Etype (L);
879 Rtyp : Entity_Id := Etype (R);
881 Discard : aliased Uint;
883 procedure Compare_Decompose
887 -- This procedure decomposes the node N into an expression node and a
888 -- signed offset, so that the value of N is equal to the value of R plus
889 -- the value V (which may be negative). If no such decomposition is
890 -- possible, then on return R is a copy of N, and V is set to zero.
892 function Compare_Fixup (N : Node_Id) return Node_Id;
893 -- This function deals with replacing 'Last and 'First references with
894 -- their corresponding type bounds, which we then can compare. The
895 -- argument is the original node, the result is the identity, unless we
896 -- have a 'Last/'First reference in which case the value returned is the
897 -- appropriate type bound.
899 function Is_Known_Valid_Operand (Opnd : Node_Id) return Boolean;
900 -- Even if the context does not assume that values are valid, some
901 -- simple cases can be recognized.
903 function Is_Same_Value (L, R : Node_Id) return Boolean;
904 -- Returns True iff L and R represent expressions that definitely have
905 -- identical (but not necessarily compile-time-known) values Indeed the
906 -- caller is expected to have already dealt with the cases of compile
907 -- time known values, so these are not tested here.
909 -----------------------
910 -- Compare_Decompose --
911 -----------------------
913 procedure Compare_Decompose
919 if Nkind (N) = N_Op_Add
920 and then Nkind (Right_Opnd (N)) = N_Integer_Literal
923 V := Intval (Right_Opnd (N));
926 elsif Nkind (N) = N_Op_Subtract
927 and then Nkind (Right_Opnd (N)) = N_Integer_Literal
930 V := UI_Negate (Intval (Right_Opnd (N)));
933 elsif Nkind (N) = N_Attribute_Reference then
934 if Attribute_Name (N) = Name_Succ then
935 R := First (Expressions (N));
939 elsif Attribute_Name (N) = Name_Pred then
940 R := First (Expressions (N));
948 end Compare_Decompose;
954 function Compare_Fixup (N : Node_Id) return Node_Id is
960 -- Fixup only required for First/Last attribute reference
962 if Nkind (N) = N_Attribute_Reference
963 and then Attribute_Name (N) in Name_First | Name_Last
965 Xtyp := Etype (Prefix (N));
967 -- If we have no type, then just abandon the attempt to do
968 -- a fixup, this is probably the result of some other error.
974 -- Dereference an access type
976 if Is_Access_Type (Xtyp) then
977 Xtyp := Designated_Type (Xtyp);
980 -- If we don't have an array type at this stage, something is
981 -- peculiar, e.g. another error, and we abandon the attempt at
984 if not Is_Array_Type (Xtyp) then
988 -- Ignore unconstrained array, since bounds are not meaningful
990 if not Is_Constrained (Xtyp) then
994 if Ekind (Xtyp) = E_String_Literal_Subtype then
995 if Attribute_Name (N) = Name_First then
996 return String_Literal_Low_Bound (Xtyp);
999 Make_Integer_Literal (Sloc (N),
1000 Intval => Intval (String_Literal_Low_Bound (Xtyp)) +
1001 String_Literal_Length (Xtyp));
1005 -- Find correct index type
1007 Indx := First_Index (Xtyp);
1009 if Present (Expressions (N)) then
1010 Subs := UI_To_Int (Expr_Value (First (Expressions (N))));
1012 for J in 2 .. Subs loop
1017 Xtyp := Etype (Indx);
1019 if Attribute_Name (N) = Name_First then
1020 return Type_Low_Bound (Xtyp);
1022 return Type_High_Bound (Xtyp);
1029 ----------------------------
1030 -- Is_Known_Valid_Operand --
1031 ----------------------------
1033 function Is_Known_Valid_Operand (Opnd : Node_Id) return Boolean is
1035 return (Is_Entity_Name (Opnd)
1037 (Is_Known_Valid (Entity (Opnd))
1038 or else Ekind (Entity (Opnd)) = E_In_Parameter
1040 (Is_Object (Entity (Opnd))
1041 and then Present (Current_Value (Entity (Opnd))))))
1042 or else Is_OK_Static_Expression (Opnd);
1043 end Is_Known_Valid_Operand;
1049 function Is_Same_Value (L, R : Node_Id) return Boolean is
1050 Lf : constant Node_Id := Compare_Fixup (L);
1051 Rf : constant Node_Id := Compare_Fixup (R);
1053 function Is_Rewritten_Loop_Entry (N : Node_Id) return Boolean;
1054 -- An attribute reference to Loop_Entry may have been rewritten into
1055 -- its prefix as a way to avoid generating a constant for that
1056 -- attribute when the corresponding pragma is ignored. These nodes
1057 -- should be ignored when deciding if they can be equal to one
1060 function Is_Same_Subscript (L, R : List_Id) return Boolean;
1061 -- L, R are the Expressions values from two attribute nodes for First
1062 -- or Last attributes. Either may be set to No_List if no expressions
1063 -- are present (indicating subscript 1). The result is True if both
1064 -- expressions represent the same subscript (note one case is where
1065 -- one subscript is missing and the other is explicitly set to 1).
1067 -----------------------------
1068 -- Is_Rewritten_Loop_Entry --
1069 -----------------------------
1071 function Is_Rewritten_Loop_Entry (N : Node_Id) return Boolean is
1072 Orig_N : constant Node_Id := Original_Node (N);
1075 and then Nkind (Orig_N) = N_Attribute_Reference
1076 and then Get_Attribute_Id (Attribute_Name (Orig_N)) =
1077 Attribute_Loop_Entry;
1078 end Is_Rewritten_Loop_Entry;
1080 -----------------------
1081 -- Is_Same_Subscript --
1082 -----------------------
1084 function Is_Same_Subscript (L, R : List_Id) return Boolean is
1090 return Expr_Value (First (R)) = Uint_1;
1095 return Expr_Value (First (L)) = Uint_1;
1097 return Expr_Value (First (L)) = Expr_Value (First (R));
1100 end Is_Same_Subscript;
1102 -- Start of processing for Is_Same_Value
1105 -- Loop_Entry nodes rewritten into their prefix inside ignored
1106 -- pragmas should never lead to a decision of equality.
1108 if Is_Rewritten_Loop_Entry (Lf)
1109 or else Is_Rewritten_Loop_Entry (Rf)
1113 -- Values are the same if they refer to the same entity and the
1114 -- entity is nonvolatile.
1116 elsif Nkind (Lf) in N_Identifier | N_Expanded_Name
1117 and then Nkind (Rf) in N_Identifier | N_Expanded_Name
1118 and then Entity (Lf) = Entity (Rf)
1120 -- If the entity is a discriminant, the two expressions may be
1121 -- bounds of components of objects of the same discriminated type.
1122 -- The values of the discriminants are not static, and therefore
1123 -- the result is unknown.
1125 and then Ekind (Entity (Lf)) /= E_Discriminant
1126 and then Present (Entity (Lf))
1128 -- This does not however apply to Float types, since we may have
1129 -- two NaN values and they should never compare equal.
1131 and then not Is_Floating_Point_Type (Etype (L))
1132 and then not Is_Volatile_Reference (L)
1133 and then not Is_Volatile_Reference (R)
1137 -- Or if they are compile-time-known and identical
1139 elsif Compile_Time_Known_Value (Lf)
1141 Compile_Time_Known_Value (Rf)
1142 and then Expr_Value (Lf) = Expr_Value (Rf)
1146 -- False if Nkind of the two nodes is different for remaining cases
1148 elsif Nkind (Lf) /= Nkind (Rf) then
1151 -- True if both 'First or 'Last values applying to the same entity
1152 -- (first and last don't change even if value does). Note that we
1153 -- need this even with the calls to Compare_Fixup, to handle the
1154 -- case of unconstrained array attributes where Compare_Fixup
1155 -- cannot find useful bounds.
1157 elsif Nkind (Lf) = N_Attribute_Reference
1158 and then Attribute_Name (Lf) = Attribute_Name (Rf)
1159 and then Attribute_Name (Lf) in Name_First | Name_Last
1160 and then Nkind (Prefix (Lf)) in N_Identifier | N_Expanded_Name
1161 and then Nkind (Prefix (Rf)) in N_Identifier | N_Expanded_Name
1162 and then Entity (Prefix (Lf)) = Entity (Prefix (Rf))
1163 and then Is_Same_Subscript (Expressions (Lf), Expressions (Rf))
1167 -- True if the same selected component from the same record
1169 elsif Nkind (Lf) = N_Selected_Component
1170 and then Selector_Name (Lf) = Selector_Name (Rf)
1171 and then Is_Same_Value (Prefix (Lf), Prefix (Rf))
1175 -- True if the same unary operator applied to the same operand
1177 elsif Nkind (Lf) in N_Unary_Op
1178 and then Is_Same_Value (Right_Opnd (Lf), Right_Opnd (Rf))
1182 -- True if the same binary operator applied to the same operands
1184 elsif Nkind (Lf) in N_Binary_Op
1185 and then Is_Same_Value (Left_Opnd (Lf), Left_Opnd (Rf))
1186 and then Is_Same_Value (Right_Opnd (Lf), Right_Opnd (Rf))
1190 -- All other cases, we can't tell, so return False
1197 -- Start of processing for Compile_Time_Compare
1200 Diff.all := No_Uint;
1202 -- In preanalysis mode, always return Unknown unless the expression
1203 -- is static. It is too early to be thinking we know the result of a
1204 -- comparison, save that judgment for the full analysis. This is
1205 -- particularly important in the case of pre and postconditions, which
1206 -- otherwise can be prematurely collapsed into having True or False
1207 -- conditions when this is inappropriate.
1209 if not (Full_Analysis
1210 or else (Is_OK_Static_Expression (L)
1212 Is_OK_Static_Expression (R)))
1217 -- If either operand could raise Constraint_Error, then we cannot
1218 -- know the result at compile time (since CE may be raised).
1220 if not (Cannot_Raise_Constraint_Error (L)
1222 Cannot_Raise_Constraint_Error (R))
1227 -- Identical operands are most certainly equal
1233 -- If expressions have no types, then do not attempt to determine if
1234 -- they are the same, since something funny is going on. One case in
1235 -- which this happens is during generic template analysis, when bounds
1236 -- are not fully analyzed.
1238 if No (Ltyp) or else No (Rtyp) then
1242 -- These get reset to the base type for the case of entities where
1243 -- Is_Known_Valid is not set. This takes care of handling possible
1244 -- invalid representations using the value of the base type, in
1245 -- accordance with RM 13.9.1(10).
1247 Ltyp := Underlying_Type (Ltyp);
1248 Rtyp := Underlying_Type (Rtyp);
1250 -- Same rationale as above, but for Underlying_Type instead of Etype
1252 if No (Ltyp) or else No (Rtyp) then
1256 -- We do not attempt comparisons for packed arrays represented as
1257 -- modular types, where the semantics of comparison is quite different.
1259 if Is_Packed_Array_Impl_Type (Ltyp)
1260 and then Is_Modular_Integer_Type (Ltyp)
1264 -- For access types, the only time we know the result at compile time
1265 -- (apart from identical operands, which we handled already) is if we
1266 -- know one operand is null and the other is not, or both operands are
1269 elsif Is_Access_Type (Ltyp) then
1270 if Known_Null (L) then
1271 if Known_Null (R) then
1273 elsif Known_Non_Null (R) then
1279 elsif Known_Non_Null (L) and then Known_Null (R) then
1286 -- Case where comparison involves two compile-time-known values
1288 elsif Compile_Time_Known_Value (L)
1290 Compile_Time_Known_Value (R)
1292 -- For the floating-point case, we have to be a little careful, since
1293 -- at compile time we are dealing with universal exact values, but at
1294 -- runtime, these will be in non-exact target form. That's why the
1295 -- returned results are LE and GE below instead of LT and GT.
1297 if Is_Floating_Point_Type (Ltyp)
1299 Is_Floating_Point_Type (Rtyp)
1302 Lo : constant Ureal := Expr_Value_R (L);
1303 Hi : constant Ureal := Expr_Value_R (R);
1314 -- For string types, we have two string literals and we proceed to
1315 -- compare them using the Ada style dictionary string comparison.
1317 elsif not Is_Scalar_Type (Ltyp) then
1319 Lstring : constant String_Id := Strval (Expr_Value_S (L));
1320 Rstring : constant String_Id := Strval (Expr_Value_S (R));
1321 Llen : constant Nat := String_Length (Lstring);
1322 Rlen : constant Nat := String_Length (Rstring);
1325 for J in 1 .. Nat'Min (Llen, Rlen) loop
1327 LC : constant Char_Code := Get_String_Char (Lstring, J);
1328 RC : constant Char_Code := Get_String_Char (Rstring, J);
1340 elsif Llen > Rlen then
1347 -- For remaining scalar cases we know exactly (note that this does
1348 -- include the fixed-point case, where we know the run time integer
1353 Lo : constant Uint := Expr_Value (L);
1354 Hi : constant Uint := Expr_Value (R);
1357 Diff.all := Hi - Lo;
1362 Diff.all := Lo - Hi;
1368 -- Cases where at least one operand is not known at compile time
1371 -- Remaining checks apply only for discrete types
1373 if not Is_Discrete_Type (Ltyp)
1375 not Is_Discrete_Type (Rtyp)
1380 -- Defend against generic types, or actually any expressions that
1381 -- contain a reference to a generic type from within a generic
1382 -- template. We don't want to do any range analysis of such
1383 -- expressions for two reasons. First, the bounds of a generic type
1384 -- itself are junk and cannot be used for any kind of analysis.
1385 -- Second, we may have a case where the range at run time is indeed
1386 -- known, but we don't want to do compile time analysis in the
1387 -- template based on that range since in an instance the value may be
1388 -- static, and able to be elaborated without reference to the bounds
1389 -- of types involved. As an example, consider:
1391 -- (F'Pos (F'Last) + 1) > Integer'Last
1393 -- The expression on the left side of > is Universal_Integer and thus
1394 -- acquires the type Integer for evaluation at run time, and at run
1395 -- time it is true that this condition is always False, but within
1396 -- an instance F may be a type with a static range greater than the
1397 -- range of Integer, and the expression statically evaluates to True.
1399 if References_Generic_Formal_Type (L)
1401 References_Generic_Formal_Type (R)
1406 -- Replace types by base types for the case of values which are not
1407 -- known to have valid representations. This takes care of properly
1408 -- dealing with invalid representations.
1410 if not Assume_Valid then
1411 if not (Is_Entity_Name (L)
1412 and then (Is_Known_Valid (Entity (L))
1413 or else Assume_No_Invalid_Values))
1415 Ltyp := Underlying_Type (Base_Type (Ltyp));
1418 if not (Is_Entity_Name (R)
1419 and then (Is_Known_Valid (Entity (R))
1420 or else Assume_No_Invalid_Values))
1422 Rtyp := Underlying_Type (Base_Type (Rtyp));
1426 -- First attempt is to decompose the expressions to extract a
1427 -- constant offset resulting from the use of any of the forms:
1434 -- Then we see if the two expressions are the same value, and if so
1435 -- the result is obtained by comparing the offsets.
1437 -- Note: the reason we do this test first is that it returns only
1438 -- decisive results (with diff set), where other tests, like the
1439 -- range test, may not be as so decisive. Consider for example
1440 -- J .. J + 1. This code can conclude LT with a difference of 1,
1441 -- even if the range of J is not known.
1450 Compare_Decompose (L, Lnode, Loffs);
1451 Compare_Decompose (R, Rnode, Roffs);
1453 if Is_Same_Value (Lnode, Rnode) then
1454 if Loffs = Roffs then
1458 -- When the offsets are not equal, we can go farther only if
1459 -- the types are not modular (e.g. X < X + 1 is False if X is
1460 -- the largest number).
1462 if not Is_Modular_Integer_Type (Ltyp)
1463 and then not Is_Modular_Integer_Type (Rtyp)
1465 if Loffs < Roffs then
1466 Diff.all := Roffs - Loffs;
1469 Diff.all := Loffs - Roffs;
1476 -- Next, try range analysis and see if operand ranges are disjoint
1484 -- True if each range is a single point
1487 Determine_Range (L, LOK, LLo, LHi, Assume_Valid);
1488 Determine_Range (R, ROK, RLo, RHi, Assume_Valid);
1491 Single := (LLo = LHi) and then (RLo = RHi);
1494 if Single and Assume_Valid then
1495 Diff.all := RLo - LLo;
1500 elsif RHi < LLo then
1501 if Single and Assume_Valid then
1502 Diff.all := LLo - RLo;
1507 elsif Single and then LLo = RLo then
1509 -- If the range includes a single literal and we can assume
1510 -- validity then the result is known even if an operand is
1513 if Assume_Valid then
1519 elsif LHi = RLo then
1522 elsif RHi = LLo then
1525 elsif not Is_Known_Valid_Operand (L)
1526 and then not Assume_Valid
1528 if Is_Same_Value (L, R) then
1535 -- If the range of either operand cannot be determined, nothing
1536 -- further can be inferred.
1543 -- Here is where we check for comparisons against maximum bounds of
1544 -- types, where we know that no value can be outside the bounds of
1545 -- the subtype. Note that this routine is allowed to assume that all
1546 -- expressions are within their subtype bounds. Callers wishing to
1547 -- deal with possibly invalid values must in any case take special
1548 -- steps (e.g. conversions to larger types) to avoid this kind of
1549 -- optimization, which is always considered to be valid. We do not
1550 -- attempt this optimization with generic types, since the type
1551 -- bounds may not be meaningful in this case.
1553 -- We are in danger of an infinite recursion here. It does not seem
1554 -- useful to go more than one level deep, so the parameter Rec is
1555 -- used to protect ourselves against this infinite recursion.
1559 -- See if we can get a decisive check against one operand and a
1560 -- bound of the other operand (four possible tests here). Note
1561 -- that we avoid testing junk bounds of a generic type.
1563 if not Is_Generic_Type (Rtyp) then
1564 case Compile_Time_Compare (L, Type_Low_Bound (Rtyp),
1566 Assume_Valid, Rec => True)
1568 when LT => return LT;
1569 when LE => return LE;
1570 when EQ => return LE;
1571 when others => null;
1574 case Compile_Time_Compare (L, Type_High_Bound (Rtyp),
1576 Assume_Valid, Rec => True)
1578 when GT => return GT;
1579 when GE => return GE;
1580 when EQ => return GE;
1581 when others => null;
1585 if not Is_Generic_Type (Ltyp) then
1586 case Compile_Time_Compare (Type_Low_Bound (Ltyp), R,
1588 Assume_Valid, Rec => True)
1590 when GT => return GT;
1591 when GE => return GE;
1592 when EQ => return GE;
1593 when others => null;
1596 case Compile_Time_Compare (Type_High_Bound (Ltyp), R,
1598 Assume_Valid, Rec => True)
1600 when LT => return LT;
1601 when LE => return LE;
1602 when EQ => return LE;
1603 when others => null;
1608 -- Next attempt is to see if we have an entity compared with a
1609 -- compile-time-known value, where there is a current value
1610 -- conditional for the entity which can tell us the result.
1614 -- Entity variable (left operand)
1617 -- Value (right operand)
1620 -- If False, we have reversed the operands
1623 -- Comparison operator kind from Get_Current_Value_Condition call
1626 -- Value from Get_Current_Value_Condition call
1631 Result : Compare_Result;
1632 -- Known result before inversion
1635 if Is_Entity_Name (L)
1636 and then Compile_Time_Known_Value (R)
1639 Val := Expr_Value (R);
1642 elsif Is_Entity_Name (R)
1643 and then Compile_Time_Known_Value (L)
1646 Val := Expr_Value (L);
1649 -- That was the last chance at finding a compile time result
1655 Get_Current_Value_Condition (Var, Op, Opn);
1657 -- That was the last chance, so if we got nothing return
1663 Opv := Expr_Value (Opn);
1665 -- We got a comparison, so we might have something interesting
1667 -- Convert LE to LT and GE to GT, just so we have fewer cases
1669 if Op = N_Op_Le then
1673 elsif Op = N_Op_Ge then
1678 -- Deal with equality case
1680 if Op = N_Op_Eq then
1683 elsif Opv < Val then
1689 -- Deal with inequality case
1691 elsif Op = N_Op_Ne then
1698 -- Deal with greater than case
1700 elsif Op = N_Op_Gt then
1703 elsif Opv = Val - 1 then
1709 -- Deal with less than case
1711 else pragma Assert (Op = N_Op_Lt);
1714 elsif Opv = Val + 1 then
1721 -- Deal with inverting result
1725 when GT => return LT;
1726 when GE => return LE;
1727 when LT => return GT;
1728 when LE => return GE;
1729 when others => return Result;
1736 end Compile_Time_Compare;
1738 -------------------------------
1739 -- Compile_Time_Known_Bounds --
1740 -------------------------------
1742 function Compile_Time_Known_Bounds (T : Entity_Id) return Boolean is
1747 if T = Any_Composite or else not Is_Array_Type (T) then
1751 Indx := First_Index (T);
1752 while Present (Indx) loop
1753 Typ := Underlying_Type (Etype (Indx));
1755 -- Never look at junk bounds of a generic type
1757 if Is_Generic_Type (Typ) then
1761 -- Otherwise check bounds for compile-time-known
1763 if not Compile_Time_Known_Value (Type_Low_Bound (Typ)) then
1765 elsif not Compile_Time_Known_Value (Type_High_Bound (Typ)) then
1773 end Compile_Time_Known_Bounds;
1775 ------------------------------
1776 -- Compile_Time_Known_Value --
1777 ------------------------------
1779 function Compile_Time_Known_Value (Op : Node_Id) return Boolean is
1780 K : constant Node_Kind := Nkind (Op);
1781 CV_Ent : CV_Entry renames CV_Cache (Nat (Op) mod CV_Cache_Size);
1784 -- Never known at compile time if bad type or raises Constraint_Error
1785 -- or empty (latter case occurs only as a result of a previous error).
1788 Check_Error_Detected;
1792 or else Etype (Op) = Any_Type
1793 or else Raises_Constraint_Error (Op)
1798 -- If we have an entity name, then see if it is the name of a constant
1799 -- and if so, test the corresponding constant value, or the name of an
1800 -- enumeration literal, which is always a constant.
1802 if Present (Etype (Op)) and then Is_Entity_Name (Op) then
1804 Ent : constant Entity_Id := Entity (Op);
1808 -- Never known at compile time if it is a packed array value. We
1809 -- might want to try to evaluate these at compile time one day,
1810 -- but we do not make that attempt now.
1812 if Is_Packed_Array_Impl_Type (Etype (Op)) then
1815 elsif Ekind (Ent) = E_Enumeration_Literal then
1818 elsif Ekind (Ent) = E_Constant then
1819 Val := Constant_Value (Ent);
1821 if Present (Val) then
1823 -- Guard against an illegal deferred constant whose full
1824 -- view is initialized with a reference to itself. Treat
1825 -- this case as a value not known at compile time.
1827 if Is_Entity_Name (Val) and then Entity (Val) = Ent then
1830 return Compile_Time_Known_Value (Val);
1833 -- Otherwise, the constant does not have a compile-time-known
1842 -- We have a value, see if it is compile-time-known
1845 -- Integer literals are worth storing in the cache
1847 if K = N_Integer_Literal then
1849 CV_Ent.V := Intval (Op);
1852 -- Other literals and NULL are known at compile time
1855 N_Character_Literal | N_Real_Literal | N_String_Literal | N_Null
1861 -- If we fall through, not known at compile time
1865 -- If we get an exception while trying to do this test, then some error
1866 -- has occurred, and we simply say that the value is not known after all
1870 -- With debug flag K we will get an exception unless an error has
1871 -- already occurred (useful for debugging).
1873 if Debug_Flag_K then
1874 Check_Error_Detected;
1878 end Compile_Time_Known_Value;
1880 --------------------------------------
1881 -- Compile_Time_Known_Value_Or_Aggr --
1882 --------------------------------------
1884 function Compile_Time_Known_Value_Or_Aggr (Op : Node_Id) return Boolean is
1886 -- If we have an entity name, then see if it is the name of a constant
1887 -- and if so, test the corresponding constant value, or the name of
1888 -- an enumeration literal, which is always a constant.
1890 if Is_Entity_Name (Op) then
1892 E : constant Entity_Id := Entity (Op);
1896 if Ekind (E) = E_Enumeration_Literal then
1899 elsif Ekind (E) /= E_Constant then
1903 V := Constant_Value (E);
1905 and then Compile_Time_Known_Value_Or_Aggr (V);
1909 -- We have a value, see if it is compile-time-known
1912 if Compile_Time_Known_Value (Op) then
1915 elsif Nkind (Op) = N_Aggregate then
1917 if Present (Expressions (Op)) then
1921 Expr := First (Expressions (Op));
1922 while Present (Expr) loop
1923 if not Compile_Time_Known_Value_Or_Aggr (Expr) then
1932 if Present (Component_Associations (Op)) then
1937 Cass := First (Component_Associations (Op));
1938 while Present (Cass) loop
1940 Compile_Time_Known_Value_Or_Aggr (Expression (Cass))
1952 elsif Nkind (Op) = N_Qualified_Expression then
1953 return Compile_Time_Known_Value_Or_Aggr (Expression (Op));
1955 -- All other types of values are not known at compile time
1962 end Compile_Time_Known_Value_Or_Aggr;
1964 ---------------------------------------
1965 -- CRT_Safe_Compile_Time_Known_Value --
1966 ---------------------------------------
1968 function CRT_Safe_Compile_Time_Known_Value (Op : Node_Id) return Boolean is
1970 if (Configurable_Run_Time_Mode or No_Run_Time_Mode)
1971 and then not Is_OK_Static_Expression (Op)
1975 return Compile_Time_Known_Value (Op);
1977 end CRT_Safe_Compile_Time_Known_Value;
1983 -- This is only called for actuals of functions that are not predefined
1984 -- operators (which have already been rewritten as operators at this
1985 -- stage), so the call can never be folded, and all that needs doing for
1986 -- the actual is to do the check for a non-static context.
1988 procedure Eval_Actual (N : Node_Id) is
1990 Check_Non_Static_Context (N);
1993 --------------------
1994 -- Eval_Allocator --
1995 --------------------
1997 -- Allocators are never static, so all we have to do is to do the
1998 -- check for a non-static context if an expression is present.
2000 procedure Eval_Allocator (N : Node_Id) is
2001 Expr : constant Node_Id := Expression (N);
2003 if Nkind (Expr) = N_Qualified_Expression then
2004 Check_Non_Static_Context (Expression (Expr));
2008 ------------------------
2009 -- Eval_Arithmetic_Op --
2010 ------------------------
2012 -- Arithmetic operations are static functions, so the result is static
2013 -- if both operands are static (RM 4.9(7), 4.9(20)).
2015 procedure Eval_Arithmetic_Op (N : Node_Id) is
2016 Left : constant Node_Id := Left_Opnd (N);
2017 Right : constant Node_Id := Right_Opnd (N);
2018 Ltype : constant Entity_Id := Etype (Left);
2019 Rtype : constant Entity_Id := Etype (Right);
2020 Otype : Entity_Id := Empty;
2025 -- If not foldable we are done
2027 Test_Expression_Is_Foldable (N, Left, Right, Stat, Fold);
2033 -- Otherwise attempt to fold
2035 if Is_Universal_Numeric_Type (Etype (Left))
2037 Is_Universal_Numeric_Type (Etype (Right))
2039 Otype := Find_Universal_Operator_Type (N);
2042 -- Fold for cases where both operands are of integer type
2044 if Is_Integer_Type (Ltype) and then Is_Integer_Type (Rtype) then
2046 Left_Int : constant Uint := Expr_Value (Left);
2047 Right_Int : constant Uint := Expr_Value (Right);
2053 Result := Left_Int + Right_Int;
2055 when N_Op_Subtract =>
2056 Result := Left_Int - Right_Int;
2058 when N_Op_Multiply =>
2061 (Num_Bits (Left_Int) + Num_Bits (Right_Int)))
2063 Result := Left_Int * Right_Int;
2070 -- The exception Constraint_Error is raised by integer
2071 -- division, rem and mod if the right operand is zero.
2073 if Right_Int = 0 then
2075 -- When SPARK_Mode is On, force a warning instead of
2076 -- an error in that case, as this likely corresponds
2077 -- to deactivated code.
2079 Apply_Compile_Time_Constraint_Error
2080 (N, "division by zero", CE_Divide_By_Zero,
2081 Warn => not Stat or SPARK_Mode = On);
2082 Set_Raises_Constraint_Error (N);
2085 -- Otherwise we can do the division
2088 Result := Left_Int / Right_Int;
2093 -- The exception Constraint_Error is raised by integer
2094 -- division, rem and mod if the right operand is zero.
2096 if Right_Int = 0 then
2098 -- When SPARK_Mode is On, force a warning instead of
2099 -- an error in that case, as this likely corresponds
2100 -- to deactivated code.
2102 Apply_Compile_Time_Constraint_Error
2103 (N, "mod with zero divisor", CE_Divide_By_Zero,
2104 Warn => not Stat or SPARK_Mode = On);
2108 Result := Left_Int mod Right_Int;
2113 -- The exception Constraint_Error is raised by integer
2114 -- division, rem and mod if the right operand is zero.
2116 if Right_Int = 0 then
2118 -- When SPARK_Mode is On, force a warning instead of
2119 -- an error in that case, as this likely corresponds
2120 -- to deactivated code.
2122 Apply_Compile_Time_Constraint_Error
2123 (N, "rem with zero divisor", CE_Divide_By_Zero,
2124 Warn => not Stat or SPARK_Mode = On);
2128 Result := Left_Int rem Right_Int;
2132 raise Program_Error;
2135 -- Adjust the result by the modulus if the type is a modular type
2137 if Is_Modular_Integer_Type (Ltype) then
2138 Result := Result mod Modulus (Ltype);
2140 -- For a signed integer type, check non-static overflow
2142 elsif (not Stat) and then Is_Signed_Integer_Type (Ltype) then
2144 BT : constant Entity_Id := Base_Type (Ltype);
2145 Lo : constant Uint := Expr_Value (Type_Low_Bound (BT));
2146 Hi : constant Uint := Expr_Value (Type_High_Bound (BT));
2148 if Result < Lo or else Result > Hi then
2149 Apply_Compile_Time_Constraint_Error
2150 (N, "value not in range of }??",
2151 CE_Overflow_Check_Failed,
2158 -- If we get here we can fold the result
2160 Fold_Uint (N, Result, Stat);
2163 -- Cases where at least one operand is a real. We handle the cases of
2164 -- both reals, or mixed/real integer cases (the latter happen only for
2165 -- divide and multiply, and the result is always real).
2167 elsif Is_Real_Type (Ltype) or else Is_Real_Type (Rtype) then
2174 if Is_Real_Type (Ltype) then
2175 Left_Real := Expr_Value_R (Left);
2177 Left_Real := UR_From_Uint (Expr_Value (Left));
2180 if Is_Real_Type (Rtype) then
2181 Right_Real := Expr_Value_R (Right);
2183 Right_Real := UR_From_Uint (Expr_Value (Right));
2186 if Nkind (N) = N_Op_Add then
2187 Result := Left_Real + Right_Real;
2189 elsif Nkind (N) = N_Op_Subtract then
2190 Result := Left_Real - Right_Real;
2192 elsif Nkind (N) = N_Op_Multiply then
2193 Result := Left_Real * Right_Real;
2195 else pragma Assert (Nkind (N) = N_Op_Divide);
2196 if UR_Is_Zero (Right_Real) then
2197 Apply_Compile_Time_Constraint_Error
2198 (N, "division by zero", CE_Divide_By_Zero);
2202 Result := Left_Real / Right_Real;
2205 Fold_Ureal (N, Result, Stat);
2209 -- If the operator was resolved to a specific type, make sure that type
2210 -- is frozen even if the expression is folded into a literal (which has
2211 -- a universal type).
2213 if Present (Otype) then
2214 Freeze_Before (N, Otype);
2216 end Eval_Arithmetic_Op;
2218 ----------------------------
2219 -- Eval_Character_Literal --
2220 ----------------------------
2222 -- Nothing to be done
2224 procedure Eval_Character_Literal (N : Node_Id) is
2225 pragma Warnings (Off, N);
2228 end Eval_Character_Literal;
2234 -- Static function calls are either calls to predefined operators
2235 -- with static arguments, or calls to functions that rename a literal.
2236 -- Only the latter case is handled here, predefined operators are
2237 -- constant-folded elsewhere.
2239 -- If the function is itself inherited the literal of the parent type must
2240 -- be explicitly converted to the return type of the function.
2242 procedure Eval_Call (N : Node_Id) is
2243 Loc : constant Source_Ptr := Sloc (N);
2244 Typ : constant Entity_Id := Etype (N);
2248 if Nkind (N) = N_Function_Call
2249 and then No (Parameter_Associations (N))
2250 and then Is_Entity_Name (Name (N))
2251 and then Present (Alias (Entity (Name (N))))
2252 and then Is_Enumeration_Type (Base_Type (Typ))
2254 Lit := Ultimate_Alias (Entity (Name (N)));
2256 if Ekind (Lit) = E_Enumeration_Literal then
2257 if Base_Type (Etype (Lit)) /= Base_Type (Typ) then
2259 (N, Convert_To (Typ, New_Occurrence_Of (Lit, Loc)));
2261 Rewrite (N, New_Occurrence_Of (Lit, Loc));
2267 elsif Nkind (N) = N_Function_Call
2268 and then Is_Entity_Name (Name (N))
2269 and then Is_Intrinsic_Subprogram (Entity (Name (N)))
2271 Eval_Intrinsic_Call (N, Entity (Name (N)));
2273 -- Ada 202x (AI12-0075): If checking for potentially static expressions
2274 -- is enabled and we have a call to a static function, substitute a
2275 -- static value for the call, to allow folding the expression. This
2276 -- supports checking the requirement of RM 6.8(5.3/5) in
2277 -- Analyze_Expression_Function.
2279 elsif Checking_Potentially_Static_Expression
2280 and then Is_Static_Function_Call (N)
2282 Fold_Dummy (N, Typ);
2286 --------------------------
2287 -- Eval_Case_Expression --
2288 --------------------------
2290 -- A conditional expression is static if all its conditions and dependent
2291 -- expressions are static. Note that we do not care if the dependent
2292 -- expressions raise CE, except for the one that will be selected.
2294 procedure Eval_Case_Expression (N : Node_Id) is
2299 Set_Is_Static_Expression (N, False);
2301 if Error_Posted (Expression (N))
2302 or else not Is_Static_Expression (Expression (N))
2304 Check_Non_Static_Context (Expression (N));
2308 -- First loop, make sure all the alternatives are static expressions
2309 -- none of which raise Constraint_Error. We make the Constraint_Error
2310 -- check because part of the legality condition for a correct static
2311 -- case expression is that the cases are covered, like any other case
2312 -- expression. And we can't do that if any of the conditions raise an
2313 -- exception, so we don't even try to evaluate if that is the case.
2315 Alt := First (Alternatives (N));
2316 while Present (Alt) loop
2318 -- The expression must be static, but we don't care at this stage
2319 -- if it raises Constraint_Error (the alternative might not match,
2320 -- in which case the expression is statically unevaluated anyway).
2322 if not Is_Static_Expression (Expression (Alt)) then
2323 Check_Non_Static_Context (Expression (Alt));
2327 -- The choices of a case always have to be static, and cannot raise
2328 -- an exception. If this condition is not met, then the expression
2329 -- is plain illegal, so just abandon evaluation attempts. No need
2330 -- to check non-static context when we have something illegal anyway.
2332 if not Is_OK_Static_Choice_List (Discrete_Choices (Alt)) then
2339 -- OK, if the above loop gets through it means that all choices are OK
2340 -- static (don't raise exceptions), so the whole case is static, and we
2341 -- can find the matching alternative.
2343 Set_Is_Static_Expression (N);
2345 -- Now to deal with propagating a possible Constraint_Error
2347 -- If the selecting expression raises CE, propagate and we are done
2349 if Raises_Constraint_Error (Expression (N)) then
2350 Set_Raises_Constraint_Error (N);
2352 -- Otherwise we need to check the alternatives to find the matching
2353 -- one. CE's in other than the matching one are not relevant. But we
2354 -- do need to check the matching one. Unlike the first loop, we do not
2355 -- have to go all the way through, when we find the matching one, quit.
2358 Alt := First (Alternatives (N));
2361 -- We must find a match among the alternatives. If not, this must
2362 -- be due to other errors, so just ignore, leaving as non-static.
2365 Set_Is_Static_Expression (N, False);
2369 -- Otherwise loop through choices of this alternative
2371 Choice := First (Discrete_Choices (Alt));
2372 while Present (Choice) loop
2374 -- If we find a matching choice, then the Expression of this
2375 -- alternative replaces N (Raises_Constraint_Error flag is
2376 -- included, so we don't have to special case that).
2378 if Choice_Matches (Expression (N), Choice) = Match then
2379 Rewrite (N, Relocate_Node (Expression (Alt)));
2389 end Eval_Case_Expression;
2391 ------------------------
2392 -- Eval_Concatenation --
2393 ------------------------
2395 -- Concatenation is a static function, so the result is static if both
2396 -- operands are static (RM 4.9(7), 4.9(21)).
2398 procedure Eval_Concatenation (N : Node_Id) is
2399 Left : constant Node_Id := Left_Opnd (N);
2400 Right : constant Node_Id := Right_Opnd (N);
2401 C_Typ : constant Entity_Id := Root_Type (Component_Type (Etype (N)));
2406 -- Concatenation is never static in Ada 83, so if Ada 83 check operand
2407 -- non-static context.
2409 if Ada_Version = Ada_83
2410 and then Comes_From_Source (N)
2412 Check_Non_Static_Context (Left);
2413 Check_Non_Static_Context (Right);
2417 -- If not foldable we are done. In principle concatenation that yields
2418 -- any string type is static (i.e. an array type of character types).
2419 -- However, character types can include enumeration literals, and
2420 -- concatenation in that case cannot be described by a literal, so we
2421 -- only consider the operation static if the result is an array of
2422 -- (a descendant of) a predefined character type.
2424 Test_Expression_Is_Foldable (N, Left, Right, Stat, Fold);
2426 if not (Is_Standard_Character_Type (C_Typ) and then Fold) then
2427 Set_Is_Static_Expression (N, False);
2431 -- Compile time string concatenation
2433 -- ??? Note that operands that are aggregates can be marked as static,
2434 -- so we should attempt at a later stage to fold concatenations with
2438 Left_Str : constant Node_Id := Get_String_Val (Left);
2440 Right_Str : constant Node_Id := Get_String_Val (Right);
2441 Folded_Val : String_Id := No_String;
2444 -- Establish new string literal, and store left operand. We make
2445 -- sure to use the special Start_String that takes an operand if
2446 -- the left operand is a string literal. Since this is optimized
2447 -- in the case where that is the most recently created string
2448 -- literal, we ensure efficient time/space behavior for the
2449 -- case of a concatenation of a series of string literals.
2451 if Nkind (Left_Str) = N_String_Literal then
2452 Left_Len := String_Length (Strval (Left_Str));
2454 -- If the left operand is the empty string, and the right operand
2455 -- is a string literal (the case of "" & "..."), the result is the
2456 -- value of the right operand. This optimization is important when
2457 -- Is_Folded_In_Parser, to avoid copying an enormous right
2460 if Left_Len = 0 and then Nkind (Right_Str) = N_String_Literal then
2461 Folded_Val := Strval (Right_Str);
2463 Start_String (Strval (Left_Str));
2468 Store_String_Char (UI_To_CC (Char_Literal_Value (Left_Str)));
2472 -- Now append the characters of the right operand, unless we
2473 -- optimized the "" & "..." case above.
2475 if Nkind (Right_Str) = N_String_Literal then
2476 if Left_Len /= 0 then
2477 Store_String_Chars (Strval (Right_Str));
2478 Folded_Val := End_String;
2481 Store_String_Char (UI_To_CC (Char_Literal_Value (Right_Str)));
2482 Folded_Val := End_String;
2485 Set_Is_Static_Expression (N, Stat);
2487 -- If left operand is the empty string, the result is the
2488 -- right operand, including its bounds if anomalous.
2491 and then Is_Array_Type (Etype (Right))
2492 and then Etype (Right) /= Any_String
2494 Set_Etype (N, Etype (Right));
2497 Fold_Str (N, Folded_Val, Static => Stat);
2499 end Eval_Concatenation;
2501 ----------------------
2502 -- Eval_Entity_Name --
2503 ----------------------
2505 -- This procedure is used for identifiers and expanded names other than
2506 -- named numbers (see Eval_Named_Integer, Eval_Named_Real. These are
2507 -- static if they denote a static constant (RM 4.9(6)) or if the name
2508 -- denotes an enumeration literal (RM 4.9(22)).
2510 procedure Eval_Entity_Name (N : Node_Id) is
2511 Def_Id : constant Entity_Id := Entity (N);
2515 -- Enumeration literals are always considered to be constants
2516 -- and cannot raise Constraint_Error (RM 4.9(22)).
2518 if Ekind (Def_Id) = E_Enumeration_Literal then
2519 Set_Is_Static_Expression (N);
2522 -- A name is static if it denotes a static constant (RM 4.9(5)), and
2523 -- we also copy Raise_Constraint_Error. Notice that even if non-static,
2524 -- it does not violate 10.2.1(8) here, since this is not a variable.
2526 elsif Ekind (Def_Id) = E_Constant then
2528 -- Deferred constants must always be treated as nonstatic outside the
2529 -- scope of their full view.
2531 if Present (Full_View (Def_Id))
2532 and then not In_Open_Scopes (Scope (Def_Id))
2536 Val := Constant_Value (Def_Id);
2539 if Present (Val) then
2540 Set_Is_Static_Expression
2541 (N, Is_Static_Expression (Val)
2542 and then Is_Static_Subtype (Etype (Def_Id)));
2543 Set_Raises_Constraint_Error (N, Raises_Constraint_Error (Val));
2545 if not Is_Static_Expression (N)
2546 and then not Is_Generic_Type (Etype (N))
2548 Validate_Static_Object_Name (N);
2551 -- Mark constant condition in SCOs
2554 and then Comes_From_Source (N)
2555 and then Is_Boolean_Type (Etype (Def_Id))
2556 and then Compile_Time_Known_Value (N)
2558 Set_SCO_Condition (N, Expr_Value_E (N) = Standard_True);
2564 -- Ada 202x (AI12-0075): If checking for potentially static expressions
2565 -- is enabled and we have a reference to a formal parameter of mode in,
2566 -- substitute a static value for the reference, to allow folding the
2567 -- expression. This supports checking the requirement of RM 6.8(5.3/5)
2568 -- in Analyze_Expression_Function.
2570 elsif Ekind (Def_Id) = E_In_Parameter
2571 and then Checking_Potentially_Static_Expression
2572 and then Is_Static_Function (Scope (Def_Id))
2574 Fold_Dummy (N, Etype (Def_Id));
2577 -- Fall through if the name is not static
2579 Validate_Static_Object_Name (N);
2580 end Eval_Entity_Name;
2582 ------------------------
2583 -- Eval_If_Expression --
2584 ------------------------
2586 -- We can fold to a static expression if the condition and both dependent
2587 -- expressions are static. Otherwise, the only required processing is to do
2588 -- the check for non-static context for the then and else expressions.
2590 procedure Eval_If_Expression (N : Node_Id) is
2591 Condition : constant Node_Id := First (Expressions (N));
2592 Then_Expr : constant Node_Id := Next (Condition);
2593 Else_Expr : constant Node_Id := Next (Then_Expr);
2595 Non_Result : Node_Id;
2597 Rstat : constant Boolean :=
2598 Is_Static_Expression (Condition)
2600 Is_Static_Expression (Then_Expr)
2602 Is_Static_Expression (Else_Expr);
2603 -- True if result is static
2606 -- If result not static, nothing to do, otherwise set static result
2611 Set_Is_Static_Expression (N);
2614 -- If any operand is Any_Type, just propagate to result and do not try
2615 -- to fold, this prevents cascaded errors.
2617 if Etype (Condition) = Any_Type or else
2618 Etype (Then_Expr) = Any_Type or else
2619 Etype (Else_Expr) = Any_Type
2621 Set_Etype (N, Any_Type);
2622 Set_Is_Static_Expression (N, False);
2626 -- If condition raises Constraint_Error then we have already signaled
2627 -- an error, and we just propagate to the result and do not fold.
2629 if Raises_Constraint_Error (Condition) then
2630 Set_Raises_Constraint_Error (N);
2634 -- Static case where we can fold. Note that we don't try to fold cases
2635 -- where the condition is known at compile time, but the result is
2636 -- non-static. This avoids possible cases of infinite recursion where
2637 -- the expander puts in a redundant test and we remove it. Instead we
2638 -- deal with these cases in the expander.
2640 -- Select result operand
2642 if Is_True (Expr_Value (Condition)) then
2643 Result := Then_Expr;
2644 Non_Result := Else_Expr;
2646 Result := Else_Expr;
2647 Non_Result := Then_Expr;
2650 -- Note that it does not matter if the non-result operand raises a
2651 -- Constraint_Error, but if the result raises Constraint_Error then we
2652 -- replace the node with a raise Constraint_Error. This will properly
2653 -- propagate Raises_Constraint_Error since this flag is set in Result.
2655 if Raises_Constraint_Error (Result) then
2656 Rewrite_In_Raise_CE (N, Result);
2657 Check_Non_Static_Context (Non_Result);
2659 -- Otherwise the result operand replaces the original node
2662 Rewrite (N, Relocate_Node (Result));
2663 Set_Is_Static_Expression (N);
2665 end Eval_If_Expression;
2667 ----------------------------
2668 -- Eval_Indexed_Component --
2669 ----------------------------
2671 -- Indexed components are never static, so we need to perform the check
2672 -- for non-static context on the index values. Then, we check if the
2673 -- value can be obtained at compile time, even though it is non-static.
2675 procedure Eval_Indexed_Component (N : Node_Id) is
2679 -- Check for non-static context on index values
2681 Expr := First (Expressions (N));
2682 while Present (Expr) loop
2683 Check_Non_Static_Context (Expr);
2687 -- If the indexed component appears in an object renaming declaration
2688 -- then we do not want to try to evaluate it, since in this case we
2689 -- need the identity of the array element.
2691 if Nkind (Parent (N)) = N_Object_Renaming_Declaration then
2694 -- Similarly if the indexed component appears as the prefix of an
2695 -- attribute we don't want to evaluate it, because at least for
2696 -- some cases of attributes we need the identify (e.g. Access, Size).
2698 elsif Nkind (Parent (N)) = N_Attribute_Reference then
2702 -- Note: there are other cases, such as the left side of an assignment,
2703 -- or an OUT parameter for a call, where the replacement results in the
2704 -- illegal use of a constant, But these cases are illegal in the first
2705 -- place, so the replacement, though silly, is harmless.
2707 -- Now see if this is a constant array reference
2709 if List_Length (Expressions (N)) = 1
2710 and then Is_Entity_Name (Prefix (N))
2711 and then Ekind (Entity (Prefix (N))) = E_Constant
2712 and then Present (Constant_Value (Entity (Prefix (N))))
2715 Loc : constant Source_Ptr := Sloc (N);
2716 Arr : constant Node_Id := Constant_Value (Entity (Prefix (N)));
2717 Sub : constant Node_Id := First (Expressions (N));
2723 -- Linear one's origin subscript value for array reference
2726 -- Lower bound of the first array index
2729 -- Value from constant array
2732 Atyp := Etype (Arr);
2734 if Is_Access_Type (Atyp) then
2735 Atyp := Designated_Type (Atyp);
2738 -- If we have an array type (we should have but perhaps there are
2739 -- error cases where this is not the case), then see if we can do
2740 -- a constant evaluation of the array reference.
2742 if Is_Array_Type (Atyp) and then Atyp /= Any_Composite then
2743 if Ekind (Atyp) = E_String_Literal_Subtype then
2744 Lbd := String_Literal_Low_Bound (Atyp);
2746 Lbd := Type_Low_Bound (Etype (First_Index (Atyp)));
2749 if Compile_Time_Known_Value (Sub)
2750 and then Nkind (Arr) = N_Aggregate
2751 and then Compile_Time_Known_Value (Lbd)
2752 and then Is_Discrete_Type (Component_Type (Atyp))
2754 Lin := UI_To_Int (Expr_Value (Sub) - Expr_Value (Lbd)) + 1;
2756 if List_Length (Expressions (Arr)) >= Lin then
2757 Elm := Pick (Expressions (Arr), Lin);
2759 -- If the resulting expression is compile-time-known,
2760 -- then we can rewrite the indexed component with this
2761 -- value, being sure to mark the result as non-static.
2762 -- We also reset the Sloc, in case this generates an
2763 -- error later on (e.g. 136'Access).
2765 if Compile_Time_Known_Value (Elm) then
2766 Rewrite (N, Duplicate_Subexpr_No_Checks (Elm));
2767 Set_Is_Static_Expression (N, False);
2772 -- We can also constant-fold if the prefix is a string literal.
2773 -- This will be useful in an instantiation or an inlining.
2775 elsif Compile_Time_Known_Value (Sub)
2776 and then Nkind (Arr) = N_String_Literal
2777 and then Compile_Time_Known_Value (Lbd)
2778 and then Expr_Value (Lbd) = 1
2779 and then Expr_Value (Sub) <=
2780 String_Literal_Length (Etype (Arr))
2783 C : constant Char_Code :=
2784 Get_String_Char (Strval (Arr),
2785 UI_To_Int (Expr_Value (Sub)));
2787 Set_Character_Literal_Name (C);
2790 Make_Character_Literal (Loc,
2792 Char_Literal_Value => UI_From_CC (C));
2793 Set_Etype (Elm, Component_Type (Atyp));
2794 Rewrite (N, Duplicate_Subexpr_No_Checks (Elm));
2795 Set_Is_Static_Expression (N, False);
2801 end Eval_Indexed_Component;
2803 --------------------------
2804 -- Eval_Integer_Literal --
2805 --------------------------
2807 -- Numeric literals are static (RM 4.9(1)), and have already been marked
2808 -- as static by the analyzer. The reason we did it that early is to allow
2809 -- the possibility of turning off the Is_Static_Expression flag after
2810 -- analysis, but before resolution, when integer literals are generated in
2811 -- the expander that do not correspond to static expressions.
2813 procedure Eval_Integer_Literal (N : Node_Id) is
2814 function In_Any_Integer_Context (Context : Node_Id) return Boolean;
2815 -- If the literal is resolved with a specific type in a context where
2816 -- the expected type is Any_Integer, there are no range checks on the
2817 -- literal. By the time the literal is evaluated, it carries the type
2818 -- imposed by the enclosing expression, and we must recover the context
2819 -- to determine that Any_Integer is meant.
2821 ----------------------------
2822 -- In_Any_Integer_Context --
2823 ----------------------------
2825 function In_Any_Integer_Context (Context : Node_Id) return Boolean is
2827 -- Any_Integer also appears in digits specifications for real types,
2828 -- but those have bounds smaller that those of any integer base type,
2829 -- so we can safely ignore these cases.
2832 Nkind (Context) in N_Attribute_Definition_Clause
2833 | N_Attribute_Reference
2834 | N_Modular_Type_Definition
2835 | N_Number_Declaration
2836 | N_Signed_Integer_Type_Definition;
2837 end In_Any_Integer_Context;
2841 Par : constant Node_Id := Parent (N);
2842 Typ : constant Entity_Id := Etype (N);
2844 -- Start of processing for Eval_Integer_Literal
2847 -- If the literal appears in a non-expression context, then it is
2848 -- certainly appearing in a non-static context, so check it. This is
2849 -- actually a redundant check, since Check_Non_Static_Context would
2850 -- check it, but it seems worthwhile to optimize out the call.
2852 -- Additionally, when the literal appears within an if or case
2853 -- expression it must be checked as well. However, due to the literal
2854 -- appearing within a conditional statement, expansion greatly changes
2855 -- the nature of its context and performing some of the checks within
2856 -- Check_Non_Static_Context on an expanded literal may lead to spurious
2857 -- and misleading warnings.
2859 if (Nkind (Par) in N_Case_Expression_Alternative | N_If_Expression
2860 or else Nkind (Par) not in N_Subexpr)
2861 and then (Nkind (Par) not in N_Case_Expression_Alternative
2863 or else Comes_From_Source (N))
2864 and then not In_Any_Integer_Context (Par)
2866 Check_Non_Static_Context (N);
2869 -- Modular integer literals must be in their base range
2871 if Is_Modular_Integer_Type (Typ)
2872 and then Is_Out_Of_Range (N, Base_Type (Typ), Assume_Valid => True)
2876 end Eval_Integer_Literal;
2878 -------------------------
2879 -- Eval_Intrinsic_Call --
2880 -------------------------
2882 procedure Eval_Intrinsic_Call (N : Node_Id; E : Entity_Id) is
2884 procedure Eval_Shift (N : Node_Id; E : Entity_Id; Op : Node_Kind);
2885 -- Evaluate an intrinsic shift call N on the given subprogram E.
2886 -- Op is the kind for the shift node.
2892 procedure Eval_Shift (N : Node_Id; E : Entity_Id; Op : Node_Kind) is
2893 Left : constant Node_Id := First_Actual (N);
2894 Right : constant Node_Id := Next_Actual (Left);
2895 Static : constant Boolean := Is_Static_Function (E);
2899 if Checking_Potentially_Static_Expression then
2900 Fold_Dummy (N, Etype (N));
2906 (N, Left, Right, Op, Static => Static, Check_Elab => not Static);
2912 -- Nothing to do if the intrinsic is handled by the back end.
2914 if Present (Interface_Name (E)) then
2918 -- Intrinsic calls as part of a static function is a language extension.
2920 if Checking_Potentially_Static_Expression
2921 and then not Extensions_Allowed
2926 -- If we have a renaming, expand the call to the original operation,
2927 -- which must itself be intrinsic, since renaming requires matching
2928 -- conventions and this has already been checked.
2930 if Present (Alias (E)) then
2931 Eval_Intrinsic_Call (N, Alias (E));
2935 -- If the intrinsic subprogram is generic, gets its original name
2937 if Present (Parent (E))
2938 and then Present (Generic_Parent (Parent (E)))
2940 Nam := Chars (Generic_Parent (Parent (E)));
2946 when Name_Shift_Left =>
2947 Eval_Shift (N, E, N_Op_Shift_Left);
2948 when Name_Shift_Right =>
2949 Eval_Shift (N, E, N_Op_Shift_Right);
2950 when Name_Shift_Right_Arithmetic =>
2951 Eval_Shift (N, E, N_Op_Shift_Right_Arithmetic);
2955 end Eval_Intrinsic_Call;
2957 ---------------------
2958 -- Eval_Logical_Op --
2959 ---------------------
2961 -- Logical operations are static functions, so the result is potentially
2962 -- static if both operands are potentially static (RM 4.9(7), 4.9(20)).
2964 procedure Eval_Logical_Op (N : Node_Id) is
2965 Left : constant Node_Id := Left_Opnd (N);
2966 Right : constant Node_Id := Right_Opnd (N);
2971 -- If not foldable we are done
2973 Test_Expression_Is_Foldable (N, Left, Right, Stat, Fold);
2979 -- Compile time evaluation of logical operation
2982 Left_Int : constant Uint := Expr_Value (Left);
2983 Right_Int : constant Uint := Expr_Value (Right);
2986 if Is_Modular_Integer_Type (Etype (N)) then
2988 Left_Bits : Bits (0 .. UI_To_Int (Esize (Etype (N))) - 1);
2989 Right_Bits : Bits (0 .. UI_To_Int (Esize (Etype (N))) - 1);
2992 To_Bits (Left_Int, Left_Bits);
2993 To_Bits (Right_Int, Right_Bits);
2995 -- Note: should really be able to use array ops instead of
2996 -- these loops, but they break the build with a cryptic error
2997 -- during the bind of gnat1 likely due to a wrong computation
2998 -- of a date or checksum.
3000 if Nkind (N) = N_Op_And then
3001 for J in Left_Bits'Range loop
3002 Left_Bits (J) := Left_Bits (J) and Right_Bits (J);
3005 elsif Nkind (N) = N_Op_Or then
3006 for J in Left_Bits'Range loop
3007 Left_Bits (J) := Left_Bits (J) or Right_Bits (J);
3011 pragma Assert (Nkind (N) = N_Op_Xor);
3013 for J in Left_Bits'Range loop
3014 Left_Bits (J) := Left_Bits (J) xor Right_Bits (J);
3018 Fold_Uint (N, From_Bits (Left_Bits, Etype (N)), Stat);
3022 pragma Assert (Is_Boolean_Type (Etype (N)));
3024 if Nkind (N) = N_Op_And then
3026 Test (Is_True (Left_Int) and then Is_True (Right_Int)), Stat);
3028 elsif Nkind (N) = N_Op_Or then
3030 Test (Is_True (Left_Int) or else Is_True (Right_Int)), Stat);
3033 pragma Assert (Nkind (N) = N_Op_Xor);
3035 Test (Is_True (Left_Int) xor Is_True (Right_Int)), Stat);
3039 end Eval_Logical_Op;
3041 ------------------------
3042 -- Eval_Membership_Op --
3043 ------------------------
3045 -- A membership test is potentially static if the expression is static, and
3046 -- the range is a potentially static range, or is a subtype mark denoting a
3047 -- static subtype (RM 4.9(12)).
3049 procedure Eval_Membership_Op (N : Node_Id) is
3050 Alts : constant List_Id := Alternatives (N);
3051 Choice : constant Node_Id := Right_Opnd (N);
3052 Expr : constant Node_Id := Left_Opnd (N);
3053 Result : Match_Result;
3056 -- Ignore if error in either operand, except to make sure that Any_Type
3057 -- is properly propagated to avoid junk cascaded errors.
3059 if Etype (Expr) = Any_Type
3060 or else (Present (Choice) and then Etype (Choice) = Any_Type)
3062 Set_Etype (N, Any_Type);
3066 -- If left operand non-static, then nothing to do
3068 if not Is_Static_Expression (Expr) then
3072 -- If choice is non-static, left operand is in non-static context
3074 if (Present (Choice) and then not Is_Static_Choice (Choice))
3075 or else (Present (Alts) and then not Is_Static_Choice_List (Alts))
3077 Check_Non_Static_Context (Expr);
3081 -- Otherwise we definitely have a static expression
3083 Set_Is_Static_Expression (N);
3085 -- If left operand raises Constraint_Error, propagate and we are done
3087 if Raises_Constraint_Error (Expr) then
3088 Set_Raises_Constraint_Error (N, True);
3093 if Present (Choice) then
3094 Result := Choice_Matches (Expr, Choice);
3096 Result := Choices_Match (Expr, Alts);
3099 -- If result is Non_Static, it means that we raise Constraint_Error,
3100 -- since we already tested that the operands were themselves static.
3102 if Result = Non_Static then
3103 Set_Raises_Constraint_Error (N);
3105 -- Otherwise we have our result (flipped if NOT IN case)
3109 (N, Test ((Result = Match) xor (Nkind (N) = N_Not_In)), True);
3110 Warn_On_Known_Condition (N);
3113 end Eval_Membership_Op;
3115 ------------------------
3116 -- Eval_Named_Integer --
3117 ------------------------
3119 procedure Eval_Named_Integer (N : Node_Id) is
3122 Expr_Value (Expression (Declaration_Node (Entity (N)))), True);
3123 end Eval_Named_Integer;
3125 ---------------------
3126 -- Eval_Named_Real --
3127 ---------------------
3129 procedure Eval_Named_Real (N : Node_Id) is
3132 Expr_Value_R (Expression (Declaration_Node (Entity (N)))), True);
3133 end Eval_Named_Real;
3139 -- Exponentiation is a static functions, so the result is potentially
3140 -- static if both operands are potentially static (RM 4.9(7), 4.9(20)).
3142 procedure Eval_Op_Expon (N : Node_Id) is
3143 Left : constant Node_Id := Left_Opnd (N);
3144 Right : constant Node_Id := Right_Opnd (N);
3149 -- If not foldable we are done
3151 Test_Expression_Is_Foldable
3152 (N, Left, Right, Stat, Fold, CRT_Safe => True);
3154 -- Return if not foldable
3160 if Configurable_Run_Time_Mode and not Stat then
3164 -- Fold exponentiation operation
3167 Right_Int : constant Uint := Expr_Value (Right);
3172 if Is_Integer_Type (Etype (Left)) then
3174 Left_Int : constant Uint := Expr_Value (Left);
3178 -- Exponentiation of an integer raises Constraint_Error for a
3179 -- negative exponent (RM 4.5.6).
3181 if Right_Int < 0 then
3182 Apply_Compile_Time_Constraint_Error
3183 (N, "integer exponent negative", CE_Range_Check_Failed,
3188 if OK_Bits (N, Num_Bits (Left_Int) * Right_Int) then
3189 Result := Left_Int ** Right_Int;
3194 if Is_Modular_Integer_Type (Etype (N)) then
3195 Result := Result mod Modulus (Etype (N));
3198 Fold_Uint (N, Result, Stat);
3206 Left_Real : constant Ureal := Expr_Value_R (Left);
3209 -- Cannot have a zero base with a negative exponent
3211 if UR_Is_Zero (Left_Real) then
3213 if Right_Int < 0 then
3214 Apply_Compile_Time_Constraint_Error
3215 (N, "zero ** negative integer", CE_Range_Check_Failed,
3219 Fold_Ureal (N, Ureal_0, Stat);
3223 Fold_Ureal (N, Left_Real ** Right_Int, Stat);
3234 -- The not operation is a static function, so the result is potentially
3235 -- static if the operand is potentially static (RM 4.9(7), 4.9(20)).
3237 procedure Eval_Op_Not (N : Node_Id) is
3238 Right : constant Node_Id := Right_Opnd (N);
3243 -- If not foldable we are done
3245 Test_Expression_Is_Foldable (N, Right, Stat, Fold);
3251 -- Fold not operation
3254 Rint : constant Uint := Expr_Value (Right);
3255 Typ : constant Entity_Id := Etype (N);
3258 -- Negation is equivalent to subtracting from the modulus minus one.
3259 -- For a binary modulus this is equivalent to the ones-complement of
3260 -- the original value. For a nonbinary modulus this is an arbitrary
3261 -- but consistent definition.
3263 if Is_Modular_Integer_Type (Typ) then
3264 Fold_Uint (N, Modulus (Typ) - 1 - Rint, Stat);
3265 else pragma Assert (Is_Boolean_Type (Typ));
3266 Fold_Uint (N, Test (not Is_True (Rint)), Stat);
3269 Set_Is_Static_Expression (N, Stat);
3273 -------------------------------
3274 -- Eval_Qualified_Expression --
3275 -------------------------------
3277 -- A qualified expression is potentially static if its subtype mark denotes
3278 -- a static subtype and its expression is potentially static (RM 4.9 (10)).
3280 procedure Eval_Qualified_Expression (N : Node_Id) is
3281 Operand : constant Node_Id := Expression (N);
3282 Target_Type : constant Entity_Id := Entity (Subtype_Mark (N));
3289 -- Can only fold if target is string or scalar and subtype is static.
3290 -- Also, do not fold if our parent is an allocator (this is because the
3291 -- qualified expression is really part of the syntactic structure of an
3292 -- allocator, and we do not want to end up with something that
3293 -- corresponds to "new 1" where the 1 is the result of folding a
3294 -- qualified expression).
3296 if not Is_Static_Subtype (Target_Type)
3297 or else Nkind (Parent (N)) = N_Allocator
3299 Check_Non_Static_Context (Operand);
3301 -- If operand is known to raise Constraint_Error, set the flag on the
3302 -- expression so it does not get optimized away.
3304 if Nkind (Operand) = N_Raise_Constraint_Error then
3305 Set_Raises_Constraint_Error (N);
3310 -- Also return if a semantic error has been posted on the node, as we
3311 -- don't want to fold in that case (for GNATprove, the node might lead
3312 -- to Constraint_Error but won't have been replaced with a raise node
3313 -- or marked as raising CE).
3315 elsif Error_Posted (N) then
3319 -- If not foldable we are done
3321 Test_Expression_Is_Foldable (N, Operand, Stat, Fold);
3326 -- Don't try fold if target type has Constraint_Error bounds
3328 elsif not Is_OK_Static_Subtype (Target_Type) then
3329 Set_Raises_Constraint_Error (N);
3333 -- Fold the result of qualification
3335 if Is_Discrete_Type (Target_Type) then
3337 -- Save Print_In_Hex indication
3339 Hex := Nkind (Operand) = N_Integer_Literal
3340 and then Print_In_Hex (Operand);
3342 Fold_Uint (N, Expr_Value (Operand), Stat);
3344 -- Preserve Print_In_Hex indication
3346 if Hex and then Nkind (N) = N_Integer_Literal then
3347 Set_Print_In_Hex (N);
3350 elsif Is_Real_Type (Target_Type) then
3351 Fold_Ureal (N, Expr_Value_R (Operand), Stat);
3354 Fold_Str (N, Strval (Get_String_Val (Operand)), Stat);
3357 Set_Is_Static_Expression (N, False);
3359 Check_String_Literal_Length (N, Target_Type);
3365 -- The expression may be foldable but not static
3367 Set_Is_Static_Expression (N, Stat);
3369 if Is_Out_Of_Range (N, Etype (N), Assume_Valid => True) then
3372 end Eval_Qualified_Expression;
3374 -----------------------
3375 -- Eval_Real_Literal --
3376 -----------------------
3378 -- Numeric literals are static (RM 4.9(1)), and have already been marked
3379 -- as static by the analyzer. The reason we did it that early is to allow
3380 -- the possibility of turning off the Is_Static_Expression flag after
3381 -- analysis, but before resolution, when integer literals are generated
3382 -- in the expander that do not correspond to static expressions.
3384 procedure Eval_Real_Literal (N : Node_Id) is
3385 PK : constant Node_Kind := Nkind (Parent (N));
3388 -- If the literal appears in a non-expression context and not as part of
3389 -- a number declaration, then it is appearing in a non-static context,
3392 if PK not in N_Subexpr and then PK /= N_Number_Declaration then
3393 Check_Non_Static_Context (N);
3395 end Eval_Real_Literal;
3397 ------------------------
3398 -- Eval_Relational_Op --
3399 ------------------------
3401 -- Relational operations are static functions, so the result is static if
3402 -- both operands are static (RM 4.9(7), 4.9(20)), except that up to Ada
3403 -- 2012, for strings the result is never static, even if the operands are.
3404 -- The string case was relaxed in Ada 2020, see AI12-0201.
3406 -- However, for internally generated nodes, we allow string equality and
3407 -- inequality to be static. This is because we rewrite A in "ABC" as an
3408 -- equality test A = "ABC", and the former is definitely static.
3410 procedure Eval_Relational_Op (N : Node_Id) is
3411 Left : constant Node_Id := Left_Opnd (N);
3412 Right : constant Node_Id := Right_Opnd (N);
3414 procedure Decompose_Expr
3416 Ent : out Entity_Id;
3417 Kind : out Character;
3419 Orig : Boolean := True);
3420 -- Given expression Expr, see if it is of the form X [+/- K]. If so, Ent
3421 -- is set to the entity in X, Kind is 'F','L','E' for 'First or 'Last or
3422 -- simple entity, and Cons is the value of K. If the expression is not
3423 -- of the required form, Ent is set to Empty.
3425 -- Orig indicates whether Expr is the original expression to consider,
3426 -- or if we are handling a subexpression (e.g. recursive call to
3429 procedure Fold_General_Op (Is_Static : Boolean);
3430 -- Attempt to fold arbitrary relational operator N. Flag Is_Static must
3431 -- be set when the operator denotes a static expression.
3433 procedure Fold_Static_Real_Op;
3434 -- Attempt to fold static real type relational operator N
3436 function Static_Length (Expr : Node_Id) return Uint;
3437 -- If Expr is an expression for a constrained array whose length is
3438 -- known at compile time, return the non-negative length, otherwise
3441 --------------------
3442 -- Decompose_Expr --
3443 --------------------
3445 procedure Decompose_Expr
3447 Ent : out Entity_Id;
3448 Kind : out Character;
3450 Orig : Boolean := True)
3455 -- Assume that the expression does not meet the expected form
3461 if Nkind (Expr) = N_Op_Add
3462 and then Compile_Time_Known_Value (Right_Opnd (Expr))
3464 Exp := Left_Opnd (Expr);
3465 Cons := Expr_Value (Right_Opnd (Expr));
3467 elsif Nkind (Expr) = N_Op_Subtract
3468 and then Compile_Time_Known_Value (Right_Opnd (Expr))
3470 Exp := Left_Opnd (Expr);
3471 Cons := -Expr_Value (Right_Opnd (Expr));
3473 -- If the bound is a constant created to remove side effects, recover
3474 -- the original expression to see if it has one of the recognizable
3477 elsif Nkind (Expr) = N_Identifier
3478 and then not Comes_From_Source (Entity (Expr))
3479 and then Ekind (Entity (Expr)) = E_Constant
3480 and then Nkind (Parent (Entity (Expr))) = N_Object_Declaration
3482 Exp := Expression (Parent (Entity (Expr)));
3483 Decompose_Expr (Exp, Ent, Kind, Cons, Orig => False);
3485 -- If original expression includes an entity, create a reference
3486 -- to it for use below.
3488 if Present (Ent) then
3489 Exp := New_Occurrence_Of (Ent, Sloc (Ent));
3495 -- Only consider the case of X + 0 for a full expression, and
3496 -- not when recursing, otherwise we may end up with evaluating
3497 -- expressions not known at compile time to 0.
3507 -- At this stage Exp is set to the potential X
3509 if Nkind (Exp) = N_Attribute_Reference then
3510 if Attribute_Name (Exp) = Name_First then
3512 elsif Attribute_Name (Exp) = Name_Last then
3518 Exp := Prefix (Exp);
3524 if Is_Entity_Name (Exp) and then Present (Entity (Exp)) then
3525 Ent := Entity (Exp);
3529 ---------------------
3530 -- Fold_General_Op --
3531 ---------------------
3533 procedure Fold_General_Op (Is_Static : Boolean) is
3534 CR : constant Compare_Result :=
3535 Compile_Time_Compare (Left, Right, Assume_Valid => False);
3540 if CR = Unknown then
3548 elsif CR = NE or else CR = GT or else CR = LT then
3555 if CR = GT or else CR = EQ or else CR = GE then
3566 elsif CR = EQ or else CR = LT or else CR = LE then
3573 if CR = LT or else CR = EQ or else CR = LE then
3584 elsif CR = EQ or else CR = GT or else CR = GE then
3591 if CR = NE or else CR = GT or else CR = LT then
3600 raise Program_Error;
3603 -- Determine the potential outcome of the relation assuming the
3604 -- operands are valid and emit a warning when the relation yields
3605 -- True or False only in the presence of invalid values.
3607 Warn_On_Constant_Valid_Condition (N);
3609 Fold_Uint (N, Test (Result), Is_Static);
3610 end Fold_General_Op;
3612 -------------------------
3613 -- Fold_Static_Real_Op --
3614 -------------------------
3616 procedure Fold_Static_Real_Op is
3617 Left_Real : constant Ureal := Expr_Value_R (Left);
3618 Right_Real : constant Ureal := Expr_Value_R (Right);
3623 when N_Op_Eq => Result := (Left_Real = Right_Real);
3624 when N_Op_Ge => Result := (Left_Real >= Right_Real);
3625 when N_Op_Gt => Result := (Left_Real > Right_Real);
3626 when N_Op_Le => Result := (Left_Real <= Right_Real);
3627 when N_Op_Lt => Result := (Left_Real < Right_Real);
3628 when N_Op_Ne => Result := (Left_Real /= Right_Real);
3629 when others => raise Program_Error;
3632 Fold_Uint (N, Test (Result), True);
3633 end Fold_Static_Real_Op;
3639 function Static_Length (Expr : Node_Id) return Uint is
3649 -- First easy case string literal
3651 if Nkind (Expr) = N_String_Literal then
3652 return UI_From_Int (String_Length (Strval (Expr)));
3654 -- With frontend inlining as performed in GNATprove mode, a variable
3655 -- may be inserted that has a string literal subtype. Deal with this
3656 -- specially as for the previous case.
3658 elsif Ekind (Etype (Expr)) = E_String_Literal_Subtype then
3659 return String_Literal_Length (Etype (Expr));
3661 -- Second easy case, not constrained subtype, so no length
3663 elsif not Is_Constrained (Etype (Expr)) then
3664 return Uint_Minus_1;
3669 Typ := Etype (First_Index (Etype (Expr)));
3671 -- The simple case, both bounds are known at compile time
3673 if Is_Discrete_Type (Typ)
3674 and then Compile_Time_Known_Value (Type_Low_Bound (Typ))
3675 and then Compile_Time_Known_Value (Type_High_Bound (Typ))
3678 UI_Max (Uint_0, Expr_Value (Type_High_Bound (Typ)) -
3679 Expr_Value (Type_Low_Bound (Typ)) + 1);
3682 -- A more complex case, where the bounds are of the form X [+/- K1]
3683 -- .. X [+/- K2]), where X is an expression that is either A'First or
3684 -- A'Last (with A an entity name), or X is an entity name, and the
3685 -- two X's are the same and K1 and K2 are known at compile time, in
3686 -- this case, the length can also be computed at compile time, even
3687 -- though the bounds are not known. A common case of this is e.g.
3688 -- (X'First .. X'First+5).
3691 (Original_Node (Type_Low_Bound (Typ)), Ent1, Kind1, Cons1);
3693 (Original_Node (Type_High_Bound (Typ)), Ent2, Kind2, Cons2);
3695 if Present (Ent1) and then Ent1 = Ent2 and then Kind1 = Kind2 then
3696 return Cons2 - Cons1 + 1;
3698 return Uint_Minus_1;
3704 Left_Typ : constant Entity_Id := Etype (Left);
3705 Right_Typ : constant Entity_Id := Etype (Right);
3708 Op_Typ : Entity_Id := Empty;
3711 Is_Static_Expression : Boolean;
3713 -- Start of processing for Eval_Relational_Op
3716 -- One special case to deal with first. If we can tell that the result
3717 -- will be false because the lengths of one or more index subtypes are
3718 -- compile-time known and different, then we can replace the entire
3719 -- result by False. We only do this for one-dimensional arrays, because
3720 -- the case of multidimensional arrays is rare and too much trouble. If
3721 -- one of the operands is an illegal aggregate, its type might still be
3722 -- an arbitrary composite type, so nothing to do.
3724 if Is_Array_Type (Left_Typ)
3725 and then Left_Typ /= Any_Composite
3726 and then Number_Dimensions (Left_Typ) = 1
3727 and then Nkind (N) in N_Op_Eq | N_Op_Ne
3729 if Raises_Constraint_Error (Left)
3731 Raises_Constraint_Error (Right)
3735 -- OK, we have the case where we may be able to do this fold
3738 Left_Len := Static_Length (Left);
3739 Right_Len := Static_Length (Right);
3741 if Left_Len /= Uint_Minus_1
3742 and then Right_Len /= Uint_Minus_1
3743 and then Left_Len /= Right_Len
3745 -- AI12-0201: comparison of string is static in Ada 202x
3749 Test (Nkind (N) = N_Op_Ne),
3750 Static => Ada_Version >= Ada_2020
3751 and then Is_String_Type (Left_Typ));
3752 Warn_On_Known_Condition (N);
3760 -- Initialize the value of Is_Static_Expression. The value of Fold
3761 -- returned by Test_Expression_Is_Foldable is not needed since, even
3762 -- when some operand is a variable, we can still perform the static
3763 -- evaluation of the expression in some cases (for example, for a
3764 -- variable of a subtype of Integer we statically know that any value
3765 -- stored in such variable is smaller than Integer'Last).
3767 Test_Expression_Is_Foldable
3768 (N, Left, Right, Is_Static_Expression, Fold);
3770 -- Comparisons of scalars can give static results.
3771 -- In addition starting with Ada 202x (AI12-0201), comparison of
3772 -- strings can also give static results, and as noted above, we also
3773 -- allow for earlier Ada versions internally generated equality and
3774 -- inequality for strings.
3775 -- ??? The Comes_From_Source test below isn't correct and will accept
3776 -- some cases that are illegal in Ada 2012. and before. Now that
3777 -- Ada 202x has relaxed the rules, this doesn't really matter.
3779 if Is_String_Type (Left_Typ) then
3780 if Ada_Version < Ada_2020
3781 and then (Comes_From_Source (N)
3782 or else Nkind (N) not in N_Op_Eq | N_Op_Ne)
3784 Is_Static_Expression := False;
3785 Set_Is_Static_Expression (N, False);
3788 elsif not Is_Scalar_Type (Left_Typ) then
3789 Is_Static_Expression := False;
3790 Set_Is_Static_Expression (N, False);
3793 -- For operators on universal numeric types called as functions with
3794 -- an explicit scope, determine appropriate specific numeric type,
3795 -- and diagnose possible ambiguity.
3797 if Is_Universal_Numeric_Type (Left_Typ)
3799 Is_Universal_Numeric_Type (Right_Typ)
3801 Op_Typ := Find_Universal_Operator_Type (N);
3804 -- Attempt to fold the relational operator
3806 if Is_Static_Expression and then Is_Real_Type (Left_Typ) then
3807 Fold_Static_Real_Op;
3809 Fold_General_Op (Is_Static_Expression);
3813 -- For the case of a folded relational operator on a specific numeric
3814 -- type, freeze the operand type now.
3816 if Present (Op_Typ) then
3817 Freeze_Before (N, Op_Typ);
3820 Warn_On_Known_Condition (N);
3821 end Eval_Relational_Op;
3827 procedure Eval_Shift (N : Node_Id) is
3829 -- This procedure is only called for compiler generated code (e.g.
3830 -- packed arrays), so there is nothing to do except attempting to fold
3833 Fold_Shift (N, Left_Opnd (N), Right_Opnd (N), Nkind (N));
3836 ------------------------
3837 -- Eval_Short_Circuit --
3838 ------------------------
3840 -- A short circuit operation is potentially static if both operands are
3841 -- potentially static (RM 4.9 (13)).
3843 procedure Eval_Short_Circuit (N : Node_Id) is
3844 Kind : constant Node_Kind := Nkind (N);
3845 Left : constant Node_Id := Left_Opnd (N);
3846 Right : constant Node_Id := Right_Opnd (N);
3849 Rstat : constant Boolean :=
3850 Is_Static_Expression (Left)
3852 Is_Static_Expression (Right);
3855 -- Short circuit operations are never static in Ada 83
3857 if Ada_Version = Ada_83 and then Comes_From_Source (N) then
3858 Check_Non_Static_Context (Left);
3859 Check_Non_Static_Context (Right);
3863 -- Now look at the operands, we can't quite use the normal call to
3864 -- Test_Expression_Is_Foldable here because short circuit operations
3865 -- are a special case, they can still be foldable, even if the right
3866 -- operand raises Constraint_Error.
3868 -- If either operand is Any_Type, just propagate to result and do not
3869 -- try to fold, this prevents cascaded errors.
3871 if Etype (Left) = Any_Type or else Etype (Right) = Any_Type then
3872 Set_Etype (N, Any_Type);
3875 -- If left operand raises Constraint_Error, then replace node N with
3876 -- the raise Constraint_Error node, and we are obviously not foldable.
3877 -- Is_Static_Expression is set from the two operands in the normal way,
3878 -- and we check the right operand if it is in a non-static context.
3880 elsif Raises_Constraint_Error (Left) then
3882 Check_Non_Static_Context (Right);
3885 Rewrite_In_Raise_CE (N, Left);
3886 Set_Is_Static_Expression (N, Rstat);
3889 -- If the result is not static, then we won't in any case fold
3891 elsif not Rstat then
3892 Check_Non_Static_Context (Left);
3893 Check_Non_Static_Context (Right);
3897 -- Here the result is static, note that, unlike the normal processing
3898 -- in Test_Expression_Is_Foldable, we did *not* check above to see if
3899 -- the right operand raises Constraint_Error, that's because it is not
3900 -- significant if the left operand is decisive.
3902 Set_Is_Static_Expression (N);
3904 -- It does not matter if the right operand raises Constraint_Error if
3905 -- it will not be evaluated. So deal specially with the cases where
3906 -- the right operand is not evaluated. Note that we will fold these
3907 -- cases even if the right operand is non-static, which is fine, but
3908 -- of course in these cases the result is not potentially static.
3910 Left_Int := Expr_Value (Left);
3912 if (Kind = N_And_Then and then Is_False (Left_Int))
3914 (Kind = N_Or_Else and then Is_True (Left_Int))
3916 Fold_Uint (N, Left_Int, Rstat);
3920 -- If first operand not decisive, then it does matter if the right
3921 -- operand raises Constraint_Error, since it will be evaluated, so
3922 -- we simply replace the node with the right operand. Note that this
3923 -- properly propagates Is_Static_Expression and Raises_Constraint_Error
3924 -- (both are set to True in Right).
3926 if Raises_Constraint_Error (Right) then
3927 Rewrite_In_Raise_CE (N, Right);
3928 Check_Non_Static_Context (Left);
3932 -- Otherwise the result depends on the right operand
3934 Fold_Uint (N, Expr_Value (Right), Rstat);
3936 end Eval_Short_Circuit;
3942 -- Slices can never be static, so the only processing required is to check
3943 -- for non-static context if an explicit range is given.
3945 procedure Eval_Slice (N : Node_Id) is
3946 Drange : constant Node_Id := Discrete_Range (N);
3949 if Nkind (Drange) = N_Range then
3950 Check_Non_Static_Context (Low_Bound (Drange));
3951 Check_Non_Static_Context (High_Bound (Drange));
3954 -- A slice of the form A (subtype), when the subtype is the index of
3955 -- the type of A, is redundant, the slice can be replaced with A, and
3956 -- this is worth a warning.
3958 if Is_Entity_Name (Prefix (N)) then
3960 E : constant Entity_Id := Entity (Prefix (N));
3961 T : constant Entity_Id := Etype (E);
3964 if Ekind (E) = E_Constant
3965 and then Is_Array_Type (T)
3966 and then Is_Entity_Name (Drange)
3968 if Is_Entity_Name (Original_Node (First_Index (T)))
3969 and then Entity (Original_Node (First_Index (T)))
3972 if Warn_On_Redundant_Constructs then
3973 Error_Msg_N ("redundant slice denotes whole array?r?", N);
3976 -- The following might be a useful optimization???
3978 -- Rewrite (N, New_Occurrence_Of (E, Sloc (N)));
3985 -------------------------
3986 -- Eval_String_Literal --
3987 -------------------------
3989 procedure Eval_String_Literal (N : Node_Id) is
3990 Typ : constant Entity_Id := Etype (N);
3991 Bas : constant Entity_Id := Base_Type (Typ);
3997 -- Nothing to do if error type (handles cases like default expressions
3998 -- or generics where we have not yet fully resolved the type).
4000 if Bas = Any_Type or else Bas = Any_String then
4004 -- String literals are static if the subtype is static (RM 4.9(2)), so
4005 -- reset the static expression flag (it was set unconditionally in
4006 -- Analyze_String_Literal) if the subtype is non-static. We tell if
4007 -- the subtype is static by looking at the lower bound.
4009 if Ekind (Typ) = E_String_Literal_Subtype then
4010 if not Is_OK_Static_Expression (String_Literal_Low_Bound (Typ)) then
4011 Set_Is_Static_Expression (N, False);
4015 -- Here if Etype of string literal is normal Etype (not yet possible,
4016 -- but may be possible in future).
4018 elsif not Is_OK_Static_Expression
4019 (Type_Low_Bound (Etype (First_Index (Typ))))
4021 Set_Is_Static_Expression (N, False);
4025 -- If original node was a type conversion, then result if non-static
4026 -- up to Ada 2012. AI12-0201 changes that with Ada 202x.
4028 if Nkind (Original_Node (N)) = N_Type_Conversion
4029 and then Ada_Version <= Ada_2012
4031 Set_Is_Static_Expression (N, False);
4035 -- Test for illegal Ada 95 cases. A string literal is illegal in Ada 95
4036 -- if its bounds are outside the index base type and this index type is
4037 -- static. This can happen in only two ways. Either the string literal
4038 -- is too long, or it is null, and the lower bound is type'First. Either
4039 -- way it is the upper bound that is out of range of the index type.
4041 if Ada_Version >= Ada_95 then
4042 if Is_Standard_String_Type (Bas) then
4043 Xtp := Standard_Positive;
4045 Xtp := Etype (First_Index (Bas));
4048 if Ekind (Typ) = E_String_Literal_Subtype then
4049 Lo := String_Literal_Low_Bound (Typ);
4051 Lo := Type_Low_Bound (Etype (First_Index (Typ)));
4054 -- Check for string too long
4056 Len := String_Length (Strval (N));
4058 if UI_From_Int (Len) > String_Type_Len (Bas) then
4060 -- Issue message. Note that this message is a warning if the
4061 -- string literal is not marked as static (happens in some cases
4062 -- of folding strings known at compile time, but not static).
4063 -- Furthermore in such cases, we reword the message, since there
4064 -- is no string literal in the source program.
4066 if Is_Static_Expression (N) then
4067 Apply_Compile_Time_Constraint_Error
4068 (N, "string literal too long for}", CE_Length_Check_Failed,
4070 Typ => First_Subtype (Bas));
4072 Apply_Compile_Time_Constraint_Error
4073 (N, "string value too long for}", CE_Length_Check_Failed,
4075 Typ => First_Subtype (Bas),
4079 -- Test for null string not allowed
4082 and then not Is_Generic_Type (Xtp)
4084 Expr_Value (Lo) = Expr_Value (Type_Low_Bound (Base_Type (Xtp)))
4086 -- Same specialization of message
4088 if Is_Static_Expression (N) then
4089 Apply_Compile_Time_Constraint_Error
4090 (N, "null string literal not allowed for}",
4091 CE_Length_Check_Failed,
4093 Typ => First_Subtype (Bas));
4095 Apply_Compile_Time_Constraint_Error
4096 (N, "null string value not allowed for}",
4097 CE_Length_Check_Failed,
4099 Typ => First_Subtype (Bas),
4104 end Eval_String_Literal;
4106 --------------------------
4107 -- Eval_Type_Conversion --
4108 --------------------------
4110 -- A type conversion is potentially static if its subtype mark is for a
4111 -- static scalar subtype, and its operand expression is potentially static
4113 -- Also add support for static string types.
4115 procedure Eval_Type_Conversion (N : Node_Id) is
4116 Operand : constant Node_Id := Expression (N);
4117 Source_Type : constant Entity_Id := Etype (Operand);
4118 Target_Type : constant Entity_Id := Etype (N);
4120 function To_Be_Treated_As_Integer (T : Entity_Id) return Boolean;
4121 -- Returns true if type T is an integer type, or if it is a fixed-point
4122 -- type to be treated as an integer (i.e. the flag Conversion_OK is set
4123 -- on the conversion node).
4125 function To_Be_Treated_As_Real (T : Entity_Id) return Boolean;
4126 -- Returns true if type T is a floating-point type, or if it is a
4127 -- fixed-point type that is not to be treated as an integer (i.e. the
4128 -- flag Conversion_OK is not set on the conversion node).
4130 ------------------------------
4131 -- To_Be_Treated_As_Integer --
4132 ------------------------------
4134 function To_Be_Treated_As_Integer (T : Entity_Id) return Boolean is
4138 or else (Is_Fixed_Point_Type (T) and then Conversion_OK (N));
4139 end To_Be_Treated_As_Integer;
4141 ---------------------------
4142 -- To_Be_Treated_As_Real --
4143 ---------------------------
4145 function To_Be_Treated_As_Real (T : Entity_Id) return Boolean is
4148 Is_Floating_Point_Type (T)
4149 or else (Is_Fixed_Point_Type (T) and then not Conversion_OK (N));
4150 end To_Be_Treated_As_Real;
4157 -- Start of processing for Eval_Type_Conversion
4160 -- Cannot fold if target type is non-static or if semantic error
4162 if not Is_Static_Subtype (Target_Type) then
4163 Check_Non_Static_Context (Operand);
4165 elsif Error_Posted (N) then
4169 -- If not foldable we are done
4171 Test_Expression_Is_Foldable (N, Operand, Stat, Fold);
4176 -- Don't try fold if target type has Constraint_Error bounds
4178 elsif not Is_OK_Static_Subtype (Target_Type) then
4179 Set_Raises_Constraint_Error (N);
4183 -- Remaining processing depends on operand types. Note that in the
4184 -- following type test, fixed-point counts as real unless the flag
4185 -- Conversion_OK is set, in which case it counts as integer.
4187 -- Fold conversion, case of string type. The result is static starting
4188 -- with Ada 202x (AI12-0201).
4190 if Is_String_Type (Target_Type) then
4193 Strval (Get_String_Val (Operand)),
4194 Static => Ada_Version >= Ada_2020);
4197 -- Fold conversion, case of integer target type
4199 elsif To_Be_Treated_As_Integer (Target_Type) then
4204 -- Integer to integer conversion
4206 if To_Be_Treated_As_Integer (Source_Type) then
4207 Result := Expr_Value (Operand);
4209 -- Real to integer conversion
4211 elsif To_Be_Treated_As_Real (Source_Type) then
4212 Result := UR_To_Uint (Expr_Value_R (Operand));
4214 -- Enumeration to integer conversion, aka 'Enum_Rep
4217 Result := Expr_Rep_Value (Operand);
4220 -- If fixed-point type (Conversion_OK must be set), then the
4221 -- result is logically an integer, but we must replace the
4222 -- conversion with the corresponding real literal, since the
4223 -- type from a semantic point of view is still fixed-point.
4225 if Is_Fixed_Point_Type (Target_Type) then
4227 (N, UR_From_Uint (Result) * Small_Value (Target_Type), Stat);
4229 -- Otherwise result is integer literal
4232 Fold_Uint (N, Result, Stat);
4236 -- Fold conversion, case of real target type
4238 elsif To_Be_Treated_As_Real (Target_Type) then
4243 if To_Be_Treated_As_Real (Source_Type) then
4244 Result := Expr_Value_R (Operand);
4246 Result := UR_From_Uint (Expr_Value (Operand));
4249 Fold_Ureal (N, Result, Stat);
4252 -- Enumeration types
4255 Fold_Uint (N, Expr_Value (Operand), Stat);
4258 if Is_Out_Of_Range (N, Etype (N), Assume_Valid => True) then
4261 end Eval_Type_Conversion;
4267 -- Predefined unary operators are static functions (RM 4.9(20)) and thus
4268 -- are potentially static if the operand is potentially static (RM 4.9(7)).
4270 procedure Eval_Unary_Op (N : Node_Id) is
4271 Right : constant Node_Id := Right_Opnd (N);
4272 Otype : Entity_Id := Empty;
4277 -- If not foldable we are done
4279 Test_Expression_Is_Foldable (N, Right, Stat, Fold);
4285 if Etype (Right) = Universal_Integer
4287 Etype (Right) = Universal_Real
4289 Otype := Find_Universal_Operator_Type (N);
4292 -- Fold for integer case
4294 if Is_Integer_Type (Etype (N)) then
4296 Rint : constant Uint := Expr_Value (Right);
4300 -- In the case of modular unary plus and abs there is no need
4301 -- to adjust the result of the operation since if the original
4302 -- operand was in bounds the result will be in the bounds of the
4303 -- modular type. However, in the case of modular unary minus the
4304 -- result may go out of the bounds of the modular type and needs
4307 if Nkind (N) = N_Op_Plus then
4310 elsif Nkind (N) = N_Op_Minus then
4311 if Is_Modular_Integer_Type (Etype (N)) then
4312 Result := (-Rint) mod Modulus (Etype (N));
4318 pragma Assert (Nkind (N) = N_Op_Abs);
4322 Fold_Uint (N, Result, Stat);
4325 -- Fold for real case
4327 elsif Is_Real_Type (Etype (N)) then
4329 Rreal : constant Ureal := Expr_Value_R (Right);
4333 if Nkind (N) = N_Op_Plus then
4335 elsif Nkind (N) = N_Op_Minus then
4336 Result := UR_Negate (Rreal);
4338 pragma Assert (Nkind (N) = N_Op_Abs);
4339 Result := abs Rreal;
4342 Fold_Ureal (N, Result, Stat);
4346 -- If the operator was resolved to a specific type, make sure that type
4347 -- is frozen even if the expression is folded into a literal (which has
4348 -- a universal type).
4350 if Present (Otype) then
4351 Freeze_Before (N, Otype);
4355 -------------------------------
4356 -- Eval_Unchecked_Conversion --
4357 -------------------------------
4359 -- Unchecked conversions can never be static, so the only required
4360 -- processing is to check for a non-static context for the operand.
4362 procedure Eval_Unchecked_Conversion (N : Node_Id) is
4364 Check_Non_Static_Context (Expression (N));
4365 end Eval_Unchecked_Conversion;
4367 --------------------
4368 -- Expr_Rep_Value --
4369 --------------------
4371 function Expr_Rep_Value (N : Node_Id) return Uint is
4372 Kind : constant Node_Kind := Nkind (N);
4376 if Is_Entity_Name (N) then
4379 -- An enumeration literal that was either in the source or created
4380 -- as a result of static evaluation.
4382 if Ekind (Ent) = E_Enumeration_Literal then
4383 return Enumeration_Rep (Ent);
4385 -- A user defined static constant
4388 pragma Assert (Ekind (Ent) = E_Constant);
4389 return Expr_Rep_Value (Constant_Value (Ent));
4392 -- An integer literal that was either in the source or created as a
4393 -- result of static evaluation.
4395 elsif Kind = N_Integer_Literal then
4398 -- A real literal for a fixed-point type. This must be the fixed-point
4399 -- case, either the literal is of a fixed-point type, or it is a bound
4400 -- of a fixed-point type, with type universal real. In either case we
4401 -- obtain the desired value from Corresponding_Integer_Value.
4403 elsif Kind = N_Real_Literal then
4404 pragma Assert (Is_Fixed_Point_Type (Underlying_Type (Etype (N))));
4405 return Corresponding_Integer_Value (N);
4407 -- The NULL access value
4409 elsif Kind = N_Null then
4410 pragma Assert (Is_Access_Type (Underlying_Type (Etype (N)))
4411 or else Error_Posted (N));
4414 -- Character literal
4416 elsif Kind = N_Character_Literal then
4419 -- Since Character literals of type Standard.Character don't have any
4420 -- defining character literals built for them, they do not have their
4421 -- Entity set, so just use their Char code. Otherwise for user-
4422 -- defined character literals use their Pos value as usual which is
4423 -- the same as the Rep value.
4426 return Char_Literal_Value (N);
4428 return Enumeration_Rep (Ent);
4431 -- Unchecked conversion, which can come from System'To_Address (X)
4432 -- where X is a static integer expression. Recursively evaluate X.
4434 elsif Kind = N_Unchecked_Type_Conversion then
4435 return Expr_Rep_Value (Expression (N));
4438 raise Program_Error;
4446 function Expr_Value (N : Node_Id) return Uint is
4447 Kind : constant Node_Kind := Nkind (N);
4448 CV_Ent : CV_Entry renames CV_Cache (Nat (N) mod CV_Cache_Size);
4453 -- If already in cache, then we know it's compile-time-known and we can
4454 -- return the value that was previously stored in the cache since
4455 -- compile-time-known values cannot change.
4457 if CV_Ent.N = N then
4461 -- Otherwise proceed to test value
4463 if Is_Entity_Name (N) then
4466 -- An enumeration literal that was either in the source or created as
4467 -- a result of static evaluation.
4469 if Ekind (Ent) = E_Enumeration_Literal then
4470 Val := Enumeration_Pos (Ent);
4472 -- A user defined static constant
4475 pragma Assert (Ekind (Ent) = E_Constant);
4476 Val := Expr_Value (Constant_Value (Ent));
4479 -- An integer literal that was either in the source or created as a
4480 -- result of static evaluation.
4482 elsif Kind = N_Integer_Literal then
4485 -- A real literal for a fixed-point type. This must be the fixed-point
4486 -- case, either the literal is of a fixed-point type, or it is a bound
4487 -- of a fixed-point type, with type universal real. In either case we
4488 -- obtain the desired value from Corresponding_Integer_Value.
4490 elsif Kind = N_Real_Literal then
4491 pragma Assert (Is_Fixed_Point_Type (Underlying_Type (Etype (N))));
4492 Val := Corresponding_Integer_Value (N);
4494 -- The NULL access value
4496 elsif Kind = N_Null then
4497 pragma Assert (Is_Access_Type (Underlying_Type (Etype (N)))
4498 or else Error_Posted (N));
4501 -- Character literal
4503 elsif Kind = N_Character_Literal then
4506 -- Since Character literals of type Standard.Character don't
4507 -- have any defining character literals built for them, they
4508 -- do not have their Entity set, so just use their Char
4509 -- code. Otherwise for user-defined character literals use
4510 -- their Pos value as usual.
4513 Val := Char_Literal_Value (N);
4515 Val := Enumeration_Pos (Ent);
4518 -- Unchecked conversion, which can come from System'To_Address (X)
4519 -- where X is a static integer expression. Recursively evaluate X.
4521 elsif Kind = N_Unchecked_Type_Conversion then
4522 Val := Expr_Value (Expression (N));
4525 raise Program_Error;
4528 -- Come here with Val set to value to be returned, set cache
4539 function Expr_Value_E (N : Node_Id) return Entity_Id is
4540 Ent : constant Entity_Id := Entity (N);
4542 if Ekind (Ent) = E_Enumeration_Literal then
4545 pragma Assert (Ekind (Ent) = E_Constant);
4547 -- We may be dealing with a enumerated character type constant, so
4548 -- handle that case here.
4550 if Nkind (Constant_Value (Ent)) = N_Character_Literal then
4553 return Expr_Value_E (Constant_Value (Ent));
4562 function Expr_Value_R (N : Node_Id) return Ureal is
4563 Kind : constant Node_Kind := Nkind (N);
4567 if Kind = N_Real_Literal then
4570 elsif Kind = N_Identifier or else Kind = N_Expanded_Name then
4572 pragma Assert (Ekind (Ent) = E_Constant);
4573 return Expr_Value_R (Constant_Value (Ent));
4575 elsif Kind = N_Integer_Literal then
4576 return UR_From_Uint (Expr_Value (N));
4578 -- Here, we have a node that cannot be interpreted as a compile time
4579 -- constant. That is definitely an error.
4582 raise Program_Error;
4590 function Expr_Value_S (N : Node_Id) return Node_Id is
4592 if Nkind (N) = N_String_Literal then
4595 pragma Assert (Ekind (Entity (N)) = E_Constant);
4596 return Expr_Value_S (Constant_Value (Entity (N)));
4600 ----------------------------------
4601 -- Find_Universal_Operator_Type --
4602 ----------------------------------
4604 function Find_Universal_Operator_Type (N : Node_Id) return Entity_Id is
4605 PN : constant Node_Id := Parent (N);
4606 Call : constant Node_Id := Original_Node (N);
4607 Is_Int : constant Boolean := Is_Integer_Type (Etype (N));
4609 Is_Fix : constant Boolean :=
4610 Nkind (N) in N_Binary_Op
4611 and then Nkind (Right_Opnd (N)) /= Nkind (Left_Opnd (N));
4612 -- A mixed-mode operation in this context indicates the presence of
4613 -- fixed-point type in the designated package.
4615 Is_Relational : constant Boolean := Etype (N) = Standard_Boolean;
4616 -- Case where N is a relational (or membership) operator (else it is an
4619 In_Membership : constant Boolean :=
4620 Nkind (PN) in N_Membership_Test
4622 Nkind (Right_Opnd (PN)) = N_Range
4624 Is_Universal_Numeric_Type (Etype (Left_Opnd (PN)))
4626 Is_Universal_Numeric_Type
4627 (Etype (Low_Bound (Right_Opnd (PN))))
4629 Is_Universal_Numeric_Type
4630 (Etype (High_Bound (Right_Opnd (PN))));
4631 -- Case where N is part of a membership test with a universal range
4635 Typ1 : Entity_Id := Empty;
4638 function Is_Mixed_Mode_Operand (Op : Node_Id) return Boolean;
4639 -- Check whether one operand is a mixed-mode operation that requires the
4640 -- presence of a fixed-point type. Given that all operands are universal
4641 -- and have been constant-folded, retrieve the original function call.
4643 ---------------------------
4644 -- Is_Mixed_Mode_Operand --
4645 ---------------------------
4647 function Is_Mixed_Mode_Operand (Op : Node_Id) return Boolean is
4648 Onod : constant Node_Id := Original_Node (Op);
4650 return Nkind (Onod) = N_Function_Call
4651 and then Present (Next_Actual (First_Actual (Onod)))
4652 and then Etype (First_Actual (Onod)) /=
4653 Etype (Next_Actual (First_Actual (Onod)));
4654 end Is_Mixed_Mode_Operand;
4656 -- Start of processing for Find_Universal_Operator_Type
4659 if Nkind (Call) /= N_Function_Call
4660 or else Nkind (Name (Call)) /= N_Expanded_Name
4664 -- There are several cases where the context does not imply the type of
4666 -- - the universal expression appears in a type conversion;
4667 -- - the expression is a relational operator applied to universal
4669 -- - the expression is a membership test with a universal operand
4670 -- and a range with universal bounds.
4672 elsif Nkind (Parent (N)) = N_Type_Conversion
4673 or else Is_Relational
4674 or else In_Membership
4676 Pack := Entity (Prefix (Name (Call)));
4678 -- If the prefix is a package declared elsewhere, iterate over its
4679 -- visible entities, otherwise iterate over all declarations in the
4680 -- designated scope.
4682 if Ekind (Pack) = E_Package
4683 and then not In_Open_Scopes (Pack)
4685 Priv_E := First_Private_Entity (Pack);
4691 E := First_Entity (Pack);
4692 while Present (E) and then E /= Priv_E loop
4693 if Is_Numeric_Type (E)
4694 and then Nkind (Parent (E)) /= N_Subtype_Declaration
4695 and then Comes_From_Source (E)
4696 and then Is_Integer_Type (E) = Is_Int
4697 and then (Nkind (N) in N_Unary_Op
4698 or else Is_Relational
4699 or else Is_Fixed_Point_Type (E) = Is_Fix)
4704 -- Before emitting an error, check for the presence of a
4705 -- mixed-mode operation that specifies a fixed point type.
4709 (Is_Mixed_Mode_Operand (Left_Opnd (N))
4710 or else Is_Mixed_Mode_Operand (Right_Opnd (N)))
4711 and then Is_Fixed_Point_Type (E) /= Is_Fixed_Point_Type (Typ1)
4714 if Is_Fixed_Point_Type (E) then
4719 -- More than one type of the proper class declared in P
4721 Error_Msg_N ("ambiguous operation", N);
4722 Error_Msg_Sloc := Sloc (Typ1);
4723 Error_Msg_N ("\possible interpretation (inherited)#", N);
4724 Error_Msg_Sloc := Sloc (E);
4725 Error_Msg_N ("\possible interpretation (inherited)#", N);
4735 end Find_Universal_Operator_Type;
4737 --------------------------
4738 -- Flag_Non_Static_Expr --
4739 --------------------------
4741 procedure Flag_Non_Static_Expr (Msg : String; Expr : Node_Id) is
4743 if Error_Posted (Expr) and then not All_Errors_Mode then
4746 Error_Msg_F (Msg, Expr);
4747 Why_Not_Static (Expr);
4749 end Flag_Non_Static_Expr;
4755 procedure Fold_Dummy (N : Node_Id; Typ : Entity_Id) is
4757 if Is_Integer_Type (Typ) then
4758 Fold_Uint (N, Uint_1, Static => True);
4760 elsif Is_Real_Type (Typ) then
4761 Fold_Ureal (N, Ureal_1, Static => True);
4763 elsif Is_Enumeration_Type (Typ) then
4766 Expr_Value (Type_Low_Bound (Base_Type (Typ))),
4769 elsif Is_String_Type (Typ) then
4772 Strval (Make_String_Literal (Sloc (N), "")),
4781 procedure Fold_Shift
4786 Static : Boolean := False;
4787 Check_Elab : Boolean := False)
4789 Typ : constant Entity_Id := Etype (Left);
4791 procedure Check_Elab_Call;
4792 -- Add checks related to calls in elaboration code
4794 ---------------------
4795 -- Check_Elab_Call --
4796 ---------------------
4798 procedure Check_Elab_Call is
4801 if Legacy_Elaboration_Checks then
4802 Check_Elab_Call (N);
4805 Build_Call_Marker (N);
4807 end Check_Elab_Call;
4810 if Compile_Time_Known_Value (Left)
4811 and then Compile_Time_Known_Value (Right)
4813 pragma Assert (not Non_Binary_Modulus (Typ));
4815 if Op = N_Op_Shift_Left then
4818 -- Fold Shift_Left (X, Y) by computing (X * 2**Y) rem modulus
4822 (Expr_Value (Left) * (Uint_2 ** Expr_Value (Right)))
4826 elsif Op = N_Op_Shift_Right then
4829 -- Fold Shift_Right (X, Y) by computing abs X / 2**Y
4833 abs Expr_Value (Left) / (Uint_2 ** Expr_Value (Right)),
4836 elsif Op = N_Op_Shift_Right_Arithmetic then
4840 Two_Y : constant Uint := Uint_2 ** Expr_Value (Right);
4843 if Is_Modular_Integer_Type (Typ) then
4844 Modulus := Einfo.Modulus (Typ);
4846 Modulus := Uint_2 ** RM_Size (Typ);
4849 -- X / 2**Y if X if positive or a small enough modular integer
4851 if (Is_Modular_Integer_Type (Typ)
4852 and then Expr_Value (Left) < Modulus / Uint_2)
4854 (not Is_Modular_Integer_Type (Typ)
4855 and then Expr_Value (Left) >= 0)
4857 Fold_Uint (N, Expr_Value (Left) / Two_Y, Static => Static);
4859 -- -1 (aka all 1's) if Y is larger than the number of bits
4860 -- available or if X = -1.
4862 elsif Two_Y > Modulus
4863 or else Expr_Value (Left) = Uint_Minus_1
4865 if Is_Modular_Integer_Type (Typ) then
4866 Fold_Uint (N, Modulus - Uint_1, Static => Static);
4868 Fold_Uint (N, Uint_Minus_1, Static => Static);
4871 -- Large modular integer, compute via multiply/divide the
4872 -- following: X >> Y + (1 << Y - 1) << (RM_Size - Y)
4874 elsif Is_Modular_Integer_Type (Typ) then
4877 (Expr_Value (Left)) / Two_Y
4879 * Uint_2 ** (RM_Size (Typ) - Expr_Value (Right)),
4882 -- Negative signed integer, compute via multiple/divide the
4884 -- (Modulus + X) >> Y + (1 << Y - 1) << (RM_Size - Y) - Modulus
4889 (Modulus + Expr_Value (Left)) / Two_Y
4891 * Uint_2 ** (RM_Size (Typ) - Expr_Value (Right))
4904 procedure Fold_Str (N : Node_Id; Val : String_Id; Static : Boolean) is
4905 Loc : constant Source_Ptr := Sloc (N);
4906 Typ : constant Entity_Id := Etype (N);
4909 if Raises_Constraint_Error (N) then
4910 Set_Is_Static_Expression (N, Static);
4914 Rewrite (N, Make_String_Literal (Loc, Strval => Val));
4916 -- We now have the literal with the right value, both the actual type
4917 -- and the expected type of this literal are taken from the expression
4918 -- that was evaluated. So now we do the Analyze and Resolve.
4920 -- Note that we have to reset Is_Static_Expression both after the
4921 -- analyze step (because Resolve will evaluate the literal, which
4922 -- will cause semantic errors if it is marked as static), and after
4923 -- the Resolve step (since Resolve in some cases resets this flag).
4926 Set_Is_Static_Expression (N, Static);
4929 Set_Is_Static_Expression (N, Static);
4936 procedure Fold_Uint (N : Node_Id; Val : Uint; Static : Boolean) is
4937 Loc : constant Source_Ptr := Sloc (N);
4938 Typ : Entity_Id := Etype (N);
4942 if Raises_Constraint_Error (N) then
4943 Set_Is_Static_Expression (N, Static);
4947 -- If we are folding a named number, retain the entity in the literal
4948 -- in the original tree.
4950 if Is_Entity_Name (N) and then Ekind (Entity (N)) = E_Named_Integer then
4956 if Is_Private_Type (Typ) then
4957 Typ := Full_View (Typ);
4960 -- For a result of type integer, substitute an N_Integer_Literal node
4961 -- for the result of the compile time evaluation of the expression.
4962 -- Set a link to the original named number when not in a generic context
4963 -- for reference in the original tree.
4965 if Is_Integer_Type (Typ) then
4966 Rewrite (N, Make_Integer_Literal (Loc, Val));
4967 Set_Original_Entity (N, Ent);
4969 -- Otherwise we have an enumeration type, and we substitute either
4970 -- an N_Identifier or N_Character_Literal to represent the enumeration
4971 -- literal corresponding to the given value, which must always be in
4972 -- range, because appropriate tests have already been made for this.
4974 else pragma Assert (Is_Enumeration_Type (Typ));
4975 Rewrite (N, Get_Enum_Lit_From_Pos (Etype (N), Val, Loc));
4978 -- We now have the literal with the right value, both the actual type
4979 -- and the expected type of this literal are taken from the expression
4980 -- that was evaluated. So now we do the Analyze and Resolve.
4982 -- Note that we have to reset Is_Static_Expression both after the
4983 -- analyze step (because Resolve will evaluate the literal, which
4984 -- will cause semantic errors if it is marked as static), and after
4985 -- the Resolve step (since Resolve in some cases sets this flag).
4988 Set_Is_Static_Expression (N, Static);
4991 Set_Is_Static_Expression (N, Static);
4998 procedure Fold_Ureal (N : Node_Id; Val : Ureal; Static : Boolean) is
4999 Loc : constant Source_Ptr := Sloc (N);
5000 Typ : constant Entity_Id := Etype (N);
5004 if Raises_Constraint_Error (N) then
5005 Set_Is_Static_Expression (N, Static);
5009 -- If we are folding a named number, retain the entity in the literal
5010 -- in the original tree.
5012 if Is_Entity_Name (N) and then Ekind (Entity (N)) = E_Named_Real then
5018 Rewrite (N, Make_Real_Literal (Loc, Realval => Val));
5020 -- Set link to original named number
5022 Set_Original_Entity (N, Ent);
5024 -- We now have the literal with the right value, both the actual type
5025 -- and the expected type of this literal are taken from the expression
5026 -- that was evaluated. So now we do the Analyze and Resolve.
5028 -- Note that we have to reset Is_Static_Expression both after the
5029 -- analyze step (because Resolve will evaluate the literal, which
5030 -- will cause semantic errors if it is marked as static), and after
5031 -- the Resolve step (since Resolve in some cases sets this flag).
5033 -- We mark the node as analyzed so that its type is not erased by
5034 -- calling Analyze_Real_Literal.
5037 Set_Is_Static_Expression (N, Static);
5041 Set_Is_Static_Expression (N, Static);
5048 function From_Bits (B : Bits; T : Entity_Id) return Uint is
5052 for J in 0 .. B'Last loop
5058 if Non_Binary_Modulus (T) then
5059 V := V mod Modulus (T);
5065 --------------------
5066 -- Get_String_Val --
5067 --------------------
5069 function Get_String_Val (N : Node_Id) return Node_Id is
5071 if Nkind (N) in N_String_Literal | N_Character_Literal then
5074 pragma Assert (Is_Entity_Name (N));
5075 return Get_String_Val (Constant_Value (Entity (N)));
5083 procedure Initialize is
5085 CV_Cache := (others => (Node_High_Bound, Uint_0));
5088 --------------------
5089 -- In_Subrange_Of --
5090 --------------------
5092 function In_Subrange_Of
5095 Fixed_Int : Boolean := False) return Boolean
5104 if T1 = T2 or else Is_Subtype_Of (T1, T2) then
5107 -- Never in range if both types are not scalar. Don't know if this can
5108 -- actually happen, but just in case.
5110 elsif not Is_Scalar_Type (T1) or else not Is_Scalar_Type (T2) then
5113 -- If T1 has infinities but T2 doesn't have infinities, then T1 is
5114 -- definitely not compatible with T2.
5116 elsif Is_Floating_Point_Type (T1)
5117 and then Has_Infinities (T1)
5118 and then Is_Floating_Point_Type (T2)
5119 and then not Has_Infinities (T2)
5124 L1 := Type_Low_Bound (T1);
5125 H1 := Type_High_Bound (T1);
5127 L2 := Type_Low_Bound (T2);
5128 H2 := Type_High_Bound (T2);
5130 -- Check bounds to see if comparison possible at compile time
5132 if Compile_Time_Compare (L1, L2, Assume_Valid => True) in Compare_GE
5134 Compile_Time_Compare (H1, H2, Assume_Valid => True) in Compare_LE
5139 -- If bounds not comparable at compile time, then the bounds of T2
5140 -- must be compile-time-known or we cannot answer the query.
5142 if not Compile_Time_Known_Value (L2)
5143 or else not Compile_Time_Known_Value (H2)
5148 -- If the bounds of T1 are know at compile time then use these
5149 -- ones, otherwise use the bounds of the base type (which are of
5150 -- course always static).
5152 if not Compile_Time_Known_Value (L1) then
5153 L1 := Type_Low_Bound (Base_Type (T1));
5156 if not Compile_Time_Known_Value (H1) then
5157 H1 := Type_High_Bound (Base_Type (T1));
5160 -- Fixed point types should be considered as such only if
5161 -- flag Fixed_Int is set to False.
5163 if Is_Floating_Point_Type (T1) or else Is_Floating_Point_Type (T2)
5164 or else (Is_Fixed_Point_Type (T1) and then not Fixed_Int)
5165 or else (Is_Fixed_Point_Type (T2) and then not Fixed_Int)
5168 Expr_Value_R (L2) <= Expr_Value_R (L1)
5170 Expr_Value_R (H2) >= Expr_Value_R (H1);
5174 Expr_Value (L2) <= Expr_Value (L1)
5176 Expr_Value (H2) >= Expr_Value (H1);
5181 -- If any exception occurs, it means that we have some bug in the compiler
5182 -- possibly triggered by a previous error, or by some unforeseen peculiar
5183 -- occurrence. However, this is only an optimization attempt, so there is
5184 -- really no point in crashing the compiler. Instead we just decide, too
5185 -- bad, we can't figure out the answer in this case after all.
5189 -- With debug flag K we will get an exception unless an error has
5190 -- already occurred (useful for debugging).
5192 if Debug_Flag_K then
5193 Check_Error_Detected;
5203 function Is_In_Range
5206 Assume_Valid : Boolean := False;
5207 Fixed_Int : Boolean := False;
5208 Int_Real : Boolean := False) return Boolean
5212 Test_In_Range (N, Typ, Assume_Valid, Fixed_Int, Int_Real) = In_Range;
5219 function Is_Null_Range (Lo : Node_Id; Hi : Node_Id) return Boolean is
5221 if Compile_Time_Known_Value (Lo)
5222 and then Compile_Time_Known_Value (Hi)
5225 Typ : Entity_Id := Etype (Lo);
5227 -- When called from the frontend, as part of the analysis of
5228 -- potentially static expressions, Typ will be the full view of a
5229 -- type with all the info needed to answer this query. When called
5230 -- from the backend, for example to know whether a range of a loop
5231 -- is null, Typ might be a private type and we need to explicitly
5232 -- switch to its corresponding full view to access the same info.
5234 if Is_Incomplete_Or_Private_Type (Typ)
5235 and then Present (Full_View (Typ))
5237 Typ := Full_View (Typ);
5240 if Is_Discrete_Type (Typ) then
5241 return Expr_Value (Lo) > Expr_Value (Hi);
5242 else pragma Assert (Is_Real_Type (Typ));
5243 return Expr_Value_R (Lo) > Expr_Value_R (Hi);
5251 -------------------------
5252 -- Is_OK_Static_Choice --
5253 -------------------------
5255 function Is_OK_Static_Choice (Choice : Node_Id) return Boolean is
5257 -- Check various possibilities for choice
5259 -- Note: for membership tests, we test more cases than are possible
5260 -- (in particular subtype indication), but it doesn't matter because
5261 -- it just won't occur (we have already done a syntax check).
5263 if Nkind (Choice) = N_Others_Choice then
5266 elsif Nkind (Choice) = N_Range then
5267 return Is_OK_Static_Range (Choice);
5269 elsif Nkind (Choice) = N_Subtype_Indication
5270 or else (Is_Entity_Name (Choice) and then Is_Type (Entity (Choice)))
5272 return Is_OK_Static_Subtype (Etype (Choice));
5275 return Is_OK_Static_Expression (Choice);
5277 end Is_OK_Static_Choice;
5279 ------------------------------
5280 -- Is_OK_Static_Choice_List --
5281 ------------------------------
5283 function Is_OK_Static_Choice_List (Choices : List_Id) return Boolean is
5287 if not Is_Static_Choice_List (Choices) then
5291 Choice := First (Choices);
5292 while Present (Choice) loop
5293 if not Is_OK_Static_Choice (Choice) then
5294 Set_Raises_Constraint_Error (Choice);
5302 end Is_OK_Static_Choice_List;
5304 -----------------------------
5305 -- Is_OK_Static_Expression --
5306 -----------------------------
5308 function Is_OK_Static_Expression (N : Node_Id) return Boolean is
5310 return Is_Static_Expression (N) and then not Raises_Constraint_Error (N);
5311 end Is_OK_Static_Expression;
5313 ------------------------
5314 -- Is_OK_Static_Range --
5315 ------------------------
5317 -- A static range is a range whose bounds are static expressions, or a
5318 -- Range_Attribute_Reference equivalent to such a range (RM 4.9(26)).
5319 -- We have already converted range attribute references, so we get the
5320 -- "or" part of this rule without needing a special test.
5322 function Is_OK_Static_Range (N : Node_Id) return Boolean is
5324 return Is_OK_Static_Expression (Low_Bound (N))
5325 and then Is_OK_Static_Expression (High_Bound (N));
5326 end Is_OK_Static_Range;
5328 --------------------------
5329 -- Is_OK_Static_Subtype --
5330 --------------------------
5332 -- Determines if Typ is a static subtype as defined in (RM 4.9(26)) where
5333 -- neither bound raises Constraint_Error when evaluated.
5335 function Is_OK_Static_Subtype (Typ : Entity_Id) return Boolean is
5336 Base_T : constant Entity_Id := Base_Type (Typ);
5337 Anc_Subt : Entity_Id;
5340 -- First a quick check on the non static subtype flag. As described
5341 -- in further detail in Einfo, this flag is not decisive in all cases,
5342 -- but if it is set, then the subtype is definitely non-static.
5344 if Is_Non_Static_Subtype (Typ) then
5348 Anc_Subt := Ancestor_Subtype (Typ);
5350 if Anc_Subt = Empty then
5354 if Is_Generic_Type (Root_Type (Base_T))
5355 or else Is_Generic_Actual_Type (Base_T)
5359 elsif Has_Dynamic_Predicate_Aspect (Typ) then
5364 elsif Is_String_Type (Typ) then
5366 Ekind (Typ) = E_String_Literal_Subtype
5368 (Is_OK_Static_Subtype (Component_Type (Typ))
5369 and then Is_OK_Static_Subtype (Etype (First_Index (Typ))));
5373 elsif Is_Scalar_Type (Typ) then
5374 if Base_T = Typ then
5378 -- Scalar_Range (Typ) might be an N_Subtype_Indication, so use
5379 -- Get_Type_{Low,High}_Bound.
5381 return Is_OK_Static_Subtype (Anc_Subt)
5382 and then Is_OK_Static_Expression (Type_Low_Bound (Typ))
5383 and then Is_OK_Static_Expression (Type_High_Bound (Typ));
5386 -- Types other than string and scalar types are never static
5391 end Is_OK_Static_Subtype;
5393 ---------------------
5394 -- Is_Out_Of_Range --
5395 ---------------------
5397 function Is_Out_Of_Range
5400 Assume_Valid : Boolean := False;
5401 Fixed_Int : Boolean := False;
5402 Int_Real : Boolean := False) return Boolean
5405 return Test_In_Range (N, Typ, Assume_Valid, Fixed_Int, Int_Real) =
5407 end Is_Out_Of_Range;
5409 ----------------------
5410 -- Is_Static_Choice --
5411 ----------------------
5413 function Is_Static_Choice (Choice : Node_Id) return Boolean is
5415 -- Check various possibilities for choice
5417 -- Note: for membership tests, we test more cases than are possible
5418 -- (in particular subtype indication), but it doesn't matter because
5419 -- it just won't occur (we have already done a syntax check).
5421 if Nkind (Choice) = N_Others_Choice then
5424 elsif Nkind (Choice) = N_Range then
5425 return Is_Static_Range (Choice);
5427 elsif Nkind (Choice) = N_Subtype_Indication
5428 or else (Is_Entity_Name (Choice) and then Is_Type (Entity (Choice)))
5430 return Is_Static_Subtype (Etype (Choice));
5433 return Is_Static_Expression (Choice);
5435 end Is_Static_Choice;
5437 ---------------------------
5438 -- Is_Static_Choice_List --
5439 ---------------------------
5441 function Is_Static_Choice_List (Choices : List_Id) return Boolean is
5445 Choice := First (Choices);
5446 while Present (Choice) loop
5447 if not Is_Static_Choice (Choice) then
5455 end Is_Static_Choice_List;
5457 ---------------------
5458 -- Is_Static_Range --
5459 ---------------------
5461 -- A static range is a range whose bounds are static expressions, or a
5462 -- Range_Attribute_Reference equivalent to such a range (RM 4.9(26)).
5463 -- We have already converted range attribute references, so we get the
5464 -- "or" part of this rule without needing a special test.
5466 function Is_Static_Range (N : Node_Id) return Boolean is
5468 return Is_Static_Expression (Low_Bound (N))
5470 Is_Static_Expression (High_Bound (N));
5471 end Is_Static_Range;
5473 -----------------------
5474 -- Is_Static_Subtype --
5475 -----------------------
5477 -- Determines if Typ is a static subtype as defined in (RM 4.9(26))
5479 function Is_Static_Subtype (Typ : Entity_Id) return Boolean is
5480 Base_T : constant Entity_Id := Base_Type (Typ);
5481 Anc_Subt : Entity_Id;
5484 -- First a quick check on the non static subtype flag. As described
5485 -- in further detail in Einfo, this flag is not decisive in all cases,
5486 -- but if it is set, then the subtype is definitely non-static.
5488 if Is_Non_Static_Subtype (Typ) then
5492 Anc_Subt := Ancestor_Subtype (Typ);
5494 if Anc_Subt = Empty then
5498 if Is_Generic_Type (Root_Type (Base_T))
5499 or else Is_Generic_Actual_Type (Base_T)
5503 -- If there is a dynamic predicate for the type (declared or inherited)
5504 -- the expression is not static.
5506 elsif Has_Dynamic_Predicate_Aspect (Typ)
5507 or else (Is_Derived_Type (Typ)
5508 and then Has_Aspect (Typ, Aspect_Dynamic_Predicate))
5514 elsif Is_String_Type (Typ) then
5516 Ekind (Typ) = E_String_Literal_Subtype
5517 or else (Is_Static_Subtype (Component_Type (Typ))
5518 and then Is_Static_Subtype (Etype (First_Index (Typ))));
5522 elsif Is_Scalar_Type (Typ) then
5523 if Base_T = Typ then
5527 return Is_Static_Subtype (Anc_Subt)
5528 and then Is_Static_Expression (Type_Low_Bound (Typ))
5529 and then Is_Static_Expression (Type_High_Bound (Typ));
5532 -- Types other than string and scalar types are never static
5537 end Is_Static_Subtype;
5539 -------------------------------
5540 -- Is_Statically_Unevaluated --
5541 -------------------------------
5543 function Is_Statically_Unevaluated (Expr : Node_Id) return Boolean is
5544 function Check_Case_Expr_Alternative
5545 (CEA : Node_Id) return Match_Result;
5546 -- We have a message emanating from the Expression of a case expression
5547 -- alternative. We examine this alternative, as follows:
5549 -- If the selecting expression of the parent case is non-static, or
5550 -- if any of the discrete choices of the given case alternative are
5551 -- non-static or raise Constraint_Error, return Non_Static.
5553 -- Otherwise check if the selecting expression matches any of the given
5554 -- discrete choices. If so, the alternative is executed and we return
5555 -- Match, otherwise, the alternative can never be executed, and so we
5558 ---------------------------------
5559 -- Check_Case_Expr_Alternative --
5560 ---------------------------------
5562 function Check_Case_Expr_Alternative
5563 (CEA : Node_Id) return Match_Result
5565 Case_Exp : constant Node_Id := Parent (CEA);
5570 pragma Assert (Nkind (Case_Exp) = N_Case_Expression);
5572 -- Check that selecting expression is static
5574 if not Is_OK_Static_Expression (Expression (Case_Exp)) then
5578 if not Is_OK_Static_Choice_List (Discrete_Choices (CEA)) then
5582 -- All choices are now known to be static. Now see if alternative
5583 -- matches one of the choices.
5585 Choice := First (Discrete_Choices (CEA));
5586 while Present (Choice) loop
5588 -- Check various possibilities for choice, returning Match if we
5589 -- find the selecting value matches any of the choices. Note that
5590 -- we know we are the last choice, so we don't have to keep going.
5592 if Nkind (Choice) = N_Others_Choice then
5594 -- Others choice is a bit annoying, it matches if none of the
5595 -- previous alternatives matches (note that we know we are the
5596 -- last alternative in this case, so we can just go backwards
5597 -- from us to see if any previous one matches).
5599 Prev_CEA := Prev (CEA);
5600 while Present (Prev_CEA) loop
5601 if Check_Case_Expr_Alternative (Prev_CEA) = Match then
5610 -- Else we have a normal static choice
5612 elsif Choice_Matches (Expression (Case_Exp), Choice) = Match then
5616 -- If we fall through, it means that the discrete choice did not
5617 -- match the selecting expression, so continue.
5622 -- If we get through that loop then all choices were static, and none
5623 -- of them matched the selecting expression. So return No_Match.
5626 end Check_Case_Expr_Alternative;
5634 -- Start of processing for Is_Statically_Unevaluated
5637 -- The (32.x) references here are from RM section 4.9
5639 -- (32.1) An expression is statically unevaluated if it is part of ...
5641 -- This means we have to climb the tree looking for one of the cases
5648 -- (32.2) The right operand of a static short-circuit control form
5649 -- whose value is determined by its left operand.
5651 -- AND THEN with False as left operand
5653 if Nkind (P) = N_And_Then
5654 and then Compile_Time_Known_Value (Left_Opnd (P))
5655 and then Is_False (Expr_Value (Left_Opnd (P)))
5659 -- OR ELSE with True as left operand
5661 elsif Nkind (P) = N_Or_Else
5662 and then Compile_Time_Known_Value (Left_Opnd (P))
5663 and then Is_True (Expr_Value (Left_Opnd (P)))
5667 -- (32.3) A dependent_expression of an if_expression whose associated
5668 -- condition is static and equals False.
5670 elsif Nkind (P) = N_If_Expression then
5672 Cond : constant Node_Id := First (Expressions (P));
5673 Texp : constant Node_Id := Next (Cond);
5674 Fexp : constant Node_Id := Next (Texp);
5677 if Compile_Time_Known_Value (Cond) then
5679 -- Condition is True and we are in the right operand
5681 if Is_True (Expr_Value (Cond)) and then OldP = Fexp then
5684 -- Condition is False and we are in the left operand
5686 elsif Is_False (Expr_Value (Cond)) and then OldP = Texp then
5692 -- (32.4) A condition or dependent_expression of an if_expression
5693 -- where the condition corresponding to at least one preceding
5694 -- dependent_expression of the if_expression is static and equals
5697 -- This refers to cases like
5699 -- (if True then 1 elsif 1/0=2 then 2 else 3)
5701 -- But we expand elsif's out anyway, so the above looks like:
5703 -- (if True then 1 else (if 1/0=2 then 2 else 3))
5705 -- So for us this is caught by the above check for the 32.3 case.
5707 -- (32.5) A dependent_expression of a case_expression whose
5708 -- selecting_expression is static and whose value is not covered
5709 -- by the corresponding discrete_choice_list.
5711 elsif Nkind (P) = N_Case_Expression_Alternative then
5713 -- First, we have to be in the expression to suppress messages.
5714 -- If we are within one of the choices, we want the message.
5716 if OldP = Expression (P) then
5718 -- Statically unevaluated if alternative does not match
5720 if Check_Case_Expr_Alternative (P) = No_Match then
5725 -- (32.6) A choice_expression (or a simple_expression of a range
5726 -- that occurs as a membership_choice of a membership_choice_list)
5727 -- of a static membership test that is preceded in the enclosing
5728 -- membership_choice_list by another item whose individual
5729 -- membership test (see (RM 4.5.2)) statically yields True.
5731 elsif Nkind (P) in N_Membership_Test then
5733 -- Only possibly unevaluated if simple expression is static
5735 if not Is_OK_Static_Expression (Left_Opnd (P)) then
5738 -- All members of the choice list must be static
5740 elsif (Present (Right_Opnd (P))
5741 and then not Is_OK_Static_Choice (Right_Opnd (P)))
5742 or else (Present (Alternatives (P))
5744 not Is_OK_Static_Choice_List (Alternatives (P)))
5748 -- If expression is the one and only alternative, then it is
5749 -- definitely not statically unevaluated, so we only have to
5750 -- test the case where there are alternatives present.
5752 elsif Present (Alternatives (P)) then
5754 -- Look for previous matching Choice
5756 Choice := First (Alternatives (P));
5757 while Present (Choice) loop
5759 -- If we reached us and no previous choices matched, this
5760 -- is not the case where we are statically unevaluated.
5762 exit when OldP = Choice;
5764 -- If a previous choice matches, then that is the case where
5765 -- we know our choice is statically unevaluated.
5767 if Choice_Matches (Left_Opnd (P), Choice) = Match then
5774 -- If we fall through the loop, we were not one of the choices,
5775 -- we must have been the expression, so that is not covered by
5776 -- this rule, and we keep going.
5782 -- OK, not statically unevaluated at this level, see if we should
5783 -- keep climbing to look for a higher level reason.
5785 -- Special case for component association in aggregates, where
5786 -- we want to keep climbing up to the parent aggregate.
5788 if Nkind (P) = N_Component_Association
5789 and then Nkind (Parent (P)) = N_Aggregate
5793 -- All done if not still within subexpression
5796 exit when Nkind (P) not in N_Subexpr;
5800 -- If we fall through the loop, not one of the cases covered!
5803 end Is_Statically_Unevaluated;
5805 --------------------
5806 -- Not_Null_Range --
5807 --------------------
5809 function Not_Null_Range (Lo : Node_Id; Hi : Node_Id) return Boolean is
5811 if Compile_Time_Known_Value (Lo)
5812 and then Compile_Time_Known_Value (Hi)
5815 Typ : Entity_Id := Etype (Lo);
5817 -- When called from the frontend, as part of the analysis of
5818 -- potentially static expressions, Typ will be the full view of a
5819 -- type with all the info needed to answer this query. When called
5820 -- from the backend, for example to know whether a range of a loop
5821 -- is null, Typ might be a private type and we need to explicitly
5822 -- switch to its corresponding full view to access the same info.
5824 if Is_Incomplete_Or_Private_Type (Typ)
5825 and then Present (Full_View (Typ))
5827 Typ := Full_View (Typ);
5830 if Is_Discrete_Type (Typ) then
5831 return Expr_Value (Lo) <= Expr_Value (Hi);
5832 else pragma Assert (Is_Real_Type (Typ));
5833 return Expr_Value_R (Lo) <= Expr_Value_R (Hi);
5846 function OK_Bits (N : Node_Id; Bits : Uint) return Boolean is
5848 -- We allow a maximum of 500,000 bits which seems a reasonable limit
5850 if Bits < 500_000 then
5853 -- Error if this maximum is exceeded
5856 Error_Msg_N ("static value too large, capacity exceeded", N);
5865 procedure Out_Of_Range (N : Node_Id) is
5867 -- If we have the static expression case, then this is an illegality
5868 -- in Ada 95 mode, except that in an instance, we never generate an
5869 -- error (if the error is legitimate, it was already diagnosed in the
5872 if Is_Static_Expression (N)
5873 and then not In_Instance
5874 and then not In_Inlined_Body
5875 and then Ada_Version >= Ada_95
5877 -- No message if we are statically unevaluated
5879 if Is_Statically_Unevaluated (N) then
5882 -- The expression to compute the length of a packed array is attached
5883 -- to the array type itself, and deserves a separate message.
5885 elsif Nkind (Parent (N)) = N_Defining_Identifier
5886 and then Is_Array_Type (Parent (N))
5887 and then Present (Packed_Array_Impl_Type (Parent (N)))
5888 and then Present (First_Rep_Item (Parent (N)))
5891 ("length of packed array must not exceed Integer''Last",
5892 First_Rep_Item (Parent (N)));
5893 Rewrite (N, Make_Integer_Literal (Sloc (N), Uint_1));
5895 -- All cases except the special array case.
5896 -- No message if we are dealing with System.Priority values in
5897 -- CodePeer mode where the target runtime may have more priorities.
5899 elsif not CodePeer_Mode or else Etype (N) /= RTE (RE_Priority) then
5900 -- Determine if the out-of-range violation constitutes a warning
5901 -- or an error based on context, according to RM 4.9 (34/3).
5903 if Nkind (Original_Node (N)) = N_Type_Conversion
5904 and then not Comes_From_Source (Original_Node (N))
5906 Apply_Compile_Time_Constraint_Error
5907 (N, "value not in range of}??", CE_Range_Check_Failed);
5909 Apply_Compile_Time_Constraint_Error
5910 (N, "value not in range of}", CE_Range_Check_Failed);
5914 -- Here we generate a warning for the Ada 83 case, or when we are in an
5915 -- instance, or when we have a non-static expression case.
5918 Apply_Compile_Time_Constraint_Error
5919 (N, "value not in range of}??", CE_Range_Check_Failed);
5923 ---------------------------
5924 -- Predicates_Compatible --
5925 ---------------------------
5927 function Predicates_Compatible (T1, T2 : Entity_Id) return Boolean is
5929 function T2_Rep_Item_Applies_To_T1 (Nam : Name_Id) return Boolean;
5930 -- Return True if the rep item for Nam is either absent on T2 or also
5933 -------------------------------
5934 -- T2_Rep_Item_Applies_To_T1 --
5935 -------------------------------
5937 function T2_Rep_Item_Applies_To_T1 (Nam : Name_Id) return Boolean is
5938 Rep_Item : constant Node_Id := Get_Rep_Item (T2, Nam);
5941 return No (Rep_Item) or else Get_Rep_Item (T1, Nam) = Rep_Item;
5942 end T2_Rep_Item_Applies_To_T1;
5944 -- Start of processing for Predicates_Compatible
5947 if Ada_Version < Ada_2012 then
5950 -- If T2 has no predicates, there is no compatibility issue
5952 elsif not Has_Predicates (T2) then
5955 -- T2 has predicates, if T1 has none then we defer to the static check
5957 elsif not Has_Predicates (T1) then
5960 -- Both T2 and T1 have predicates, check that all predicates that apply
5961 -- to T2 apply also to T1 (RM 4.9.1(9/3)).
5963 elsif T2_Rep_Item_Applies_To_T1 (Name_Static_Predicate)
5964 and then T2_Rep_Item_Applies_To_T1 (Name_Dynamic_Predicate)
5965 and then T2_Rep_Item_Applies_To_T1 (Name_Predicate)
5970 -- Implement the static check prescribed by RM 4.9.1(10/3)
5972 if Is_Static_Subtype (T1) and then Is_Static_Subtype (T2) then
5973 -- We just need to query Interval_Lists for discrete types
5975 if Is_Discrete_Type (T1) and then Is_Discrete_Type (T2) then
5977 Interval_List1 : constant Interval_Lists.Discrete_Interval_List
5978 := Interval_Lists.Type_Intervals (T1);
5979 Interval_List2 : constant Interval_Lists.Discrete_Interval_List
5980 := Interval_Lists.Type_Intervals (T2);
5982 return Interval_Lists.Is_Subset (Interval_List1, Interval_List2)
5983 and then not (Has_Predicates (T1)
5984 and then not Predicate_Checks_Suppressed (T2)
5985 and then Predicate_Checks_Suppressed (T1));
5989 -- TBD: Implement Interval_Lists for real types
5994 -- If either subtype is not static, the predicates are not compatible
5999 end Predicates_Compatible;
6001 ----------------------
6002 -- Predicates_Match --
6003 ----------------------
6005 function Predicates_Match (T1, T2 : Entity_Id) return Boolean is
6007 function Have_Same_Rep_Item (Nam : Name_Id) return Boolean;
6008 -- Return True if T1 and T2 have the same rep item for Nam
6010 ------------------------
6011 -- Have_Same_Rep_Item --
6012 ------------------------
6014 function Have_Same_Rep_Item (Nam : Name_Id) return Boolean is
6016 return Get_Rep_Item (T1, Nam) = Get_Rep_Item (T2, Nam);
6017 end Have_Same_Rep_Item;
6019 -- Start of processing for Predicates_Match
6022 if Ada_Version < Ada_2012 then
6025 -- If T2 has no predicates, match if and only if T1 has none
6027 elsif not Has_Predicates (T2) then
6028 return not Has_Predicates (T1);
6030 -- T2 has predicates, no match if T1 has none
6032 elsif not Has_Predicates (T1) then
6035 -- Both T2 and T1 have predicates, check that they all come
6036 -- from the same declarations.
6039 return Have_Same_Rep_Item (Name_Static_Predicate)
6040 and then Have_Same_Rep_Item (Name_Dynamic_Predicate)
6041 and then Have_Same_Rep_Item (Name_Predicate);
6043 end Predicates_Match;
6045 ---------------------------------------------
6046 -- Real_Or_String_Static_Predicate_Matches --
6047 ---------------------------------------------
6049 function Real_Or_String_Static_Predicate_Matches
6051 Typ : Entity_Id) return Boolean
6053 Expr : constant Node_Id := Static_Real_Or_String_Predicate (Typ);
6054 -- The predicate expression from the type
6056 Pfun : constant Entity_Id := Predicate_Function (Typ);
6057 -- The entity for the predicate function
6059 Ent_Name : constant Name_Id := Chars (First_Formal (Pfun));
6060 -- The name of the formal of the predicate function. Occurrences of the
6061 -- type name in Expr have been rewritten as references to this formal,
6062 -- and it has a unique name, so we can identify references by this name.
6065 -- Copy of the predicate function tree
6067 function Process (N : Node_Id) return Traverse_Result;
6068 -- Function used to process nodes during the traversal in which we will
6069 -- find occurrences of the entity name, and replace such occurrences
6070 -- by a real literal with the value to be tested.
6072 procedure Traverse is new Traverse_Proc (Process);
6073 -- The actual traversal procedure
6079 function Process (N : Node_Id) return Traverse_Result is
6081 if Nkind (N) = N_Identifier and then Chars (N) = Ent_Name then
6083 Nod : constant Node_Id := New_Copy (Val);
6085 Set_Sloc (Nod, Sloc (N));
6090 -- The predicate function may contain string-comparison operations
6091 -- that have been converted into calls to run-time array-comparison
6092 -- routines. To evaluate the predicate statically, we recover the
6093 -- original comparison operation and replace the occurrence of the
6094 -- formal by the static string value. The actuals of the generated
6095 -- call are of the form X'Address.
6097 elsif Nkind (N) in N_Op_Compare
6098 and then Nkind (Left_Opnd (N)) = N_Function_Call
6101 C : constant Node_Id := Left_Opnd (N);
6102 F : constant Node_Id := First (Parameter_Associations (C));
6103 L : constant Node_Id := Prefix (F);
6104 R : constant Node_Id := Prefix (Next (F));
6107 -- If an operand is an entity name, it is the formal of the
6108 -- predicate function, so replace it with the string value.
6109 -- It may be either operand in the call. The other operand
6110 -- is a static string from the original predicate.
6112 if Is_Entity_Name (L) then
6113 Rewrite (Left_Opnd (N), New_Copy (Val));
6114 Rewrite (Right_Opnd (N), New_Copy (R));
6117 Rewrite (Left_Opnd (N), New_Copy (L));
6118 Rewrite (Right_Opnd (N), New_Copy (Val));
6129 -- Start of processing for Real_Or_String_Static_Predicate_Matches
6132 -- First deal with special case of inherited predicate, where the
6133 -- predicate expression looks like:
6135 -- xxPredicate (typ (Ent)) and then Expr
6137 -- where Expr is the predicate expression for this level, and the
6138 -- left operand is the call to evaluate the inherited predicate.
6140 if Nkind (Expr) = N_And_Then
6141 and then Nkind (Left_Opnd (Expr)) = N_Function_Call
6142 and then Is_Predicate_Function (Entity (Name (Left_Opnd (Expr))))
6144 -- OK we have the inherited case, so make a call to evaluate the
6145 -- inherited predicate. If that fails, so do we!
6148 Real_Or_String_Static_Predicate_Matches
6150 Typ => Etype (First_Formal (Entity (Name (Left_Opnd (Expr))))))
6155 -- Use the right operand for the continued processing
6157 Copy := Copy_Separate_Tree (Right_Opnd (Expr));
6159 -- Case where call to predicate function appears on its own (this means
6160 -- that the predicate at this level is just inherited from the parent).
6162 elsif Nkind (Expr) = N_Function_Call then
6164 Typ : constant Entity_Id :=
6165 Etype (First_Formal (Entity (Name (Expr))));
6168 -- If the inherited predicate is dynamic, just ignore it. We can't
6169 -- go trying to evaluate a dynamic predicate as a static one!
6171 if Has_Dynamic_Predicate_Aspect (Typ) then
6174 -- Otherwise inherited predicate is static, check for match
6177 return Real_Or_String_Static_Predicate_Matches (Val, Typ);
6181 -- If not just an inherited predicate, copy whole expression
6184 Copy := Copy_Separate_Tree (Expr);
6187 -- Now we replace occurrences of the entity by the value
6191 -- And analyze the resulting static expression to see if it is True
6193 Analyze_And_Resolve (Copy, Standard_Boolean);
6194 return Is_True (Expr_Value (Copy));
6195 end Real_Or_String_Static_Predicate_Matches;
6197 -------------------------
6198 -- Rewrite_In_Raise_CE --
6199 -------------------------
6201 procedure Rewrite_In_Raise_CE (N : Node_Id; Exp : Node_Id) is
6202 Stat : constant Boolean := Is_Static_Expression (N);
6203 Typ : constant Entity_Id := Etype (N);
6206 -- If we want to raise CE in the condition of a N_Raise_CE node, we
6207 -- can just clear the condition if the reason is appropriate. We do
6208 -- not do this operation if the parent has a reason other than range
6209 -- check failed, because otherwise we would change the reason.
6211 if Present (Parent (N))
6212 and then Nkind (Parent (N)) = N_Raise_Constraint_Error
6213 and then Reason (Parent (N)) =
6214 UI_From_Int (RT_Exception_Code'Pos (CE_Range_Check_Failed))
6216 Set_Condition (Parent (N), Empty);
6218 -- Else build an explicit N_Raise_CE
6221 if Nkind (Exp) = N_Raise_Constraint_Error then
6223 Make_Raise_Constraint_Error (Sloc (Exp),
6224 Reason => Reason (Exp)));
6227 Make_Raise_Constraint_Error (Sloc (Exp),
6228 Reason => CE_Range_Check_Failed));
6231 Set_Raises_Constraint_Error (N);
6235 -- Set proper flags in result
6237 Set_Raises_Constraint_Error (N, True);
6238 Set_Is_Static_Expression (N, Stat);
6239 end Rewrite_In_Raise_CE;
6241 ------------------------------------------------
6242 -- Set_Checking_Potentially_Static_Expression --
6243 ------------------------------------------------
6245 procedure Set_Checking_Potentially_Static_Expression (Value : Boolean) is
6247 -- Verify that we're not currently checking for a potentially static
6248 -- expression unless we're disabling such checking.
6251 (not Checking_For_Potentially_Static_Expression or else not Value);
6253 Checking_For_Potentially_Static_Expression := Value;
6254 end Set_Checking_Potentially_Static_Expression;
6256 ---------------------
6257 -- String_Type_Len --
6258 ---------------------
6260 function String_Type_Len (Stype : Entity_Id) return Uint is
6261 NT : constant Entity_Id := Etype (First_Index (Stype));
6265 if Is_OK_Static_Subtype (NT) then
6268 T := Base_Type (NT);
6271 return Expr_Value (Type_High_Bound (T)) -
6272 Expr_Value (Type_Low_Bound (T)) + 1;
6273 end String_Type_Len;
6275 ------------------------------------
6276 -- Subtypes_Statically_Compatible --
6277 ------------------------------------
6279 function Subtypes_Statically_Compatible
6282 Formal_Derived_Matching : Boolean := False) return Boolean
6285 -- A type is always statically compatible with itself
6290 -- Not compatible if predicates are not compatible
6292 elsif not Predicates_Compatible (T1, T2) then
6297 elsif Is_Scalar_Type (T1) then
6299 -- Definitely compatible if we match
6301 if Subtypes_Statically_Match (T1, T2) then
6304 -- If either subtype is nonstatic then they're not compatible
6306 elsif not Is_OK_Static_Subtype (T1)
6308 not Is_OK_Static_Subtype (T2)
6312 -- Base types must match, but we don't check that (should we???) but
6313 -- we do at least check that both types are real, or both types are
6316 elsif Is_Real_Type (T1) /= Is_Real_Type (T2) then
6319 -- Here we check the bounds
6323 LB1 : constant Node_Id := Type_Low_Bound (T1);
6324 HB1 : constant Node_Id := Type_High_Bound (T1);
6325 LB2 : constant Node_Id := Type_Low_Bound (T2);
6326 HB2 : constant Node_Id := Type_High_Bound (T2);
6329 if Is_Real_Type (T1) then
6331 Expr_Value_R (LB1) > Expr_Value_R (HB1)
6333 (Expr_Value_R (LB2) <= Expr_Value_R (LB1)
6334 and then Expr_Value_R (HB1) <= Expr_Value_R (HB2));
6338 Expr_Value (LB1) > Expr_Value (HB1)
6340 (Expr_Value (LB2) <= Expr_Value (LB1)
6341 and then Expr_Value (HB1) <= Expr_Value (HB2));
6348 elsif Is_Access_Type (T1) then
6350 (not Is_Constrained (T2)
6351 or else Subtypes_Statically_Match
6352 (Designated_Type (T1), Designated_Type (T2)))
6353 and then not (Can_Never_Be_Null (T2)
6354 and then not Can_Never_Be_Null (T1));
6360 (Is_Composite_Type (T1) and then not Is_Constrained (T2))
6361 or else Subtypes_Statically_Match
6362 (T1, T2, Formal_Derived_Matching);
6364 end Subtypes_Statically_Compatible;
6366 -------------------------------
6367 -- Subtypes_Statically_Match --
6368 -------------------------------
6370 -- Subtypes statically match if they have statically matching constraints
6371 -- (RM 4.9.1(2)). Constraints statically match if there are none, or if
6372 -- they are the same identical constraint, or if they are static and the
6373 -- values match (RM 4.9.1(1)).
6375 -- In addition, in GNAT, the object size (Esize) values of the types must
6376 -- match if they are set (unless checking an actual for a formal derived
6377 -- type). The use of 'Object_Size can cause this to be false even if the
6378 -- types would otherwise match in the Ada 95 RM sense, but this deviation
6379 -- is adopted by AI12-059 which introduces Object_Size in Ada 2020.
6381 function Subtypes_Statically_Match
6384 Formal_Derived_Matching : Boolean := False) return Boolean
6387 -- A type always statically matches itself
6392 -- No match if sizes different (from use of 'Object_Size). This test
6393 -- is excluded if Formal_Derived_Matching is True, as the base types
6394 -- can be different in that case and typically have different sizes.
6396 elsif not Formal_Derived_Matching
6397 and then Known_Static_Esize (T1)
6398 and then Known_Static_Esize (T2)
6399 and then Esize (T1) /= Esize (T2)
6403 -- No match if predicates do not match
6405 elsif not Predicates_Match (T1, T2) then
6410 elsif Is_Scalar_Type (T1) then
6412 -- Base types must be the same
6414 if Base_Type (T1) /= Base_Type (T2) then
6418 -- A constrained numeric subtype never matches an unconstrained
6419 -- subtype, i.e. both types must be constrained or unconstrained.
6421 -- To understand the requirement for this test, see RM 4.9.1(1).
6422 -- As is made clear in RM 3.5.4(11), type Integer, for example is
6423 -- a constrained subtype with constraint bounds matching the bounds
6424 -- of its corresponding unconstrained base type. In this situation,
6425 -- Integer and Integer'Base do not statically match, even though
6426 -- they have the same bounds.
6428 -- We only apply this test to types in Standard and types that appear
6429 -- in user programs. That way, we do not have to be too careful about
6430 -- setting Is_Constrained right for Itypes.
6432 if Is_Numeric_Type (T1)
6433 and then (Is_Constrained (T1) /= Is_Constrained (T2))
6434 and then (Scope (T1) = Standard_Standard
6435 or else Comes_From_Source (T1))
6436 and then (Scope (T2) = Standard_Standard
6437 or else Comes_From_Source (T2))
6441 -- A generic scalar type does not statically match its base type
6442 -- (AI-311). In this case we make sure that the formals, which are
6443 -- first subtypes of their bases, are constrained.
6445 elsif Is_Generic_Type (T1)
6446 and then Is_Generic_Type (T2)
6447 and then (Is_Constrained (T1) /= Is_Constrained (T2))
6452 -- If there was an error in either range, then just assume the types
6453 -- statically match to avoid further junk errors.
6455 if No (Scalar_Range (T1)) or else No (Scalar_Range (T2))
6456 or else Error_Posted (Scalar_Range (T1))
6457 or else Error_Posted (Scalar_Range (T2))
6462 -- Otherwise both types have bounds that can be compared
6465 LB1 : constant Node_Id := Type_Low_Bound (T1);
6466 HB1 : constant Node_Id := Type_High_Bound (T1);
6467 LB2 : constant Node_Id := Type_Low_Bound (T2);
6468 HB2 : constant Node_Id := Type_High_Bound (T2);
6471 -- If the bounds are the same tree node, then match (common case)
6473 if LB1 = LB2 and then HB1 = HB2 then
6476 -- Otherwise bounds must be static and identical value
6479 if not Is_OK_Static_Subtype (T1)
6481 not Is_OK_Static_Subtype (T2)
6485 elsif Is_Real_Type (T1) then
6487 Expr_Value_R (LB1) = Expr_Value_R (LB2)
6489 Expr_Value_R (HB1) = Expr_Value_R (HB2);
6493 Expr_Value (LB1) = Expr_Value (LB2)
6495 Expr_Value (HB1) = Expr_Value (HB2);
6500 -- Type with discriminants
6502 elsif Has_Discriminants (T1) or else Has_Discriminants (T2) then
6504 -- Handle derivations of private subtypes. For example S1 statically
6505 -- matches the full view of T1 in the following example:
6507 -- type T1(<>) is new Root with private;
6508 -- subtype S1 is new T1;
6509 -- overriding proc P1 (P : S1);
6511 -- type T1 (D : Disc) is new Root with ...
6513 if Ekind (T2) = E_Record_Subtype_With_Private
6514 and then not Has_Discriminants (T2)
6515 and then Partial_View_Has_Unknown_Discr (T1)
6516 and then Etype (T2) = T1
6520 elsif Ekind (T1) = E_Record_Subtype_With_Private
6521 and then not Has_Discriminants (T1)
6522 and then Partial_View_Has_Unknown_Discr (T2)
6523 and then Etype (T1) = T2
6527 -- Because of view exchanges in multiple instantiations, conformance
6528 -- checking might try to match a partial view of a type with no
6529 -- discriminants with a full view that has defaulted discriminants.
6530 -- In such a case, use the discriminant constraint of the full view,
6531 -- which must exist because we know that the two subtypes have the
6534 elsif Has_Discriminants (T1) /= Has_Discriminants (T2) then
6536 if Is_Private_Type (T2)
6537 and then Present (Full_View (T2))
6538 and then Has_Discriminants (Full_View (T2))
6540 return Subtypes_Statically_Match (T1, Full_View (T2));
6542 elsif Is_Private_Type (T1)
6543 and then Present (Full_View (T1))
6544 and then Has_Discriminants (Full_View (T1))
6546 return Subtypes_Statically_Match (Full_View (T1), T2);
6558 function Original_Discriminant_Constraint
6559 (Typ : Entity_Id) return Elist_Id;
6560 -- Returns Typ's discriminant constraint, or if the constraint
6561 -- is inherited from an ancestor type, then climbs the parent
6562 -- types to locate and return the constraint farthest up the
6563 -- parent chain that Typ's constraint is ultimately inherited
6564 -- from (stopping before a parent that doesn't impose a constraint
6565 -- or a parent that has new discriminants). This ensures a proper
6566 -- result from the equality comparison of Elist_Ids below (as
6567 -- otherwise, derived types that inherit constraints may appear
6568 -- to be unequal, because each level of derivation can have its
6569 -- own copy of the constraint).
6571 function Original_Discriminant_Constraint
6572 (Typ : Entity_Id) return Elist_Id
6575 if not Has_Discriminants (Typ) then
6578 -- If Typ is not a derived type, then directly return the
6581 elsif not Is_Derived_Type (Typ) then
6582 return Discriminant_Constraint (Typ);
6584 -- If the parent type doesn't have discriminants, doesn't
6585 -- have a constraint, or has new discriminants, then stop
6586 -- and return Typ's constraint.
6588 elsif not Has_Discriminants (Etype (Typ))
6590 -- No constraint on the parent type
6592 or else not Present (Discriminant_Constraint (Etype (Typ)))
6593 or else Is_Empty_Elmt_List
6594 (Discriminant_Constraint (Etype (Typ)))
6596 -- The parent type defines new discriminants
6599 (Is_Base_Type (Etype (Typ))
6600 and then Present (Discriminant_Specifications
6601 (Parent (Etype (Typ)))))
6603 return Discriminant_Constraint (Typ);
6605 -- Otherwise, make a recursive call on the parent type
6608 return Original_Discriminant_Constraint (Etype (Typ));
6610 end Original_Discriminant_Constraint;
6614 DL1 : constant Elist_Id := Original_Discriminant_Constraint (T1);
6615 DL2 : constant Elist_Id := Original_Discriminant_Constraint (T2);
6623 elsif Is_Constrained (T1) /= Is_Constrained (T2) then
6627 -- Now loop through the discriminant constraints
6629 -- Note: the guard here seems necessary, since it is possible at
6630 -- least for DL1 to be No_Elist. Not clear this is reasonable ???
6632 if Present (DL1) and then Present (DL2) then
6633 DA1 := First_Elmt (DL1);
6634 DA2 := First_Elmt (DL2);
6635 while Present (DA1) loop
6637 Expr1 : constant Node_Id := Node (DA1);
6638 Expr2 : constant Node_Id := Node (DA2);
6641 if not Is_OK_Static_Expression (Expr1)
6642 or else not Is_OK_Static_Expression (Expr2)
6646 -- If either expression raised a Constraint_Error,
6647 -- consider the expressions as matching, since this
6648 -- helps to prevent cascading errors.
6650 elsif Raises_Constraint_Error (Expr1)
6651 or else Raises_Constraint_Error (Expr2)
6655 elsif Expr_Value (Expr1) /= Expr_Value (Expr2) then
6668 -- A definite type does not match an indefinite or classwide type.
6669 -- However, a generic type with unknown discriminants may be
6670 -- instantiated with a type with no discriminants, and conformance
6671 -- checking on an inherited operation may compare the actual with the
6672 -- subtype that renames it in the instance.
6674 elsif Has_Unknown_Discriminants (T1) /= Has_Unknown_Discriminants (T2)
6677 Is_Generic_Actual_Type (T1) or else Is_Generic_Actual_Type (T2);
6681 elsif Is_Array_Type (T1) then
6683 -- If either subtype is unconstrained then both must be, and if both
6684 -- are unconstrained then no further checking is needed.
6686 if not Is_Constrained (T1) or else not Is_Constrained (T2) then
6687 return not (Is_Constrained (T1) or else Is_Constrained (T2));
6690 -- Both subtypes are constrained, so check that the index subtypes
6691 -- statically match.
6694 Index1 : Node_Id := First_Index (T1);
6695 Index2 : Node_Id := First_Index (T2);
6698 while Present (Index1) loop
6700 Subtypes_Statically_Match (Etype (Index1), Etype (Index2))
6705 Next_Index (Index1);
6706 Next_Index (Index2);
6712 elsif Is_Access_Type (T1) then
6713 if Can_Never_Be_Null (T1) /= Can_Never_Be_Null (T2) then
6716 elsif Ekind (T1) in E_Access_Subprogram_Type
6717 | E_Anonymous_Access_Subprogram_Type
6721 (Designated_Type (T1),
6722 Designated_Type (T2));
6725 Subtypes_Statically_Match
6726 (Designated_Type (T1),
6727 Designated_Type (T2))
6728 and then Is_Access_Constant (T1) = Is_Access_Constant (T2);
6731 -- All other types definitely match
6736 end Subtypes_Statically_Match;
6742 function Test (Cond : Boolean) return Uint is
6751 ---------------------
6752 -- Test_Comparison --
6753 ---------------------
6755 procedure Test_Comparison
6757 Assume_Valid : Boolean;
6758 True_Result : out Boolean;
6759 False_Result : out Boolean)
6761 Left : constant Node_Id := Left_Opnd (Op);
6762 Left_Typ : constant Entity_Id := Etype (Left);
6763 Orig_Op : constant Node_Id := Original_Node (Op);
6765 procedure Replacement_Warning (Msg : String);
6766 -- Emit a warning on a comparison that can be replaced by '='
6768 -------------------------
6769 -- Replacement_Warning --
6770 -------------------------
6772 procedure Replacement_Warning (Msg : String) is
6774 if Constant_Condition_Warnings
6775 and then Comes_From_Source (Orig_Op)
6776 and then Is_Integer_Type (Left_Typ)
6777 and then not Error_Posted (Op)
6778 and then not Has_Warnings_Off (Left_Typ)
6779 and then not In_Instance
6781 Error_Msg_N (Msg, Op);
6783 end Replacement_Warning;
6787 Res : constant Compare_Result :=
6788 Compile_Time_Compare (Left, Right_Opnd (Op), Assume_Valid);
6790 -- Start of processing for Test_Comparison
6793 case N_Op_Compare (Nkind (Op)) is
6795 True_Result := Res = EQ;
6796 False_Result := Res = LT or else Res = GT or else Res = NE;
6799 True_Result := Res in Compare_GE;
6800 False_Result := Res = LT;
6802 if Res = LE and then Nkind (Orig_Op) = N_Op_Ge then
6804 ("can never be greater than, could replace by ""'=""?c?");
6808 True_Result := Res = GT;
6809 False_Result := Res in Compare_LE;
6812 True_Result := Res in Compare_LE;
6813 False_Result := Res = GT;
6815 if Res = GE and then Nkind (Orig_Op) = N_Op_Le then
6817 ("can never be less than, could replace by ""'=""?c?");
6821 True_Result := Res = LT;
6822 False_Result := Res in Compare_GE;
6825 True_Result := Res = NE or else Res = GT or else Res = LT;
6826 False_Result := Res = EQ;
6828 end Test_Comparison;
6830 ---------------------------------
6831 -- Test_Expression_Is_Foldable --
6832 ---------------------------------
6836 procedure Test_Expression_Is_Foldable
6846 if Debug_Flag_Dot_F and then In_Extended_Main_Source_Unit (N) then
6850 -- If operand is Any_Type, just propagate to result and do not
6851 -- try to fold, this prevents cascaded errors.
6853 if Etype (Op1) = Any_Type then
6854 Set_Etype (N, Any_Type);
6857 -- If operand raises Constraint_Error, then replace node N with the
6858 -- raise Constraint_Error node, and we are obviously not foldable.
6859 -- Note that this replacement inherits the Is_Static_Expression flag
6860 -- from the operand.
6862 elsif Raises_Constraint_Error (Op1) then
6863 Rewrite_In_Raise_CE (N, Op1);
6866 -- If the operand is not static, then the result is not static, and
6867 -- all we have to do is to check the operand since it is now known
6868 -- to appear in a non-static context.
6870 elsif not Is_Static_Expression (Op1) then
6871 Check_Non_Static_Context (Op1);
6872 Fold := Compile_Time_Known_Value (Op1);
6875 -- An expression of a formal modular type is not foldable because
6876 -- the modulus is unknown.
6878 elsif Is_Modular_Integer_Type (Etype (Op1))
6879 and then Is_Generic_Type (Etype (Op1))
6881 Check_Non_Static_Context (Op1);
6884 -- Here we have the case of an operand whose type is OK, which is
6885 -- static, and which does not raise Constraint_Error, we can fold.
6888 Set_Is_Static_Expression (N);
6892 end Test_Expression_Is_Foldable;
6896 procedure Test_Expression_Is_Foldable
6902 CRT_Safe : Boolean := False)
6904 Rstat : constant Boolean := Is_Static_Expression (Op1)
6906 Is_Static_Expression (Op2);
6912 -- Inhibit folding if -gnatd.f flag set
6914 if Debug_Flag_Dot_F and then In_Extended_Main_Source_Unit (N) then
6918 -- If either operand is Any_Type, just propagate to result and
6919 -- do not try to fold, this prevents cascaded errors.
6921 if Etype (Op1) = Any_Type or else Etype (Op2) = Any_Type then
6922 Set_Etype (N, Any_Type);
6925 -- If left operand raises Constraint_Error, then replace node N with the
6926 -- Raise_Constraint_Error node, and we are obviously not foldable.
6927 -- Is_Static_Expression is set from the two operands in the normal way,
6928 -- and we check the right operand if it is in a non-static context.
6930 elsif Raises_Constraint_Error (Op1) then
6932 Check_Non_Static_Context (Op2);
6935 Rewrite_In_Raise_CE (N, Op1);
6936 Set_Is_Static_Expression (N, Rstat);
6939 -- Similar processing for the case of the right operand. Note that we
6940 -- don't use this routine for the short-circuit case, so we do not have
6941 -- to worry about that special case here.
6943 elsif Raises_Constraint_Error (Op2) then
6945 Check_Non_Static_Context (Op1);
6948 Rewrite_In_Raise_CE (N, Op2);
6949 Set_Is_Static_Expression (N, Rstat);
6952 -- Exclude expressions of a generic modular type, as above
6954 elsif Is_Modular_Integer_Type (Etype (Op1))
6955 and then Is_Generic_Type (Etype (Op1))
6957 Check_Non_Static_Context (Op1);
6960 -- If result is not static, then check non-static contexts on operands
6961 -- since one of them may be static and the other one may not be static.
6963 elsif not Rstat then
6964 Check_Non_Static_Context (Op1);
6965 Check_Non_Static_Context (Op2);
6968 Fold := CRT_Safe_Compile_Time_Known_Value (Op1)
6969 and then CRT_Safe_Compile_Time_Known_Value (Op2);
6971 Fold := Compile_Time_Known_Value (Op1)
6972 and then Compile_Time_Known_Value (Op2);
6977 -- Else result is static and foldable. Both operands are static, and
6978 -- neither raises Constraint_Error, so we can definitely fold.
6981 Set_Is_Static_Expression (N);
6986 end Test_Expression_Is_Foldable;
6992 function Test_In_Range
6995 Assume_Valid : Boolean;
6996 Fixed_Int : Boolean;
6997 Int_Real : Boolean) return Range_Membership
7002 pragma Warnings (Off, Assume_Valid);
7003 -- For now Assume_Valid is unreferenced since the current implementation
7004 -- always returns Unknown if N is not a compile-time-known value, but we
7005 -- keep the parameter to allow for future enhancements in which we try
7006 -- to get the information in the variable case as well.
7009 -- If an error was posted on expression, then return Unknown, we do not
7010 -- want cascaded errors based on some false analysis of a junk node.
7012 if Error_Posted (N) then
7015 -- Expression that raises Constraint_Error is an odd case. We certainly
7016 -- do not want to consider it to be in range. It might make sense to
7017 -- consider it always out of range, but this causes incorrect error
7018 -- messages about static expressions out of range. So we just return
7019 -- Unknown, which is always safe.
7021 elsif Raises_Constraint_Error (N) then
7024 -- Universal types have no range limits, so always in range
7026 elsif Typ = Universal_Integer or else Typ = Universal_Real then
7029 -- Never known if not scalar type. Don't know if this can actually
7030 -- happen, but our spec allows it, so we must check.
7032 elsif not Is_Scalar_Type (Typ) then
7035 -- Never known if this is a generic type, since the bounds of generic
7036 -- types are junk. Note that if we only checked for static expressions
7037 -- (instead of compile-time-known values) below, we would not need this
7038 -- check, because values of a generic type can never be static, but they
7039 -- can be known at compile time.
7041 elsif Is_Generic_Type (Typ) then
7044 -- Case of a known compile time value, where we can check if it is in
7045 -- the bounds of the given type.
7047 elsif Compile_Time_Known_Value (N) then
7056 Lo := Type_Low_Bound (Typ);
7057 Hi := Type_High_Bound (Typ);
7059 LB_Known := Compile_Time_Known_Value (Lo);
7060 HB_Known := Compile_Time_Known_Value (Hi);
7062 -- Fixed point types should be considered as such only if flag
7063 -- Fixed_Int is set to False.
7065 if Is_Floating_Point_Type (Typ)
7066 or else (Is_Fixed_Point_Type (Typ) and then not Fixed_Int)
7069 Valr := Expr_Value_R (N);
7071 if LB_Known and HB_Known then
7072 if Valr >= Expr_Value_R (Lo)
7074 Valr <= Expr_Value_R (Hi)
7078 return Out_Of_Range;
7081 elsif (LB_Known and then Valr < Expr_Value_R (Lo))
7083 (HB_Known and then Valr > Expr_Value_R (Hi))
7085 return Out_Of_Range;
7092 Val := Expr_Value (N);
7094 if LB_Known and HB_Known then
7095 if Val >= Expr_Value (Lo) and then Val <= Expr_Value (Hi)
7099 return Out_Of_Range;
7102 elsif (LB_Known and then Val < Expr_Value (Lo))
7104 (HB_Known and then Val > Expr_Value (Hi))
7106 return Out_Of_Range;
7114 -- Here for value not known at compile time. Case of expression subtype
7115 -- is Typ or is a subtype of Typ, and we can assume expression is valid.
7116 -- In this case we know it is in range without knowing its value.
7119 and then (Etype (N) = Typ or else Is_Subtype_Of (Etype (N), Typ))
7123 -- Another special case. For signed integer types, if the target type
7124 -- has Is_Known_Valid set, and the source type does not have a larger
7125 -- size, then the source value must be in range. We exclude biased
7126 -- types, because they bizarrely can generate out of range values.
7128 elsif Is_Signed_Integer_Type (Etype (N))
7129 and then Is_Known_Valid (Typ)
7130 and then Esize (Etype (N)) <= Esize (Typ)
7131 and then not Has_Biased_Representation (Etype (N))
7135 -- For all other cases, result is unknown
7146 procedure To_Bits (U : Uint; B : out Bits) is
7148 for J in 0 .. B'Last loop
7149 B (J) := (U / (2 ** J)) mod 2 /= 0;
7153 --------------------
7154 -- Why_Not_Static --
7155 --------------------
7157 procedure Why_Not_Static (Expr : Node_Id) is
7158 N : constant Node_Id := Original_Node (Expr);
7159 Typ : Entity_Id := Empty;
7164 procedure Why_Not_Static_List (L : List_Id);
7165 -- A version that can be called on a list of expressions. Finds all
7166 -- non-static violations in any element of the list.
7168 -------------------------
7169 -- Why_Not_Static_List --
7170 -------------------------
7172 procedure Why_Not_Static_List (L : List_Id) is
7175 if Is_Non_Empty_List (L) then
7177 while Present (N) loop
7182 end Why_Not_Static_List;
7184 -- Start of processing for Why_Not_Static
7187 -- Ignore call on error or empty node
7189 if No (Expr) or else Nkind (Expr) = N_Error then
7193 -- Preprocessing for sub expressions
7195 if Nkind (Expr) in N_Subexpr then
7197 -- Nothing to do if expression is static
7199 if Is_OK_Static_Expression (Expr) then
7203 -- Test for Constraint_Error raised
7205 if Raises_Constraint_Error (Expr) then
7207 -- Special case membership to find out which piece to flag
7209 if Nkind (N) in N_Membership_Test then
7210 if Raises_Constraint_Error (Left_Opnd (N)) then
7211 Why_Not_Static (Left_Opnd (N));
7214 elsif Present (Right_Opnd (N))
7215 and then Raises_Constraint_Error (Right_Opnd (N))
7217 Why_Not_Static (Right_Opnd (N));
7221 pragma Assert (Present (Alternatives (N)));
7223 Alt := First (Alternatives (N));
7224 while Present (Alt) loop
7225 if Raises_Constraint_Error (Alt) then
7226 Why_Not_Static (Alt);
7234 -- Special case a range to find out which bound to flag
7236 elsif Nkind (N) = N_Range then
7237 if Raises_Constraint_Error (Low_Bound (N)) then
7238 Why_Not_Static (Low_Bound (N));
7241 elsif Raises_Constraint_Error (High_Bound (N)) then
7242 Why_Not_Static (High_Bound (N));
7246 -- Special case attribute to see which part to flag
7248 elsif Nkind (N) = N_Attribute_Reference then
7249 if Raises_Constraint_Error (Prefix (N)) then
7250 Why_Not_Static (Prefix (N));
7254 if Present (Expressions (N)) then
7255 Exp := First (Expressions (N));
7256 while Present (Exp) loop
7257 if Raises_Constraint_Error (Exp) then
7258 Why_Not_Static (Exp);
7266 -- Special case a subtype name
7268 elsif Is_Entity_Name (Expr) and then Is_Type (Entity (Expr)) then
7270 ("!& is not a static subtype (RM 4.9(26))", N, Entity (Expr));
7274 -- End of special cases
7277 ("!expression raises exception, cannot be static (RM 4.9(34))",
7282 -- If no type, then something is pretty wrong, so ignore
7284 Typ := Etype (Expr);
7290 -- Type must be scalar or string type (but allow Bignum, since this
7291 -- is really a scalar type from our point of view in this diagnosis).
7293 if not Is_Scalar_Type (Typ)
7294 and then not Is_String_Type (Typ)
7295 and then not Is_RTE (Typ, RE_Bignum)
7298 ("!static expression must have scalar or string type " &
7304 -- If we got through those checks, test particular node kind
7310 when N_Expanded_Name
7316 if Is_Named_Number (E) then
7319 elsif Ekind (E) = E_Constant then
7321 -- One case we can give a metter message is when we have a
7322 -- string literal created by concatenating an aggregate with
7323 -- an others expression.
7325 Entity_Case : declare
7326 CV : constant Node_Id := Constant_Value (E);
7327 CO : constant Node_Id := Original_Node (CV);
7329 function Is_Aggregate (N : Node_Id) return Boolean;
7330 -- See if node N came from an others aggregate, if so
7331 -- return True and set Error_Msg_Sloc to aggregate.
7337 function Is_Aggregate (N : Node_Id) return Boolean is
7339 if Nkind (Original_Node (N)) = N_Aggregate then
7340 Error_Msg_Sloc := Sloc (Original_Node (N));
7343 elsif Is_Entity_Name (N)
7344 and then Ekind (Entity (N)) = E_Constant
7346 Nkind (Original_Node (Constant_Value (Entity (N)))) =
7350 Sloc (Original_Node (Constant_Value (Entity (N))));
7358 -- Start of processing for Entity_Case
7361 if Is_Aggregate (CV)
7362 or else (Nkind (CO) = N_Op_Concat
7363 and then (Is_Aggregate (Left_Opnd (CO))
7365 Is_Aggregate (Right_Opnd (CO))))
7367 Error_Msg_N ("!aggregate (#) is never static", N);
7369 elsif No (CV) or else not Is_Static_Expression (CV) then
7371 ("!& is not a static constant (RM 4.9(5))", N, E);
7375 elsif Is_Type (E) then
7377 ("!& is not a static subtype (RM 4.9(26))", N, E);
7381 ("!& is not static constant or named number "
7382 & "(RM 4.9(5))", N, E);
7391 if Nkind (N) in N_Op_Shift then
7393 ("!shift functions are never static (RM 4.9(6,18))", N);
7395 Why_Not_Static (Left_Opnd (N));
7396 Why_Not_Static (Right_Opnd (N));
7402 Why_Not_Static (Right_Opnd (N));
7404 -- Attribute reference
7406 when N_Attribute_Reference =>
7407 Why_Not_Static_List (Expressions (N));
7409 E := Etype (Prefix (N));
7411 if E = Standard_Void_Type then
7415 -- Special case non-scalar'Size since this is a common error
7417 if Attribute_Name (N) = Name_Size then
7419 ("!size attribute is only static for static scalar type "
7420 & "(RM 4.9(7,8))", N);
7424 elsif Is_Array_Type (E) then
7425 if Attribute_Name (N)
7426 not in Name_First | Name_Last | Name_Length
7429 ("!static array attribute must be Length, First, or Last "
7430 & "(RM 4.9(8))", N);
7432 -- Since we know the expression is not-static (we already
7433 -- tested for this, must mean array is not static).
7437 ("!prefix is non-static array (RM 4.9(8))", Prefix (N));
7442 -- Special case generic types, since again this is a common source
7445 elsif Is_Generic_Actual_Type (E) or else Is_Generic_Type (E) then
7447 ("!attribute of generic type is never static "
7448 & "(RM 4.9(7,8))", N);
7450 elsif Is_OK_Static_Subtype (E) then
7453 elsif Is_Scalar_Type (E) then
7455 ("!prefix type for attribute is not static scalar subtype "
7456 & "(RM 4.9(7))", N);
7460 ("!static attribute must apply to array/scalar type "
7461 & "(RM 4.9(7,8))", N);
7466 when N_String_Literal =>
7468 ("!subtype of string literal is non-static (RM 4.9(4))", N);
7470 -- Explicit dereference
7472 when N_Explicit_Dereference =>
7474 ("!explicit dereference is never static (RM 4.9)", N);
7478 when N_Function_Call =>
7479 Why_Not_Static_List (Parameter_Associations (N));
7481 -- Complain about non-static function call unless we have Bignum
7482 -- which means that the underlying expression is really some
7483 -- scalar arithmetic operation.
7485 if not Is_RTE (Typ, RE_Bignum) then
7486 Error_Msg_N ("!non-static function call (RM 4.9(6,18))", N);
7489 -- Parameter assocation (test actual parameter)
7491 when N_Parameter_Association =>
7492 Why_Not_Static (Explicit_Actual_Parameter (N));
7494 -- Indexed component
7496 when N_Indexed_Component =>
7497 Error_Msg_N ("!indexed component is never static (RM 4.9)", N);
7501 when N_Procedure_Call_Statement =>
7502 Error_Msg_N ("!procedure call is never static (RM 4.9)", N);
7504 -- Qualified expression (test expression)
7506 when N_Qualified_Expression =>
7507 Why_Not_Static (Expression (N));
7512 | N_Extension_Aggregate
7514 Error_Msg_N ("!an aggregate is never static (RM 4.9)", N);
7519 Why_Not_Static (Low_Bound (N));
7520 Why_Not_Static (High_Bound (N));
7522 -- Range constraint, test range expression
7524 when N_Range_Constraint =>
7525 Why_Not_Static (Range_Expression (N));
7527 -- Subtype indication, test constraint
7529 when N_Subtype_Indication =>
7530 Why_Not_Static (Constraint (N));
7532 -- Selected component
7534 when N_Selected_Component =>
7535 Error_Msg_N ("!selected component is never static (RM 4.9)", N);
7540 Error_Msg_N ("!slice is never static (RM 4.9)", N);
7542 when N_Type_Conversion =>
7543 Why_Not_Static (Expression (N));
7545 if not Is_Scalar_Type (Entity (Subtype_Mark (N)))
7546 or else not Is_OK_Static_Subtype (Entity (Subtype_Mark (N)))
7549 ("!static conversion requires static scalar subtype result "
7550 & "(RM 4.9(9))", N);
7553 -- Unchecked type conversion
7555 when N_Unchecked_Type_Conversion =>
7557 ("!unchecked type conversion is never static (RM 4.9)", N);
7559 -- All other cases, no reason to give