1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 with Aspects
; use Aspects
;
27 with Atree
; use Atree
;
28 with Checks
; use Checks
;
29 with Debug
; use Debug
;
30 with Einfo
; use Einfo
;
31 with Elists
; use Elists
;
32 with Errout
; use Errout
;
33 with Eval_Fat
; use Eval_Fat
;
34 with Exp_Util
; use Exp_Util
;
35 with Freeze
; use Freeze
;
37 with Namet
; use Namet
;
38 with Nmake
; use Nmake
;
39 with Nlists
; use Nlists
;
41 with Par_SCO
; use Par_SCO
;
42 with Rtsfind
; use Rtsfind
;
44 with Sem_Aux
; use Sem_Aux
;
45 with Sem_Cat
; use Sem_Cat
;
46 with Sem_Ch6
; use Sem_Ch6
;
47 with Sem_Ch8
; use Sem_Ch8
;
48 with Sem_Res
; use Sem_Res
;
49 with Sem_Util
; use Sem_Util
;
50 with Sem_Type
; use Sem_Type
;
51 with Sem_Warn
; use Sem_Warn
;
52 with Sinfo
; use Sinfo
;
53 with Snames
; use Snames
;
54 with Stand
; use Stand
;
55 with Stringt
; use Stringt
;
56 with Tbuild
; use Tbuild
;
58 package body Sem_Eval
is
60 -----------------------------------------
61 -- Handling of Compile Time Evaluation --
62 -----------------------------------------
64 -- The compile time evaluation of expressions is distributed over several
65 -- Eval_xxx procedures. These procedures are called immediately after
66 -- a subexpression is resolved and is therefore accomplished in a bottom
67 -- up fashion. The flags are synthesized using the following approach.
69 -- Is_Static_Expression is determined by following the rules in
70 -- RM-4.9. This involves testing the Is_Static_Expression flag of
71 -- the operands in many cases.
73 -- Raises_Constraint_Error is usually set if any of the operands have
74 -- the flag set or if an attempt to compute the value of the current
75 -- expression results in Constraint_Error.
77 -- The general approach is as follows. First compute Is_Static_Expression.
78 -- If the node is not static, then the flag is left off in the node and
79 -- we are all done. Otherwise for a static node, we test if any of the
80 -- operands will raise Constraint_Error, and if so, propagate the flag
81 -- Raises_Constraint_Error to the result node and we are done (since the
82 -- error was already posted at a lower level).
84 -- For the case of a static node whose operands do not raise constraint
85 -- error, we attempt to evaluate the node. If this evaluation succeeds,
86 -- then the node is replaced by the result of this computation. If the
87 -- evaluation raises Constraint_Error, then we rewrite the node with
88 -- Apply_Compile_Time_Constraint_Error to raise the exception and also
89 -- to post appropriate error messages.
95 type Bits
is array (Nat
range <>) of Boolean;
96 -- Used to convert unsigned (modular) values for folding logical ops
98 -- The following declarations are used to maintain a cache of nodes that
99 -- have compile-time-known values. The cache is maintained only for
100 -- discrete types (the most common case), and is populated by calls to
101 -- Compile_Time_Known_Value and Expr_Value, but only used by Expr_Value
102 -- since it is possible for the status to change (in particular it is
103 -- possible for a node to get replaced by a Constraint_Error node).
105 CV_Bits
: constant := 5;
106 -- Number of low order bits of Node_Id value used to reference entries
107 -- in the cache table.
109 CV_Cache_Size
: constant Nat
:= 2 ** CV_Bits
;
110 -- Size of cache for compile time values
112 subtype CV_Range
is Nat
range 0 .. CV_Cache_Size
;
114 type CV_Entry
is record
119 type Match_Result
is (Match
, No_Match
, Non_Static
);
120 -- Result returned from functions that test for a matching result. If the
121 -- operands are not OK_Static then Non_Static will be returned. Otherwise
122 -- Match/No_Match is returned depending on whether the match succeeds.
124 type CV_Cache_Array
is array (CV_Range
) of CV_Entry
;
126 CV_Cache
: CV_Cache_Array
:= (others => (Node_High_Bound
, Uint_0
));
127 -- This is the actual cache, with entries consisting of node/value pairs,
128 -- and the impossible value Node_High_Bound used for unset entries.
130 type Range_Membership
is (In_Range
, Out_Of_Range
, Unknown
);
131 -- Range membership may either be statically known to be in range or out
132 -- of range, or not statically known. Used for Test_In_Range below.
134 -----------------------
135 -- Local Subprograms --
136 -----------------------
138 function Choice_Matches
140 Choice
: Node_Id
) return Match_Result
;
141 -- Determines whether given value Expr matches the given Choice. The Expr
142 -- can be of discrete, real, or string type and must be a compile time
143 -- known value (it is an error to make the call if these conditions are
144 -- not met). The choice can be a range, subtype name, subtype indication,
145 -- or expression. The returned result is Non_Static if Choice is not
146 -- OK_Static, otherwise either Match or No_Match is returned depending
147 -- on whether Choice matches Expr. This is used for case expression
148 -- alternatives, and also for membership tests. In each case, more
149 -- possibilities are tested than the syntax allows (e.g. membership allows
150 -- subtype indications and non-discrete types, and case allows an OTHERS
151 -- choice), but it does not matter, since we have already done a full
152 -- semantic and syntax check of the construct, so the extra possibilities
153 -- just will not arise for correct expressions.
155 -- Note: if Choice_Matches finds that a choice raises Constraint_Error, e.g
156 -- a reference to a type, one of whose bounds raises Constraint_Error, then
157 -- it also sets the Raises_Constraint_Error flag on the Choice itself.
159 function Choices_Match
161 Choices
: List_Id
) return Match_Result
;
162 -- This function applies Choice_Matches to each element of Choices. If the
163 -- result is No_Match, then it continues and checks the next element. If
164 -- the result is Match or Non_Static, this result is immediately given
165 -- as the result without checking the rest of the list. Expr can be of
166 -- discrete, real, or string type and must be a compile-time-known value
167 -- (it is an error to make the call if these conditions are not met).
169 function Find_Universal_Operator_Type
(N
: Node_Id
) return Entity_Id
;
170 -- Check whether an arithmetic operation with universal operands which is a
171 -- rewritten function call with an explicit scope indication is ambiguous:
172 -- P."+" (1, 2) will be ambiguous if there is more than one visible numeric
173 -- type declared in P and the context does not impose a type on the result
174 -- (e.g. in the expression of a type conversion). If ambiguous, emit an
175 -- error and return Empty, else return the result type of the operator.
177 function From_Bits
(B
: Bits
; T
: Entity_Id
) return Uint
;
178 -- Converts a bit string of length B'Length to a Uint value to be used for
179 -- a target of type T, which is a modular type. This procedure includes the
180 -- necessary reduction by the modulus in the case of a nonbinary modulus
181 -- (for a binary modulus, the bit string is the right length any way so all
184 function Get_String_Val
(N
: Node_Id
) return Node_Id
;
185 -- Given a tree node for a folded string or character value, returns the
186 -- corresponding string literal or character literal (one of the two must
187 -- be available, or the operand would not have been marked as foldable in
188 -- the earlier analysis of the operation).
190 function Is_OK_Static_Choice
(Choice
: Node_Id
) return Boolean;
191 -- Given a choice (from a case expression or membership test), returns
192 -- True if the choice is static and does not raise a Constraint_Error.
194 function Is_OK_Static_Choice_List
(Choices
: List_Id
) return Boolean;
195 -- Given a choice list (from a case expression or membership test), return
196 -- True if all choices are static in the sense of Is_OK_Static_Choice.
198 function Is_Static_Choice
(Choice
: Node_Id
) return Boolean;
199 -- Given a choice (from a case expression or membership test), returns
200 -- True if the choice is static. No test is made for raising of constraint
201 -- error, so this function is used only for legality tests.
203 function Is_Static_Choice_List
(Choices
: List_Id
) return Boolean;
204 -- Given a choice list (from a case expression or membership test), return
205 -- True if all choices are static in the sense of Is_Static_Choice.
207 function Is_Static_Range
(N
: Node_Id
) return Boolean;
208 -- Determine if range is static, as defined in RM 4.9(26). The only allowed
209 -- argument is an N_Range node (but note that the semantic analysis of
210 -- equivalent range attribute references already turned them into the
211 -- equivalent range). This differs from Is_OK_Static_Range (which is what
212 -- must be used by clients) in that it does not care whether the bounds
213 -- raise Constraint_Error or not. Used for checking whether expressions are
214 -- static in the 4.9 sense (without worrying about exceptions).
216 function OK_Bits
(N
: Node_Id
; Bits
: Uint
) return Boolean;
217 -- Bits represents the number of bits in an integer value to be computed
218 -- (but the value has not been computed yet). If this value in Bits is
219 -- reasonable, a result of True is returned, with the implication that the
220 -- caller should go ahead and complete the calculation. If the value in
221 -- Bits is unreasonably large, then an error is posted on node N, and
222 -- False is returned (and the caller skips the proposed calculation).
224 procedure Out_Of_Range
(N
: Node_Id
);
225 -- This procedure is called if it is determined that node N, which appears
226 -- in a non-static context, is a compile-time-known value which is outside
227 -- its range, i.e. the range of Etype. This is used in contexts where
228 -- this is an illegality if N is static, and should generate a warning
231 function Real_Or_String_Static_Predicate_Matches
233 Typ
: Entity_Id
) return Boolean;
234 -- This is the function used to evaluate real or string static predicates.
235 -- Val is an unanalyzed N_Real_Literal or N_String_Literal node, which
236 -- represents the value to be tested against the predicate. Typ is the
237 -- type with the predicate, from which the predicate expression can be
238 -- extracted. The result returned is True if the given value satisfies
241 procedure Rewrite_In_Raise_CE
(N
: Node_Id
; Exp
: Node_Id
);
242 -- N and Exp are nodes representing an expression, Exp is known to raise
243 -- CE. N is rewritten in term of Exp in the optimal way.
245 function String_Type_Len
(Stype
: Entity_Id
) return Uint
;
246 -- Given a string type, determines the length of the index type, or, if
247 -- this index type is non-static, the length of the base type of this index
248 -- type. Note that if the string type is itself static, then the index type
249 -- is static, so the second case applies only if the string type passed is
252 function Test
(Cond
: Boolean) return Uint
;
253 pragma Inline
(Test
);
254 -- This function simply returns the appropriate Boolean'Pos value
255 -- corresponding to the value of Cond as a universal integer. It is
256 -- used for producing the result of the static evaluation of the
259 procedure Test_Expression_Is_Foldable
264 -- Tests to see if expression N whose single operand is Op1 is foldable,
265 -- i.e. the operand value is known at compile time. If the operation is
266 -- foldable, then Fold is True on return, and Stat indicates whether the
267 -- result is static (i.e. the operand was static). Note that it is quite
268 -- possible for Fold to be True, and Stat to be False, since there are
269 -- cases in which we know the value of an operand even though it is not
270 -- technically static (e.g. the static lower bound of a range whose upper
271 -- bound is non-static).
273 -- If Stat is set False on return, then Test_Expression_Is_Foldable makes
274 -- a call to Check_Non_Static_Context on the operand. If Fold is False on
275 -- return, then all processing is complete, and the caller should return,
276 -- since there is nothing else to do.
278 -- If Stat is set True on return, then Is_Static_Expression is also set
279 -- true in node N. There are some cases where this is over-enthusiastic,
280 -- e.g. in the two operand case below, for string comparison, the result is
281 -- not static even though the two operands are static. In such cases, the
282 -- caller must reset the Is_Static_Expression flag in N.
284 -- If Fold and Stat are both set to False then this routine performs also
285 -- the following extra actions:
287 -- If either operand is Any_Type then propagate it to result to prevent
290 -- If some operand raises Constraint_Error, then replace the node N
291 -- with the raise Constraint_Error node. This replacement inherits the
292 -- Is_Static_Expression flag from the operands.
294 procedure Test_Expression_Is_Foldable
300 CRT_Safe
: Boolean := False);
301 -- Same processing, except applies to an expression N with two operands
302 -- Op1 and Op2. The result is static only if both operands are static. If
303 -- CRT_Safe is set True, then CRT_Safe_Compile_Time_Known_Value is used
304 -- for the tests that the two operands are known at compile time. See
305 -- spec of this routine for further details.
307 function Test_In_Range
310 Assume_Valid
: Boolean;
312 Int_Real
: Boolean) return Range_Membership
;
313 -- Common processing for Is_In_Range and Is_Out_Of_Range: Returns In_Range
314 -- or Out_Of_Range if it can be guaranteed at compile time that expression
315 -- N is known to be in or out of range of the subtype Typ. If not compile
316 -- time known, Unknown is returned. See documentation of Is_In_Range for
317 -- complete description of parameters.
319 procedure To_Bits
(U
: Uint
; B
: out Bits
);
320 -- Converts a Uint value to a bit string of length B'Length
322 -----------------------------------------------
323 -- Check_Expression_Against_Static_Predicate --
324 -----------------------------------------------
326 procedure Check_Expression_Against_Static_Predicate
331 -- Nothing to do if expression is not known at compile time, or the
332 -- type has no static predicate set (will be the case for all non-scalar
333 -- types, so no need to make a special test for that).
335 if not (Has_Static_Predicate
(Typ
)
336 and then Compile_Time_Known_Value
(Expr
))
341 -- Here we have a static predicate (note that it could have arisen from
342 -- an explicitly specified Dynamic_Predicate whose expression met the
343 -- rules for being predicate-static). If the expression is known at
344 -- compile time and obeys the predicate, then it is static and must be
345 -- labeled as such, which matters e.g. for case statements. The original
346 -- expression may be a type conversion of a variable with a known value,
347 -- which might otherwise not be marked static.
349 -- Case of real static predicate
351 if Is_Real_Type
(Typ
) then
352 if Real_Or_String_Static_Predicate_Matches
353 (Val
=> Make_Real_Literal
(Sloc
(Expr
), Expr_Value_R
(Expr
)),
356 Set_Is_Static_Expression
(Expr
);
360 -- Case of string static predicate
362 elsif Is_String_Type
(Typ
) then
363 if Real_Or_String_Static_Predicate_Matches
364 (Val
=> Expr_Value_S
(Expr
), Typ
=> Typ
)
366 Set_Is_Static_Expression
(Expr
);
370 -- Case of discrete static predicate
373 pragma Assert
(Is_Discrete_Type
(Typ
));
375 -- If static predicate matches, nothing to do
377 if Choices_Match
(Expr
, Static_Discrete_Predicate
(Typ
)) = Match
then
378 Set_Is_Static_Expression
(Expr
);
383 -- Here we know that the predicate will fail
385 -- Special case of static expression failing a predicate (other than one
386 -- that was explicitly specified with a Dynamic_Predicate aspect). This
387 -- is the case where the expression is no longer considered static.
389 if Is_Static_Expression
(Expr
)
390 and then not Has_Dynamic_Predicate_Aspect
(Typ
)
393 ("??static expression fails static predicate check on &",
396 ("\??expression is no longer considered static", Expr
);
397 Set_Is_Static_Expression
(Expr
, False);
399 -- In all other cases, this is just a warning that a test will fail.
400 -- It does not matter if the expression is static or not, or if the
401 -- predicate comes from a dynamic predicate aspect or not.
405 ("??expression fails predicate check on &", Expr
, Typ
);
407 end Check_Expression_Against_Static_Predicate
;
409 ------------------------------
410 -- Check_Non_Static_Context --
411 ------------------------------
413 procedure Check_Non_Static_Context
(N
: Node_Id
) is
414 T
: constant Entity_Id
:= Etype
(N
);
415 Checks_On
: constant Boolean :=
416 not Index_Checks_Suppressed
(T
)
417 and not Range_Checks_Suppressed
(T
);
420 -- Ignore cases of non-scalar types, error types, or universal real
421 -- types that have no usable bounds.
424 or else not Is_Scalar_Type
(T
)
425 or else T
= Universal_Fixed
426 or else T
= Universal_Real
431 -- At this stage we have a scalar type. If we have an expression that
432 -- raises CE, then we already issued a warning or error msg so there is
433 -- nothing more to be done in this routine.
435 if Raises_Constraint_Error
(N
) then
439 -- Now we have a scalar type which is not marked as raising a constraint
440 -- error exception. The main purpose of this routine is to deal with
441 -- static expressions appearing in a non-static context. That means
442 -- that if we do not have a static expression then there is not much
443 -- to do. The one case that we deal with here is that if we have a
444 -- floating-point value that is out of range, then we post a warning
445 -- that an infinity will result.
447 if not Is_Static_Expression
(N
) then
448 if Is_Floating_Point_Type
(T
) then
449 if Is_Out_Of_Range
(N
, Base_Type
(T
), Assume_Valid
=> True) then
451 ("??float value out of range, infinity will be generated", N
);
453 -- The literal may be the result of constant-folding of a non-
454 -- static subexpression of a larger expression (e.g. a conversion
455 -- of a non-static variable whose value happens to be known). At
456 -- this point we must reduce the value of the subexpression to a
457 -- machine number (RM 4.9 (38/2)).
459 elsif Nkind
(N
) = N_Real_Literal
460 and then Nkind
(Parent
(N
)) in N_Subexpr
462 Rewrite
(N
, New_Copy
(N
));
464 (N
, Machine
(Base_Type
(T
), Realval
(N
), Round_Even
, N
));
471 -- Here we have the case of outer level static expression of scalar
472 -- type, where the processing of this procedure is needed.
474 -- For real types, this is where we convert the value to a machine
475 -- number (see RM 4.9(38)). Also see ACVC test C490001. We should only
476 -- need to do this if the parent is a constant declaration, since in
477 -- other cases, gigi should do the necessary conversion correctly, but
478 -- experimentation shows that this is not the case on all machines, in
479 -- particular if we do not convert all literals to machine values in
480 -- non-static contexts, then ACVC test C490001 fails on Sparc/Solaris
483 -- This conversion is always done by GNATprove on real literals in
484 -- non-static expressions, by calling Check_Non_Static_Context from
485 -- gnat2why, as GNATprove cannot do the conversion later contrary
486 -- to gigi. The frontend computes the information about which
487 -- expressions are static, which is used by gnat2why to call
488 -- Check_Non_Static_Context on exactly those real literals that are
489 -- not subexpressions of static expressions.
491 if Nkind
(N
) = N_Real_Literal
492 and then not Is_Machine_Number
(N
)
493 and then not Is_Generic_Type
(Etype
(N
))
494 and then Etype
(N
) /= Universal_Real
496 -- Check that value is in bounds before converting to machine
497 -- number, so as not to lose case where value overflows in the
498 -- least significant bit or less. See B490001.
500 if Is_Out_Of_Range
(N
, Base_Type
(T
), Assume_Valid
=> True) then
505 -- Note: we have to copy the node, to avoid problems with conformance
506 -- of very similar numbers (see ACVC tests B4A010C and B63103A).
508 Rewrite
(N
, New_Copy
(N
));
510 if not Is_Floating_Point_Type
(T
) then
512 (N
, Corresponding_Integer_Value
(N
) * Small_Value
(T
));
514 elsif not UR_Is_Zero
(Realval
(N
)) then
516 -- Note: even though RM 4.9(38) specifies biased rounding, this
517 -- has been modified by AI-100 in order to prevent confusing
518 -- differences in rounding between static and non-static
519 -- expressions. AI-100 specifies that the effect of such rounding
520 -- is implementation dependent, and in GNAT we round to nearest
521 -- even to match the run-time behavior. Note that this applies
522 -- to floating point literals, not fixed points ones, even though
523 -- their compiler representation is also as a universal real.
526 (N
, Machine
(Base_Type
(T
), Realval
(N
), Round_Even
, N
));
527 Set_Is_Machine_Number
(N
);
532 -- Check for out of range universal integer. This is a non-static
533 -- context, so the integer value must be in range of the runtime
534 -- representation of universal integers.
536 -- We do this only within an expression, because that is the only
537 -- case in which non-static universal integer values can occur, and
538 -- furthermore, Check_Non_Static_Context is currently (incorrectly???)
539 -- called in contexts like the expression of a number declaration where
540 -- we certainly want to allow out of range values.
542 -- We inhibit the warning when expansion is disabled, because the
543 -- preanalysis of a range of a 64-bit modular type may appear to
544 -- violate the constraint on non-static Universal_Integer. If there
545 -- is a true overflow it will be diagnosed during full analysis.
547 if Etype
(N
) = Universal_Integer
548 and then Nkind
(N
) = N_Integer_Literal
549 and then Nkind
(Parent
(N
)) in N_Subexpr
550 and then Expander_Active
552 (Intval
(N
) < Expr_Value
(Type_Low_Bound
(Universal_Integer
))
554 Intval
(N
) > Expr_Value
(Type_High_Bound
(Universal_Integer
)))
556 Apply_Compile_Time_Constraint_Error
557 (N
, "non-static universal integer value out of range<<",
558 CE_Range_Check_Failed
);
560 -- Check out of range of base type
562 elsif Is_Out_Of_Range
(N
, Base_Type
(T
), Assume_Valid
=> True) then
565 -- Give a warning or error on the value outside the subtype. A warning
566 -- is omitted if the expression appears in a range that could be null
567 -- (warnings are handled elsewhere for this case).
569 elsif T
/= Base_Type
(T
) and then Nkind
(Parent
(N
)) /= N_Range
then
570 if Is_In_Range
(N
, T
, Assume_Valid
=> True) then
573 elsif Is_Out_Of_Range
(N
, T
, Assume_Valid
=> True) then
574 -- Ignore out of range values for System.Priority in CodePeer
575 -- mode since the actual target compiler may provide a wider
578 if CodePeer_Mode
and then T
= RTE
(RE_Priority
) then
579 Set_Do_Range_Check
(N
, False);
581 -- Determine if the out-of-range violation constitutes a warning
582 -- or an error based on context, according to RM 4.9 (34/3).
584 elsif Nkind_In
(Original_Node
(N
), N_Type_Conversion
,
585 N_Qualified_Expression
)
586 and then Comes_From_Source
(Original_Node
(N
))
588 Apply_Compile_Time_Constraint_Error
589 (N
, "value not in range of}", CE_Range_Check_Failed
);
591 Apply_Compile_Time_Constraint_Error
592 (N
, "value not in range of}<<", CE_Range_Check_Failed
);
596 Enable_Range_Check
(N
);
599 Set_Do_Range_Check
(N
, False);
602 end Check_Non_Static_Context
;
604 ---------------------------------
605 -- Check_String_Literal_Length --
606 ---------------------------------
608 procedure Check_String_Literal_Length
(N
: Node_Id
; Ttype
: Entity_Id
) is
610 if not Raises_Constraint_Error
(N
) and then Is_Constrained
(Ttype
) then
611 if UI_From_Int
(String_Length
(Strval
(N
))) /= String_Type_Len
(Ttype
)
613 Apply_Compile_Time_Constraint_Error
614 (N
, "string length wrong for}??",
615 CE_Length_Check_Failed
,
620 end Check_String_Literal_Length
;
626 function Choice_Matches
628 Choice
: Node_Id
) return Match_Result
630 Etyp
: constant Entity_Id
:= Etype
(Expr
);
636 pragma Assert
(Compile_Time_Known_Value
(Expr
));
637 pragma Assert
(Is_Scalar_Type
(Etyp
) or else Is_String_Type
(Etyp
));
639 if not Is_OK_Static_Choice
(Choice
) then
640 Set_Raises_Constraint_Error
(Choice
);
643 -- When the choice denotes a subtype with a static predictate, check the
644 -- expression against the predicate values. Different procedures apply
645 -- to discrete and non-discrete types.
647 elsif (Nkind
(Choice
) = N_Subtype_Indication
648 or else (Is_Entity_Name
(Choice
)
649 and then Is_Type
(Entity
(Choice
))))
650 and then Has_Predicates
(Etype
(Choice
))
651 and then Has_Static_Predicate
(Etype
(Choice
))
653 if Is_Discrete_Type
(Etype
(Choice
)) then
656 (Expr
, Static_Discrete_Predicate
(Etype
(Choice
)));
658 elsif Real_Or_String_Static_Predicate_Matches
(Expr
, Etype
(Choice
))
666 -- Discrete type case only
668 elsif Is_Discrete_Type
(Etyp
) then
669 Val
:= Expr_Value
(Expr
);
671 if Nkind
(Choice
) = N_Range
then
672 if Val
>= Expr_Value
(Low_Bound
(Choice
))
674 Val
<= Expr_Value
(High_Bound
(Choice
))
681 elsif Nkind
(Choice
) = N_Subtype_Indication
682 or else (Is_Entity_Name
(Choice
) and then Is_Type
(Entity
(Choice
)))
684 if Val
>= Expr_Value
(Type_Low_Bound
(Etype
(Choice
)))
686 Val
<= Expr_Value
(Type_High_Bound
(Etype
(Choice
)))
693 elsif Nkind
(Choice
) = N_Others_Choice
then
697 if Val
= Expr_Value
(Choice
) then
706 elsif Is_Real_Type
(Etyp
) then
707 ValR
:= Expr_Value_R
(Expr
);
709 if Nkind
(Choice
) = N_Range
then
710 if ValR
>= Expr_Value_R
(Low_Bound
(Choice
))
712 ValR
<= Expr_Value_R
(High_Bound
(Choice
))
719 elsif Nkind
(Choice
) = N_Subtype_Indication
720 or else (Is_Entity_Name
(Choice
) and then Is_Type
(Entity
(Choice
)))
722 if ValR
>= Expr_Value_R
(Type_Low_Bound
(Etype
(Choice
)))
724 ValR
<= Expr_Value_R
(Type_High_Bound
(Etype
(Choice
)))
732 if ValR
= Expr_Value_R
(Choice
) then
742 pragma Assert
(Is_String_Type
(Etyp
));
743 ValS
:= Expr_Value_S
(Expr
);
745 if Nkind
(Choice
) = N_Subtype_Indication
746 or else (Is_Entity_Name
(Choice
) and then Is_Type
(Entity
(Choice
)))
748 if not Is_Constrained
(Etype
(Choice
)) then
753 Typlen
: constant Uint
:=
754 String_Type_Len
(Etype
(Choice
));
755 Strlen
: constant Uint
:=
756 UI_From_Int
(String_Length
(Strval
(ValS
)));
758 if Typlen
= Strlen
then
767 if String_Equal
(Strval
(ValS
), Strval
(Expr_Value_S
(Choice
)))
781 function Choices_Match
783 Choices
: List_Id
) return Match_Result
786 Result
: Match_Result
;
789 Choice
:= First
(Choices
);
790 while Present
(Choice
) loop
791 Result
:= Choice_Matches
(Expr
, Choice
);
793 if Result
/= No_Match
then
803 --------------------------
804 -- Compile_Time_Compare --
805 --------------------------
807 function Compile_Time_Compare
809 Assume_Valid
: Boolean) return Compare_Result
811 Discard
: aliased Uint
;
813 return Compile_Time_Compare
(L
, R
, Discard
'Access, Assume_Valid
);
814 end Compile_Time_Compare
;
816 function Compile_Time_Compare
819 Assume_Valid
: Boolean;
820 Rec
: Boolean := False) return Compare_Result
822 Ltyp
: Entity_Id
:= Etype
(L
);
823 Rtyp
: Entity_Id
:= Etype
(R
);
825 Discard
: aliased Uint
;
827 procedure Compare_Decompose
831 -- This procedure decomposes the node N into an expression node and a
832 -- signed offset, so that the value of N is equal to the value of R plus
833 -- the value V (which may be negative). If no such decomposition is
834 -- possible, then on return R is a copy of N, and V is set to zero.
836 function Compare_Fixup
(N
: Node_Id
) return Node_Id
;
837 -- This function deals with replacing 'Last and 'First references with
838 -- their corresponding type bounds, which we then can compare. The
839 -- argument is the original node, the result is the identity, unless we
840 -- have a 'Last/'First reference in which case the value returned is the
841 -- appropriate type bound.
843 function Is_Known_Valid_Operand
(Opnd
: Node_Id
) return Boolean;
844 -- Even if the context does not assume that values are valid, some
845 -- simple cases can be recognized.
847 function Is_Same_Value
(L
, R
: Node_Id
) return Boolean;
848 -- Returns True iff L and R represent expressions that definitely have
849 -- identical (but not necessarily compile-time-known) values Indeed the
850 -- caller is expected to have already dealt with the cases of compile
851 -- time known values, so these are not tested here.
853 -----------------------
854 -- Compare_Decompose --
855 -----------------------
857 procedure Compare_Decompose
863 if Nkind
(N
) = N_Op_Add
864 and then Nkind
(Right_Opnd
(N
)) = N_Integer_Literal
867 V
:= Intval
(Right_Opnd
(N
));
870 elsif Nkind
(N
) = N_Op_Subtract
871 and then Nkind
(Right_Opnd
(N
)) = N_Integer_Literal
874 V
:= UI_Negate
(Intval
(Right_Opnd
(N
)));
877 elsif Nkind
(N
) = N_Attribute_Reference
then
878 if Attribute_Name
(N
) = Name_Succ
then
879 R
:= First
(Expressions
(N
));
883 elsif Attribute_Name
(N
) = Name_Pred
then
884 R
:= First
(Expressions
(N
));
892 end Compare_Decompose
;
898 function Compare_Fixup
(N
: Node_Id
) return Node_Id
is
904 -- Fixup only required for First/Last attribute reference
906 if Nkind
(N
) = N_Attribute_Reference
907 and then Nam_In
(Attribute_Name
(N
), Name_First
, Name_Last
)
909 Xtyp
:= Etype
(Prefix
(N
));
911 -- If we have no type, then just abandon the attempt to do
912 -- a fixup, this is probably the result of some other error.
918 -- Dereference an access type
920 if Is_Access_Type
(Xtyp
) then
921 Xtyp
:= Designated_Type
(Xtyp
);
924 -- If we don't have an array type at this stage, something is
925 -- peculiar, e.g. another error, and we abandon the attempt at
928 if not Is_Array_Type
(Xtyp
) then
932 -- Ignore unconstrained array, since bounds are not meaningful
934 if not Is_Constrained
(Xtyp
) then
938 if Ekind
(Xtyp
) = E_String_Literal_Subtype
then
939 if Attribute_Name
(N
) = Name_First
then
940 return String_Literal_Low_Bound
(Xtyp
);
943 Make_Integer_Literal
(Sloc
(N
),
944 Intval
=> Intval
(String_Literal_Low_Bound
(Xtyp
)) +
945 String_Literal_Length
(Xtyp
));
949 -- Find correct index type
951 Indx
:= First_Index
(Xtyp
);
953 if Present
(Expressions
(N
)) then
954 Subs
:= UI_To_Int
(Expr_Value
(First
(Expressions
(N
))));
956 for J
in 2 .. Subs
loop
957 Indx
:= Next_Index
(Indx
);
961 Xtyp
:= Etype
(Indx
);
963 if Attribute_Name
(N
) = Name_First
then
964 return Type_Low_Bound
(Xtyp
);
966 return Type_High_Bound
(Xtyp
);
973 ----------------------------
974 -- Is_Known_Valid_Operand --
975 ----------------------------
977 function Is_Known_Valid_Operand
(Opnd
: Node_Id
) return Boolean is
979 return (Is_Entity_Name
(Opnd
)
981 (Is_Known_Valid
(Entity
(Opnd
))
982 or else Ekind
(Entity
(Opnd
)) = E_In_Parameter
984 (Ekind
(Entity
(Opnd
)) in Object_Kind
985 and then Present
(Current_Value
(Entity
(Opnd
))))))
986 or else Is_OK_Static_Expression
(Opnd
);
987 end Is_Known_Valid_Operand
;
993 function Is_Same_Value
(L
, R
: Node_Id
) return Boolean is
994 Lf
: constant Node_Id
:= Compare_Fixup
(L
);
995 Rf
: constant Node_Id
:= Compare_Fixup
(R
);
997 function Is_Rewritten_Loop_Entry
(N
: Node_Id
) return Boolean;
998 -- An attribute reference to Loop_Entry may have been rewritten into
999 -- its prefix as a way to avoid generating a constant for that
1000 -- attribute when the corresponding pragma is ignored. These nodes
1001 -- should be ignored when deciding if they can be equal to one
1004 function Is_Same_Subscript
(L
, R
: List_Id
) return Boolean;
1005 -- L, R are the Expressions values from two attribute nodes for First
1006 -- or Last attributes. Either may be set to No_List if no expressions
1007 -- are present (indicating subscript 1). The result is True if both
1008 -- expressions represent the same subscript (note one case is where
1009 -- one subscript is missing and the other is explicitly set to 1).
1011 -----------------------------
1012 -- Is_Rewritten_Loop_Entry --
1013 -----------------------------
1015 function Is_Rewritten_Loop_Entry
(N
: Node_Id
) return Boolean is
1016 Orig_N
: constant Node_Id
:= Original_Node
(N
);
1019 and then Nkind
(Orig_N
) = N_Attribute_Reference
1020 and then Get_Attribute_Id
(Attribute_Name
(Orig_N
)) =
1021 Attribute_Loop_Entry
;
1022 end Is_Rewritten_Loop_Entry
;
1024 -----------------------
1025 -- Is_Same_Subscript --
1026 -----------------------
1028 function Is_Same_Subscript
(L
, R
: List_Id
) return Boolean is
1034 return Expr_Value
(First
(R
)) = Uint_1
;
1039 return Expr_Value
(First
(L
)) = Uint_1
;
1041 return Expr_Value
(First
(L
)) = Expr_Value
(First
(R
));
1044 end Is_Same_Subscript
;
1046 -- Start of processing for Is_Same_Value
1049 -- Loop_Entry nodes rewritten into their prefix inside ignored
1050 -- pragmas should never lead to a decision of equality.
1052 if Is_Rewritten_Loop_Entry
(Lf
)
1053 or else Is_Rewritten_Loop_Entry
(Rf
)
1057 -- Values are the same if they refer to the same entity and the
1058 -- entity is nonvolatile.
1060 elsif Nkind_In
(Lf
, N_Identifier
, N_Expanded_Name
)
1061 and then Nkind_In
(Rf
, N_Identifier
, N_Expanded_Name
)
1062 and then Entity
(Lf
) = Entity
(Rf
)
1064 -- If the entity is a discriminant, the two expressions may be
1065 -- bounds of components of objects of the same discriminated type.
1066 -- The values of the discriminants are not static, and therefore
1067 -- the result is unknown.
1069 and then Ekind
(Entity
(Lf
)) /= E_Discriminant
1070 and then Present
(Entity
(Lf
))
1072 -- This does not however apply to Float types, since we may have
1073 -- two NaN values and they should never compare equal.
1075 and then not Is_Floating_Point_Type
(Etype
(L
))
1076 and then not Is_Volatile_Reference
(L
)
1077 and then not Is_Volatile_Reference
(R
)
1081 -- Or if they are compile-time-known and identical
1083 elsif Compile_Time_Known_Value
(Lf
)
1085 Compile_Time_Known_Value
(Rf
)
1086 and then Expr_Value
(Lf
) = Expr_Value
(Rf
)
1090 -- False if Nkind of the two nodes is different for remaining cases
1092 elsif Nkind
(Lf
) /= Nkind
(Rf
) then
1095 -- True if both 'First or 'Last values applying to the same entity
1096 -- (first and last don't change even if value does). Note that we
1097 -- need this even with the calls to Compare_Fixup, to handle the
1098 -- case of unconstrained array attributes where Compare_Fixup
1099 -- cannot find useful bounds.
1101 elsif Nkind
(Lf
) = N_Attribute_Reference
1102 and then Attribute_Name
(Lf
) = Attribute_Name
(Rf
)
1103 and then Nam_In
(Attribute_Name
(Lf
), Name_First
, Name_Last
)
1104 and then Nkind_In
(Prefix
(Lf
), N_Identifier
, N_Expanded_Name
)
1105 and then Nkind_In
(Prefix
(Rf
), N_Identifier
, N_Expanded_Name
)
1106 and then Entity
(Prefix
(Lf
)) = Entity
(Prefix
(Rf
))
1107 and then Is_Same_Subscript
(Expressions
(Lf
), Expressions
(Rf
))
1111 -- True if the same selected component from the same record
1113 elsif Nkind
(Lf
) = N_Selected_Component
1114 and then Selector_Name
(Lf
) = Selector_Name
(Rf
)
1115 and then Is_Same_Value
(Prefix
(Lf
), Prefix
(Rf
))
1119 -- True if the same unary operator applied to the same operand
1121 elsif Nkind
(Lf
) in N_Unary_Op
1122 and then Is_Same_Value
(Right_Opnd
(Lf
), Right_Opnd
(Rf
))
1126 -- True if the same binary operator applied to the same operands
1128 elsif Nkind
(Lf
) in N_Binary_Op
1129 and then Is_Same_Value
(Left_Opnd
(Lf
), Left_Opnd
(Rf
))
1130 and then Is_Same_Value
(Right_Opnd
(Lf
), Right_Opnd
(Rf
))
1134 -- All other cases, we can't tell, so return False
1141 -- Start of processing for Compile_Time_Compare
1144 Diff
.all := No_Uint
;
1146 -- In preanalysis mode, always return Unknown unless the expression
1147 -- is static. It is too early to be thinking we know the result of a
1148 -- comparison, save that judgment for the full analysis. This is
1149 -- particularly important in the case of pre and postconditions, which
1150 -- otherwise can be prematurely collapsed into having True or False
1151 -- conditions when this is inappropriate.
1153 if not (Full_Analysis
1154 or else (Is_OK_Static_Expression
(L
)
1156 Is_OK_Static_Expression
(R
)))
1161 -- If either operand could raise Constraint_Error, then we cannot
1162 -- know the result at compile time (since CE may be raised).
1164 if not (Cannot_Raise_Constraint_Error
(L
)
1166 Cannot_Raise_Constraint_Error
(R
))
1171 -- Identical operands are most certainly equal
1177 -- If expressions have no types, then do not attempt to determine if
1178 -- they are the same, since something funny is going on. One case in
1179 -- which this happens is during generic template analysis, when bounds
1180 -- are not fully analyzed.
1182 if No
(Ltyp
) or else No
(Rtyp
) then
1186 -- These get reset to the base type for the case of entities where
1187 -- Is_Known_Valid is not set. This takes care of handling possible
1188 -- invalid representations using the value of the base type, in
1189 -- accordance with RM 13.9.1(10).
1191 Ltyp
:= Underlying_Type
(Ltyp
);
1192 Rtyp
:= Underlying_Type
(Rtyp
);
1194 -- Same rationale as above, but for Underlying_Type instead of Etype
1196 if No
(Ltyp
) or else No
(Rtyp
) then
1200 -- We do not attempt comparisons for packed arrays represented as
1201 -- modular types, where the semantics of comparison is quite different.
1203 if Is_Packed_Array_Impl_Type
(Ltyp
)
1204 and then Is_Modular_Integer_Type
(Ltyp
)
1208 -- For access types, the only time we know the result at compile time
1209 -- (apart from identical operands, which we handled already) is if we
1210 -- know one operand is null and the other is not, or both operands are
1213 elsif Is_Access_Type
(Ltyp
) then
1214 if Known_Null
(L
) then
1215 if Known_Null
(R
) then
1217 elsif Known_Non_Null
(R
) then
1223 elsif Known_Non_Null
(L
) and then Known_Null
(R
) then
1230 -- Case where comparison involves two compile-time-known values
1232 elsif Compile_Time_Known_Value
(L
)
1234 Compile_Time_Known_Value
(R
)
1236 -- For the floating-point case, we have to be a little careful, since
1237 -- at compile time we are dealing with universal exact values, but at
1238 -- runtime, these will be in non-exact target form. That's why the
1239 -- returned results are LE and GE below instead of LT and GT.
1241 if Is_Floating_Point_Type
(Ltyp
)
1243 Is_Floating_Point_Type
(Rtyp
)
1246 Lo
: constant Ureal
:= Expr_Value_R
(L
);
1247 Hi
: constant Ureal
:= Expr_Value_R
(R
);
1258 -- For string types, we have two string literals and we proceed to
1259 -- compare them using the Ada style dictionary string comparison.
1261 elsif not Is_Scalar_Type
(Ltyp
) then
1263 Lstring
: constant String_Id
:= Strval
(Expr_Value_S
(L
));
1264 Rstring
: constant String_Id
:= Strval
(Expr_Value_S
(R
));
1265 Llen
: constant Nat
:= String_Length
(Lstring
);
1266 Rlen
: constant Nat
:= String_Length
(Rstring
);
1269 for J
in 1 .. Nat
'Min (Llen
, Rlen
) loop
1271 LC
: constant Char_Code
:= Get_String_Char
(Lstring
, J
);
1272 RC
: constant Char_Code
:= Get_String_Char
(Rstring
, J
);
1284 elsif Llen
> Rlen
then
1291 -- For remaining scalar cases we know exactly (note that this does
1292 -- include the fixed-point case, where we know the run time integer
1297 Lo
: constant Uint
:= Expr_Value
(L
);
1298 Hi
: constant Uint
:= Expr_Value
(R
);
1301 Diff
.all := Hi
- Lo
;
1306 Diff
.all := Lo
- Hi
;
1312 -- Cases where at least one operand is not known at compile time
1315 -- Remaining checks apply only for discrete types
1317 if not Is_Discrete_Type
(Ltyp
)
1319 not Is_Discrete_Type
(Rtyp
)
1324 -- Defend against generic types, or actually any expressions that
1325 -- contain a reference to a generic type from within a generic
1326 -- template. We don't want to do any range analysis of such
1327 -- expressions for two reasons. First, the bounds of a generic type
1328 -- itself are junk and cannot be used for any kind of analysis.
1329 -- Second, we may have a case where the range at run time is indeed
1330 -- known, but we don't want to do compile time analysis in the
1331 -- template based on that range since in an instance the value may be
1332 -- static, and able to be elaborated without reference to the bounds
1333 -- of types involved. As an example, consider:
1335 -- (F'Pos (F'Last) + 1) > Integer'Last
1337 -- The expression on the left side of > is Universal_Integer and thus
1338 -- acquires the type Integer for evaluation at run time, and at run
1339 -- time it is true that this condition is always False, but within
1340 -- an instance F may be a type with a static range greater than the
1341 -- range of Integer, and the expression statically evaluates to True.
1343 if References_Generic_Formal_Type
(L
)
1345 References_Generic_Formal_Type
(R
)
1350 -- Replace types by base types for the case of values which are not
1351 -- known to have valid representations. This takes care of properly
1352 -- dealing with invalid representations.
1354 if not Assume_Valid
then
1355 if not (Is_Entity_Name
(L
)
1356 and then (Is_Known_Valid
(Entity
(L
))
1357 or else Assume_No_Invalid_Values
))
1359 Ltyp
:= Underlying_Type
(Base_Type
(Ltyp
));
1362 if not (Is_Entity_Name
(R
)
1363 and then (Is_Known_Valid
(Entity
(R
))
1364 or else Assume_No_Invalid_Values
))
1366 Rtyp
:= Underlying_Type
(Base_Type
(Rtyp
));
1370 -- First attempt is to decompose the expressions to extract a
1371 -- constant offset resulting from the use of any of the forms:
1378 -- Then we see if the two expressions are the same value, and if so
1379 -- the result is obtained by comparing the offsets.
1381 -- Note: the reason we do this test first is that it returns only
1382 -- decisive results (with diff set), where other tests, like the
1383 -- range test, may not be as so decisive. Consider for example
1384 -- J .. J + 1. This code can conclude LT with a difference of 1,
1385 -- even if the range of J is not known.
1394 Compare_Decompose
(L
, Lnode
, Loffs
);
1395 Compare_Decompose
(R
, Rnode
, Roffs
);
1397 if Is_Same_Value
(Lnode
, Rnode
) then
1398 if Loffs
= Roffs
then
1402 -- When the offsets are not equal, we can go farther only if
1403 -- the types are not modular (e.g. X < X + 1 is False if X is
1404 -- the largest number).
1406 if not Is_Modular_Integer_Type
(Ltyp
)
1407 and then not Is_Modular_Integer_Type
(Rtyp
)
1409 if Loffs
< Roffs
then
1410 Diff
.all := Roffs
- Loffs
;
1413 Diff
.all := Loffs
- Roffs
;
1420 -- Next, try range analysis and see if operand ranges are disjoint
1428 -- True if each range is a single point
1431 Determine_Range
(L
, LOK
, LLo
, LHi
, Assume_Valid
);
1432 Determine_Range
(R
, ROK
, RLo
, RHi
, Assume_Valid
);
1435 Single
:= (LLo
= LHi
) and then (RLo
= RHi
);
1438 if Single
and Assume_Valid
then
1439 Diff
.all := RLo
- LLo
;
1444 elsif RHi
< LLo
then
1445 if Single
and Assume_Valid
then
1446 Diff
.all := LLo
- RLo
;
1451 elsif Single
and then LLo
= RLo
then
1453 -- If the range includes a single literal and we can assume
1454 -- validity then the result is known even if an operand is
1457 if Assume_Valid
then
1463 elsif LHi
= RLo
then
1466 elsif RHi
= LLo
then
1469 elsif not Is_Known_Valid_Operand
(L
)
1470 and then not Assume_Valid
1472 if Is_Same_Value
(L
, R
) then
1479 -- If the range of either operand cannot be determined, nothing
1480 -- further can be inferred.
1487 -- Here is where we check for comparisons against maximum bounds of
1488 -- types, where we know that no value can be outside the bounds of
1489 -- the subtype. Note that this routine is allowed to assume that all
1490 -- expressions are within their subtype bounds. Callers wishing to
1491 -- deal with possibly invalid values must in any case take special
1492 -- steps (e.g. conversions to larger types) to avoid this kind of
1493 -- optimization, which is always considered to be valid. We do not
1494 -- attempt this optimization with generic types, since the type
1495 -- bounds may not be meaningful in this case.
1497 -- We are in danger of an infinite recursion here. It does not seem
1498 -- useful to go more than one level deep, so the parameter Rec is
1499 -- used to protect ourselves against this infinite recursion.
1503 -- See if we can get a decisive check against one operand and a
1504 -- bound of the other operand (four possible tests here). Note
1505 -- that we avoid testing junk bounds of a generic type.
1507 if not Is_Generic_Type
(Rtyp
) then
1508 case Compile_Time_Compare
(L
, Type_Low_Bound
(Rtyp
),
1510 Assume_Valid
, Rec
=> True)
1512 when LT
=> return LT
;
1513 when LE
=> return LE
;
1514 when EQ
=> return LE
;
1515 when others => null;
1518 case Compile_Time_Compare
(L
, Type_High_Bound
(Rtyp
),
1520 Assume_Valid
, Rec
=> True)
1522 when GT
=> return GT
;
1523 when GE
=> return GE
;
1524 when EQ
=> return GE
;
1525 when others => null;
1529 if not Is_Generic_Type
(Ltyp
) then
1530 case Compile_Time_Compare
(Type_Low_Bound
(Ltyp
), R
,
1532 Assume_Valid
, Rec
=> True)
1534 when GT
=> return GT
;
1535 when GE
=> return GE
;
1536 when EQ
=> return GE
;
1537 when others => null;
1540 case Compile_Time_Compare
(Type_High_Bound
(Ltyp
), R
,
1542 Assume_Valid
, Rec
=> True)
1544 when LT
=> return LT
;
1545 when LE
=> return LE
;
1546 when EQ
=> return LE
;
1547 when others => null;
1552 -- Next attempt is to see if we have an entity compared with a
1553 -- compile-time-known value, where there is a current value
1554 -- conditional for the entity which can tell us the result.
1558 -- Entity variable (left operand)
1561 -- Value (right operand)
1564 -- If False, we have reversed the operands
1567 -- Comparison operator kind from Get_Current_Value_Condition call
1570 -- Value from Get_Current_Value_Condition call
1575 Result
: Compare_Result
;
1576 -- Known result before inversion
1579 if Is_Entity_Name
(L
)
1580 and then Compile_Time_Known_Value
(R
)
1583 Val
:= Expr_Value
(R
);
1586 elsif Is_Entity_Name
(R
)
1587 and then Compile_Time_Known_Value
(L
)
1590 Val
:= Expr_Value
(L
);
1593 -- That was the last chance at finding a compile time result
1599 Get_Current_Value_Condition
(Var
, Op
, Opn
);
1601 -- That was the last chance, so if we got nothing return
1607 Opv
:= Expr_Value
(Opn
);
1609 -- We got a comparison, so we might have something interesting
1611 -- Convert LE to LT and GE to GT, just so we have fewer cases
1613 if Op
= N_Op_Le
then
1617 elsif Op
= N_Op_Ge
then
1622 -- Deal with equality case
1624 if Op
= N_Op_Eq
then
1627 elsif Opv
< Val
then
1633 -- Deal with inequality case
1635 elsif Op
= N_Op_Ne
then
1642 -- Deal with greater than case
1644 elsif Op
= N_Op_Gt
then
1647 elsif Opv
= Val
- 1 then
1653 -- Deal with less than case
1655 else pragma Assert
(Op
= N_Op_Lt
);
1658 elsif Opv
= Val
+ 1 then
1665 -- Deal with inverting result
1669 when GT
=> return LT
;
1670 when GE
=> return LE
;
1671 when LT
=> return GT
;
1672 when LE
=> return GE
;
1673 when others => return Result
;
1680 end Compile_Time_Compare
;
1682 -------------------------------
1683 -- Compile_Time_Known_Bounds --
1684 -------------------------------
1686 function Compile_Time_Known_Bounds
(T
: Entity_Id
) return Boolean is
1691 if T
= Any_Composite
or else not Is_Array_Type
(T
) then
1695 Indx
:= First_Index
(T
);
1696 while Present
(Indx
) loop
1697 Typ
:= Underlying_Type
(Etype
(Indx
));
1699 -- Never look at junk bounds of a generic type
1701 if Is_Generic_Type
(Typ
) then
1705 -- Otherwise check bounds for compile-time-known
1707 if not Compile_Time_Known_Value
(Type_Low_Bound
(Typ
)) then
1709 elsif not Compile_Time_Known_Value
(Type_High_Bound
(Typ
)) then
1717 end Compile_Time_Known_Bounds
;
1719 ------------------------------
1720 -- Compile_Time_Known_Value --
1721 ------------------------------
1723 function Compile_Time_Known_Value
(Op
: Node_Id
) return Boolean is
1724 K
: constant Node_Kind
:= Nkind
(Op
);
1725 CV_Ent
: CV_Entry
renames CV_Cache
(Nat
(Op
) mod CV_Cache_Size
);
1728 -- Never known at compile time if bad type or raises Constraint_Error
1729 -- or empty (latter case occurs only as a result of a previous error).
1732 Check_Error_Detected
;
1736 or else Etype
(Op
) = Any_Type
1737 or else Raises_Constraint_Error
(Op
)
1742 -- If we have an entity name, then see if it is the name of a constant
1743 -- and if so, test the corresponding constant value, or the name of an
1744 -- enumeration literal, which is always a constant.
1746 if Present
(Etype
(Op
)) and then Is_Entity_Name
(Op
) then
1748 Ent
: constant Entity_Id
:= Entity
(Op
);
1752 -- Never known at compile time if it is a packed array value. We
1753 -- might want to try to evaluate these at compile time one day,
1754 -- but we do not make that attempt now.
1756 if Is_Packed_Array_Impl_Type
(Etype
(Op
)) then
1759 elsif Ekind
(Ent
) = E_Enumeration_Literal
then
1762 elsif Ekind
(Ent
) = E_Constant
then
1763 Val
:= Constant_Value
(Ent
);
1765 if Present
(Val
) then
1767 -- Guard against an illegal deferred constant whose full
1768 -- view is initialized with a reference to itself. Treat
1769 -- this case as a value not known at compile time.
1771 if Is_Entity_Name
(Val
) and then Entity
(Val
) = Ent
then
1774 return Compile_Time_Known_Value
(Val
);
1777 -- Otherwise, the constant does not have a compile-time-known
1786 -- We have a value, see if it is compile-time-known
1789 -- Integer literals are worth storing in the cache
1791 if K
= N_Integer_Literal
then
1793 CV_Ent
.V
:= Intval
(Op
);
1796 -- Other literals and NULL are known at compile time
1799 Nkind_In
(K
, N_Character_Literal
,
1808 -- If we fall through, not known at compile time
1812 -- If we get an exception while trying to do this test, then some error
1813 -- has occurred, and we simply say that the value is not known after all
1818 end Compile_Time_Known_Value
;
1820 --------------------------------------
1821 -- Compile_Time_Known_Value_Or_Aggr --
1822 --------------------------------------
1824 function Compile_Time_Known_Value_Or_Aggr
(Op
: Node_Id
) return Boolean is
1826 -- If we have an entity name, then see if it is the name of a constant
1827 -- and if so, test the corresponding constant value, or the name of
1828 -- an enumeration literal, which is always a constant.
1830 if Is_Entity_Name
(Op
) then
1832 E
: constant Entity_Id
:= Entity
(Op
);
1836 if Ekind
(E
) = E_Enumeration_Literal
then
1839 elsif Ekind
(E
) /= E_Constant
then
1843 V
:= Constant_Value
(E
);
1845 and then Compile_Time_Known_Value_Or_Aggr
(V
);
1849 -- We have a value, see if it is compile-time-known
1852 if Compile_Time_Known_Value
(Op
) then
1855 elsif Nkind
(Op
) = N_Aggregate
then
1857 if Present
(Expressions
(Op
)) then
1861 Expr
:= First
(Expressions
(Op
));
1862 while Present
(Expr
) loop
1863 if not Compile_Time_Known_Value_Or_Aggr
(Expr
) then
1872 if Present
(Component_Associations
(Op
)) then
1877 Cass
:= First
(Component_Associations
(Op
));
1878 while Present
(Cass
) loop
1880 Compile_Time_Known_Value_Or_Aggr
(Expression
(Cass
))
1892 elsif Nkind
(Op
) = N_Qualified_Expression
then
1893 return Compile_Time_Known_Value_Or_Aggr
(Expression
(Op
));
1895 -- All other types of values are not known at compile time
1902 end Compile_Time_Known_Value_Or_Aggr
;
1904 ---------------------------------------
1905 -- CRT_Safe_Compile_Time_Known_Value --
1906 ---------------------------------------
1908 function CRT_Safe_Compile_Time_Known_Value
(Op
: Node_Id
) return Boolean is
1910 if (Configurable_Run_Time_Mode
or No_Run_Time_Mode
)
1911 and then not Is_OK_Static_Expression
(Op
)
1915 return Compile_Time_Known_Value
(Op
);
1917 end CRT_Safe_Compile_Time_Known_Value
;
1923 -- This is only called for actuals of functions that are not predefined
1924 -- operators (which have already been rewritten as operators at this
1925 -- stage), so the call can never be folded, and all that needs doing for
1926 -- the actual is to do the check for a non-static context.
1928 procedure Eval_Actual
(N
: Node_Id
) is
1930 Check_Non_Static_Context
(N
);
1933 --------------------
1934 -- Eval_Allocator --
1935 --------------------
1937 -- Allocators are never static, so all we have to do is to do the
1938 -- check for a non-static context if an expression is present.
1940 procedure Eval_Allocator
(N
: Node_Id
) is
1941 Expr
: constant Node_Id
:= Expression
(N
);
1943 if Nkind
(Expr
) = N_Qualified_Expression
then
1944 Check_Non_Static_Context
(Expression
(Expr
));
1948 ------------------------
1949 -- Eval_Arithmetic_Op --
1950 ------------------------
1952 -- Arithmetic operations are static functions, so the result is static
1953 -- if both operands are static (RM 4.9(7), 4.9(20)).
1955 procedure Eval_Arithmetic_Op
(N
: Node_Id
) is
1956 Left
: constant Node_Id
:= Left_Opnd
(N
);
1957 Right
: constant Node_Id
:= Right_Opnd
(N
);
1958 Ltype
: constant Entity_Id
:= Etype
(Left
);
1959 Rtype
: constant Entity_Id
:= Etype
(Right
);
1960 Otype
: Entity_Id
:= Empty
;
1965 -- If not foldable we are done
1967 Test_Expression_Is_Foldable
(N
, Left
, Right
, Stat
, Fold
);
1973 -- Otherwise attempt to fold
1975 if Is_Universal_Numeric_Type
(Etype
(Left
))
1977 Is_Universal_Numeric_Type
(Etype
(Right
))
1979 Otype
:= Find_Universal_Operator_Type
(N
);
1982 -- Fold for cases where both operands are of integer type
1984 if Is_Integer_Type
(Ltype
) and then Is_Integer_Type
(Rtype
) then
1986 Left_Int
: constant Uint
:= Expr_Value
(Left
);
1987 Right_Int
: constant Uint
:= Expr_Value
(Right
);
1993 Result
:= Left_Int
+ Right_Int
;
1995 when N_Op_Subtract
=>
1996 Result
:= Left_Int
- Right_Int
;
1998 when N_Op_Multiply
=>
2001 (Num_Bits
(Left_Int
) + Num_Bits
(Right_Int
)))
2003 Result
:= Left_Int
* Right_Int
;
2010 -- The exception Constraint_Error is raised by integer
2011 -- division, rem and mod if the right operand is zero.
2013 if Right_Int
= 0 then
2015 -- When SPARK_Mode is On, force a warning instead of
2016 -- an error in that case, as this likely corresponds
2017 -- to deactivated code.
2019 Apply_Compile_Time_Constraint_Error
2020 (N
, "division by zero", CE_Divide_By_Zero
,
2021 Warn
=> not Stat
or SPARK_Mode
= On
);
2022 Set_Raises_Constraint_Error
(N
);
2025 -- Otherwise we can do the division
2028 Result
:= Left_Int
/ Right_Int
;
2033 -- The exception Constraint_Error is raised by integer
2034 -- division, rem and mod if the right operand is zero.
2036 if Right_Int
= 0 then
2038 -- When SPARK_Mode is On, force a warning instead of
2039 -- an error in that case, as this likely corresponds
2040 -- to deactivated code.
2042 Apply_Compile_Time_Constraint_Error
2043 (N
, "mod with zero divisor", CE_Divide_By_Zero
,
2044 Warn
=> not Stat
or SPARK_Mode
= On
);
2048 Result
:= Left_Int
mod Right_Int
;
2053 -- The exception Constraint_Error is raised by integer
2054 -- division, rem and mod if the right operand is zero.
2056 if Right_Int
= 0 then
2058 -- When SPARK_Mode is On, force a warning instead of
2059 -- an error in that case, as this likely corresponds
2060 -- to deactivated code.
2062 Apply_Compile_Time_Constraint_Error
2063 (N
, "rem with zero divisor", CE_Divide_By_Zero
,
2064 Warn
=> not Stat
or SPARK_Mode
= On
);
2068 Result
:= Left_Int
rem Right_Int
;
2072 raise Program_Error
;
2075 -- Adjust the result by the modulus if the type is a modular type
2077 if Is_Modular_Integer_Type
(Ltype
) then
2078 Result
:= Result
mod Modulus
(Ltype
);
2080 -- For a signed integer type, check non-static overflow
2082 elsif (not Stat
) and then Is_Signed_Integer_Type
(Ltype
) then
2084 BT
: constant Entity_Id
:= Base_Type
(Ltype
);
2085 Lo
: constant Uint
:= Expr_Value
(Type_Low_Bound
(BT
));
2086 Hi
: constant Uint
:= Expr_Value
(Type_High_Bound
(BT
));
2088 if Result
< Lo
or else Result
> Hi
then
2089 Apply_Compile_Time_Constraint_Error
2090 (N
, "value not in range of }??",
2091 CE_Overflow_Check_Failed
,
2098 -- If we get here we can fold the result
2100 Fold_Uint
(N
, Result
, Stat
);
2103 -- Cases where at least one operand is a real. We handle the cases of
2104 -- both reals, or mixed/real integer cases (the latter happen only for
2105 -- divide and multiply, and the result is always real).
2107 elsif Is_Real_Type
(Ltype
) or else Is_Real_Type
(Rtype
) then
2114 if Is_Real_Type
(Ltype
) then
2115 Left_Real
:= Expr_Value_R
(Left
);
2117 Left_Real
:= UR_From_Uint
(Expr_Value
(Left
));
2120 if Is_Real_Type
(Rtype
) then
2121 Right_Real
:= Expr_Value_R
(Right
);
2123 Right_Real
:= UR_From_Uint
(Expr_Value
(Right
));
2126 if Nkind
(N
) = N_Op_Add
then
2127 Result
:= Left_Real
+ Right_Real
;
2129 elsif Nkind
(N
) = N_Op_Subtract
then
2130 Result
:= Left_Real
- Right_Real
;
2132 elsif Nkind
(N
) = N_Op_Multiply
then
2133 Result
:= Left_Real
* Right_Real
;
2135 else pragma Assert
(Nkind
(N
) = N_Op_Divide
);
2136 if UR_Is_Zero
(Right_Real
) then
2137 Apply_Compile_Time_Constraint_Error
2138 (N
, "division by zero", CE_Divide_By_Zero
);
2142 Result
:= Left_Real
/ Right_Real
;
2145 Fold_Ureal
(N
, Result
, Stat
);
2149 -- If the operator was resolved to a specific type, make sure that type
2150 -- is frozen even if the expression is folded into a literal (which has
2151 -- a universal type).
2153 if Present
(Otype
) then
2154 Freeze_Before
(N
, Otype
);
2156 end Eval_Arithmetic_Op
;
2158 ----------------------------
2159 -- Eval_Character_Literal --
2160 ----------------------------
2162 -- Nothing to be done
2164 procedure Eval_Character_Literal
(N
: Node_Id
) is
2165 pragma Warnings
(Off
, N
);
2168 end Eval_Character_Literal
;
2174 -- Static function calls are either calls to predefined operators
2175 -- with static arguments, or calls to functions that rename a literal.
2176 -- Only the latter case is handled here, predefined operators are
2177 -- constant-folded elsewhere.
2179 -- If the function is itself inherited (see 7423-001) the literal of
2180 -- the parent type must be explicitly converted to the return type
2183 procedure Eval_Call
(N
: Node_Id
) is
2184 Loc
: constant Source_Ptr
:= Sloc
(N
);
2185 Typ
: constant Entity_Id
:= Etype
(N
);
2189 if Nkind
(N
) = N_Function_Call
2190 and then No
(Parameter_Associations
(N
))
2191 and then Is_Entity_Name
(Name
(N
))
2192 and then Present
(Alias
(Entity
(Name
(N
))))
2193 and then Is_Enumeration_Type
(Base_Type
(Typ
))
2195 Lit
:= Ultimate_Alias
(Entity
(Name
(N
)));
2197 if Ekind
(Lit
) = E_Enumeration_Literal
then
2198 if Base_Type
(Etype
(Lit
)) /= Base_Type
(Typ
) then
2200 (N
, Convert_To
(Typ
, New_Occurrence_Of
(Lit
, Loc
)));
2202 Rewrite
(N
, New_Occurrence_Of
(Lit
, Loc
));
2210 --------------------------
2211 -- Eval_Case_Expression --
2212 --------------------------
2214 -- A conditional expression is static if all its conditions and dependent
2215 -- expressions are static. Note that we do not care if the dependent
2216 -- expressions raise CE, except for the one that will be selected.
2218 procedure Eval_Case_Expression
(N
: Node_Id
) is
2223 Set_Is_Static_Expression
(N
, False);
2225 if Error_Posted
(Expression
(N
))
2226 or else not Is_Static_Expression
(Expression
(N
))
2228 Check_Non_Static_Context
(Expression
(N
));
2232 -- First loop, make sure all the alternatives are static expressions
2233 -- none of which raise Constraint_Error. We make the Constraint_Error
2234 -- check because part of the legality condition for a correct static
2235 -- case expression is that the cases are covered, like any other case
2236 -- expression. And we can't do that if any of the conditions raise an
2237 -- exception, so we don't even try to evaluate if that is the case.
2239 Alt
:= First
(Alternatives
(N
));
2240 while Present
(Alt
) loop
2242 -- The expression must be static, but we don't care at this stage
2243 -- if it raises Constraint_Error (the alternative might not match,
2244 -- in which case the expression is statically unevaluated anyway).
2246 if not Is_Static_Expression
(Expression
(Alt
)) then
2247 Check_Non_Static_Context
(Expression
(Alt
));
2251 -- The choices of a case always have to be static, and cannot raise
2252 -- an exception. If this condition is not met, then the expression
2253 -- is plain illegal, so just abandon evaluation attempts. No need
2254 -- to check non-static context when we have something illegal anyway.
2256 if not Is_OK_Static_Choice_List
(Discrete_Choices
(Alt
)) then
2263 -- OK, if the above loop gets through it means that all choices are OK
2264 -- static (don't raise exceptions), so the whole case is static, and we
2265 -- can find the matching alternative.
2267 Set_Is_Static_Expression
(N
);
2269 -- Now to deal with propagating a possible Constraint_Error
2271 -- If the selecting expression raises CE, propagate and we are done
2273 if Raises_Constraint_Error
(Expression
(N
)) then
2274 Set_Raises_Constraint_Error
(N
);
2276 -- Otherwise we need to check the alternatives to find the matching
2277 -- one. CE's in other than the matching one are not relevant. But we
2278 -- do need to check the matching one. Unlike the first loop, we do not
2279 -- have to go all the way through, when we find the matching one, quit.
2282 Alt
:= First
(Alternatives
(N
));
2285 -- We must find a match among the alternatives. If not, this must
2286 -- be due to other errors, so just ignore, leaving as non-static.
2289 Set_Is_Static_Expression
(N
, False);
2293 -- Otherwise loop through choices of this alternative
2295 Choice
:= First
(Discrete_Choices
(Alt
));
2296 while Present
(Choice
) loop
2298 -- If we find a matching choice, then the Expression of this
2299 -- alternative replaces N (Raises_Constraint_Error flag is
2300 -- included, so we don't have to special case that).
2302 if Choice_Matches
(Expression
(N
), Choice
) = Match
then
2303 Rewrite
(N
, Relocate_Node
(Expression
(Alt
)));
2313 end Eval_Case_Expression
;
2315 ------------------------
2316 -- Eval_Concatenation --
2317 ------------------------
2319 -- Concatenation is a static function, so the result is static if both
2320 -- operands are static (RM 4.9(7), 4.9(21)).
2322 procedure Eval_Concatenation
(N
: Node_Id
) is
2323 Left
: constant Node_Id
:= Left_Opnd
(N
);
2324 Right
: constant Node_Id
:= Right_Opnd
(N
);
2325 C_Typ
: constant Entity_Id
:= Root_Type
(Component_Type
(Etype
(N
)));
2330 -- Concatenation is never static in Ada 83, so if Ada 83 check operand
2331 -- non-static context.
2333 if Ada_Version
= Ada_83
2334 and then Comes_From_Source
(N
)
2336 Check_Non_Static_Context
(Left
);
2337 Check_Non_Static_Context
(Right
);
2341 -- If not foldable we are done. In principle concatenation that yields
2342 -- any string type is static (i.e. an array type of character types).
2343 -- However, character types can include enumeration literals, and
2344 -- concatenation in that case cannot be described by a literal, so we
2345 -- only consider the operation static if the result is an array of
2346 -- (a descendant of) a predefined character type.
2348 Test_Expression_Is_Foldable
(N
, Left
, Right
, Stat
, Fold
);
2350 if not (Is_Standard_Character_Type
(C_Typ
) and then Fold
) then
2351 Set_Is_Static_Expression
(N
, False);
2355 -- Compile time string concatenation
2357 -- ??? Note that operands that are aggregates can be marked as static,
2358 -- so we should attempt at a later stage to fold concatenations with
2362 Left_Str
: constant Node_Id
:= Get_String_Val
(Left
);
2364 Right_Str
: constant Node_Id
:= Get_String_Val
(Right
);
2365 Folded_Val
: String_Id
:= No_String
;
2368 -- Establish new string literal, and store left operand. We make
2369 -- sure to use the special Start_String that takes an operand if
2370 -- the left operand is a string literal. Since this is optimized
2371 -- in the case where that is the most recently created string
2372 -- literal, we ensure efficient time/space behavior for the
2373 -- case of a concatenation of a series of string literals.
2375 if Nkind
(Left_Str
) = N_String_Literal
then
2376 Left_Len
:= String_Length
(Strval
(Left_Str
));
2378 -- If the left operand is the empty string, and the right operand
2379 -- is a string literal (the case of "" & "..."), the result is the
2380 -- value of the right operand. This optimization is important when
2381 -- Is_Folded_In_Parser, to avoid copying an enormous right
2384 if Left_Len
= 0 and then Nkind
(Right_Str
) = N_String_Literal
then
2385 Folded_Val
:= Strval
(Right_Str
);
2387 Start_String
(Strval
(Left_Str
));
2392 Store_String_Char
(UI_To_CC
(Char_Literal_Value
(Left_Str
)));
2396 -- Now append the characters of the right operand, unless we
2397 -- optimized the "" & "..." case above.
2399 if Nkind
(Right_Str
) = N_String_Literal
then
2400 if Left_Len
/= 0 then
2401 Store_String_Chars
(Strval
(Right_Str
));
2402 Folded_Val
:= End_String
;
2405 Store_String_Char
(UI_To_CC
(Char_Literal_Value
(Right_Str
)));
2406 Folded_Val
:= End_String
;
2409 Set_Is_Static_Expression
(N
, Stat
);
2411 -- If left operand is the empty string, the result is the
2412 -- right operand, including its bounds if anomalous.
2415 and then Is_Array_Type
(Etype
(Right
))
2416 and then Etype
(Right
) /= Any_String
2418 Set_Etype
(N
, Etype
(Right
));
2421 Fold_Str
(N
, Folded_Val
, Static
=> Stat
);
2423 end Eval_Concatenation
;
2425 ----------------------
2426 -- Eval_Entity_Name --
2427 ----------------------
2429 -- This procedure is used for identifiers and expanded names other than
2430 -- named numbers (see Eval_Named_Integer, Eval_Named_Real. These are
2431 -- static if they denote a static constant (RM 4.9(6)) or if the name
2432 -- denotes an enumeration literal (RM 4.9(22)).
2434 procedure Eval_Entity_Name
(N
: Node_Id
) is
2435 Def_Id
: constant Entity_Id
:= Entity
(N
);
2439 -- Enumeration literals are always considered to be constants
2440 -- and cannot raise Constraint_Error (RM 4.9(22)).
2442 if Ekind
(Def_Id
) = E_Enumeration_Literal
then
2443 Set_Is_Static_Expression
(N
);
2446 -- A name is static if it denotes a static constant (RM 4.9(5)), and
2447 -- we also copy Raise_Constraint_Error. Notice that even if non-static,
2448 -- it does not violate 10.2.1(8) here, since this is not a variable.
2450 elsif Ekind
(Def_Id
) = E_Constant
then
2452 -- Deferred constants must always be treated as nonstatic outside the
2453 -- scope of their full view.
2455 if Present
(Full_View
(Def_Id
))
2456 and then not In_Open_Scopes
(Scope
(Def_Id
))
2460 Val
:= Constant_Value
(Def_Id
);
2463 if Present
(Val
) then
2464 Set_Is_Static_Expression
2465 (N
, Is_Static_Expression
(Val
)
2466 and then Is_Static_Subtype
(Etype
(Def_Id
)));
2467 Set_Raises_Constraint_Error
(N
, Raises_Constraint_Error
(Val
));
2469 if not Is_Static_Expression
(N
)
2470 and then not Is_Generic_Type
(Etype
(N
))
2472 Validate_Static_Object_Name
(N
);
2475 -- Mark constant condition in SCOs
2478 and then Comes_From_Source
(N
)
2479 and then Is_Boolean_Type
(Etype
(Def_Id
))
2480 and then Compile_Time_Known_Value
(N
)
2482 Set_SCO_Condition
(N
, Expr_Value_E
(N
) = Standard_True
);
2489 -- Fall through if the name is not static
2491 Validate_Static_Object_Name
(N
);
2492 end Eval_Entity_Name
;
2494 ------------------------
2495 -- Eval_If_Expression --
2496 ------------------------
2498 -- We can fold to a static expression if the condition and both dependent
2499 -- expressions are static. Otherwise, the only required processing is to do
2500 -- the check for non-static context for the then and else expressions.
2502 procedure Eval_If_Expression
(N
: Node_Id
) is
2503 Condition
: constant Node_Id
:= First
(Expressions
(N
));
2504 Then_Expr
: constant Node_Id
:= Next
(Condition
);
2505 Else_Expr
: constant Node_Id
:= Next
(Then_Expr
);
2507 Non_Result
: Node_Id
;
2509 Rstat
: constant Boolean :=
2510 Is_Static_Expression
(Condition
)
2512 Is_Static_Expression
(Then_Expr
)
2514 Is_Static_Expression
(Else_Expr
);
2515 -- True if result is static
2518 -- If result not static, nothing to do, otherwise set static result
2523 Set_Is_Static_Expression
(N
);
2526 -- If any operand is Any_Type, just propagate to result and do not try
2527 -- to fold, this prevents cascaded errors.
2529 if Etype
(Condition
) = Any_Type
or else
2530 Etype
(Then_Expr
) = Any_Type
or else
2531 Etype
(Else_Expr
) = Any_Type
2533 Set_Etype
(N
, Any_Type
);
2534 Set_Is_Static_Expression
(N
, False);
2538 -- If condition raises Constraint_Error then we have already signaled
2539 -- an error, and we just propagate to the result and do not fold.
2541 if Raises_Constraint_Error
(Condition
) then
2542 Set_Raises_Constraint_Error
(N
);
2546 -- Static case where we can fold. Note that we don't try to fold cases
2547 -- where the condition is known at compile time, but the result is
2548 -- non-static. This avoids possible cases of infinite recursion where
2549 -- the expander puts in a redundant test and we remove it. Instead we
2550 -- deal with these cases in the expander.
2552 -- Select result operand
2554 if Is_True
(Expr_Value
(Condition
)) then
2555 Result
:= Then_Expr
;
2556 Non_Result
:= Else_Expr
;
2558 Result
:= Else_Expr
;
2559 Non_Result
:= Then_Expr
;
2562 -- Note that it does not matter if the non-result operand raises a
2563 -- Constraint_Error, but if the result raises Constraint_Error then we
2564 -- replace the node with a raise Constraint_Error. This will properly
2565 -- propagate Raises_Constraint_Error since this flag is set in Result.
2567 if Raises_Constraint_Error
(Result
) then
2568 Rewrite_In_Raise_CE
(N
, Result
);
2569 Check_Non_Static_Context
(Non_Result
);
2571 -- Otherwise the result operand replaces the original node
2574 Rewrite
(N
, Relocate_Node
(Result
));
2575 Set_Is_Static_Expression
(N
);
2577 end Eval_If_Expression
;
2579 ----------------------------
2580 -- Eval_Indexed_Component --
2581 ----------------------------
2583 -- Indexed components are never static, so we need to perform the check
2584 -- for non-static context on the index values. Then, we check if the
2585 -- value can be obtained at compile time, even though it is non-static.
2587 procedure Eval_Indexed_Component
(N
: Node_Id
) is
2591 -- Check for non-static context on index values
2593 Expr
:= First
(Expressions
(N
));
2594 while Present
(Expr
) loop
2595 Check_Non_Static_Context
(Expr
);
2599 -- If the indexed component appears in an object renaming declaration
2600 -- then we do not want to try to evaluate it, since in this case we
2601 -- need the identity of the array element.
2603 if Nkind
(Parent
(N
)) = N_Object_Renaming_Declaration
then
2606 -- Similarly if the indexed component appears as the prefix of an
2607 -- attribute we don't want to evaluate it, because at least for
2608 -- some cases of attributes we need the identify (e.g. Access, Size)
2610 elsif Nkind
(Parent
(N
)) = N_Attribute_Reference
then
2614 -- Note: there are other cases, such as the left side of an assignment,
2615 -- or an OUT parameter for a call, where the replacement results in the
2616 -- illegal use of a constant, But these cases are illegal in the first
2617 -- place, so the replacement, though silly, is harmless.
2619 -- Now see if this is a constant array reference
2621 if List_Length
(Expressions
(N
)) = 1
2622 and then Is_Entity_Name
(Prefix
(N
))
2623 and then Ekind
(Entity
(Prefix
(N
))) = E_Constant
2624 and then Present
(Constant_Value
(Entity
(Prefix
(N
))))
2627 Loc
: constant Source_Ptr
:= Sloc
(N
);
2628 Arr
: constant Node_Id
:= Constant_Value
(Entity
(Prefix
(N
)));
2629 Sub
: constant Node_Id
:= First
(Expressions
(N
));
2635 -- Linear one's origin subscript value for array reference
2638 -- Lower bound of the first array index
2641 -- Value from constant array
2644 Atyp
:= Etype
(Arr
);
2646 if Is_Access_Type
(Atyp
) then
2647 Atyp
:= Designated_Type
(Atyp
);
2650 -- If we have an array type (we should have but perhaps there are
2651 -- error cases where this is not the case), then see if we can do
2652 -- a constant evaluation of the array reference.
2654 if Is_Array_Type
(Atyp
) and then Atyp
/= Any_Composite
then
2655 if Ekind
(Atyp
) = E_String_Literal_Subtype
then
2656 Lbd
:= String_Literal_Low_Bound
(Atyp
);
2658 Lbd
:= Type_Low_Bound
(Etype
(First_Index
(Atyp
)));
2661 if Compile_Time_Known_Value
(Sub
)
2662 and then Nkind
(Arr
) = N_Aggregate
2663 and then Compile_Time_Known_Value
(Lbd
)
2664 and then Is_Discrete_Type
(Component_Type
(Atyp
))
2666 Lin
:= UI_To_Int
(Expr_Value
(Sub
) - Expr_Value
(Lbd
)) + 1;
2668 if List_Length
(Expressions
(Arr
)) >= Lin
then
2669 Elm
:= Pick
(Expressions
(Arr
), Lin
);
2671 -- If the resulting expression is compile-time-known,
2672 -- then we can rewrite the indexed component with this
2673 -- value, being sure to mark the result as non-static.
2674 -- We also reset the Sloc, in case this generates an
2675 -- error later on (e.g. 136'Access).
2677 if Compile_Time_Known_Value
(Elm
) then
2678 Rewrite
(N
, Duplicate_Subexpr_No_Checks
(Elm
));
2679 Set_Is_Static_Expression
(N
, False);
2684 -- We can also constant-fold if the prefix is a string literal.
2685 -- This will be useful in an instantiation or an inlining.
2687 elsif Compile_Time_Known_Value
(Sub
)
2688 and then Nkind
(Arr
) = N_String_Literal
2689 and then Compile_Time_Known_Value
(Lbd
)
2690 and then Expr_Value
(Lbd
) = 1
2691 and then Expr_Value
(Sub
) <=
2692 String_Literal_Length
(Etype
(Arr
))
2695 C
: constant Char_Code
:=
2696 Get_String_Char
(Strval
(Arr
),
2697 UI_To_Int
(Expr_Value
(Sub
)));
2699 Set_Character_Literal_Name
(C
);
2702 Make_Character_Literal
(Loc
,
2704 Char_Literal_Value
=> UI_From_CC
(C
));
2705 Set_Etype
(Elm
, Component_Type
(Atyp
));
2706 Rewrite
(N
, Duplicate_Subexpr_No_Checks
(Elm
));
2707 Set_Is_Static_Expression
(N
, False);
2713 end Eval_Indexed_Component
;
2715 --------------------------
2716 -- Eval_Integer_Literal --
2717 --------------------------
2719 -- Numeric literals are static (RM 4.9(1)), and have already been marked
2720 -- as static by the analyzer. The reason we did it that early is to allow
2721 -- the possibility of turning off the Is_Static_Expression flag after
2722 -- analysis, but before resolution, when integer literals are generated in
2723 -- the expander that do not correspond to static expressions.
2725 procedure Eval_Integer_Literal
(N
: Node_Id
) is
2726 function In_Any_Integer_Context
(Context
: Node_Id
) return Boolean;
2727 -- If the literal is resolved with a specific type in a context where
2728 -- the expected type is Any_Integer, there are no range checks on the
2729 -- literal. By the time the literal is evaluated, it carries the type
2730 -- imposed by the enclosing expression, and we must recover the context
2731 -- to determine that Any_Integer is meant.
2733 ----------------------------
2734 -- In_Any_Integer_Context --
2735 ----------------------------
2737 function In_Any_Integer_Context
(Context
: Node_Id
) return Boolean is
2739 -- Any_Integer also appears in digits specifications for real types,
2740 -- but those have bounds smaller that those of any integer base type,
2741 -- so we can safely ignore these cases.
2744 Nkind_In
(Context
, N_Attribute_Definition_Clause
,
2745 N_Attribute_Reference
,
2746 N_Modular_Type_Definition
,
2747 N_Number_Declaration
,
2748 N_Signed_Integer_Type_Definition
);
2749 end In_Any_Integer_Context
;
2753 Par
: constant Node_Id
:= Parent
(N
);
2754 Typ
: constant Entity_Id
:= Etype
(N
);
2756 -- Start of processing for Eval_Integer_Literal
2759 -- If the literal appears in a non-expression context, then it is
2760 -- certainly appearing in a non-static context, so check it. This is
2761 -- actually a redundant check, since Check_Non_Static_Context would
2762 -- check it, but it seems worthwhile to optimize out the call.
2764 -- Additionally, when the literal appears within an if or case
2765 -- expression it must be checked as well. However, due to the literal
2766 -- appearing within a conditional statement, expansion greatly changes
2767 -- the nature of its context and performing some of the checks within
2768 -- Check_Non_Static_Context on an expanded literal may lead to spurious
2769 -- and misleading warnings.
2771 if (Nkind_In
(Par
, N_Case_Expression_Alternative
, N_If_Expression
)
2772 or else Nkind
(Parent
(N
)) not in N_Subexpr
)
2773 and then (not Nkind_In
(Par
, N_Case_Expression_Alternative
,
2775 or else Comes_From_Source
(N
))
2776 and then not In_Any_Integer_Context
(Par
)
2778 Check_Non_Static_Context
(N
);
2781 -- Modular integer literals must be in their base range
2783 if Is_Modular_Integer_Type
(Typ
)
2784 and then Is_Out_Of_Range
(N
, Base_Type
(Typ
), Assume_Valid
=> True)
2788 end Eval_Integer_Literal
;
2790 ---------------------
2791 -- Eval_Logical_Op --
2792 ---------------------
2794 -- Logical operations are static functions, so the result is potentially
2795 -- static if both operands are potentially static (RM 4.9(7), 4.9(20)).
2797 procedure Eval_Logical_Op
(N
: Node_Id
) is
2798 Left
: constant Node_Id
:= Left_Opnd
(N
);
2799 Right
: constant Node_Id
:= Right_Opnd
(N
);
2804 -- If not foldable we are done
2806 Test_Expression_Is_Foldable
(N
, Left
, Right
, Stat
, Fold
);
2812 -- Compile time evaluation of logical operation
2815 Left_Int
: constant Uint
:= Expr_Value
(Left
);
2816 Right_Int
: constant Uint
:= Expr_Value
(Right
);
2819 if Is_Modular_Integer_Type
(Etype
(N
)) then
2821 Left_Bits
: Bits
(0 .. UI_To_Int
(Esize
(Etype
(N
))) - 1);
2822 Right_Bits
: Bits
(0 .. UI_To_Int
(Esize
(Etype
(N
))) - 1);
2825 To_Bits
(Left_Int
, Left_Bits
);
2826 To_Bits
(Right_Int
, Right_Bits
);
2828 -- Note: should really be able to use array ops instead of
2829 -- these loops, but they weren't working at the time ???
2831 if Nkind
(N
) = N_Op_And
then
2832 for J
in Left_Bits
'Range loop
2833 Left_Bits
(J
) := Left_Bits
(J
) and Right_Bits
(J
);
2836 elsif Nkind
(N
) = N_Op_Or
then
2837 for J
in Left_Bits
'Range loop
2838 Left_Bits
(J
) := Left_Bits
(J
) or Right_Bits
(J
);
2842 pragma Assert
(Nkind
(N
) = N_Op_Xor
);
2844 for J
in Left_Bits
'Range loop
2845 Left_Bits
(J
) := Left_Bits
(J
) xor Right_Bits
(J
);
2849 Fold_Uint
(N
, From_Bits
(Left_Bits
, Etype
(N
)), Stat
);
2853 pragma Assert
(Is_Boolean_Type
(Etype
(N
)));
2855 if Nkind
(N
) = N_Op_And
then
2857 Test
(Is_True
(Left_Int
) and then Is_True
(Right_Int
)), Stat
);
2859 elsif Nkind
(N
) = N_Op_Or
then
2861 Test
(Is_True
(Left_Int
) or else Is_True
(Right_Int
)), Stat
);
2864 pragma Assert
(Nkind
(N
) = N_Op_Xor
);
2866 Test
(Is_True
(Left_Int
) xor Is_True
(Right_Int
)), Stat
);
2870 end Eval_Logical_Op
;
2872 ------------------------
2873 -- Eval_Membership_Op --
2874 ------------------------
2876 -- A membership test is potentially static if the expression is static, and
2877 -- the range is a potentially static range, or is a subtype mark denoting a
2878 -- static subtype (RM 4.9(12)).
2880 procedure Eval_Membership_Op
(N
: Node_Id
) is
2881 Alts
: constant List_Id
:= Alternatives
(N
);
2882 Choice
: constant Node_Id
:= Right_Opnd
(N
);
2883 Expr
: constant Node_Id
:= Left_Opnd
(N
);
2884 Result
: Match_Result
;
2887 -- Ignore if error in either operand, except to make sure that Any_Type
2888 -- is properly propagated to avoid junk cascaded errors.
2890 if Etype
(Expr
) = Any_Type
2891 or else (Present
(Choice
) and then Etype
(Choice
) = Any_Type
)
2893 Set_Etype
(N
, Any_Type
);
2897 -- If left operand non-static, then nothing to do
2899 if not Is_Static_Expression
(Expr
) then
2903 -- If choice is non-static, left operand is in non-static context
2905 if (Present
(Choice
) and then not Is_Static_Choice
(Choice
))
2906 or else (Present
(Alts
) and then not Is_Static_Choice_List
(Alts
))
2908 Check_Non_Static_Context
(Expr
);
2912 -- Otherwise we definitely have a static expression
2914 Set_Is_Static_Expression
(N
);
2916 -- If left operand raises Constraint_Error, propagate and we are done
2918 if Raises_Constraint_Error
(Expr
) then
2919 Set_Raises_Constraint_Error
(N
, True);
2924 if Present
(Choice
) then
2925 Result
:= Choice_Matches
(Expr
, Choice
);
2927 Result
:= Choices_Match
(Expr
, Alts
);
2930 -- If result is Non_Static, it means that we raise Constraint_Error,
2931 -- since we already tested that the operands were themselves static.
2933 if Result
= Non_Static
then
2934 Set_Raises_Constraint_Error
(N
);
2936 -- Otherwise we have our result (flipped if NOT IN case)
2940 (N
, Test
((Result
= Match
) xor (Nkind
(N
) = N_Not_In
)), True);
2941 Warn_On_Known_Condition
(N
);
2944 end Eval_Membership_Op
;
2946 ------------------------
2947 -- Eval_Named_Integer --
2948 ------------------------
2950 procedure Eval_Named_Integer
(N
: Node_Id
) is
2953 Expr_Value
(Expression
(Declaration_Node
(Entity
(N
)))), True);
2954 end Eval_Named_Integer
;
2956 ---------------------
2957 -- Eval_Named_Real --
2958 ---------------------
2960 procedure Eval_Named_Real
(N
: Node_Id
) is
2963 Expr_Value_R
(Expression
(Declaration_Node
(Entity
(N
)))), True);
2964 end Eval_Named_Real
;
2970 -- Exponentiation is a static functions, so the result is potentially
2971 -- static if both operands are potentially static (RM 4.9(7), 4.9(20)).
2973 procedure Eval_Op_Expon
(N
: Node_Id
) is
2974 Left
: constant Node_Id
:= Left_Opnd
(N
);
2975 Right
: constant Node_Id
:= Right_Opnd
(N
);
2980 -- If not foldable we are done
2982 Test_Expression_Is_Foldable
2983 (N
, Left
, Right
, Stat
, Fold
, CRT_Safe
=> True);
2985 -- Return if not foldable
2991 if Configurable_Run_Time_Mode
and not Stat
then
2995 -- Fold exponentiation operation
2998 Right_Int
: constant Uint
:= Expr_Value
(Right
);
3003 if Is_Integer_Type
(Etype
(Left
)) then
3005 Left_Int
: constant Uint
:= Expr_Value
(Left
);
3009 -- Exponentiation of an integer raises Constraint_Error for a
3010 -- negative exponent (RM 4.5.6).
3012 if Right_Int
< 0 then
3013 Apply_Compile_Time_Constraint_Error
3014 (N
, "integer exponent negative", CE_Range_Check_Failed
,
3019 if OK_Bits
(N
, Num_Bits
(Left_Int
) * Right_Int
) then
3020 Result
:= Left_Int
** Right_Int
;
3025 if Is_Modular_Integer_Type
(Etype
(N
)) then
3026 Result
:= Result
mod Modulus
(Etype
(N
));
3029 Fold_Uint
(N
, Result
, Stat
);
3037 Left_Real
: constant Ureal
:= Expr_Value_R
(Left
);
3040 -- Cannot have a zero base with a negative exponent
3042 if UR_Is_Zero
(Left_Real
) then
3044 if Right_Int
< 0 then
3045 Apply_Compile_Time_Constraint_Error
3046 (N
, "zero ** negative integer", CE_Range_Check_Failed
,
3050 Fold_Ureal
(N
, Ureal_0
, Stat
);
3054 Fold_Ureal
(N
, Left_Real
** Right_Int
, Stat
);
3065 -- The not operation is a static functions, so the result is potentially
3066 -- static if the operand is potentially static (RM 4.9(7), 4.9(20)).
3068 procedure Eval_Op_Not
(N
: Node_Id
) is
3069 Right
: constant Node_Id
:= Right_Opnd
(N
);
3074 -- If not foldable we are done
3076 Test_Expression_Is_Foldable
(N
, Right
, Stat
, Fold
);
3082 -- Fold not operation
3085 Rint
: constant Uint
:= Expr_Value
(Right
);
3086 Typ
: constant Entity_Id
:= Etype
(N
);
3089 -- Negation is equivalent to subtracting from the modulus minus one.
3090 -- For a binary modulus this is equivalent to the ones-complement of
3091 -- the original value. For a nonbinary modulus this is an arbitrary
3092 -- but consistent definition.
3094 if Is_Modular_Integer_Type
(Typ
) then
3095 Fold_Uint
(N
, Modulus
(Typ
) - 1 - Rint
, Stat
);
3096 else pragma Assert
(Is_Boolean_Type
(Typ
));
3097 Fold_Uint
(N
, Test
(not Is_True
(Rint
)), Stat
);
3100 Set_Is_Static_Expression
(N
, Stat
);
3104 -------------------------------
3105 -- Eval_Qualified_Expression --
3106 -------------------------------
3108 -- A qualified expression is potentially static if its subtype mark denotes
3109 -- a static subtype and its expression is potentially static (RM 4.9 (11)).
3111 procedure Eval_Qualified_Expression
(N
: Node_Id
) is
3112 Operand
: constant Node_Id
:= Expression
(N
);
3113 Target_Type
: constant Entity_Id
:= Entity
(Subtype_Mark
(N
));
3120 -- Can only fold if target is string or scalar and subtype is static.
3121 -- Also, do not fold if our parent is an allocator (this is because the
3122 -- qualified expression is really part of the syntactic structure of an
3123 -- allocator, and we do not want to end up with something that
3124 -- corresponds to "new 1" where the 1 is the result of folding a
3125 -- qualified expression).
3127 if not Is_Static_Subtype
(Target_Type
)
3128 or else Nkind
(Parent
(N
)) = N_Allocator
3130 Check_Non_Static_Context
(Operand
);
3132 -- If operand is known to raise constraint_error, set the flag on the
3133 -- expression so it does not get optimized away.
3135 if Nkind
(Operand
) = N_Raise_Constraint_Error
then
3136 Set_Raises_Constraint_Error
(N
);
3142 -- If not foldable we are done
3144 Test_Expression_Is_Foldable
(N
, Operand
, Stat
, Fold
);
3149 -- Don't try fold if target type has Constraint_Error bounds
3151 elsif not Is_OK_Static_Subtype
(Target_Type
) then
3152 Set_Raises_Constraint_Error
(N
);
3156 -- Here we will fold, save Print_In_Hex indication
3158 Hex
:= Nkind
(Operand
) = N_Integer_Literal
3159 and then Print_In_Hex
(Operand
);
3161 -- Fold the result of qualification
3163 if Is_Discrete_Type
(Target_Type
) then
3164 Fold_Uint
(N
, Expr_Value
(Operand
), Stat
);
3166 -- Preserve Print_In_Hex indication
3168 if Hex
and then Nkind
(N
) = N_Integer_Literal
then
3169 Set_Print_In_Hex
(N
);
3172 elsif Is_Real_Type
(Target_Type
) then
3173 Fold_Ureal
(N
, Expr_Value_R
(Operand
), Stat
);
3176 Fold_Str
(N
, Strval
(Get_String_Val
(Operand
)), Stat
);
3179 Set_Is_Static_Expression
(N
, False);
3181 Check_String_Literal_Length
(N
, Target_Type
);
3187 -- The expression may be foldable but not static
3189 Set_Is_Static_Expression
(N
, Stat
);
3191 if Is_Out_Of_Range
(N
, Etype
(N
), Assume_Valid
=> True) then
3194 end Eval_Qualified_Expression
;
3196 -----------------------
3197 -- Eval_Real_Literal --
3198 -----------------------
3200 -- Numeric literals are static (RM 4.9(1)), and have already been marked
3201 -- as static by the analyzer. The reason we did it that early is to allow
3202 -- the possibility of turning off the Is_Static_Expression flag after
3203 -- analysis, but before resolution, when integer literals are generated
3204 -- in the expander that do not correspond to static expressions.
3206 procedure Eval_Real_Literal
(N
: Node_Id
) is
3207 PK
: constant Node_Kind
:= Nkind
(Parent
(N
));
3210 -- If the literal appears in a non-expression context and not as part of
3211 -- a number declaration, then it is appearing in a non-static context,
3214 if PK
not in N_Subexpr
and then PK
/= N_Number_Declaration
then
3215 Check_Non_Static_Context
(N
);
3217 end Eval_Real_Literal
;
3219 ------------------------
3220 -- Eval_Relational_Op --
3221 ------------------------
3223 -- Relational operations are static functions, so the result is static if
3224 -- both operands are static (RM 4.9(7), 4.9(20)), except that for strings,
3225 -- the result is never static, even if the operands are.
3227 -- However, for internally generated nodes, we allow string equality and
3228 -- inequality to be static. This is because we rewrite A in "ABC" as an
3229 -- equality test A = "ABC", and the former is definitely static.
3231 procedure Eval_Relational_Op
(N
: Node_Id
) is
3232 Left
: constant Node_Id
:= Left_Opnd
(N
);
3233 Right
: constant Node_Id
:= Right_Opnd
(N
);
3235 procedure Decompose_Expr
3237 Ent
: out Entity_Id
;
3238 Kind
: out Character;
3240 Orig
: Boolean := True);
3241 -- Given expression Expr, see if it is of the form X [+/- K]. If so, Ent
3242 -- is set to the entity in X, Kind is 'F','L','E' for 'First or 'Last or
3243 -- simple entity, and Cons is the value of K. If the expression is not
3244 -- of the required form, Ent is set to Empty.
3246 -- Orig indicates whether Expr is the original expression to consider,
3247 -- or if we are handling a subexpression (e.g. recursive call to
3250 procedure Fold_General_Op
(Is_Static
: Boolean);
3251 -- Attempt to fold arbitrary relational operator N. Flag Is_Static must
3252 -- be set when the operator denotes a static expression.
3254 procedure Fold_Static_Real_Op
;
3255 -- Attempt to fold static real type relational operator N
3257 function Static_Length
(Expr
: Node_Id
) return Uint
;
3258 -- If Expr is an expression for a constrained array whose length is
3259 -- known at compile time, return the non-negative length, otherwise
3262 --------------------
3263 -- Decompose_Expr --
3264 --------------------
3266 procedure Decompose_Expr
3268 Ent
: out Entity_Id
;
3269 Kind
: out Character;
3271 Orig
: Boolean := True)
3276 -- Assume that the expression does not meet the expected form
3282 if Nkind
(Expr
) = N_Op_Add
3283 and then Compile_Time_Known_Value
(Right_Opnd
(Expr
))
3285 Exp
:= Left_Opnd
(Expr
);
3286 Cons
:= Expr_Value
(Right_Opnd
(Expr
));
3288 elsif Nkind
(Expr
) = N_Op_Subtract
3289 and then Compile_Time_Known_Value
(Right_Opnd
(Expr
))
3291 Exp
:= Left_Opnd
(Expr
);
3292 Cons
:= -Expr_Value
(Right_Opnd
(Expr
));
3294 -- If the bound is a constant created to remove side effects, recover
3295 -- the original expression to see if it has one of the recognizable
3298 elsif Nkind
(Expr
) = N_Identifier
3299 and then not Comes_From_Source
(Entity
(Expr
))
3300 and then Ekind
(Entity
(Expr
)) = E_Constant
3301 and then Nkind
(Parent
(Entity
(Expr
))) = N_Object_Declaration
3303 Exp
:= Expression
(Parent
(Entity
(Expr
)));
3304 Decompose_Expr
(Exp
, Ent
, Kind
, Cons
, Orig
=> False);
3306 -- If original expression includes an entity, create a reference
3307 -- to it for use below.
3309 if Present
(Ent
) then
3310 Exp
:= New_Occurrence_Of
(Ent
, Sloc
(Ent
));
3316 -- Only consider the case of X + 0 for a full expression, and
3317 -- not when recursing, otherwise we may end up with evaluating
3318 -- expressions not known at compile time to 0.
3328 -- At this stage Exp is set to the potential X
3330 if Nkind
(Exp
) = N_Attribute_Reference
then
3331 if Attribute_Name
(Exp
) = Name_First
then
3333 elsif Attribute_Name
(Exp
) = Name_Last
then
3339 Exp
:= Prefix
(Exp
);
3345 if Is_Entity_Name
(Exp
) and then Present
(Entity
(Exp
)) then
3346 Ent
:= Entity
(Exp
);
3350 ---------------------
3351 -- Fold_General_Op --
3352 ---------------------
3354 procedure Fold_General_Op
(Is_Static
: Boolean) is
3355 CR
: constant Compare_Result
:=
3356 Compile_Time_Compare
(Left
, Right
, Assume_Valid
=> False);
3361 if CR
= Unknown
then
3369 elsif CR
= NE
or else CR
= GT
or else CR
= LT
then
3376 if CR
= GT
or else CR
= EQ
or else CR
= GE
then
3387 elsif CR
= EQ
or else CR
= LT
or else CR
= LE
then
3394 if CR
= LT
or else CR
= EQ
or else CR
= LE
then
3405 elsif CR
= EQ
or else CR
= GT
or else CR
= GE
then
3412 if CR
= NE
or else CR
= GT
or else CR
= LT
then
3421 raise Program_Error
;
3424 -- Determine the potential outcome of the relation assuming the
3425 -- operands are valid and emit a warning when the relation yields
3426 -- True or False only in the presence of invalid values.
3428 Warn_On_Constant_Valid_Condition
(N
);
3430 Fold_Uint
(N
, Test
(Result
), Is_Static
);
3431 end Fold_General_Op
;
3433 -------------------------
3434 -- Fold_Static_Real_Op --
3435 -------------------------
3437 procedure Fold_Static_Real_Op
is
3438 Left_Real
: constant Ureal
:= Expr_Value_R
(Left
);
3439 Right_Real
: constant Ureal
:= Expr_Value_R
(Right
);
3444 when N_Op_Eq
=> Result
:= (Left_Real
= Right_Real
);
3445 when N_Op_Ge
=> Result
:= (Left_Real
>= Right_Real
);
3446 when N_Op_Gt
=> Result
:= (Left_Real
> Right_Real
);
3447 when N_Op_Le
=> Result
:= (Left_Real
<= Right_Real
);
3448 when N_Op_Lt
=> Result
:= (Left_Real
< Right_Real
);
3449 when N_Op_Ne
=> Result
:= (Left_Real
/= Right_Real
);
3450 when others => raise Program_Error
;
3453 Fold_Uint
(N
, Test
(Result
), True);
3454 end Fold_Static_Real_Op
;
3460 function Static_Length
(Expr
: Node_Id
) return Uint
is
3470 -- First easy case string literal
3472 if Nkind
(Expr
) = N_String_Literal
then
3473 return UI_From_Int
(String_Length
(Strval
(Expr
)));
3475 -- With frontend inlining as performed in GNATprove mode, a variable
3476 -- may be inserted that has a string literal subtype. Deal with this
3477 -- specially as for the previous case.
3479 elsif Ekind
(Etype
(Expr
)) = E_String_Literal_Subtype
then
3480 return String_Literal_Length
(Etype
(Expr
));
3482 -- Second easy case, not constrained subtype, so no length
3484 elsif not Is_Constrained
(Etype
(Expr
)) then
3485 return Uint_Minus_1
;
3490 Typ
:= Etype
(First_Index
(Etype
(Expr
)));
3492 -- The simple case, both bounds are known at compile time
3494 if Is_Discrete_Type
(Typ
)
3495 and then Compile_Time_Known_Value
(Type_Low_Bound
(Typ
))
3496 and then Compile_Time_Known_Value
(Type_High_Bound
(Typ
))
3499 UI_Max
(Uint_0
, Expr_Value
(Type_High_Bound
(Typ
)) -
3500 Expr_Value
(Type_Low_Bound
(Typ
)) + 1);
3503 -- A more complex case, where the bounds are of the form X [+/- K1]
3504 -- .. X [+/- K2]), where X is an expression that is either A'First or
3505 -- A'Last (with A an entity name), or X is an entity name, and the
3506 -- two X's are the same and K1 and K2 are known at compile time, in
3507 -- this case, the length can also be computed at compile time, even
3508 -- though the bounds are not known. A common case of this is e.g.
3509 -- (X'First .. X'First+5).
3512 (Original_Node
(Type_Low_Bound
(Typ
)), Ent1
, Kind1
, Cons1
);
3514 (Original_Node
(Type_High_Bound
(Typ
)), Ent2
, Kind2
, Cons2
);
3516 if Present
(Ent1
) and then Ent1
= Ent2
and then Kind1
= Kind2
then
3517 return Cons2
- Cons1
+ 1;
3519 return Uint_Minus_1
;
3525 Left_Typ
: constant Entity_Id
:= Etype
(Left
);
3526 Right_Typ
: constant Entity_Id
:= Etype
(Right
);
3529 Op_Typ
: Entity_Id
:= Empty
;
3532 Is_Static_Expression
: Boolean;
3534 -- Start of processing for Eval_Relational_Op
3537 -- One special case to deal with first. If we can tell that the result
3538 -- will be false because the lengths of one or more index subtypes are
3539 -- compile-time known and different, then we can replace the entire
3540 -- result by False. We only do this for one-dimensional arrays, because
3541 -- the case of multidimensional arrays is rare and too much trouble. If
3542 -- one of the operands is an illegal aggregate, its type might still be
3543 -- an arbitrary composite type, so nothing to do.
3545 if Is_Array_Type
(Left_Typ
)
3546 and then Left_Typ
/= Any_Composite
3547 and then Number_Dimensions
(Left_Typ
) = 1
3548 and then Nkind_In
(N
, N_Op_Eq
, N_Op_Ne
)
3550 if Raises_Constraint_Error
(Left
)
3552 Raises_Constraint_Error
(Right
)
3556 -- OK, we have the case where we may be able to do this fold
3559 Left_Len
:= Static_Length
(Left
);
3560 Right_Len
:= Static_Length
(Right
);
3562 if Left_Len
/= Uint_Minus_1
3563 and then Right_Len
/= Uint_Minus_1
3564 and then Left_Len
/= Right_Len
3566 Fold_Uint
(N
, Test
(Nkind
(N
) = N_Op_Ne
), False);
3567 Warn_On_Known_Condition
(N
);
3575 -- Initialize the value of Is_Static_Expression. The value of Fold
3576 -- returned by Test_Expression_Is_Foldable is not needed since, even
3577 -- when some operand is a variable, we can still perform the static
3578 -- evaluation of the expression in some cases (for example, for a
3579 -- variable of a subtype of Integer we statically know that any value
3580 -- stored in such variable is smaller than Integer'Last).
3582 Test_Expression_Is_Foldable
3583 (N
, Left
, Right
, Is_Static_Expression
, Fold
);
3585 -- Only comparisons of scalars can give static results. A comparison
3586 -- of strings never yields a static result, even if both operands are
3587 -- static strings, except that as noted above, we allow equality and
3588 -- inequality for strings.
3590 if Is_String_Type
(Left_Typ
)
3591 and then not Comes_From_Source
(N
)
3592 and then Nkind_In
(N
, N_Op_Eq
, N_Op_Ne
)
3596 elsif not Is_Scalar_Type
(Left_Typ
) then
3597 Is_Static_Expression
:= False;
3598 Set_Is_Static_Expression
(N
, False);
3601 -- For operators on universal numeric types called as functions with
3602 -- an explicit scope, determine appropriate specific numeric type,
3603 -- and diagnose possible ambiguity.
3605 if Is_Universal_Numeric_Type
(Left_Typ
)
3607 Is_Universal_Numeric_Type
(Right_Typ
)
3609 Op_Typ
:= Find_Universal_Operator_Type
(N
);
3612 -- Attempt to fold the relational operator
3614 if Is_Static_Expression
and then Is_Real_Type
(Left_Typ
) then
3615 Fold_Static_Real_Op
;
3617 Fold_General_Op
(Is_Static_Expression
);
3621 -- For the case of a folded relational operator on a specific numeric
3622 -- type, freeze the operand type now.
3624 if Present
(Op_Typ
) then
3625 Freeze_Before
(N
, Op_Typ
);
3628 Warn_On_Known_Condition
(N
);
3629 end Eval_Relational_Op
;
3635 -- Shift operations are intrinsic operations that can never be static, so
3636 -- the only processing required is to perform the required check for a non
3637 -- static context for the two operands.
3639 -- Actually we could do some compile time evaluation here some time ???
3641 procedure Eval_Shift
(N
: Node_Id
) is
3643 Check_Non_Static_Context
(Left_Opnd
(N
));
3644 Check_Non_Static_Context
(Right_Opnd
(N
));
3647 ------------------------
3648 -- Eval_Short_Circuit --
3649 ------------------------
3651 -- A short circuit operation is potentially static if both operands are
3652 -- potentially static (RM 4.9 (13)).
3654 procedure Eval_Short_Circuit
(N
: Node_Id
) is
3655 Kind
: constant Node_Kind
:= Nkind
(N
);
3656 Left
: constant Node_Id
:= Left_Opnd
(N
);
3657 Right
: constant Node_Id
:= Right_Opnd
(N
);
3660 Rstat
: constant Boolean :=
3661 Is_Static_Expression
(Left
)
3663 Is_Static_Expression
(Right
);
3666 -- Short circuit operations are never static in Ada 83
3668 if Ada_Version
= Ada_83
and then Comes_From_Source
(N
) then
3669 Check_Non_Static_Context
(Left
);
3670 Check_Non_Static_Context
(Right
);
3674 -- Now look at the operands, we can't quite use the normal call to
3675 -- Test_Expression_Is_Foldable here because short circuit operations
3676 -- are a special case, they can still be foldable, even if the right
3677 -- operand raises Constraint_Error.
3679 -- If either operand is Any_Type, just propagate to result and do not
3680 -- try to fold, this prevents cascaded errors.
3682 if Etype
(Left
) = Any_Type
or else Etype
(Right
) = Any_Type
then
3683 Set_Etype
(N
, Any_Type
);
3686 -- If left operand raises Constraint_Error, then replace node N with
3687 -- the raise Constraint_Error node, and we are obviously not foldable.
3688 -- Is_Static_Expression is set from the two operands in the normal way,
3689 -- and we check the right operand if it is in a non-static context.
3691 elsif Raises_Constraint_Error
(Left
) then
3693 Check_Non_Static_Context
(Right
);
3696 Rewrite_In_Raise_CE
(N
, Left
);
3697 Set_Is_Static_Expression
(N
, Rstat
);
3700 -- If the result is not static, then we won't in any case fold
3702 elsif not Rstat
then
3703 Check_Non_Static_Context
(Left
);
3704 Check_Non_Static_Context
(Right
);
3708 -- Here the result is static, note that, unlike the normal processing
3709 -- in Test_Expression_Is_Foldable, we did *not* check above to see if
3710 -- the right operand raises Constraint_Error, that's because it is not
3711 -- significant if the left operand is decisive.
3713 Set_Is_Static_Expression
(N
);
3715 -- It does not matter if the right operand raises Constraint_Error if
3716 -- it will not be evaluated. So deal specially with the cases where
3717 -- the right operand is not evaluated. Note that we will fold these
3718 -- cases even if the right operand is non-static, which is fine, but
3719 -- of course in these cases the result is not potentially static.
3721 Left_Int
:= Expr_Value
(Left
);
3723 if (Kind
= N_And_Then
and then Is_False
(Left_Int
))
3725 (Kind
= N_Or_Else
and then Is_True
(Left_Int
))
3727 Fold_Uint
(N
, Left_Int
, Rstat
);
3731 -- If first operand not decisive, then it does matter if the right
3732 -- operand raises Constraint_Error, since it will be evaluated, so
3733 -- we simply replace the node with the right operand. Note that this
3734 -- properly propagates Is_Static_Expression and Raises_Constraint_Error
3735 -- (both are set to True in Right).
3737 if Raises_Constraint_Error
(Right
) then
3738 Rewrite_In_Raise_CE
(N
, Right
);
3739 Check_Non_Static_Context
(Left
);
3743 -- Otherwise the result depends on the right operand
3745 Fold_Uint
(N
, Expr_Value
(Right
), Rstat
);
3747 end Eval_Short_Circuit
;
3753 -- Slices can never be static, so the only processing required is to check
3754 -- for non-static context if an explicit range is given.
3756 procedure Eval_Slice
(N
: Node_Id
) is
3757 Drange
: constant Node_Id
:= Discrete_Range
(N
);
3760 if Nkind
(Drange
) = N_Range
then
3761 Check_Non_Static_Context
(Low_Bound
(Drange
));
3762 Check_Non_Static_Context
(High_Bound
(Drange
));
3765 -- A slice of the form A (subtype), when the subtype is the index of
3766 -- the type of A, is redundant, the slice can be replaced with A, and
3767 -- this is worth a warning.
3769 if Is_Entity_Name
(Prefix
(N
)) then
3771 E
: constant Entity_Id
:= Entity
(Prefix
(N
));
3772 T
: constant Entity_Id
:= Etype
(E
);
3775 if Ekind
(E
) = E_Constant
3776 and then Is_Array_Type
(T
)
3777 and then Is_Entity_Name
(Drange
)
3779 if Is_Entity_Name
(Original_Node
(First_Index
(T
)))
3780 and then Entity
(Original_Node
(First_Index
(T
)))
3783 if Warn_On_Redundant_Constructs
then
3784 Error_Msg_N
("redundant slice denotes whole array?r?", N
);
3787 -- The following might be a useful optimization???
3789 -- Rewrite (N, New_Occurrence_Of (E, Sloc (N)));
3796 -------------------------
3797 -- Eval_String_Literal --
3798 -------------------------
3800 procedure Eval_String_Literal
(N
: Node_Id
) is
3801 Typ
: constant Entity_Id
:= Etype
(N
);
3802 Bas
: constant Entity_Id
:= Base_Type
(Typ
);
3808 -- Nothing to do if error type (handles cases like default expressions
3809 -- or generics where we have not yet fully resolved the type).
3811 if Bas
= Any_Type
or else Bas
= Any_String
then
3815 -- String literals are static if the subtype is static (RM 4.9(2)), so
3816 -- reset the static expression flag (it was set unconditionally in
3817 -- Analyze_String_Literal) if the subtype is non-static. We tell if
3818 -- the subtype is static by looking at the lower bound.
3820 if Ekind
(Typ
) = E_String_Literal_Subtype
then
3821 if not Is_OK_Static_Expression
(String_Literal_Low_Bound
(Typ
)) then
3822 Set_Is_Static_Expression
(N
, False);
3826 -- Here if Etype of string literal is normal Etype (not yet possible,
3827 -- but may be possible in future).
3829 elsif not Is_OK_Static_Expression
3830 (Type_Low_Bound
(Etype
(First_Index
(Typ
))))
3832 Set_Is_Static_Expression
(N
, False);
3836 -- If original node was a type conversion, then result if non-static
3838 if Nkind
(Original_Node
(N
)) = N_Type_Conversion
then
3839 Set_Is_Static_Expression
(N
, False);
3843 -- Test for illegal Ada 95 cases. A string literal is illegal in Ada 95
3844 -- if its bounds are outside the index base type and this index type is
3845 -- static. This can happen in only two ways. Either the string literal
3846 -- is too long, or it is null, and the lower bound is type'First. Either
3847 -- way it is the upper bound that is out of range of the index type.
3849 if Ada_Version
>= Ada_95
then
3850 if Is_Standard_String_Type
(Bas
) then
3851 Xtp
:= Standard_Positive
;
3853 Xtp
:= Etype
(First_Index
(Bas
));
3856 if Ekind
(Typ
) = E_String_Literal_Subtype
then
3857 Lo
:= String_Literal_Low_Bound
(Typ
);
3859 Lo
:= Type_Low_Bound
(Etype
(First_Index
(Typ
)));
3862 -- Check for string too long
3864 Len
:= String_Length
(Strval
(N
));
3866 if UI_From_Int
(Len
) > String_Type_Len
(Bas
) then
3868 -- Issue message. Note that this message is a warning if the
3869 -- string literal is not marked as static (happens in some cases
3870 -- of folding strings known at compile time, but not static).
3871 -- Furthermore in such cases, we reword the message, since there
3872 -- is no string literal in the source program.
3874 if Is_Static_Expression
(N
) then
3875 Apply_Compile_Time_Constraint_Error
3876 (N
, "string literal too long for}", CE_Length_Check_Failed
,
3878 Typ
=> First_Subtype
(Bas
));
3880 Apply_Compile_Time_Constraint_Error
3881 (N
, "string value too long for}", CE_Length_Check_Failed
,
3883 Typ
=> First_Subtype
(Bas
),
3887 -- Test for null string not allowed
3890 and then not Is_Generic_Type
(Xtp
)
3892 Expr_Value
(Lo
) = Expr_Value
(Type_Low_Bound
(Base_Type
(Xtp
)))
3894 -- Same specialization of message
3896 if Is_Static_Expression
(N
) then
3897 Apply_Compile_Time_Constraint_Error
3898 (N
, "null string literal not allowed for}",
3899 CE_Length_Check_Failed
,
3901 Typ
=> First_Subtype
(Bas
));
3903 Apply_Compile_Time_Constraint_Error
3904 (N
, "null string value not allowed for}",
3905 CE_Length_Check_Failed
,
3907 Typ
=> First_Subtype
(Bas
),
3912 end Eval_String_Literal
;
3914 --------------------------
3915 -- Eval_Type_Conversion --
3916 --------------------------
3918 -- A type conversion is potentially static if its subtype mark is for a
3919 -- static scalar subtype, and its operand expression is potentially static
3922 procedure Eval_Type_Conversion
(N
: Node_Id
) is
3923 Operand
: constant Node_Id
:= Expression
(N
);
3924 Source_Type
: constant Entity_Id
:= Etype
(Operand
);
3925 Target_Type
: constant Entity_Id
:= Etype
(N
);
3927 function To_Be_Treated_As_Integer
(T
: Entity_Id
) return Boolean;
3928 -- Returns true if type T is an integer type, or if it is a fixed-point
3929 -- type to be treated as an integer (i.e. the flag Conversion_OK is set
3930 -- on the conversion node).
3932 function To_Be_Treated_As_Real
(T
: Entity_Id
) return Boolean;
3933 -- Returns true if type T is a floating-point type, or if it is a
3934 -- fixed-point type that is not to be treated as an integer (i.e. the
3935 -- flag Conversion_OK is not set on the conversion node).
3937 ------------------------------
3938 -- To_Be_Treated_As_Integer --
3939 ------------------------------
3941 function To_Be_Treated_As_Integer
(T
: Entity_Id
) return Boolean is
3945 or else (Is_Fixed_Point_Type
(T
) and then Conversion_OK
(N
));
3946 end To_Be_Treated_As_Integer
;
3948 ---------------------------
3949 -- To_Be_Treated_As_Real --
3950 ---------------------------
3952 function To_Be_Treated_As_Real
(T
: Entity_Id
) return Boolean is
3955 Is_Floating_Point_Type
(T
)
3956 or else (Is_Fixed_Point_Type
(T
) and then not Conversion_OK
(N
));
3957 end To_Be_Treated_As_Real
;
3964 -- Start of processing for Eval_Type_Conversion
3967 -- Cannot fold if target type is non-static or if semantic error
3969 if not Is_Static_Subtype
(Target_Type
) then
3970 Check_Non_Static_Context
(Operand
);
3972 elsif Error_Posted
(N
) then
3976 -- If not foldable we are done
3978 Test_Expression_Is_Foldable
(N
, Operand
, Stat
, Fold
);
3983 -- Don't try fold if target type has Constraint_Error bounds
3985 elsif not Is_OK_Static_Subtype
(Target_Type
) then
3986 Set_Raises_Constraint_Error
(N
);
3990 -- Remaining processing depends on operand types. Note that in the
3991 -- following type test, fixed-point counts as real unless the flag
3992 -- Conversion_OK is set, in which case it counts as integer.
3994 -- Fold conversion, case of string type. The result is not static
3996 if Is_String_Type
(Target_Type
) then
3997 Fold_Str
(N
, Strval
(Get_String_Val
(Operand
)), Static
=> False);
4000 -- Fold conversion, case of integer target type
4002 elsif To_Be_Treated_As_Integer
(Target_Type
) then
4007 -- Integer to integer conversion
4009 if To_Be_Treated_As_Integer
(Source_Type
) then
4010 Result
:= Expr_Value
(Operand
);
4012 -- Real to integer conversion
4015 Result
:= UR_To_Uint
(Expr_Value_R
(Operand
));
4018 -- If fixed-point type (Conversion_OK must be set), then the
4019 -- result is logically an integer, but we must replace the
4020 -- conversion with the corresponding real literal, since the
4021 -- type from a semantic point of view is still fixed-point.
4023 if Is_Fixed_Point_Type
(Target_Type
) then
4025 (N
, UR_From_Uint
(Result
) * Small_Value
(Target_Type
), Stat
);
4027 -- Otherwise result is integer literal
4030 Fold_Uint
(N
, Result
, Stat
);
4034 -- Fold conversion, case of real target type
4036 elsif To_Be_Treated_As_Real
(Target_Type
) then
4041 if To_Be_Treated_As_Real
(Source_Type
) then
4042 Result
:= Expr_Value_R
(Operand
);
4044 Result
:= UR_From_Uint
(Expr_Value
(Operand
));
4047 Fold_Ureal
(N
, Result
, Stat
);
4050 -- Enumeration types
4053 Fold_Uint
(N
, Expr_Value
(Operand
), Stat
);
4056 if Is_Out_Of_Range
(N
, Etype
(N
), Assume_Valid
=> True) then
4060 end Eval_Type_Conversion
;
4066 -- Predefined unary operators are static functions (RM 4.9(20)) and thus
4067 -- are potentially static if the operand is potentially static (RM 4.9(7)).
4069 procedure Eval_Unary_Op
(N
: Node_Id
) is
4070 Right
: constant Node_Id
:= Right_Opnd
(N
);
4071 Otype
: Entity_Id
:= Empty
;
4076 -- If not foldable we are done
4078 Test_Expression_Is_Foldable
(N
, Right
, Stat
, Fold
);
4084 if Etype
(Right
) = Universal_Integer
4086 Etype
(Right
) = Universal_Real
4088 Otype
:= Find_Universal_Operator_Type
(N
);
4091 -- Fold for integer case
4093 if Is_Integer_Type
(Etype
(N
)) then
4095 Rint
: constant Uint
:= Expr_Value
(Right
);
4099 -- In the case of modular unary plus and abs there is no need
4100 -- to adjust the result of the operation since if the original
4101 -- operand was in bounds the result will be in the bounds of the
4102 -- modular type. However, in the case of modular unary minus the
4103 -- result may go out of the bounds of the modular type and needs
4106 if Nkind
(N
) = N_Op_Plus
then
4109 elsif Nkind
(N
) = N_Op_Minus
then
4110 if Is_Modular_Integer_Type
(Etype
(N
)) then
4111 Result
:= (-Rint
) mod Modulus
(Etype
(N
));
4117 pragma Assert
(Nkind
(N
) = N_Op_Abs
);
4121 Fold_Uint
(N
, Result
, Stat
);
4124 -- Fold for real case
4126 elsif Is_Real_Type
(Etype
(N
)) then
4128 Rreal
: constant Ureal
:= Expr_Value_R
(Right
);
4132 if Nkind
(N
) = N_Op_Plus
then
4134 elsif Nkind
(N
) = N_Op_Minus
then
4135 Result
:= UR_Negate
(Rreal
);
4137 pragma Assert
(Nkind
(N
) = N_Op_Abs
);
4138 Result
:= abs Rreal
;
4141 Fold_Ureal
(N
, Result
, Stat
);
4145 -- If the operator was resolved to a specific type, make sure that type
4146 -- is frozen even if the expression is folded into a literal (which has
4147 -- a universal type).
4149 if Present
(Otype
) then
4150 Freeze_Before
(N
, Otype
);
4154 -------------------------------
4155 -- Eval_Unchecked_Conversion --
4156 -------------------------------
4158 -- Unchecked conversions can never be static, so the only required
4159 -- processing is to check for a non-static context for the operand.
4161 procedure Eval_Unchecked_Conversion
(N
: Node_Id
) is
4163 Check_Non_Static_Context
(Expression
(N
));
4164 end Eval_Unchecked_Conversion
;
4166 --------------------
4167 -- Expr_Rep_Value --
4168 --------------------
4170 function Expr_Rep_Value
(N
: Node_Id
) return Uint
is
4171 Kind
: constant Node_Kind
:= Nkind
(N
);
4175 if Is_Entity_Name
(N
) then
4178 -- An enumeration literal that was either in the source or created
4179 -- as a result of static evaluation.
4181 if Ekind
(Ent
) = E_Enumeration_Literal
then
4182 return Enumeration_Rep
(Ent
);
4184 -- A user defined static constant
4187 pragma Assert
(Ekind
(Ent
) = E_Constant
);
4188 return Expr_Rep_Value
(Constant_Value
(Ent
));
4191 -- An integer literal that was either in the source or created as a
4192 -- result of static evaluation.
4194 elsif Kind
= N_Integer_Literal
then
4197 -- A real literal for a fixed-point type. This must be the fixed-point
4198 -- case, either the literal is of a fixed-point type, or it is a bound
4199 -- of a fixed-point type, with type universal real. In either case we
4200 -- obtain the desired value from Corresponding_Integer_Value.
4202 elsif Kind
= N_Real_Literal
then
4203 pragma Assert
(Is_Fixed_Point_Type
(Underlying_Type
(Etype
(N
))));
4204 return Corresponding_Integer_Value
(N
);
4206 -- Otherwise must be character literal
4209 pragma Assert
(Kind
= N_Character_Literal
);
4212 -- Since Character literals of type Standard.Character don't have any
4213 -- defining character literals built for them, they do not have their
4214 -- Entity set, so just use their Char code. Otherwise for user-
4215 -- defined character literals use their Pos value as usual which is
4216 -- the same as the Rep value.
4219 return Char_Literal_Value
(N
);
4221 return Enumeration_Rep
(Ent
);
4230 function Expr_Value
(N
: Node_Id
) return Uint
is
4231 Kind
: constant Node_Kind
:= Nkind
(N
);
4232 CV_Ent
: CV_Entry
renames CV_Cache
(Nat
(N
) mod CV_Cache_Size
);
4237 -- If already in cache, then we know it's compile-time-known and we can
4238 -- return the value that was previously stored in the cache since
4239 -- compile-time-known values cannot change.
4241 if CV_Ent
.N
= N
then
4245 -- Otherwise proceed to test value
4247 if Is_Entity_Name
(N
) then
4250 -- An enumeration literal that was either in the source or created as
4251 -- a result of static evaluation.
4253 if Ekind
(Ent
) = E_Enumeration_Literal
then
4254 Val
:= Enumeration_Pos
(Ent
);
4256 -- A user defined static constant
4259 pragma Assert
(Ekind
(Ent
) = E_Constant
);
4260 Val
:= Expr_Value
(Constant_Value
(Ent
));
4263 -- An integer literal that was either in the source or created as a
4264 -- result of static evaluation.
4266 elsif Kind
= N_Integer_Literal
then
4269 -- A real literal for a fixed-point type. This must be the fixed-point
4270 -- case, either the literal is of a fixed-point type, or it is a bound
4271 -- of a fixed-point type, with type universal real. In either case we
4272 -- obtain the desired value from Corresponding_Integer_Value.
4274 elsif Kind
= N_Real_Literal
then
4275 pragma Assert
(Is_Fixed_Point_Type
(Underlying_Type
(Etype
(N
))));
4276 Val
:= Corresponding_Integer_Value
(N
);
4278 -- The NULL access value
4280 elsif Kind
= N_Null
then
4281 pragma Assert
(Is_Access_Type
(Underlying_Type
(Etype
(N
)))
4282 or else Error_Posted
(N
));
4285 -- Character literal
4287 elsif Kind
= N_Character_Literal
then
4290 -- Since Character literals of type Standard.Character don't
4291 -- have any defining character literals built for them, they
4292 -- do not have their Entity set, so just use their Char
4293 -- code. Otherwise for user-defined character literals use
4294 -- their Pos value as usual.
4297 Val
:= Char_Literal_Value
(N
);
4299 Val
:= Enumeration_Pos
(Ent
);
4302 -- Unchecked conversion, which can come from System'To_Address (X)
4303 -- where X is a static integer expression. Recursively evaluate X.
4305 elsif Kind
= N_Unchecked_Type_Conversion
then
4306 Val
:= Expr_Value
(Expression
(N
));
4309 raise Program_Error
;
4312 -- Come here with Val set to value to be returned, set cache
4323 function Expr_Value_E
(N
: Node_Id
) return Entity_Id
is
4324 Ent
: constant Entity_Id
:= Entity
(N
);
4326 if Ekind
(Ent
) = E_Enumeration_Literal
then
4329 pragma Assert
(Ekind
(Ent
) = E_Constant
);
4331 -- We may be dealing with a enumerated character type constant, so
4332 -- handle that case here.
4334 if Nkind
(Constant_Value
(Ent
)) = N_Character_Literal
then
4337 return Expr_Value_E
(Constant_Value
(Ent
));
4346 function Expr_Value_R
(N
: Node_Id
) return Ureal
is
4347 Kind
: constant Node_Kind
:= Nkind
(N
);
4351 if Kind
= N_Real_Literal
then
4354 elsif Kind
= N_Identifier
or else Kind
= N_Expanded_Name
then
4356 pragma Assert
(Ekind
(Ent
) = E_Constant
);
4357 return Expr_Value_R
(Constant_Value
(Ent
));
4359 elsif Kind
= N_Integer_Literal
then
4360 return UR_From_Uint
(Expr_Value
(N
));
4362 -- Here, we have a node that cannot be interpreted as a compile time
4363 -- constant. That is definitely an error.
4366 raise Program_Error
;
4374 function Expr_Value_S
(N
: Node_Id
) return Node_Id
is
4376 if Nkind
(N
) = N_String_Literal
then
4379 pragma Assert
(Ekind
(Entity
(N
)) = E_Constant
);
4380 return Expr_Value_S
(Constant_Value
(Entity
(N
)));
4384 ----------------------------------
4385 -- Find_Universal_Operator_Type --
4386 ----------------------------------
4388 function Find_Universal_Operator_Type
(N
: Node_Id
) return Entity_Id
is
4389 PN
: constant Node_Id
:= Parent
(N
);
4390 Call
: constant Node_Id
:= Original_Node
(N
);
4391 Is_Int
: constant Boolean := Is_Integer_Type
(Etype
(N
));
4393 Is_Fix
: constant Boolean :=
4394 Nkind
(N
) in N_Binary_Op
4395 and then Nkind
(Right_Opnd
(N
)) /= Nkind
(Left_Opnd
(N
));
4396 -- A mixed-mode operation in this context indicates the presence of
4397 -- fixed-point type in the designated package.
4399 Is_Relational
: constant Boolean := Etype
(N
) = Standard_Boolean
;
4400 -- Case where N is a relational (or membership) operator (else it is an
4403 In_Membership
: constant Boolean :=
4404 Nkind
(PN
) in N_Membership_Test
4406 Nkind
(Right_Opnd
(PN
)) = N_Range
4408 Is_Universal_Numeric_Type
(Etype
(Left_Opnd
(PN
)))
4410 Is_Universal_Numeric_Type
4411 (Etype
(Low_Bound
(Right_Opnd
(PN
))))
4413 Is_Universal_Numeric_Type
4414 (Etype
(High_Bound
(Right_Opnd
(PN
))));
4415 -- Case where N is part of a membership test with a universal range
4419 Typ1
: Entity_Id
:= Empty
;
4422 function Is_Mixed_Mode_Operand
(Op
: Node_Id
) return Boolean;
4423 -- Check whether one operand is a mixed-mode operation that requires the
4424 -- presence of a fixed-point type. Given that all operands are universal
4425 -- and have been constant-folded, retrieve the original function call.
4427 ---------------------------
4428 -- Is_Mixed_Mode_Operand --
4429 ---------------------------
4431 function Is_Mixed_Mode_Operand
(Op
: Node_Id
) return Boolean is
4432 Onod
: constant Node_Id
:= Original_Node
(Op
);
4434 return Nkind
(Onod
) = N_Function_Call
4435 and then Present
(Next_Actual
(First_Actual
(Onod
)))
4436 and then Etype
(First_Actual
(Onod
)) /=
4437 Etype
(Next_Actual
(First_Actual
(Onod
)));
4438 end Is_Mixed_Mode_Operand
;
4440 -- Start of processing for Find_Universal_Operator_Type
4443 if Nkind
(Call
) /= N_Function_Call
4444 or else Nkind
(Name
(Call
)) /= N_Expanded_Name
4448 -- There are several cases where the context does not imply the type of
4450 -- - the universal expression appears in a type conversion;
4451 -- - the expression is a relational operator applied to universal
4453 -- - the expression is a membership test with a universal operand
4454 -- and a range with universal bounds.
4456 elsif Nkind
(Parent
(N
)) = N_Type_Conversion
4457 or else Is_Relational
4458 or else In_Membership
4460 Pack
:= Entity
(Prefix
(Name
(Call
)));
4462 -- If the prefix is a package declared elsewhere, iterate over its
4463 -- visible entities, otherwise iterate over all declarations in the
4464 -- designated scope.
4466 if Ekind
(Pack
) = E_Package
4467 and then not In_Open_Scopes
(Pack
)
4469 Priv_E
:= First_Private_Entity
(Pack
);
4475 E
:= First_Entity
(Pack
);
4476 while Present
(E
) and then E
/= Priv_E
loop
4477 if Is_Numeric_Type
(E
)
4478 and then Nkind
(Parent
(E
)) /= N_Subtype_Declaration
4479 and then Comes_From_Source
(E
)
4480 and then Is_Integer_Type
(E
) = Is_Int
4481 and then (Nkind
(N
) in N_Unary_Op
4482 or else Is_Relational
4483 or else Is_Fixed_Point_Type
(E
) = Is_Fix
)
4488 -- Before emitting an error, check for the presence of a
4489 -- mixed-mode operation that specifies a fixed point type.
4493 (Is_Mixed_Mode_Operand
(Left_Opnd
(N
))
4494 or else Is_Mixed_Mode_Operand
(Right_Opnd
(N
)))
4495 and then Is_Fixed_Point_Type
(E
) /= Is_Fixed_Point_Type
(Typ1
)
4498 if Is_Fixed_Point_Type
(E
) then
4503 -- More than one type of the proper class declared in P
4505 Error_Msg_N
("ambiguous operation", N
);
4506 Error_Msg_Sloc
:= Sloc
(Typ1
);
4507 Error_Msg_N
("\possible interpretation (inherited)#", N
);
4508 Error_Msg_Sloc
:= Sloc
(E
);
4509 Error_Msg_N
("\possible interpretation (inherited)#", N
);
4519 end Find_Universal_Operator_Type
;
4521 --------------------------
4522 -- Flag_Non_Static_Expr --
4523 --------------------------
4525 procedure Flag_Non_Static_Expr
(Msg
: String; Expr
: Node_Id
) is
4527 if Error_Posted
(Expr
) and then not All_Errors_Mode
then
4530 Error_Msg_F
(Msg
, Expr
);
4531 Why_Not_Static
(Expr
);
4533 end Flag_Non_Static_Expr
;
4539 procedure Fold_Str
(N
: Node_Id
; Val
: String_Id
; Static
: Boolean) is
4540 Loc
: constant Source_Ptr
:= Sloc
(N
);
4541 Typ
: constant Entity_Id
:= Etype
(N
);
4544 if Raises_Constraint_Error
(N
) then
4545 Set_Is_Static_Expression
(N
, Static
);
4549 Rewrite
(N
, Make_String_Literal
(Loc
, Strval
=> Val
));
4551 -- We now have the literal with the right value, both the actual type
4552 -- and the expected type of this literal are taken from the expression
4553 -- that was evaluated. So now we do the Analyze and Resolve.
4555 -- Note that we have to reset Is_Static_Expression both after the
4556 -- analyze step (because Resolve will evaluate the literal, which
4557 -- will cause semantic errors if it is marked as static), and after
4558 -- the Resolve step (since Resolve in some cases resets this flag).
4561 Set_Is_Static_Expression
(N
, Static
);
4564 Set_Is_Static_Expression
(N
, Static
);
4571 procedure Fold_Uint
(N
: Node_Id
; Val
: Uint
; Static
: Boolean) is
4572 Loc
: constant Source_Ptr
:= Sloc
(N
);
4573 Typ
: Entity_Id
:= Etype
(N
);
4577 if Raises_Constraint_Error
(N
) then
4578 Set_Is_Static_Expression
(N
, Static
);
4582 -- If we are folding a named number, retain the entity in the literal,
4585 if Is_Entity_Name
(N
) and then Ekind
(Entity
(N
)) = E_Named_Integer
then
4591 if Is_Private_Type
(Typ
) then
4592 Typ
:= Full_View
(Typ
);
4595 -- For a result of type integer, substitute an N_Integer_Literal node
4596 -- for the result of the compile time evaluation of the expression.
4597 -- For ASIS use, set a link to the original named number when not in
4598 -- a generic context.
4600 if Is_Integer_Type
(Typ
) then
4601 Rewrite
(N
, Make_Integer_Literal
(Loc
, Val
));
4602 Set_Original_Entity
(N
, Ent
);
4604 -- Otherwise we have an enumeration type, and we substitute either
4605 -- an N_Identifier or N_Character_Literal to represent the enumeration
4606 -- literal corresponding to the given value, which must always be in
4607 -- range, because appropriate tests have already been made for this.
4609 else pragma Assert
(Is_Enumeration_Type
(Typ
));
4610 Rewrite
(N
, Get_Enum_Lit_From_Pos
(Etype
(N
), Val
, Loc
));
4613 -- We now have the literal with the right value, both the actual type
4614 -- and the expected type of this literal are taken from the expression
4615 -- that was evaluated. So now we do the Analyze and Resolve.
4617 -- Note that we have to reset Is_Static_Expression both after the
4618 -- analyze step (because Resolve will evaluate the literal, which
4619 -- will cause semantic errors if it is marked as static), and after
4620 -- the Resolve step (since Resolve in some cases sets this flag).
4623 Set_Is_Static_Expression
(N
, Static
);
4626 Set_Is_Static_Expression
(N
, Static
);
4633 procedure Fold_Ureal
(N
: Node_Id
; Val
: Ureal
; Static
: Boolean) is
4634 Loc
: constant Source_Ptr
:= Sloc
(N
);
4635 Typ
: constant Entity_Id
:= Etype
(N
);
4639 if Raises_Constraint_Error
(N
) then
4640 Set_Is_Static_Expression
(N
, Static
);
4644 -- If we are folding a named number, retain the entity in the literal,
4647 if Is_Entity_Name
(N
) and then Ekind
(Entity
(N
)) = E_Named_Real
then
4653 Rewrite
(N
, Make_Real_Literal
(Loc
, Realval
=> Val
));
4655 -- Set link to original named number, for ASIS use
4657 Set_Original_Entity
(N
, Ent
);
4659 -- We now have the literal with the right value, both the actual type
4660 -- and the expected type of this literal are taken from the expression
4661 -- that was evaluated. So now we do the Analyze and Resolve.
4663 -- Note that we have to reset Is_Static_Expression both after the
4664 -- analyze step (because Resolve will evaluate the literal, which
4665 -- will cause semantic errors if it is marked as static), and after
4666 -- the Resolve step (since Resolve in some cases sets this flag).
4668 -- We mark the node as analyzed so that its type is not erased by
4669 -- calling Analyze_Real_Literal.
4672 Set_Is_Static_Expression
(N
, Static
);
4676 Set_Is_Static_Expression
(N
, Static
);
4683 function From_Bits
(B
: Bits
; T
: Entity_Id
) return Uint
is
4687 for J
in 0 .. B
'Last loop
4693 if Non_Binary_Modulus
(T
) then
4694 V
:= V
mod Modulus
(T
);
4700 --------------------
4701 -- Get_String_Val --
4702 --------------------
4704 function Get_String_Val
(N
: Node_Id
) return Node_Id
is
4706 if Nkind_In
(N
, N_String_Literal
, N_Character_Literal
) then
4709 pragma Assert
(Is_Entity_Name
(N
));
4710 return Get_String_Val
(Constant_Value
(Entity
(N
)));
4718 procedure Initialize
is
4720 CV_Cache
:= (others => (Node_High_Bound
, Uint_0
));
4723 --------------------
4724 -- In_Subrange_Of --
4725 --------------------
4727 function In_Subrange_Of
4730 Fixed_Int
: Boolean := False) return Boolean
4739 if T1
= T2
or else Is_Subtype_Of
(T1
, T2
) then
4742 -- Never in range if both types are not scalar. Don't know if this can
4743 -- actually happen, but just in case.
4745 elsif not Is_Scalar_Type
(T1
) or else not Is_Scalar_Type
(T2
) then
4748 -- If T1 has infinities but T2 doesn't have infinities, then T1 is
4749 -- definitely not compatible with T2.
4751 elsif Is_Floating_Point_Type
(T1
)
4752 and then Has_Infinities
(T1
)
4753 and then Is_Floating_Point_Type
(T2
)
4754 and then not Has_Infinities
(T2
)
4759 L1
:= Type_Low_Bound
(T1
);
4760 H1
:= Type_High_Bound
(T1
);
4762 L2
:= Type_Low_Bound
(T2
);
4763 H2
:= Type_High_Bound
(T2
);
4765 -- Check bounds to see if comparison possible at compile time
4767 if Compile_Time_Compare
(L1
, L2
, Assume_Valid
=> True) in Compare_GE
4769 Compile_Time_Compare
(H1
, H2
, Assume_Valid
=> True) in Compare_LE
4774 -- If bounds not comparable at compile time, then the bounds of T2
4775 -- must be compile-time-known or we cannot answer the query.
4777 if not Compile_Time_Known_Value
(L2
)
4778 or else not Compile_Time_Known_Value
(H2
)
4783 -- If the bounds of T1 are know at compile time then use these
4784 -- ones, otherwise use the bounds of the base type (which are of
4785 -- course always static).
4787 if not Compile_Time_Known_Value
(L1
) then
4788 L1
:= Type_Low_Bound
(Base_Type
(T1
));
4791 if not Compile_Time_Known_Value
(H1
) then
4792 H1
:= Type_High_Bound
(Base_Type
(T1
));
4795 -- Fixed point types should be considered as such only if
4796 -- flag Fixed_Int is set to False.
4798 if Is_Floating_Point_Type
(T1
) or else Is_Floating_Point_Type
(T2
)
4799 or else (Is_Fixed_Point_Type
(T1
) and then not Fixed_Int
)
4800 or else (Is_Fixed_Point_Type
(T2
) and then not Fixed_Int
)
4803 Expr_Value_R
(L2
) <= Expr_Value_R
(L1
)
4805 Expr_Value_R
(H2
) >= Expr_Value_R
(H1
);
4809 Expr_Value
(L2
) <= Expr_Value
(L1
)
4811 Expr_Value
(H2
) >= Expr_Value
(H1
);
4816 -- If any exception occurs, it means that we have some bug in the compiler
4817 -- possibly triggered by a previous error, or by some unforeseen peculiar
4818 -- occurrence. However, this is only an optimization attempt, so there is
4819 -- really no point in crashing the compiler. Instead we just decide, too
4820 -- bad, we can't figure out the answer in this case after all.
4825 -- Debug flag K disables this behavior (useful for debugging)
4827 if Debug_Flag_K
then
4838 function Is_In_Range
4841 Assume_Valid
: Boolean := False;
4842 Fixed_Int
: Boolean := False;
4843 Int_Real
: Boolean := False) return Boolean
4847 Test_In_Range
(N
, Typ
, Assume_Valid
, Fixed_Int
, Int_Real
) = In_Range
;
4854 function Is_Null_Range
(Lo
: Node_Id
; Hi
: Node_Id
) return Boolean is
4856 if Compile_Time_Known_Value
(Lo
)
4857 and then Compile_Time_Known_Value
(Hi
)
4860 Typ
: Entity_Id
:= Etype
(Lo
);
4862 -- When called from the frontend, as part of the analysis of
4863 -- potentially static expressions, Typ will be the full view of a
4864 -- type with all the info needed to answer this query. When called
4865 -- from the backend, for example to know whether a range of a loop
4866 -- is null, Typ might be a private type and we need to explicitly
4867 -- switch to its corresponding full view to access the same info.
4869 if Is_Incomplete_Or_Private_Type
(Typ
)
4870 and then Present
(Full_View
(Typ
))
4872 Typ
:= Full_View
(Typ
);
4875 if Is_Discrete_Type
(Typ
) then
4876 return Expr_Value
(Lo
) > Expr_Value
(Hi
);
4877 else pragma Assert
(Is_Real_Type
(Typ
));
4878 return Expr_Value_R
(Lo
) > Expr_Value_R
(Hi
);
4886 -------------------------
4887 -- Is_OK_Static_Choice --
4888 -------------------------
4890 function Is_OK_Static_Choice
(Choice
: Node_Id
) return Boolean is
4892 -- Check various possibilities for choice
4894 -- Note: for membership tests, we test more cases than are possible
4895 -- (in particular subtype indication), but it doesn't matter because
4896 -- it just won't occur (we have already done a syntax check).
4898 if Nkind
(Choice
) = N_Others_Choice
then
4901 elsif Nkind
(Choice
) = N_Range
then
4902 return Is_OK_Static_Range
(Choice
);
4904 elsif Nkind
(Choice
) = N_Subtype_Indication
4905 or else (Is_Entity_Name
(Choice
) and then Is_Type
(Entity
(Choice
)))
4907 return Is_OK_Static_Subtype
(Etype
(Choice
));
4910 return Is_OK_Static_Expression
(Choice
);
4912 end Is_OK_Static_Choice
;
4914 ------------------------------
4915 -- Is_OK_Static_Choice_List --
4916 ------------------------------
4918 function Is_OK_Static_Choice_List
(Choices
: List_Id
) return Boolean is
4922 if not Is_Static_Choice_List
(Choices
) then
4926 Choice
:= First
(Choices
);
4927 while Present
(Choice
) loop
4928 if not Is_OK_Static_Choice
(Choice
) then
4929 Set_Raises_Constraint_Error
(Choice
);
4937 end Is_OK_Static_Choice_List
;
4939 -----------------------------
4940 -- Is_OK_Static_Expression --
4941 -----------------------------
4943 function Is_OK_Static_Expression
(N
: Node_Id
) return Boolean is
4945 return Is_Static_Expression
(N
) and then not Raises_Constraint_Error
(N
);
4946 end Is_OK_Static_Expression
;
4948 ------------------------
4949 -- Is_OK_Static_Range --
4950 ------------------------
4952 -- A static range is a range whose bounds are static expressions, or a
4953 -- Range_Attribute_Reference equivalent to such a range (RM 4.9(26)).
4954 -- We have already converted range attribute references, so we get the
4955 -- "or" part of this rule without needing a special test.
4957 function Is_OK_Static_Range
(N
: Node_Id
) return Boolean is
4959 return Is_OK_Static_Expression
(Low_Bound
(N
))
4960 and then Is_OK_Static_Expression
(High_Bound
(N
));
4961 end Is_OK_Static_Range
;
4963 --------------------------
4964 -- Is_OK_Static_Subtype --
4965 --------------------------
4967 -- Determines if Typ is a static subtype as defined in (RM 4.9(26)) where
4968 -- neither bound raises Constraint_Error when evaluated.
4970 function Is_OK_Static_Subtype
(Typ
: Entity_Id
) return Boolean is
4971 Base_T
: constant Entity_Id
:= Base_Type
(Typ
);
4972 Anc_Subt
: Entity_Id
;
4975 -- First a quick check on the non static subtype flag. As described
4976 -- in further detail in Einfo, this flag is not decisive in all cases,
4977 -- but if it is set, then the subtype is definitely non-static.
4979 if Is_Non_Static_Subtype
(Typ
) then
4983 Anc_Subt
:= Ancestor_Subtype
(Typ
);
4985 if Anc_Subt
= Empty
then
4989 if Is_Generic_Type
(Root_Type
(Base_T
))
4990 or else Is_Generic_Actual_Type
(Base_T
)
4994 elsif Has_Dynamic_Predicate_Aspect
(Typ
) then
4999 elsif Is_String_Type
(Typ
) then
5001 Ekind
(Typ
) = E_String_Literal_Subtype
5003 (Is_OK_Static_Subtype
(Component_Type
(Typ
))
5004 and then Is_OK_Static_Subtype
(Etype
(First_Index
(Typ
))));
5008 elsif Is_Scalar_Type
(Typ
) then
5009 if Base_T
= Typ
then
5013 -- Scalar_Range (Typ) might be an N_Subtype_Indication, so use
5014 -- Get_Type_{Low,High}_Bound.
5016 return Is_OK_Static_Subtype
(Anc_Subt
)
5017 and then Is_OK_Static_Expression
(Type_Low_Bound
(Typ
))
5018 and then Is_OK_Static_Expression
(Type_High_Bound
(Typ
));
5021 -- Types other than string and scalar types are never static
5026 end Is_OK_Static_Subtype
;
5028 ---------------------
5029 -- Is_Out_Of_Range --
5030 ---------------------
5032 function Is_Out_Of_Range
5035 Assume_Valid
: Boolean := False;
5036 Fixed_Int
: Boolean := False;
5037 Int_Real
: Boolean := False) return Boolean
5040 return Test_In_Range
(N
, Typ
, Assume_Valid
, Fixed_Int
, Int_Real
) =
5042 end Is_Out_Of_Range
;
5044 ----------------------
5045 -- Is_Static_Choice --
5046 ----------------------
5048 function Is_Static_Choice
(Choice
: Node_Id
) return Boolean is
5050 -- Check various possibilities for choice
5052 -- Note: for membership tests, we test more cases than are possible
5053 -- (in particular subtype indication), but it doesn't matter because
5054 -- it just won't occur (we have already done a syntax check).
5056 if Nkind
(Choice
) = N_Others_Choice
then
5059 elsif Nkind
(Choice
) = N_Range
then
5060 return Is_Static_Range
(Choice
);
5062 elsif Nkind
(Choice
) = N_Subtype_Indication
5063 or else (Is_Entity_Name
(Choice
) and then Is_Type
(Entity
(Choice
)))
5065 return Is_Static_Subtype
(Etype
(Choice
));
5068 return Is_Static_Expression
(Choice
);
5070 end Is_Static_Choice
;
5072 ---------------------------
5073 -- Is_Static_Choice_List --
5074 ---------------------------
5076 function Is_Static_Choice_List
(Choices
: List_Id
) return Boolean is
5080 Choice
:= First
(Choices
);
5081 while Present
(Choice
) loop
5082 if not Is_Static_Choice
(Choice
) then
5090 end Is_Static_Choice_List
;
5092 ---------------------
5093 -- Is_Static_Range --
5094 ---------------------
5096 -- A static range is a range whose bounds are static expressions, or a
5097 -- Range_Attribute_Reference equivalent to such a range (RM 4.9(26)).
5098 -- We have already converted range attribute references, so we get the
5099 -- "or" part of this rule without needing a special test.
5101 function Is_Static_Range
(N
: Node_Id
) return Boolean is
5103 return Is_Static_Expression
(Low_Bound
(N
))
5105 Is_Static_Expression
(High_Bound
(N
));
5106 end Is_Static_Range
;
5108 -----------------------
5109 -- Is_Static_Subtype --
5110 -----------------------
5112 -- Determines if Typ is a static subtype as defined in (RM 4.9(26))
5114 function Is_Static_Subtype
(Typ
: Entity_Id
) return Boolean is
5115 Base_T
: constant Entity_Id
:= Base_Type
(Typ
);
5116 Anc_Subt
: Entity_Id
;
5119 -- First a quick check on the non static subtype flag. As described
5120 -- in further detail in Einfo, this flag is not decisive in all cases,
5121 -- but if it is set, then the subtype is definitely non-static.
5123 if Is_Non_Static_Subtype
(Typ
) then
5127 Anc_Subt
:= Ancestor_Subtype
(Typ
);
5129 if Anc_Subt
= Empty
then
5133 if Is_Generic_Type
(Root_Type
(Base_T
))
5134 or else Is_Generic_Actual_Type
(Base_T
)
5138 -- If there is a dynamic predicate for the type (declared or inherited)
5139 -- the expression is not static.
5141 elsif Has_Dynamic_Predicate_Aspect
(Typ
)
5142 or else (Is_Derived_Type
(Typ
)
5143 and then Has_Aspect
(Typ
, Aspect_Dynamic_Predicate
))
5149 elsif Is_String_Type
(Typ
) then
5151 Ekind
(Typ
) = E_String_Literal_Subtype
5152 or else (Is_Static_Subtype
(Component_Type
(Typ
))
5153 and then Is_Static_Subtype
(Etype
(First_Index
(Typ
))));
5157 elsif Is_Scalar_Type
(Typ
) then
5158 if Base_T
= Typ
then
5162 return Is_Static_Subtype
(Anc_Subt
)
5163 and then Is_Static_Expression
(Type_Low_Bound
(Typ
))
5164 and then Is_Static_Expression
(Type_High_Bound
(Typ
));
5167 -- Types other than string and scalar types are never static
5172 end Is_Static_Subtype
;
5174 -------------------------------
5175 -- Is_Statically_Unevaluated --
5176 -------------------------------
5178 function Is_Statically_Unevaluated
(Expr
: Node_Id
) return Boolean is
5179 function Check_Case_Expr_Alternative
5180 (CEA
: Node_Id
) return Match_Result
;
5181 -- We have a message emanating from the Expression of a case expression
5182 -- alternative. We examine this alternative, as follows:
5184 -- If the selecting expression of the parent case is non-static, or
5185 -- if any of the discrete choices of the given case alternative are
5186 -- non-static or raise Constraint_Error, return Non_Static.
5188 -- Otherwise check if the selecting expression matches any of the given
5189 -- discrete choices. If so, the alternative is executed and we return
5190 -- Match, otherwise, the alternative can never be executed, and so we
5193 ---------------------------------
5194 -- Check_Case_Expr_Alternative --
5195 ---------------------------------
5197 function Check_Case_Expr_Alternative
5198 (CEA
: Node_Id
) return Match_Result
5200 Case_Exp
: constant Node_Id
:= Parent
(CEA
);
5205 pragma Assert
(Nkind
(Case_Exp
) = N_Case_Expression
);
5207 -- Check that selecting expression is static
5209 if not Is_OK_Static_Expression
(Expression
(Case_Exp
)) then
5213 if not Is_OK_Static_Choice_List
(Discrete_Choices
(CEA
)) then
5217 -- All choices are now known to be static. Now see if alternative
5218 -- matches one of the choices.
5220 Choice
:= First
(Discrete_Choices
(CEA
));
5221 while Present
(Choice
) loop
5223 -- Check various possibilities for choice, returning Match if we
5224 -- find the selecting value matches any of the choices. Note that
5225 -- we know we are the last choice, so we don't have to keep going.
5227 if Nkind
(Choice
) = N_Others_Choice
then
5229 -- Others choice is a bit annoying, it matches if none of the
5230 -- previous alternatives matches (note that we know we are the
5231 -- last alternative in this case, so we can just go backwards
5232 -- from us to see if any previous one matches).
5234 Prev_CEA
:= Prev
(CEA
);
5235 while Present
(Prev_CEA
) loop
5236 if Check_Case_Expr_Alternative
(Prev_CEA
) = Match
then
5245 -- Else we have a normal static choice
5247 elsif Choice_Matches
(Expression
(Case_Exp
), Choice
) = Match
then
5251 -- If we fall through, it means that the discrete choice did not
5252 -- match the selecting expression, so continue.
5257 -- If we get through that loop then all choices were static, and none
5258 -- of them matched the selecting expression. So return No_Match.
5261 end Check_Case_Expr_Alternative
;
5269 -- Start of processing for Is_Statically_Unevaluated
5272 -- The (32.x) references here are from RM section 4.9
5274 -- (32.1) An expression is statically unevaluated if it is part of ...
5276 -- This means we have to climb the tree looking for one of the cases
5283 -- (32.2) The right operand of a static short-circuit control form
5284 -- whose value is determined by its left operand.
5286 -- AND THEN with False as left operand
5288 if Nkind
(P
) = N_And_Then
5289 and then Compile_Time_Known_Value
(Left_Opnd
(P
))
5290 and then Is_False
(Expr_Value
(Left_Opnd
(P
)))
5294 -- OR ELSE with True as left operand
5296 elsif Nkind
(P
) = N_Or_Else
5297 and then Compile_Time_Known_Value
(Left_Opnd
(P
))
5298 and then Is_True
(Expr_Value
(Left_Opnd
(P
)))
5302 -- (32.3) A dependent_expression of an if_expression whose associated
5303 -- condition is static and equals False.
5305 elsif Nkind
(P
) = N_If_Expression
then
5307 Cond
: constant Node_Id
:= First
(Expressions
(P
));
5308 Texp
: constant Node_Id
:= Next
(Cond
);
5309 Fexp
: constant Node_Id
:= Next
(Texp
);
5312 if Compile_Time_Known_Value
(Cond
) then
5314 -- Condition is True and we are in the right operand
5316 if Is_True
(Expr_Value
(Cond
)) and then OldP
= Fexp
then
5319 -- Condition is False and we are in the left operand
5321 elsif Is_False
(Expr_Value
(Cond
)) and then OldP
= Texp
then
5327 -- (32.4) A condition or dependent_expression of an if_expression
5328 -- where the condition corresponding to at least one preceding
5329 -- dependent_expression of the if_expression is static and equals
5332 -- This refers to cases like
5334 -- (if True then 1 elsif 1/0=2 then 2 else 3)
5336 -- But we expand elsif's out anyway, so the above looks like:
5338 -- (if True then 1 else (if 1/0=2 then 2 else 3))
5340 -- So for us this is caught by the above check for the 32.3 case.
5342 -- (32.5) A dependent_expression of a case_expression whose
5343 -- selecting_expression is static and whose value is not covered
5344 -- by the corresponding discrete_choice_list.
5346 elsif Nkind
(P
) = N_Case_Expression_Alternative
then
5348 -- First, we have to be in the expression to suppress messages.
5349 -- If we are within one of the choices, we want the message.
5351 if OldP
= Expression
(P
) then
5353 -- Statically unevaluated if alternative does not match
5355 if Check_Case_Expr_Alternative
(P
) = No_Match
then
5360 -- (32.6) A choice_expression (or a simple_expression of a range
5361 -- that occurs as a membership_choice of a membership_choice_list)
5362 -- of a static membership test that is preceded in the enclosing
5363 -- membership_choice_list by another item whose individual
5364 -- membership test (see (RM 4.5.2)) statically yields True.
5366 elsif Nkind
(P
) in N_Membership_Test
then
5368 -- Only possibly unevaluated if simple expression is static
5370 if not Is_OK_Static_Expression
(Left_Opnd
(P
)) then
5373 -- All members of the choice list must be static
5375 elsif (Present
(Right_Opnd
(P
))
5376 and then not Is_OK_Static_Choice
(Right_Opnd
(P
)))
5377 or else (Present
(Alternatives
(P
))
5379 not Is_OK_Static_Choice_List
(Alternatives
(P
)))
5383 -- If expression is the one and only alternative, then it is
5384 -- definitely not statically unevaluated, so we only have to
5385 -- test the case where there are alternatives present.
5387 elsif Present
(Alternatives
(P
)) then
5389 -- Look for previous matching Choice
5391 Choice
:= First
(Alternatives
(P
));
5392 while Present
(Choice
) loop
5394 -- If we reached us and no previous choices matched, this
5395 -- is not the case where we are statically unevaluated.
5397 exit when OldP
= Choice
;
5399 -- If a previous choice matches, then that is the case where
5400 -- we know our choice is statically unevaluated.
5402 if Choice_Matches
(Left_Opnd
(P
), Choice
) = Match
then
5409 -- If we fall through the loop, we were not one of the choices,
5410 -- we must have been the expression, so that is not covered by
5411 -- this rule, and we keep going.
5417 -- OK, not statically unevaluated at this level, see if we should
5418 -- keep climbing to look for a higher level reason.
5420 -- Special case for component association in aggregates, where
5421 -- we want to keep climbing up to the parent aggregate.
5423 if Nkind
(P
) = N_Component_Association
5424 and then Nkind
(Parent
(P
)) = N_Aggregate
5428 -- All done if not still within subexpression
5431 exit when Nkind
(P
) not in N_Subexpr
;
5435 -- If we fall through the loop, not one of the cases covered!
5438 end Is_Statically_Unevaluated
;
5440 --------------------
5441 -- Not_Null_Range --
5442 --------------------
5444 function Not_Null_Range
(Lo
: Node_Id
; Hi
: Node_Id
) return Boolean is
5446 if Compile_Time_Known_Value
(Lo
)
5447 and then Compile_Time_Known_Value
(Hi
)
5450 Typ
: Entity_Id
:= Etype
(Lo
);
5452 -- When called from the frontend, as part of the analysis of
5453 -- potentially static expressions, Typ will be the full view of a
5454 -- type with all the info needed to answer this query. When called
5455 -- from the backend, for example to know whether a range of a loop
5456 -- is null, Typ might be a private type and we need to explicitly
5457 -- switch to its corresponding full view to access the same info.
5459 if Is_Incomplete_Or_Private_Type
(Typ
)
5460 and then Present
(Full_View
(Typ
))
5462 Typ
:= Full_View
(Typ
);
5465 if Is_Discrete_Type
(Typ
) then
5466 return Expr_Value
(Lo
) <= Expr_Value
(Hi
);
5467 else pragma Assert
(Is_Real_Type
(Typ
));
5468 return Expr_Value_R
(Lo
) <= Expr_Value_R
(Hi
);
5481 function OK_Bits
(N
: Node_Id
; Bits
: Uint
) return Boolean is
5483 -- We allow a maximum of 500,000 bits which seems a reasonable limit
5485 if Bits
< 500_000
then
5488 -- Error if this maximum is exceeded
5491 Error_Msg_N
("static value too large, capacity exceeded", N
);
5500 procedure Out_Of_Range
(N
: Node_Id
) is
5502 -- If we have the static expression case, then this is an illegality
5503 -- in Ada 95 mode, except that in an instance, we never generate an
5504 -- error (if the error is legitimate, it was already diagnosed in the
5507 if Is_Static_Expression
(N
)
5508 and then not In_Instance
5509 and then not In_Inlined_Body
5510 and then Ada_Version
>= Ada_95
5512 -- No message if we are statically unevaluated
5514 if Is_Statically_Unevaluated
(N
) then
5517 -- The expression to compute the length of a packed array is attached
5518 -- to the array type itself, and deserves a separate message.
5520 elsif Nkind
(Parent
(N
)) = N_Defining_Identifier
5521 and then Is_Array_Type
(Parent
(N
))
5522 and then Present
(Packed_Array_Impl_Type
(Parent
(N
)))
5523 and then Present
(First_Rep_Item
(Parent
(N
)))
5526 ("length of packed array must not exceed Integer''Last",
5527 First_Rep_Item
(Parent
(N
)));
5528 Rewrite
(N
, Make_Integer_Literal
(Sloc
(N
), Uint_1
));
5530 -- All cases except the special array case.
5531 -- No message if we are dealing with System.Priority values in
5532 -- CodePeer mode where the target runtime may have more priorities.
5534 elsif not CodePeer_Mode
or else Etype
(N
) /= RTE
(RE_Priority
) then
5535 -- Determine if the out-of-range violation constitutes a warning
5536 -- or an error based on context, according to RM 4.9 (34/3).
5538 if Nkind
(Original_Node
(N
)) = N_Type_Conversion
5539 and then not Comes_From_Source
(Original_Node
(N
))
5541 Apply_Compile_Time_Constraint_Error
5542 (N
, "value not in range of}??", CE_Range_Check_Failed
);
5544 Apply_Compile_Time_Constraint_Error
5545 (N
, "value not in range of}", CE_Range_Check_Failed
);
5549 -- Here we generate a warning for the Ada 83 case, or when we are in an
5550 -- instance, or when we have a non-static expression case.
5553 Apply_Compile_Time_Constraint_Error
5554 (N
, "value not in range of}??", CE_Range_Check_Failed
);
5558 ----------------------
5559 -- Predicates_Match --
5560 ----------------------
5562 function Predicates_Match
(T1
, T2
: Entity_Id
) return Boolean is
5567 if Ada_Version
< Ada_2012
then
5570 -- Both types must have predicates or lack them
5572 elsif Has_Predicates
(T1
) /= Has_Predicates
(T2
) then
5575 -- Check matching predicates
5580 (T1
, Name_Static_Predicate
, Check_Parents
=> False);
5583 (T2
, Name_Static_Predicate
, Check_Parents
=> False);
5585 -- Subtypes statically match if the predicate comes from the
5586 -- same declaration, which can only happen if one is a subtype
5587 -- of the other and has no explicit predicate.
5589 -- Suppress warnings on order of actuals, which is otherwise
5590 -- triggered by one of the two calls below.
5592 pragma Warnings
(Off
);
5593 return Pred1
= Pred2
5594 or else (No
(Pred1
) and then Is_Subtype_Of
(T1
, T2
))
5595 or else (No
(Pred2
) and then Is_Subtype_Of
(T2
, T1
));
5596 pragma Warnings
(On
);
5598 end Predicates_Match
;
5600 ---------------------------------------------
5601 -- Real_Or_String_Static_Predicate_Matches --
5602 ---------------------------------------------
5604 function Real_Or_String_Static_Predicate_Matches
5606 Typ
: Entity_Id
) return Boolean
5608 Expr
: constant Node_Id
:= Static_Real_Or_String_Predicate
(Typ
);
5609 -- The predicate expression from the type
5611 Pfun
: constant Entity_Id
:= Predicate_Function
(Typ
);
5612 -- The entity for the predicate function
5614 Ent_Name
: constant Name_Id
:= Chars
(First_Formal
(Pfun
));
5615 -- The name of the formal of the predicate function. Occurrences of the
5616 -- type name in Expr have been rewritten as references to this formal,
5617 -- and it has a unique name, so we can identify references by this name.
5620 -- Copy of the predicate function tree
5622 function Process
(N
: Node_Id
) return Traverse_Result
;
5623 -- Function used to process nodes during the traversal in which we will
5624 -- find occurrences of the entity name, and replace such occurrences
5625 -- by a real literal with the value to be tested.
5627 procedure Traverse
is new Traverse_Proc
(Process
);
5628 -- The actual traversal procedure
5634 function Process
(N
: Node_Id
) return Traverse_Result
is
5636 if Nkind
(N
) = N_Identifier
and then Chars
(N
) = Ent_Name
then
5638 Nod
: constant Node_Id
:= New_Copy
(Val
);
5640 Set_Sloc
(Nod
, Sloc
(N
));
5645 -- The predicate function may contain string-comparison operations
5646 -- that have been converted into calls to run-time array-comparison
5647 -- routines. To evaluate the predicate statically, we recover the
5648 -- original comparison operation and replace the occurrence of the
5649 -- formal by the static string value. The actuals of the generated
5650 -- call are of the form X'Address.
5652 elsif Nkind
(N
) in N_Op_Compare
5653 and then Nkind
(Left_Opnd
(N
)) = N_Function_Call
5656 C
: constant Node_Id
:= Left_Opnd
(N
);
5657 F
: constant Node_Id
:= First
(Parameter_Associations
(C
));
5658 L
: constant Node_Id
:= Prefix
(F
);
5659 R
: constant Node_Id
:= Prefix
(Next
(F
));
5662 -- If an operand is an entity name, it is the formal of the
5663 -- predicate function, so replace it with the string value.
5664 -- It may be either operand in the call. The other operand
5665 -- is a static string from the original predicate.
5667 if Is_Entity_Name
(L
) then
5668 Rewrite
(Left_Opnd
(N
), New_Copy
(Val
));
5669 Rewrite
(Right_Opnd
(N
), New_Copy
(R
));
5672 Rewrite
(Left_Opnd
(N
), New_Copy
(L
));
5673 Rewrite
(Right_Opnd
(N
), New_Copy
(Val
));
5684 -- Start of processing for Real_Or_String_Static_Predicate_Matches
5687 -- First deal with special case of inherited predicate, where the
5688 -- predicate expression looks like:
5690 -- xxPredicate (typ (Ent)) and then Expr
5692 -- where Expr is the predicate expression for this level, and the
5693 -- left operand is the call to evaluate the inherited predicate.
5695 if Nkind
(Expr
) = N_And_Then
5696 and then Nkind
(Left_Opnd
(Expr
)) = N_Function_Call
5697 and then Is_Predicate_Function
(Entity
(Name
(Left_Opnd
(Expr
))))
5699 -- OK we have the inherited case, so make a call to evaluate the
5700 -- inherited predicate. If that fails, so do we!
5703 Real_Or_String_Static_Predicate_Matches
5705 Typ
=> Etype
(First_Formal
(Entity
(Name
(Left_Opnd
(Expr
))))))
5710 -- Use the right operand for the continued processing
5712 Copy
:= Copy_Separate_Tree
(Right_Opnd
(Expr
));
5714 -- Case where call to predicate function appears on its own (this means
5715 -- that the predicate at this level is just inherited from the parent).
5717 elsif Nkind
(Expr
) = N_Function_Call
then
5719 Typ
: constant Entity_Id
:=
5720 Etype
(First_Formal
(Entity
(Name
(Expr
))));
5723 -- If the inherited predicate is dynamic, just ignore it. We can't
5724 -- go trying to evaluate a dynamic predicate as a static one!
5726 if Has_Dynamic_Predicate_Aspect
(Typ
) then
5729 -- Otherwise inherited predicate is static, check for match
5732 return Real_Or_String_Static_Predicate_Matches
(Val
, Typ
);
5736 -- If not just an inherited predicate, copy whole expression
5739 Copy
:= Copy_Separate_Tree
(Expr
);
5742 -- Now we replace occurrences of the entity by the value
5746 -- And analyze the resulting static expression to see if it is True
5748 Analyze_And_Resolve
(Copy
, Standard_Boolean
);
5749 return Is_True
(Expr_Value
(Copy
));
5750 end Real_Or_String_Static_Predicate_Matches
;
5752 -------------------------
5753 -- Rewrite_In_Raise_CE --
5754 -------------------------
5756 procedure Rewrite_In_Raise_CE
(N
: Node_Id
; Exp
: Node_Id
) is
5757 Stat
: constant Boolean := Is_Static_Expression
(N
);
5758 Typ
: constant Entity_Id
:= Etype
(N
);
5761 -- If we want to raise CE in the condition of a N_Raise_CE node, we
5762 -- can just clear the condition if the reason is appropriate. We do
5763 -- not do this operation if the parent has a reason other than range
5764 -- check failed, because otherwise we would change the reason.
5766 if Present
(Parent
(N
))
5767 and then Nkind
(Parent
(N
)) = N_Raise_Constraint_Error
5768 and then Reason
(Parent
(N
)) =
5769 UI_From_Int
(RT_Exception_Code
'Pos (CE_Range_Check_Failed
))
5771 Set_Condition
(Parent
(N
), Empty
);
5773 -- Else build an explicit N_Raise_CE
5776 if Nkind
(Exp
) = N_Raise_Constraint_Error
then
5778 Make_Raise_Constraint_Error
(Sloc
(Exp
),
5779 Reason
=> Reason
(Exp
)));
5782 Make_Raise_Constraint_Error
(Sloc
(Exp
),
5783 Reason
=> CE_Range_Check_Failed
));
5786 Set_Raises_Constraint_Error
(N
);
5790 -- Set proper flags in result
5792 Set_Raises_Constraint_Error
(N
, True);
5793 Set_Is_Static_Expression
(N
, Stat
);
5794 end Rewrite_In_Raise_CE
;
5796 ---------------------
5797 -- String_Type_Len --
5798 ---------------------
5800 function String_Type_Len
(Stype
: Entity_Id
) return Uint
is
5801 NT
: constant Entity_Id
:= Etype
(First_Index
(Stype
));
5805 if Is_OK_Static_Subtype
(NT
) then
5808 T
:= Base_Type
(NT
);
5811 return Expr_Value
(Type_High_Bound
(T
)) -
5812 Expr_Value
(Type_Low_Bound
(T
)) + 1;
5813 end String_Type_Len
;
5815 ------------------------------------
5816 -- Subtypes_Statically_Compatible --
5817 ------------------------------------
5819 function Subtypes_Statically_Compatible
5822 Formal_Derived_Matching
: Boolean := False) return Boolean
5827 if Is_Scalar_Type
(T1
) then
5829 -- Definitely compatible if we match
5831 if Subtypes_Statically_Match
(T1
, T2
) then
5834 -- If either subtype is nonstatic then they're not compatible
5836 elsif not Is_OK_Static_Subtype
(T1
)
5838 not Is_OK_Static_Subtype
(T2
)
5842 -- Base types must match, but we don't check that (should we???) but
5843 -- we do at least check that both types are real, or both types are
5846 elsif Is_Real_Type
(T1
) /= Is_Real_Type
(T2
) then
5849 -- Here we check the bounds
5853 LB1
: constant Node_Id
:= Type_Low_Bound
(T1
);
5854 HB1
: constant Node_Id
:= Type_High_Bound
(T1
);
5855 LB2
: constant Node_Id
:= Type_Low_Bound
(T2
);
5856 HB2
: constant Node_Id
:= Type_High_Bound
(T2
);
5859 if Is_Real_Type
(T1
) then
5861 Expr_Value_R
(LB1
) > Expr_Value_R
(HB1
)
5863 (Expr_Value_R
(LB2
) <= Expr_Value_R
(LB1
)
5864 and then Expr_Value_R
(HB1
) <= Expr_Value_R
(HB2
));
5868 Expr_Value
(LB1
) > Expr_Value
(HB1
)
5870 (Expr_Value
(LB2
) <= Expr_Value
(LB1
)
5871 and then Expr_Value
(HB1
) <= Expr_Value
(HB2
));
5878 elsif Is_Access_Type
(T1
) then
5880 (not Is_Constrained
(T2
)
5881 or else Subtypes_Statically_Match
5882 (Designated_Type
(T1
), Designated_Type
(T2
)))
5883 and then not (Can_Never_Be_Null
(T2
)
5884 and then not Can_Never_Be_Null
(T1
));
5890 (Is_Composite_Type
(T1
) and then not Is_Constrained
(T2
))
5891 or else Subtypes_Statically_Match
5892 (T1
, T2
, Formal_Derived_Matching
);
5894 end Subtypes_Statically_Compatible
;
5896 -------------------------------
5897 -- Subtypes_Statically_Match --
5898 -------------------------------
5900 -- Subtypes statically match if they have statically matching constraints
5901 -- (RM 4.9.1(2)). Constraints statically match if there are none, or if
5902 -- they are the same identical constraint, or if they are static and the
5903 -- values match (RM 4.9.1(1)).
5905 -- In addition, in GNAT, the object size (Esize) values of the types must
5906 -- match if they are set (unless checking an actual for a formal derived
5907 -- type). The use of 'Object_Size can cause this to be false even if the
5908 -- types would otherwise match in the Ada 95 RM sense, but this deviation
5909 -- is adopted by AI12-059 which introduces Object_Size in Ada 2020.
5911 function Subtypes_Statically_Match
5914 Formal_Derived_Matching
: Boolean := False) return Boolean
5917 -- A type always statically matches itself
5922 -- No match if sizes different (from use of 'Object_Size). This test
5923 -- is excluded if Formal_Derived_Matching is True, as the base types
5924 -- can be different in that case and typically have different sizes.
5926 elsif not Formal_Derived_Matching
5927 and then Known_Static_Esize
(T1
)
5928 and then Known_Static_Esize
(T2
)
5929 and then Esize
(T1
) /= Esize
(T2
)
5933 -- No match if predicates do not match
5935 elsif not Predicates_Match
(T1
, T2
) then
5940 elsif Is_Scalar_Type
(T1
) then
5942 -- Base types must be the same
5944 if Base_Type
(T1
) /= Base_Type
(T2
) then
5948 -- A constrained numeric subtype never matches an unconstrained
5949 -- subtype, i.e. both types must be constrained or unconstrained.
5951 -- To understand the requirement for this test, see RM 4.9.1(1).
5952 -- As is made clear in RM 3.5.4(11), type Integer, for example is
5953 -- a constrained subtype with constraint bounds matching the bounds
5954 -- of its corresponding unconstrained base type. In this situation,
5955 -- Integer and Integer'Base do not statically match, even though
5956 -- they have the same bounds.
5958 -- We only apply this test to types in Standard and types that appear
5959 -- in user programs. That way, we do not have to be too careful about
5960 -- setting Is_Constrained right for Itypes.
5962 if Is_Numeric_Type
(T1
)
5963 and then (Is_Constrained
(T1
) /= Is_Constrained
(T2
))
5964 and then (Scope
(T1
) = Standard_Standard
5965 or else Comes_From_Source
(T1
))
5966 and then (Scope
(T2
) = Standard_Standard
5967 or else Comes_From_Source
(T2
))
5971 -- A generic scalar type does not statically match its base type
5972 -- (AI-311). In this case we make sure that the formals, which are
5973 -- first subtypes of their bases, are constrained.
5975 elsif Is_Generic_Type
(T1
)
5976 and then Is_Generic_Type
(T2
)
5977 and then (Is_Constrained
(T1
) /= Is_Constrained
(T2
))
5982 -- If there was an error in either range, then just assume the types
5983 -- statically match to avoid further junk errors.
5985 if No
(Scalar_Range
(T1
)) or else No
(Scalar_Range
(T2
))
5986 or else Error_Posted
(Scalar_Range
(T1
))
5987 or else Error_Posted
(Scalar_Range
(T2
))
5992 -- Otherwise both types have bounds that can be compared
5995 LB1
: constant Node_Id
:= Type_Low_Bound
(T1
);
5996 HB1
: constant Node_Id
:= Type_High_Bound
(T1
);
5997 LB2
: constant Node_Id
:= Type_Low_Bound
(T2
);
5998 HB2
: constant Node_Id
:= Type_High_Bound
(T2
);
6001 -- If the bounds are the same tree node, then match (common case)
6003 if LB1
= LB2
and then HB1
= HB2
then
6006 -- Otherwise bounds must be static and identical value
6009 if not Is_OK_Static_Subtype
(T1
)
6011 not Is_OK_Static_Subtype
(T2
)
6015 elsif Is_Real_Type
(T1
) then
6017 Expr_Value_R
(LB1
) = Expr_Value_R
(LB2
)
6019 Expr_Value_R
(HB1
) = Expr_Value_R
(HB2
);
6023 Expr_Value
(LB1
) = Expr_Value
(LB2
)
6025 Expr_Value
(HB1
) = Expr_Value
(HB2
);
6030 -- Type with discriminants
6032 elsif Has_Discriminants
(T1
) or else Has_Discriminants
(T2
) then
6034 -- Because of view exchanges in multiple instantiations, conformance
6035 -- checking might try to match a partial view of a type with no
6036 -- discriminants with a full view that has defaulted discriminants.
6037 -- In such a case, use the discriminant constraint of the full view,
6038 -- which must exist because we know that the two subtypes have the
6041 if Has_Discriminants
(T1
) /= Has_Discriminants
(T2
) then
6043 if Is_Private_Type
(T2
)
6044 and then Present
(Full_View
(T2
))
6045 and then Has_Discriminants
(Full_View
(T2
))
6047 return Subtypes_Statically_Match
(T1
, Full_View
(T2
));
6049 elsif Is_Private_Type
(T1
)
6050 and then Present
(Full_View
(T1
))
6051 and then Has_Discriminants
(Full_View
(T1
))
6053 return Subtypes_Statically_Match
(Full_View
(T1
), T2
);
6064 DL1
: constant Elist_Id
:= Discriminant_Constraint
(T1
);
6065 DL2
: constant Elist_Id
:= Discriminant_Constraint
(T2
);
6073 elsif Is_Constrained
(T1
) /= Is_Constrained
(T2
) then
6077 -- Now loop through the discriminant constraints
6079 -- Note: the guard here seems necessary, since it is possible at
6080 -- least for DL1 to be No_Elist. Not clear this is reasonable ???
6082 if Present
(DL1
) and then Present
(DL2
) then
6083 DA1
:= First_Elmt
(DL1
);
6084 DA2
:= First_Elmt
(DL2
);
6085 while Present
(DA1
) loop
6087 Expr1
: constant Node_Id
:= Node
(DA1
);
6088 Expr2
: constant Node_Id
:= Node
(DA2
);
6091 if not Is_OK_Static_Expression
(Expr1
)
6092 or else not Is_OK_Static_Expression
(Expr2
)
6096 -- If either expression raised a Constraint_Error,
6097 -- consider the expressions as matching, since this
6098 -- helps to prevent cascading errors.
6100 elsif Raises_Constraint_Error
(Expr1
)
6101 or else Raises_Constraint_Error
(Expr2
)
6105 elsif Expr_Value
(Expr1
) /= Expr_Value
(Expr2
) then
6118 -- A definite type does not match an indefinite or classwide type.
6119 -- However, a generic type with unknown discriminants may be
6120 -- instantiated with a type with no discriminants, and conformance
6121 -- checking on an inherited operation may compare the actual with the
6122 -- subtype that renames it in the instance.
6124 elsif Has_Unknown_Discriminants
(T1
) /= Has_Unknown_Discriminants
(T2
)
6127 Is_Generic_Actual_Type
(T1
) or else Is_Generic_Actual_Type
(T2
);
6131 elsif Is_Array_Type
(T1
) then
6133 -- If either subtype is unconstrained then both must be, and if both
6134 -- are unconstrained then no further checking is needed.
6136 if not Is_Constrained
(T1
) or else not Is_Constrained
(T2
) then
6137 return not (Is_Constrained
(T1
) or else Is_Constrained
(T2
));
6140 -- Both subtypes are constrained, so check that the index subtypes
6141 -- statically match.
6144 Index1
: Node_Id
:= First_Index
(T1
);
6145 Index2
: Node_Id
:= First_Index
(T2
);
6148 while Present
(Index1
) loop
6150 Subtypes_Statically_Match
(Etype
(Index1
), Etype
(Index2
))
6155 Next_Index
(Index1
);
6156 Next_Index
(Index2
);
6162 elsif Is_Access_Type
(T1
) then
6163 if Can_Never_Be_Null
(T1
) /= Can_Never_Be_Null
(T2
) then
6166 elsif Ekind_In
(T1
, E_Access_Subprogram_Type
,
6167 E_Anonymous_Access_Subprogram_Type
)
6171 (Designated_Type
(T1
),
6172 Designated_Type
(T2
));
6175 Subtypes_Statically_Match
6176 (Designated_Type
(T1
),
6177 Designated_Type
(T2
))
6178 and then Is_Access_Constant
(T1
) = Is_Access_Constant
(T2
);
6181 -- All other types definitely match
6186 end Subtypes_Statically_Match
;
6192 function Test
(Cond
: Boolean) return Uint
is
6201 ---------------------
6202 -- Test_Comparison --
6203 ---------------------
6205 procedure Test_Comparison
6207 Assume_Valid
: Boolean;
6208 True_Result
: out Boolean;
6209 False_Result
: out Boolean)
6211 Left
: constant Node_Id
:= Left_Opnd
(Op
);
6212 Left_Typ
: constant Entity_Id
:= Etype
(Left
);
6213 Orig_Op
: constant Node_Id
:= Original_Node
(Op
);
6215 procedure Replacement_Warning
(Msg
: String);
6216 -- Emit a warning on a comparison that can be replaced by '='
6218 -------------------------
6219 -- Replacement_Warning --
6220 -------------------------
6222 procedure Replacement_Warning
(Msg
: String) is
6224 if Constant_Condition_Warnings
6225 and then Comes_From_Source
(Orig_Op
)
6226 and then Is_Integer_Type
(Left_Typ
)
6227 and then not Error_Posted
(Op
)
6228 and then not Has_Warnings_Off
(Left_Typ
)
6229 and then not In_Instance
6231 Error_Msg_N
(Msg
, Op
);
6233 end Replacement_Warning
;
6237 Res
: constant Compare_Result
:=
6238 Compile_Time_Compare
(Left
, Right_Opnd
(Op
), Assume_Valid
);
6240 -- Start of processing for Test_Comparison
6243 case N_Op_Compare
(Nkind
(Op
)) is
6245 True_Result
:= Res
= EQ
;
6246 False_Result
:= Res
= LT
or else Res
= GT
or else Res
= NE
;
6249 True_Result
:= Res
in Compare_GE
;
6250 False_Result
:= Res
= LT
;
6252 if Res
= LE
and then Nkind
(Orig_Op
) = N_Op_Ge
then
6254 ("can never be greater than, could replace by ""'=""?c?");
6258 True_Result
:= Res
= GT
;
6259 False_Result
:= Res
in Compare_LE
;
6262 True_Result
:= Res
in Compare_LE
;
6263 False_Result
:= Res
= GT
;
6265 if Res
= GE
and then Nkind
(Orig_Op
) = N_Op_Le
then
6267 ("can never be less than, could replace by ""'=""?c?");
6271 True_Result
:= Res
= LT
;
6272 False_Result
:= Res
in Compare_GE
;
6275 True_Result
:= Res
= NE
or else Res
= GT
or else Res
= LT
;
6276 False_Result
:= Res
= EQ
;
6278 end Test_Comparison
;
6280 ---------------------------------
6281 -- Test_Expression_Is_Foldable --
6282 ---------------------------------
6286 procedure Test_Expression_Is_Foldable
6296 if Debug_Flag_Dot_F
and then In_Extended_Main_Source_Unit
(N
) then
6300 -- If operand is Any_Type, just propagate to result and do not
6301 -- try to fold, this prevents cascaded errors.
6303 if Etype
(Op1
) = Any_Type
then
6304 Set_Etype
(N
, Any_Type
);
6307 -- If operand raises Constraint_Error, then replace node N with the
6308 -- raise Constraint_Error node, and we are obviously not foldable.
6309 -- Note that this replacement inherits the Is_Static_Expression flag
6310 -- from the operand.
6312 elsif Raises_Constraint_Error
(Op1
) then
6313 Rewrite_In_Raise_CE
(N
, Op1
);
6316 -- If the operand is not static, then the result is not static, and
6317 -- all we have to do is to check the operand since it is now known
6318 -- to appear in a non-static context.
6320 elsif not Is_Static_Expression
(Op1
) then
6321 Check_Non_Static_Context
(Op1
);
6322 Fold
:= Compile_Time_Known_Value
(Op1
);
6325 -- An expression of a formal modular type is not foldable because
6326 -- the modulus is unknown.
6328 elsif Is_Modular_Integer_Type
(Etype
(Op1
))
6329 and then Is_Generic_Type
(Etype
(Op1
))
6331 Check_Non_Static_Context
(Op1
);
6334 -- Here we have the case of an operand whose type is OK, which is
6335 -- static, and which does not raise Constraint_Error, we can fold.
6338 Set_Is_Static_Expression
(N
);
6342 end Test_Expression_Is_Foldable
;
6346 procedure Test_Expression_Is_Foldable
6352 CRT_Safe
: Boolean := False)
6354 Rstat
: constant Boolean := Is_Static_Expression
(Op1
)
6356 Is_Static_Expression
(Op2
);
6362 -- Inhibit folding if -gnatd.f flag set
6364 if Debug_Flag_Dot_F
and then In_Extended_Main_Source_Unit
(N
) then
6368 -- If either operand is Any_Type, just propagate to result and
6369 -- do not try to fold, this prevents cascaded errors.
6371 if Etype
(Op1
) = Any_Type
or else Etype
(Op2
) = Any_Type
then
6372 Set_Etype
(N
, Any_Type
);
6375 -- If left operand raises Constraint_Error, then replace node N with the
6376 -- Raise_Constraint_Error node, and we are obviously not foldable.
6377 -- Is_Static_Expression is set from the two operands in the normal way,
6378 -- and we check the right operand if it is in a non-static context.
6380 elsif Raises_Constraint_Error
(Op1
) then
6382 Check_Non_Static_Context
(Op2
);
6385 Rewrite_In_Raise_CE
(N
, Op1
);
6386 Set_Is_Static_Expression
(N
, Rstat
);
6389 -- Similar processing for the case of the right operand. Note that we
6390 -- don't use this routine for the short-circuit case, so we do not have
6391 -- to worry about that special case here.
6393 elsif Raises_Constraint_Error
(Op2
) then
6395 Check_Non_Static_Context
(Op1
);
6398 Rewrite_In_Raise_CE
(N
, Op2
);
6399 Set_Is_Static_Expression
(N
, Rstat
);
6402 -- Exclude expressions of a generic modular type, as above
6404 elsif Is_Modular_Integer_Type
(Etype
(Op1
))
6405 and then Is_Generic_Type
(Etype
(Op1
))
6407 Check_Non_Static_Context
(Op1
);
6410 -- If result is not static, then check non-static contexts on operands
6411 -- since one of them may be static and the other one may not be static.
6413 elsif not Rstat
then
6414 Check_Non_Static_Context
(Op1
);
6415 Check_Non_Static_Context
(Op2
);
6418 Fold
:= CRT_Safe_Compile_Time_Known_Value
(Op1
)
6419 and then CRT_Safe_Compile_Time_Known_Value
(Op2
);
6421 Fold
:= Compile_Time_Known_Value
(Op1
)
6422 and then Compile_Time_Known_Value
(Op2
);
6427 -- Else result is static and foldable. Both operands are static, and
6428 -- neither raises Constraint_Error, so we can definitely fold.
6431 Set_Is_Static_Expression
(N
);
6436 end Test_Expression_Is_Foldable
;
6442 function Test_In_Range
6445 Assume_Valid
: Boolean;
6446 Fixed_Int
: Boolean;
6447 Int_Real
: Boolean) return Range_Membership
6452 pragma Warnings
(Off
, Assume_Valid
);
6453 -- For now Assume_Valid is unreferenced since the current implementation
6454 -- always returns Unknown if N is not a compile-time-known value, but we
6455 -- keep the parameter to allow for future enhancements in which we try
6456 -- to get the information in the variable case as well.
6459 -- If an error was posted on expression, then return Unknown, we do not
6460 -- want cascaded errors based on some false analysis of a junk node.
6462 if Error_Posted
(N
) then
6465 -- Expression that raises Constraint_Error is an odd case. We certainly
6466 -- do not want to consider it to be in range. It might make sense to
6467 -- consider it always out of range, but this causes incorrect error
6468 -- messages about static expressions out of range. So we just return
6469 -- Unknown, which is always safe.
6471 elsif Raises_Constraint_Error
(N
) then
6474 -- Universal types have no range limits, so always in range
6476 elsif Typ
= Universal_Integer
or else Typ
= Universal_Real
then
6479 -- Never known if not scalar type. Don't know if this can actually
6480 -- happen, but our spec allows it, so we must check.
6482 elsif not Is_Scalar_Type
(Typ
) then
6485 -- Never known if this is a generic type, since the bounds of generic
6486 -- types are junk. Note that if we only checked for static expressions
6487 -- (instead of compile-time-known values) below, we would not need this
6488 -- check, because values of a generic type can never be static, but they
6489 -- can be known at compile time.
6491 elsif Is_Generic_Type
(Typ
) then
6494 -- Case of a known compile time value, where we can check if it is in
6495 -- the bounds of the given type.
6497 elsif Compile_Time_Known_Value
(N
) then
6506 Lo
:= Type_Low_Bound
(Typ
);
6507 Hi
:= Type_High_Bound
(Typ
);
6509 LB_Known
:= Compile_Time_Known_Value
(Lo
);
6510 HB_Known
:= Compile_Time_Known_Value
(Hi
);
6512 -- Fixed point types should be considered as such only if flag
6513 -- Fixed_Int is set to False.
6515 if Is_Floating_Point_Type
(Typ
)
6516 or else (Is_Fixed_Point_Type
(Typ
) and then not Fixed_Int
)
6519 Valr
:= Expr_Value_R
(N
);
6521 if LB_Known
and HB_Known
then
6522 if Valr
>= Expr_Value_R
(Lo
)
6524 Valr
<= Expr_Value_R
(Hi
)
6528 return Out_Of_Range
;
6531 elsif (LB_Known
and then Valr
< Expr_Value_R
(Lo
))
6533 (HB_Known
and then Valr
> Expr_Value_R
(Hi
))
6535 return Out_Of_Range
;
6542 Val
:= Expr_Value
(N
);
6544 if LB_Known
and HB_Known
then
6545 if Val
>= Expr_Value
(Lo
) and then Val
<= Expr_Value
(Hi
)
6549 return Out_Of_Range
;
6552 elsif (LB_Known
and then Val
< Expr_Value
(Lo
))
6554 (HB_Known
and then Val
> Expr_Value
(Hi
))
6556 return Out_Of_Range
;
6564 -- Here for value not known at compile time. Case of expression subtype
6565 -- is Typ or is a subtype of Typ, and we can assume expression is valid.
6566 -- In this case we know it is in range without knowing its value.
6569 and then (Etype
(N
) = Typ
or else Is_Subtype_Of
(Etype
(N
), Typ
))
6573 -- Another special case. For signed integer types, if the target type
6574 -- has Is_Known_Valid set, and the source type does not have a larger
6575 -- size, then the source value must be in range. We exclude biased
6576 -- types, because they bizarrely can generate out of range values.
6578 elsif Is_Signed_Integer_Type
(Etype
(N
))
6579 and then Is_Known_Valid
(Typ
)
6580 and then Esize
(Etype
(N
)) <= Esize
(Typ
)
6581 and then not Has_Biased_Representation
(Etype
(N
))
6585 -- For all other cases, result is unknown
6596 procedure To_Bits
(U
: Uint
; B
: out Bits
) is
6598 for J
in 0 .. B
'Last loop
6599 B
(J
) := (U
/ (2 ** J
)) mod 2 /= 0;
6603 --------------------
6604 -- Why_Not_Static --
6605 --------------------
6607 procedure Why_Not_Static
(Expr
: Node_Id
) is
6608 N
: constant Node_Id
:= Original_Node
(Expr
);
6609 Typ
: Entity_Id
:= Empty
;
6614 procedure Why_Not_Static_List
(L
: List_Id
);
6615 -- A version that can be called on a list of expressions. Finds all
6616 -- non-static violations in any element of the list.
6618 -------------------------
6619 -- Why_Not_Static_List --
6620 -------------------------
6622 procedure Why_Not_Static_List
(L
: List_Id
) is
6625 if Is_Non_Empty_List
(L
) then
6627 while Present
(N
) loop
6632 end Why_Not_Static_List
;
6634 -- Start of processing for Why_Not_Static
6637 -- Ignore call on error or empty node
6639 if No
(Expr
) or else Nkind
(Expr
) = N_Error
then
6643 -- Preprocessing for sub expressions
6645 if Nkind
(Expr
) in N_Subexpr
then
6647 -- Nothing to do if expression is static
6649 if Is_OK_Static_Expression
(Expr
) then
6653 -- Test for Constraint_Error raised
6655 if Raises_Constraint_Error
(Expr
) then
6657 -- Special case membership to find out which piece to flag
6659 if Nkind
(N
) in N_Membership_Test
then
6660 if Raises_Constraint_Error
(Left_Opnd
(N
)) then
6661 Why_Not_Static
(Left_Opnd
(N
));
6664 elsif Present
(Right_Opnd
(N
))
6665 and then Raises_Constraint_Error
(Right_Opnd
(N
))
6667 Why_Not_Static
(Right_Opnd
(N
));
6671 pragma Assert
(Present
(Alternatives
(N
)));
6673 Alt
:= First
(Alternatives
(N
));
6674 while Present
(Alt
) loop
6675 if Raises_Constraint_Error
(Alt
) then
6676 Why_Not_Static
(Alt
);
6684 -- Special case a range to find out which bound to flag
6686 elsif Nkind
(N
) = N_Range
then
6687 if Raises_Constraint_Error
(Low_Bound
(N
)) then
6688 Why_Not_Static
(Low_Bound
(N
));
6691 elsif Raises_Constraint_Error
(High_Bound
(N
)) then
6692 Why_Not_Static
(High_Bound
(N
));
6696 -- Special case attribute to see which part to flag
6698 elsif Nkind
(N
) = N_Attribute_Reference
then
6699 if Raises_Constraint_Error
(Prefix
(N
)) then
6700 Why_Not_Static
(Prefix
(N
));
6704 if Present
(Expressions
(N
)) then
6705 Exp
:= First
(Expressions
(N
));
6706 while Present
(Exp
) loop
6707 if Raises_Constraint_Error
(Exp
) then
6708 Why_Not_Static
(Exp
);
6716 -- Special case a subtype name
6718 elsif Is_Entity_Name
(Expr
) and then Is_Type
(Entity
(Expr
)) then
6720 ("!& is not a static subtype (RM 4.9(26))", N
, Entity
(Expr
));
6724 -- End of special cases
6727 ("!expression raises exception, cannot be static (RM 4.9(34))",
6732 -- If no type, then something is pretty wrong, so ignore
6734 Typ
:= Etype
(Expr
);
6740 -- Type must be scalar or string type (but allow Bignum, since this
6741 -- is really a scalar type from our point of view in this diagnosis).
6743 if not Is_Scalar_Type
(Typ
)
6744 and then not Is_String_Type
(Typ
)
6745 and then not Is_RTE
(Typ
, RE_Bignum
)
6748 ("!static expression must have scalar or string type " &
6754 -- If we got through those checks, test particular node kind
6760 when N_Expanded_Name
6766 if Is_Named_Number
(E
) then
6769 elsif Ekind
(E
) = E_Constant
then
6771 -- One case we can give a metter message is when we have a
6772 -- string literal created by concatenating an aggregate with
6773 -- an others expression.
6775 Entity_Case
: declare
6776 CV
: constant Node_Id
:= Constant_Value
(E
);
6777 CO
: constant Node_Id
:= Original_Node
(CV
);
6779 function Is_Aggregate
(N
: Node_Id
) return Boolean;
6780 -- See if node N came from an others aggregate, if so
6781 -- return True and set Error_Msg_Sloc to aggregate.
6787 function Is_Aggregate
(N
: Node_Id
) return Boolean is
6789 if Nkind
(Original_Node
(N
)) = N_Aggregate
then
6790 Error_Msg_Sloc
:= Sloc
(Original_Node
(N
));
6793 elsif Is_Entity_Name
(N
)
6794 and then Ekind
(Entity
(N
)) = E_Constant
6796 Nkind
(Original_Node
(Constant_Value
(Entity
(N
)))) =
6800 Sloc
(Original_Node
(Constant_Value
(Entity
(N
))));
6808 -- Start of processing for Entity_Case
6811 if Is_Aggregate
(CV
)
6812 or else (Nkind
(CO
) = N_Op_Concat
6813 and then (Is_Aggregate
(Left_Opnd
(CO
))
6815 Is_Aggregate
(Right_Opnd
(CO
))))
6817 Error_Msg_N
("!aggregate (#) is never static", N
);
6819 elsif No
(CV
) or else not Is_Static_Expression
(CV
) then
6821 ("!& is not a static constant (RM 4.9(5))", N
, E
);
6825 elsif Is_Type
(E
) then
6827 ("!& is not a static subtype (RM 4.9(26))", N
, E
);
6831 ("!& is not static constant or named number "
6832 & "(RM 4.9(5))", N
, E
);
6841 if Nkind
(N
) in N_Op_Shift
then
6843 ("!shift functions are never static (RM 4.9(6,18))", N
);
6845 Why_Not_Static
(Left_Opnd
(N
));
6846 Why_Not_Static
(Right_Opnd
(N
));
6852 Why_Not_Static
(Right_Opnd
(N
));
6854 -- Attribute reference
6856 when N_Attribute_Reference
=>
6857 Why_Not_Static_List
(Expressions
(N
));
6859 E
:= Etype
(Prefix
(N
));
6861 if E
= Standard_Void_Type
then
6865 -- Special case non-scalar'Size since this is a common error
6867 if Attribute_Name
(N
) = Name_Size
then
6869 ("!size attribute is only static for static scalar type "
6870 & "(RM 4.9(7,8))", N
);
6874 elsif Is_Array_Type
(E
) then
6875 if not Nam_In
(Attribute_Name
(N
), Name_First
,
6880 ("!static array attribute must be Length, First, or Last "
6881 & "(RM 4.9(8))", N
);
6883 -- Since we know the expression is not-static (we already
6884 -- tested for this, must mean array is not static).
6888 ("!prefix is non-static array (RM 4.9(8))", Prefix
(N
));
6893 -- Special case generic types, since again this is a common source
6896 elsif Is_Generic_Actual_Type
(E
) or else Is_Generic_Type
(E
) then
6898 ("!attribute of generic type is never static "
6899 & "(RM 4.9(7,8))", N
);
6901 elsif Is_OK_Static_Subtype
(E
) then
6904 elsif Is_Scalar_Type
(E
) then
6906 ("!prefix type for attribute is not static scalar subtype "
6907 & "(RM 4.9(7))", N
);
6911 ("!static attribute must apply to array/scalar type "
6912 & "(RM 4.9(7,8))", N
);
6917 when N_String_Literal
=>
6919 ("!subtype of string literal is non-static (RM 4.9(4))", N
);
6921 -- Explicit dereference
6923 when N_Explicit_Dereference
=>
6925 ("!explicit dereference is never static (RM 4.9)", N
);
6929 when N_Function_Call
=>
6930 Why_Not_Static_List
(Parameter_Associations
(N
));
6932 -- Complain about non-static function call unless we have Bignum
6933 -- which means that the underlying expression is really some
6934 -- scalar arithmetic operation.
6936 if not Is_RTE
(Typ
, RE_Bignum
) then
6937 Error_Msg_N
("!non-static function call (RM 4.9(6,18))", N
);
6940 -- Parameter assocation (test actual parameter)
6942 when N_Parameter_Association
=>
6943 Why_Not_Static
(Explicit_Actual_Parameter
(N
));
6945 -- Indexed component
6947 when N_Indexed_Component
=>
6948 Error_Msg_N
("!indexed component is never static (RM 4.9)", N
);
6952 when N_Procedure_Call_Statement
=>
6953 Error_Msg_N
("!procedure call is never static (RM 4.9)", N
);
6955 -- Qualified expression (test expression)
6957 when N_Qualified_Expression
=>
6958 Why_Not_Static
(Expression
(N
));
6963 | N_Extension_Aggregate
6965 Error_Msg_N
("!an aggregate is never static (RM 4.9)", N
);
6970 Why_Not_Static
(Low_Bound
(N
));
6971 Why_Not_Static
(High_Bound
(N
));
6973 -- Range constraint, test range expression
6975 when N_Range_Constraint
=>
6976 Why_Not_Static
(Range_Expression
(N
));
6978 -- Subtype indication, test constraint
6980 when N_Subtype_Indication
=>
6981 Why_Not_Static
(Constraint
(N
));
6983 -- Selected component
6985 when N_Selected_Component
=>
6986 Error_Msg_N
("!selected component is never static (RM 4.9)", N
);
6991 Error_Msg_N
("!slice is never static (RM 4.9)", N
);
6993 when N_Type_Conversion
=>
6994 Why_Not_Static
(Expression
(N
));
6996 if not Is_Scalar_Type
(Entity
(Subtype_Mark
(N
)))
6997 or else not Is_OK_Static_Subtype
(Entity
(Subtype_Mark
(N
)))
7000 ("!static conversion requires static scalar subtype result "
7001 & "(RM 4.9(9))", N
);
7004 -- Unchecked type conversion
7006 when N_Unchecked_Type_Conversion
=>
7008 ("!unchecked type conversion is never static (RM 4.9)", N
);
7010 -- All other cases, no reason to give