1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2015, 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 Atree; use Atree;
27 with Checks; use Checks;
28 with Debug; use Debug;
29 with Einfo; use Einfo;
30 with Elists; use Elists;
31 with Errout; use Errout;
32 with Eval_Fat; use Eval_Fat;
33 with Exp_Util; use Exp_Util;
34 with Freeze; use Freeze;
36 with Namet; use Namet;
37 with Nmake; use Nmake;
38 with Nlists; use Nlists;
40 with Par_SCO; use Par_SCO;
41 with Rtsfind; use Rtsfind;
43 with Sem_Aux; use Sem_Aux;
44 with Sem_Cat; use Sem_Cat;
45 with Sem_Ch6; use Sem_Ch6;
46 with Sem_Ch8; use Sem_Ch8;
47 with Sem_Res; use Sem_Res;
48 with Sem_Util; use Sem_Util;
49 with Sem_Type; use Sem_Type;
50 with Sem_Warn; use Sem_Warn;
51 with Sinfo; use Sinfo;
52 with Snames; use Snames;
53 with Stand; use Stand;
54 with Stringt; use Stringt;
55 with Tbuild; use Tbuild;
57 package body Sem_Eval is
59 -----------------------------------------
60 -- Handling of Compile Time Evaluation --
61 -----------------------------------------
63 -- The compile time evaluation of expressions is distributed over several
64 -- Eval_xxx procedures. These procedures are called immediately after
65 -- a subexpression is resolved and is therefore accomplished in a bottom
66 -- up fashion. The flags are synthesized using the following approach.
68 -- Is_Static_Expression is determined by following the detailed rules
69 -- in RM 4.9(4-14). This involves testing the Is_Static_Expression
70 -- flag of the operands in many cases.
72 -- Raises_Constraint_Error is set if any of the operands have the flag
73 -- set or if an attempt to compute the value of the current expression
74 -- results in detection of a runtime constraint error.
76 -- As described in the spec, the requirement is that Is_Static_Expression
77 -- be accurately set, and in addition for nodes for which this flag is set,
78 -- Raises_Constraint_Error must also be set. Furthermore a node which has
79 -- Is_Static_Expression set, and Raises_Constraint_Error clear, then the
80 -- requirement is that the expression value must be precomputed, and the
81 -- node is either a literal, or the name of a constant entity whose value
82 -- is a static expression.
84 -- The general approach is as follows. First compute Is_Static_Expression.
85 -- If the node is not static, then the flag is left off in the node and
86 -- we are all done. Otherwise for a static node, we test if any of the
87 -- operands will raise constraint error, and if so, propagate the flag
88 -- Raises_Constraint_Error to the result node and we are done (since the
89 -- error was already posted at a lower level).
91 -- For the case of a static node whose operands do not raise constraint
92 -- error, we attempt to evaluate the node. If this evaluation succeeds,
93 -- then the node is replaced by the result of this computation. If the
94 -- evaluation raises constraint error, then we rewrite the node with
95 -- Apply_Compile_Time_Constraint_Error to raise the exception and also
96 -- to post appropriate error messages.
102 type Bits is array (Nat range <>) of Boolean;
103 -- Used to convert unsigned (modular) values for folding logical ops
105 -- The following declarations are used to maintain a cache of nodes that
106 -- have compile time known values. The cache is maintained only for
107 -- discrete types (the most common case), and is populated by calls to
108 -- Compile_Time_Known_Value and Expr_Value, but only used by Expr_Value
109 -- since it is possible for the status to change (in particular it is
110 -- possible for a node to get replaced by a constraint error node).
112 CV_Bits : constant := 5;
113 -- Number of low order bits of Node_Id value used to reference entries
114 -- in the cache table.
116 CV_Cache_Size : constant Nat := 2 ** CV_Bits;
117 -- Size of cache for compile time values
119 subtype CV_Range is Nat range 0 .. CV_Cache_Size;
121 type CV_Entry is record
126 type Match_Result is (Match, No_Match, Non_Static);
127 -- Result returned from functions that test for a matching result. If the
128 -- operands are not OK_Static then Non_Static will be returned. Otherwise
129 -- Match/No_Match is returned depending on whether the match succeeds.
131 type CV_Cache_Array is array (CV_Range) of CV_Entry;
133 CV_Cache : CV_Cache_Array := (others => (Node_High_Bound, Uint_0));
134 -- This is the actual cache, with entries consisting of node/value pairs,
135 -- and the impossible value Node_High_Bound used for unset entries.
137 type Range_Membership is (In_Range, Out_Of_Range, Unknown);
138 -- Range membership may either be statically known to be in range or out
139 -- of range, or not statically known. Used for Test_In_Range below.
141 -----------------------
142 -- Local Subprograms --
143 -----------------------
145 function Choice_Matches
147 Choice : Node_Id) return Match_Result;
148 -- Determines whether given value Expr matches the given Choice. The Expr
149 -- can be of discrete, real, or string type and must be a compile time
150 -- known value (it is an error to make the call if these conditions are
151 -- not met). The choice can be a range, subtype name, subtype indication,
152 -- or expression. The returned result is Non_Static if Choice is not
153 -- OK_Static, otherwise either Match or No_Match is returned depending
154 -- on whether Choice matches Expr. This is used for case expression
155 -- alternatives, and also for membership tests. In each case, more
156 -- possibilities are tested than the syntax allows (e.g. membership allows
157 -- subtype indications and non-discrete types, and case allows an OTHERS
158 -- choice), but it does not matter, since we have already done a full
159 -- semantic and syntax check of the construct, so the extra possibilities
160 -- just will not arise for correct expressions.
162 -- Note: if Choice_Matches finds that a choice raises Constraint_Error, e.g
163 -- a reference to a type, one of whose bounds raises Constraint_Error, then
164 -- it also sets the Raises_Constraint_Error flag on the Choice itself.
166 function Choices_Match
168 Choices : List_Id) return Match_Result;
169 -- This function applies Choice_Matches to each element of Choices. If the
170 -- result is No_Match, then it continues and checks the next element. If
171 -- the result is Match or Non_Static, this result is immediately given
172 -- as the result without checking the rest of the list. Expr can be of
173 -- discrete, real, or string type and must be a compile time known value
174 -- (it is an error to make the call if these conditions are not met).
176 function Find_Universal_Operator_Type (N : Node_Id) return Entity_Id;
177 -- Check whether an arithmetic operation with universal operands which is a
178 -- rewritten function call with an explicit scope indication is ambiguous:
179 -- P."+" (1, 2) will be ambiguous if there is more than one visible numeric
180 -- type declared in P and the context does not impose a type on the result
181 -- (e.g. in the expression of a type conversion). If ambiguous, emit an
182 -- error and return Empty, else return the result type of the operator.
184 function From_Bits (B : Bits; T : Entity_Id) return Uint;
185 -- Converts a bit string of length B'Length to a Uint value to be used for
186 -- a target of type T, which is a modular type. This procedure includes the
187 -- necessary reduction by the modulus in the case of a nonbinary modulus
188 -- (for a binary modulus, the bit string is the right length any way so all
191 function Get_String_Val (N : Node_Id) return Node_Id;
192 -- Given a tree node for a folded string or character value, returns the
193 -- corresponding string literal or character literal (one of the two must
194 -- be available, or the operand would not have been marked as foldable in
195 -- the earlier analysis of the operation).
197 function Is_OK_Static_Choice (Choice : Node_Id) return Boolean;
198 -- Given a choice (from a case expression or membership test), returns
199 -- True if the choice is static and does not raise a Constraint_Error.
201 function Is_OK_Static_Choice_List (Choices : List_Id) return Boolean;
202 -- Given a choice list (from a case expression or membership test), return
203 -- True if all choices are static in the sense of Is_OK_Static_Choice.
205 function Is_Static_Choice (Choice : Node_Id) return Boolean;
206 -- Given a choice (from a case expression or membership test), returns
207 -- True if the choice is static. No test is made for raising of constraint
208 -- error, so this function is used only for legality tests.
210 function Is_Static_Choice_List (Choices : List_Id) return Boolean;
211 -- Given a choice list (from a case expression or membership test), return
212 -- True if all choices are static in the sense of Is_Static_Choice.
214 function Is_Static_Range (N : Node_Id) return Boolean;
215 -- Determine if range is static, as defined in RM 4.9(26). The only allowed
216 -- argument is an N_Range node (but note that the semantic analysis of
217 -- equivalent range attribute references already turned them into the
218 -- equivalent range). This differs from Is_OK_Static_Range (which is what
219 -- must be used by clients) in that it does not care whether the bounds
220 -- raise Constraint_Error or not. Used for checking whether expressions are
221 -- static in the 4.9 sense (without worrying about exceptions).
223 function OK_Bits (N : Node_Id; Bits : Uint) return Boolean;
224 -- Bits represents the number of bits in an integer value to be computed
225 -- (but the value has not been computed yet). If this value in Bits is
226 -- reasonable, a result of True is returned, with the implication that the
227 -- caller should go ahead and complete the calculation. If the value in
228 -- Bits is unreasonably large, then an error is posted on node N, and
229 -- False is returned (and the caller skips the proposed calculation).
231 procedure Out_Of_Range (N : Node_Id);
232 -- This procedure is called if it is determined that node N, which appears
233 -- in a non-static context, is a compile time known value which is outside
234 -- its range, i.e. the range of Etype. This is used in contexts where
235 -- this is an illegality if N is static, and should generate a warning
238 function Real_Or_String_Static_Predicate_Matches
240 Typ : Entity_Id) return Boolean;
241 -- This is the function used to evaluate real or string static predicates.
242 -- Val is an unanalyzed N_Real_Literal or N_String_Literal node, which
243 -- represents the value to be tested against the predicate. Typ is the
244 -- type with the predicate, from which the predicate expression can be
245 -- extracted. The result returned is True if the given value satisfies
248 procedure Rewrite_In_Raise_CE (N : Node_Id; Exp : Node_Id);
249 -- N and Exp are nodes representing an expression, Exp is known to raise
250 -- CE. N is rewritten in term of Exp in the optimal way.
252 function String_Type_Len (Stype : Entity_Id) return Uint;
253 -- Given a string type, determines the length of the index type, or, if
254 -- this index type is non-static, the length of the base type of this index
255 -- type. Note that if the string type is itself static, then the index type
256 -- is static, so the second case applies only if the string type passed is
259 function Test (Cond : Boolean) return Uint;
260 pragma Inline (Test);
261 -- This function simply returns the appropriate Boolean'Pos value
262 -- corresponding to the value of Cond as a universal integer. It is
263 -- used for producing the result of the static evaluation of the
266 procedure Test_Expression_Is_Foldable
271 -- Tests to see if expression N whose single operand is Op1 is foldable,
272 -- i.e. the operand value is known at compile time. If the operation is
273 -- foldable, then Fold is True on return, and Stat indicates whether the
274 -- result is static (i.e. the operand was static). Note that it is quite
275 -- possible for Fold to be True, and Stat to be False, since there are
276 -- cases in which we know the value of an operand even though it is not
277 -- technically static (e.g. the static lower bound of a range whose upper
278 -- bound is non-static).
280 -- If Stat is set False on return, then Test_Expression_Is_Foldable makes
281 -- a call to Check_Non_Static_Context on the operand. If Fold is False on
282 -- return, then all processing is complete, and the caller should return,
283 -- since there is nothing else to do.
285 -- If Stat is set True on return, then Is_Static_Expression is also set
286 -- true in node N. There are some cases where this is over-enthusiastic,
287 -- e.g. in the two operand case below, for string comparison, the result is
288 -- not static even though the two operands are static. In such cases, the
289 -- caller must reset the Is_Static_Expression flag in N.
291 -- If Fold and Stat are both set to False then this routine performs also
292 -- the following extra actions:
294 -- If either operand is Any_Type then propagate it to result to prevent
297 -- If some operand raises constraint error, then replace the node N
298 -- with the raise constraint error node. This replacement inherits the
299 -- Is_Static_Expression flag from the operands.
301 procedure Test_Expression_Is_Foldable
307 CRT_Safe : Boolean := False);
308 -- Same processing, except applies to an expression N with two operands
309 -- Op1 and Op2. The result is static only if both operands are static. If
310 -- CRT_Safe is set True, then CRT_Safe_Compile_Time_Known_Value is used
311 -- for the tests that the two operands are known at compile time. See
312 -- spec of this routine for further details.
314 function Test_In_Range
317 Assume_Valid : Boolean;
319 Int_Real : Boolean) return Range_Membership;
320 -- Common processing for Is_In_Range and Is_Out_Of_Range: Returns In_Range
321 -- or Out_Of_Range if it can be guaranteed at compile time that expression
322 -- N is known to be in or out of range of the subtype Typ. If not compile
323 -- time known, Unknown is returned. See documentation of Is_In_Range for
324 -- complete description of parameters.
326 procedure To_Bits (U : Uint; B : out Bits);
327 -- Converts a Uint value to a bit string of length B'Length
329 -----------------------------------------------
330 -- Check_Expression_Against_Static_Predicate --
331 -----------------------------------------------
333 procedure Check_Expression_Against_Static_Predicate
338 -- Nothing to do if expression is not known at compile time, or the
339 -- type has no static predicate set (will be the case for all non-scalar
340 -- types, so no need to make a special test for that).
342 if not (Has_Static_Predicate (Typ)
343 and then Compile_Time_Known_Value (Expr))
348 -- Here we have a static predicate (note that it could have arisen from
349 -- an explicitly specified Dynamic_Predicate whose expression met the
350 -- rules for being predicate-static).
352 -- Case of real static predicate
354 if Is_Real_Type (Typ) then
355 if Real_Or_String_Static_Predicate_Matches
356 (Val => Make_Real_Literal (Sloc (Expr), Expr_Value_R (Expr)),
362 -- Case of string static predicate
364 elsif Is_String_Type (Typ) then
365 if Real_Or_String_Static_Predicate_Matches
366 (Val => Expr_Value_S (Expr), Typ => Typ)
371 -- Case of discrete static predicate
374 pragma Assert (Is_Discrete_Type (Typ));
376 -- If static predicate matches, nothing to do
378 if Choices_Match (Expr, Static_Discrete_Predicate (Typ)) = Match then
383 -- Here we know that the predicate will fail
385 -- Special case of static expression failing a predicate (other than one
386 -- that was explicitly specified with a Dynamic_Predicate aspect). This
387 -- is the case where the expression is no longer considered static.
389 if Is_Static_Expression (Expr)
390 and then not Has_Dynamic_Predicate_Aspect (Typ)
393 ("??static expression fails static predicate check on &",
396 ("\??expression is no longer considered static", Expr);
397 Set_Is_Static_Expression (Expr, False);
399 -- In all other cases, this is just a warning that a test will fail.
400 -- It does not matter if the expression is static or not, or if the
401 -- predicate comes from a dynamic predicate aspect or not.
405 ("??expression fails predicate check on &", Expr, Typ);
407 end Check_Expression_Against_Static_Predicate;
409 ------------------------------
410 -- Check_Non_Static_Context --
411 ------------------------------
413 procedure Check_Non_Static_Context (N : Node_Id) is
414 T : constant Entity_Id := Etype (N);
415 Checks_On : constant Boolean :=
416 not Index_Checks_Suppressed (T)
417 and not Range_Checks_Suppressed (T);
420 -- Ignore cases of non-scalar types, error types, or universal real
421 -- types that have no usable bounds.
424 or else not Is_Scalar_Type (T)
425 or else T = Universal_Fixed
426 or else T = Universal_Real
431 -- At this stage we have a scalar type. If we have an expression that
432 -- raises CE, then we already issued a warning or error msg so there is
433 -- nothing more to be done in this routine.
435 if Raises_Constraint_Error (N) then
439 -- Now we have a scalar type which is not marked as raising a constraint
440 -- error exception. The main purpose of this routine is to deal with
441 -- static expressions appearing in a non-static context. That means
442 -- that if we do not have a static expression then there is not much
443 -- to do. The one case that we deal with here is that if we have a
444 -- floating-point value that is out of range, then we post a warning
445 -- that an infinity will result.
447 if not Is_Static_Expression (N) then
448 if Is_Floating_Point_Type (T)
449 and then Is_Out_Of_Range (N, Base_Type (T), Assume_Valid => True)
452 ("??float value out of range, infinity will be generated", N);
458 -- Here we have the case of outer level static expression of scalar
459 -- type, where the processing of this procedure is needed.
461 -- For real types, this is where we convert the value to a machine
462 -- number (see RM 4.9(38)). Also see ACVC test C490001. We should only
463 -- need to do this if the parent is a constant declaration, since in
464 -- other cases, gigi should do the necessary conversion correctly, but
465 -- experimentation shows that this is not the case on all machines, in
466 -- particular if we do not convert all literals to machine values in
467 -- non-static contexts, then ACVC test C490001 fails on Sparc/Solaris
470 if Nkind (N) = N_Real_Literal
471 and then not Is_Machine_Number (N)
472 and then not Is_Generic_Type (Etype (N))
473 and then Etype (N) /= Universal_Real
475 -- Check that value is in bounds before converting to machine
476 -- number, so as not to lose case where value overflows in the
477 -- least significant bit or less. See B490001.
479 if Is_Out_Of_Range (N, Base_Type (T), Assume_Valid => True) then
484 -- Note: we have to copy the node, to avoid problems with conformance
485 -- of very similar numbers (see ACVC tests B4A010C and B63103A).
487 Rewrite (N, New_Copy (N));
489 if not Is_Floating_Point_Type (T) then
491 (N, Corresponding_Integer_Value (N) * Small_Value (T));
493 elsif not UR_Is_Zero (Realval (N)) then
495 -- Note: even though RM 4.9(38) specifies biased rounding, this
496 -- has been modified by AI-100 in order to prevent confusing
497 -- differences in rounding between static and non-static
498 -- expressions. AI-100 specifies that the effect of such rounding
499 -- is implementation dependent, and in GNAT we round to nearest
500 -- even to match the run-time behavior. Note that this applies
501 -- to floating point literals, not fixed points ones, even though
502 -- their compiler representation is also as a universal real.
505 (N, Machine (Base_Type (T), Realval (N), Round_Even, N));
506 Set_Is_Machine_Number (N);
511 -- Check for out of range universal integer. This is a non-static
512 -- context, so the integer value must be in range of the runtime
513 -- representation of universal integers.
515 -- We do this only within an expression, because that is the only
516 -- case in which non-static universal integer values can occur, and
517 -- furthermore, Check_Non_Static_Context is currently (incorrectly???)
518 -- called in contexts like the expression of a number declaration where
519 -- we certainly want to allow out of range values.
521 if Etype (N) = Universal_Integer
522 and then Nkind (N) = N_Integer_Literal
523 and then Nkind (Parent (N)) in N_Subexpr
525 (Intval (N) < Expr_Value (Type_Low_Bound (Universal_Integer))
527 Intval (N) > Expr_Value (Type_High_Bound (Universal_Integer)))
529 Apply_Compile_Time_Constraint_Error
530 (N, "non-static universal integer value out of range<<",
531 CE_Range_Check_Failed);
533 -- Check out of range of base type
535 elsif Is_Out_Of_Range (N, Base_Type (T), Assume_Valid => True) then
538 -- Give warning if outside subtype (where one or both of the bounds of
539 -- the subtype is static). This warning is omitted if the expression
540 -- appears in a range that could be null (warnings are handled elsewhere
543 elsif T /= Base_Type (T) and then Nkind (Parent (N)) /= N_Range then
544 if Is_In_Range (N, T, Assume_Valid => True) then
547 elsif Is_Out_Of_Range (N, T, Assume_Valid => True) then
548 Apply_Compile_Time_Constraint_Error
549 (N, "value not in range of}<<", CE_Range_Check_Failed);
552 Enable_Range_Check (N);
555 Set_Do_Range_Check (N, False);
558 end Check_Non_Static_Context;
560 ---------------------------------
561 -- Check_String_Literal_Length --
562 ---------------------------------
564 procedure Check_String_Literal_Length (N : Node_Id; Ttype : Entity_Id) is
566 if not Raises_Constraint_Error (N) and then Is_Constrained (Ttype) then
567 if UI_From_Int (String_Length (Strval (N))) /= String_Type_Len (Ttype)
569 Apply_Compile_Time_Constraint_Error
570 (N, "string length wrong for}??",
571 CE_Length_Check_Failed,
576 end Check_String_Literal_Length;
582 function Choice_Matches
584 Choice : Node_Id) return Match_Result
586 Etyp : constant Entity_Id := Etype (Expr);
592 pragma Assert (Compile_Time_Known_Value (Expr));
593 pragma Assert (Is_Scalar_Type (Etyp) or else Is_String_Type (Etyp));
595 if not Is_OK_Static_Choice (Choice) then
596 Set_Raises_Constraint_Error (Choice);
599 -- When the choice denotes a subtype with a static predictate, check the
600 -- expression against the predicate values.
602 elsif (Nkind (Choice) = N_Subtype_Indication
603 or else (Is_Entity_Name (Choice)
604 and then Is_Type (Entity (Choice))))
605 and then Has_Predicates (Etype (Choice))
606 and then Has_Static_Predicate (Etype (Choice))
609 Choices_Match (Expr, Static_Discrete_Predicate (Etype (Choice)));
611 -- Discrete type case
613 elsif Is_Discrete_Type (Etyp) then
614 Val := Expr_Value (Expr);
616 if Nkind (Choice) = N_Range then
617 if Val >= Expr_Value (Low_Bound (Choice))
619 Val <= Expr_Value (High_Bound (Choice))
626 elsif Nkind (Choice) = N_Subtype_Indication
627 or else (Is_Entity_Name (Choice) and then Is_Type (Entity (Choice)))
629 if Val >= Expr_Value (Type_Low_Bound (Etype (Choice)))
631 Val <= Expr_Value (Type_High_Bound (Etype (Choice)))
638 elsif Nkind (Choice) = N_Others_Choice then
642 if Val = Expr_Value (Choice) then
651 elsif Is_Real_Type (Etyp) then
652 ValR := Expr_Value_R (Expr);
654 if Nkind (Choice) = N_Range then
655 if ValR >= Expr_Value_R (Low_Bound (Choice))
657 ValR <= Expr_Value_R (High_Bound (Choice))
664 elsif Nkind (Choice) = N_Subtype_Indication
665 or else (Is_Entity_Name (Choice) and then Is_Type (Entity (Choice)))
667 if ValR >= Expr_Value_R (Type_Low_Bound (Etype (Choice)))
669 ValR <= Expr_Value_R (Type_High_Bound (Etype (Choice)))
677 if ValR = Expr_Value_R (Choice) then
687 pragma Assert (Is_String_Type (Etyp));
688 ValS := Expr_Value_S (Expr);
690 if Nkind (Choice) = N_Subtype_Indication
691 or else (Is_Entity_Name (Choice) and then Is_Type (Entity (Choice)))
693 if not Is_Constrained (Etype (Choice)) then
698 Typlen : constant Uint :=
699 String_Type_Len (Etype (Choice));
700 Strlen : constant Uint :=
701 UI_From_Int (String_Length (Strval (ValS)));
703 if Typlen = Strlen then
712 if String_Equal (Strval (ValS), Strval (Expr_Value_S (Choice)))
726 function Choices_Match
728 Choices : List_Id) return Match_Result
731 Result : Match_Result;
734 Choice := First (Choices);
735 while Present (Choice) loop
736 Result := Choice_Matches (Expr, Choice);
738 if Result /= No_Match then
748 --------------------------
749 -- Compile_Time_Compare --
750 --------------------------
752 function Compile_Time_Compare
754 Assume_Valid : Boolean) return Compare_Result
756 Discard : aliased Uint;
758 return Compile_Time_Compare (L, R, Discard'Access, Assume_Valid);
759 end Compile_Time_Compare;
761 function Compile_Time_Compare
764 Assume_Valid : Boolean;
765 Rec : Boolean := False) return Compare_Result
767 Ltyp : Entity_Id := Underlying_Type (Etype (L));
768 Rtyp : Entity_Id := Underlying_Type (Etype (R));
769 -- These get reset to the base type for the case of entities where
770 -- Is_Known_Valid is not set. This takes care of handling possible
771 -- invalid representations using the value of the base type, in
772 -- accordance with RM 13.9.1(10).
774 Discard : aliased Uint;
776 procedure Compare_Decompose
780 -- This procedure decomposes the node N into an expression node and a
781 -- signed offset, so that the value of N is equal to the value of R plus
782 -- the value V (which may be negative). If no such decomposition is
783 -- possible, then on return R is a copy of N, and V is set to zero.
785 function Compare_Fixup (N : Node_Id) return Node_Id;
786 -- This function deals with replacing 'Last and 'First references with
787 -- their corresponding type bounds, which we then can compare. The
788 -- argument is the original node, the result is the identity, unless we
789 -- have a 'Last/'First reference in which case the value returned is the
790 -- appropriate type bound.
792 function Is_Known_Valid_Operand (Opnd : Node_Id) return Boolean;
793 -- Even if the context does not assume that values are valid, some
794 -- simple cases can be recognized.
796 function Is_Same_Value (L, R : Node_Id) return Boolean;
797 -- Returns True iff L and R represent expressions that definitely have
798 -- identical (but not necessarily compile time known) values Indeed the
799 -- caller is expected to have already dealt with the cases of compile
800 -- time known values, so these are not tested here.
802 -----------------------
803 -- Compare_Decompose --
804 -----------------------
806 procedure Compare_Decompose
812 if Nkind (N) = N_Op_Add
813 and then Nkind (Right_Opnd (N)) = N_Integer_Literal
816 V := Intval (Right_Opnd (N));
819 elsif Nkind (N) = N_Op_Subtract
820 and then Nkind (Right_Opnd (N)) = N_Integer_Literal
823 V := UI_Negate (Intval (Right_Opnd (N)));
826 elsif Nkind (N) = N_Attribute_Reference then
827 if Attribute_Name (N) = Name_Succ then
828 R := First (Expressions (N));
832 elsif Attribute_Name (N) = Name_Pred then
833 R := First (Expressions (N));
841 end Compare_Decompose;
847 function Compare_Fixup (N : Node_Id) return Node_Id is
853 -- Fixup only required for First/Last attribute reference
855 if Nkind (N) = N_Attribute_Reference
856 and then Nam_In (Attribute_Name (N), Name_First, Name_Last)
858 Xtyp := Etype (Prefix (N));
860 -- If we have no type, then just abandon the attempt to do
861 -- a fixup, this is probably the result of some other error.
867 -- Dereference an access type
869 if Is_Access_Type (Xtyp) then
870 Xtyp := Designated_Type (Xtyp);
873 -- If we don't have an array type at this stage, something is
874 -- peculiar, e.g. another error, and we abandon the attempt at
877 if not Is_Array_Type (Xtyp) then
881 -- Ignore unconstrained array, since bounds are not meaningful
883 if not Is_Constrained (Xtyp) then
887 if Ekind (Xtyp) = E_String_Literal_Subtype then
888 if Attribute_Name (N) = Name_First then
889 return String_Literal_Low_Bound (Xtyp);
892 Make_Integer_Literal (Sloc (N),
893 Intval => Intval (String_Literal_Low_Bound (Xtyp)) +
894 String_Literal_Length (Xtyp));
898 -- Find correct index type
900 Indx := First_Index (Xtyp);
902 if Present (Expressions (N)) then
903 Subs := UI_To_Int (Expr_Value (First (Expressions (N))));
905 for J in 2 .. Subs loop
906 Indx := Next_Index (Indx);
910 Xtyp := Etype (Indx);
912 if Attribute_Name (N) = Name_First then
913 return Type_Low_Bound (Xtyp);
915 return Type_High_Bound (Xtyp);
922 ----------------------------
923 -- Is_Known_Valid_Operand --
924 ----------------------------
926 function Is_Known_Valid_Operand (Opnd : Node_Id) return Boolean is
928 return (Is_Entity_Name (Opnd)
930 (Is_Known_Valid (Entity (Opnd))
931 or else Ekind (Entity (Opnd)) = E_In_Parameter
933 (Ekind (Entity (Opnd)) in Object_Kind
934 and then Present (Current_Value (Entity (Opnd))))))
935 or else Is_OK_Static_Expression (Opnd);
936 end Is_Known_Valid_Operand;
942 function Is_Same_Value (L, R : Node_Id) return Boolean is
943 Lf : constant Node_Id := Compare_Fixup (L);
944 Rf : constant Node_Id := Compare_Fixup (R);
946 function Is_Same_Subscript (L, R : List_Id) return Boolean;
947 -- L, R are the Expressions values from two attribute nodes for First
948 -- or Last attributes. Either may be set to No_List if no expressions
949 -- are present (indicating subscript 1). The result is True if both
950 -- expressions represent the same subscript (note one case is where
951 -- one subscript is missing and the other is explicitly set to 1).
953 -----------------------
954 -- Is_Same_Subscript --
955 -----------------------
957 function Is_Same_Subscript (L, R : List_Id) return Boolean is
963 return Expr_Value (First (R)) = Uint_1;
968 return Expr_Value (First (L)) = Uint_1;
970 return Expr_Value (First (L)) = Expr_Value (First (R));
973 end Is_Same_Subscript;
975 -- Start of processing for Is_Same_Value
978 -- Values are the same if they refer to the same entity and the
979 -- entity is non-volatile. This does not however apply to Float
980 -- types, since we may have two NaN values and they should never
983 -- If the entity is a discriminant, the two expressions may be bounds
984 -- of components of objects of the same discriminated type. The
985 -- values of the discriminants are not static, and therefore the
986 -- result is unknown.
988 -- It would be better to comment individual branches of this test ???
990 if Nkind_In (Lf, N_Identifier, N_Expanded_Name)
991 and then Nkind_In (Rf, N_Identifier, N_Expanded_Name)
992 and then Entity (Lf) = Entity (Rf)
993 and then Ekind (Entity (Lf)) /= E_Discriminant
994 and then Present (Entity (Lf))
995 and then not Is_Floating_Point_Type (Etype (L))
996 and then not Is_Volatile_Reference (L)
997 and then not Is_Volatile_Reference (R)
1001 -- Or if they are compile time known and identical
1003 elsif Compile_Time_Known_Value (Lf)
1005 Compile_Time_Known_Value (Rf)
1006 and then Expr_Value (Lf) = Expr_Value (Rf)
1010 -- False if Nkind of the two nodes is different for remaining cases
1012 elsif Nkind (Lf) /= Nkind (Rf) then
1015 -- True if both 'First or 'Last values applying to the same entity
1016 -- (first and last don't change even if value does). Note that we
1017 -- need this even with the calls to Compare_Fixup, to handle the
1018 -- case of unconstrained array attributes where Compare_Fixup
1019 -- cannot find useful bounds.
1021 elsif Nkind (Lf) = N_Attribute_Reference
1022 and then Attribute_Name (Lf) = Attribute_Name (Rf)
1023 and then Nam_In (Attribute_Name (Lf), Name_First, Name_Last)
1024 and then Nkind_In (Prefix (Lf), N_Identifier, N_Expanded_Name)
1025 and then Nkind_In (Prefix (Rf), N_Identifier, N_Expanded_Name)
1026 and then Entity (Prefix (Lf)) = Entity (Prefix (Rf))
1027 and then Is_Same_Subscript (Expressions (Lf), Expressions (Rf))
1031 -- True if the same selected component from the same record
1033 elsif Nkind (Lf) = N_Selected_Component
1034 and then Selector_Name (Lf) = Selector_Name (Rf)
1035 and then Is_Same_Value (Prefix (Lf), Prefix (Rf))
1039 -- True if the same unary operator applied to the same operand
1041 elsif Nkind (Lf) in N_Unary_Op
1042 and then Is_Same_Value (Right_Opnd (Lf), Right_Opnd (Rf))
1046 -- True if the same binary operator applied to the same operands
1048 elsif Nkind (Lf) in N_Binary_Op
1049 and then Is_Same_Value (Left_Opnd (Lf), Left_Opnd (Rf))
1050 and then Is_Same_Value (Right_Opnd (Lf), Right_Opnd (Rf))
1054 -- All other cases, we can't tell, so return False
1061 -- Start of processing for Compile_Time_Compare
1064 Diff.all := No_Uint;
1066 -- In preanalysis mode, always return Unknown unless the expression
1067 -- is static. It is too early to be thinking we know the result of a
1068 -- comparison, save that judgment for the full analysis. This is
1069 -- particularly important in the case of pre and postconditions, which
1070 -- otherwise can be prematurely collapsed into having True or False
1071 -- conditions when this is inappropriate.
1073 if not (Full_Analysis
1074 or else (Is_OK_Static_Expression (L)
1076 Is_OK_Static_Expression (R)))
1081 -- If either operand could raise constraint error, then we cannot
1082 -- know the result at compile time (since CE may be raised).
1084 if not (Cannot_Raise_Constraint_Error (L)
1086 Cannot_Raise_Constraint_Error (R))
1091 -- Identical operands are most certainly equal
1096 -- If expressions have no types, then do not attempt to determine if
1097 -- they are the same, since something funny is going on. One case in
1098 -- which this happens is during generic template analysis, when bounds
1099 -- are not fully analyzed.
1101 elsif No (Ltyp) or else No (Rtyp) then
1104 -- We do not attempt comparisons for packed arrays represented as
1105 -- modular types, where the semantics of comparison is quite different.
1107 elsif Is_Packed_Array_Impl_Type (Ltyp)
1108 and then Is_Modular_Integer_Type (Ltyp)
1112 -- For access types, the only time we know the result at compile time
1113 -- (apart from identical operands, which we handled already) is if we
1114 -- know one operand is null and the other is not, or both operands are
1117 elsif Is_Access_Type (Ltyp) then
1118 if Known_Null (L) then
1119 if Known_Null (R) then
1121 elsif Known_Non_Null (R) then
1127 elsif Known_Non_Null (L) and then Known_Null (R) then
1134 -- Case where comparison involves two compile time known values
1136 elsif Compile_Time_Known_Value (L)
1138 Compile_Time_Known_Value (R)
1140 -- For the floating-point case, we have to be a little careful, since
1141 -- at compile time we are dealing with universal exact values, but at
1142 -- runtime, these will be in non-exact target form. That's why the
1143 -- returned results are LE and GE below instead of LT and GT.
1145 if Is_Floating_Point_Type (Ltyp)
1147 Is_Floating_Point_Type (Rtyp)
1150 Lo : constant Ureal := Expr_Value_R (L);
1151 Hi : constant Ureal := Expr_Value_R (R);
1162 -- For string types, we have two string literals and we proceed to
1163 -- compare them using the Ada style dictionary string comparison.
1165 elsif not Is_Scalar_Type (Ltyp) then
1167 Lstring : constant String_Id := Strval (Expr_Value_S (L));
1168 Rstring : constant String_Id := Strval (Expr_Value_S (R));
1169 Llen : constant Nat := String_Length (Lstring);
1170 Rlen : constant Nat := String_Length (Rstring);
1173 for J in 1 .. Nat'Min (Llen, Rlen) loop
1175 LC : constant Char_Code := Get_String_Char (Lstring, J);
1176 RC : constant Char_Code := Get_String_Char (Rstring, J);
1188 elsif Llen > Rlen then
1195 -- For remaining scalar cases we know exactly (note that this does
1196 -- include the fixed-point case, where we know the run time integer
1201 Lo : constant Uint := Expr_Value (L);
1202 Hi : constant Uint := Expr_Value (R);
1205 Diff.all := Hi - Lo;
1210 Diff.all := Lo - Hi;
1216 -- Cases where at least one operand is not known at compile time
1219 -- Remaining checks apply only for discrete types
1221 if not Is_Discrete_Type (Ltyp)
1223 not Is_Discrete_Type (Rtyp)
1228 -- Defend against generic types, or actually any expressions that
1229 -- contain a reference to a generic type from within a generic
1230 -- template. We don't want to do any range analysis of such
1231 -- expressions for two reasons. First, the bounds of a generic type
1232 -- itself are junk and cannot be used for any kind of analysis.
1233 -- Second, we may have a case where the range at run time is indeed
1234 -- known, but we don't want to do compile time analysis in the
1235 -- template based on that range since in an instance the value may be
1236 -- static, and able to be elaborated without reference to the bounds
1237 -- of types involved. As an example, consider:
1239 -- (F'Pos (F'Last) + 1) > Integer'Last
1241 -- The expression on the left side of > is Universal_Integer and thus
1242 -- acquires the type Integer for evaluation at run time, and at run
1243 -- time it is true that this condition is always False, but within
1244 -- an instance F may be a type with a static range greater than the
1245 -- range of Integer, and the expression statically evaluates to True.
1247 if References_Generic_Formal_Type (L)
1249 References_Generic_Formal_Type (R)
1254 -- Replace types by base types for the case of values which are not
1255 -- known to have valid representations. This takes care of properly
1256 -- dealing with invalid representations.
1258 if not Assume_Valid then
1259 if not (Is_Entity_Name (L)
1260 and then (Is_Known_Valid (Entity (L))
1261 or else Assume_No_Invalid_Values))
1263 Ltyp := Underlying_Type (Base_Type (Ltyp));
1266 if not (Is_Entity_Name (R)
1267 and then (Is_Known_Valid (Entity (R))
1268 or else Assume_No_Invalid_Values))
1270 Rtyp := Underlying_Type (Base_Type (Rtyp));
1274 -- First attempt is to decompose the expressions to extract a
1275 -- constant offset resulting from the use of any of the forms:
1282 -- Then we see if the two expressions are the same value, and if so
1283 -- the result is obtained by comparing the offsets.
1285 -- Note: the reason we do this test first is that it returns only
1286 -- decisive results (with diff set), where other tests, like the
1287 -- range test, may not be as so decisive. Consider for example
1288 -- J .. J + 1. This code can conclude LT with a difference of 1,
1289 -- even if the range of J is not known.
1298 Compare_Decompose (L, Lnode, Loffs);
1299 Compare_Decompose (R, Rnode, Roffs);
1301 if Is_Same_Value (Lnode, Rnode) then
1302 if Loffs = Roffs then
1304 elsif Loffs < Roffs then
1305 Diff.all := Roffs - Loffs;
1308 Diff.all := Loffs - Roffs;
1314 -- Next, try range analysis and see if operand ranges are disjoint
1322 -- True if each range is a single point
1325 Determine_Range (L, LOK, LLo, LHi, Assume_Valid);
1326 Determine_Range (R, ROK, RLo, RHi, Assume_Valid);
1329 Single := (LLo = LHi) and then (RLo = RHi);
1332 if Single and Assume_Valid then
1333 Diff.all := RLo - LLo;
1338 elsif RHi < LLo then
1339 if Single and Assume_Valid then
1340 Diff.all := LLo - RLo;
1345 elsif Single and then LLo = RLo then
1347 -- If the range includes a single literal and we can assume
1348 -- validity then the result is known even if an operand is
1351 if Assume_Valid then
1357 elsif LHi = RLo then
1360 elsif RHi = LLo then
1363 elsif not Is_Known_Valid_Operand (L)
1364 and then not Assume_Valid
1366 if Is_Same_Value (L, R) then
1373 -- If the range of either operand cannot be determined, nothing
1374 -- further can be inferred.
1381 -- Here is where we check for comparisons against maximum bounds of
1382 -- types, where we know that no value can be outside the bounds of
1383 -- the subtype. Note that this routine is allowed to assume that all
1384 -- expressions are within their subtype bounds. Callers wishing to
1385 -- deal with possibly invalid values must in any case take special
1386 -- steps (e.g. conversions to larger types) to avoid this kind of
1387 -- optimization, which is always considered to be valid. We do not
1388 -- attempt this optimization with generic types, since the type
1389 -- bounds may not be meaningful in this case.
1391 -- We are in danger of an infinite recursion here. It does not seem
1392 -- useful to go more than one level deep, so the parameter Rec is
1393 -- used to protect ourselves against this infinite recursion.
1397 -- See if we can get a decisive check against one operand and a
1398 -- bound of the other operand (four possible tests here). Note
1399 -- that we avoid testing junk bounds of a generic type.
1401 if not Is_Generic_Type (Rtyp) then
1402 case Compile_Time_Compare (L, Type_Low_Bound (Rtyp),
1404 Assume_Valid, Rec => True)
1406 when LT => return LT;
1407 when LE => return LE;
1408 when EQ => return LE;
1409 when others => null;
1412 case Compile_Time_Compare (L, Type_High_Bound (Rtyp),
1414 Assume_Valid, Rec => True)
1416 when GT => return GT;
1417 when GE => return GE;
1418 when EQ => return GE;
1419 when others => null;
1423 if not Is_Generic_Type (Ltyp) then
1424 case Compile_Time_Compare (Type_Low_Bound (Ltyp), R,
1426 Assume_Valid, Rec => True)
1428 when GT => return GT;
1429 when GE => return GE;
1430 when EQ => return GE;
1431 when others => null;
1434 case Compile_Time_Compare (Type_High_Bound (Ltyp), R,
1436 Assume_Valid, Rec => True)
1438 when LT => return LT;
1439 when LE => return LE;
1440 when EQ => return LE;
1441 when others => null;
1446 -- Next attempt is to see if we have an entity compared with a
1447 -- compile time known value, where there is a current value
1448 -- conditional for the entity which can tell us the result.
1452 -- Entity variable (left operand)
1455 -- Value (right operand)
1458 -- If False, we have reversed the operands
1461 -- Comparison operator kind from Get_Current_Value_Condition call
1464 -- Value from Get_Current_Value_Condition call
1469 Result : Compare_Result;
1470 -- Known result before inversion
1473 if Is_Entity_Name (L)
1474 and then Compile_Time_Known_Value (R)
1477 Val := Expr_Value (R);
1480 elsif Is_Entity_Name (R)
1481 and then Compile_Time_Known_Value (L)
1484 Val := Expr_Value (L);
1487 -- That was the last chance at finding a compile time result
1493 Get_Current_Value_Condition (Var, Op, Opn);
1495 -- That was the last chance, so if we got nothing return
1501 Opv := Expr_Value (Opn);
1503 -- We got a comparison, so we might have something interesting
1505 -- Convert LE to LT and GE to GT, just so we have fewer cases
1507 if Op = N_Op_Le then
1511 elsif Op = N_Op_Ge then
1516 -- Deal with equality case
1518 if Op = N_Op_Eq then
1521 elsif Opv < Val then
1527 -- Deal with inequality case
1529 elsif Op = N_Op_Ne then
1536 -- Deal with greater than case
1538 elsif Op = N_Op_Gt then
1541 elsif Opv = Val - 1 then
1547 -- Deal with less than case
1549 else pragma Assert (Op = N_Op_Lt);
1552 elsif Opv = Val + 1 then
1559 -- Deal with inverting result
1563 when GT => return LT;
1564 when GE => return LE;
1565 when LT => return GT;
1566 when LE => return GE;
1567 when others => return Result;
1574 end Compile_Time_Compare;
1576 -------------------------------
1577 -- Compile_Time_Known_Bounds --
1578 -------------------------------
1580 function Compile_Time_Known_Bounds (T : Entity_Id) return Boolean is
1585 if T = Any_Composite or else not Is_Array_Type (T) then
1589 Indx := First_Index (T);
1590 while Present (Indx) loop
1591 Typ := Underlying_Type (Etype (Indx));
1593 -- Never look at junk bounds of a generic type
1595 if Is_Generic_Type (Typ) then
1599 -- Otherwise check bounds for compile time known
1601 if not Compile_Time_Known_Value (Type_Low_Bound (Typ)) then
1603 elsif not Compile_Time_Known_Value (Type_High_Bound (Typ)) then
1611 end Compile_Time_Known_Bounds;
1613 ------------------------------
1614 -- Compile_Time_Known_Value --
1615 ------------------------------
1617 function Compile_Time_Known_Value (Op : Node_Id) return Boolean is
1618 K : constant Node_Kind := Nkind (Op);
1619 CV_Ent : CV_Entry renames CV_Cache (Nat (Op) mod CV_Cache_Size);
1622 -- Never known at compile time if bad type or raises constraint error
1623 -- or empty (latter case occurs only as a result of a previous error).
1626 Check_Error_Detected;
1630 or else Etype (Op) = Any_Type
1631 or else Raises_Constraint_Error (Op)
1636 -- If we have an entity name, then see if it is the name of a constant
1637 -- and if so, test the corresponding constant value, or the name of
1638 -- an enumeration literal, which is always a constant.
1640 if Present (Etype (Op)) and then Is_Entity_Name (Op) then
1642 E : constant Entity_Id := Entity (Op);
1646 -- Never known at compile time if it is a packed array value.
1647 -- We might want to try to evaluate these at compile time one
1648 -- day, but we do not make that attempt now.
1650 if Is_Packed_Array_Impl_Type (Etype (Op)) then
1654 if Ekind (E) = E_Enumeration_Literal then
1657 elsif Ekind (E) = E_Constant then
1658 V := Constant_Value (E);
1659 return Present (V) and then Compile_Time_Known_Value (V);
1663 -- We have a value, see if it is compile time known
1666 -- Integer literals are worth storing in the cache
1668 if K = N_Integer_Literal then
1670 CV_Ent.V := Intval (Op);
1673 -- Other literals and NULL are known at compile time
1676 Nkind_In (K, N_Character_Literal,
1685 -- If we fall through, not known at compile time
1689 -- If we get an exception while trying to do this test, then some error
1690 -- has occurred, and we simply say that the value is not known after all
1695 end Compile_Time_Known_Value;
1697 --------------------------------------
1698 -- Compile_Time_Known_Value_Or_Aggr --
1699 --------------------------------------
1701 function Compile_Time_Known_Value_Or_Aggr (Op : Node_Id) return Boolean is
1703 -- If we have an entity name, then see if it is the name of a constant
1704 -- and if so, test the corresponding constant value, or the name of
1705 -- an enumeration literal, which is always a constant.
1707 if Is_Entity_Name (Op) then
1709 E : constant Entity_Id := Entity (Op);
1713 if Ekind (E) = E_Enumeration_Literal then
1716 elsif Ekind (E) /= E_Constant then
1720 V := Constant_Value (E);
1722 and then Compile_Time_Known_Value_Or_Aggr (V);
1726 -- We have a value, see if it is compile time known
1729 if Compile_Time_Known_Value (Op) then
1732 elsif Nkind (Op) = N_Aggregate then
1734 if Present (Expressions (Op)) then
1738 Expr := First (Expressions (Op));
1739 while Present (Expr) loop
1740 if not Compile_Time_Known_Value_Or_Aggr (Expr) then
1749 if Present (Component_Associations (Op)) then
1754 Cass := First (Component_Associations (Op));
1755 while Present (Cass) loop
1757 Compile_Time_Known_Value_Or_Aggr (Expression (Cass))
1769 -- All other types of values are not known at compile time
1776 end Compile_Time_Known_Value_Or_Aggr;
1778 ---------------------------------------
1779 -- CRT_Safe_Compile_Time_Known_Value --
1780 ---------------------------------------
1782 function CRT_Safe_Compile_Time_Known_Value (Op : Node_Id) return Boolean is
1784 if (Configurable_Run_Time_Mode or No_Run_Time_Mode)
1785 and then not Is_OK_Static_Expression (Op)
1789 return Compile_Time_Known_Value (Op);
1791 end CRT_Safe_Compile_Time_Known_Value;
1797 -- This is only called for actuals of functions that are not predefined
1798 -- operators (which have already been rewritten as operators at this
1799 -- stage), so the call can never be folded, and all that needs doing for
1800 -- the actual is to do the check for a non-static context.
1802 procedure Eval_Actual (N : Node_Id) is
1804 Check_Non_Static_Context (N);
1807 --------------------
1808 -- Eval_Allocator --
1809 --------------------
1811 -- Allocators are never static, so all we have to do is to do the
1812 -- check for a non-static context if an expression is present.
1814 procedure Eval_Allocator (N : Node_Id) is
1815 Expr : constant Node_Id := Expression (N);
1817 if Nkind (Expr) = N_Qualified_Expression then
1818 Check_Non_Static_Context (Expression (Expr));
1822 ------------------------
1823 -- Eval_Arithmetic_Op --
1824 ------------------------
1826 -- Arithmetic operations are static functions, so the result is static
1827 -- if both operands are static (RM 4.9(7), 4.9(20)).
1829 procedure Eval_Arithmetic_Op (N : Node_Id) is
1830 Left : constant Node_Id := Left_Opnd (N);
1831 Right : constant Node_Id := Right_Opnd (N);
1832 Ltype : constant Entity_Id := Etype (Left);
1833 Rtype : constant Entity_Id := Etype (Right);
1834 Otype : Entity_Id := Empty;
1839 -- If not foldable we are done
1841 Test_Expression_Is_Foldable (N, Left, Right, Stat, Fold);
1847 -- Otherwise attempt to fold
1849 if Is_Universal_Numeric_Type (Etype (Left))
1851 Is_Universal_Numeric_Type (Etype (Right))
1853 Otype := Find_Universal_Operator_Type (N);
1856 -- Fold for cases where both operands are of integer type
1858 if Is_Integer_Type (Ltype) and then Is_Integer_Type (Rtype) then
1860 Left_Int : constant Uint := Expr_Value (Left);
1861 Right_Int : constant Uint := Expr_Value (Right);
1867 Result := Left_Int + Right_Int;
1869 when N_Op_Subtract =>
1870 Result := Left_Int - Right_Int;
1872 when N_Op_Multiply =>
1875 (Num_Bits (Left_Int) + Num_Bits (Right_Int)))
1877 Result := Left_Int * Right_Int;
1884 -- The exception Constraint_Error is raised by integer
1885 -- division, rem and mod if the right operand is zero.
1887 if Right_Int = 0 then
1888 Apply_Compile_Time_Constraint_Error
1889 (N, "division by zero", CE_Divide_By_Zero,
1891 Set_Raises_Constraint_Error (N);
1894 -- Otherwise we can do the division
1897 Result := Left_Int / Right_Int;
1902 -- The exception Constraint_Error is raised by integer
1903 -- division, rem and mod if the right operand is zero.
1905 if Right_Int = 0 then
1906 Apply_Compile_Time_Constraint_Error
1907 (N, "mod with zero divisor", CE_Divide_By_Zero,
1911 Result := Left_Int mod Right_Int;
1916 -- The exception Constraint_Error is raised by integer
1917 -- division, rem and mod if the right operand is zero.
1919 if Right_Int = 0 then
1920 Apply_Compile_Time_Constraint_Error
1921 (N, "rem with zero divisor", CE_Divide_By_Zero,
1926 Result := Left_Int rem Right_Int;
1930 raise Program_Error;
1933 -- Adjust the result by the modulus if the type is a modular type
1935 if Is_Modular_Integer_Type (Ltype) then
1936 Result := Result mod Modulus (Ltype);
1938 -- For a signed integer type, check non-static overflow
1940 elsif (not Stat) and then Is_Signed_Integer_Type (Ltype) then
1942 BT : constant Entity_Id := Base_Type (Ltype);
1943 Lo : constant Uint := Expr_Value (Type_Low_Bound (BT));
1944 Hi : constant Uint := Expr_Value (Type_High_Bound (BT));
1946 if Result < Lo or else Result > Hi then
1947 Apply_Compile_Time_Constraint_Error
1948 (N, "value not in range of }??",
1949 CE_Overflow_Check_Failed,
1956 -- If we get here we can fold the result
1958 Fold_Uint (N, Result, Stat);
1961 -- Cases where at least one operand is a real. We handle the cases of
1962 -- both reals, or mixed/real integer cases (the latter happen only for
1963 -- divide and multiply, and the result is always real).
1965 elsif Is_Real_Type (Ltype) or else Is_Real_Type (Rtype) then
1972 if Is_Real_Type (Ltype) then
1973 Left_Real := Expr_Value_R (Left);
1975 Left_Real := UR_From_Uint (Expr_Value (Left));
1978 if Is_Real_Type (Rtype) then
1979 Right_Real := Expr_Value_R (Right);
1981 Right_Real := UR_From_Uint (Expr_Value (Right));
1984 if Nkind (N) = N_Op_Add then
1985 Result := Left_Real + Right_Real;
1987 elsif Nkind (N) = N_Op_Subtract then
1988 Result := Left_Real - Right_Real;
1990 elsif Nkind (N) = N_Op_Multiply then
1991 Result := Left_Real * Right_Real;
1993 else pragma Assert (Nkind (N) = N_Op_Divide);
1994 if UR_Is_Zero (Right_Real) then
1995 Apply_Compile_Time_Constraint_Error
1996 (N, "division by zero", CE_Divide_By_Zero);
2000 Result := Left_Real / Right_Real;
2003 Fold_Ureal (N, Result, Stat);
2007 -- If the operator was resolved to a specific type, make sure that type
2008 -- is frozen even if the expression is folded into a literal (which has
2009 -- a universal type).
2011 if Present (Otype) then
2012 Freeze_Before (N, Otype);
2014 end Eval_Arithmetic_Op;
2016 ----------------------------
2017 -- Eval_Character_Literal --
2018 ----------------------------
2020 -- Nothing to be done
2022 procedure Eval_Character_Literal (N : Node_Id) is
2023 pragma Warnings (Off, N);
2026 end Eval_Character_Literal;
2032 -- Static function calls are either calls to predefined operators
2033 -- with static arguments, or calls to functions that rename a literal.
2034 -- Only the latter case is handled here, predefined operators are
2035 -- constant-folded elsewhere.
2037 -- If the function is itself inherited (see 7423-001) the literal of
2038 -- the parent type must be explicitly converted to the return type
2041 procedure Eval_Call (N : Node_Id) is
2042 Loc : constant Source_Ptr := Sloc (N);
2043 Typ : constant Entity_Id := Etype (N);
2047 if Nkind (N) = N_Function_Call
2048 and then No (Parameter_Associations (N))
2049 and then Is_Entity_Name (Name (N))
2050 and then Present (Alias (Entity (Name (N))))
2051 and then Is_Enumeration_Type (Base_Type (Typ))
2053 Lit := Ultimate_Alias (Entity (Name (N)));
2055 if Ekind (Lit) = E_Enumeration_Literal then
2056 if Base_Type (Etype (Lit)) /= Base_Type (Typ) then
2058 (N, Convert_To (Typ, New_Occurrence_Of (Lit, Loc)));
2060 Rewrite (N, New_Occurrence_Of (Lit, Loc));
2068 --------------------------
2069 -- Eval_Case_Expression --
2070 --------------------------
2072 -- A conditional expression is static if all its conditions and dependent
2073 -- expressions are static. Note that we do not care if the dependent
2074 -- expressions raise CE, except for the one that will be selected.
2076 procedure Eval_Case_Expression (N : Node_Id) is
2081 Set_Is_Static_Expression (N, False);
2083 if not Is_Static_Expression (Expression (N)) then
2084 Check_Non_Static_Context (Expression (N));
2088 -- First loop, make sure all the alternatives are static expressions
2089 -- none of which raise Constraint_Error. We make the constraint error
2090 -- check because part of the legality condition for a correct static
2091 -- case expression is that the cases are covered, like any other case
2092 -- expression. And we can't do that if any of the conditions raise an
2093 -- exception, so we don't even try to evaluate if that is the case.
2095 Alt := First (Alternatives (N));
2096 while Present (Alt) loop
2098 -- The expression must be static, but we don't care at this stage
2099 -- if it raises Constraint_Error (the alternative might not match,
2100 -- in which case the expression is statically unevaluated anyway).
2102 if not Is_Static_Expression (Expression (Alt)) then
2103 Check_Non_Static_Context (Expression (Alt));
2107 -- The choices of a case always have to be static, and cannot raise
2108 -- an exception. If this condition is not met, then the expression
2109 -- is plain illegal, so just abandon evaluation attempts. No need
2110 -- to check non-static context when we have something illegal anyway.
2112 if not Is_OK_Static_Choice_List (Discrete_Choices (Alt)) then
2119 -- OK, if the above loop gets through it means that all choices are OK
2120 -- static (don't raise exceptions), so the whole case is static, and we
2121 -- can find the matching alternative.
2123 Set_Is_Static_Expression (N);
2125 -- Now to deal with propagating a possible constraint error
2127 -- If the selecting expression raises CE, propagate and we are done
2129 if Raises_Constraint_Error (Expression (N)) then
2130 Set_Raises_Constraint_Error (N);
2132 -- Otherwise we need to check the alternatives to find the matching
2133 -- one. CE's in other than the matching one are not relevant. But we
2134 -- do need to check the matching one. Unlike the first loop, we do not
2135 -- have to go all the way through, when we find the matching one, quit.
2138 Alt := First (Alternatives (N));
2141 -- We must find a match among the alternatives. If not, this must
2142 -- be due to other errors, so just ignore, leaving as non-static.
2145 Set_Is_Static_Expression (N, False);
2149 -- Otherwise loop through choices of this alternative
2151 Choice := First (Discrete_Choices (Alt));
2152 while Present (Choice) loop
2154 -- If we find a matching choice, then the Expression of this
2155 -- alternative replaces N (Raises_Constraint_Error flag is
2156 -- included, so we don't have to special case that).
2158 if Choice_Matches (Expression (N), Choice) = Match then
2159 Rewrite (N, Relocate_Node (Expression (Alt)));
2169 end Eval_Case_Expression;
2171 ------------------------
2172 -- Eval_Concatenation --
2173 ------------------------
2175 -- Concatenation is a static function, so the result is static if both
2176 -- operands are static (RM 4.9(7), 4.9(21)).
2178 procedure Eval_Concatenation (N : Node_Id) is
2179 Left : constant Node_Id := Left_Opnd (N);
2180 Right : constant Node_Id := Right_Opnd (N);
2181 C_Typ : constant Entity_Id := Root_Type (Component_Type (Etype (N)));
2186 -- Concatenation is never static in Ada 83, so if Ada 83 check operand
2187 -- non-static context.
2189 if Ada_Version = Ada_83
2190 and then Comes_From_Source (N)
2192 Check_Non_Static_Context (Left);
2193 Check_Non_Static_Context (Right);
2197 -- If not foldable we are done. In principle concatenation that yields
2198 -- any string type is static (i.e. an array type of character types).
2199 -- However, character types can include enumeration literals, and
2200 -- concatenation in that case cannot be described by a literal, so we
2201 -- only consider the operation static if the result is an array of
2202 -- (a descendant of) a predefined character type.
2204 Test_Expression_Is_Foldable (N, Left, Right, Stat, Fold);
2206 if not (Is_Standard_Character_Type (C_Typ) and then Fold) then
2207 Set_Is_Static_Expression (N, False);
2211 -- Compile time string concatenation
2213 -- ??? Note that operands that are aggregates can be marked as static,
2214 -- so we should attempt at a later stage to fold concatenations with
2218 Left_Str : constant Node_Id := Get_String_Val (Left);
2220 Right_Str : constant Node_Id := Get_String_Val (Right);
2221 Folded_Val : String_Id;
2224 -- Establish new string literal, and store left operand. We make
2225 -- sure to use the special Start_String that takes an operand if
2226 -- the left operand is a string literal. Since this is optimized
2227 -- in the case where that is the most recently created string
2228 -- literal, we ensure efficient time/space behavior for the
2229 -- case of a concatenation of a series of string literals.
2231 if Nkind (Left_Str) = N_String_Literal then
2232 Left_Len := String_Length (Strval (Left_Str));
2234 -- If the left operand is the empty string, and the right operand
2235 -- is a string literal (the case of "" & "..."), the result is the
2236 -- value of the right operand. This optimization is important when
2237 -- Is_Folded_In_Parser, to avoid copying an enormous right
2240 if Left_Len = 0 and then Nkind (Right_Str) = N_String_Literal then
2241 Folded_Val := Strval (Right_Str);
2243 Start_String (Strval (Left_Str));
2248 Store_String_Char (UI_To_CC (Char_Literal_Value (Left_Str)));
2252 -- Now append the characters of the right operand, unless we
2253 -- optimized the "" & "..." case above.
2255 if Nkind (Right_Str) = N_String_Literal then
2256 if Left_Len /= 0 then
2257 Store_String_Chars (Strval (Right_Str));
2258 Folded_Val := End_String;
2261 Store_String_Char (UI_To_CC (Char_Literal_Value (Right_Str)));
2262 Folded_Val := End_String;
2265 Set_Is_Static_Expression (N, Stat);
2267 -- If left operand is the empty string, the result is the
2268 -- right operand, including its bounds if anomalous.
2271 and then Is_Array_Type (Etype (Right))
2272 and then Etype (Right) /= Any_String
2274 Set_Etype (N, Etype (Right));
2277 Fold_Str (N, Folded_Val, Static => Stat);
2279 end Eval_Concatenation;
2281 ----------------------
2282 -- Eval_Entity_Name --
2283 ----------------------
2285 -- This procedure is used for identifiers and expanded names other than
2286 -- named numbers (see Eval_Named_Integer, Eval_Named_Real. These are
2287 -- static if they denote a static constant (RM 4.9(6)) or if the name
2288 -- denotes an enumeration literal (RM 4.9(22)).
2290 procedure Eval_Entity_Name (N : Node_Id) is
2291 Def_Id : constant Entity_Id := Entity (N);
2295 -- Enumeration literals are always considered to be constants
2296 -- and cannot raise constraint error (RM 4.9(22)).
2298 if Ekind (Def_Id) = E_Enumeration_Literal then
2299 Set_Is_Static_Expression (N);
2302 -- A name is static if it denotes a static constant (RM 4.9(5)), and
2303 -- we also copy Raise_Constraint_Error. Notice that even if non-static,
2304 -- it does not violate 10.2.1(8) here, since this is not a variable.
2306 elsif Ekind (Def_Id) = E_Constant then
2308 -- Deferred constants must always be treated as nonstatic outside the
2309 -- scope of their full view.
2311 if Present (Full_View (Def_Id))
2312 and then not In_Open_Scopes (Scope (Def_Id))
2316 Val := Constant_Value (Def_Id);
2319 if Present (Val) then
2320 Set_Is_Static_Expression
2321 (N, Is_Static_Expression (Val)
2322 and then Is_Static_Subtype (Etype (Def_Id)));
2323 Set_Raises_Constraint_Error (N, Raises_Constraint_Error (Val));
2325 if not Is_Static_Expression (N)
2326 and then not Is_Generic_Type (Etype (N))
2328 Validate_Static_Object_Name (N);
2331 -- Mark constant condition in SCOs
2334 and then Comes_From_Source (N)
2335 and then Is_Boolean_Type (Etype (Def_Id))
2336 and then Compile_Time_Known_Value (N)
2338 Set_SCO_Condition (N, Expr_Value_E (N) = Standard_True);
2345 -- Fall through if the name is not static
2347 Validate_Static_Object_Name (N);
2348 end Eval_Entity_Name;
2350 ------------------------
2351 -- Eval_If_Expression --
2352 ------------------------
2354 -- We can fold to a static expression if the condition and both dependent
2355 -- expressions are static. Otherwise, the only required processing is to do
2356 -- the check for non-static context for the then and else expressions.
2358 procedure Eval_If_Expression (N : Node_Id) is
2359 Condition : constant Node_Id := First (Expressions (N));
2360 Then_Expr : constant Node_Id := Next (Condition);
2361 Else_Expr : constant Node_Id := Next (Then_Expr);
2363 Non_Result : Node_Id;
2365 Rstat : constant Boolean :=
2366 Is_Static_Expression (Condition)
2368 Is_Static_Expression (Then_Expr)
2370 Is_Static_Expression (Else_Expr);
2371 -- True if result is static
2374 -- If result not static, nothing to do, otherwise set static result
2379 Set_Is_Static_Expression (N);
2382 -- If any operand is Any_Type, just propagate to result and do not try
2383 -- to fold, this prevents cascaded errors.
2385 if Etype (Condition) = Any_Type or else
2386 Etype (Then_Expr) = Any_Type or else
2387 Etype (Else_Expr) = Any_Type
2389 Set_Etype (N, Any_Type);
2390 Set_Is_Static_Expression (N, False);
2394 -- If condition raises constraint error then we have already signaled
2395 -- an error, and we just propagate to the result and do not fold.
2397 if Raises_Constraint_Error (Condition) then
2398 Set_Raises_Constraint_Error (N);
2402 -- Static case where we can fold. Note that we don't try to fold cases
2403 -- where the condition is known at compile time, but the result is
2404 -- non-static. This avoids possible cases of infinite recursion where
2405 -- the expander puts in a redundant test and we remove it. Instead we
2406 -- deal with these cases in the expander.
2408 -- Select result operand
2410 if Is_True (Expr_Value (Condition)) then
2411 Result := Then_Expr;
2412 Non_Result := Else_Expr;
2414 Result := Else_Expr;
2415 Non_Result := Then_Expr;
2418 -- Note that it does not matter if the non-result operand raises a
2419 -- Constraint_Error, but if the result raises constraint error then we
2420 -- replace the node with a raise constraint error. This will properly
2421 -- propagate Raises_Constraint_Error since this flag is set in Result.
2423 if Raises_Constraint_Error (Result) then
2424 Rewrite_In_Raise_CE (N, Result);
2425 Check_Non_Static_Context (Non_Result);
2427 -- Otherwise the result operand replaces the original node
2430 Rewrite (N, Relocate_Node (Result));
2431 Set_Is_Static_Expression (N);
2433 end Eval_If_Expression;
2435 ----------------------------
2436 -- Eval_Indexed_Component --
2437 ----------------------------
2439 -- Indexed components are never static, so we need to perform the check
2440 -- for non-static context on the index values. Then, we check if the
2441 -- value can be obtained at compile time, even though it is non-static.
2443 procedure Eval_Indexed_Component (N : Node_Id) is
2447 -- Check for non-static context on index values
2449 Expr := First (Expressions (N));
2450 while Present (Expr) loop
2451 Check_Non_Static_Context (Expr);
2455 -- If the indexed component appears in an object renaming declaration
2456 -- then we do not want to try to evaluate it, since in this case we
2457 -- need the identity of the array element.
2459 if Nkind (Parent (N)) = N_Object_Renaming_Declaration then
2462 -- Similarly if the indexed component appears as the prefix of an
2463 -- attribute we don't want to evaluate it, because at least for
2464 -- some cases of attributes we need the identify (e.g. Access, Size)
2466 elsif Nkind (Parent (N)) = N_Attribute_Reference then
2470 -- Note: there are other cases, such as the left side of an assignment,
2471 -- or an OUT parameter for a call, where the replacement results in the
2472 -- illegal use of a constant, But these cases are illegal in the first
2473 -- place, so the replacement, though silly, is harmless.
2475 -- Now see if this is a constant array reference
2477 if List_Length (Expressions (N)) = 1
2478 and then Is_Entity_Name (Prefix (N))
2479 and then Ekind (Entity (Prefix (N))) = E_Constant
2480 and then Present (Constant_Value (Entity (Prefix (N))))
2483 Loc : constant Source_Ptr := Sloc (N);
2484 Arr : constant Node_Id := Constant_Value (Entity (Prefix (N)));
2485 Sub : constant Node_Id := First (Expressions (N));
2491 -- Linear one's origin subscript value for array reference
2494 -- Lower bound of the first array index
2497 -- Value from constant array
2500 Atyp := Etype (Arr);
2502 if Is_Access_Type (Atyp) then
2503 Atyp := Designated_Type (Atyp);
2506 -- If we have an array type (we should have but perhaps there are
2507 -- error cases where this is not the case), then see if we can do
2508 -- a constant evaluation of the array reference.
2510 if Is_Array_Type (Atyp) and then Atyp /= Any_Composite then
2511 if Ekind (Atyp) = E_String_Literal_Subtype then
2512 Lbd := String_Literal_Low_Bound (Atyp);
2514 Lbd := Type_Low_Bound (Etype (First_Index (Atyp)));
2517 if Compile_Time_Known_Value (Sub)
2518 and then Nkind (Arr) = N_Aggregate
2519 and then Compile_Time_Known_Value (Lbd)
2520 and then Is_Discrete_Type (Component_Type (Atyp))
2522 Lin := UI_To_Int (Expr_Value (Sub) - Expr_Value (Lbd)) + 1;
2524 if List_Length (Expressions (Arr)) >= Lin then
2525 Elm := Pick (Expressions (Arr), Lin);
2527 -- If the resulting expression is compile time known,
2528 -- then we can rewrite the indexed component with this
2529 -- value, being sure to mark the result as non-static.
2530 -- We also reset the Sloc, in case this generates an
2531 -- error later on (e.g. 136'Access).
2533 if Compile_Time_Known_Value (Elm) then
2534 Rewrite (N, Duplicate_Subexpr_No_Checks (Elm));
2535 Set_Is_Static_Expression (N, False);
2540 -- We can also constant-fold if the prefix is a string literal.
2541 -- This will be useful in an instantiation or an inlining.
2543 elsif Compile_Time_Known_Value (Sub)
2544 and then Nkind (Arr) = N_String_Literal
2545 and then Compile_Time_Known_Value (Lbd)
2546 and then Expr_Value (Lbd) = 1
2547 and then Expr_Value (Sub) <=
2548 String_Literal_Length (Etype (Arr))
2551 C : constant Char_Code :=
2552 Get_String_Char (Strval (Arr),
2553 UI_To_Int (Expr_Value (Sub)));
2555 Set_Character_Literal_Name (C);
2558 Make_Character_Literal (Loc,
2560 Char_Literal_Value => UI_From_CC (C));
2561 Set_Etype (Elm, Component_Type (Atyp));
2562 Rewrite (N, Duplicate_Subexpr_No_Checks (Elm));
2563 Set_Is_Static_Expression (N, False);
2569 end Eval_Indexed_Component;
2571 --------------------------
2572 -- Eval_Integer_Literal --
2573 --------------------------
2575 -- Numeric literals are static (RM 4.9(1)), and have already been marked
2576 -- as static by the analyzer. The reason we did it that early is to allow
2577 -- the possibility of turning off the Is_Static_Expression flag after
2578 -- analysis, but before resolution, when integer literals are generated in
2579 -- the expander that do not correspond to static expressions.
2581 procedure Eval_Integer_Literal (N : Node_Id) is
2582 T : constant Entity_Id := Etype (N);
2584 function In_Any_Integer_Context return Boolean;
2585 -- If the literal is resolved with a specific type in a context where
2586 -- the expected type is Any_Integer, there are no range checks on the
2587 -- literal. By the time the literal is evaluated, it carries the type
2588 -- imposed by the enclosing expression, and we must recover the context
2589 -- to determine that Any_Integer is meant.
2591 ----------------------------
2592 -- In_Any_Integer_Context --
2593 ----------------------------
2595 function In_Any_Integer_Context return Boolean is
2596 Par : constant Node_Id := Parent (N);
2597 K : constant Node_Kind := Nkind (Par);
2600 -- Any_Integer also appears in digits specifications for real types,
2601 -- but those have bounds smaller that those of any integer base type,
2602 -- so we can safely ignore these cases.
2604 return Nkind_In (K, N_Number_Declaration,
2605 N_Attribute_Reference,
2606 N_Attribute_Definition_Clause,
2607 N_Modular_Type_Definition,
2608 N_Signed_Integer_Type_Definition);
2609 end In_Any_Integer_Context;
2611 -- Start of processing for Eval_Integer_Literal
2615 -- If the literal appears in a non-expression context, then it is
2616 -- certainly appearing in a non-static context, so check it. This is
2617 -- actually a redundant check, since Check_Non_Static_Context would
2618 -- check it, but it seems worth while avoiding the call.
2620 if Nkind (Parent (N)) not in N_Subexpr
2621 and then not In_Any_Integer_Context
2623 Check_Non_Static_Context (N);
2626 -- Modular integer literals must be in their base range
2628 if Is_Modular_Integer_Type (T)
2629 and then Is_Out_Of_Range (N, Base_Type (T), Assume_Valid => True)
2633 end Eval_Integer_Literal;
2635 ---------------------
2636 -- Eval_Logical_Op --
2637 ---------------------
2639 -- Logical operations are static functions, so the result is potentially
2640 -- static if both operands are potentially static (RM 4.9(7), 4.9(20)).
2642 procedure Eval_Logical_Op (N : Node_Id) is
2643 Left : constant Node_Id := Left_Opnd (N);
2644 Right : constant Node_Id := Right_Opnd (N);
2649 -- If not foldable we are done
2651 Test_Expression_Is_Foldable (N, Left, Right, Stat, Fold);
2657 -- Compile time evaluation of logical operation
2660 Left_Int : constant Uint := Expr_Value (Left);
2661 Right_Int : constant Uint := Expr_Value (Right);
2664 if Is_Modular_Integer_Type (Etype (N)) then
2666 Left_Bits : Bits (0 .. UI_To_Int (Esize (Etype (N))) - 1);
2667 Right_Bits : Bits (0 .. UI_To_Int (Esize (Etype (N))) - 1);
2670 To_Bits (Left_Int, Left_Bits);
2671 To_Bits (Right_Int, Right_Bits);
2673 -- Note: should really be able to use array ops instead of
2674 -- these loops, but they weren't working at the time ???
2676 if Nkind (N) = N_Op_And then
2677 for J in Left_Bits'Range loop
2678 Left_Bits (J) := Left_Bits (J) and Right_Bits (J);
2681 elsif Nkind (N) = N_Op_Or then
2682 for J in Left_Bits'Range loop
2683 Left_Bits (J) := Left_Bits (J) or Right_Bits (J);
2687 pragma Assert (Nkind (N) = N_Op_Xor);
2689 for J in Left_Bits'Range loop
2690 Left_Bits (J) := Left_Bits (J) xor Right_Bits (J);
2694 Fold_Uint (N, From_Bits (Left_Bits, Etype (N)), Stat);
2698 pragma Assert (Is_Boolean_Type (Etype (N)));
2700 if Nkind (N) = N_Op_And then
2702 Test (Is_True (Left_Int) and then Is_True (Right_Int)), Stat);
2704 elsif Nkind (N) = N_Op_Or then
2706 Test (Is_True (Left_Int) or else Is_True (Right_Int)), Stat);
2709 pragma Assert (Nkind (N) = N_Op_Xor);
2711 Test (Is_True (Left_Int) xor Is_True (Right_Int)), Stat);
2715 end Eval_Logical_Op;
2717 ------------------------
2718 -- Eval_Membership_Op --
2719 ------------------------
2721 -- A membership test is potentially static if the expression is static, and
2722 -- the range is a potentially static range, or is a subtype mark denoting a
2723 -- static subtype (RM 4.9(12)).
2725 procedure Eval_Membership_Op (N : Node_Id) is
2726 Alts : constant List_Id := Alternatives (N);
2727 Choice : constant Node_Id := Right_Opnd (N);
2728 Expr : constant Node_Id := Left_Opnd (N);
2729 Result : Match_Result;
2732 -- Ignore if error in either operand, except to make sure that Any_Type
2733 -- is properly propagated to avoid junk cascaded errors.
2735 if Etype (Expr) = Any_Type
2736 or else (Present (Choice) and then Etype (Choice) = Any_Type)
2738 Set_Etype (N, Any_Type);
2742 -- If left operand non-static, then nothing to do
2744 if not Is_Static_Expression (Expr) then
2748 -- If choice is non-static, left operand is in non-static context
2750 if (Present (Choice) and then not Is_Static_Choice (Choice))
2751 or else (Present (Alts) and then not Is_Static_Choice_List (Alts))
2753 Check_Non_Static_Context (Expr);
2757 -- Otherwise we definitely have a static expression
2759 Set_Is_Static_Expression (N);
2761 -- If left operand raises constraint error, propagate and we are done
2763 if Raises_Constraint_Error (Expr) then
2764 Set_Raises_Constraint_Error (N, True);
2769 if Present (Choice) then
2770 Result := Choice_Matches (Expr, Choice);
2772 Result := Choices_Match (Expr, Alts);
2775 -- If result is Non_Static, it means that we raise Constraint_Error,
2776 -- since we already tested that the operands were themselves static.
2778 if Result = Non_Static then
2779 Set_Raises_Constraint_Error (N);
2781 -- Otherwise we have our result (flipped if NOT IN case)
2785 (N, Test ((Result = Match) xor (Nkind (N) = N_Not_In)), True);
2786 Warn_On_Known_Condition (N);
2789 end Eval_Membership_Op;
2791 ------------------------
2792 -- Eval_Named_Integer --
2793 ------------------------
2795 procedure Eval_Named_Integer (N : Node_Id) is
2798 Expr_Value (Expression (Declaration_Node (Entity (N)))), True);
2799 end Eval_Named_Integer;
2801 ---------------------
2802 -- Eval_Named_Real --
2803 ---------------------
2805 procedure Eval_Named_Real (N : Node_Id) is
2808 Expr_Value_R (Expression (Declaration_Node (Entity (N)))), True);
2809 end Eval_Named_Real;
2815 -- Exponentiation is a static functions, so the result is potentially
2816 -- static if both operands are potentially static (RM 4.9(7), 4.9(20)).
2818 procedure Eval_Op_Expon (N : Node_Id) is
2819 Left : constant Node_Id := Left_Opnd (N);
2820 Right : constant Node_Id := Right_Opnd (N);
2825 -- If not foldable we are done
2827 Test_Expression_Is_Foldable
2828 (N, Left, Right, Stat, Fold, CRT_Safe => True);
2830 -- Return if not foldable
2836 if Configurable_Run_Time_Mode and not Stat then
2840 -- Fold exponentiation operation
2843 Right_Int : constant Uint := Expr_Value (Right);
2848 if Is_Integer_Type (Etype (Left)) then
2850 Left_Int : constant Uint := Expr_Value (Left);
2854 -- Exponentiation of an integer raises Constraint_Error for a
2855 -- negative exponent (RM 4.5.6).
2857 if Right_Int < 0 then
2858 Apply_Compile_Time_Constraint_Error
2859 (N, "integer exponent negative", CE_Range_Check_Failed,
2864 if OK_Bits (N, Num_Bits (Left_Int) * Right_Int) then
2865 Result := Left_Int ** Right_Int;
2870 if Is_Modular_Integer_Type (Etype (N)) then
2871 Result := Result mod Modulus (Etype (N));
2874 Fold_Uint (N, Result, Stat);
2882 Left_Real : constant Ureal := Expr_Value_R (Left);
2885 -- Cannot have a zero base with a negative exponent
2887 if UR_Is_Zero (Left_Real) then
2889 if Right_Int < 0 then
2890 Apply_Compile_Time_Constraint_Error
2891 (N, "zero ** negative integer", CE_Range_Check_Failed,
2895 Fold_Ureal (N, Ureal_0, Stat);
2899 Fold_Ureal (N, Left_Real ** Right_Int, Stat);
2910 -- The not operation is a static functions, so the result is potentially
2911 -- static if the operand is potentially static (RM 4.9(7), 4.9(20)).
2913 procedure Eval_Op_Not (N : Node_Id) is
2914 Right : constant Node_Id := Right_Opnd (N);
2919 -- If not foldable we are done
2921 Test_Expression_Is_Foldable (N, Right, Stat, Fold);
2927 -- Fold not operation
2930 Rint : constant Uint := Expr_Value (Right);
2931 Typ : constant Entity_Id := Etype (N);
2934 -- Negation is equivalent to subtracting from the modulus minus one.
2935 -- For a binary modulus this is equivalent to the ones-complement of
2936 -- the original value. For a nonbinary modulus this is an arbitrary
2937 -- but consistent definition.
2939 if Is_Modular_Integer_Type (Typ) then
2940 Fold_Uint (N, Modulus (Typ) - 1 - Rint, Stat);
2941 else pragma Assert (Is_Boolean_Type (Typ));
2942 Fold_Uint (N, Test (not Is_True (Rint)), Stat);
2945 Set_Is_Static_Expression (N, Stat);
2949 -------------------------------
2950 -- Eval_Qualified_Expression --
2951 -------------------------------
2953 -- A qualified expression is potentially static if its subtype mark denotes
2954 -- a static subtype and its expression is potentially static (RM 4.9 (11)).
2956 procedure Eval_Qualified_Expression (N : Node_Id) is
2957 Operand : constant Node_Id := Expression (N);
2958 Target_Type : constant Entity_Id := Entity (Subtype_Mark (N));
2965 -- Can only fold if target is string or scalar and subtype is static.
2966 -- Also, do not fold if our parent is an allocator (this is because the
2967 -- qualified expression is really part of the syntactic structure of an
2968 -- allocator, and we do not want to end up with something that
2969 -- corresponds to "new 1" where the 1 is the result of folding a
2970 -- qualified expression).
2972 if not Is_Static_Subtype (Target_Type)
2973 or else Nkind (Parent (N)) = N_Allocator
2975 Check_Non_Static_Context (Operand);
2977 -- If operand is known to raise constraint_error, set the flag on the
2978 -- expression so it does not get optimized away.
2980 if Nkind (Operand) = N_Raise_Constraint_Error then
2981 Set_Raises_Constraint_Error (N);
2987 -- If not foldable we are done
2989 Test_Expression_Is_Foldable (N, Operand, Stat, Fold);
2994 -- Don't try fold if target type has constraint error bounds
2996 elsif not Is_OK_Static_Subtype (Target_Type) then
2997 Set_Raises_Constraint_Error (N);
3001 -- Here we will fold, save Print_In_Hex indication
3003 Hex := Nkind (Operand) = N_Integer_Literal
3004 and then Print_In_Hex (Operand);
3006 -- Fold the result of qualification
3008 if Is_Discrete_Type (Target_Type) then
3009 Fold_Uint (N, Expr_Value (Operand), Stat);
3011 -- Preserve Print_In_Hex indication
3013 if Hex and then Nkind (N) = N_Integer_Literal then
3014 Set_Print_In_Hex (N);
3017 elsif Is_Real_Type (Target_Type) then
3018 Fold_Ureal (N, Expr_Value_R (Operand), Stat);
3021 Fold_Str (N, Strval (Get_String_Val (Operand)), Stat);
3024 Set_Is_Static_Expression (N, False);
3026 Check_String_Literal_Length (N, Target_Type);
3032 -- The expression may be foldable but not static
3034 Set_Is_Static_Expression (N, Stat);
3036 if Is_Out_Of_Range (N, Etype (N), Assume_Valid => True) then
3039 end Eval_Qualified_Expression;
3041 -----------------------
3042 -- Eval_Real_Literal --
3043 -----------------------
3045 -- Numeric literals are static (RM 4.9(1)), and have already been marked
3046 -- as static by the analyzer. The reason we did it that early is to allow
3047 -- the possibility of turning off the Is_Static_Expression flag after
3048 -- analysis, but before resolution, when integer literals are generated
3049 -- in the expander that do not correspond to static expressions.
3051 procedure Eval_Real_Literal (N : Node_Id) is
3052 PK : constant Node_Kind := Nkind (Parent (N));
3055 -- If the literal appears in a non-expression context and not as part of
3056 -- a number declaration, then it is appearing in a non-static context,
3059 if PK not in N_Subexpr and then PK /= N_Number_Declaration then
3060 Check_Non_Static_Context (N);
3062 end Eval_Real_Literal;
3064 ------------------------
3065 -- Eval_Relational_Op --
3066 ------------------------
3068 -- Relational operations are static functions, so the result is static if
3069 -- both operands are static (RM 4.9(7), 4.9(20)), except that for strings,
3070 -- the result is never static, even if the operands are.
3072 -- However, for internally generated nodes, we allow string equality and
3073 -- inequality to be static. This is because we rewrite A in "ABC" as an
3074 -- equality test A = "ABC", and the former is definitely static.
3076 procedure Eval_Relational_Op (N : Node_Id) is
3077 Left : constant Node_Id := Left_Opnd (N);
3078 Right : constant Node_Id := Right_Opnd (N);
3079 Typ : constant Entity_Id := Etype (Left);
3080 Otype : Entity_Id := Empty;
3084 -- One special case to deal with first. If we can tell that the result
3085 -- will be false because the lengths of one or more index subtypes are
3086 -- compile time known and different, then we can replace the entire
3087 -- result by False. We only do this for one dimensional arrays, because
3088 -- the case of multi-dimensional arrays is rare and too much trouble. If
3089 -- one of the operands is an illegal aggregate, its type might still be
3090 -- an arbitrary composite type, so nothing to do.
3092 if Is_Array_Type (Typ)
3093 and then Typ /= Any_Composite
3094 and then Number_Dimensions (Typ) = 1
3095 and then (Nkind (N) = N_Op_Eq or else Nkind (N) = N_Op_Ne)
3097 if Raises_Constraint_Error (Left)
3099 Raises_Constraint_Error (Right)
3104 -- OK, we have the case where we may be able to do this fold
3106 Length_Mismatch : declare
3107 procedure Get_Static_Length (Op : Node_Id; Len : out Uint);
3108 -- If Op is an expression for a constrained array with a known at
3109 -- compile time length, then Len is set to this (non-negative
3110 -- length). Otherwise Len is set to minus 1.
3112 -----------------------
3113 -- Get_Static_Length --
3114 -----------------------
3116 procedure Get_Static_Length (Op : Node_Id; Len : out Uint) is
3120 -- First easy case string literal
3122 if Nkind (Op) = N_String_Literal then
3123 Len := UI_From_Int (String_Length (Strval (Op)));
3127 -- Second easy case, not constrained subtype, so no length
3129 if not Is_Constrained (Etype (Op)) then
3130 Len := Uint_Minus_1;
3136 T := Etype (First_Index (Etype (Op)));
3138 -- The simple case, both bounds are known at compile time
3140 if Is_Discrete_Type (T)
3141 and then Compile_Time_Known_Value (Type_Low_Bound (T))
3142 and then Compile_Time_Known_Value (Type_High_Bound (T))
3144 Len := UI_Max (Uint_0,
3145 Expr_Value (Type_High_Bound (T)) -
3146 Expr_Value (Type_Low_Bound (T)) + 1);
3150 -- A more complex case, where the bounds are of the form
3151 -- X [+/- K1] .. X [+/- K2]), where X is an expression that is
3152 -- either A'First or A'Last (with A an entity name), or X is an
3153 -- entity name, and the two X's are the same and K1 and K2 are
3154 -- known at compile time, in this case, the length can also be
3155 -- computed at compile time, even though the bounds are not
3156 -- known. A common case of this is e.g. (X'First .. X'First+5).
3158 Extract_Length : declare
3159 procedure Decompose_Expr
3161 Ent : out Entity_Id;
3162 Kind : out Character;
3164 Orig : Boolean := True);
3165 -- Given an expression see if it is of the form given above,
3166 -- X [+/- K]. If so Ent is set to the entity in X, Kind is
3167 -- 'F','L','E' for 'First/'Last/simple entity, and Cons is
3168 -- the value of K. If the expression is not of the required
3169 -- form, Ent is set to Empty.
3171 -- Orig indicates whether Expr is the original expression
3172 -- to consider, or if we are handling a sub-expression
3173 -- (e.g. recursive call to Decompose_Expr).
3175 --------------------
3176 -- Decompose_Expr --
3177 --------------------
3179 procedure Decompose_Expr
3181 Ent : out Entity_Id;
3182 Kind : out Character;
3184 Orig : Boolean := True)
3191 if Nkind (Expr) = N_Op_Add
3192 and then Compile_Time_Known_Value (Right_Opnd (Expr))
3194 Exp := Left_Opnd (Expr);
3195 Cons := Expr_Value (Right_Opnd (Expr));
3197 elsif Nkind (Expr) = N_Op_Subtract
3198 and then Compile_Time_Known_Value (Right_Opnd (Expr))
3200 Exp := Left_Opnd (Expr);
3201 Cons := -Expr_Value (Right_Opnd (Expr));
3203 -- If the bound is a constant created to remove side
3204 -- effects, recover original expression to see if it has
3205 -- one of the recognizable forms.
3207 elsif Nkind (Expr) = N_Identifier
3208 and then not Comes_From_Source (Entity (Expr))
3209 and then Ekind (Entity (Expr)) = E_Constant
3211 Nkind (Parent (Entity (Expr))) = N_Object_Declaration
3213 Exp := Expression (Parent (Entity (Expr)));
3214 Decompose_Expr (Exp, Ent, Kind, Cons, Orig => False);
3216 -- If original expression includes an entity, create a
3217 -- reference to it for use below.
3219 if Present (Ent) then
3220 Exp := New_Occurrence_Of (Ent, Sloc (Ent));
3226 -- Only consider the case of X + 0 for a full
3227 -- expression, and not when recursing, otherwise we
3228 -- may end up with evaluating expressions not known
3229 -- at compile time to 0.
3239 -- At this stage Exp is set to the potential X
3241 if Nkind (Exp) = N_Attribute_Reference then
3242 if Attribute_Name (Exp) = Name_First then
3244 elsif Attribute_Name (Exp) = Name_Last then
3250 Exp := Prefix (Exp);
3256 if Is_Entity_Name (Exp)
3257 and then Present (Entity (Exp))
3259 Ent := Entity (Exp);
3265 Ent1, Ent2 : Entity_Id;
3266 Kind1, Kind2 : Character;
3267 Cons1, Cons2 : Uint;
3269 -- Start of processing for Extract_Length
3273 (Original_Node (Type_Low_Bound (T)), Ent1, Kind1, Cons1);
3275 (Original_Node (Type_High_Bound (T)), Ent2, Kind2, Cons2);
3278 and then Kind1 = Kind2
3279 and then Ent1 = Ent2
3281 Len := Cons2 - Cons1 + 1;
3283 Len := Uint_Minus_1;
3286 end Get_Static_Length;
3293 -- Start of processing for Length_Mismatch
3296 Get_Static_Length (Left, Len_L);
3297 Get_Static_Length (Right, Len_R);
3299 if Len_L /= Uint_Minus_1
3300 and then Len_R /= Uint_Minus_1
3301 and then Len_L /= Len_R
3303 Fold_Uint (N, Test (Nkind (N) = N_Op_Ne), False);
3304 Warn_On_Known_Condition (N);
3307 end Length_Mismatch;
3311 Is_Static_Expression : Boolean;
3313 Is_Foldable : Boolean;
3314 pragma Unreferenced (Is_Foldable);
3317 -- Initialize the value of Is_Static_Expression. The value of
3318 -- Is_Foldable returned by Test_Expression_Is_Foldable is not needed
3319 -- since, even when some operand is a variable, we can still perform
3320 -- the static evaluation of the expression in some cases (for
3321 -- example, for a variable of a subtype of Integer we statically
3322 -- know that any value stored in such variable is smaller than
3325 Test_Expression_Is_Foldable
3326 (N, Left, Right, Is_Static_Expression, Is_Foldable);
3328 -- Only comparisons of scalars can give static results. In
3329 -- particular, comparisons of strings never yield a static
3330 -- result, even if both operands are static strings, except that
3331 -- as noted above, we allow equality/inequality for strings.
3333 if Is_String_Type (Typ)
3334 and then not Comes_From_Source (N)
3335 and then Nkind_In (N, N_Op_Eq, N_Op_Ne)
3339 elsif not Is_Scalar_Type (Typ) then
3340 Is_Static_Expression := False;
3341 Set_Is_Static_Expression (N, False);
3344 -- For operators on universal numeric types called as functions with
3345 -- an explicit scope, determine appropriate specific numeric type,
3346 -- and diagnose possible ambiguity.
3348 if Is_Universal_Numeric_Type (Etype (Left))
3350 Is_Universal_Numeric_Type (Etype (Right))
3352 Otype := Find_Universal_Operator_Type (N);
3355 -- For static real type expressions, do not use Compile_Time_Compare
3356 -- since it worries about run-time results which are not exact.
3358 if Is_Static_Expression and then Is_Real_Type (Typ) then
3360 Left_Real : constant Ureal := Expr_Value_R (Left);
3361 Right_Real : constant Ureal := Expr_Value_R (Right);
3365 when N_Op_Eq => Result := (Left_Real = Right_Real);
3366 when N_Op_Ne => Result := (Left_Real /= Right_Real);
3367 when N_Op_Lt => Result := (Left_Real < Right_Real);
3368 when N_Op_Le => Result := (Left_Real <= Right_Real);
3369 when N_Op_Gt => Result := (Left_Real > Right_Real);
3370 when N_Op_Ge => Result := (Left_Real >= Right_Real);
3373 raise Program_Error;
3376 Fold_Uint (N, Test (Result), True);
3379 -- For all other cases, we use Compile_Time_Compare to do the compare
3383 CR : constant Compare_Result :=
3384 Compile_Time_Compare
3385 (Left, Right, Assume_Valid => False);
3388 if CR = Unknown then
3396 elsif CR = NE or else CR = GT or else CR = LT then
3403 if CR = NE or else CR = GT or else CR = LT then
3414 elsif CR = EQ or else CR = GT or else CR = GE then
3421 if CR = LT or else CR = EQ or else CR = LE then
3432 elsif CR = EQ or else CR = LT or else CR = LE then
3439 if CR = GT or else CR = EQ or else CR = GE then
3448 raise Program_Error;
3452 Fold_Uint (N, Test (Result), Is_Static_Expression);
3456 -- For the case of a folded relational operator on a specific numeric
3457 -- type, freeze operand type now.
3459 if Present (Otype) then
3460 Freeze_Before (N, Otype);
3463 Warn_On_Known_Condition (N);
3464 end Eval_Relational_Op;
3470 -- Shift operations are intrinsic operations that can never be static, so
3471 -- the only processing required is to perform the required check for a non
3472 -- static context for the two operands.
3474 -- Actually we could do some compile time evaluation here some time ???
3476 procedure Eval_Shift (N : Node_Id) is
3478 Check_Non_Static_Context (Left_Opnd (N));
3479 Check_Non_Static_Context (Right_Opnd (N));
3482 ------------------------
3483 -- Eval_Short_Circuit --
3484 ------------------------
3486 -- A short circuit operation is potentially static if both operands are
3487 -- potentially static (RM 4.9 (13)).
3489 procedure Eval_Short_Circuit (N : Node_Id) is
3490 Kind : constant Node_Kind := Nkind (N);
3491 Left : constant Node_Id := Left_Opnd (N);
3492 Right : constant Node_Id := Right_Opnd (N);
3495 Rstat : constant Boolean :=
3496 Is_Static_Expression (Left)
3498 Is_Static_Expression (Right);
3501 -- Short circuit operations are never static in Ada 83
3503 if Ada_Version = Ada_83 and then Comes_From_Source (N) then
3504 Check_Non_Static_Context (Left);
3505 Check_Non_Static_Context (Right);
3509 -- Now look at the operands, we can't quite use the normal call to
3510 -- Test_Expression_Is_Foldable here because short circuit operations
3511 -- are a special case, they can still be foldable, even if the right
3512 -- operand raises constraint error.
3514 -- If either operand is Any_Type, just propagate to result and do not
3515 -- try to fold, this prevents cascaded errors.
3517 if Etype (Left) = Any_Type or else Etype (Right) = Any_Type then
3518 Set_Etype (N, Any_Type);
3521 -- If left operand raises constraint error, then replace node N with
3522 -- the raise constraint error node, and we are obviously not foldable.
3523 -- Is_Static_Expression is set from the two operands in the normal way,
3524 -- and we check the right operand if it is in a non-static context.
3526 elsif Raises_Constraint_Error (Left) then
3528 Check_Non_Static_Context (Right);
3531 Rewrite_In_Raise_CE (N, Left);
3532 Set_Is_Static_Expression (N, Rstat);
3535 -- If the result is not static, then we won't in any case fold
3537 elsif not Rstat then
3538 Check_Non_Static_Context (Left);
3539 Check_Non_Static_Context (Right);
3543 -- Here the result is static, note that, unlike the normal processing
3544 -- in Test_Expression_Is_Foldable, we did *not* check above to see if
3545 -- the right operand raises constraint error, that's because it is not
3546 -- significant if the left operand is decisive.
3548 Set_Is_Static_Expression (N);
3550 -- It does not matter if the right operand raises constraint error if
3551 -- it will not be evaluated. So deal specially with the cases where
3552 -- the right operand is not evaluated. Note that we will fold these
3553 -- cases even if the right operand is non-static, which is fine, but
3554 -- of course in these cases the result is not potentially static.
3556 Left_Int := Expr_Value (Left);
3558 if (Kind = N_And_Then and then Is_False (Left_Int))
3560 (Kind = N_Or_Else and then Is_True (Left_Int))
3562 Fold_Uint (N, Left_Int, Rstat);
3566 -- If first operand not decisive, then it does matter if the right
3567 -- operand raises constraint error, since it will be evaluated, so
3568 -- we simply replace the node with the right operand. Note that this
3569 -- properly propagates Is_Static_Expression and Raises_Constraint_Error
3570 -- (both are set to True in Right).
3572 if Raises_Constraint_Error (Right) then
3573 Rewrite_In_Raise_CE (N, Right);
3574 Check_Non_Static_Context (Left);
3578 -- Otherwise the result depends on the right operand
3580 Fold_Uint (N, Expr_Value (Right), Rstat);
3582 end Eval_Short_Circuit;
3588 -- Slices can never be static, so the only processing required is to check
3589 -- for non-static context if an explicit range is given.
3591 procedure Eval_Slice (N : Node_Id) is
3592 Drange : constant Node_Id := Discrete_Range (N);
3595 if Nkind (Drange) = N_Range then
3596 Check_Non_Static_Context (Low_Bound (Drange));
3597 Check_Non_Static_Context (High_Bound (Drange));
3600 -- A slice of the form A (subtype), when the subtype is the index of
3601 -- the type of A, is redundant, the slice can be replaced with A, and
3602 -- this is worth a warning.
3604 if Is_Entity_Name (Prefix (N)) then
3606 E : constant Entity_Id := Entity (Prefix (N));
3607 T : constant Entity_Id := Etype (E);
3610 if Ekind (E) = E_Constant
3611 and then Is_Array_Type (T)
3612 and then Is_Entity_Name (Drange)
3614 if Is_Entity_Name (Original_Node (First_Index (T)))
3615 and then Entity (Original_Node (First_Index (T)))
3618 if Warn_On_Redundant_Constructs then
3619 Error_Msg_N ("redundant slice denotes whole array?r?", N);
3622 -- The following might be a useful optimization???
3624 -- Rewrite (N, New_Occurrence_Of (E, Sloc (N)));
3631 -------------------------
3632 -- Eval_String_Literal --
3633 -------------------------
3635 procedure Eval_String_Literal (N : Node_Id) is
3636 Typ : constant Entity_Id := Etype (N);
3637 Bas : constant Entity_Id := Base_Type (Typ);
3643 -- Nothing to do if error type (handles cases like default expressions
3644 -- or generics where we have not yet fully resolved the type).
3646 if Bas = Any_Type or else Bas = Any_String then
3650 -- String literals are static if the subtype is static (RM 4.9(2)), so
3651 -- reset the static expression flag (it was set unconditionally in
3652 -- Analyze_String_Literal) if the subtype is non-static. We tell if
3653 -- the subtype is static by looking at the lower bound.
3655 if Ekind (Typ) = E_String_Literal_Subtype then
3656 if not Is_OK_Static_Expression (String_Literal_Low_Bound (Typ)) then
3657 Set_Is_Static_Expression (N, False);
3661 -- Here if Etype of string literal is normal Etype (not yet possible,
3662 -- but may be possible in future).
3664 elsif not Is_OK_Static_Expression
3665 (Type_Low_Bound (Etype (First_Index (Typ))))
3667 Set_Is_Static_Expression (N, False);
3671 -- If original node was a type conversion, then result if non-static
3673 if Nkind (Original_Node (N)) = N_Type_Conversion then
3674 Set_Is_Static_Expression (N, False);
3678 -- Test for illegal Ada 95 cases. A string literal is illegal in Ada 95
3679 -- if its bounds are outside the index base type and this index type is
3680 -- static. This can happen in only two ways. Either the string literal
3681 -- is too long, or it is null, and the lower bound is type'First. Either
3682 -- way it is the upper bound that is out of range of the index type.
3684 if Ada_Version >= Ada_95 then
3685 if Is_Standard_String_Type (Bas) then
3686 Xtp := Standard_Positive;
3688 Xtp := Etype (First_Index (Bas));
3691 if Ekind (Typ) = E_String_Literal_Subtype then
3692 Lo := String_Literal_Low_Bound (Typ);
3694 Lo := Type_Low_Bound (Etype (First_Index (Typ)));
3697 -- Check for string too long
3699 Len := String_Length (Strval (N));
3701 if UI_From_Int (Len) > String_Type_Len (Bas) then
3703 -- Issue message. Note that this message is a warning if the
3704 -- string literal is not marked as static (happens in some cases
3705 -- of folding strings known at compile time, but not static).
3706 -- Furthermore in such cases, we reword the message, since there
3707 -- is no string literal in the source program.
3709 if Is_Static_Expression (N) then
3710 Apply_Compile_Time_Constraint_Error
3711 (N, "string literal too long for}", CE_Length_Check_Failed,
3713 Typ => First_Subtype (Bas));
3715 Apply_Compile_Time_Constraint_Error
3716 (N, "string value too long for}", CE_Length_Check_Failed,
3718 Typ => First_Subtype (Bas),
3722 -- Test for null string not allowed
3725 and then not Is_Generic_Type (Xtp)
3727 Expr_Value (Lo) = Expr_Value (Type_Low_Bound (Base_Type (Xtp)))
3729 -- Same specialization of message
3731 if Is_Static_Expression (N) then
3732 Apply_Compile_Time_Constraint_Error
3733 (N, "null string literal not allowed for}",
3734 CE_Length_Check_Failed,
3736 Typ => First_Subtype (Bas));
3738 Apply_Compile_Time_Constraint_Error
3739 (N, "null string value not allowed for}",
3740 CE_Length_Check_Failed,
3742 Typ => First_Subtype (Bas),
3747 end Eval_String_Literal;
3749 --------------------------
3750 -- Eval_Type_Conversion --
3751 --------------------------
3753 -- A type conversion is potentially static if its subtype mark is for a
3754 -- static scalar subtype, and its operand expression is potentially static
3757 procedure Eval_Type_Conversion (N : Node_Id) is
3758 Operand : constant Node_Id := Expression (N);
3759 Source_Type : constant Entity_Id := Etype (Operand);
3760 Target_Type : constant Entity_Id := Etype (N);
3762 function To_Be_Treated_As_Integer (T : Entity_Id) return Boolean;
3763 -- Returns true if type T is an integer type, or if it is a fixed-point
3764 -- type to be treated as an integer (i.e. the flag Conversion_OK is set
3765 -- on the conversion node).
3767 function To_Be_Treated_As_Real (T : Entity_Id) return Boolean;
3768 -- Returns true if type T is a floating-point type, or if it is a
3769 -- fixed-point type that is not to be treated as an integer (i.e. the
3770 -- flag Conversion_OK is not set on the conversion node).
3772 ------------------------------
3773 -- To_Be_Treated_As_Integer --
3774 ------------------------------
3776 function To_Be_Treated_As_Integer (T : Entity_Id) return Boolean is
3780 or else (Is_Fixed_Point_Type (T) and then Conversion_OK (N));
3781 end To_Be_Treated_As_Integer;
3783 ---------------------------
3784 -- To_Be_Treated_As_Real --
3785 ---------------------------
3787 function To_Be_Treated_As_Real (T : Entity_Id) return Boolean is
3790 Is_Floating_Point_Type (T)
3791 or else (Is_Fixed_Point_Type (T) and then not Conversion_OK (N));
3792 end To_Be_Treated_As_Real;
3799 -- Start of processing for Eval_Type_Conversion
3802 -- Cannot fold if target type is non-static or if semantic error
3804 if not Is_Static_Subtype (Target_Type) then
3805 Check_Non_Static_Context (Operand);
3807 elsif Error_Posted (N) then
3811 -- If not foldable we are done
3813 Test_Expression_Is_Foldable (N, Operand, Stat, Fold);
3818 -- Don't try fold if target type has constraint error bounds
3820 elsif not Is_OK_Static_Subtype (Target_Type) then
3821 Set_Raises_Constraint_Error (N);
3825 -- Remaining processing depends on operand types. Note that in the
3826 -- following type test, fixed-point counts as real unless the flag
3827 -- Conversion_OK is set, in which case it counts as integer.
3829 -- Fold conversion, case of string type. The result is not static
3831 if Is_String_Type (Target_Type) then
3832 Fold_Str (N, Strval (Get_String_Val (Operand)), Static => False);
3835 -- Fold conversion, case of integer target type
3837 elsif To_Be_Treated_As_Integer (Target_Type) then
3842 -- Integer to integer conversion
3844 if To_Be_Treated_As_Integer (Source_Type) then
3845 Result := Expr_Value (Operand);
3847 -- Real to integer conversion
3850 Result := UR_To_Uint (Expr_Value_R (Operand));
3853 -- If fixed-point type (Conversion_OK must be set), then the
3854 -- result is logically an integer, but we must replace the
3855 -- conversion with the corresponding real literal, since the
3856 -- type from a semantic point of view is still fixed-point.
3858 if Is_Fixed_Point_Type (Target_Type) then
3860 (N, UR_From_Uint (Result) * Small_Value (Target_Type), Stat);
3862 -- Otherwise result is integer literal
3865 Fold_Uint (N, Result, Stat);
3869 -- Fold conversion, case of real target type
3871 elsif To_Be_Treated_As_Real (Target_Type) then
3876 if To_Be_Treated_As_Real (Source_Type) then
3877 Result := Expr_Value_R (Operand);
3879 Result := UR_From_Uint (Expr_Value (Operand));
3882 Fold_Ureal (N, Result, Stat);
3885 -- Enumeration types
3888 Fold_Uint (N, Expr_Value (Operand), Stat);
3891 if Is_Out_Of_Range (N, Etype (N), Assume_Valid => True) then
3895 end Eval_Type_Conversion;
3901 -- Predefined unary operators are static functions (RM 4.9(20)) and thus
3902 -- are potentially static if the operand is potentially static (RM 4.9(7)).
3904 procedure Eval_Unary_Op (N : Node_Id) is
3905 Right : constant Node_Id := Right_Opnd (N);
3906 Otype : Entity_Id := Empty;
3911 -- If not foldable we are done
3913 Test_Expression_Is_Foldable (N, Right, Stat, Fold);
3919 if Etype (Right) = Universal_Integer
3921 Etype (Right) = Universal_Real
3923 Otype := Find_Universal_Operator_Type (N);
3926 -- Fold for integer case
3928 if Is_Integer_Type (Etype (N)) then
3930 Rint : constant Uint := Expr_Value (Right);
3934 -- In the case of modular unary plus and abs there is no need
3935 -- to adjust the result of the operation since if the original
3936 -- operand was in bounds the result will be in the bounds of the
3937 -- modular type. However, in the case of modular unary minus the
3938 -- result may go out of the bounds of the modular type and needs
3941 if Nkind (N) = N_Op_Plus then
3944 elsif Nkind (N) = N_Op_Minus then
3945 if Is_Modular_Integer_Type (Etype (N)) then
3946 Result := (-Rint) mod Modulus (Etype (N));
3952 pragma Assert (Nkind (N) = N_Op_Abs);
3956 Fold_Uint (N, Result, Stat);
3959 -- Fold for real case
3961 elsif Is_Real_Type (Etype (N)) then
3963 Rreal : constant Ureal := Expr_Value_R (Right);
3967 if Nkind (N) = N_Op_Plus then
3969 elsif Nkind (N) = N_Op_Minus then
3970 Result := UR_Negate (Rreal);
3972 pragma Assert (Nkind (N) = N_Op_Abs);
3973 Result := abs Rreal;
3976 Fold_Ureal (N, Result, Stat);
3980 -- If the operator was resolved to a specific type, make sure that type
3981 -- is frozen even if the expression is folded into a literal (which has
3982 -- a universal type).
3984 if Present (Otype) then
3985 Freeze_Before (N, Otype);
3989 -------------------------------
3990 -- Eval_Unchecked_Conversion --
3991 -------------------------------
3993 -- Unchecked conversions can never be static, so the only required
3994 -- processing is to check for a non-static context for the operand.
3996 procedure Eval_Unchecked_Conversion (N : Node_Id) is
3998 Check_Non_Static_Context (Expression (N));
3999 end Eval_Unchecked_Conversion;
4001 --------------------
4002 -- Expr_Rep_Value --
4003 --------------------
4005 function Expr_Rep_Value (N : Node_Id) return Uint is
4006 Kind : constant Node_Kind := Nkind (N);
4010 if Is_Entity_Name (N) then
4013 -- An enumeration literal that was either in the source or created
4014 -- as a result of static evaluation.
4016 if Ekind (Ent) = E_Enumeration_Literal then
4017 return Enumeration_Rep (Ent);
4019 -- A user defined static constant
4022 pragma Assert (Ekind (Ent) = E_Constant);
4023 return Expr_Rep_Value (Constant_Value (Ent));
4026 -- An integer literal that was either in the source or created as a
4027 -- result of static evaluation.
4029 elsif Kind = N_Integer_Literal then
4032 -- A real literal for a fixed-point type. This must be the fixed-point
4033 -- case, either the literal is of a fixed-point type, or it is a bound
4034 -- of a fixed-point type, with type universal real. In either case we
4035 -- obtain the desired value from Corresponding_Integer_Value.
4037 elsif Kind = N_Real_Literal then
4038 pragma Assert (Is_Fixed_Point_Type (Underlying_Type (Etype (N))));
4039 return Corresponding_Integer_Value (N);
4041 -- Otherwise must be character literal
4044 pragma Assert (Kind = N_Character_Literal);
4047 -- Since Character literals of type Standard.Character don't have any
4048 -- defining character literals built for them, they do not have their
4049 -- Entity set, so just use their Char code. Otherwise for user-
4050 -- defined character literals use their Pos value as usual which is
4051 -- the same as the Rep value.
4054 return Char_Literal_Value (N);
4056 return Enumeration_Rep (Ent);
4065 function Expr_Value (N : Node_Id) return Uint is
4066 Kind : constant Node_Kind := Nkind (N);
4067 CV_Ent : CV_Entry renames CV_Cache (Nat (N) mod CV_Cache_Size);
4072 -- If already in cache, then we know it's compile time known and we can
4073 -- return the value that was previously stored in the cache since
4074 -- compile time known values cannot change.
4076 if CV_Ent.N = N then
4080 -- Otherwise proceed to test value
4082 if Is_Entity_Name (N) then
4085 -- An enumeration literal that was either in the source or created as
4086 -- a result of static evaluation.
4088 if Ekind (Ent) = E_Enumeration_Literal then
4089 Val := Enumeration_Pos (Ent);
4091 -- A user defined static constant
4094 pragma Assert (Ekind (Ent) = E_Constant);
4095 Val := Expr_Value (Constant_Value (Ent));
4098 -- An integer literal that was either in the source or created as a
4099 -- result of static evaluation.
4101 elsif Kind = N_Integer_Literal then
4104 -- A real literal for a fixed-point type. This must be the fixed-point
4105 -- case, either the literal is of a fixed-point type, or it is a bound
4106 -- of a fixed-point type, with type universal real. In either case we
4107 -- obtain the desired value from Corresponding_Integer_Value.
4109 elsif Kind = N_Real_Literal then
4110 pragma Assert (Is_Fixed_Point_Type (Underlying_Type (Etype (N))));
4111 Val := Corresponding_Integer_Value (N);
4113 -- Otherwise must be character literal
4116 pragma Assert (Kind = N_Character_Literal);
4119 -- Since Character literals of type Standard.Character don't
4120 -- have any defining character literals built for them, they
4121 -- do not have their Entity set, so just use their Char
4122 -- code. Otherwise for user-defined character literals use
4123 -- their Pos value as usual.
4126 Val := Char_Literal_Value (N);
4128 Val := Enumeration_Pos (Ent);
4132 -- Come here with Val set to value to be returned, set cache
4143 function Expr_Value_E (N : Node_Id) return Entity_Id is
4144 Ent : constant Entity_Id := Entity (N);
4146 if Ekind (Ent) = E_Enumeration_Literal then
4149 pragma Assert (Ekind (Ent) = E_Constant);
4150 return Expr_Value_E (Constant_Value (Ent));
4158 function Expr_Value_R (N : Node_Id) return Ureal is
4159 Kind : constant Node_Kind := Nkind (N);
4163 if Kind = N_Real_Literal then
4166 elsif Kind = N_Identifier or else Kind = N_Expanded_Name then
4168 pragma Assert (Ekind (Ent) = E_Constant);
4169 return Expr_Value_R (Constant_Value (Ent));
4171 elsif Kind = N_Integer_Literal then
4172 return UR_From_Uint (Expr_Value (N));
4174 -- Here, we have a node that cannot be interpreted as a compile time
4175 -- constant. That is definitely an error.
4178 raise Program_Error;
4186 function Expr_Value_S (N : Node_Id) return Node_Id is
4188 if Nkind (N) = N_String_Literal then
4191 pragma Assert (Ekind (Entity (N)) = E_Constant);
4192 return Expr_Value_S (Constant_Value (Entity (N)));
4196 ----------------------------------
4197 -- Find_Universal_Operator_Type --
4198 ----------------------------------
4200 function Find_Universal_Operator_Type (N : Node_Id) return Entity_Id is
4201 PN : constant Node_Id := Parent (N);
4202 Call : constant Node_Id := Original_Node (N);
4203 Is_Int : constant Boolean := Is_Integer_Type (Etype (N));
4205 Is_Fix : constant Boolean :=
4206 Nkind (N) in N_Binary_Op
4207 and then Nkind (Right_Opnd (N)) /= Nkind (Left_Opnd (N));
4208 -- A mixed-mode operation in this context indicates the presence of
4209 -- fixed-point type in the designated package.
4211 Is_Relational : constant Boolean := Etype (N) = Standard_Boolean;
4212 -- Case where N is a relational (or membership) operator (else it is an
4215 In_Membership : constant Boolean :=
4216 Nkind (PN) in N_Membership_Test
4218 Nkind (Right_Opnd (PN)) = N_Range
4220 Is_Universal_Numeric_Type (Etype (Left_Opnd (PN)))
4222 Is_Universal_Numeric_Type
4223 (Etype (Low_Bound (Right_Opnd (PN))))
4225 Is_Universal_Numeric_Type
4226 (Etype (High_Bound (Right_Opnd (PN))));
4227 -- Case where N is part of a membership test with a universal range
4231 Typ1 : Entity_Id := Empty;
4234 function Is_Mixed_Mode_Operand (Op : Node_Id) return Boolean;
4235 -- Check whether one operand is a mixed-mode operation that requires the
4236 -- presence of a fixed-point type. Given that all operands are universal
4237 -- and have been constant-folded, retrieve the original function call.
4239 ---------------------------
4240 -- Is_Mixed_Mode_Operand --
4241 ---------------------------
4243 function Is_Mixed_Mode_Operand (Op : Node_Id) return Boolean is
4244 Onod : constant Node_Id := Original_Node (Op);
4246 return Nkind (Onod) = N_Function_Call
4247 and then Present (Next_Actual (First_Actual (Onod)))
4248 and then Etype (First_Actual (Onod)) /=
4249 Etype (Next_Actual (First_Actual (Onod)));
4250 end Is_Mixed_Mode_Operand;
4252 -- Start of processing for Find_Universal_Operator_Type
4255 if Nkind (Call) /= N_Function_Call
4256 or else Nkind (Name (Call)) /= N_Expanded_Name
4260 -- There are several cases where the context does not imply the type of
4262 -- - the universal expression appears in a type conversion;
4263 -- - the expression is a relational operator applied to universal
4265 -- - the expression is a membership test with a universal operand
4266 -- and a range with universal bounds.
4268 elsif Nkind (Parent (N)) = N_Type_Conversion
4269 or else Is_Relational
4270 or else In_Membership
4272 Pack := Entity (Prefix (Name (Call)));
4274 -- If the prefix is a package declared elsewhere, iterate over its
4275 -- visible entities, otherwise iterate over all declarations in the
4276 -- designated scope.
4278 if Ekind (Pack) = E_Package
4279 and then not In_Open_Scopes (Pack)
4281 Priv_E := First_Private_Entity (Pack);
4287 E := First_Entity (Pack);
4288 while Present (E) and then E /= Priv_E loop
4289 if Is_Numeric_Type (E)
4290 and then Nkind (Parent (E)) /= N_Subtype_Declaration
4291 and then Comes_From_Source (E)
4292 and then Is_Integer_Type (E) = Is_Int
4293 and then (Nkind (N) in N_Unary_Op
4294 or else Is_Relational
4295 or else Is_Fixed_Point_Type (E) = Is_Fix)
4300 -- Before emitting an error, check for the presence of a
4301 -- mixed-mode operation that specifies a fixed point type.
4305 (Is_Mixed_Mode_Operand (Left_Opnd (N))
4306 or else Is_Mixed_Mode_Operand (Right_Opnd (N)))
4307 and then Is_Fixed_Point_Type (E) /= Is_Fixed_Point_Type (Typ1)
4310 if Is_Fixed_Point_Type (E) then
4315 -- More than one type of the proper class declared in P
4317 Error_Msg_N ("ambiguous operation", N);
4318 Error_Msg_Sloc := Sloc (Typ1);
4319 Error_Msg_N ("\possible interpretation (inherited)#", N);
4320 Error_Msg_Sloc := Sloc (E);
4321 Error_Msg_N ("\possible interpretation (inherited)#", N);
4331 end Find_Universal_Operator_Type;
4333 --------------------------
4334 -- Flag_Non_Static_Expr --
4335 --------------------------
4337 procedure Flag_Non_Static_Expr (Msg : String; Expr : Node_Id) is
4339 if Error_Posted (Expr) and then not All_Errors_Mode then
4342 Error_Msg_F (Msg, Expr);
4343 Why_Not_Static (Expr);
4345 end Flag_Non_Static_Expr;
4351 procedure Fold_Str (N : Node_Id; Val : String_Id; Static : Boolean) is
4352 Loc : constant Source_Ptr := Sloc (N);
4353 Typ : constant Entity_Id := Etype (N);
4356 if Raises_Constraint_Error (N) then
4357 Set_Is_Static_Expression (N, Static);
4361 Rewrite (N, Make_String_Literal (Loc, Strval => Val));
4363 -- We now have the literal with the right value, both the actual type
4364 -- and the expected type of this literal are taken from the expression
4365 -- that was evaluated. So now we do the Analyze and Resolve.
4367 -- Note that we have to reset Is_Static_Expression both after the
4368 -- analyze step (because Resolve will evaluate the literal, which
4369 -- will cause semantic errors if it is marked as static), and after
4370 -- the Resolve step (since Resolve in some cases resets this flag).
4373 Set_Is_Static_Expression (N, Static);
4376 Set_Is_Static_Expression (N, Static);
4383 procedure Fold_Uint (N : Node_Id; Val : Uint; Static : Boolean) is
4384 Loc : constant Source_Ptr := Sloc (N);
4385 Typ : Entity_Id := Etype (N);
4389 if Raises_Constraint_Error (N) then
4390 Set_Is_Static_Expression (N, Static);
4394 -- If we are folding a named number, retain the entity in the literal,
4397 if Is_Entity_Name (N) and then Ekind (Entity (N)) = E_Named_Integer then
4403 if Is_Private_Type (Typ) then
4404 Typ := Full_View (Typ);
4407 -- For a result of type integer, substitute an N_Integer_Literal node
4408 -- for the result of the compile time evaluation of the expression.
4409 -- For ASIS use, set a link to the original named number when not in
4410 -- a generic context.
4412 if Is_Integer_Type (Typ) then
4413 Rewrite (N, Make_Integer_Literal (Loc, Val));
4414 Set_Original_Entity (N, Ent);
4416 -- Otherwise we have an enumeration type, and we substitute either
4417 -- an N_Identifier or N_Character_Literal to represent the enumeration
4418 -- literal corresponding to the given value, which must always be in
4419 -- range, because appropriate tests have already been made for this.
4421 else pragma Assert (Is_Enumeration_Type (Typ));
4422 Rewrite (N, Get_Enum_Lit_From_Pos (Etype (N), Val, Loc));
4425 -- We now have the literal with the right value, both the actual type
4426 -- and the expected type of this literal are taken from the expression
4427 -- that was evaluated. So now we do the Analyze and Resolve.
4429 -- Note that we have to reset Is_Static_Expression both after the
4430 -- analyze step (because Resolve will evaluate the literal, which
4431 -- will cause semantic errors if it is marked as static), and after
4432 -- the Resolve step (since Resolve in some cases sets this flag).
4435 Set_Is_Static_Expression (N, Static);
4438 Set_Is_Static_Expression (N, Static);
4445 procedure Fold_Ureal (N : Node_Id; Val : Ureal; Static : Boolean) is
4446 Loc : constant Source_Ptr := Sloc (N);
4447 Typ : constant Entity_Id := Etype (N);
4451 if Raises_Constraint_Error (N) then
4452 Set_Is_Static_Expression (N, Static);
4456 -- If we are folding a named number, retain the entity in the literal,
4459 if Is_Entity_Name (N) and then Ekind (Entity (N)) = E_Named_Real then
4465 Rewrite (N, Make_Real_Literal (Loc, Realval => Val));
4467 -- Set link to original named number, for ASIS use
4469 Set_Original_Entity (N, Ent);
4471 -- We now have the literal with the right value, both the actual type
4472 -- and the expected type of this literal are taken from the expression
4473 -- that was evaluated. So now we do the Analyze and Resolve.
4475 -- Note that we have to reset Is_Static_Expression both after the
4476 -- analyze step (because Resolve will evaluate the literal, which
4477 -- will cause semantic errors if it is marked as static), and after
4478 -- the Resolve step (since Resolve in some cases sets this flag).
4481 Set_Is_Static_Expression (N, Static);
4484 Set_Is_Static_Expression (N, Static);
4491 function From_Bits (B : Bits; T : Entity_Id) return Uint is
4495 for J in 0 .. B'Last loop
4501 if Non_Binary_Modulus (T) then
4502 V := V mod Modulus (T);
4508 --------------------
4509 -- Get_String_Val --
4510 --------------------
4512 function Get_String_Val (N : Node_Id) return Node_Id is
4514 if Nkind_In (N, N_String_Literal, N_Character_Literal) then
4517 pragma Assert (Is_Entity_Name (N));
4518 return Get_String_Val (Constant_Value (Entity (N)));
4526 procedure Initialize is
4528 CV_Cache := (others => (Node_High_Bound, Uint_0));
4531 --------------------
4532 -- In_Subrange_Of --
4533 --------------------
4535 function In_Subrange_Of
4538 Fixed_Int : Boolean := False) return Boolean
4547 if T1 = T2 or else Is_Subtype_Of (T1, T2) then
4550 -- Never in range if both types are not scalar. Don't know if this can
4551 -- actually happen, but just in case.
4553 elsif not Is_Scalar_Type (T1) or else not Is_Scalar_Type (T2) then
4556 -- If T1 has infinities but T2 doesn't have infinities, then T1 is
4557 -- definitely not compatible with T2.
4559 elsif Is_Floating_Point_Type (T1)
4560 and then Has_Infinities (T1)
4561 and then Is_Floating_Point_Type (T2)
4562 and then not Has_Infinities (T2)
4567 L1 := Type_Low_Bound (T1);
4568 H1 := Type_High_Bound (T1);
4570 L2 := Type_Low_Bound (T2);
4571 H2 := Type_High_Bound (T2);
4573 -- Check bounds to see if comparison possible at compile time
4575 if Compile_Time_Compare (L1, L2, Assume_Valid => True) in Compare_GE
4577 Compile_Time_Compare (H1, H2, Assume_Valid => True) in Compare_LE
4582 -- If bounds not comparable at compile time, then the bounds of T2
4583 -- must be compile time known or we cannot answer the query.
4585 if not Compile_Time_Known_Value (L2)
4586 or else not Compile_Time_Known_Value (H2)
4591 -- If the bounds of T1 are know at compile time then use these
4592 -- ones, otherwise use the bounds of the base type (which are of
4593 -- course always static).
4595 if not Compile_Time_Known_Value (L1) then
4596 L1 := Type_Low_Bound (Base_Type (T1));
4599 if not Compile_Time_Known_Value (H1) then
4600 H1 := Type_High_Bound (Base_Type (T1));
4603 -- Fixed point types should be considered as such only if
4604 -- flag Fixed_Int is set to False.
4606 if Is_Floating_Point_Type (T1) or else Is_Floating_Point_Type (T2)
4607 or else (Is_Fixed_Point_Type (T1) and then not Fixed_Int)
4608 or else (Is_Fixed_Point_Type (T2) and then not Fixed_Int)
4611 Expr_Value_R (L2) <= Expr_Value_R (L1)
4613 Expr_Value_R (H2) >= Expr_Value_R (H1);
4617 Expr_Value (L2) <= Expr_Value (L1)
4619 Expr_Value (H2) >= Expr_Value (H1);
4624 -- If any exception occurs, it means that we have some bug in the compiler
4625 -- possibly triggered by a previous error, or by some unforeseen peculiar
4626 -- occurrence. However, this is only an optimization attempt, so there is
4627 -- really no point in crashing the compiler. Instead we just decide, too
4628 -- bad, we can't figure out the answer in this case after all.
4633 -- Debug flag K disables this behavior (useful for debugging)
4635 if Debug_Flag_K then
4646 function Is_In_Range
4649 Assume_Valid : Boolean := False;
4650 Fixed_Int : Boolean := False;
4651 Int_Real : Boolean := False) return Boolean
4655 Test_In_Range (N, Typ, Assume_Valid, Fixed_Int, Int_Real) = In_Range;
4662 function Is_Null_Range (Lo : Node_Id; Hi : Node_Id) return Boolean is
4663 Typ : constant Entity_Id := Etype (Lo);
4666 if not Compile_Time_Known_Value (Lo)
4667 or else not Compile_Time_Known_Value (Hi)
4672 if Is_Discrete_Type (Typ) then
4673 return Expr_Value (Lo) > Expr_Value (Hi);
4674 else pragma Assert (Is_Real_Type (Typ));
4675 return Expr_Value_R (Lo) > Expr_Value_R (Hi);
4679 -------------------------
4680 -- Is_OK_Static_Choice --
4681 -------------------------
4683 function Is_OK_Static_Choice (Choice : Node_Id) return Boolean is
4685 -- Check various possibilities for choice
4687 -- Note: for membership tests, we test more cases than are possible
4688 -- (in particular subtype indication), but it doesn't matter because
4689 -- it just won't occur (we have already done a syntax check).
4691 if Nkind (Choice) = N_Others_Choice then
4694 elsif Nkind (Choice) = N_Range then
4695 return Is_OK_Static_Range (Choice);
4697 elsif Nkind (Choice) = N_Subtype_Indication
4698 or else (Is_Entity_Name (Choice) and then Is_Type (Entity (Choice)))
4700 return Is_OK_Static_Subtype (Etype (Choice));
4703 return Is_OK_Static_Expression (Choice);
4705 end Is_OK_Static_Choice;
4707 ------------------------------
4708 -- Is_OK_Static_Choice_List --
4709 ------------------------------
4711 function Is_OK_Static_Choice_List (Choices : List_Id) return Boolean is
4715 if not Is_Static_Choice_List (Choices) then
4719 Choice := First (Choices);
4720 while Present (Choice) loop
4721 if not Is_OK_Static_Choice (Choice) then
4722 Set_Raises_Constraint_Error (Choice);
4730 end Is_OK_Static_Choice_List;
4732 -----------------------------
4733 -- Is_OK_Static_Expression --
4734 -----------------------------
4736 function Is_OK_Static_Expression (N : Node_Id) return Boolean is
4738 return Is_Static_Expression (N) and then not Raises_Constraint_Error (N);
4739 end Is_OK_Static_Expression;
4741 ------------------------
4742 -- Is_OK_Static_Range --
4743 ------------------------
4745 -- A static range is a range whose bounds are static expressions, or a
4746 -- Range_Attribute_Reference equivalent to such a range (RM 4.9(26)).
4747 -- We have already converted range attribute references, so we get the
4748 -- "or" part of this rule without needing a special test.
4750 function Is_OK_Static_Range (N : Node_Id) return Boolean is
4752 return Is_OK_Static_Expression (Low_Bound (N))
4753 and then Is_OK_Static_Expression (High_Bound (N));
4754 end Is_OK_Static_Range;
4756 --------------------------
4757 -- Is_OK_Static_Subtype --
4758 --------------------------
4760 -- Determines if Typ is a static subtype as defined in (RM 4.9(26)) where
4761 -- neither bound raises constraint error when evaluated.
4763 function Is_OK_Static_Subtype (Typ : Entity_Id) return Boolean is
4764 Base_T : constant Entity_Id := Base_Type (Typ);
4765 Anc_Subt : Entity_Id;
4768 -- First a quick check on the non static subtype flag. As described
4769 -- in further detail in Einfo, this flag is not decisive in all cases,
4770 -- but if it is set, then the subtype is definitely non-static.
4772 if Is_Non_Static_Subtype (Typ) then
4776 Anc_Subt := Ancestor_Subtype (Typ);
4778 if Anc_Subt = Empty then
4782 if Is_Generic_Type (Root_Type (Base_T))
4783 or else Is_Generic_Actual_Type (Base_T)
4787 elsif Has_Dynamic_Predicate_Aspect (Typ) then
4792 elsif Is_String_Type (Typ) then
4794 Ekind (Typ) = E_String_Literal_Subtype
4796 (Is_OK_Static_Subtype (Component_Type (Typ))
4797 and then Is_OK_Static_Subtype (Etype (First_Index (Typ))));
4801 elsif Is_Scalar_Type (Typ) then
4802 if Base_T = Typ then
4806 -- Scalar_Range (Typ) might be an N_Subtype_Indication, so use
4807 -- Get_Type_{Low,High}_Bound.
4809 return Is_OK_Static_Subtype (Anc_Subt)
4810 and then Is_OK_Static_Expression (Type_Low_Bound (Typ))
4811 and then Is_OK_Static_Expression (Type_High_Bound (Typ));
4814 -- Types other than string and scalar types are never static
4819 end Is_OK_Static_Subtype;
4821 ---------------------
4822 -- Is_Out_Of_Range --
4823 ---------------------
4825 function Is_Out_Of_Range
4828 Assume_Valid : Boolean := False;
4829 Fixed_Int : Boolean := False;
4830 Int_Real : Boolean := False) return Boolean
4833 return Test_In_Range (N, Typ, Assume_Valid, Fixed_Int, Int_Real) =
4835 end Is_Out_Of_Range;
4837 ----------------------
4838 -- Is_Static_Choice --
4839 ----------------------
4841 function Is_Static_Choice (Choice : Node_Id) return Boolean is
4843 -- Check various possibilities for choice
4845 -- Note: for membership tests, we test more cases than are possible
4846 -- (in particular subtype indication), but it doesn't matter because
4847 -- it just won't occur (we have already done a syntax check).
4849 if Nkind (Choice) = N_Others_Choice then
4852 elsif Nkind (Choice) = N_Range then
4853 return Is_Static_Range (Choice);
4855 elsif Nkind (Choice) = N_Subtype_Indication
4856 or else (Is_Entity_Name (Choice) and then Is_Type (Entity (Choice)))
4858 return Is_Static_Subtype (Etype (Choice));
4861 return Is_Static_Expression (Choice);
4863 end Is_Static_Choice;
4865 ---------------------------
4866 -- Is_Static_Choice_List --
4867 ---------------------------
4869 function Is_Static_Choice_List (Choices : List_Id) return Boolean is
4873 Choice := First (Choices);
4874 while Present (Choice) loop
4875 if not Is_Static_Choice (Choice) then
4883 end Is_Static_Choice_List;
4885 ---------------------
4886 -- Is_Static_Range --
4887 ---------------------
4889 -- A static range is a range whose bounds are static expressions, or a
4890 -- Range_Attribute_Reference equivalent to such a range (RM 4.9(26)).
4891 -- We have already converted range attribute references, so we get the
4892 -- "or" part of this rule without needing a special test.
4894 function Is_Static_Range (N : Node_Id) return Boolean is
4896 return Is_Static_Expression (Low_Bound (N))
4898 Is_Static_Expression (High_Bound (N));
4899 end Is_Static_Range;
4901 -----------------------
4902 -- Is_Static_Subtype --
4903 -----------------------
4905 -- Determines if Typ is a static subtype as defined in (RM 4.9(26))
4907 function Is_Static_Subtype (Typ : Entity_Id) return Boolean is
4908 Base_T : constant Entity_Id := Base_Type (Typ);
4909 Anc_Subt : Entity_Id;
4912 -- First a quick check on the non static subtype flag. As described
4913 -- in further detail in Einfo, this flag is not decisive in all cases,
4914 -- but if it is set, then the subtype is definitely non-static.
4916 if Is_Non_Static_Subtype (Typ) then
4920 Anc_Subt := Ancestor_Subtype (Typ);
4922 if Anc_Subt = Empty then
4926 if Is_Generic_Type (Root_Type (Base_T))
4927 or else Is_Generic_Actual_Type (Base_T)
4931 elsif Has_Dynamic_Predicate_Aspect (Typ) then
4936 elsif Is_String_Type (Typ) then
4938 Ekind (Typ) = E_String_Literal_Subtype
4939 or else (Is_Static_Subtype (Component_Type (Typ))
4940 and then Is_Static_Subtype (Etype (First_Index (Typ))));
4944 elsif Is_Scalar_Type (Typ) then
4945 if Base_T = Typ then
4949 return Is_Static_Subtype (Anc_Subt)
4950 and then Is_Static_Expression (Type_Low_Bound (Typ))
4951 and then Is_Static_Expression (Type_High_Bound (Typ));
4954 -- Types other than string and scalar types are never static
4959 end Is_Static_Subtype;
4961 -------------------------------
4962 -- Is_Statically_Unevaluated --
4963 -------------------------------
4965 function Is_Statically_Unevaluated (Expr : Node_Id) return Boolean is
4966 function Check_Case_Expr_Alternative
4967 (CEA : Node_Id) return Match_Result;
4968 -- We have a message emanating from the Expression of a case expression
4969 -- alternative. We examine this alternative, as follows:
4971 -- If the selecting expression of the parent case is non-static, or
4972 -- if any of the discrete choices of the given case alternative are
4973 -- non-static or raise Constraint_Error, return Non_Static.
4975 -- Otherwise check if the selecting expression matches any of the given
4976 -- discrete choices. If so, the alternative is executed and we return
4977 -- Match, otherwise, the alternative can never be executed, and so we
4980 ---------------------------------
4981 -- Check_Case_Expr_Alternative --
4982 ---------------------------------
4984 function Check_Case_Expr_Alternative
4985 (CEA : Node_Id) return Match_Result
4987 Case_Exp : constant Node_Id := Parent (CEA);
4992 pragma Assert (Nkind (Case_Exp) = N_Case_Expression);
4994 -- Check that selecting expression is static
4996 if not Is_OK_Static_Expression (Expression (Case_Exp)) then
5000 if not Is_OK_Static_Choice_List (Discrete_Choices (CEA)) then
5004 -- All choices are now known to be static. Now see if alternative
5005 -- matches one of the choices.
5007 Choice := First (Discrete_Choices (CEA));
5008 while Present (Choice) loop
5010 -- Check various possibilities for choice, returning Match if we
5011 -- find the selecting value matches any of the choices. Note that
5012 -- we know we are the last choice, so we don't have to keep going.
5014 if Nkind (Choice) = N_Others_Choice then
5016 -- Others choice is a bit annoying, it matches if none of the
5017 -- previous alternatives matches (note that we know we are the
5018 -- last alternative in this case, so we can just go backwards
5019 -- from us to see if any previous one matches).
5021 Prev_CEA := Prev (CEA);
5022 while Present (Prev_CEA) loop
5023 if Check_Case_Expr_Alternative (Prev_CEA) = Match then
5032 -- Else we have a normal static choice
5034 elsif Choice_Matches (Expression (Case_Exp), Choice) = Match then
5038 -- If we fall through, it means that the discrete choice did not
5039 -- match the selecting expression, so continue.
5044 -- If we get through that loop then all choices were static, and none
5045 -- of them matched the selecting expression. So return No_Match.
5048 end Check_Case_Expr_Alternative;
5056 -- Start of processing for Is_Statically_Unevaluated
5059 -- The (32.x) references here are from RM section 4.9
5061 -- (32.1) An expression is statically unevaluated if it is part of ...
5063 -- This means we have to climb the tree looking for one of the cases
5070 -- (32.2) The right operand of a static short-circuit control form
5071 -- whose value is determined by its left operand.
5073 -- AND THEN with False as left operand
5075 if Nkind (P) = N_And_Then
5076 and then Compile_Time_Known_Value (Left_Opnd (P))
5077 and then Is_False (Expr_Value (Left_Opnd (P)))
5081 -- OR ELSE with True as left operand
5083 elsif Nkind (P) = N_Or_Else
5084 and then Compile_Time_Known_Value (Left_Opnd (P))
5085 and then Is_True (Expr_Value (Left_Opnd (P)))
5089 -- (32.3) A dependent_expression of an if_expression whose associated
5090 -- condition is static and equals False.
5092 elsif Nkind (P) = N_If_Expression then
5094 Cond : constant Node_Id := First (Expressions (P));
5095 Texp : constant Node_Id := Next (Cond);
5096 Fexp : constant Node_Id := Next (Texp);
5099 if Compile_Time_Known_Value (Cond) then
5101 -- Condition is True and we are in the right operand
5103 if Is_True (Expr_Value (Cond)) and then OldP = Fexp then
5106 -- Condition is False and we are in the left operand
5108 elsif Is_False (Expr_Value (Cond)) and then OldP = Texp then
5114 -- (32.4) A condition or dependent_expression of an if_expression
5115 -- where the condition corresponding to at least one preceding
5116 -- dependent_expression of the if_expression is static and equals
5119 -- This refers to cases like
5121 -- (if True then 1 elsif 1/0=2 then 2 else 3)
5123 -- But we expand elsif's out anyway, so the above looks like:
5125 -- (if True then 1 else (if 1/0=2 then 2 else 3))
5127 -- So for us this is caught by the above check for the 32.3 case.
5129 -- (32.5) A dependent_expression of a case_expression whose
5130 -- selecting_expression is static and whose value is not covered
5131 -- by the corresponding discrete_choice_list.
5133 elsif Nkind (P) = N_Case_Expression_Alternative then
5135 -- First, we have to be in the expression to suppress messages.
5136 -- If we are within one of the choices, we want the message.
5138 if OldP = Expression (P) then
5140 -- Statically unevaluated if alternative does not match
5142 if Check_Case_Expr_Alternative (P) = No_Match then
5147 -- (32.6) A choice_expression (or a simple_expression of a range
5148 -- that occurs as a membership_choice of a membership_choice_list)
5149 -- of a static membership test that is preceded in the enclosing
5150 -- membership_choice_list by another item whose individual
5151 -- membership test (see (RM 4.5.2)) statically yields True.
5153 elsif Nkind (P) in N_Membership_Test then
5155 -- Only possibly unevaluated if simple expression is static
5157 if not Is_OK_Static_Expression (Left_Opnd (P)) then
5160 -- All members of the choice list must be static
5162 elsif (Present (Right_Opnd (P))
5163 and then not Is_OK_Static_Choice (Right_Opnd (P)))
5164 or else (Present (Alternatives (P))
5166 not Is_OK_Static_Choice_List (Alternatives (P)))
5170 -- If expression is the one and only alternative, then it is
5171 -- definitely not statically unevaluated, so we only have to
5172 -- test the case where there are alternatives present.
5174 elsif Present (Alternatives (P)) then
5176 -- Look for previous matching Choice
5178 Choice := First (Alternatives (P));
5179 while Present (Choice) loop
5181 -- If we reached us and no previous choices matched, this
5182 -- is not the case where we are statically unevaluated.
5184 exit when OldP = Choice;
5186 -- If a previous choice matches, then that is the case where
5187 -- we know our choice is statically unevaluated.
5189 if Choice_Matches (Left_Opnd (P), Choice) = Match then
5196 -- If we fall through the loop, we were not one of the choices,
5197 -- we must have been the expression, so that is not covered by
5198 -- this rule, and we keep going.
5204 -- OK, not statically unevaluated at this level, see if we should
5205 -- keep climbing to look for a higher level reason.
5207 -- Special case for component association in aggregates, where
5208 -- we want to keep climbing up to the parent aggregate.
5210 if Nkind (P) = N_Component_Association
5211 and then Nkind (Parent (P)) = N_Aggregate
5215 -- All done if not still within subexpression
5218 exit when Nkind (P) not in N_Subexpr;
5222 -- If we fall through the loop, not one of the cases covered!
5225 end Is_Statically_Unevaluated;
5227 --------------------
5228 -- Not_Null_Range --
5229 --------------------
5231 function Not_Null_Range (Lo : Node_Id; Hi : Node_Id) return Boolean is
5232 Typ : constant Entity_Id := Etype (Lo);
5235 if not Compile_Time_Known_Value (Lo)
5236 or else not Compile_Time_Known_Value (Hi)
5241 if Is_Discrete_Type (Typ) then
5242 return Expr_Value (Lo) <= Expr_Value (Hi);
5243 else pragma Assert (Is_Real_Type (Typ));
5244 return Expr_Value_R (Lo) <= Expr_Value_R (Hi);
5252 function OK_Bits (N : Node_Id; Bits : Uint) return Boolean is
5254 -- We allow a maximum of 500,000 bits which seems a reasonable limit
5256 if Bits < 500_000 then
5259 -- Error if this maximum is exceeded
5262 Error_Msg_N ("static value too large, capacity exceeded", N);
5271 procedure Out_Of_Range (N : Node_Id) is
5273 -- If we have the static expression case, then this is an illegality
5274 -- in Ada 95 mode, except that in an instance, we never generate an
5275 -- error (if the error is legitimate, it was already diagnosed in the
5278 if Is_Static_Expression (N)
5279 and then not In_Instance
5280 and then not In_Inlined_Body
5281 and then Ada_Version >= Ada_95
5283 -- No message if we are statically unevaluated
5285 if Is_Statically_Unevaluated (N) then
5288 -- The expression to compute the length of a packed array is attached
5289 -- to the array type itself, and deserves a separate message.
5291 elsif Nkind (Parent (N)) = N_Defining_Identifier
5292 and then Is_Array_Type (Parent (N))
5293 and then Present (Packed_Array_Impl_Type (Parent (N)))
5294 and then Present (First_Rep_Item (Parent (N)))
5297 ("length of packed array must not exceed Integer''Last",
5298 First_Rep_Item (Parent (N)));
5299 Rewrite (N, Make_Integer_Literal (Sloc (N), Uint_1));
5301 -- All cases except the special array case
5304 Apply_Compile_Time_Constraint_Error
5305 (N, "value not in range of}", CE_Range_Check_Failed);
5308 -- Here we generate a warning for the Ada 83 case, or when we are in an
5309 -- instance, or when we have a non-static expression case.
5312 Apply_Compile_Time_Constraint_Error
5313 (N, "value not in range of}??", CE_Range_Check_Failed);
5317 ----------------------
5318 -- Predicates_Match --
5319 ----------------------
5321 function Predicates_Match (T1, T2 : Entity_Id) return Boolean is
5326 if Ada_Version < Ada_2012 then
5329 -- Both types must have predicates or lack them
5331 elsif Has_Predicates (T1) /= Has_Predicates (T2) then
5334 -- Check matching predicates
5339 (T1, Name_Static_Predicate, Check_Parents => False);
5342 (T2, Name_Static_Predicate, Check_Parents => False);
5344 -- Subtypes statically match if the predicate comes from the
5345 -- same declaration, which can only happen if one is a subtype
5346 -- of the other and has no explicit predicate.
5348 -- Suppress warnings on order of actuals, which is otherwise
5349 -- triggered by one of the two calls below.
5351 pragma Warnings (Off);
5352 return Pred1 = Pred2
5353 or else (No (Pred1) and then Is_Subtype_Of (T1, T2))
5354 or else (No (Pred2) and then Is_Subtype_Of (T2, T1));
5355 pragma Warnings (On);
5357 end Predicates_Match;
5359 ---------------------------------------------
5360 -- Real_Or_String_Static_Predicate_Matches --
5361 ---------------------------------------------
5363 function Real_Or_String_Static_Predicate_Matches
5365 Typ : Entity_Id) return Boolean
5367 Expr : constant Node_Id := Static_Real_Or_String_Predicate (Typ);
5368 -- The predicate expression from the type
5370 Pfun : constant Entity_Id := Predicate_Function (Typ);
5371 -- The entity for the predicate function
5373 Ent_Name : constant Name_Id := Chars (First_Formal (Pfun));
5374 -- The name of the formal of the predicate function. Occurrences of the
5375 -- type name in Expr have been rewritten as references to this formal,
5376 -- and it has a unique name, so we can identify references by this name.
5379 -- Copy of the predicate function tree
5381 function Process (N : Node_Id) return Traverse_Result;
5382 -- Function used to process nodes during the traversal in which we will
5383 -- find occurrences of the entity name, and replace such occurrences
5384 -- by a real literal with the value to be tested.
5386 procedure Traverse is new Traverse_Proc (Process);
5387 -- The actual traversal procedure
5393 function Process (N : Node_Id) return Traverse_Result is
5395 if Nkind (N) = N_Identifier and then Chars (N) = Ent_Name then
5397 Nod : constant Node_Id := New_Copy (Val);
5399 Set_Sloc (Nod, Sloc (N));
5409 -- Start of processing for Real_Or_String_Static_Predicate_Matches
5412 -- First deal with special case of inherited predicate, where the
5413 -- predicate expression looks like:
5415 -- xxPredicate (typ (Ent)) and then Expr
5417 -- where Expr is the predicate expression for this level, and the
5418 -- left operand is the call to evaluate the inherited predicate.
5420 if Nkind (Expr) = N_And_Then
5421 and then Nkind (Left_Opnd (Expr)) = N_Function_Call
5422 and then Is_Predicate_Function (Entity (Name (Left_Opnd (Expr))))
5424 -- OK we have the inherited case, so make a call to evaluate the
5425 -- inherited predicate. If that fails, so do we!
5428 Real_Or_String_Static_Predicate_Matches
5430 Typ => Etype (First_Formal (Entity (Name (Left_Opnd (Expr))))))
5435 -- Use the right operand for the continued processing
5437 Copy := Copy_Separate_Tree (Right_Opnd (Expr));
5439 -- Case where call to predicate function appears on its own (this means
5440 -- that the predicate at this level is just inherited from the parent).
5442 elsif Nkind (Expr) = N_Function_Call then
5444 Typ : constant Entity_Id :=
5445 Etype (First_Formal (Entity (Name (Expr))));
5448 -- If the inherited predicate is dynamic, just ignore it. We can't
5449 -- go trying to evaluate a dynamic predicate as a static one!
5451 if Has_Dynamic_Predicate_Aspect (Typ) then
5454 -- Otherwise inherited predicate is static, check for match
5457 return Real_Or_String_Static_Predicate_Matches (Val, Typ);
5461 -- If not just an inherited predicate, copy whole expression
5464 Copy := Copy_Separate_Tree (Expr);
5467 -- Now we replace occurrences of the entity by the value
5471 -- And analyze the resulting static expression to see if it is True
5473 Analyze_And_Resolve (Copy, Standard_Boolean);
5474 return Is_True (Expr_Value (Copy));
5475 end Real_Or_String_Static_Predicate_Matches;
5477 -------------------------
5478 -- Rewrite_In_Raise_CE --
5479 -------------------------
5481 procedure Rewrite_In_Raise_CE (N : Node_Id; Exp : Node_Id) is
5482 Typ : constant Entity_Id := Etype (N);
5483 Stat : constant Boolean := Is_Static_Expression (N);
5486 -- If we want to raise CE in the condition of a N_Raise_CE node, we
5487 -- can just clear the condition if the reason is appropriate. We do
5488 -- not do this operation if the parent has a reason other than range
5489 -- check failed, because otherwise we would change the reason.
5491 if Present (Parent (N))
5492 and then Nkind (Parent (N)) = N_Raise_Constraint_Error
5493 and then Reason (Parent (N)) =
5494 UI_From_Int (RT_Exception_Code'Pos (CE_Range_Check_Failed))
5496 Set_Condition (Parent (N), Empty);
5498 -- Else build an explicit N_Raise_CE
5502 Make_Raise_Constraint_Error (Sloc (Exp),
5503 Reason => CE_Range_Check_Failed));
5504 Set_Raises_Constraint_Error (N);
5508 -- Set proper flags in result
5510 Set_Raises_Constraint_Error (N, True);
5511 Set_Is_Static_Expression (N, Stat);
5512 end Rewrite_In_Raise_CE;
5514 ---------------------
5515 -- String_Type_Len --
5516 ---------------------
5518 function String_Type_Len (Stype : Entity_Id) return Uint is
5519 NT : constant Entity_Id := Etype (First_Index (Stype));
5523 if Is_OK_Static_Subtype (NT) then
5526 T := Base_Type (NT);
5529 return Expr_Value (Type_High_Bound (T)) -
5530 Expr_Value (Type_Low_Bound (T)) + 1;
5531 end String_Type_Len;
5533 ------------------------------------
5534 -- Subtypes_Statically_Compatible --
5535 ------------------------------------
5537 function Subtypes_Statically_Compatible
5540 Formal_Derived_Matching : Boolean := False) return Boolean
5545 if Is_Scalar_Type (T1) then
5547 -- Definitely compatible if we match
5549 if Subtypes_Statically_Match (T1, T2) then
5552 -- If either subtype is nonstatic then they're not compatible
5554 elsif not Is_OK_Static_Subtype (T1)
5556 not Is_OK_Static_Subtype (T2)
5560 -- If either type has constraint error bounds, then consider that
5561 -- they match to avoid junk cascaded errors here.
5563 elsif not Is_OK_Static_Subtype (T1)
5564 or else not Is_OK_Static_Subtype (T2)
5568 -- Base types must match, but we don't check that (should we???) but
5569 -- we do at least check that both types are real, or both types are
5572 elsif Is_Real_Type (T1) /= Is_Real_Type (T2) then
5575 -- Here we check the bounds
5579 LB1 : constant Node_Id := Type_Low_Bound (T1);
5580 HB1 : constant Node_Id := Type_High_Bound (T1);
5581 LB2 : constant Node_Id := Type_Low_Bound (T2);
5582 HB2 : constant Node_Id := Type_High_Bound (T2);
5585 if Is_Real_Type (T1) then
5587 (Expr_Value_R (LB1) > Expr_Value_R (HB1))
5589 (Expr_Value_R (LB2) <= Expr_Value_R (LB1)
5591 Expr_Value_R (HB1) <= Expr_Value_R (HB2));
5595 (Expr_Value (LB1) > Expr_Value (HB1))
5597 (Expr_Value (LB2) <= Expr_Value (LB1)
5599 Expr_Value (HB1) <= Expr_Value (HB2));
5606 elsif Is_Access_Type (T1) then
5607 return (not Is_Constrained (T2)
5608 or else (Subtypes_Statically_Match
5609 (Designated_Type (T1), Designated_Type (T2))))
5610 and then not (Can_Never_Be_Null (T2)
5611 and then not Can_Never_Be_Null (T1));
5616 return (Is_Composite_Type (T1) and then not Is_Constrained (T2))
5617 or else Subtypes_Statically_Match (T1, T2, Formal_Derived_Matching);
5619 end Subtypes_Statically_Compatible;
5621 -------------------------------
5622 -- Subtypes_Statically_Match --
5623 -------------------------------
5625 -- Subtypes statically match if they have statically matching constraints
5626 -- (RM 4.9.1(2)). Constraints statically match if there are none, or if
5627 -- they are the same identical constraint, or if they are static and the
5628 -- values match (RM 4.9.1(1)).
5630 -- In addition, in GNAT, the object size (Esize) values of the types must
5631 -- match if they are set (unless checking an actual for a formal derived
5632 -- type). The use of 'Object_Size can cause this to be false even if the
5633 -- types would otherwise match in the RM sense.
5635 function Subtypes_Statically_Match
5638 Formal_Derived_Matching : Boolean := False) return Boolean
5641 -- A type always statically matches itself
5646 -- No match if sizes different (from use of 'Object_Size). This test
5647 -- is excluded if Formal_Derived_Matching is True, as the base types
5648 -- can be different in that case and typically have different sizes
5649 -- (and Esizes can be set when Frontend_Layout_On_Target is True).
5651 elsif not Formal_Derived_Matching
5652 and then Known_Static_Esize (T1)
5653 and then Known_Static_Esize (T2)
5654 and then Esize (T1) /= Esize (T2)
5658 -- No match if predicates do not match
5660 elsif not Predicates_Match (T1, T2) then
5665 elsif Is_Scalar_Type (T1) then
5667 -- Base types must be the same
5669 if Base_Type (T1) /= Base_Type (T2) then
5673 -- A constrained numeric subtype never matches an unconstrained
5674 -- subtype, i.e. both types must be constrained or unconstrained.
5676 -- To understand the requirement for this test, see RM 4.9.1(1).
5677 -- As is made clear in RM 3.5.4(11), type Integer, for example is
5678 -- a constrained subtype with constraint bounds matching the bounds
5679 -- of its corresponding unconstrained base type. In this situation,
5680 -- Integer and Integer'Base do not statically match, even though
5681 -- they have the same bounds.
5683 -- We only apply this test to types in Standard and types that appear
5684 -- in user programs. That way, we do not have to be too careful about
5685 -- setting Is_Constrained right for Itypes.
5687 if Is_Numeric_Type (T1)
5688 and then (Is_Constrained (T1) /= Is_Constrained (T2))
5689 and then (Scope (T1) = Standard_Standard
5690 or else Comes_From_Source (T1))
5691 and then (Scope (T2) = Standard_Standard
5692 or else Comes_From_Source (T2))
5696 -- A generic scalar type does not statically match its base type
5697 -- (AI-311). In this case we make sure that the formals, which are
5698 -- first subtypes of their bases, are constrained.
5700 elsif Is_Generic_Type (T1)
5701 and then Is_Generic_Type (T2)
5702 and then (Is_Constrained (T1) /= Is_Constrained (T2))
5707 -- If there was an error in either range, then just assume the types
5708 -- statically match to avoid further junk errors.
5710 if No (Scalar_Range (T1)) or else No (Scalar_Range (T2))
5711 or else Error_Posted (Scalar_Range (T1))
5712 or else Error_Posted (Scalar_Range (T2))
5717 -- Otherwise both types have bounds that can be compared
5720 LB1 : constant Node_Id := Type_Low_Bound (T1);
5721 HB1 : constant Node_Id := Type_High_Bound (T1);
5722 LB2 : constant Node_Id := Type_Low_Bound (T2);
5723 HB2 : constant Node_Id := Type_High_Bound (T2);
5726 -- If the bounds are the same tree node, then match (common case)
5728 if LB1 = LB2 and then HB1 = HB2 then
5731 -- Otherwise bounds must be static and identical value
5734 if not Is_OK_Static_Subtype (T1)
5735 or else not Is_OK_Static_Subtype (T2)
5739 -- If either type has constraint error bounds, then say that
5740 -- they match to avoid junk cascaded errors here.
5742 elsif not Is_OK_Static_Subtype (T1)
5743 or else not Is_OK_Static_Subtype (T2)
5747 elsif Is_Real_Type (T1) then
5749 (Expr_Value_R (LB1) = Expr_Value_R (LB2))
5751 (Expr_Value_R (HB1) = Expr_Value_R (HB2));
5755 Expr_Value (LB1) = Expr_Value (LB2)
5757 Expr_Value (HB1) = Expr_Value (HB2);
5762 -- Type with discriminants
5764 elsif Has_Discriminants (T1) or else Has_Discriminants (T2) then
5766 -- Because of view exchanges in multiple instantiations, conformance
5767 -- checking might try to match a partial view of a type with no
5768 -- discriminants with a full view that has defaulted discriminants.
5769 -- In such a case, use the discriminant constraint of the full view,
5770 -- which must exist because we know that the two subtypes have the
5773 if Has_Discriminants (T1) /= Has_Discriminants (T2) then
5774 -- A generic actual type is declared through a subtype declaration
5775 -- and may have an inconsistent indication of the presence of
5776 -- discriminants, so check the type it renames.
5778 if Is_Generic_Actual_Type (T1)
5779 and then not Has_Discriminants (Etype (T1))
5780 and then not Has_Discriminants (T2)
5784 elsif In_Instance then
5785 if Is_Private_Type (T2)
5786 and then Present (Full_View (T2))
5787 and then Has_Discriminants (Full_View (T2))
5789 return Subtypes_Statically_Match (T1, Full_View (T2));
5791 elsif Is_Private_Type (T1)
5792 and then Present (Full_View (T1))
5793 and then Has_Discriminants (Full_View (T1))
5795 return Subtypes_Statically_Match (Full_View (T1), T2);
5806 DL1 : constant Elist_Id := Discriminant_Constraint (T1);
5807 DL2 : constant Elist_Id := Discriminant_Constraint (T2);
5815 elsif Is_Constrained (T1) /= Is_Constrained (T2) then
5819 -- Now loop through the discriminant constraints
5821 -- Note: the guard here seems necessary, since it is possible at
5822 -- least for DL1 to be No_Elist. Not clear this is reasonable ???
5824 if Present (DL1) and then Present (DL2) then
5825 DA1 := First_Elmt (DL1);
5826 DA2 := First_Elmt (DL2);
5827 while Present (DA1) loop
5829 Expr1 : constant Node_Id := Node (DA1);
5830 Expr2 : constant Node_Id := Node (DA2);
5833 if not Is_OK_Static_Expression (Expr1)
5834 or else not Is_OK_Static_Expression (Expr2)
5838 -- If either expression raised a constraint error,
5839 -- consider the expressions as matching, since this
5840 -- helps to prevent cascading errors.
5842 elsif Raises_Constraint_Error (Expr1)
5843 or else Raises_Constraint_Error (Expr2)
5847 elsif Expr_Value (Expr1) /= Expr_Value (Expr2) then
5860 -- A definite type does not match an indefinite or classwide type.
5861 -- However, a generic type with unknown discriminants may be
5862 -- instantiated with a type with no discriminants, and conformance
5863 -- checking on an inherited operation may compare the actual with the
5864 -- subtype that renames it in the instance.
5866 elsif Has_Unknown_Discriminants (T1) /= Has_Unknown_Discriminants (T2)
5869 Is_Generic_Actual_Type (T1) or else Is_Generic_Actual_Type (T2);
5873 elsif Is_Array_Type (T1) then
5875 -- If either subtype is unconstrained then both must be, and if both
5876 -- are unconstrained then no further checking is needed.
5878 if not Is_Constrained (T1) or else not Is_Constrained (T2) then
5879 return not (Is_Constrained (T1) or else Is_Constrained (T2));
5882 -- Both subtypes are constrained, so check that the index subtypes
5883 -- statically match.
5886 Index1 : Node_Id := First_Index (T1);
5887 Index2 : Node_Id := First_Index (T2);
5890 while Present (Index1) loop
5892 Subtypes_Statically_Match (Etype (Index1), Etype (Index2))
5897 Next_Index (Index1);
5898 Next_Index (Index2);
5904 elsif Is_Access_Type (T1) then
5905 if Can_Never_Be_Null (T1) /= Can_Never_Be_Null (T2) then
5908 elsif Ekind_In (T1, E_Access_Subprogram_Type,
5909 E_Anonymous_Access_Subprogram_Type)
5913 (Designated_Type (T1),
5914 Designated_Type (T2));
5917 Subtypes_Statically_Match
5918 (Designated_Type (T1),
5919 Designated_Type (T2))
5920 and then Is_Access_Constant (T1) = Is_Access_Constant (T2);
5923 -- All other types definitely match
5928 end Subtypes_Statically_Match;
5934 function Test (Cond : Boolean) return Uint is
5943 ---------------------------------
5944 -- Test_Expression_Is_Foldable --
5945 ---------------------------------
5949 procedure Test_Expression_Is_Foldable
5959 if Debug_Flag_Dot_F and then In_Extended_Main_Source_Unit (N) then
5963 -- If operand is Any_Type, just propagate to result and do not
5964 -- try to fold, this prevents cascaded errors.
5966 if Etype (Op1) = Any_Type then
5967 Set_Etype (N, Any_Type);
5970 -- If operand raises constraint error, then replace node N with the
5971 -- raise constraint error node, and we are obviously not foldable.
5972 -- Note that this replacement inherits the Is_Static_Expression flag
5973 -- from the operand.
5975 elsif Raises_Constraint_Error (Op1) then
5976 Rewrite_In_Raise_CE (N, Op1);
5979 -- If the operand is not static, then the result is not static, and
5980 -- all we have to do is to check the operand since it is now known
5981 -- to appear in a non-static context.
5983 elsif not Is_Static_Expression (Op1) then
5984 Check_Non_Static_Context (Op1);
5985 Fold := Compile_Time_Known_Value (Op1);
5988 -- An expression of a formal modular type is not foldable because
5989 -- the modulus is unknown.
5991 elsif Is_Modular_Integer_Type (Etype (Op1))
5992 and then Is_Generic_Type (Etype (Op1))
5994 Check_Non_Static_Context (Op1);
5997 -- Here we have the case of an operand whose type is OK, which is
5998 -- static, and which does not raise constraint error, we can fold.
6001 Set_Is_Static_Expression (N);
6005 end Test_Expression_Is_Foldable;
6009 procedure Test_Expression_Is_Foldable
6015 CRT_Safe : Boolean := False)
6017 Rstat : constant Boolean := Is_Static_Expression (Op1)
6019 Is_Static_Expression (Op2);
6025 -- Inhibit folding if -gnatd.f flag set
6027 if Debug_Flag_Dot_F and then In_Extended_Main_Source_Unit (N) then
6031 -- If either operand is Any_Type, just propagate to result and
6032 -- do not try to fold, this prevents cascaded errors.
6034 if Etype (Op1) = Any_Type or else Etype (Op2) = Any_Type then
6035 Set_Etype (N, Any_Type);
6038 -- If left operand raises constraint error, then replace node N with the
6039 -- Raise_Constraint_Error node, and we are obviously not foldable.
6040 -- Is_Static_Expression is set from the two operands in the normal way,
6041 -- and we check the right operand if it is in a non-static context.
6043 elsif Raises_Constraint_Error (Op1) then
6045 Check_Non_Static_Context (Op2);
6048 Rewrite_In_Raise_CE (N, Op1);
6049 Set_Is_Static_Expression (N, Rstat);
6052 -- Similar processing for the case of the right operand. Note that we
6053 -- don't use this routine for the short-circuit case, so we do not have
6054 -- to worry about that special case here.
6056 elsif Raises_Constraint_Error (Op2) then
6058 Check_Non_Static_Context (Op1);
6061 Rewrite_In_Raise_CE (N, Op2);
6062 Set_Is_Static_Expression (N, Rstat);
6065 -- Exclude expressions of a generic modular type, as above
6067 elsif Is_Modular_Integer_Type (Etype (Op1))
6068 and then Is_Generic_Type (Etype (Op1))
6070 Check_Non_Static_Context (Op1);
6073 -- If result is not static, then check non-static contexts on operands
6074 -- since one of them may be static and the other one may not be static.
6076 elsif not Rstat then
6077 Check_Non_Static_Context (Op1);
6078 Check_Non_Static_Context (Op2);
6081 Fold := CRT_Safe_Compile_Time_Known_Value (Op1)
6082 and then CRT_Safe_Compile_Time_Known_Value (Op2);
6084 Fold := Compile_Time_Known_Value (Op1)
6085 and then Compile_Time_Known_Value (Op2);
6090 -- Else result is static and foldable. Both operands are static, and
6091 -- neither raises constraint error, so we can definitely fold.
6094 Set_Is_Static_Expression (N);
6099 end Test_Expression_Is_Foldable;
6105 function Test_In_Range
6108 Assume_Valid : Boolean;
6109 Fixed_Int : Boolean;
6110 Int_Real : Boolean) return Range_Membership
6115 pragma Warnings (Off, Assume_Valid);
6116 -- For now Assume_Valid is unreferenced since the current implementation
6117 -- always returns Unknown if N is not a compile time known value, but we
6118 -- keep the parameter to allow for future enhancements in which we try
6119 -- to get the information in the variable case as well.
6122 -- If an error was posted on expression, then return Unknown, we do not
6123 -- want cascaded errors based on some false analysis of a junk node.
6125 if Error_Posted (N) then
6128 -- Expression that raises constraint error is an odd case. We certainly
6129 -- do not want to consider it to be in range. It might make sense to
6130 -- consider it always out of range, but this causes incorrect error
6131 -- messages about static expressions out of range. So we just return
6132 -- Unknown, which is always safe.
6134 elsif Raises_Constraint_Error (N) then
6137 -- Universal types have no range limits, so always in range
6139 elsif Typ = Universal_Integer or else Typ = Universal_Real then
6142 -- Never known if not scalar type. Don't know if this can actually
6143 -- happen, but our spec allows it, so we must check.
6145 elsif not Is_Scalar_Type (Typ) then
6148 -- Never known if this is a generic type, since the bounds of generic
6149 -- types are junk. Note that if we only checked for static expressions
6150 -- (instead of compile time known values) below, we would not need this
6151 -- check, because values of a generic type can never be static, but they
6152 -- can be known at compile time.
6154 elsif Is_Generic_Type (Typ) then
6157 -- Case of a known compile time value, where we can check if it is in
6158 -- the bounds of the given type.
6160 elsif Compile_Time_Known_Value (N) then
6169 Lo := Type_Low_Bound (Typ);
6170 Hi := Type_High_Bound (Typ);
6172 LB_Known := Compile_Time_Known_Value (Lo);
6173 HB_Known := Compile_Time_Known_Value (Hi);
6175 -- Fixed point types should be considered as such only if flag
6176 -- Fixed_Int is set to False.
6178 if Is_Floating_Point_Type (Typ)
6179 or else (Is_Fixed_Point_Type (Typ) and then not Fixed_Int)
6182 Valr := Expr_Value_R (N);
6184 if LB_Known and HB_Known then
6185 if Valr >= Expr_Value_R (Lo)
6187 Valr <= Expr_Value_R (Hi)
6191 return Out_Of_Range;
6194 elsif (LB_Known and then Valr < Expr_Value_R (Lo))
6196 (HB_Known and then Valr > Expr_Value_R (Hi))
6198 return Out_Of_Range;
6205 Val := Expr_Value (N);
6207 if LB_Known and HB_Known then
6208 if Val >= Expr_Value (Lo) and then Val <= Expr_Value (Hi)
6212 return Out_Of_Range;
6215 elsif (LB_Known and then Val < Expr_Value (Lo))
6217 (HB_Known and then Val > Expr_Value (Hi))
6219 return Out_Of_Range;
6227 -- Here for value not known at compile time. Case of expression subtype
6228 -- is Typ or is a subtype of Typ, and we can assume expression is valid.
6229 -- In this case we know it is in range without knowing its value.
6232 and then (Etype (N) = Typ or else Is_Subtype_Of (Etype (N), Typ))
6236 -- Another special case. For signed integer types, if the target type
6237 -- has Is_Known_Valid set, and the source type does not have a larger
6238 -- size, then the source value must be in range. We exclude biased
6239 -- types, because they bizarrely can generate out of range values.
6241 elsif Is_Signed_Integer_Type (Etype (N))
6242 and then Is_Known_Valid (Typ)
6243 and then Esize (Etype (N)) <= Esize (Typ)
6244 and then not Has_Biased_Representation (Etype (N))
6248 -- For all other cases, result is unknown
6259 procedure To_Bits (U : Uint; B : out Bits) is
6261 for J in 0 .. B'Last loop
6262 B (J) := (U / (2 ** J)) mod 2 /= 0;
6266 --------------------
6267 -- Why_Not_Static --
6268 --------------------
6270 procedure Why_Not_Static (Expr : Node_Id) is
6271 N : constant Node_Id := Original_Node (Expr);
6277 procedure Why_Not_Static_List (L : List_Id);
6278 -- A version that can be called on a list of expressions. Finds all
6279 -- non-static violations in any element of the list.
6281 -------------------------
6282 -- Why_Not_Static_List --
6283 -------------------------
6285 procedure Why_Not_Static_List (L : List_Id) is
6288 if Is_Non_Empty_List (L) then
6290 while Present (N) loop
6295 end Why_Not_Static_List;
6297 -- Start of processing for Why_Not_Static
6300 -- Ignore call on error or empty node
6302 if No (Expr) or else Nkind (Expr) = N_Error then
6306 -- Preprocessing for sub expressions
6308 if Nkind (Expr) in N_Subexpr then
6310 -- Nothing to do if expression is static
6312 if Is_OK_Static_Expression (Expr) then
6316 -- Test for constraint error raised
6318 if Raises_Constraint_Error (Expr) then
6320 -- Special case membership to find out which piece to flag
6322 if Nkind (N) in N_Membership_Test then
6323 if Raises_Constraint_Error (Left_Opnd (N)) then
6324 Why_Not_Static (Left_Opnd (N));
6327 elsif Present (Right_Opnd (N))
6328 and then Raises_Constraint_Error (Right_Opnd (N))
6330 Why_Not_Static (Right_Opnd (N));
6334 pragma Assert (Present (Alternatives (N)));
6336 Alt := First (Alternatives (N));
6337 while Present (Alt) loop
6338 if Raises_Constraint_Error (Alt) then
6339 Why_Not_Static (Alt);
6347 -- Special case a range to find out which bound to flag
6349 elsif Nkind (N) = N_Range then
6350 if Raises_Constraint_Error (Low_Bound (N)) then
6351 Why_Not_Static (Low_Bound (N));
6354 elsif Raises_Constraint_Error (High_Bound (N)) then
6355 Why_Not_Static (High_Bound (N));
6359 -- Special case attribute to see which part to flag
6361 elsif Nkind (N) = N_Attribute_Reference then
6362 if Raises_Constraint_Error (Prefix (N)) then
6363 Why_Not_Static (Prefix (N));
6367 if Present (Expressions (N)) then
6368 Exp := First (Expressions (N));
6369 while Present (Exp) loop
6370 if Raises_Constraint_Error (Exp) then
6371 Why_Not_Static (Exp);
6379 -- Special case a subtype name
6381 elsif Is_Entity_Name (Expr) and then Is_Type (Entity (Expr)) then
6383 ("!& is not a static subtype (RM 4.9(26))", N, Entity (Expr));
6387 -- End of special cases
6390 ("!expression raises exception, cannot be static (RM 4.9(34))",
6395 -- If no type, then something is pretty wrong, so ignore
6397 Typ := Etype (Expr);
6403 -- Type must be scalar or string type (but allow Bignum, since this
6404 -- is really a scalar type from our point of view in this diagnosis).
6406 if not Is_Scalar_Type (Typ)
6407 and then not Is_String_Type (Typ)
6408 and then not Is_RTE (Typ, RE_Bignum)
6411 ("!static expression must have scalar or string type " &
6417 -- If we got through those checks, test particular node kind
6423 when N_Expanded_Name | N_Identifier | N_Operator_Symbol =>
6426 if Is_Named_Number (E) then
6429 elsif Ekind (E) = E_Constant then
6431 -- One case we can give a metter message is when we have a
6432 -- string literal created by concatenating an aggregate with
6433 -- an others expression.
6435 Entity_Case : declare
6436 CV : constant Node_Id := Constant_Value (E);
6437 CO : constant Node_Id := Original_Node (CV);
6439 function Is_Aggregate (N : Node_Id) return Boolean;
6440 -- See if node N came from an others aggregate, if so
6441 -- return True and set Error_Msg_Sloc to aggregate.
6447 function Is_Aggregate (N : Node_Id) return Boolean is
6449 if Nkind (Original_Node (N)) = N_Aggregate then
6450 Error_Msg_Sloc := Sloc (Original_Node (N));
6453 elsif Is_Entity_Name (N)
6454 and then Ekind (Entity (N)) = E_Constant
6456 Nkind (Original_Node (Constant_Value (Entity (N)))) =
6460 Sloc (Original_Node (Constant_Value (Entity (N))));
6468 -- Start of processing for Entity_Case
6471 if Is_Aggregate (CV)
6472 or else (Nkind (CO) = N_Op_Concat
6473 and then (Is_Aggregate (Left_Opnd (CO))
6475 Is_Aggregate (Right_Opnd (CO))))
6477 Error_Msg_N ("!aggregate (#) is never static", N);
6479 elsif No (CV) or else not Is_Static_Expression (CV) then
6481 ("!& is not a static constant (RM 4.9(5))", N, E);
6485 elsif Is_Type (E) then
6487 ("!& is not a static subtype (RM 4.9(26))", N, E);
6491 ("!& is not static constant or named number "
6492 & "(RM 4.9(5))", N, E);
6497 when N_Binary_Op | N_Short_Circuit | N_Membership_Test =>
6498 if Nkind (N) in N_Op_Shift then
6500 ("!shift functions are never static (RM 4.9(6,18))", N);
6502 Why_Not_Static (Left_Opnd (N));
6503 Why_Not_Static (Right_Opnd (N));
6509 Why_Not_Static (Right_Opnd (N));
6511 -- Attribute reference
6513 when N_Attribute_Reference =>
6514 Why_Not_Static_List (Expressions (N));
6516 E := Etype (Prefix (N));
6518 if E = Standard_Void_Type then
6522 -- Special case non-scalar'Size since this is a common error
6524 if Attribute_Name (N) = Name_Size then
6526 ("!size attribute is only static for static scalar type "
6527 & "(RM 4.9(7,8))", N);
6531 elsif Is_Array_Type (E) then
6532 if not Nam_In (Attribute_Name (N), Name_First,
6537 ("!static array attribute must be Length, First, or Last "
6538 & "(RM 4.9(8))", N);
6540 -- Since we know the expression is not-static (we already
6541 -- tested for this, must mean array is not static).
6545 ("!prefix is non-static array (RM 4.9(8))", Prefix (N));
6550 -- Special case generic types, since again this is a common source
6553 elsif Is_Generic_Actual_Type (E) or else Is_Generic_Type (E) then
6555 ("!attribute of generic type is never static "
6556 & "(RM 4.9(7,8))", N);
6558 elsif Is_OK_Static_Subtype (E) then
6561 elsif Is_Scalar_Type (E) then
6563 ("!prefix type for attribute is not static scalar subtype "
6564 & "(RM 4.9(7))", N);
6568 ("!static attribute must apply to array/scalar type "
6569 & "(RM 4.9(7,8))", N);
6574 when N_String_Literal =>
6576 ("!subtype of string literal is non-static (RM 4.9(4))", N);
6578 -- Explicit dereference
6580 when N_Explicit_Dereference =>
6582 ("!explicit dereference is never static (RM 4.9)", N);
6586 when N_Function_Call =>
6587 Why_Not_Static_List (Parameter_Associations (N));
6589 -- Complain about non-static function call unless we have Bignum
6590 -- which means that the underlying expression is really some
6591 -- scalar arithmetic operation.
6593 if not Is_RTE (Typ, RE_Bignum) then
6594 Error_Msg_N ("!non-static function call (RM 4.9(6,18))", N);
6597 -- Parameter assocation (test actual parameter)
6599 when N_Parameter_Association =>
6600 Why_Not_Static (Explicit_Actual_Parameter (N));
6602 -- Indexed component
6604 when N_Indexed_Component =>
6605 Error_Msg_N ("!indexed component is never static (RM 4.9)", N);
6609 when N_Procedure_Call_Statement =>
6610 Error_Msg_N ("!procedure call is never static (RM 4.9)", N);
6612 -- Qualified expression (test expression)
6614 when N_Qualified_Expression =>
6615 Why_Not_Static (Expression (N));
6619 when N_Aggregate | N_Extension_Aggregate =>
6620 Error_Msg_N ("!an aggregate is never static (RM 4.9)", N);
6625 Why_Not_Static (Low_Bound (N));
6626 Why_Not_Static (High_Bound (N));
6628 -- Range constraint, test range expression
6630 when N_Range_Constraint =>
6631 Why_Not_Static (Range_Expression (N));
6633 -- Subtype indication, test constraint
6635 when N_Subtype_Indication =>
6636 Why_Not_Static (Constraint (N));
6638 -- Selected component
6640 when N_Selected_Component =>
6641 Error_Msg_N ("!selected component is never static (RM 4.9)", N);
6646 Error_Msg_N ("!slice is never static (RM 4.9)", N);
6648 when N_Type_Conversion =>
6649 Why_Not_Static (Expression (N));
6651 if not Is_Scalar_Type (Entity (Subtype_Mark (N)))
6652 or else not Is_OK_Static_Subtype (Entity (Subtype_Mark (N)))
6655 ("!static conversion requires static scalar subtype result "
6656 & "(RM 4.9(9))", N);
6659 -- Unchecked type conversion
6661 when N_Unchecked_Type_Conversion =>
6663 ("!unchecked type conversion is never static (RM 4.9)", N);
6665 -- All other cases, no reason to give