1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2014, 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 From_Bits (B : Bits; T : Entity_Id) return Uint;
177 -- Converts a bit string of length B'Length to a Uint value to be used for
178 -- a target of type T, which is a modular type. This procedure includes the
179 -- necessary reduction by the modulus in the case of a non-binary modulus
180 -- (for a binary modulus, the bit string is the right length any way so all
183 function Is_Static_Choice (Choice : Node_Id) return Boolean;
184 -- Given a choice (from a case expression or membership test), returns
185 -- True if the choice is static. No test is made for raising of constraint
186 -- error, so this function is used only for legality tests.
188 function Is_Static_Choice_List (Choices : List_Id) return Boolean;
189 -- Given a choice list (from a case expression or membership test), return
190 -- True if all choices are static in the sense of Is_Static_Choice.
192 function Is_OK_Static_Choice (Choice : Node_Id) return Boolean;
193 -- Given a choice (from a case expression or membership test), returns
194 -- True if the choice is static and does not raise a Constraint_Error.
196 function Is_OK_Static_Choice_List (Choices : List_Id) return Boolean;
197 -- Given a choice list (from a case expression or membership test), return
198 -- True if all choices are static in the sense of Is_OK_Static_Choice.
200 function Is_Static_Range (N : Node_Id) return Boolean;
201 -- Determine if range is static, as defined in RM 4.9(26). The only allowed
202 -- argument is an N_Range node (but note that the semantic analysis of
203 -- equivalent range attribute references already turned them into the
204 -- equivalent range). This differs from Is_OK_Static_Range (which is what
205 -- must be used by clients) in that it does not care whether the bounds
206 -- raise Constraint_Error or not. Used for checking whether expressions are
207 -- static in the 4.9 sense (without worrying about exceptions).
209 function Get_String_Val (N : Node_Id) return Node_Id;
210 -- Given a tree node for a folded string or character value, returns the
211 -- corresponding string literal or character literal (one of the two must
212 -- be available, or the operand would not have been marked as foldable in
213 -- the earlier analysis of the operation).
215 function OK_Bits (N : Node_Id; Bits : Uint) return Boolean;
216 -- Bits represents the number of bits in an integer value to be computed
217 -- (but the value has not been computed yet). If this value in Bits is
218 -- reasonable, a result of True is returned, with the implication that the
219 -- caller should go ahead and complete the calculation. If the value in
220 -- Bits is unreasonably large, then an error is posted on node N, and
221 -- False is returned (and the caller skips the proposed calculation).
223 procedure Out_Of_Range (N : Node_Id);
224 -- This procedure is called if it is determined that node N, which appears
225 -- in a non-static context, is a compile time known value which is outside
226 -- its range, i.e. the range of Etype. This is used in contexts where
227 -- this is an illegality if N is static, and should generate a warning
230 procedure Rewrite_In_Raise_CE (N : Node_Id; Exp : Node_Id);
231 -- N and Exp are nodes representing an expression, Exp is known to raise
232 -- CE. N is rewritten in term of Exp in the optimal way.
234 function String_Type_Len (Stype : Entity_Id) return Uint;
235 -- Given a string type, determines the length of the index type, or, if
236 -- this index type is non-static, the length of the base type of this index
237 -- type. Note that if the string type is itself static, then the index type
238 -- is static, so the second case applies only if the string type passed is
241 function Test (Cond : Boolean) return Uint;
242 pragma Inline (Test);
243 -- This function simply returns the appropriate Boolean'Pos value
244 -- corresponding to the value of Cond as a universal integer. It is
245 -- used for producing the result of the static evaluation of the
248 function Find_Universal_Operator_Type (N : Node_Id) return Entity_Id;
249 -- Check whether an arithmetic operation with universal operands which is a
250 -- rewritten function call with an explicit scope indication is ambiguous:
251 -- P."+" (1, 2) will be ambiguous if there is more than one visible numeric
252 -- type declared in P and the context does not impose a type on the result
253 -- (e.g. in the expression of a type conversion). If ambiguous, emit an
254 -- error and return Empty, else return the result type of the operator.
256 procedure Test_Expression_Is_Foldable
261 -- Tests to see if expression N whose single operand is Op1 is foldable,
262 -- i.e. the operand value is known at compile time. If the operation is
263 -- foldable, then Fold is True on return, and Stat indicates whether the
264 -- result is static (i.e. the operand was static). Note that it is quite
265 -- possible for Fold to be True, and Stat to be False, since there are
266 -- cases in which we know the value of an operand even though it is not
267 -- technically static (e.g. the static lower bound of a range whose upper
268 -- bound is non-static).
270 -- If Stat is set False on return, then Test_Expression_Is_Foldable makes
271 -- a call to Check_Non_Static_Context on the operand. If Fold is False on
272 -- return, then all processing is complete, and the caller should return,
273 -- since there is nothing else to do.
275 -- If Stat is set True on return, then Is_Static_Expression is also set
276 -- true in node N. There are some cases where this is over-enthusiastic,
277 -- e.g. in the two operand case below, for string comparison, the result is
278 -- not static even though the two operands are static. In such cases, the
279 -- caller must reset the Is_Static_Expression flag in N.
281 -- If Fold and Stat are both set to False then this routine performs also
282 -- the following extra actions:
284 -- If either operand is Any_Type then propagate it to result to prevent
287 -- If some operand raises constraint error, then replace the node N
288 -- with the raise constraint error node. This replacement inherits the
289 -- Is_Static_Expression flag from the operands.
291 procedure Test_Expression_Is_Foldable
297 CRT_Safe : Boolean := False);
298 -- Same processing, except applies to an expression N with two operands
299 -- Op1 and Op2. The result is static only if both operands are static. If
300 -- CRT_Safe is set True, then CRT_Safe_Compile_Time_Known_Value is used
301 -- for the tests that the two operands are known at compile time. See
302 -- spec of this routine for further details.
304 function Test_In_Range
307 Assume_Valid : Boolean;
309 Int_Real : Boolean) return Range_Membership;
310 -- Common processing for Is_In_Range and Is_Out_Of_Range: Returns In_Range
311 -- or Out_Of_Range if it can be guaranteed at compile time that expression
312 -- N is known to be in or out of range of the subtype Typ. If not compile
313 -- time known, Unknown is returned. See documentation of Is_In_Range for
314 -- complete description of parameters.
316 procedure To_Bits (U : Uint; B : out Bits);
317 -- Converts a Uint value to a bit string of length B'Length
319 -----------------------------------------------
320 -- Check_Expression_Against_Static_Predicate --
321 -----------------------------------------------
323 procedure Check_Expression_Against_Static_Predicate
328 -- Nothing to do if expression is not known at compile time, or the
329 -- type has no static predicate set (will be the case for all non-scalar
330 -- types, so no need to make a special test for that).
332 if not (Has_Static_Predicate (Typ)
333 and then Compile_Time_Known_Value (Expr))
338 -- Here we have a static predicate (note that it could have arisen from
339 -- an explicitly specified Dynamic_Predicate whose expression met the
340 -- rules for being predicate-static).
342 -- If we are not generating code, nothing more to do (why???)
344 if Operating_Mode < Generate_Code then
348 -- If we have the real case, then for now, not implemented
350 if not Is_Discrete_Type (Typ) then
351 Error_Msg_N ("??real predicate not applied", Expr);
355 -- If static predicate matches, nothing to do
357 if Choices_Match (Expr, Static_Discrete_Predicate (Typ)) = Match then
361 -- Here we know that the predicate will fail
363 -- Special case of static expression failing a predicate (other than one
364 -- that was explicitly specified with a Dynamic_Predicate aspect). This
365 -- is the case where the expression is no longer considered static.
367 if Is_Static_Expression (Expr)
368 and then not Has_Dynamic_Predicate_Aspect (Typ)
371 ("??static expression fails static predicate check on &",
374 ("\??expression is no longer considered static", Expr);
375 Set_Is_Static_Expression (Expr, False);
377 -- In all other cases, this is just a warning that a test will fail.
378 -- It does not matter if the expression is static or not, or if the
379 -- predicate comes from a dynamic predicate aspect or not.
383 ("??expression fails predicate check on &", Expr, Typ);
385 end Check_Expression_Against_Static_Predicate;
387 ------------------------------
388 -- Check_Non_Static_Context --
389 ------------------------------
391 procedure Check_Non_Static_Context (N : Node_Id) is
392 T : constant Entity_Id := Etype (N);
393 Checks_On : constant Boolean :=
394 not Index_Checks_Suppressed (T)
395 and not Range_Checks_Suppressed (T);
398 -- Ignore cases of non-scalar types, error types, or universal real
399 -- types that have no usable bounds.
402 or else not Is_Scalar_Type (T)
403 or else T = Universal_Fixed
404 or else T = Universal_Real
409 -- At this stage we have a scalar type. If we have an expression that
410 -- raises CE, then we already issued a warning or error msg so there is
411 -- nothing more to be done in this routine.
413 if Raises_Constraint_Error (N) then
417 -- Now we have a scalar type which is not marked as raising a constraint
418 -- error exception. The main purpose of this routine is to deal with
419 -- static expressions appearing in a non-static context. That means
420 -- that if we do not have a static expression then there is not much
421 -- to do. The one case that we deal with here is that if we have a
422 -- floating-point value that is out of range, then we post a warning
423 -- that an infinity will result.
425 if not Is_Static_Expression (N) then
426 if Is_Floating_Point_Type (T)
427 and then Is_Out_Of_Range (N, Base_Type (T), Assume_Valid => True)
430 ("??float value out of range, infinity will be generated", N);
436 -- Here we have the case of outer level static expression of scalar
437 -- type, where the processing of this procedure is needed.
439 -- For real types, this is where we convert the value to a machine
440 -- number (see RM 4.9(38)). Also see ACVC test C490001. We should only
441 -- need to do this if the parent is a constant declaration, since in
442 -- other cases, gigi should do the necessary conversion correctly, but
443 -- experimentation shows that this is not the case on all machines, in
444 -- particular if we do not convert all literals to machine values in
445 -- non-static contexts, then ACVC test C490001 fails on Sparc/Solaris
448 if Nkind (N) = N_Real_Literal
449 and then not Is_Machine_Number (N)
450 and then not Is_Generic_Type (Etype (N))
451 and then Etype (N) /= Universal_Real
453 -- Check that value is in bounds before converting to machine
454 -- number, so as not to lose case where value overflows in the
455 -- least significant bit or less. See B490001.
457 if Is_Out_Of_Range (N, Base_Type (T), Assume_Valid => True) then
462 -- Note: we have to copy the node, to avoid problems with conformance
463 -- of very similar numbers (see ACVC tests B4A010C and B63103A).
465 Rewrite (N, New_Copy (N));
467 if not Is_Floating_Point_Type (T) then
469 (N, Corresponding_Integer_Value (N) * Small_Value (T));
471 elsif not UR_Is_Zero (Realval (N)) then
473 -- Note: even though RM 4.9(38) specifies biased rounding, this
474 -- has been modified by AI-100 in order to prevent confusing
475 -- differences in rounding between static and non-static
476 -- expressions. AI-100 specifies that the effect of such rounding
477 -- is implementation dependent, and in GNAT we round to nearest
478 -- even to match the run-time behavior.
481 (N, Machine (Base_Type (T), Realval (N), Round_Even, N));
484 Set_Is_Machine_Number (N);
487 -- Check for out of range universal integer. This is a non-static
488 -- context, so the integer value must be in range of the runtime
489 -- representation of universal integers.
491 -- We do this only within an expression, because that is the only
492 -- case in which non-static universal integer values can occur, and
493 -- furthermore, Check_Non_Static_Context is currently (incorrectly???)
494 -- called in contexts like the expression of a number declaration where
495 -- we certainly want to allow out of range values.
497 if Etype (N) = Universal_Integer
498 and then Nkind (N) = N_Integer_Literal
499 and then Nkind (Parent (N)) in N_Subexpr
501 (Intval (N) < Expr_Value (Type_Low_Bound (Universal_Integer))
503 Intval (N) > Expr_Value (Type_High_Bound (Universal_Integer)))
505 Apply_Compile_Time_Constraint_Error
506 (N, "non-static universal integer value out of range<<",
507 CE_Range_Check_Failed);
509 -- Check out of range of base type
511 elsif Is_Out_Of_Range (N, Base_Type (T), Assume_Valid => True) then
514 -- Give warning if outside subtype (where one or both of the bounds of
515 -- the subtype is static). This warning is omitted if the expression
516 -- appears in a range that could be null (warnings are handled elsewhere
519 elsif T /= Base_Type (T) and then Nkind (Parent (N)) /= N_Range then
520 if Is_In_Range (N, T, Assume_Valid => True) then
523 elsif Is_Out_Of_Range (N, T, Assume_Valid => True) then
524 Apply_Compile_Time_Constraint_Error
525 (N, "value not in range of}<<", CE_Range_Check_Failed);
528 Enable_Range_Check (N);
531 Set_Do_Range_Check (N, False);
534 end Check_Non_Static_Context;
536 ---------------------------------
537 -- Check_String_Literal_Length --
538 ---------------------------------
540 procedure Check_String_Literal_Length (N : Node_Id; Ttype : Entity_Id) is
542 if not Raises_Constraint_Error (N) and then Is_Constrained (Ttype) then
543 if UI_From_Int (String_Length (Strval (N))) /= String_Type_Len (Ttype)
545 Apply_Compile_Time_Constraint_Error
546 (N, "string length wrong for}??",
547 CE_Length_Check_Failed,
552 end Check_String_Literal_Length;
558 function Choice_Matches
560 Choice : Node_Id) return Match_Result
562 Etyp : constant Entity_Id := Etype (Expr);
568 pragma Assert (Compile_Time_Known_Value (Expr));
569 pragma Assert (Is_Scalar_Type (Etyp) or else Is_String_Type (Etyp));
571 if not Is_OK_Static_Choice (Choice) then
572 Set_Raises_Constraint_Error (Choice);
575 -- Discrete type case
577 elsif Is_Discrete_Type (Etype (Expr)) then
578 Val := Expr_Value (Expr);
580 if Nkind (Choice) = N_Range then
581 if Val >= Expr_Value (Low_Bound (Choice))
583 Val <= Expr_Value (High_Bound (Choice))
590 elsif Nkind (Choice) = N_Subtype_Indication
592 (Is_Entity_Name (Choice) and then Is_Type (Entity (Choice)))
594 if Val >= Expr_Value (Type_Low_Bound (Etype (Choice)))
596 Val <= Expr_Value (Type_High_Bound (Etype (Choice)))
603 elsif Nkind (Choice) = N_Others_Choice then
607 if Val = Expr_Value (Choice) then
616 elsif Is_Real_Type (Etype (Expr)) then
617 ValR := Expr_Value_R (Expr);
619 if Nkind (Choice) = N_Range then
620 if ValR >= Expr_Value_R (Low_Bound (Choice))
622 ValR <= Expr_Value_R (High_Bound (Choice))
629 elsif Nkind (Choice) = N_Subtype_Indication
631 (Is_Entity_Name (Choice) and then Is_Type (Entity (Choice)))
633 if ValR >= Expr_Value_R (Type_Low_Bound (Etype (Choice)))
635 ValR <= Expr_Value_R (Type_High_Bound (Etype (Choice)))
643 if ValR = Expr_Value_R (Choice) then
653 pragma Assert (Is_String_Type (Etype (Expr)));
654 ValS := Expr_Value_S (Expr);
656 if Nkind (Choice) = N_Subtype_Indication
658 (Is_Entity_Name (Choice) and then Is_Type (Entity (Choice)))
660 if not Is_Constrained (Etype (Choice)) then
665 Typlen : constant Uint :=
666 String_Type_Len (Etype (Choice));
667 Strlen : constant Uint :=
668 UI_From_Int (String_Length (Strval (ValS)));
670 if Typlen = Strlen then
679 if String_Equal (Strval (ValS), Strval (Expr_Value_S (Choice)))
693 function Choices_Match
695 Choices : List_Id) return Match_Result
698 Result : Match_Result;
701 Choice := First (Choices);
702 while Present (Choice) loop
703 Result := Choice_Matches (Expr, Choice);
705 if Result /= No_Match then
715 --------------------------
716 -- Compile_Time_Compare --
717 --------------------------
719 function Compile_Time_Compare
721 Assume_Valid : Boolean) return Compare_Result
723 Discard : aliased Uint;
725 return Compile_Time_Compare (L, R, Discard'Access, Assume_Valid);
726 end Compile_Time_Compare;
728 function Compile_Time_Compare
731 Assume_Valid : Boolean;
732 Rec : Boolean := False) return Compare_Result
734 Ltyp : Entity_Id := Underlying_Type (Etype (L));
735 Rtyp : Entity_Id := Underlying_Type (Etype (R));
736 -- These get reset to the base type for the case of entities where
737 -- Is_Known_Valid is not set. This takes care of handling possible
738 -- invalid representations using the value of the base type, in
739 -- accordance with RM 13.9.1(10).
741 Discard : aliased Uint;
743 procedure Compare_Decompose
747 -- This procedure decomposes the node N into an expression node and a
748 -- signed offset, so that the value of N is equal to the value of R plus
749 -- the value V (which may be negative). If no such decomposition is
750 -- possible, then on return R is a copy of N, and V is set to zero.
752 function Compare_Fixup (N : Node_Id) return Node_Id;
753 -- This function deals with replacing 'Last and 'First references with
754 -- their corresponding type bounds, which we then can compare. The
755 -- argument is the original node, the result is the identity, unless we
756 -- have a 'Last/'First reference in which case the value returned is the
757 -- appropriate type bound.
759 function Is_Known_Valid_Operand (Opnd : Node_Id) return Boolean;
760 -- Even if the context does not assume that values are valid, some
761 -- simple cases can be recognized.
763 function Is_Same_Value (L, R : Node_Id) return Boolean;
764 -- Returns True iff L and R represent expressions that definitely have
765 -- identical (but not necessarily compile time known) values Indeed the
766 -- caller is expected to have already dealt with the cases of compile
767 -- time known values, so these are not tested here.
769 -----------------------
770 -- Compare_Decompose --
771 -----------------------
773 procedure Compare_Decompose
779 if Nkind (N) = N_Op_Add
780 and then Nkind (Right_Opnd (N)) = N_Integer_Literal
783 V := Intval (Right_Opnd (N));
786 elsif Nkind (N) = N_Op_Subtract
787 and then Nkind (Right_Opnd (N)) = N_Integer_Literal
790 V := UI_Negate (Intval (Right_Opnd (N)));
793 elsif Nkind (N) = N_Attribute_Reference then
794 if Attribute_Name (N) = Name_Succ then
795 R := First (Expressions (N));
799 elsif Attribute_Name (N) = Name_Pred then
800 R := First (Expressions (N));
808 end Compare_Decompose;
814 function Compare_Fixup (N : Node_Id) return Node_Id is
820 -- Fixup only required for First/Last attribute reference
822 if Nkind (N) = N_Attribute_Reference
823 and then Nam_In (Attribute_Name (N), Name_First, Name_Last)
825 Xtyp := Etype (Prefix (N));
827 -- If we have no type, then just abandon the attempt to do
828 -- a fixup, this is probably the result of some other error.
834 -- Dereference an access type
836 if Is_Access_Type (Xtyp) then
837 Xtyp := Designated_Type (Xtyp);
840 -- If we don't have an array type at this stage, something is
841 -- peculiar, e.g. another error, and we abandon the attempt at
844 if not Is_Array_Type (Xtyp) then
848 -- Ignore unconstrained array, since bounds are not meaningful
850 if not Is_Constrained (Xtyp) then
854 if Ekind (Xtyp) = E_String_Literal_Subtype then
855 if Attribute_Name (N) = Name_First then
856 return String_Literal_Low_Bound (Xtyp);
859 Make_Integer_Literal (Sloc (N),
860 Intval => Intval (String_Literal_Low_Bound (Xtyp)) +
861 String_Literal_Length (Xtyp));
865 -- Find correct index type
867 Indx := First_Index (Xtyp);
869 if Present (Expressions (N)) then
870 Subs := UI_To_Int (Expr_Value (First (Expressions (N))));
872 for J in 2 .. Subs loop
873 Indx := Next_Index (Indx);
877 Xtyp := Etype (Indx);
879 if Attribute_Name (N) = Name_First then
880 return Type_Low_Bound (Xtyp);
882 return Type_High_Bound (Xtyp);
889 ----------------------------
890 -- Is_Known_Valid_Operand --
891 ----------------------------
893 function Is_Known_Valid_Operand (Opnd : Node_Id) return Boolean is
895 return (Is_Entity_Name (Opnd)
897 (Is_Known_Valid (Entity (Opnd))
898 or else Ekind (Entity (Opnd)) = E_In_Parameter
900 (Ekind (Entity (Opnd)) in Object_Kind
901 and then Present (Current_Value (Entity (Opnd))))))
902 or else Is_OK_Static_Expression (Opnd);
903 end Is_Known_Valid_Operand;
909 function Is_Same_Value (L, R : Node_Id) return Boolean is
910 Lf : constant Node_Id := Compare_Fixup (L);
911 Rf : constant Node_Id := Compare_Fixup (R);
913 function Is_Same_Subscript (L, R : List_Id) return Boolean;
914 -- L, R are the Expressions values from two attribute nodes for First
915 -- or Last attributes. Either may be set to No_List if no expressions
916 -- are present (indicating subscript 1). The result is True if both
917 -- expressions represent the same subscript (note one case is where
918 -- one subscript is missing and the other is explicitly set to 1).
920 -----------------------
921 -- Is_Same_Subscript --
922 -----------------------
924 function Is_Same_Subscript (L, R : List_Id) return Boolean is
930 return Expr_Value (First (R)) = Uint_1;
935 return Expr_Value (First (L)) = Uint_1;
937 return Expr_Value (First (L)) = Expr_Value (First (R));
940 end Is_Same_Subscript;
942 -- Start of processing for Is_Same_Value
945 -- Values are the same if they refer to the same entity and the
946 -- entity is non-volatile. This does not however apply to Float
947 -- types, since we may have two NaN values and they should never
950 -- If the entity is a discriminant, the two expressions may be bounds
951 -- of components of objects of the same discriminated type. The
952 -- values of the discriminants are not static, and therefore the
953 -- result is unknown.
955 -- It would be better to comment individual branches of this test ???
957 if Nkind_In (Lf, N_Identifier, N_Expanded_Name)
958 and then Nkind_In (Rf, N_Identifier, N_Expanded_Name)
959 and then Entity (Lf) = Entity (Rf)
960 and then Ekind (Entity (Lf)) /= E_Discriminant
961 and then Present (Entity (Lf))
962 and then not Is_Floating_Point_Type (Etype (L))
963 and then not Is_Volatile_Reference (L)
964 and then not Is_Volatile_Reference (R)
968 -- Or if they are compile time known and identical
970 elsif Compile_Time_Known_Value (Lf)
972 Compile_Time_Known_Value (Rf)
973 and then Expr_Value (Lf) = Expr_Value (Rf)
977 -- False if Nkind of the two nodes is different for remaining cases
979 elsif Nkind (Lf) /= Nkind (Rf) then
982 -- True if both 'First or 'Last values applying to the same entity
983 -- (first and last don't change even if value does). Note that we
984 -- need this even with the calls to Compare_Fixup, to handle the
985 -- case of unconstrained array attributes where Compare_Fixup
986 -- cannot find useful bounds.
988 elsif Nkind (Lf) = N_Attribute_Reference
989 and then Attribute_Name (Lf) = Attribute_Name (Rf)
990 and then Nam_In (Attribute_Name (Lf), Name_First, Name_Last)
991 and then Nkind_In (Prefix (Lf), N_Identifier, N_Expanded_Name)
992 and then Nkind_In (Prefix (Rf), N_Identifier, N_Expanded_Name)
993 and then Entity (Prefix (Lf)) = Entity (Prefix (Rf))
994 and then Is_Same_Subscript (Expressions (Lf), Expressions (Rf))
998 -- True if the same selected component from the same record
1000 elsif Nkind (Lf) = N_Selected_Component
1001 and then Selector_Name (Lf) = Selector_Name (Rf)
1002 and then Is_Same_Value (Prefix (Lf), Prefix (Rf))
1006 -- True if the same unary operator applied to the same operand
1008 elsif Nkind (Lf) in N_Unary_Op
1009 and then Is_Same_Value (Right_Opnd (Lf), Right_Opnd (Rf))
1013 -- True if the same binary operator applied to the same operands
1015 elsif Nkind (Lf) in N_Binary_Op
1016 and then Is_Same_Value (Left_Opnd (Lf), Left_Opnd (Rf))
1017 and then Is_Same_Value (Right_Opnd (Lf), Right_Opnd (Rf))
1021 -- All other cases, we can't tell, so return False
1028 -- Start of processing for Compile_Time_Compare
1031 Diff.all := No_Uint;
1033 -- In preanalysis mode, always return Unknown unless the expression
1034 -- is static. It is too early to be thinking we know the result of a
1035 -- comparison, save that judgment for the full analysis. This is
1036 -- particularly important in the case of pre and postconditions, which
1037 -- otherwise can be prematurely collapsed into having True or False
1038 -- conditions when this is inappropriate.
1040 if not (Full_Analysis
1041 or else (Is_OK_Static_Expression (L)
1043 Is_OK_Static_Expression (R)))
1048 -- If either operand could raise constraint error, then we cannot
1049 -- know the result at compile time (since CE may be raised).
1051 if not (Cannot_Raise_Constraint_Error (L)
1053 Cannot_Raise_Constraint_Error (R))
1058 -- Identical operands are most certainly equal
1063 -- If expressions have no types, then do not attempt to determine if
1064 -- they are the same, since something funny is going on. One case in
1065 -- which this happens is during generic template analysis, when bounds
1066 -- are not fully analyzed.
1068 elsif No (Ltyp) or else No (Rtyp) then
1071 -- We do not attempt comparisons for packed arrays arrays represented as
1072 -- modular types, where the semantics of comparison is quite different.
1074 elsif Is_Packed_Array_Impl_Type (Ltyp)
1075 and then Is_Modular_Integer_Type (Ltyp)
1079 -- For access types, the only time we know the result at compile time
1080 -- (apart from identical operands, which we handled already) is if we
1081 -- know one operand is null and the other is not, or both operands are
1084 elsif Is_Access_Type (Ltyp) then
1085 if Known_Null (L) then
1086 if Known_Null (R) then
1088 elsif Known_Non_Null (R) then
1094 elsif Known_Non_Null (L) and then Known_Null (R) then
1101 -- Case where comparison involves two compile time known values
1103 elsif Compile_Time_Known_Value (L)
1105 Compile_Time_Known_Value (R)
1107 -- For the floating-point case, we have to be a little careful, since
1108 -- at compile time we are dealing with universal exact values, but at
1109 -- runtime, these will be in non-exact target form. That's why the
1110 -- returned results are LE and GE below instead of LT and GT.
1112 if Is_Floating_Point_Type (Ltyp)
1114 Is_Floating_Point_Type (Rtyp)
1117 Lo : constant Ureal := Expr_Value_R (L);
1118 Hi : constant Ureal := Expr_Value_R (R);
1129 -- For string types, we have two string literals and we proceed to
1130 -- compare them using the Ada style dictionary string comparison.
1132 elsif not Is_Scalar_Type (Ltyp) then
1134 Lstring : constant String_Id := Strval (Expr_Value_S (L));
1135 Rstring : constant String_Id := Strval (Expr_Value_S (R));
1136 Llen : constant Nat := String_Length (Lstring);
1137 Rlen : constant Nat := String_Length (Rstring);
1140 for J in 1 .. Nat'Min (Llen, Rlen) loop
1142 LC : constant Char_Code := Get_String_Char (Lstring, J);
1143 RC : constant Char_Code := Get_String_Char (Rstring, J);
1155 elsif Llen > Rlen then
1162 -- For remaining scalar cases we know exactly (note that this does
1163 -- include the fixed-point case, where we know the run time integer
1168 Lo : constant Uint := Expr_Value (L);
1169 Hi : constant Uint := Expr_Value (R);
1172 Diff.all := Hi - Lo;
1177 Diff.all := Lo - Hi;
1183 -- Cases where at least one operand is not known at compile time
1186 -- Remaining checks apply only for discrete types
1188 if not Is_Discrete_Type (Ltyp)
1190 not Is_Discrete_Type (Rtyp)
1195 -- Defend against generic types, or actually any expressions that
1196 -- contain a reference to a generic type from within a generic
1197 -- template. We don't want to do any range analysis of such
1198 -- expressions for two reasons. First, the bounds of a generic type
1199 -- itself are junk and cannot be used for any kind of analysis.
1200 -- Second, we may have a case where the range at run time is indeed
1201 -- known, but we don't want to do compile time analysis in the
1202 -- template based on that range since in an instance the value may be
1203 -- static, and able to be elaborated without reference to the bounds
1204 -- of types involved. As an example, consider:
1206 -- (F'Pos (F'Last) + 1) > Integer'Last
1208 -- The expression on the left side of > is Universal_Integer and thus
1209 -- acquires the type Integer for evaluation at run time, and at run
1210 -- time it is true that this condition is always False, but within
1211 -- an instance F may be a type with a static range greater than the
1212 -- range of Integer, and the expression statically evaluates to True.
1214 if References_Generic_Formal_Type (L)
1216 References_Generic_Formal_Type (R)
1221 -- Replace types by base types for the case of entities which are not
1222 -- known to have valid representations. This takes care of properly
1223 -- dealing with invalid representations.
1225 if not Assume_Valid and then not Assume_No_Invalid_Values then
1226 if Is_Entity_Name (L) and then not Is_Known_Valid (Entity (L)) then
1227 Ltyp := Underlying_Type (Base_Type (Ltyp));
1230 if Is_Entity_Name (R) and then not Is_Known_Valid (Entity (R)) then
1231 Rtyp := Underlying_Type (Base_Type (Rtyp));
1235 -- First attempt is to decompose the expressions to extract a
1236 -- constant offset resulting from the use of any of the forms:
1243 -- Then we see if the two expressions are the same value, and if so
1244 -- the result is obtained by comparing the offsets.
1246 -- Note: the reason we do this test first is that it returns only
1247 -- decisive results (with diff set), where other tests, like the
1248 -- range test, may not be as so decisive. Consider for example
1249 -- J .. J + 1. This code can conclude LT with a difference of 1,
1250 -- even if the range of J is not known.
1259 Compare_Decompose (L, Lnode, Loffs);
1260 Compare_Decompose (R, Rnode, Roffs);
1262 if Is_Same_Value (Lnode, Rnode) then
1263 if Loffs = Roffs then
1265 elsif Loffs < Roffs then
1266 Diff.all := Roffs - Loffs;
1269 Diff.all := Loffs - Roffs;
1275 -- Next, try range analysis and see if operand ranges are disjoint
1283 -- True if each range is a single point
1286 Determine_Range (L, LOK, LLo, LHi, Assume_Valid);
1287 Determine_Range (R, ROK, RLo, RHi, Assume_Valid);
1290 Single := (LLo = LHi) and then (RLo = RHi);
1293 if Single and Assume_Valid then
1294 Diff.all := RLo - LLo;
1299 elsif RHi < LLo then
1300 if Single and Assume_Valid then
1301 Diff.all := LLo - RLo;
1306 elsif Single and then LLo = RLo then
1308 -- If the range includes a single literal and we can assume
1309 -- validity then the result is known even if an operand is
1312 if Assume_Valid then
1318 elsif LHi = RLo then
1321 elsif RHi = LLo then
1324 elsif not Is_Known_Valid_Operand (L)
1325 and then not Assume_Valid
1327 if Is_Same_Value (L, R) then
1334 -- If the range of either operand cannot be determined, nothing
1335 -- further can be inferred.
1342 -- Here is where we check for comparisons against maximum bounds of
1343 -- types, where we know that no value can be outside the bounds of
1344 -- the subtype. Note that this routine is allowed to assume that all
1345 -- expressions are within their subtype bounds. Callers wishing to
1346 -- deal with possibly invalid values must in any case take special
1347 -- steps (e.g. conversions to larger types) to avoid this kind of
1348 -- optimization, which is always considered to be valid. We do not
1349 -- attempt this optimization with generic types, since the type
1350 -- bounds may not be meaningful in this case.
1352 -- We are in danger of an infinite recursion here. It does not seem
1353 -- useful to go more than one level deep, so the parameter Rec is
1354 -- used to protect ourselves against this infinite recursion.
1358 -- See if we can get a decisive check against one operand and a
1359 -- bound of the other operand (four possible tests here). Note
1360 -- that we avoid testing junk bounds of a generic type.
1362 if not Is_Generic_Type (Rtyp) then
1363 case Compile_Time_Compare (L, Type_Low_Bound (Rtyp),
1365 Assume_Valid, Rec => True)
1367 when LT => return LT;
1368 when LE => return LE;
1369 when EQ => return LE;
1370 when others => null;
1373 case Compile_Time_Compare (L, Type_High_Bound (Rtyp),
1375 Assume_Valid, Rec => True)
1377 when GT => return GT;
1378 when GE => return GE;
1379 when EQ => return GE;
1380 when others => null;
1384 if not Is_Generic_Type (Ltyp) then
1385 case Compile_Time_Compare (Type_Low_Bound (Ltyp), R,
1387 Assume_Valid, Rec => True)
1389 when GT => return GT;
1390 when GE => return GE;
1391 when EQ => return GE;
1392 when others => null;
1395 case Compile_Time_Compare (Type_High_Bound (Ltyp), R,
1397 Assume_Valid, Rec => True)
1399 when LT => return LT;
1400 when LE => return LE;
1401 when EQ => return LE;
1402 when others => null;
1407 -- Next attempt is to see if we have an entity compared with a
1408 -- compile time known value, where there is a current value
1409 -- conditional for the entity which can tell us the result.
1413 -- Entity variable (left operand)
1416 -- Value (right operand)
1419 -- If False, we have reversed the operands
1422 -- Comparison operator kind from Get_Current_Value_Condition call
1425 -- Value from Get_Current_Value_Condition call
1430 Result : Compare_Result;
1431 -- Known result before inversion
1434 if Is_Entity_Name (L)
1435 and then Compile_Time_Known_Value (R)
1438 Val := Expr_Value (R);
1441 elsif Is_Entity_Name (R)
1442 and then Compile_Time_Known_Value (L)
1445 Val := Expr_Value (L);
1448 -- That was the last chance at finding a compile time result
1454 Get_Current_Value_Condition (Var, Op, Opn);
1456 -- That was the last chance, so if we got nothing return
1462 Opv := Expr_Value (Opn);
1464 -- We got a comparison, so we might have something interesting
1466 -- Convert LE to LT and GE to GT, just so we have fewer cases
1468 if Op = N_Op_Le then
1472 elsif Op = N_Op_Ge then
1477 -- Deal with equality case
1479 if Op = N_Op_Eq then
1482 elsif Opv < Val then
1488 -- Deal with inequality case
1490 elsif Op = N_Op_Ne then
1497 -- Deal with greater than case
1499 elsif Op = N_Op_Gt then
1502 elsif Opv = Val - 1 then
1508 -- Deal with less than case
1510 else pragma Assert (Op = N_Op_Lt);
1513 elsif Opv = Val + 1 then
1520 -- Deal with inverting result
1524 when GT => return LT;
1525 when GE => return LE;
1526 when LT => return GT;
1527 when LE => return GE;
1528 when others => return Result;
1535 end Compile_Time_Compare;
1537 -------------------------------
1538 -- Compile_Time_Known_Bounds --
1539 -------------------------------
1541 function Compile_Time_Known_Bounds (T : Entity_Id) return Boolean is
1546 if T = Any_Composite or else not Is_Array_Type (T) then
1550 Indx := First_Index (T);
1551 while Present (Indx) loop
1552 Typ := Underlying_Type (Etype (Indx));
1554 -- Never look at junk bounds of a generic type
1556 if Is_Generic_Type (Typ) then
1560 -- Otherwise check bounds for compile time known
1562 if not Compile_Time_Known_Value (Type_Low_Bound (Typ)) then
1564 elsif not Compile_Time_Known_Value (Type_High_Bound (Typ)) then
1572 end Compile_Time_Known_Bounds;
1574 ------------------------------
1575 -- Compile_Time_Known_Value --
1576 ------------------------------
1578 function Compile_Time_Known_Value (Op : Node_Id) return Boolean is
1579 K : constant Node_Kind := Nkind (Op);
1580 CV_Ent : CV_Entry renames CV_Cache (Nat (Op) mod CV_Cache_Size);
1583 -- Never known at compile time if bad type or raises constraint error
1584 -- or empty (latter case occurs only as a result of a previous error).
1587 Check_Error_Detected;
1591 or else Etype (Op) = Any_Type
1592 or else Raises_Constraint_Error (Op)
1597 -- If we have an entity name, then see if it is the name of a constant
1598 -- and if so, test the corresponding constant value, or the name of
1599 -- an enumeration literal, which is always a constant.
1601 if Present (Etype (Op)) and then Is_Entity_Name (Op) then
1603 E : constant Entity_Id := Entity (Op);
1607 -- Never known at compile time if it is a packed array value.
1608 -- We might want to try to evaluate these at compile time one
1609 -- day, but we do not make that attempt now.
1611 if Is_Packed_Array_Impl_Type (Etype (Op)) then
1615 if Ekind (E) = E_Enumeration_Literal then
1618 elsif Ekind (E) = E_Constant then
1619 V := Constant_Value (E);
1620 return Present (V) and then Compile_Time_Known_Value (V);
1624 -- We have a value, see if it is compile time known
1627 -- Integer literals are worth storing in the cache
1629 if K = N_Integer_Literal then
1631 CV_Ent.V := Intval (Op);
1634 -- Other literals and NULL are known at compile time
1637 Nkind_In (K, N_Character_Literal,
1644 -- Any reference to Null_Parameter is known at compile time. No
1645 -- other attribute references (that have not already been folded)
1646 -- are known at compile time.
1648 elsif K = N_Attribute_Reference then
1649 return Attribute_Name (Op) = Name_Null_Parameter;
1653 -- If we fall through, not known at compile time
1657 -- If we get an exception while trying to do this test, then some error
1658 -- has occurred, and we simply say that the value is not known after all
1663 end Compile_Time_Known_Value;
1665 --------------------------------------
1666 -- Compile_Time_Known_Value_Or_Aggr --
1667 --------------------------------------
1669 function Compile_Time_Known_Value_Or_Aggr (Op : Node_Id) return Boolean is
1671 -- If we have an entity name, then see if it is the name of a constant
1672 -- and if so, test the corresponding constant value, or the name of
1673 -- an enumeration literal, which is always a constant.
1675 if Is_Entity_Name (Op) then
1677 E : constant Entity_Id := Entity (Op);
1681 if Ekind (E) = E_Enumeration_Literal then
1684 elsif Ekind (E) /= E_Constant then
1688 V := Constant_Value (E);
1690 and then Compile_Time_Known_Value_Or_Aggr (V);
1694 -- We have a value, see if it is compile time known
1697 if Compile_Time_Known_Value (Op) then
1700 elsif Nkind (Op) = N_Aggregate then
1702 if Present (Expressions (Op)) then
1706 Expr := First (Expressions (Op));
1707 while Present (Expr) loop
1708 if not Compile_Time_Known_Value_Or_Aggr (Expr) then
1717 if Present (Component_Associations (Op)) then
1722 Cass := First (Component_Associations (Op));
1723 while Present (Cass) loop
1725 Compile_Time_Known_Value_Or_Aggr (Expression (Cass))
1737 -- All other types of values are not known at compile time
1744 end Compile_Time_Known_Value_Or_Aggr;
1746 ---------------------------------------
1747 -- CRT_Safe_Compile_Time_Known_Value --
1748 ---------------------------------------
1750 function CRT_Safe_Compile_Time_Known_Value (Op : Node_Id) return Boolean is
1752 if (Configurable_Run_Time_Mode or No_Run_Time_Mode)
1753 and then not Is_OK_Static_Expression (Op)
1757 return Compile_Time_Known_Value (Op);
1759 end CRT_Safe_Compile_Time_Known_Value;
1765 -- This is only called for actuals of functions that are not predefined
1766 -- operators (which have already been rewritten as operators at this
1767 -- stage), so the call can never be folded, and all that needs doing for
1768 -- the actual is to do the check for a non-static context.
1770 procedure Eval_Actual (N : Node_Id) is
1772 Check_Non_Static_Context (N);
1775 --------------------
1776 -- Eval_Allocator --
1777 --------------------
1779 -- Allocators are never static, so all we have to do is to do the
1780 -- check for a non-static context if an expression is present.
1782 procedure Eval_Allocator (N : Node_Id) is
1783 Expr : constant Node_Id := Expression (N);
1785 if Nkind (Expr) = N_Qualified_Expression then
1786 Check_Non_Static_Context (Expression (Expr));
1790 ------------------------
1791 -- Eval_Arithmetic_Op --
1792 ------------------------
1794 -- Arithmetic operations are static functions, so the result is static
1795 -- if both operands are static (RM 4.9(7), 4.9(20)).
1797 procedure Eval_Arithmetic_Op (N : Node_Id) is
1798 Left : constant Node_Id := Left_Opnd (N);
1799 Right : constant Node_Id := Right_Opnd (N);
1800 Ltype : constant Entity_Id := Etype (Left);
1801 Rtype : constant Entity_Id := Etype (Right);
1802 Otype : Entity_Id := Empty;
1807 -- If not foldable we are done
1809 Test_Expression_Is_Foldable (N, Left, Right, Stat, Fold);
1815 -- Otherwise attempt to fold
1817 if Is_Universal_Numeric_Type (Etype (Left))
1819 Is_Universal_Numeric_Type (Etype (Right))
1821 Otype := Find_Universal_Operator_Type (N);
1824 -- Fold for cases where both operands are of integer type
1826 if Is_Integer_Type (Ltype) and then Is_Integer_Type (Rtype) then
1828 Left_Int : constant Uint := Expr_Value (Left);
1829 Right_Int : constant Uint := Expr_Value (Right);
1835 Result := Left_Int + Right_Int;
1837 when N_Op_Subtract =>
1838 Result := Left_Int - Right_Int;
1840 when N_Op_Multiply =>
1843 (Num_Bits (Left_Int) + Num_Bits (Right_Int)))
1845 Result := Left_Int * Right_Int;
1852 -- The exception Constraint_Error is raised by integer
1853 -- division, rem and mod if the right operand is zero.
1855 if Right_Int = 0 then
1856 Apply_Compile_Time_Constraint_Error
1857 (N, "division by zero", CE_Divide_By_Zero,
1859 Set_Raises_Constraint_Error (N);
1862 -- Otherwise we can do the division
1865 Result := Left_Int / Right_Int;
1870 -- The exception Constraint_Error is raised by integer
1871 -- division, rem and mod if the right operand is zero.
1873 if Right_Int = 0 then
1874 Apply_Compile_Time_Constraint_Error
1875 (N, "mod with zero divisor", CE_Divide_By_Zero,
1879 Result := Left_Int mod 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, "rem with zero divisor", CE_Divide_By_Zero,
1894 Result := Left_Int rem Right_Int;
1898 raise Program_Error;
1901 -- Adjust the result by the modulus if the type is a modular type
1903 if Is_Modular_Integer_Type (Ltype) then
1904 Result := Result mod Modulus (Ltype);
1906 -- For a signed integer type, check non-static overflow
1908 elsif (not Stat) and then Is_Signed_Integer_Type (Ltype) then
1910 BT : constant Entity_Id := Base_Type (Ltype);
1911 Lo : constant Uint := Expr_Value (Type_Low_Bound (BT));
1912 Hi : constant Uint := Expr_Value (Type_High_Bound (BT));
1914 if Result < Lo or else Result > Hi then
1915 Apply_Compile_Time_Constraint_Error
1916 (N, "value not in range of }??",
1917 CE_Overflow_Check_Failed,
1924 -- If we get here we can fold the result
1926 Fold_Uint (N, Result, Stat);
1929 -- Cases where at least one operand is a real. We handle the cases of
1930 -- both reals, or mixed/real integer cases (the latter happen only for
1931 -- divide and multiply, and the result is always real).
1933 elsif Is_Real_Type (Ltype) or else Is_Real_Type (Rtype) then
1940 if Is_Real_Type (Ltype) then
1941 Left_Real := Expr_Value_R (Left);
1943 Left_Real := UR_From_Uint (Expr_Value (Left));
1946 if Is_Real_Type (Rtype) then
1947 Right_Real := Expr_Value_R (Right);
1949 Right_Real := UR_From_Uint (Expr_Value (Right));
1952 if Nkind (N) = N_Op_Add then
1953 Result := Left_Real + Right_Real;
1955 elsif Nkind (N) = N_Op_Subtract then
1956 Result := Left_Real - Right_Real;
1958 elsif Nkind (N) = N_Op_Multiply then
1959 Result := Left_Real * Right_Real;
1961 else pragma Assert (Nkind (N) = N_Op_Divide);
1962 if UR_Is_Zero (Right_Real) then
1963 Apply_Compile_Time_Constraint_Error
1964 (N, "division by zero", CE_Divide_By_Zero);
1968 Result := Left_Real / Right_Real;
1971 Fold_Ureal (N, Result, Stat);
1975 -- If the operator was resolved to a specific type, make sure that type
1976 -- is frozen even if the expression is folded into a literal (which has
1977 -- a universal type).
1979 if Present (Otype) then
1980 Freeze_Before (N, Otype);
1982 end Eval_Arithmetic_Op;
1984 ----------------------------
1985 -- Eval_Character_Literal --
1986 ----------------------------
1988 -- Nothing to be done
1990 procedure Eval_Character_Literal (N : Node_Id) is
1991 pragma Warnings (Off, N);
1994 end Eval_Character_Literal;
2000 -- Static function calls are either calls to predefined operators
2001 -- with static arguments, or calls to functions that rename a literal.
2002 -- Only the latter case is handled here, predefined operators are
2003 -- constant-folded elsewhere.
2005 -- If the function is itself inherited (see 7423-001) the literal of
2006 -- the parent type must be explicitly converted to the return type
2009 procedure Eval_Call (N : Node_Id) is
2010 Loc : constant Source_Ptr := Sloc (N);
2011 Typ : constant Entity_Id := Etype (N);
2015 if Nkind (N) = N_Function_Call
2016 and then No (Parameter_Associations (N))
2017 and then Is_Entity_Name (Name (N))
2018 and then Present (Alias (Entity (Name (N))))
2019 and then Is_Enumeration_Type (Base_Type (Typ))
2021 Lit := Ultimate_Alias (Entity (Name (N)));
2023 if Ekind (Lit) = E_Enumeration_Literal then
2024 if Base_Type (Etype (Lit)) /= Base_Type (Typ) then
2026 (N, Convert_To (Typ, New_Occurrence_Of (Lit, Loc)));
2028 Rewrite (N, New_Occurrence_Of (Lit, Loc));
2036 --------------------------
2037 -- Eval_Case_Expression --
2038 --------------------------
2040 -- A conditional expression is static if all its conditions and dependent
2041 -- expressions are static. Note that we do not care if the dependent
2042 -- expressions raise CE, except for the one that will be selected.
2044 procedure Eval_Case_Expression (N : Node_Id) is
2049 Set_Is_Static_Expression (N, False);
2051 if not Is_Static_Expression (Expression (N)) then
2052 Check_Non_Static_Context (Expression (N));
2056 -- First loop, make sure all the alternatives are static expressions
2057 -- none of which raise Constraint_Error. We make the constraint error
2058 -- check because part of the legality condition for a correct static
2059 -- case expression is that the cases are covered, like any other case
2060 -- expression. And we can't do that if any of the conditions raise an
2061 -- exception, so we don't even try to evaluate if that is the case.
2063 Alt := First (Alternatives (N));
2064 while Present (Alt) loop
2066 -- The expression must be static, but we don't care at this stage
2067 -- if it raises Constraint_Error (the alternative might not match,
2068 -- in which case the expression is statically unevaluated anyway).
2070 if not Is_Static_Expression (Expression (Alt)) then
2071 Check_Non_Static_Context (Expression (Alt));
2075 -- The choices of a case always have to be static, and cannot raise
2076 -- an exception. If this condition is not met, then the expression
2077 -- is plain illegal, so just abandon evaluation attempts. No need
2078 -- to check non-static context when we have something illegal anyway.
2080 if not Is_OK_Static_Choice_List (Discrete_Choices (Alt)) then
2087 -- OK, if the above loop gets through it means that all choices are OK
2088 -- static (don't raise exceptions), so the whole case is static, and we
2089 -- can find the matching alternative.
2091 Set_Is_Static_Expression (N);
2093 -- Now to deal with propagating a possible constraint error
2095 -- If the selecting expression raises CE, propagate and we are done
2097 if Raises_Constraint_Error (Expression (N)) then
2098 Set_Raises_Constraint_Error (N);
2100 -- Otherwise we need to check the alternatives to find the matching
2101 -- one. CE's in other than the matching one are not relevant. But we
2102 -- do need to check the matching one. Unlike the first loop, we do not
2103 -- have to go all the way through, when we find the matching one, quit.
2106 Alt := First (Alternatives (N));
2109 -- We must find a match among the alternatives, If not this must
2110 -- be due to other errors, so just ignore, leaving as non-static.
2113 Set_Is_Static_Expression (N, False);
2117 -- Otherwise loop through choices of this alternative
2119 Choice := First (Discrete_Choices (Alt));
2120 while Present (Choice) loop
2122 -- If we find a matching choice, then the Expression of this
2123 -- alternative replaces N (Raises_Constraint_Error flag is
2124 -- included, so we don't have to special case that).
2126 if Choice_Matches (Expression (N), Choice) = Match then
2127 Rewrite (N, Relocate_Node (Expression (Alt)));
2137 end Eval_Case_Expression;
2139 ------------------------
2140 -- Eval_Concatenation --
2141 ------------------------
2143 -- Concatenation is a static function, so the result is static if both
2144 -- operands are static (RM 4.9(7), 4.9(21)).
2146 procedure Eval_Concatenation (N : Node_Id) is
2147 Left : constant Node_Id := Left_Opnd (N);
2148 Right : constant Node_Id := Right_Opnd (N);
2149 C_Typ : constant Entity_Id := Root_Type (Component_Type (Etype (N)));
2154 -- Concatenation is never static in Ada 83, so if Ada 83 check operand
2155 -- non-static context.
2157 if Ada_Version = Ada_83
2158 and then Comes_From_Source (N)
2160 Check_Non_Static_Context (Left);
2161 Check_Non_Static_Context (Right);
2165 -- If not foldable we are done. In principle concatenation that yields
2166 -- any string type is static (i.e. an array type of character types).
2167 -- However, character types can include enumeration literals, and
2168 -- concatenation in that case cannot be described by a literal, so we
2169 -- only consider the operation static if the result is an array of
2170 -- (a descendant of) a predefined character type.
2172 Test_Expression_Is_Foldable (N, Left, Right, Stat, Fold);
2174 if not (Is_Standard_Character_Type (C_Typ) and then Fold) then
2175 Set_Is_Static_Expression (N, False);
2179 -- Compile time string concatenation
2181 -- ??? Note that operands that are aggregates can be marked as static,
2182 -- so we should attempt at a later stage to fold concatenations with
2186 Left_Str : constant Node_Id := Get_String_Val (Left);
2188 Right_Str : constant Node_Id := Get_String_Val (Right);
2189 Folded_Val : String_Id;
2192 -- Establish new string literal, and store left operand. We make
2193 -- sure to use the special Start_String that takes an operand if
2194 -- the left operand is a string literal. Since this is optimized
2195 -- in the case where that is the most recently created string
2196 -- literal, we ensure efficient time/space behavior for the
2197 -- case of a concatenation of a series of string literals.
2199 if Nkind (Left_Str) = N_String_Literal then
2200 Left_Len := String_Length (Strval (Left_Str));
2202 -- If the left operand is the empty string, and the right operand
2203 -- is a string literal (the case of "" & "..."), the result is the
2204 -- value of the right operand. This optimization is important when
2205 -- Is_Folded_In_Parser, to avoid copying an enormous right
2208 if Left_Len = 0 and then Nkind (Right_Str) = N_String_Literal then
2209 Folded_Val := Strval (Right_Str);
2211 Start_String (Strval (Left_Str));
2216 Store_String_Char (UI_To_CC (Char_Literal_Value (Left_Str)));
2220 -- Now append the characters of the right operand, unless we
2221 -- optimized the "" & "..." case above.
2223 if Nkind (Right_Str) = N_String_Literal then
2224 if Left_Len /= 0 then
2225 Store_String_Chars (Strval (Right_Str));
2226 Folded_Val := End_String;
2229 Store_String_Char (UI_To_CC (Char_Literal_Value (Right_Str)));
2230 Folded_Val := End_String;
2233 Set_Is_Static_Expression (N, Stat);
2235 -- If left operand is the empty string, the result is the
2236 -- right operand, including its bounds if anomalous.
2239 and then Is_Array_Type (Etype (Right))
2240 and then Etype (Right) /= Any_String
2242 Set_Etype (N, Etype (Right));
2245 Fold_Str (N, Folded_Val, Static => Stat);
2247 end Eval_Concatenation;
2249 ----------------------
2250 -- Eval_Entity_Name --
2251 ----------------------
2253 -- This procedure is used for identifiers and expanded names other than
2254 -- named numbers (see Eval_Named_Integer, Eval_Named_Real. These are
2255 -- static if they denote a static constant (RM 4.9(6)) or if the name
2256 -- denotes an enumeration literal (RM 4.9(22)).
2258 procedure Eval_Entity_Name (N : Node_Id) is
2259 Def_Id : constant Entity_Id := Entity (N);
2263 -- Enumeration literals are always considered to be constants
2264 -- and cannot raise constraint error (RM 4.9(22)).
2266 if Ekind (Def_Id) = E_Enumeration_Literal then
2267 Set_Is_Static_Expression (N);
2270 -- A name is static if it denotes a static constant (RM 4.9(5)), and
2271 -- we also copy Raise_Constraint_Error. Notice that even if non-static,
2272 -- it does not violate 10.2.1(8) here, since this is not a variable.
2274 elsif Ekind (Def_Id) = E_Constant then
2276 -- Deferred constants must always be treated as nonstatic outside the
2277 -- scope of their full view.
2279 if Present (Full_View (Def_Id))
2280 and then not In_Open_Scopes (Scope (Def_Id))
2284 Val := Constant_Value (Def_Id);
2287 if Present (Val) then
2288 Set_Is_Static_Expression
2289 (N, Is_Static_Expression (Val)
2290 and then Is_Static_Subtype (Etype (Def_Id)));
2291 Set_Raises_Constraint_Error (N, Raises_Constraint_Error (Val));
2293 if not Is_Static_Expression (N)
2294 and then not Is_Generic_Type (Etype (N))
2296 Validate_Static_Object_Name (N);
2299 -- Mark constant condition in SCOs
2302 and then Comes_From_Source (N)
2303 and then Is_Boolean_Type (Etype (Def_Id))
2304 and then Compile_Time_Known_Value (N)
2306 Set_SCO_Condition (N, Expr_Value_E (N) = Standard_True);
2313 -- Fall through if the name is not static
2315 Validate_Static_Object_Name (N);
2316 end Eval_Entity_Name;
2318 ------------------------
2319 -- Eval_If_Expression --
2320 ------------------------
2322 -- We can fold to a static expression if the condition and both dependent
2323 -- expressions are static. Otherwise, the only required processing is to do
2324 -- the check for non-static context for the then and else expressions.
2326 procedure Eval_If_Expression (N : Node_Id) is
2327 Condition : constant Node_Id := First (Expressions (N));
2328 Then_Expr : constant Node_Id := Next (Condition);
2329 Else_Expr : constant Node_Id := Next (Then_Expr);
2331 Non_Result : Node_Id;
2333 Rstat : constant Boolean :=
2334 Is_Static_Expression (Condition)
2336 Is_Static_Expression (Then_Expr)
2338 Is_Static_Expression (Else_Expr);
2339 -- True if result is static
2342 -- If result not static, nothing to do, otherwise set static result
2347 Set_Is_Static_Expression (N);
2350 -- If any operand is Any_Type, just propagate to result and do not try
2351 -- to fold, this prevents cascaded errors.
2353 if Etype (Condition) = Any_Type or else
2354 Etype (Then_Expr) = Any_Type or else
2355 Etype (Else_Expr) = Any_Type
2357 Set_Etype (N, Any_Type);
2358 Set_Is_Static_Expression (N, False);
2362 -- If condition raises constraint error then we have already signalled
2363 -- an error, and we just propagate to the result and do not fold.
2365 if Raises_Constraint_Error (Condition) then
2366 Set_Raises_Constraint_Error (N);
2370 -- Static case where we can fold. Note that we don't try to fold cases
2371 -- where the condition is known at compile time, but the result is
2372 -- non-static. This avoids possible cases of infinite recursion where
2373 -- the expander puts in a redundant test and we remove it. Instead we
2374 -- deal with these cases in the expander.
2376 -- Select result operand
2378 if Is_True (Expr_Value (Condition)) then
2379 Result := Then_Expr;
2380 Non_Result := Else_Expr;
2382 Result := Else_Expr;
2383 Non_Result := Then_Expr;
2386 -- Note that it does not matter if the non-result operand raises a
2387 -- Constraint_Error, but if the result raises constraint error then we
2388 -- replace the node with a raise constraint error. This will properly
2389 -- propagate Raises_Constraint_Error since this flag is set in Result.
2391 if Raises_Constraint_Error (Result) then
2392 Rewrite_In_Raise_CE (N, Result);
2393 Check_Non_Static_Context (Non_Result);
2395 -- Otherwise the result operand replaces the original node
2398 Rewrite (N, Relocate_Node (Result));
2399 Set_Is_Static_Expression (N);
2401 end Eval_If_Expression;
2403 ----------------------------
2404 -- Eval_Indexed_Component --
2405 ----------------------------
2407 -- Indexed components are never static, so we need to perform the check
2408 -- for non-static context on the index values. Then, we check if the
2409 -- value can be obtained at compile time, even though it is non-static.
2411 procedure Eval_Indexed_Component (N : Node_Id) is
2415 -- Check for non-static context on index values
2417 Expr := First (Expressions (N));
2418 while Present (Expr) loop
2419 Check_Non_Static_Context (Expr);
2423 -- If the indexed component appears in an object renaming declaration
2424 -- then we do not want to try to evaluate it, since in this case we
2425 -- need the identity of the array element.
2427 if Nkind (Parent (N)) = N_Object_Renaming_Declaration then
2430 -- Similarly if the indexed component appears as the prefix of an
2431 -- attribute we don't want to evaluate it, because at least for
2432 -- some cases of attributes we need the identify (e.g. Access, Size)
2434 elsif Nkind (Parent (N)) = N_Attribute_Reference then
2438 -- Note: there are other cases, such as the left side of an assignment,
2439 -- or an OUT parameter for a call, where the replacement results in the
2440 -- illegal use of a constant, But these cases are illegal in the first
2441 -- place, so the replacement, though silly, is harmless.
2443 -- Now see if this is a constant array reference
2445 if List_Length (Expressions (N)) = 1
2446 and then Is_Entity_Name (Prefix (N))
2447 and then Ekind (Entity (Prefix (N))) = E_Constant
2448 and then Present (Constant_Value (Entity (Prefix (N))))
2451 Loc : constant Source_Ptr := Sloc (N);
2452 Arr : constant Node_Id := Constant_Value (Entity (Prefix (N)));
2453 Sub : constant Node_Id := First (Expressions (N));
2459 -- Linear one's origin subscript value for array reference
2462 -- Lower bound of the first array index
2465 -- Value from constant array
2468 Atyp := Etype (Arr);
2470 if Is_Access_Type (Atyp) then
2471 Atyp := Designated_Type (Atyp);
2474 -- If we have an array type (we should have but perhaps there are
2475 -- error cases where this is not the case), then see if we can do
2476 -- a constant evaluation of the array reference.
2478 if Is_Array_Type (Atyp) and then Atyp /= Any_Composite then
2479 if Ekind (Atyp) = E_String_Literal_Subtype then
2480 Lbd := String_Literal_Low_Bound (Atyp);
2482 Lbd := Type_Low_Bound (Etype (First_Index (Atyp)));
2485 if Compile_Time_Known_Value (Sub)
2486 and then Nkind (Arr) = N_Aggregate
2487 and then Compile_Time_Known_Value (Lbd)
2488 and then Is_Discrete_Type (Component_Type (Atyp))
2490 Lin := UI_To_Int (Expr_Value (Sub) - Expr_Value (Lbd)) + 1;
2492 if List_Length (Expressions (Arr)) >= Lin then
2493 Elm := Pick (Expressions (Arr), Lin);
2495 -- If the resulting expression is compile time known,
2496 -- then we can rewrite the indexed component with this
2497 -- value, being sure to mark the result as non-static.
2498 -- We also reset the Sloc, in case this generates an
2499 -- error later on (e.g. 136'Access).
2501 if Compile_Time_Known_Value (Elm) then
2502 Rewrite (N, Duplicate_Subexpr_No_Checks (Elm));
2503 Set_Is_Static_Expression (N, False);
2508 -- We can also constant-fold if the prefix is a string literal.
2509 -- This will be useful in an instantiation or an inlining.
2511 elsif Compile_Time_Known_Value (Sub)
2512 and then Nkind (Arr) = N_String_Literal
2513 and then Compile_Time_Known_Value (Lbd)
2514 and then Expr_Value (Lbd) = 1
2515 and then Expr_Value (Sub) <=
2516 String_Literal_Length (Etype (Arr))
2519 C : constant Char_Code :=
2520 Get_String_Char (Strval (Arr),
2521 UI_To_Int (Expr_Value (Sub)));
2523 Set_Character_Literal_Name (C);
2526 Make_Character_Literal (Loc,
2528 Char_Literal_Value => UI_From_CC (C));
2529 Set_Etype (Elm, Component_Type (Atyp));
2530 Rewrite (N, Duplicate_Subexpr_No_Checks (Elm));
2531 Set_Is_Static_Expression (N, False);
2537 end Eval_Indexed_Component;
2539 --------------------------
2540 -- Eval_Integer_Literal --
2541 --------------------------
2543 -- Numeric literals are static (RM 4.9(1)), and have already been marked
2544 -- as static by the analyzer. The reason we did it that early is to allow
2545 -- the possibility of turning off the Is_Static_Expression flag after
2546 -- analysis, but before resolution, when integer literals are generated in
2547 -- the expander that do not correspond to static expressions.
2549 procedure Eval_Integer_Literal (N : Node_Id) is
2550 T : constant Entity_Id := Etype (N);
2552 function In_Any_Integer_Context return Boolean;
2553 -- If the literal is resolved with a specific type in a context where
2554 -- the expected type is Any_Integer, there are no range checks on the
2555 -- literal. By the time the literal is evaluated, it carries the type
2556 -- imposed by the enclosing expression, and we must recover the context
2557 -- to determine that Any_Integer is meant.
2559 ----------------------------
2560 -- In_Any_Integer_Context --
2561 ----------------------------
2563 function In_Any_Integer_Context return Boolean is
2564 Par : constant Node_Id := Parent (N);
2565 K : constant Node_Kind := Nkind (Par);
2568 -- Any_Integer also appears in digits specifications for real types,
2569 -- but those have bounds smaller that those of any integer base type,
2570 -- so we can safely ignore these cases.
2572 return Nkind_In (K, N_Number_Declaration,
2573 N_Attribute_Reference,
2574 N_Attribute_Definition_Clause,
2575 N_Modular_Type_Definition,
2576 N_Signed_Integer_Type_Definition);
2577 end In_Any_Integer_Context;
2579 -- Start of processing for Eval_Integer_Literal
2583 -- If the literal appears in a non-expression context, then it is
2584 -- certainly appearing in a non-static context, so check it. This is
2585 -- actually a redundant check, since Check_Non_Static_Context would
2586 -- check it, but it seems worth while avoiding the call.
2588 if Nkind (Parent (N)) not in N_Subexpr
2589 and then not In_Any_Integer_Context
2591 Check_Non_Static_Context (N);
2594 -- Modular integer literals must be in their base range
2596 if Is_Modular_Integer_Type (T)
2597 and then Is_Out_Of_Range (N, Base_Type (T), Assume_Valid => True)
2601 end Eval_Integer_Literal;
2603 ---------------------
2604 -- Eval_Logical_Op --
2605 ---------------------
2607 -- Logical operations are static functions, so the result is potentially
2608 -- static if both operands are potentially static (RM 4.9(7), 4.9(20)).
2610 procedure Eval_Logical_Op (N : Node_Id) is
2611 Left : constant Node_Id := Left_Opnd (N);
2612 Right : constant Node_Id := Right_Opnd (N);
2617 -- If not foldable we are done
2619 Test_Expression_Is_Foldable (N, Left, Right, Stat, Fold);
2625 -- Compile time evaluation of logical operation
2628 Left_Int : constant Uint := Expr_Value (Left);
2629 Right_Int : constant Uint := Expr_Value (Right);
2632 -- VMS includes bitwise operations on signed types
2634 if Is_Modular_Integer_Type (Etype (N))
2635 or else Is_VMS_Operator (Entity (N))
2638 Left_Bits : Bits (0 .. UI_To_Int (Esize (Etype (N))) - 1);
2639 Right_Bits : Bits (0 .. UI_To_Int (Esize (Etype (N))) - 1);
2642 To_Bits (Left_Int, Left_Bits);
2643 To_Bits (Right_Int, Right_Bits);
2645 -- Note: should really be able to use array ops instead of
2646 -- these loops, but they weren't working at the time ???
2648 if Nkind (N) = N_Op_And then
2649 for J in Left_Bits'Range loop
2650 Left_Bits (J) := Left_Bits (J) and Right_Bits (J);
2653 elsif Nkind (N) = N_Op_Or then
2654 for J in Left_Bits'Range loop
2655 Left_Bits (J) := Left_Bits (J) or Right_Bits (J);
2659 pragma Assert (Nkind (N) = N_Op_Xor);
2661 for J in Left_Bits'Range loop
2662 Left_Bits (J) := Left_Bits (J) xor Right_Bits (J);
2666 Fold_Uint (N, From_Bits (Left_Bits, Etype (N)), Stat);
2670 pragma Assert (Is_Boolean_Type (Etype (N)));
2672 if Nkind (N) = N_Op_And then
2674 Test (Is_True (Left_Int) and then Is_True (Right_Int)), Stat);
2676 elsif Nkind (N) = N_Op_Or then
2678 Test (Is_True (Left_Int) or else Is_True (Right_Int)), Stat);
2681 pragma Assert (Nkind (N) = N_Op_Xor);
2683 Test (Is_True (Left_Int) xor Is_True (Right_Int)), Stat);
2687 end Eval_Logical_Op;
2689 ------------------------
2690 -- Eval_Membership_Op --
2691 ------------------------
2693 -- A membership test is potentially static if the expression is static, and
2694 -- the range is a potentially static range, or is a subtype mark denoting a
2695 -- static subtype (RM 4.9(12)).
2697 procedure Eval_Membership_Op (N : Node_Id) is
2698 Left : constant Node_Id := Left_Opnd (N);
2699 Right : constant Node_Id := Right_Opnd (N);
2700 Alts : constant List_Id := Alternatives (N);
2701 Result : Match_Result;
2704 -- Ignore if error in either operand, except to make sure that Any_Type
2705 -- is properly propagated to avoid junk cascaded errors.
2707 if Etype (Left) = Any_Type
2708 or else (Present (Right) and then Etype (Right) = Any_Type)
2710 Set_Etype (N, Any_Type);
2714 -- Ignore if types involved have predicates
2715 -- Is this right for static predicates ???
2716 -- And what about the alternatives ???
2718 if Present (Predicate_Function (Etype (Left)))
2719 or else (Present (Right)
2720 and then Present (Predicate_Function (Etype (Right))))
2725 -- If left operand non-static, then nothing to do
2727 if not Is_Static_Expression (Left) then
2731 -- If choice is non-static, left operand is in non-static context
2733 if (Present (Right) and then not Is_Static_Choice (Right))
2734 or else (Present (Alts) and then not Is_Static_Choice_List (Alts))
2736 Check_Non_Static_Context (Left);
2740 -- Otherwise we definitely have a static expression
2742 Set_Is_Static_Expression (N);
2744 -- If left operand raises constraint error, propagate and we are done
2746 if Raises_Constraint_Error (Left) then
2747 Set_Raises_Constraint_Error (N, True);
2752 if Present (Right) then
2753 Result := Choice_Matches (Left, Right);
2755 Result := Choices_Match (Left, Alts);
2758 -- If result is Non_Static, it means that we raise Constraint_Error,
2759 -- since we already tested that the operands were themselves static.
2761 if Result = Non_Static then
2762 Set_Raises_Constraint_Error (N);
2764 -- Otherwise we have our result (flipped if NOT IN case)
2768 (N, Test ((Result = Match) xor (Nkind (N) = N_Not_In)), True);
2769 Warn_On_Known_Condition (N);
2772 end Eval_Membership_Op;
2774 ------------------------
2775 -- Eval_Named_Integer --
2776 ------------------------
2778 procedure Eval_Named_Integer (N : Node_Id) is
2781 Expr_Value (Expression (Declaration_Node (Entity (N)))), True);
2782 end Eval_Named_Integer;
2784 ---------------------
2785 -- Eval_Named_Real --
2786 ---------------------
2788 procedure Eval_Named_Real (N : Node_Id) is
2791 Expr_Value_R (Expression (Declaration_Node (Entity (N)))), True);
2792 end Eval_Named_Real;
2798 -- Exponentiation is a static functions, so the result is potentially
2799 -- static if both operands are potentially static (RM 4.9(7), 4.9(20)).
2801 procedure Eval_Op_Expon (N : Node_Id) is
2802 Left : constant Node_Id := Left_Opnd (N);
2803 Right : constant Node_Id := Right_Opnd (N);
2808 -- If not foldable we are done
2810 Test_Expression_Is_Foldable
2811 (N, Left, Right, Stat, Fold, CRT_Safe => True);
2813 -- Return if not foldable
2819 if Configurable_Run_Time_Mode and not Stat then
2823 -- Fold exponentiation operation
2826 Right_Int : constant Uint := Expr_Value (Right);
2831 if Is_Integer_Type (Etype (Left)) then
2833 Left_Int : constant Uint := Expr_Value (Left);
2837 -- Exponentiation of an integer raises Constraint_Error for a
2838 -- negative exponent (RM 4.5.6).
2840 if Right_Int < 0 then
2841 Apply_Compile_Time_Constraint_Error
2842 (N, "integer exponent negative", CE_Range_Check_Failed,
2847 if OK_Bits (N, Num_Bits (Left_Int) * Right_Int) then
2848 Result := Left_Int ** Right_Int;
2853 if Is_Modular_Integer_Type (Etype (N)) then
2854 Result := Result mod Modulus (Etype (N));
2857 Fold_Uint (N, Result, Stat);
2865 Left_Real : constant Ureal := Expr_Value_R (Left);
2868 -- Cannot have a zero base with a negative exponent
2870 if UR_Is_Zero (Left_Real) then
2872 if Right_Int < 0 then
2873 Apply_Compile_Time_Constraint_Error
2874 (N, "zero ** negative integer", CE_Range_Check_Failed,
2878 Fold_Ureal (N, Ureal_0, Stat);
2882 Fold_Ureal (N, Left_Real ** Right_Int, Stat);
2893 -- The not operation is a static functions, so the result is potentially
2894 -- static if the operand is potentially static (RM 4.9(7), 4.9(20)).
2896 procedure Eval_Op_Not (N : Node_Id) is
2897 Right : constant Node_Id := Right_Opnd (N);
2902 -- If not foldable we are done
2904 Test_Expression_Is_Foldable (N, Right, Stat, Fold);
2910 -- Fold not operation
2913 Rint : constant Uint := Expr_Value (Right);
2914 Typ : constant Entity_Id := Etype (N);
2917 -- Negation is equivalent to subtracting from the modulus minus one.
2918 -- For a binary modulus this is equivalent to the ones-complement of
2919 -- the original value. For non-binary modulus this is an arbitrary
2920 -- but consistent definition.
2922 if Is_Modular_Integer_Type (Typ) then
2923 Fold_Uint (N, Modulus (Typ) - 1 - Rint, Stat);
2924 else pragma Assert (Is_Boolean_Type (Typ));
2925 Fold_Uint (N, Test (not Is_True (Rint)), Stat);
2928 Set_Is_Static_Expression (N, Stat);
2932 -------------------------------
2933 -- Eval_Qualified_Expression --
2934 -------------------------------
2936 -- A qualified expression is potentially static if its subtype mark denotes
2937 -- a static subtype and its expression is potentially static (RM 4.9 (11)).
2939 procedure Eval_Qualified_Expression (N : Node_Id) is
2940 Operand : constant Node_Id := Expression (N);
2941 Target_Type : constant Entity_Id := Entity (Subtype_Mark (N));
2948 -- Can only fold if target is string or scalar and subtype is static.
2949 -- Also, do not fold if our parent is an allocator (this is because the
2950 -- qualified expression is really part of the syntactic structure of an
2951 -- allocator, and we do not want to end up with something that
2952 -- corresponds to "new 1" where the 1 is the result of folding a
2953 -- qualified expression).
2955 if not Is_Static_Subtype (Target_Type)
2956 or else Nkind (Parent (N)) = N_Allocator
2958 Check_Non_Static_Context (Operand);
2960 -- If operand is known to raise constraint_error, set the flag on the
2961 -- expression so it does not get optimized away.
2963 if Nkind (Operand) = N_Raise_Constraint_Error then
2964 Set_Raises_Constraint_Error (N);
2970 -- If not foldable we are done
2972 Test_Expression_Is_Foldable (N, Operand, Stat, Fold);
2977 -- Don't try fold if target type has constraint error bounds
2979 elsif not Is_OK_Static_Subtype (Target_Type) then
2980 Set_Raises_Constraint_Error (N);
2984 -- Here we will fold, save Print_In_Hex indication
2986 Hex := Nkind (Operand) = N_Integer_Literal
2987 and then Print_In_Hex (Operand);
2989 -- Fold the result of qualification
2991 if Is_Discrete_Type (Target_Type) then
2992 Fold_Uint (N, Expr_Value (Operand), Stat);
2994 -- Preserve Print_In_Hex indication
2996 if Hex and then Nkind (N) = N_Integer_Literal then
2997 Set_Print_In_Hex (N);
3000 elsif Is_Real_Type (Target_Type) then
3001 Fold_Ureal (N, Expr_Value_R (Operand), Stat);
3004 Fold_Str (N, Strval (Get_String_Val (Operand)), Stat);
3007 Set_Is_Static_Expression (N, False);
3009 Check_String_Literal_Length (N, Target_Type);
3015 -- The expression may be foldable but not static
3017 Set_Is_Static_Expression (N, Stat);
3019 if Is_Out_Of_Range (N, Etype (N), Assume_Valid => True) then
3022 end Eval_Qualified_Expression;
3024 -----------------------
3025 -- Eval_Real_Literal --
3026 -----------------------
3028 -- Numeric literals are static (RM 4.9(1)), and have already been marked
3029 -- as static by the analyzer. The reason we did it that early is to allow
3030 -- the possibility of turning off the Is_Static_Expression flag after
3031 -- analysis, but before resolution, when integer literals are generated
3032 -- in the expander that do not correspond to static expressions.
3034 procedure Eval_Real_Literal (N : Node_Id) is
3035 PK : constant Node_Kind := Nkind (Parent (N));
3038 -- If the literal appears in a non-expression context and not as part of
3039 -- a number declaration, then it is appearing in a non-static context,
3042 if PK not in N_Subexpr and then PK /= N_Number_Declaration then
3043 Check_Non_Static_Context (N);
3045 end Eval_Real_Literal;
3047 ------------------------
3048 -- Eval_Relational_Op --
3049 ------------------------
3051 -- Relational operations are static functions, so the result is static if
3052 -- both operands are static (RM 4.9(7), 4.9(20)), except that for strings,
3053 -- the result is never static, even if the operands are.
3055 procedure Eval_Relational_Op (N : Node_Id) is
3056 Left : constant Node_Id := Left_Opnd (N);
3057 Right : constant Node_Id := Right_Opnd (N);
3058 Typ : constant Entity_Id := Etype (Left);
3059 Otype : Entity_Id := Empty;
3063 -- One special case to deal with first. If we can tell that the result
3064 -- will be false because the lengths of one or more index subtypes are
3065 -- compile time known and different, then we can replace the entire
3066 -- result by False. We only do this for one dimensional arrays, because
3067 -- the case of multi-dimensional arrays is rare and too much trouble. If
3068 -- one of the operands is an illegal aggregate, its type might still be
3069 -- an arbitrary composite type, so nothing to do.
3071 if Is_Array_Type (Typ)
3072 and then Typ /= Any_Composite
3073 and then Number_Dimensions (Typ) = 1
3074 and then (Nkind (N) = N_Op_Eq or else Nkind (N) = N_Op_Ne)
3076 if Raises_Constraint_Error (Left)
3078 Raises_Constraint_Error (Right)
3083 -- OK, we have the case where we may be able to do this fold
3085 Length_Mismatch : declare
3086 procedure Get_Static_Length (Op : Node_Id; Len : out Uint);
3087 -- If Op is an expression for a constrained array with a known at
3088 -- compile time length, then Len is set to this (non-negative
3089 -- length). Otherwise Len is set to minus 1.
3091 -----------------------
3092 -- Get_Static_Length --
3093 -----------------------
3095 procedure Get_Static_Length (Op : Node_Id; Len : out Uint) is
3099 -- First easy case string literal
3101 if Nkind (Op) = N_String_Literal then
3102 Len := UI_From_Int (String_Length (Strval (Op)));
3106 -- Second easy case, not constrained subtype, so no length
3108 if not Is_Constrained (Etype (Op)) then
3109 Len := Uint_Minus_1;
3115 T := Etype (First_Index (Etype (Op)));
3117 -- The simple case, both bounds are known at compile time
3119 if Is_Discrete_Type (T)
3120 and then Compile_Time_Known_Value (Type_Low_Bound (T))
3121 and then Compile_Time_Known_Value (Type_High_Bound (T))
3123 Len := UI_Max (Uint_0,
3124 Expr_Value (Type_High_Bound (T)) -
3125 Expr_Value (Type_Low_Bound (T)) + 1);
3129 -- A more complex case, where the bounds are of the form
3130 -- X [+/- K1] .. X [+/- K2]), where X is an expression that is
3131 -- either A'First or A'Last (with A an entity name), or X is an
3132 -- entity name, and the two X's are the same and K1 and K2 are
3133 -- known at compile time, in this case, the length can also be
3134 -- computed at compile time, even though the bounds are not
3135 -- known. A common case of this is e.g. (X'First .. X'First+5).
3137 Extract_Length : declare
3138 procedure Decompose_Expr
3140 Ent : out Entity_Id;
3141 Kind : out Character;
3143 -- Given an expression see if it is of the form given above,
3144 -- X [+/- K]. If so Ent is set to the entity in X, Kind is
3145 -- 'F','L','E' for 'First/'Last/simple entity, and Cons is
3146 -- the value of K. If the expression is not of the required
3147 -- form, Ent is set to Empty.
3149 --------------------
3150 -- Decompose_Expr --
3151 --------------------
3153 procedure Decompose_Expr
3155 Ent : out Entity_Id;
3156 Kind : out Character;
3162 if Nkind (Expr) = N_Op_Add
3163 and then Compile_Time_Known_Value (Right_Opnd (Expr))
3165 Exp := Left_Opnd (Expr);
3166 Cons := Expr_Value (Right_Opnd (Expr));
3168 elsif Nkind (Expr) = N_Op_Subtract
3169 and then Compile_Time_Known_Value (Right_Opnd (Expr))
3171 Exp := Left_Opnd (Expr);
3172 Cons := -Expr_Value (Right_Opnd (Expr));
3174 -- If the bound is a constant created to remove side
3175 -- effects, recover original expression to see if it has
3176 -- one of the recognizable forms.
3178 elsif Nkind (Expr) = N_Identifier
3179 and then not Comes_From_Source (Entity (Expr))
3180 and then Ekind (Entity (Expr)) = E_Constant
3182 Nkind (Parent (Entity (Expr))) = N_Object_Declaration
3184 Exp := Expression (Parent (Entity (Expr)));
3185 Decompose_Expr (Exp, Ent, Kind, Cons);
3187 -- If original expression includes an entity, create a
3188 -- reference to it for use below.
3190 if Present (Ent) then
3191 Exp := New_Occurrence_Of (Ent, Sloc (Ent));
3199 -- At this stage Exp is set to the potential X
3201 if Nkind (Exp) = N_Attribute_Reference then
3202 if Attribute_Name (Exp) = Name_First then
3204 elsif Attribute_Name (Exp) = Name_Last then
3211 Exp := Prefix (Exp);
3217 if Is_Entity_Name (Exp) and then Present (Entity (Exp))
3219 Ent := Entity (Exp);
3227 Ent1, Ent2 : Entity_Id;
3228 Kind1, Kind2 : Character;
3229 Cons1, Cons2 : Uint;
3231 -- Start of processing for Extract_Length
3235 (Original_Node (Type_Low_Bound (T)), Ent1, Kind1, Cons1);
3237 (Original_Node (Type_High_Bound (T)), Ent2, Kind2, Cons2);
3240 and then Kind1 = Kind2
3241 and then Ent1 = Ent2
3243 Len := Cons2 - Cons1 + 1;
3245 Len := Uint_Minus_1;
3248 end Get_Static_Length;
3255 -- Start of processing for Length_Mismatch
3258 Get_Static_Length (Left, Len_L);
3259 Get_Static_Length (Right, Len_R);
3261 if Len_L /= Uint_Minus_1
3262 and then Len_R /= Uint_Minus_1
3263 and then Len_L /= Len_R
3265 Fold_Uint (N, Test (Nkind (N) = N_Op_Ne), False);
3266 Warn_On_Known_Condition (N);
3269 end Length_Mismatch;
3273 Is_Static_Expression : Boolean;
3275 Is_Foldable : Boolean;
3276 pragma Unreferenced (Is_Foldable);
3279 -- Initialize the value of Is_Static_Expression. The value of
3280 -- Is_Foldable returned by Test_Expression_Is_Foldable is not needed
3281 -- since, even when some operand is a variable, we can still perform
3282 -- the static evaluation of the expression in some cases (for
3283 -- example, for a variable of a subtype of Integer we statically
3284 -- know that any value stored in such variable is smaller than
3287 Test_Expression_Is_Foldable
3288 (N, Left, Right, Is_Static_Expression, Is_Foldable);
3290 -- Only comparisons of scalars can give static results. In
3291 -- particular, comparisons of strings never yield a static
3292 -- result, even if both operands are static strings.
3294 if not Is_Scalar_Type (Typ) then
3295 Is_Static_Expression := False;
3296 Set_Is_Static_Expression (N, False);
3299 -- For operators on universal numeric types called as functions with
3300 -- an explicit scope, determine appropriate specific numeric type,
3301 -- and diagnose possible ambiguity.
3303 if Is_Universal_Numeric_Type (Etype (Left))
3305 Is_Universal_Numeric_Type (Etype (Right))
3307 Otype := Find_Universal_Operator_Type (N);
3310 -- For static real type expressions, we cannot use
3311 -- Compile_Time_Compare since it worries about run-time
3312 -- results which are not exact.
3314 if Is_Static_Expression and then Is_Real_Type (Typ) then
3316 Left_Real : constant Ureal := Expr_Value_R (Left);
3317 Right_Real : constant Ureal := Expr_Value_R (Right);
3321 when N_Op_Eq => Result := (Left_Real = Right_Real);
3322 when N_Op_Ne => Result := (Left_Real /= Right_Real);
3323 when N_Op_Lt => Result := (Left_Real < Right_Real);
3324 when N_Op_Le => Result := (Left_Real <= Right_Real);
3325 when N_Op_Gt => Result := (Left_Real > Right_Real);
3326 when N_Op_Ge => Result := (Left_Real >= Right_Real);
3329 raise Program_Error;
3332 Fold_Uint (N, Test (Result), True);
3335 -- For all other cases, we use Compile_Time_Compare to do the compare
3339 CR : constant Compare_Result :=
3340 Compile_Time_Compare
3341 (Left, Right, Assume_Valid => False);
3344 if CR = Unknown then
3352 elsif CR = NE or else CR = GT or else CR = LT then
3359 if CR = NE or else CR = GT or else CR = LT then
3370 elsif CR = EQ or else CR = GT or else CR = GE then
3377 if CR = LT or else CR = EQ or else CR = LE then
3388 elsif CR = EQ or else CR = LT or else CR = LE then
3395 if CR = GT or else CR = EQ or else CR = GE then
3404 raise Program_Error;
3408 Fold_Uint (N, Test (Result), Is_Static_Expression);
3412 -- For the case of a folded relational operator on a specific numeric
3413 -- type, freeze operand type now.
3415 if Present (Otype) then
3416 Freeze_Before (N, Otype);
3419 Warn_On_Known_Condition (N);
3420 end Eval_Relational_Op;
3426 -- Shift operations are intrinsic operations that can never be static, so
3427 -- the only processing required is to perform the required check for a non
3428 -- static context for the two operands.
3430 -- Actually we could do some compile time evaluation here some time ???
3432 procedure Eval_Shift (N : Node_Id) is
3434 Check_Non_Static_Context (Left_Opnd (N));
3435 Check_Non_Static_Context (Right_Opnd (N));
3438 ------------------------
3439 -- Eval_Short_Circuit --
3440 ------------------------
3442 -- A short circuit operation is potentially static if both operands are
3443 -- potentially static (RM 4.9 (13)).
3445 procedure Eval_Short_Circuit (N : Node_Id) is
3446 Kind : constant Node_Kind := Nkind (N);
3447 Left : constant Node_Id := Left_Opnd (N);
3448 Right : constant Node_Id := Right_Opnd (N);
3451 Rstat : constant Boolean :=
3452 Is_Static_Expression (Left)
3454 Is_Static_Expression (Right);
3457 -- Short circuit operations are never static in Ada 83
3459 if Ada_Version = Ada_83 and then Comes_From_Source (N) then
3460 Check_Non_Static_Context (Left);
3461 Check_Non_Static_Context (Right);
3465 -- Now look at the operands, we can't quite use the normal call to
3466 -- Test_Expression_Is_Foldable here because short circuit operations
3467 -- are a special case, they can still be foldable, even if the right
3468 -- operand raises constraint error.
3470 -- If either operand is Any_Type, just propagate to result and do not
3471 -- try to fold, this prevents cascaded errors.
3473 if Etype (Left) = Any_Type or else Etype (Right) = Any_Type then
3474 Set_Etype (N, Any_Type);
3477 -- If left operand raises constraint error, then replace node N with
3478 -- the raise constraint error node, and we are obviously not foldable.
3479 -- Is_Static_Expression is set from the two operands in the normal way,
3480 -- and we check the right operand if it is in a non-static context.
3482 elsif Raises_Constraint_Error (Left) then
3484 Check_Non_Static_Context (Right);
3487 Rewrite_In_Raise_CE (N, Left);
3488 Set_Is_Static_Expression (N, Rstat);
3491 -- If the result is not static, then we won't in any case fold
3493 elsif not Rstat then
3494 Check_Non_Static_Context (Left);
3495 Check_Non_Static_Context (Right);
3499 -- Here the result is static, note that, unlike the normal processing
3500 -- in Test_Expression_Is_Foldable, we did *not* check above to see if
3501 -- the right operand raises constraint error, that's because it is not
3502 -- significant if the left operand is decisive.
3504 Set_Is_Static_Expression (N);
3506 -- It does not matter if the right operand raises constraint error if
3507 -- it will not be evaluated. So deal specially with the cases where
3508 -- the right operand is not evaluated. Note that we will fold these
3509 -- cases even if the right operand is non-static, which is fine, but
3510 -- of course in these cases the result is not potentially static.
3512 Left_Int := Expr_Value (Left);
3514 if (Kind = N_And_Then and then Is_False (Left_Int))
3516 (Kind = N_Or_Else and then Is_True (Left_Int))
3518 Fold_Uint (N, Left_Int, Rstat);
3522 -- If first operand not decisive, then it does matter if the right
3523 -- operand raises constraint error, since it will be evaluated, so
3524 -- we simply replace the node with the right operand. Note that this
3525 -- properly propagates Is_Static_Expression and Raises_Constraint_Error
3526 -- (both are set to True in Right).
3528 if Raises_Constraint_Error (Right) then
3529 Rewrite_In_Raise_CE (N, Right);
3530 Check_Non_Static_Context (Left);
3534 -- Otherwise the result depends on the right operand
3536 Fold_Uint (N, Expr_Value (Right), Rstat);
3538 end Eval_Short_Circuit;
3544 -- Slices can never be static, so the only processing required is to check
3545 -- for non-static context if an explicit range is given.
3547 procedure Eval_Slice (N : Node_Id) is
3548 Drange : constant Node_Id := Discrete_Range (N);
3551 if Nkind (Drange) = N_Range then
3552 Check_Non_Static_Context (Low_Bound (Drange));
3553 Check_Non_Static_Context (High_Bound (Drange));
3556 -- A slice of the form A (subtype), when the subtype is the index of
3557 -- the type of A, is redundant, the slice can be replaced with A, and
3558 -- this is worth a warning.
3560 if Is_Entity_Name (Prefix (N)) then
3562 E : constant Entity_Id := Entity (Prefix (N));
3563 T : constant Entity_Id := Etype (E);
3566 if Ekind (E) = E_Constant
3567 and then Is_Array_Type (T)
3568 and then Is_Entity_Name (Drange)
3570 if Is_Entity_Name (Original_Node (First_Index (T)))
3571 and then Entity (Original_Node (First_Index (T)))
3574 if Warn_On_Redundant_Constructs then
3575 Error_Msg_N ("redundant slice denotes whole array?r?", N);
3578 -- The following might be a useful optimization???
3580 -- Rewrite (N, New_Occurrence_Of (E, Sloc (N)));
3587 -------------------------
3588 -- Eval_String_Literal --
3589 -------------------------
3591 procedure Eval_String_Literal (N : Node_Id) is
3592 Typ : constant Entity_Id := Etype (N);
3593 Bas : constant Entity_Id := Base_Type (Typ);
3599 -- Nothing to do if error type (handles cases like default expressions
3600 -- or generics where we have not yet fully resolved the type).
3602 if Bas = Any_Type or else Bas = Any_String then
3606 -- String literals are static if the subtype is static (RM 4.9(2)), so
3607 -- reset the static expression flag (it was set unconditionally in
3608 -- Analyze_String_Literal) if the subtype is non-static. We tell if
3609 -- the subtype is static by looking at the lower bound.
3611 if Ekind (Typ) = E_String_Literal_Subtype then
3612 if not Is_OK_Static_Expression (String_Literal_Low_Bound (Typ)) then
3613 Set_Is_Static_Expression (N, False);
3617 -- Here if Etype of string literal is normal Etype (not yet possible,
3618 -- but may be possible in future).
3620 elsif not Is_OK_Static_Expression
3621 (Type_Low_Bound (Etype (First_Index (Typ))))
3623 Set_Is_Static_Expression (N, False);
3627 -- If original node was a type conversion, then result if non-static
3629 if Nkind (Original_Node (N)) = N_Type_Conversion then
3630 Set_Is_Static_Expression (N, False);
3634 -- Test for illegal Ada 95 cases. A string literal is illegal in Ada 95
3635 -- if its bounds are outside the index base type and this index type is
3636 -- static. This can happen in only two ways. Either the string literal
3637 -- is too long, or it is null, and the lower bound is type'First. In
3638 -- either case it is the upper bound that is out of range of the index
3640 if Ada_Version >= Ada_95 then
3641 if Root_Type (Bas) = Standard_String
3643 Root_Type (Bas) = Standard_Wide_String
3645 Root_Type (Bas) = Standard_Wide_Wide_String
3647 Xtp := Standard_Positive;
3649 Xtp := Etype (First_Index (Bas));
3652 if Ekind (Typ) = E_String_Literal_Subtype then
3653 Lo := String_Literal_Low_Bound (Typ);
3655 Lo := Type_Low_Bound (Etype (First_Index (Typ)));
3658 -- Check for string too long
3660 Len := String_Length (Strval (N));
3662 if UI_From_Int (Len) > String_Type_Len (Bas) then
3664 -- Issue message. Note that this message is a warning if the
3665 -- string literal is not marked as static (happens in some cases
3666 -- of folding strings known at compile time, but not static).
3667 -- Furthermore in such cases, we reword the message, since there
3668 -- is no string literal in the source program.
3670 if Is_Static_Expression (N) then
3671 Apply_Compile_Time_Constraint_Error
3672 (N, "string literal too long for}", CE_Length_Check_Failed,
3674 Typ => First_Subtype (Bas));
3676 Apply_Compile_Time_Constraint_Error
3677 (N, "string value too long for}", CE_Length_Check_Failed,
3679 Typ => First_Subtype (Bas),
3683 -- Test for null string not allowed
3686 and then not Is_Generic_Type (Xtp)
3688 Expr_Value (Lo) = Expr_Value (Type_Low_Bound (Base_Type (Xtp)))
3690 -- Same specialization of message
3692 if Is_Static_Expression (N) then
3693 Apply_Compile_Time_Constraint_Error
3694 (N, "null string literal not allowed for}",
3695 CE_Length_Check_Failed,
3697 Typ => First_Subtype (Bas));
3699 Apply_Compile_Time_Constraint_Error
3700 (N, "null string value not allowed for}",
3701 CE_Length_Check_Failed,
3703 Typ => First_Subtype (Bas),
3708 end Eval_String_Literal;
3710 --------------------------
3711 -- Eval_Type_Conversion --
3712 --------------------------
3714 -- A type conversion is potentially static if its subtype mark is for a
3715 -- static scalar subtype, and its operand expression is potentially static
3718 procedure Eval_Type_Conversion (N : Node_Id) is
3719 Operand : constant Node_Id := Expression (N);
3720 Source_Type : constant Entity_Id := Etype (Operand);
3721 Target_Type : constant Entity_Id := Etype (N);
3726 function To_Be_Treated_As_Integer (T : Entity_Id) return Boolean;
3727 -- Returns true if type T is an integer type, or if it is a fixed-point
3728 -- type to be treated as an integer (i.e. the flag Conversion_OK is set
3729 -- on the conversion node).
3731 function To_Be_Treated_As_Real (T : Entity_Id) return Boolean;
3732 -- Returns true if type T is a floating-point type, or if it is a
3733 -- fixed-point type that is not to be treated as an integer (i.e. the
3734 -- flag Conversion_OK is not set on the conversion node).
3736 ------------------------------
3737 -- To_Be_Treated_As_Integer --
3738 ------------------------------
3740 function To_Be_Treated_As_Integer (T : Entity_Id) return Boolean is
3744 or else (Is_Fixed_Point_Type (T) and then Conversion_OK (N));
3745 end To_Be_Treated_As_Integer;
3747 ---------------------------
3748 -- To_Be_Treated_As_Real --
3749 ---------------------------
3751 function To_Be_Treated_As_Real (T : Entity_Id) return Boolean is
3754 Is_Floating_Point_Type (T)
3755 or else (Is_Fixed_Point_Type (T) and then not Conversion_OK (N));
3756 end To_Be_Treated_As_Real;
3758 -- Start of processing for Eval_Type_Conversion
3761 -- Cannot fold if target type is non-static or if semantic error
3763 if not Is_Static_Subtype (Target_Type) then
3764 Check_Non_Static_Context (Operand);
3766 elsif Error_Posted (N) then
3770 -- If not foldable we are done
3772 Test_Expression_Is_Foldable (N, Operand, Stat, Fold);
3777 -- Don't try fold if target type has constraint error bounds
3779 elsif not Is_OK_Static_Subtype (Target_Type) then
3780 Set_Raises_Constraint_Error (N);
3784 -- Remaining processing depends on operand types. Note that in the
3785 -- following type test, fixed-point counts as real unless the flag
3786 -- Conversion_OK is set, in which case it counts as integer.
3788 -- Fold conversion, case of string type. The result is not static
3790 if Is_String_Type (Target_Type) then
3791 Fold_Str (N, Strval (Get_String_Val (Operand)), Static => False);
3794 -- Fold conversion, case of integer target type
3796 elsif To_Be_Treated_As_Integer (Target_Type) then
3801 -- Integer to integer conversion
3803 if To_Be_Treated_As_Integer (Source_Type) then
3804 Result := Expr_Value (Operand);
3806 -- Real to integer conversion
3809 Result := UR_To_Uint (Expr_Value_R (Operand));
3812 -- If fixed-point type (Conversion_OK must be set), then the
3813 -- result is logically an integer, but we must replace the
3814 -- conversion with the corresponding real literal, since the
3815 -- type from a semantic point of view is still fixed-point.
3817 if Is_Fixed_Point_Type (Target_Type) then
3819 (N, UR_From_Uint (Result) * Small_Value (Target_Type), Stat);
3821 -- Otherwise result is integer literal
3824 Fold_Uint (N, Result, Stat);
3828 -- Fold conversion, case of real target type
3830 elsif To_Be_Treated_As_Real (Target_Type) then
3835 if To_Be_Treated_As_Real (Source_Type) then
3836 Result := Expr_Value_R (Operand);
3838 Result := UR_From_Uint (Expr_Value (Operand));
3841 Fold_Ureal (N, Result, Stat);
3844 -- Enumeration types
3847 Fold_Uint (N, Expr_Value (Operand), Stat);
3850 if Is_Out_Of_Range (N, Etype (N), Assume_Valid => True) then
3854 end Eval_Type_Conversion;
3860 -- Predefined unary operators are static functions (RM 4.9(20)) and thus
3861 -- are potentially static if the operand is potentially static (RM 4.9(7)).
3863 procedure Eval_Unary_Op (N : Node_Id) is
3864 Right : constant Node_Id := Right_Opnd (N);
3865 Otype : Entity_Id := Empty;
3870 -- If not foldable we are done
3872 Test_Expression_Is_Foldable (N, Right, Stat, Fold);
3878 if Etype (Right) = Universal_Integer
3880 Etype (Right) = Universal_Real
3882 Otype := Find_Universal_Operator_Type (N);
3885 -- Fold for integer case
3887 if Is_Integer_Type (Etype (N)) then
3889 Rint : constant Uint := Expr_Value (Right);
3893 -- In the case of modular unary plus and abs there is no need
3894 -- to adjust the result of the operation since if the original
3895 -- operand was in bounds the result will be in the bounds of the
3896 -- modular type. However, in the case of modular unary minus the
3897 -- result may go out of the bounds of the modular type and needs
3900 if Nkind (N) = N_Op_Plus then
3903 elsif Nkind (N) = N_Op_Minus then
3904 if Is_Modular_Integer_Type (Etype (N)) then
3905 Result := (-Rint) mod Modulus (Etype (N));
3911 pragma Assert (Nkind (N) = N_Op_Abs);
3915 Fold_Uint (N, Result, Stat);
3918 -- Fold for real case
3920 elsif Is_Real_Type (Etype (N)) then
3922 Rreal : constant Ureal := Expr_Value_R (Right);
3926 if Nkind (N) = N_Op_Plus then
3928 elsif Nkind (N) = N_Op_Minus then
3929 Result := UR_Negate (Rreal);
3931 pragma Assert (Nkind (N) = N_Op_Abs);
3932 Result := abs Rreal;
3935 Fold_Ureal (N, Result, Stat);
3939 -- If the operator was resolved to a specific type, make sure that type
3940 -- is frozen even if the expression is folded into a literal (which has
3941 -- a universal type).
3943 if Present (Otype) then
3944 Freeze_Before (N, Otype);
3948 -------------------------------
3949 -- Eval_Unchecked_Conversion --
3950 -------------------------------
3952 -- Unchecked conversions can never be static, so the only required
3953 -- processing is to check for a non-static context for the operand.
3955 procedure Eval_Unchecked_Conversion (N : Node_Id) is
3957 Check_Non_Static_Context (Expression (N));
3958 end Eval_Unchecked_Conversion;
3960 --------------------
3961 -- Expr_Rep_Value --
3962 --------------------
3964 function Expr_Rep_Value (N : Node_Id) return Uint is
3965 Kind : constant Node_Kind := Nkind (N);
3969 if Is_Entity_Name (N) then
3972 -- An enumeration literal that was either in the source or created
3973 -- as a result of static evaluation.
3975 if Ekind (Ent) = E_Enumeration_Literal then
3976 return Enumeration_Rep (Ent);
3978 -- A user defined static constant
3981 pragma Assert (Ekind (Ent) = E_Constant);
3982 return Expr_Rep_Value (Constant_Value (Ent));
3985 -- An integer literal that was either in the source or created as a
3986 -- result of static evaluation.
3988 elsif Kind = N_Integer_Literal then
3991 -- A real literal for a fixed-point type. This must be the fixed-point
3992 -- case, either the literal is of a fixed-point type, or it is a bound
3993 -- of a fixed-point type, with type universal real. In either case we
3994 -- obtain the desired value from Corresponding_Integer_Value.
3996 elsif Kind = N_Real_Literal then
3997 pragma Assert (Is_Fixed_Point_Type (Underlying_Type (Etype (N))));
3998 return Corresponding_Integer_Value (N);
4000 -- Peculiar VMS case, if we have xxx'Null_Parameter, return zero
4002 elsif Kind = N_Attribute_Reference
4003 and then Attribute_Name (N) = Name_Null_Parameter
4007 -- Otherwise must be character literal
4010 pragma Assert (Kind = N_Character_Literal);
4013 -- Since Character literals of type Standard.Character don't have any
4014 -- defining character literals built for them, they do not have their
4015 -- Entity set, so just use their Char code. Otherwise for user-
4016 -- defined character literals use their Pos value as usual which is
4017 -- the same as the Rep value.
4020 return Char_Literal_Value (N);
4022 return Enumeration_Rep (Ent);
4031 function Expr_Value (N : Node_Id) return Uint is
4032 Kind : constant Node_Kind := Nkind (N);
4033 CV_Ent : CV_Entry renames CV_Cache (Nat (N) mod CV_Cache_Size);
4038 -- If already in cache, then we know it's compile time known and we can
4039 -- return the value that was previously stored in the cache since
4040 -- compile time known values cannot change.
4042 if CV_Ent.N = N then
4046 -- Otherwise proceed to test value
4048 if Is_Entity_Name (N) then
4051 -- An enumeration literal that was either in the source or created as
4052 -- a result of static evaluation.
4054 if Ekind (Ent) = E_Enumeration_Literal then
4055 Val := Enumeration_Pos (Ent);
4057 -- A user defined static constant
4060 pragma Assert (Ekind (Ent) = E_Constant);
4061 Val := Expr_Value (Constant_Value (Ent));
4064 -- An integer literal that was either in the source or created as a
4065 -- result of static evaluation.
4067 elsif Kind = N_Integer_Literal then
4070 -- A real literal for a fixed-point type. This must be the fixed-point
4071 -- case, either the literal is of a fixed-point type, or it is a bound
4072 -- of a fixed-point type, with type universal real. In either case we
4073 -- obtain the desired value from Corresponding_Integer_Value.
4075 elsif Kind = N_Real_Literal then
4076 pragma Assert (Is_Fixed_Point_Type (Underlying_Type (Etype (N))));
4077 Val := Corresponding_Integer_Value (N);
4079 -- Peculiar VMS case, if we have xxx'Null_Parameter, return zero
4081 elsif Kind = N_Attribute_Reference
4082 and then Attribute_Name (N) = Name_Null_Parameter
4086 -- Otherwise must be character literal
4089 pragma Assert (Kind = N_Character_Literal);
4092 -- Since Character literals of type Standard.Character don't
4093 -- have any defining character literals built for them, they
4094 -- do not have their Entity set, so just use their Char
4095 -- code. Otherwise for user-defined character literals use
4096 -- their Pos value as usual.
4099 Val := Char_Literal_Value (N);
4101 Val := Enumeration_Pos (Ent);
4105 -- Come here with Val set to value to be returned, set cache
4116 function Expr_Value_E (N : Node_Id) return Entity_Id is
4117 Ent : constant Entity_Id := Entity (N);
4119 if Ekind (Ent) = E_Enumeration_Literal then
4122 pragma Assert (Ekind (Ent) = E_Constant);
4123 return Expr_Value_E (Constant_Value (Ent));
4131 function Expr_Value_R (N : Node_Id) return Ureal is
4132 Kind : constant Node_Kind := Nkind (N);
4136 if Kind = N_Real_Literal then
4139 elsif Kind = N_Identifier or else Kind = N_Expanded_Name then
4141 pragma Assert (Ekind (Ent) = E_Constant);
4142 return Expr_Value_R (Constant_Value (Ent));
4144 elsif Kind = N_Integer_Literal then
4145 return UR_From_Uint (Expr_Value (N));
4147 -- Peculiar VMS case, if we have xxx'Null_Parameter, return 0.0
4149 elsif Kind = N_Attribute_Reference
4150 and then Attribute_Name (N) = Name_Null_Parameter
4155 -- If we fall through, we have a node that cannot be interpreted as a
4156 -- compile time constant. That is definitely an error.
4158 raise Program_Error;
4165 function Expr_Value_S (N : Node_Id) return Node_Id is
4167 if Nkind (N) = N_String_Literal then
4170 pragma Assert (Ekind (Entity (N)) = E_Constant);
4171 return Expr_Value_S (Constant_Value (Entity (N)));
4175 ----------------------------------
4176 -- Find_Universal_Operator_Type --
4177 ----------------------------------
4179 function Find_Universal_Operator_Type (N : Node_Id) return Entity_Id is
4180 PN : constant Node_Id := Parent (N);
4181 Call : constant Node_Id := Original_Node (N);
4182 Is_Int : constant Boolean := Is_Integer_Type (Etype (N));
4184 Is_Fix : constant Boolean :=
4185 Nkind (N) in N_Binary_Op
4186 and then Nkind (Right_Opnd (N)) /= Nkind (Left_Opnd (N));
4187 -- A mixed-mode operation in this context indicates the presence of
4188 -- fixed-point type in the designated package.
4190 Is_Relational : constant Boolean := Etype (N) = Standard_Boolean;
4191 -- Case where N is a relational (or membership) operator (else it is an
4194 In_Membership : constant Boolean :=
4195 Nkind (PN) in N_Membership_Test
4197 Nkind (Right_Opnd (PN)) = N_Range
4199 Is_Universal_Numeric_Type (Etype (Left_Opnd (PN)))
4201 Is_Universal_Numeric_Type
4202 (Etype (Low_Bound (Right_Opnd (PN))))
4204 Is_Universal_Numeric_Type
4205 (Etype (High_Bound (Right_Opnd (PN))));
4206 -- Case where N is part of a membership test with a universal range
4210 Typ1 : Entity_Id := Empty;
4213 function Is_Mixed_Mode_Operand (Op : Node_Id) return Boolean;
4214 -- Check whether one operand is a mixed-mode operation that requires the
4215 -- presence of a fixed-point type. Given that all operands are universal
4216 -- and have been constant-folded, retrieve the original function call.
4218 ---------------------------
4219 -- Is_Mixed_Mode_Operand --
4220 ---------------------------
4222 function Is_Mixed_Mode_Operand (Op : Node_Id) return Boolean is
4223 Onod : constant Node_Id := Original_Node (Op);
4225 return Nkind (Onod) = N_Function_Call
4226 and then Present (Next_Actual (First_Actual (Onod)))
4227 and then Etype (First_Actual (Onod)) /=
4228 Etype (Next_Actual (First_Actual (Onod)));
4229 end Is_Mixed_Mode_Operand;
4231 -- Start of processing for Find_Universal_Operator_Type
4234 if Nkind (Call) /= N_Function_Call
4235 or else Nkind (Name (Call)) /= N_Expanded_Name
4239 -- There are several cases where the context does not imply the type of
4241 -- - the universal expression appears in a type conversion;
4242 -- - the expression is a relational operator applied to universal
4244 -- - the expression is a membership test with a universal operand
4245 -- and a range with universal bounds.
4247 elsif Nkind (Parent (N)) = N_Type_Conversion
4248 or else Is_Relational
4249 or else In_Membership
4251 Pack := Entity (Prefix (Name (Call)));
4253 -- If the prefix is a package declared elsewhere, iterate over its
4254 -- visible entities, otherwise iterate over all declarations in the
4255 -- designated scope.
4257 if Ekind (Pack) = E_Package
4258 and then not In_Open_Scopes (Pack)
4260 Priv_E := First_Private_Entity (Pack);
4266 E := First_Entity (Pack);
4267 while Present (E) and then E /= Priv_E loop
4268 if Is_Numeric_Type (E)
4269 and then Nkind (Parent (E)) /= N_Subtype_Declaration
4270 and then Comes_From_Source (E)
4271 and then Is_Integer_Type (E) = Is_Int
4272 and then (Nkind (N) in N_Unary_Op
4273 or else Is_Relational
4274 or else Is_Fixed_Point_Type (E) = Is_Fix)
4279 -- Before emitting an error, check for the presence of a
4280 -- mixed-mode operation that specifies a fixed point type.
4284 (Is_Mixed_Mode_Operand (Left_Opnd (N))
4285 or else Is_Mixed_Mode_Operand (Right_Opnd (N)))
4286 and then Is_Fixed_Point_Type (E) /= Is_Fixed_Point_Type (Typ1)
4289 if Is_Fixed_Point_Type (E) then
4294 -- More than one type of the proper class declared in P
4296 Error_Msg_N ("ambiguous operation", N);
4297 Error_Msg_Sloc := Sloc (Typ1);
4298 Error_Msg_N ("\possible interpretation (inherited)#", N);
4299 Error_Msg_Sloc := Sloc (E);
4300 Error_Msg_N ("\possible interpretation (inherited)#", N);
4310 end Find_Universal_Operator_Type;
4312 --------------------------
4313 -- Flag_Non_Static_Expr --
4314 --------------------------
4316 procedure Flag_Non_Static_Expr (Msg : String; Expr : Node_Id) is
4318 if Error_Posted (Expr) and then not All_Errors_Mode then
4321 Error_Msg_F (Msg, Expr);
4322 Why_Not_Static (Expr);
4324 end Flag_Non_Static_Expr;
4330 procedure Fold_Str (N : Node_Id; Val : String_Id; Static : Boolean) is
4331 Loc : constant Source_Ptr := Sloc (N);
4332 Typ : constant Entity_Id := Etype (N);
4335 if Raises_Constraint_Error (N) then
4336 Set_Is_Static_Expression (N, Static);
4340 Rewrite (N, Make_String_Literal (Loc, Strval => Val));
4342 -- We now have the literal with the right value, both the actual type
4343 -- and the expected type of this literal are taken from the expression
4344 -- that was evaluated. So now we do the Analyze and Resolve.
4346 -- Note that we have to reset Is_Static_Expression both after the
4347 -- analyze step (because Resolve will evaluate the literal, which
4348 -- will cause semantic errors if it is marked as static), and after
4349 -- the Resolve step (since Resolve in some cases resets this flag).
4352 Set_Is_Static_Expression (N, Static);
4355 Set_Is_Static_Expression (N, Static);
4362 procedure Fold_Uint (N : Node_Id; Val : Uint; Static : Boolean) is
4363 Loc : constant Source_Ptr := Sloc (N);
4364 Typ : Entity_Id := Etype (N);
4368 if Raises_Constraint_Error (N) then
4369 Set_Is_Static_Expression (N, Static);
4373 -- If we are folding a named number, retain the entity in the literal,
4376 if Is_Entity_Name (N) and then Ekind (Entity (N)) = E_Named_Integer then
4382 if Is_Private_Type (Typ) then
4383 Typ := Full_View (Typ);
4386 -- For a result of type integer, substitute an N_Integer_Literal node
4387 -- for the result of the compile time evaluation of the expression.
4388 -- For ASIS use, set a link to the original named number when not in
4389 -- a generic context.
4391 if Is_Integer_Type (Typ) then
4392 Rewrite (N, Make_Integer_Literal (Loc, Val));
4393 Set_Original_Entity (N, Ent);
4395 -- Otherwise we have an enumeration type, and we substitute either
4396 -- an N_Identifier or N_Character_Literal to represent the enumeration
4397 -- literal corresponding to the given value, which must always be in
4398 -- range, because appropriate tests have already been made for this.
4400 else pragma Assert (Is_Enumeration_Type (Typ));
4401 Rewrite (N, Get_Enum_Lit_From_Pos (Etype (N), Val, Loc));
4404 -- We now have the literal with the right value, both the actual type
4405 -- and the expected type of this literal are taken from the expression
4406 -- that was evaluated. So now we do the Analyze and Resolve.
4408 -- Note that we have to reset Is_Static_Expression both after the
4409 -- analyze step (because Resolve will evaluate the literal, which
4410 -- will cause semantic errors if it is marked as static), and after
4411 -- the Resolve step (since Resolve in some cases sets this flag).
4414 Set_Is_Static_Expression (N, Static);
4417 Set_Is_Static_Expression (N, Static);
4424 procedure Fold_Ureal (N : Node_Id; Val : Ureal; Static : Boolean) is
4425 Loc : constant Source_Ptr := Sloc (N);
4426 Typ : constant Entity_Id := Etype (N);
4430 if Raises_Constraint_Error (N) then
4431 Set_Is_Static_Expression (N, Static);
4435 -- If we are folding a named number, retain the entity in the literal,
4438 if Is_Entity_Name (N) and then Ekind (Entity (N)) = E_Named_Real then
4444 Rewrite (N, Make_Real_Literal (Loc, Realval => Val));
4446 -- Set link to original named number, for ASIS use
4448 Set_Original_Entity (N, Ent);
4450 -- We now have the literal with the right value, both the actual type
4451 -- and the expected type of this literal are taken from the expression
4452 -- that was evaluated. So now we do the Analyze and Resolve.
4454 -- Note that we have to reset Is_Static_Expression both after the
4455 -- analyze step (because Resolve will evaluate the literal, which
4456 -- will cause semantic errors if it is marked as static), and after
4457 -- the Resolve step (since Resolve in some cases sets this flag).
4460 Set_Is_Static_Expression (N, Static);
4463 Set_Is_Static_Expression (N, Static);
4470 function From_Bits (B : Bits; T : Entity_Id) return Uint is
4474 for J in 0 .. B'Last loop
4480 if Non_Binary_Modulus (T) then
4481 V := V mod Modulus (T);
4487 --------------------
4488 -- Get_String_Val --
4489 --------------------
4491 function Get_String_Val (N : Node_Id) return Node_Id is
4493 if Nkind_In (N, N_String_Literal, N_Character_Literal) then
4496 pragma Assert (Is_Entity_Name (N));
4497 return Get_String_Val (Constant_Value (Entity (N)));
4505 procedure Initialize is
4507 CV_Cache := (others => (Node_High_Bound, Uint_0));
4510 --------------------
4511 -- In_Subrange_Of --
4512 --------------------
4514 function In_Subrange_Of
4517 Fixed_Int : Boolean := False) return Boolean
4526 if T1 = T2 or else Is_Subtype_Of (T1, T2) then
4529 -- Never in range if both types are not scalar. Don't know if this can
4530 -- actually happen, but just in case.
4532 elsif not Is_Scalar_Type (T1) or else not Is_Scalar_Type (T2) then
4535 -- If T1 has infinities but T2 doesn't have infinities, then T1 is
4536 -- definitely not compatible with T2.
4538 elsif Is_Floating_Point_Type (T1)
4539 and then Has_Infinities (T1)
4540 and then Is_Floating_Point_Type (T2)
4541 and then not Has_Infinities (T2)
4546 L1 := Type_Low_Bound (T1);
4547 H1 := Type_High_Bound (T1);
4549 L2 := Type_Low_Bound (T2);
4550 H2 := Type_High_Bound (T2);
4552 -- Check bounds to see if comparison possible at compile time
4554 if Compile_Time_Compare (L1, L2, Assume_Valid => True) in Compare_GE
4556 Compile_Time_Compare (H1, H2, Assume_Valid => True) in Compare_LE
4561 -- If bounds not comparable at compile time, then the bounds of T2
4562 -- must be compile time known or we cannot answer the query.
4564 if not Compile_Time_Known_Value (L2)
4565 or else not Compile_Time_Known_Value (H2)
4570 -- If the bounds of T1 are know at compile time then use these
4571 -- ones, otherwise use the bounds of the base type (which are of
4572 -- course always static).
4574 if not Compile_Time_Known_Value (L1) then
4575 L1 := Type_Low_Bound (Base_Type (T1));
4578 if not Compile_Time_Known_Value (H1) then
4579 H1 := Type_High_Bound (Base_Type (T1));
4582 -- Fixed point types should be considered as such only if
4583 -- flag Fixed_Int is set to False.
4585 if Is_Floating_Point_Type (T1) or else Is_Floating_Point_Type (T2)
4586 or else (Is_Fixed_Point_Type (T1) and then not Fixed_Int)
4587 or else (Is_Fixed_Point_Type (T2) and then not Fixed_Int)
4590 Expr_Value_R (L2) <= Expr_Value_R (L1)
4592 Expr_Value_R (H2) >= Expr_Value_R (H1);
4596 Expr_Value (L2) <= Expr_Value (L1)
4598 Expr_Value (H2) >= Expr_Value (H1);
4603 -- If any exception occurs, it means that we have some bug in the compiler
4604 -- possibly triggered by a previous error, or by some unforeseen peculiar
4605 -- occurrence. However, this is only an optimization attempt, so there is
4606 -- really no point in crashing the compiler. Instead we just decide, too
4607 -- bad, we can't figure out the answer in this case after all.
4612 -- Debug flag K disables this behavior (useful for debugging)
4614 if Debug_Flag_K then
4625 function Is_In_Range
4628 Assume_Valid : Boolean := False;
4629 Fixed_Int : Boolean := False;
4630 Int_Real : Boolean := False) return Boolean
4634 Test_In_Range (N, Typ, Assume_Valid, Fixed_Int, Int_Real) = In_Range;
4641 function Is_Null_Range (Lo : Node_Id; Hi : Node_Id) return Boolean is
4642 Typ : constant Entity_Id := Etype (Lo);
4645 if not Compile_Time_Known_Value (Lo)
4646 or else not Compile_Time_Known_Value (Hi)
4651 if Is_Discrete_Type (Typ) then
4652 return Expr_Value (Lo) > Expr_Value (Hi);
4653 else pragma Assert (Is_Real_Type (Typ));
4654 return Expr_Value_R (Lo) > Expr_Value_R (Hi);
4658 -------------------------
4659 -- Is_OK_Static_Choice --
4660 -------------------------
4662 function Is_OK_Static_Choice (Choice : Node_Id) return Boolean is
4664 -- Check various possibilities for choice
4666 -- Note: for membership tests, we test more cases than are possible
4667 -- (in particular subtype indication), but it doesn't matter because
4668 -- it just won't occur (we have already done a syntax check).
4670 if Nkind (Choice) = N_Others_Choice then
4673 elsif Nkind (Choice) = N_Range then
4674 return Is_OK_Static_Range (Choice);
4676 elsif Nkind (Choice) = N_Subtype_Indication
4678 (Is_Entity_Name (Choice) and then Is_Type (Entity (Choice)))
4680 return Is_OK_Static_Subtype (Etype (Choice));
4683 return Is_OK_Static_Expression (Choice);
4685 end Is_OK_Static_Choice;
4687 ------------------------------
4688 -- Is_OK_Static_Choice_List --
4689 ------------------------------
4691 function Is_OK_Static_Choice_List (Choices : List_Id) return Boolean is
4695 if not Is_Static_Choice_List (Choices) then
4699 Choice := First (Choices);
4700 while Present (Choice) loop
4701 if not Is_OK_Static_Choice (Choice) then
4702 Set_Raises_Constraint_Error (Choice);
4710 end Is_OK_Static_Choice_List;
4712 -----------------------------
4713 -- Is_OK_Static_Expression --
4714 -----------------------------
4716 function Is_OK_Static_Expression (N : Node_Id) return Boolean is
4718 return Is_Static_Expression (N) and then not Raises_Constraint_Error (N);
4719 end Is_OK_Static_Expression;
4721 ------------------------
4722 -- Is_OK_Static_Range --
4723 ------------------------
4725 -- A static range is a range whose bounds are static expressions, or a
4726 -- Range_Attribute_Reference equivalent to such a range (RM 4.9(26)).
4727 -- We have already converted range attribute references, so we get the
4728 -- "or" part of this rule without needing a special test.
4730 function Is_OK_Static_Range (N : Node_Id) return Boolean is
4732 return Is_OK_Static_Expression (Low_Bound (N))
4733 and then Is_OK_Static_Expression (High_Bound (N));
4734 end Is_OK_Static_Range;
4736 --------------------------
4737 -- Is_OK_Static_Subtype --
4738 --------------------------
4740 -- Determines if Typ is a static subtype as defined in (RM 4.9(26)) where
4741 -- neither bound raises constraint error when evaluated.
4743 function Is_OK_Static_Subtype (Typ : Entity_Id) return Boolean is
4744 Base_T : constant Entity_Id := Base_Type (Typ);
4745 Anc_Subt : Entity_Id;
4748 -- First a quick check on the non static subtype flag. As described
4749 -- in further detail in Einfo, this flag is not decisive in all cases,
4750 -- but if it is set, then the subtype is definitely non-static.
4752 if Is_Non_Static_Subtype (Typ) then
4756 Anc_Subt := Ancestor_Subtype (Typ);
4758 if Anc_Subt = Empty then
4762 if Is_Generic_Type (Root_Type (Base_T))
4763 or else Is_Generic_Actual_Type (Base_T)
4769 elsif Is_String_Type (Typ) then
4771 Ekind (Typ) = E_String_Literal_Subtype
4773 (Is_OK_Static_Subtype (Component_Type (Typ))
4774 and then Is_OK_Static_Subtype (Etype (First_Index (Typ))));
4778 elsif Is_Scalar_Type (Typ) then
4779 if Base_T = Typ then
4783 -- Scalar_Range (Typ) might be an N_Subtype_Indication, so use
4784 -- Get_Type_{Low,High}_Bound.
4786 return Is_OK_Static_Subtype (Anc_Subt)
4787 and then Is_OK_Static_Expression (Type_Low_Bound (Typ))
4788 and then Is_OK_Static_Expression (Type_High_Bound (Typ));
4791 -- Types other than string and scalar types are never static
4796 end Is_OK_Static_Subtype;
4798 ---------------------
4799 -- Is_Out_Of_Range --
4800 ---------------------
4802 function Is_Out_Of_Range
4805 Assume_Valid : Boolean := False;
4806 Fixed_Int : Boolean := False;
4807 Int_Real : Boolean := False) return Boolean
4810 return Test_In_Range (N, Typ, Assume_Valid, Fixed_Int, Int_Real) =
4812 end Is_Out_Of_Range;
4814 ----------------------
4815 -- Is_Static_Choice --
4816 ----------------------
4818 function Is_Static_Choice (Choice : Node_Id) return Boolean is
4820 -- Check various possibilities for choice
4822 -- Note: for membership tests, we test more cases than are possible
4823 -- (in particular subtype indication), but it doesn't matter because
4824 -- it just won't occur (we have already done a syntax check).
4826 if Nkind (Choice) = N_Others_Choice then
4829 elsif Nkind (Choice) = N_Range then
4830 return Is_Static_Range (Choice);
4832 elsif Nkind (Choice) = N_Subtype_Indication
4834 (Is_Entity_Name (Choice) and then Is_Type (Entity (Choice)))
4836 return Is_Static_Subtype (Etype (Choice));
4839 return Is_Static_Expression (Choice);
4841 end Is_Static_Choice;
4843 ---------------------------
4844 -- Is_Static_Choice_List --
4845 ---------------------------
4847 function Is_Static_Choice_List (Choices : List_Id) return Boolean is
4851 Choice := First (Choices);
4852 while Present (Choice) loop
4853 if not Is_Static_Choice (Choice) then
4861 end Is_Static_Choice_List;
4863 ---------------------
4864 -- Is_Static_Range --
4865 ---------------------
4867 -- A static range is a range whose bounds are static expressions, or a
4868 -- Range_Attribute_Reference equivalent to such a range (RM 4.9(26)).
4869 -- We have already converted range attribute references, so we get the
4870 -- "or" part of this rule without needing a special test.
4872 function Is_Static_Range (N : Node_Id) return Boolean is
4874 return Is_Static_Expression (Low_Bound (N))
4876 Is_Static_Expression (High_Bound (N));
4877 end Is_Static_Range;
4879 -----------------------
4880 -- Is_Static_Subtype --
4881 -----------------------
4883 -- Determines if Typ is a static subtype as defined in (RM 4.9(26))
4885 function Is_Static_Subtype (Typ : Entity_Id) return Boolean is
4886 Base_T : constant Entity_Id := Base_Type (Typ);
4887 Anc_Subt : Entity_Id;
4890 -- First a quick check on the non static subtype flag. As described
4891 -- in further detail in Einfo, this flag is not decisive in all cases,
4892 -- but if it is set, then the subtype is definitely non-static.
4894 if Is_Non_Static_Subtype (Typ) then
4898 Anc_Subt := Ancestor_Subtype (Typ);
4900 if Anc_Subt = Empty then
4904 if Is_Generic_Type (Root_Type (Base_T))
4905 or else Is_Generic_Actual_Type (Base_T)
4911 elsif Is_String_Type (Typ) then
4913 Ekind (Typ) = E_String_Literal_Subtype
4914 or else (Is_Static_Subtype (Component_Type (Typ))
4915 and then Is_Static_Subtype (Etype (First_Index (Typ))));
4919 elsif Is_Scalar_Type (Typ) then
4920 if Base_T = Typ then
4924 return Is_Static_Subtype (Anc_Subt)
4925 and then Is_Static_Expression (Type_Low_Bound (Typ))
4926 and then Is_Static_Expression (Type_High_Bound (Typ));
4929 -- Types other than string and scalar types are never static
4934 end Is_Static_Subtype;
4936 -------------------------------
4937 -- Is_Statically_Unevaluated --
4938 -------------------------------
4940 function Is_Statically_Unevaluated (Expr : Node_Id) return Boolean is
4941 function Check_Case_Expr_Alternative
4942 (CEA : Node_Id) return Match_Result;
4943 -- We have a message emanating from the Expression of a case expression
4944 -- alternative. We examine this alternative, as follows:
4946 -- If the selecting expression of the parent case is non-static, or
4947 -- if any of the discrete choices of the given case alternative are
4948 -- non-static or raise Constraint_Error, return Non_Static.
4950 -- Otherwise check if the selecting expression matches any of the given
4951 -- discrete choices. If so the alternative is executed and we return
4952 -- Open, otherwise, the alternative can never be executed, and so we
4955 ---------------------------------
4956 -- Check_Case_Expr_Alternative --
4957 ---------------------------------
4959 function Check_Case_Expr_Alternative
4960 (CEA : Node_Id) return Match_Result
4962 Case_Exp : constant Node_Id := Parent (CEA);
4967 pragma Assert (Nkind (Case_Exp) = N_Case_Expression);
4969 -- Check selecting expression is static
4971 if not Is_OK_Static_Expression (Expression (Case_Exp)) then
4975 if not Is_OK_Static_Choice_List (Discrete_Choices (CEA)) then
4979 -- All choices are now known to be static. Now see if alternative
4980 -- matches one of the choices.
4982 Choice := First (Discrete_Choices (CEA));
4983 while Present (Choice) loop
4985 -- Check various possibilities for choice, returning Closed if we
4986 -- find the selecting value matches any of the choices. Note that
4987 -- we know we are the last choice, so we don't have to keep going.
4989 if Nkind (Choice) = N_Others_Choice then
4991 -- Others choice is a bit annoying, it matches if none of the
4992 -- previous alternatives matches (note that we know we are the
4993 -- last alternative in this case, so we can just go backwards
4994 -- from us to see if any previous one matches).
4996 Prev_CEA := Prev (CEA);
4997 while Present (Prev_CEA) loop
4998 if Check_Case_Expr_Alternative (Prev_CEA) = Match then
5007 -- Else we have a normal static choice
5009 elsif Choice_Matches (Expression (Case_Exp), Choice) = Match then
5013 -- If we fall through, it means that the discrete choice did not
5014 -- match the selecting expression, so continue.
5019 -- If we get through that loop then all choices were static, and
5020 -- none of them matched the selecting expression. So return Closed.
5023 end Check_Case_Expr_Alternative;
5031 -- Start of processing for Is_Statically_Unevaluated
5034 -- The (32.x) references here are from RM section 4.9
5036 -- (32.1) An expression is statically unevaluated if it is part of ...
5038 -- This means we have to climb the tree looking for one of the cases
5045 -- (32.2) The right operand of a static short-circuit control form
5046 -- whose value is determined by its left operand.
5048 -- AND THEN with False as left operand
5050 if Nkind (P) = N_And_Then
5051 and then Compile_Time_Known_Value (Left_Opnd (P))
5052 and then Is_False (Expr_Value (Left_Opnd (P)))
5056 -- OR ELSE with True as left operand
5058 elsif Nkind (P) = N_Or_Else
5059 and then Compile_Time_Known_Value (Left_Opnd (P))
5060 and then Is_True (Expr_Value (Left_Opnd (P)))
5064 -- (32.3) A dependent_expression of an if_expression whose associated
5065 -- condition is static and equals False.
5067 elsif Nkind (P) = N_If_Expression then
5069 Cond : constant Node_Id := First (Expressions (P));
5070 Texp : constant Node_Id := Next (Cond);
5071 Fexp : constant Node_Id := Next (Texp);
5074 if Compile_Time_Known_Value (Cond) then
5076 -- Condition is True and we are in the right operand
5078 if Is_True (Expr_Value (Cond)) and then OldP = Fexp then
5081 -- Condition is False and we are in the left operand
5083 elsif Is_False (Expr_Value (Cond)) and then OldP = Texp then
5089 -- (32.4) A condition or dependent_expression of an if_expression
5090 -- where the condition corresponding to at least one preceding
5091 -- dependent_expression of the if_expression is static and equals
5094 -- This refers to cases like
5096 -- (if 1 then 1 elsif 1/0=2 then 2 else 3)
5098 -- But we expand elsif's out anyway, so the above looks like:
5100 -- (if 1 then 1 else (if 1/0=2 then 2 else 3))
5102 -- So for us this is caught by the above check for the 32.3 case.
5104 -- (32.5) A dependent_expression of a case_expression whose
5105 -- selecting_expression is static and whose value is not covered
5106 -- by the corresponding discrete_choice_list.
5108 elsif Nkind (P) = N_Case_Expression_Alternative then
5110 -- First, we have to be in the expression to suppress messages.
5111 -- If we are within one of the choices, we want the message.
5113 if OldP = Expression (P) then
5115 -- Statically unevaluated if alternative does not match
5117 if Check_Case_Expr_Alternative (P) = No_Match then
5122 -- (32.6) A choice_expression (or a simple_expression of a range
5123 -- that occurs as a membership_choice of a membership_choice_list)
5124 -- of a static membership test that is preceded in the enclosing
5125 -- membership_choice_list by another item whose individual
5126 -- membership test (see (RM 4.5.2)) statically yields True.
5128 elsif Nkind (P) in N_Membership_Test then
5130 -- Only possibly unevaluated if simple expression is static
5132 if not Is_OK_Static_Expression (Left_Opnd (P)) then
5135 -- All members of the choice list must be static
5137 elsif (Present (Right_Opnd (P))
5138 and then not Is_OK_Static_Choice (Right_Opnd (P)))
5139 or else (Present (Alternatives (P))
5141 not Is_OK_Static_Choice_List (Alternatives (P)))
5145 -- If expression is the one and only alternative, then it is
5146 -- definitely not statically unevaluated, so we only have to
5147 -- test the case where there are alternatives present.
5149 elsif Present (Alternatives (P)) then
5151 -- Look for previous matching Choice
5153 Choice := First (Alternatives (P));
5154 while Present (Choice) loop
5156 -- If we reached us and no previous choices matched, this
5157 -- is not the case where we are statically unevaluated.
5159 exit when OldP = Choice;
5161 -- If a previous choice matches, then that is the case where
5162 -- we know our choice is statically unevaluated.
5164 if Choice_Matches (Left_Opnd (P), Choice) = Match then
5171 -- If we fall through the loop, we were not one of the choices,
5172 -- we must have been the expression, so that is not covered by
5173 -- this rule, and we keep going.
5179 -- OK, not statically unevaluated at this level, see if we should
5180 -- keep climbing to look for a higher level reason.
5182 -- Special case for component association in aggregates, where
5183 -- we want to keep climbing up to the parent aggregate.
5185 if Nkind (P) = N_Component_Association
5186 and then Nkind (Parent (P)) = N_Aggregate
5190 -- All done if not still within subexpression
5193 exit when Nkind (P) not in N_Subexpr;
5197 -- If we fall through the loop, not one of the cases covered!
5200 end Is_Statically_Unevaluated;
5202 --------------------
5203 -- Not_Null_Range --
5204 --------------------
5206 function Not_Null_Range (Lo : Node_Id; Hi : Node_Id) return Boolean is
5207 Typ : constant Entity_Id := Etype (Lo);
5210 if not Compile_Time_Known_Value (Lo)
5211 or else not Compile_Time_Known_Value (Hi)
5216 if Is_Discrete_Type (Typ) then
5217 return Expr_Value (Lo) <= Expr_Value (Hi);
5218 else pragma Assert (Is_Real_Type (Typ));
5219 return Expr_Value_R (Lo) <= Expr_Value_R (Hi);
5227 function OK_Bits (N : Node_Id; Bits : Uint) return Boolean is
5229 -- We allow a maximum of 500,000 bits which seems a reasonable limit
5231 if Bits < 500_000 then
5234 -- Error if this maximum is exceeded
5237 Error_Msg_N ("static value too large, capacity exceeded", N);
5246 procedure Out_Of_Range (N : Node_Id) is
5248 -- If we have the static expression case, then this is an illegality
5249 -- in Ada 95 mode, except that in an instance, we never generate an
5250 -- error (if the error is legitimate, it was already diagnosed in the
5251 -- template). The expression to compute the length of a packed array is
5252 -- attached to the array type itself, and deserves a separate message.
5254 if Is_Static_Expression (N)
5255 and then not In_Instance
5256 and then not In_Inlined_Body
5257 and then Ada_Version >= Ada_95
5259 if Nkind (Parent (N)) = N_Defining_Identifier
5260 and then Is_Array_Type (Parent (N))
5261 and then Present (Packed_Array_Impl_Type (Parent (N)))
5262 and then Present (First_Rep_Item (Parent (N)))
5265 ("length of packed array must not exceed Integer''Last",
5266 First_Rep_Item (Parent (N)));
5267 Rewrite (N, Make_Integer_Literal (Sloc (N), Uint_1));
5270 Apply_Compile_Time_Constraint_Error
5271 (N, "value not in range of}", CE_Range_Check_Failed);
5274 -- Here we generate a warning for the Ada 83 case, or when we are in an
5275 -- instance, or when we have a non-static expression case.
5278 Apply_Compile_Time_Constraint_Error
5279 (N, "value not in range of}??", CE_Range_Check_Failed);
5283 ----------------------
5284 -- Predicates_Match --
5285 ----------------------
5287 function Predicates_Match (T1, T2 : Entity_Id) return Boolean is
5292 if Ada_Version < Ada_2012 then
5295 -- Both types must have predicates or lack them
5297 elsif Has_Predicates (T1) /= Has_Predicates (T2) then
5300 -- Check matching predicates
5305 (T1, Name_Static_Predicate, Check_Parents => False);
5308 (T2, Name_Static_Predicate, Check_Parents => False);
5310 -- Subtypes statically match if the predicate comes from the
5311 -- same declaration, which can only happen if one is a subtype
5312 -- of the other and has no explicit predicate.
5314 -- Suppress warnings on order of actuals, which is otherwise
5315 -- triggered by one of the two calls below.
5317 pragma Warnings (Off);
5318 return Pred1 = Pred2
5319 or else (No (Pred1) and then Is_Subtype_Of (T1, T2))
5320 or else (No (Pred2) and then Is_Subtype_Of (T2, T1));
5321 pragma Warnings (On);
5323 end Predicates_Match;
5325 -------------------------
5326 -- Rewrite_In_Raise_CE --
5327 -------------------------
5329 procedure Rewrite_In_Raise_CE (N : Node_Id; Exp : Node_Id) is
5330 Typ : constant Entity_Id := Etype (N);
5331 Stat : constant Boolean := Is_Static_Expression (N);
5334 -- If we want to raise CE in the condition of a N_Raise_CE node, we
5335 -- can just clear the condition if the reason is appropriate. We do
5336 -- not do this operation if the parent has a reason other than range
5337 -- check failed, because otherwise we would change the reason.
5339 if Present (Parent (N))
5340 and then Nkind (Parent (N)) = N_Raise_Constraint_Error
5341 and then Reason (Parent (N)) =
5342 UI_From_Int (RT_Exception_Code'Pos (CE_Range_Check_Failed))
5344 Set_Condition (Parent (N), Empty);
5346 -- If the expression raising CE is a N_Raise_CE node, we can use that
5347 -- one. We just preserve the type of the context.
5349 elsif Nkind (Exp) = N_Raise_Constraint_Error then
5353 -- Else build an explicit N_Raise_CE
5357 Make_Raise_Constraint_Error (Sloc (Exp),
5358 Reason => CE_Range_Check_Failed));
5359 Set_Raises_Constraint_Error (N);
5363 -- Set proper flags in result
5365 Set_Raises_Constraint_Error (N, True);
5366 Set_Is_Static_Expression (N, Stat);
5367 end Rewrite_In_Raise_CE;
5369 ---------------------
5370 -- String_Type_Len --
5371 ---------------------
5373 function String_Type_Len (Stype : Entity_Id) return Uint is
5374 NT : constant Entity_Id := Etype (First_Index (Stype));
5378 if Is_OK_Static_Subtype (NT) then
5381 T := Base_Type (NT);
5384 return Expr_Value (Type_High_Bound (T)) -
5385 Expr_Value (Type_Low_Bound (T)) + 1;
5386 end String_Type_Len;
5388 ------------------------------------
5389 -- Subtypes_Statically_Compatible --
5390 ------------------------------------
5392 function Subtypes_Statically_Compatible
5395 Formal_Derived_Matching : Boolean := False) return Boolean
5400 if Is_Scalar_Type (T1) then
5402 -- Definitely compatible if we match
5404 if Subtypes_Statically_Match (T1, T2) then
5407 -- If either subtype is nonstatic then they're not compatible
5409 elsif not Is_OK_Static_Subtype (T1)
5411 not Is_OK_Static_Subtype (T2)
5415 -- If either type has constraint error bounds, then consider that
5416 -- they match to avoid junk cascaded errors here.
5418 elsif not Is_OK_Static_Subtype (T1)
5419 or else not Is_OK_Static_Subtype (T2)
5423 -- Base types must match, but we don't check that (should we???) but
5424 -- we do at least check that both types are real, or both types are
5427 elsif Is_Real_Type (T1) /= Is_Real_Type (T2) then
5430 -- Here we check the bounds
5434 LB1 : constant Node_Id := Type_Low_Bound (T1);
5435 HB1 : constant Node_Id := Type_High_Bound (T1);
5436 LB2 : constant Node_Id := Type_Low_Bound (T2);
5437 HB2 : constant Node_Id := Type_High_Bound (T2);
5440 if Is_Real_Type (T1) then
5442 (Expr_Value_R (LB1) > Expr_Value_R (HB1))
5444 (Expr_Value_R (LB2) <= Expr_Value_R (LB1)
5446 Expr_Value_R (HB1) <= Expr_Value_R (HB2));
5450 (Expr_Value (LB1) > Expr_Value (HB1))
5452 (Expr_Value (LB2) <= Expr_Value (LB1)
5454 Expr_Value (HB1) <= Expr_Value (HB2));
5461 elsif Is_Access_Type (T1) then
5462 return (not Is_Constrained (T2)
5463 or else (Subtypes_Statically_Match
5464 (Designated_Type (T1), Designated_Type (T2))))
5465 and then not (Can_Never_Be_Null (T2)
5466 and then not Can_Never_Be_Null (T1));
5471 return (Is_Composite_Type (T1) and then not Is_Constrained (T2))
5472 or else Subtypes_Statically_Match (T1, T2, Formal_Derived_Matching);
5474 end Subtypes_Statically_Compatible;
5476 -------------------------------
5477 -- Subtypes_Statically_Match --
5478 -------------------------------
5480 -- Subtypes statically match if they have statically matching constraints
5481 -- (RM 4.9.1(2)). Constraints statically match if there are none, or if
5482 -- they are the same identical constraint, or if they are static and the
5483 -- values match (RM 4.9.1(1)).
5485 -- In addition, in GNAT, the object size (Esize) values of the types must
5486 -- match if they are set (unless checking an actual for a formal derived
5487 -- type). The use of 'Object_Size can cause this to be false even if the
5488 -- types would otherwise match in the RM sense.
5490 function Subtypes_Statically_Match
5493 Formal_Derived_Matching : Boolean := False) return Boolean
5496 -- A type always statically matches itself
5501 -- No match if sizes different (from use of 'Object_Size). This test
5502 -- is excluded if Formal_Derived_Matching is True, as the base types
5503 -- can be different in that case and typically have different sizes
5504 -- (and Esizes can be set when Frontend_Layout_On_Target is True).
5506 elsif not Formal_Derived_Matching
5507 and then Known_Static_Esize (T1)
5508 and then Known_Static_Esize (T2)
5509 and then Esize (T1) /= Esize (T2)
5513 -- No match if predicates do not match
5515 elsif not Predicates_Match (T1, T2) then
5520 elsif Is_Scalar_Type (T1) then
5522 -- Base types must be the same
5524 if Base_Type (T1) /= Base_Type (T2) then
5528 -- A constrained numeric subtype never matches an unconstrained
5529 -- subtype, i.e. both types must be constrained or unconstrained.
5531 -- To understand the requirement for this test, see RM 4.9.1(1).
5532 -- As is made clear in RM 3.5.4(11), type Integer, for example is
5533 -- a constrained subtype with constraint bounds matching the bounds
5534 -- of its corresponding unconstrained base type. In this situation,
5535 -- Integer and Integer'Base do not statically match, even though
5536 -- they have the same bounds.
5538 -- We only apply this test to types in Standard and types that appear
5539 -- in user programs. That way, we do not have to be too careful about
5540 -- setting Is_Constrained right for Itypes.
5542 if Is_Numeric_Type (T1)
5543 and then (Is_Constrained (T1) /= Is_Constrained (T2))
5544 and then (Scope (T1) = Standard_Standard
5545 or else Comes_From_Source (T1))
5546 and then (Scope (T2) = Standard_Standard
5547 or else Comes_From_Source (T2))
5551 -- A generic scalar type does not statically match its base type
5552 -- (AI-311). In this case we make sure that the formals, which are
5553 -- first subtypes of their bases, are constrained.
5555 elsif Is_Generic_Type (T1)
5556 and then Is_Generic_Type (T2)
5557 and then (Is_Constrained (T1) /= Is_Constrained (T2))
5562 -- If there was an error in either range, then just assume the types
5563 -- statically match to avoid further junk errors.
5565 if No (Scalar_Range (T1)) or else No (Scalar_Range (T2))
5566 or else Error_Posted (Scalar_Range (T1))
5567 or else Error_Posted (Scalar_Range (T2))
5572 -- Otherwise both types have bounds that can be compared
5575 LB1 : constant Node_Id := Type_Low_Bound (T1);
5576 HB1 : constant Node_Id := Type_High_Bound (T1);
5577 LB2 : constant Node_Id := Type_Low_Bound (T2);
5578 HB2 : constant Node_Id := Type_High_Bound (T2);
5581 -- If the bounds are the same tree node, then match (common case)
5583 if LB1 = LB2 and then HB1 = HB2 then
5586 -- Otherwise bounds must be static and identical value
5589 if not Is_OK_Static_Subtype (T1)
5590 or else not Is_OK_Static_Subtype (T2)
5594 -- If either type has constraint error bounds, then say that
5595 -- they match to avoid junk cascaded errors here.
5597 elsif not Is_OK_Static_Subtype (T1)
5598 or else not Is_OK_Static_Subtype (T2)
5602 elsif Is_Real_Type (T1) then
5604 (Expr_Value_R (LB1) = Expr_Value_R (LB2))
5606 (Expr_Value_R (HB1) = Expr_Value_R (HB2));
5610 Expr_Value (LB1) = Expr_Value (LB2)
5612 Expr_Value (HB1) = Expr_Value (HB2);
5617 -- Type with discriminants
5619 elsif Has_Discriminants (T1) or else Has_Discriminants (T2) then
5621 -- Because of view exchanges in multiple instantiations, conformance
5622 -- checking might try to match a partial view of a type with no
5623 -- discriminants with a full view that has defaulted discriminants.
5624 -- In such a case, use the discriminant constraint of the full view,
5625 -- which must exist because we know that the two subtypes have the
5628 if Has_Discriminants (T1) /= Has_Discriminants (T2) then
5630 if Is_Private_Type (T2)
5631 and then Present (Full_View (T2))
5632 and then Has_Discriminants (Full_View (T2))
5634 return Subtypes_Statically_Match (T1, Full_View (T2));
5636 elsif Is_Private_Type (T1)
5637 and then Present (Full_View (T1))
5638 and then Has_Discriminants (Full_View (T1))
5640 return Subtypes_Statically_Match (Full_View (T1), T2);
5651 DL1 : constant Elist_Id := Discriminant_Constraint (T1);
5652 DL2 : constant Elist_Id := Discriminant_Constraint (T2);
5660 elsif Is_Constrained (T1) /= Is_Constrained (T2) then
5664 -- Now loop through the discriminant constraints
5666 -- Note: the guard here seems necessary, since it is possible at
5667 -- least for DL1 to be No_Elist. Not clear this is reasonable ???
5669 if Present (DL1) and then Present (DL2) then
5670 DA1 := First_Elmt (DL1);
5671 DA2 := First_Elmt (DL2);
5672 while Present (DA1) loop
5674 Expr1 : constant Node_Id := Node (DA1);
5675 Expr2 : constant Node_Id := Node (DA2);
5678 if not Is_OK_Static_Expression (Expr1)
5679 or else not Is_OK_Static_Expression (Expr2)
5683 -- If either expression raised a constraint error,
5684 -- consider the expressions as matching, since this
5685 -- helps to prevent cascading errors.
5687 elsif Raises_Constraint_Error (Expr1)
5688 or else Raises_Constraint_Error (Expr2)
5692 elsif Expr_Value (Expr1) /= Expr_Value (Expr2) then
5705 -- A definite type does not match an indefinite or classwide type.
5706 -- However, a generic type with unknown discriminants may be
5707 -- instantiated with a type with no discriminants, and conformance
5708 -- checking on an inherited operation may compare the actual with the
5709 -- subtype that renames it in the instance.
5711 elsif Has_Unknown_Discriminants (T1) /= Has_Unknown_Discriminants (T2)
5714 Is_Generic_Actual_Type (T1) or else Is_Generic_Actual_Type (T2);
5718 elsif Is_Array_Type (T1) then
5720 -- If either subtype is unconstrained then both must be, and if both
5721 -- are unconstrained then no further checking is needed.
5723 if not Is_Constrained (T1) or else not Is_Constrained (T2) then
5724 return not (Is_Constrained (T1) or else Is_Constrained (T2));
5727 -- Both subtypes are constrained, so check that the index subtypes
5728 -- statically match.
5731 Index1 : Node_Id := First_Index (T1);
5732 Index2 : Node_Id := First_Index (T2);
5735 while Present (Index1) loop
5737 Subtypes_Statically_Match (Etype (Index1), Etype (Index2))
5742 Next_Index (Index1);
5743 Next_Index (Index2);
5749 elsif Is_Access_Type (T1) then
5750 if Can_Never_Be_Null (T1) /= Can_Never_Be_Null (T2) then
5753 elsif Ekind_In (T1, E_Access_Subprogram_Type,
5754 E_Anonymous_Access_Subprogram_Type)
5758 (Designated_Type (T1),
5759 Designated_Type (T2));
5762 Subtypes_Statically_Match
5763 (Designated_Type (T1),
5764 Designated_Type (T2))
5765 and then Is_Access_Constant (T1) = Is_Access_Constant (T2);
5768 -- All other types definitely match
5773 end Subtypes_Statically_Match;
5779 function Test (Cond : Boolean) return Uint is
5788 ---------------------------------
5789 -- Test_Expression_Is_Foldable --
5790 ---------------------------------
5794 procedure Test_Expression_Is_Foldable
5804 if Debug_Flag_Dot_F and then In_Extended_Main_Source_Unit (N) then
5808 -- If operand is Any_Type, just propagate to result and do not
5809 -- try to fold, this prevents cascaded errors.
5811 if Etype (Op1) = Any_Type then
5812 Set_Etype (N, Any_Type);
5815 -- If operand raises constraint error, then replace node N with the
5816 -- raise constraint error node, and we are obviously not foldable.
5817 -- Note that this replacement inherits the Is_Static_Expression flag
5818 -- from the operand.
5820 elsif Raises_Constraint_Error (Op1) then
5821 Rewrite_In_Raise_CE (N, Op1);
5824 -- If the operand is not static, then the result is not static, and
5825 -- all we have to do is to check the operand since it is now known
5826 -- to appear in a non-static context.
5828 elsif not Is_Static_Expression (Op1) then
5829 Check_Non_Static_Context (Op1);
5830 Fold := Compile_Time_Known_Value (Op1);
5833 -- An expression of a formal modular type is not foldable because
5834 -- the modulus is unknown.
5836 elsif Is_Modular_Integer_Type (Etype (Op1))
5837 and then Is_Generic_Type (Etype (Op1))
5839 Check_Non_Static_Context (Op1);
5842 -- Here we have the case of an operand whose type is OK, which is
5843 -- static, and which does not raise constraint error, we can fold.
5846 Set_Is_Static_Expression (N);
5850 end Test_Expression_Is_Foldable;
5854 procedure Test_Expression_Is_Foldable
5860 CRT_Safe : Boolean := False)
5862 Rstat : constant Boolean := Is_Static_Expression (Op1)
5864 Is_Static_Expression (Op2);
5870 -- Inhibit folding if -gnatd.f flag set
5872 if Debug_Flag_Dot_F and then In_Extended_Main_Source_Unit (N) then
5876 -- If either operand is Any_Type, just propagate to result and
5877 -- do not try to fold, this prevents cascaded errors.
5879 if Etype (Op1) = Any_Type or else Etype (Op2) = Any_Type then
5880 Set_Etype (N, Any_Type);
5883 -- If left operand raises constraint error, then replace node N with the
5884 -- Raise_Constraint_Error node, and we are obviously not foldable.
5885 -- Is_Static_Expression is set from the two operands in the normal way,
5886 -- and we check the right operand if it is in a non-static context.
5888 elsif Raises_Constraint_Error (Op1) then
5890 Check_Non_Static_Context (Op2);
5893 Rewrite_In_Raise_CE (N, Op1);
5894 Set_Is_Static_Expression (N, Rstat);
5897 -- Similar processing for the case of the right operand. Note that we
5898 -- don't use this routine for the short-circuit case, so we do not have
5899 -- to worry about that special case here.
5901 elsif Raises_Constraint_Error (Op2) then
5903 Check_Non_Static_Context (Op1);
5906 Rewrite_In_Raise_CE (N, Op2);
5907 Set_Is_Static_Expression (N, Rstat);
5910 -- Exclude expressions of a generic modular type, as above
5912 elsif Is_Modular_Integer_Type (Etype (Op1))
5913 and then Is_Generic_Type (Etype (Op1))
5915 Check_Non_Static_Context (Op1);
5918 -- If result is not static, then check non-static contexts on operands
5919 -- since one of them may be static and the other one may not be static.
5921 elsif not Rstat then
5922 Check_Non_Static_Context (Op1);
5923 Check_Non_Static_Context (Op2);
5926 Fold := CRT_Safe_Compile_Time_Known_Value (Op1)
5927 and then CRT_Safe_Compile_Time_Known_Value (Op2);
5929 Fold := Compile_Time_Known_Value (Op1)
5930 and then Compile_Time_Known_Value (Op2);
5935 -- Else result is static and foldable. Both operands are static, and
5936 -- neither raises constraint error, so we can definitely fold.
5939 Set_Is_Static_Expression (N);
5944 end Test_Expression_Is_Foldable;
5950 function Test_In_Range
5953 Assume_Valid : Boolean;
5954 Fixed_Int : Boolean;
5955 Int_Real : Boolean) return Range_Membership
5960 pragma Warnings (Off, Assume_Valid);
5961 -- For now Assume_Valid is unreferenced since the current implementation
5962 -- always returns Unknown if N is not a compile time known value, but we
5963 -- keep the parameter to allow for future enhancements in which we try
5964 -- to get the information in the variable case as well.
5967 -- Universal types have no range limits, so always in range
5969 if Typ = Universal_Integer or else Typ = Universal_Real then
5972 -- Never known if not scalar type. Don't know if this can actually
5973 -- happen, but our spec allows it, so we must check.
5975 elsif not Is_Scalar_Type (Typ) then
5978 -- Never known if this is a generic type, since the bounds of generic
5979 -- types are junk. Note that if we only checked for static expressions
5980 -- (instead of compile time known values) below, we would not need this
5981 -- check, because values of a generic type can never be static, but they
5982 -- can be known at compile time.
5984 elsif Is_Generic_Type (Typ) then
5987 -- Never known unless we have a compile time known value
5989 elsif not Compile_Time_Known_Value (N) then
5992 -- General processing with a known compile time value
6003 Lo := Type_Low_Bound (Typ);
6004 Hi := Type_High_Bound (Typ);
6006 LB_Known := Compile_Time_Known_Value (Lo);
6007 HB_Known := Compile_Time_Known_Value (Hi);
6009 -- Fixed point types should be considered as such only if flag
6010 -- Fixed_Int is set to False.
6012 if Is_Floating_Point_Type (Typ)
6013 or else (Is_Fixed_Point_Type (Typ) and then not Fixed_Int)
6016 Valr := Expr_Value_R (N);
6018 if LB_Known and HB_Known then
6019 if Valr >= Expr_Value_R (Lo)
6021 Valr <= Expr_Value_R (Hi)
6025 return Out_Of_Range;
6028 elsif (LB_Known and then Valr < Expr_Value_R (Lo))
6030 (HB_Known and then Valr > Expr_Value_R (Hi))
6032 return Out_Of_Range;
6039 Val := Expr_Value (N);
6041 if LB_Known and HB_Known then
6042 if Val >= Expr_Value (Lo) and then Val <= Expr_Value (Hi)
6046 return Out_Of_Range;
6049 elsif (LB_Known and then Val < Expr_Value (Lo))
6051 (HB_Known and then Val > Expr_Value (Hi))
6053 return Out_Of_Range;
6067 procedure To_Bits (U : Uint; B : out Bits) is
6069 for J in 0 .. B'Last loop
6070 B (J) := (U / (2 ** J)) mod 2 /= 0;
6074 --------------------
6075 -- Why_Not_Static --
6076 --------------------
6078 procedure Why_Not_Static (Expr : Node_Id) is
6079 N : constant Node_Id := Original_Node (Expr);
6085 procedure Why_Not_Static_List (L : List_Id);
6086 -- A version that can be called on a list of expressions. Finds all
6087 -- non-static violations in any element of the list.
6089 -------------------------
6090 -- Why_Not_Static_List --
6091 -------------------------
6093 procedure Why_Not_Static_List (L : List_Id) is
6096 if Is_Non_Empty_List (L) then
6098 while Present (N) loop
6103 end Why_Not_Static_List;
6105 -- Start of processing for Why_Not_Static
6108 -- Ignore call on error or empty node
6110 if No (Expr) or else Nkind (Expr) = N_Error then
6114 -- Preprocessing for sub expressions
6116 if Nkind (Expr) in N_Subexpr then
6118 -- Nothing to do if expression is static
6120 if Is_OK_Static_Expression (Expr) then
6124 -- Test for constraint error raised
6126 if Raises_Constraint_Error (Expr) then
6128 -- Special case membership to find out which piece to flag
6130 if Nkind (N) in N_Membership_Test then
6131 if Raises_Constraint_Error (Left_Opnd (N)) then
6132 Why_Not_Static (Left_Opnd (N));
6135 elsif Present (Right_Opnd (N))
6136 and then Raises_Constraint_Error (Right_Opnd (N))
6138 Why_Not_Static (Right_Opnd (N));
6142 pragma Assert (Present (Alternatives (N)));
6144 Alt := First (Alternatives (N));
6145 while Present (Alt) loop
6146 if Raises_Constraint_Error (Alt) then
6147 Why_Not_Static (Alt);
6155 -- Special case a range to find out which bound to flag
6157 elsif Nkind (N) = N_Range then
6158 if Raises_Constraint_Error (Low_Bound (N)) then
6159 Why_Not_Static (Low_Bound (N));
6162 elsif Raises_Constraint_Error (High_Bound (N)) then
6163 Why_Not_Static (High_Bound (N));
6167 -- Special case attribute to see which part to flag
6169 elsif Nkind (N) = N_Attribute_Reference then
6170 if Raises_Constraint_Error (Prefix (N)) then
6171 Why_Not_Static (Prefix (N));
6175 if Present (Expressions (N)) then
6176 Exp := First (Expressions (N));
6177 while Present (Exp) loop
6178 if Raises_Constraint_Error (Exp) then
6179 Why_Not_Static (Exp);
6187 -- Special case a subtype name
6189 elsif Is_Entity_Name (Expr) and then Is_Type (Entity (Expr)) then
6191 ("!& is not a static subtype (RM 4.9(26))", N, Entity (Expr));
6195 -- End of special cases
6198 ("!expression raises exception, cannot be static (RM 4.9(34))",
6203 -- If no type, then something is pretty wrong, so ignore
6205 Typ := Etype (Expr);
6211 -- Type must be scalar or string type (but allow Bignum, since this
6212 -- is really a scalar type from our point of view in this diagnosis).
6214 if not Is_Scalar_Type (Typ)
6215 and then not Is_String_Type (Typ)
6216 and then not Is_RTE (Typ, RE_Bignum)
6219 ("!static expression must have scalar or string type " &
6225 -- If we got through those checks, test particular node kind
6231 when N_Expanded_Name | N_Identifier | N_Operator_Symbol =>
6234 if Is_Named_Number (E) then
6237 elsif Ekind (E) = E_Constant then
6239 -- One case we can give a metter message is when we have a
6240 -- string literal created by concatenating an aggregate with
6241 -- an others expression.
6243 Entity_Case : declare
6244 CV : constant Node_Id := Constant_Value (E);
6245 CO : constant Node_Id := Original_Node (CV);
6247 function Is_Aggregate (N : Node_Id) return Boolean;
6248 -- See if node N came from an others aggregate, if so
6249 -- return True and set Error_Msg_Sloc to aggregate.
6255 function Is_Aggregate (N : Node_Id) return Boolean is
6257 if Nkind (Original_Node (N)) = N_Aggregate then
6258 Error_Msg_Sloc := Sloc (Original_Node (N));
6261 elsif Is_Entity_Name (N)
6262 and then Ekind (Entity (N)) = E_Constant
6264 Nkind (Original_Node (Constant_Value (Entity (N)))) =
6268 Sloc (Original_Node (Constant_Value (Entity (N))));
6276 -- Start of processing for Entity_Case
6279 if Is_Aggregate (CV)
6280 or else (Nkind (CO) = N_Op_Concat
6281 and then (Is_Aggregate (Left_Opnd (CO))
6283 Is_Aggregate (Right_Opnd (CO))))
6285 Error_Msg_N ("!aggregate (#) is never static", N);
6287 elsif No (CV) or else not Is_Static_Expression (CV) then
6289 ("!& is not a static constant (RM 4.9(5))", N, E);
6293 elsif Is_Type (E) then
6295 ("!& is not a static subtype (RM 4.9(26))", N, E);
6299 ("!& is not static constant or named number "
6300 & "(RM 4.9(5))", N, E);
6305 when N_Binary_Op | N_Short_Circuit | N_Membership_Test =>
6306 if Nkind (N) in N_Op_Shift then
6308 ("!shift functions are never static (RM 4.9(6,18))", N);
6310 Why_Not_Static (Left_Opnd (N));
6311 Why_Not_Static (Right_Opnd (N));
6317 Why_Not_Static (Right_Opnd (N));
6319 -- Attribute reference
6321 when N_Attribute_Reference =>
6322 Why_Not_Static_List (Expressions (N));
6324 E := Etype (Prefix (N));
6326 if E = Standard_Void_Type then
6330 -- Special case non-scalar'Size since this is a common error
6332 if Attribute_Name (N) = Name_Size then
6334 ("!size attribute is only static for static scalar type "
6335 & "(RM 4.9(7,8))", N);
6339 elsif Is_Array_Type (E) then
6340 if not Nam_In (Attribute_Name (N), Name_First,
6345 ("!static array attribute must be Length, First, or Last "
6346 & "(RM 4.9(8))", N);
6348 -- Since we know the expression is not-static (we already
6349 -- tested for this, must mean array is not static).
6353 ("!prefix is non-static array (RM 4.9(8))", Prefix (N));
6358 -- Special case generic types, since again this is a common source
6361 elsif Is_Generic_Actual_Type (E) or else Is_Generic_Type (E) then
6363 ("!attribute of generic type is never static "
6364 & "(RM 4.9(7,8))", N);
6366 elsif Is_OK_Static_Subtype (E) then
6369 elsif Is_Scalar_Type (E) then
6371 ("!prefix type for attribute is not static scalar subtype "
6372 & "(RM 4.9(7))", N);
6376 ("!static attribute must apply to array/scalar type "
6377 & "(RM 4.9(7,8))", N);
6382 when N_String_Literal =>
6384 ("!subtype of string literal is non-static (RM 4.9(4))", N);
6386 -- Explicit dereference
6388 when N_Explicit_Dereference =>
6390 ("!explicit dereference is never static (RM 4.9)", N);
6394 when N_Function_Call =>
6395 Why_Not_Static_List (Parameter_Associations (N));
6397 -- Complain about non-static function call unless we have Bignum
6398 -- which means that the underlying expression is really some
6399 -- scalar arithmetic operation.
6401 if not Is_RTE (Typ, RE_Bignum) then
6402 Error_Msg_N ("!non-static function call (RM 4.9(6,18))", N);
6405 -- Parameter assocation (test actual parameter)
6407 when N_Parameter_Association =>
6408 Why_Not_Static (Explicit_Actual_Parameter (N));
6410 -- Indexed component
6412 when N_Indexed_Component =>
6413 Error_Msg_N ("!indexed component is never static (RM 4.9)", N);
6417 when N_Procedure_Call_Statement =>
6418 Error_Msg_N ("!procedure call is never static (RM 4.9)", N);
6420 -- Qualified expression (test expression)
6422 when N_Qualified_Expression =>
6423 Why_Not_Static (Expression (N));
6427 when N_Aggregate | N_Extension_Aggregate =>
6428 Error_Msg_N ("!an aggregate is never static (RM 4.9)", N);
6433 Why_Not_Static (Low_Bound (N));
6434 Why_Not_Static (High_Bound (N));
6436 -- Range constraint, test range expression
6438 when N_Range_Constraint =>
6439 Why_Not_Static (Range_Expression (N));
6441 -- Subtype indication, test constraint
6443 when N_Subtype_Indication =>
6444 Why_Not_Static (Constraint (N));
6446 -- Selected component
6448 when N_Selected_Component =>
6449 Error_Msg_N ("!selected component is never static (RM 4.9)", N);
6454 Error_Msg_N ("!slice is never static (RM 4.9)", N);
6456 when N_Type_Conversion =>
6457 Why_Not_Static (Expression (N));
6459 if not Is_Scalar_Type (Entity (Subtype_Mark (N)))
6460 or else not Is_OK_Static_Subtype (Entity (Subtype_Mark (N)))
6463 ("!static conversion requires static scalar subtype result "
6464 & "(RM 4.9(9))", N);
6467 -- Unchecked type conversion
6469 when N_Unchecked_Type_Conversion =>
6471 ("!unchecked type conversion is never static (RM 4.9)", N);
6473 -- All other cases, no reason to give