1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2021, 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 Einfo
.Entities
; use Einfo
.Entities
;
32 with Einfo
.Utils
; use Einfo
.Utils
;
33 with Elists
; use Elists
;
34 with Errout
; use Errout
;
35 with Eval_Fat
; use Eval_Fat
;
36 with Exp_Util
; use Exp_Util
;
37 with Freeze
; use Freeze
;
39 with Namet
; use Namet
;
40 with Nmake
; use Nmake
;
41 with Nlists
; use Nlists
;
43 with Par_SCO
; use Par_SCO
;
44 with Rtsfind
; use Rtsfind
;
46 with Sem_Aux
; use Sem_Aux
;
47 with Sem_Cat
; use Sem_Cat
;
48 with Sem_Ch3
; use Sem_Ch3
;
49 with Sem_Ch6
; use Sem_Ch6
;
50 with Sem_Ch8
; use Sem_Ch8
;
51 with Sem_Elab
; use Sem_Elab
;
52 with Sem_Res
; use Sem_Res
;
53 with Sem_Util
; use Sem_Util
;
54 with Sem_Type
; use Sem_Type
;
55 with Sem_Warn
; use Sem_Warn
;
56 with Sinfo
; use Sinfo
;
57 with Sinfo
.Nodes
; use Sinfo
.Nodes
;
58 with Sinfo
.Utils
; use Sinfo
.Utils
;
59 with Snames
; use Snames
;
60 with Stand
; use Stand
;
61 with Stringt
; use Stringt
;
62 with Tbuild
; use Tbuild
;
64 package body Sem_Eval
is
66 -----------------------------------------
67 -- Handling of Compile Time Evaluation --
68 -----------------------------------------
70 -- The compile time evaluation of expressions is distributed over several
71 -- Eval_xxx procedures. These procedures are called immediately after
72 -- a subexpression is resolved and is therefore accomplished in a bottom
73 -- up fashion. The flags are synthesized using the following approach.
75 -- Is_Static_Expression is determined by following the rules in
76 -- RM-4.9. This involves testing the Is_Static_Expression flag of
77 -- the operands in many cases.
79 -- Raises_Constraint_Error is usually set if any of the operands have
80 -- the flag set or if an attempt to compute the value of the current
81 -- expression results in Constraint_Error.
83 -- The general approach is as follows. First compute Is_Static_Expression.
84 -- If the node is not static, then the flag is left off in the node and
85 -- we are all done. Otherwise for a static node, we test if any of the
86 -- operands will raise Constraint_Error, and if so, propagate the flag
87 -- Raises_Constraint_Error to the result node and we are done (since the
88 -- error was already posted at a lower level).
90 -- For the case of a static node whose operands do not raise constraint
91 -- error, we attempt to evaluate the node. If this evaluation succeeds,
92 -- then the node is replaced by the result of this computation. If the
93 -- evaluation raises Constraint_Error, then we rewrite the node with
94 -- Apply_Compile_Time_Constraint_Error to raise the exception and also
95 -- to post appropriate error messages.
101 type Bits
is array (Nat
range <>) of Boolean;
102 -- Used to convert unsigned (modular) values for folding logical ops
104 -- The following declarations are used to maintain a cache of nodes that
105 -- have compile-time-known values. The cache is maintained only for
106 -- discrete types (the most common case), and is populated by calls to
107 -- Compile_Time_Known_Value and Expr_Value, but only used by Expr_Value
108 -- since it is possible for the status to change (in particular it is
109 -- possible for a node to get replaced by a Constraint_Error node).
111 CV_Bits
: constant := 5;
112 -- Number of low order bits of Node_Id value used to reference entries
113 -- in the cache table.
115 CV_Cache_Size
: constant Nat
:= 2 ** CV_Bits
;
116 -- Size of cache for compile time values
118 subtype CV_Range
is Nat
range 0 .. CV_Cache_Size
;
120 type CV_Entry
is record
122 -- We use 'Base here, in case we want to add a predicate to Node_Id
126 type Match_Result
is (Match
, No_Match
, Non_Static
);
127 -- Result returned from functions that test for a matching result. If the
128 -- operands are not OK_Static then Non_Static will be returned. Otherwise
129 -- Match/No_Match is returned depending on whether the match succeeds.
131 type CV_Cache_Array
is array (CV_Range
) of CV_Entry
;
133 CV_Cache
: CV_Cache_Array
;
134 -- This is the actual cache, with entries consisting of node/value pairs,
135 -- and the impossible value Node_High_Bound used for unset entries.
137 type Range_Membership
is (In_Range
, Out_Of_Range
, Unknown
);
138 -- Range membership may either be statically known to be in range or out
139 -- of range, or not statically known. Used for Test_In_Range below.
141 Checking_For_Potentially_Static_Expression
: Boolean := False;
142 -- Global flag that is set True during Analyze_Static_Expression_Function
143 -- in order to verify that the result expression of a static expression
144 -- function is a potentially static function (see RM2022 6.8(5.3)).
146 -----------------------
147 -- Local Subprograms --
148 -----------------------
150 procedure Check_Non_Static_Context_For_Overflow
154 -- For a signed integer type, check non-static overflow in Result when
155 -- Stat is False. This applies also inside inlined code, where the static
156 -- property may be an effect of the inlining, which should not be allowed
157 -- to remove run-time checks (whether during compilation, or even more
158 -- crucially in the special inlining-for-proof in GNATprove mode).
160 function Choice_Matches
162 Choice
: Node_Id
) return Match_Result
;
163 -- Determines whether given value Expr matches the given Choice. The Expr
164 -- can be of discrete, real, or string type and must be a compile time
165 -- known value (it is an error to make the call if these conditions are
166 -- not met). The choice can be a range, subtype name, subtype indication,
167 -- or expression. The returned result is Non_Static if Choice is not
168 -- OK_Static, otherwise either Match or No_Match is returned depending
169 -- on whether Choice matches Expr. This is used for case expression
170 -- alternatives, and also for membership tests. In each case, more
171 -- possibilities are tested than the syntax allows (e.g. membership allows
172 -- subtype indications and non-discrete types, and case allows an OTHERS
173 -- choice), but it does not matter, since we have already done a full
174 -- semantic and syntax check of the construct, so the extra possibilities
175 -- just will not arise for correct expressions.
177 -- Note: if Choice_Matches finds that a choice raises Constraint_Error, e.g
178 -- a reference to a type, one of whose bounds raises Constraint_Error, then
179 -- it also sets the Raises_Constraint_Error flag on the Choice itself.
181 function Choices_Match
183 Choices
: List_Id
) return Match_Result
;
184 -- This function applies Choice_Matches to each element of Choices. If the
185 -- result is No_Match, then it continues and checks the next element. If
186 -- the result is Match or Non_Static, this result is immediately given
187 -- as the result without checking the rest of the list. Expr can be of
188 -- discrete, real, or string type and must be a compile-time-known value
189 -- (it is an error to make the call if these conditions are not met).
191 procedure Eval_Intrinsic_Call
(N
: Node_Id
; E
: Entity_Id
);
192 -- Evaluate a call N to an intrinsic subprogram E.
194 function Find_Universal_Operator_Type
(N
: Node_Id
) return Entity_Id
;
195 -- Check whether an arithmetic operation with universal operands which is a
196 -- rewritten function call with an explicit scope indication is ambiguous:
197 -- P."+" (1, 2) will be ambiguous if there is more than one visible numeric
198 -- type declared in P and the context does not impose a type on the result
199 -- (e.g. in the expression of a type conversion). If ambiguous, emit an
200 -- error and return Empty, else return the result type of the operator.
202 procedure Fold_Dummy
(N
: Node_Id
; Typ
: Entity_Id
);
203 -- Rewrite N as a constant dummy value in the relevant type if possible.
210 Static
: Boolean := False;
211 Check_Elab
: Boolean := False);
212 -- Rewrite N as the result of evaluating Left <shift op> Right if possible.
213 -- Op represents the shift operation.
214 -- Static indicates whether the resulting node should be marked static.
215 -- Check_Elab indicates whether checks for elaboration calls should be
216 -- inserted when relevant.
218 function From_Bits
(B
: Bits
; T
: Entity_Id
) return Uint
;
219 -- Converts a bit string of length B'Length to a Uint value to be used for
220 -- a target of type T, which is a modular type. This procedure includes the
221 -- necessary reduction by the modulus in the case of a nonbinary modulus
222 -- (for a binary modulus, the bit string is the right length any way so all
225 function Get_String_Val
(N
: Node_Id
) return Node_Id
;
226 -- Given a tree node for a folded string or character value, returns the
227 -- corresponding string literal or character literal (one of the two must
228 -- be available, or the operand would not have been marked as foldable in
229 -- the earlier analysis of the operation).
231 function Is_OK_Static_Choice
(Choice
: Node_Id
) return Boolean;
232 -- Given a choice (from a case expression or membership test), returns
233 -- True if the choice is static and does not raise a Constraint_Error.
235 function Is_OK_Static_Choice_List
(Choices
: List_Id
) return Boolean;
236 -- Given a choice list (from a case expression or membership test), return
237 -- True if all choices are static in the sense of Is_OK_Static_Choice.
239 function Is_Static_Choice
(Choice
: Node_Id
) return Boolean;
240 -- Given a choice (from a case expression or membership test), returns
241 -- True if the choice is static. No test is made for raising of constraint
242 -- error, so this function is used only for legality tests.
244 function Is_Static_Choice_List
(Choices
: List_Id
) return Boolean;
245 -- Given a choice list (from a case expression or membership test), return
246 -- True if all choices are static in the sense of Is_Static_Choice.
248 function Is_Static_Range
(N
: Node_Id
) return Boolean;
249 -- Determine if range is static, as defined in RM 4.9(26). The only allowed
250 -- argument is an N_Range node (but note that the semantic analysis of
251 -- equivalent range attribute references already turned them into the
252 -- equivalent range). This differs from Is_OK_Static_Range (which is what
253 -- must be used by clients) in that it does not care whether the bounds
254 -- raise Constraint_Error or not. Used for checking whether expressions are
255 -- static in the 4.9 sense (without worrying about exceptions).
257 function OK_Bits
(N
: Node_Id
; Bits
: Uint
) return Boolean;
258 -- Bits represents the number of bits in an integer value to be computed
259 -- (but the value has not been computed yet). If this value in Bits is
260 -- reasonable, a result of True is returned, with the implication that the
261 -- caller should go ahead and complete the calculation. If the value in
262 -- Bits is unreasonably large, then an error is posted on node N, and
263 -- False is returned (and the caller skips the proposed calculation).
265 procedure Out_Of_Range
(N
: Node_Id
);
266 -- This procedure is called if it is determined that node N, which appears
267 -- in a non-static context, is a compile-time-known value which is outside
268 -- its range, i.e. the range of Etype. This is used in contexts where
269 -- this is an illegality if N is static, and should generate a warning
272 function Real_Or_String_Static_Predicate_Matches
274 Typ
: Entity_Id
) return Boolean;
275 -- This is the function used to evaluate real or string static predicates.
276 -- Val is an unanalyzed N_Real_Literal or N_String_Literal node, which
277 -- represents the value to be tested against the predicate. Typ is the
278 -- type with the predicate, from which the predicate expression can be
279 -- extracted. The result returned is True if the given value satisfies
282 procedure Rewrite_In_Raise_CE
(N
: Node_Id
; Exp
: Node_Id
);
283 -- N and Exp are nodes representing an expression, Exp is known to raise
284 -- CE. N is rewritten in term of Exp in the optimal way.
286 function String_Type_Len
(Stype
: Entity_Id
) return Uint
;
287 -- Given a string type, determines the length of the index type, or, if
288 -- this index type is non-static, the length of the base type of this index
289 -- type. Note that if the string type is itself static, then the index type
290 -- is static, so the second case applies only if the string type passed is
293 function Test
(Cond
: Boolean) return Uint
;
294 pragma Inline
(Test
);
295 -- This function simply returns the appropriate Boolean'Pos value
296 -- corresponding to the value of Cond as a universal integer. It is
297 -- used for producing the result of the static evaluation of the
300 procedure Test_Expression_Is_Foldable
305 -- Tests to see if expression N whose single operand is Op1 is foldable,
306 -- i.e. the operand value is known at compile time. If the operation is
307 -- foldable, then Fold is True on return, and Stat indicates whether the
308 -- result is static (i.e. the operand was static). Note that it is quite
309 -- possible for Fold to be True, and Stat to be False, since there are
310 -- cases in which we know the value of an operand even though it is not
311 -- technically static (e.g. the static lower bound of a range whose upper
312 -- bound is non-static).
314 -- If Stat is set False on return, then Test_Expression_Is_Foldable makes
315 -- a call to Check_Non_Static_Context on the operand. If Fold is False on
316 -- return, then all processing is complete, and the caller should return,
317 -- since there is nothing else to do.
319 -- If Stat is set True on return, then Is_Static_Expression is also set
320 -- true in node N. There are some cases where this is over-enthusiastic,
321 -- e.g. in the two operand case below, for string comparison, the result is
322 -- not static even though the two operands are static. In such cases, the
323 -- caller must reset the Is_Static_Expression flag in N.
325 -- If Fold and Stat are both set to False then this routine performs also
326 -- the following extra actions:
328 -- If either operand is Any_Type then propagate it to result to prevent
331 -- If some operand raises Constraint_Error, then replace the node N
332 -- with the raise Constraint_Error node. This replacement inherits the
333 -- Is_Static_Expression flag from the operands.
335 procedure Test_Expression_Is_Foldable
341 CRT_Safe
: Boolean := False);
342 -- Same processing, except applies to an expression N with two operands
343 -- Op1 and Op2. The result is static only if both operands are static. If
344 -- CRT_Safe is set True, then CRT_Safe_Compile_Time_Known_Value is used
345 -- for the tests that the two operands are known at compile time. See
346 -- spec of this routine for further details.
348 function Test_In_Range
351 Assume_Valid
: Boolean;
353 Int_Real
: Boolean) return Range_Membership
;
354 -- Common processing for Is_In_Range and Is_Out_Of_Range: Returns In_Range
355 -- or Out_Of_Range if it can be guaranteed at compile time that expression
356 -- N is known to be in or out of range of the subtype Typ. If not compile
357 -- time known, Unknown is returned. See documentation of Is_In_Range for
358 -- complete description of parameters.
360 procedure To_Bits
(U
: Uint
; B
: out Bits
);
361 -- Converts a Uint value to a bit string of length B'Length
363 -----------------------------------------------
364 -- Check_Expression_Against_Static_Predicate --
365 -----------------------------------------------
367 procedure Check_Expression_Against_Static_Predicate
370 Static_Failure_Is_Error
: Boolean := False)
373 -- Nothing to do if expression is not known at compile time, or the
374 -- type has no static predicate set (will be the case for all non-scalar
375 -- types, so no need to make a special test for that).
377 if not (Has_Static_Predicate
(Typ
)
378 and then Compile_Time_Known_Value
(Expr
))
383 -- Here we have a static predicate (note that it could have arisen from
384 -- an explicitly specified Dynamic_Predicate whose expression met the
385 -- rules for being predicate-static). If the expression is known at
386 -- compile time and obeys the predicate, then it is static and must be
387 -- labeled as such, which matters e.g. for case statements. The original
388 -- expression may be a type conversion of a variable with a known value,
389 -- which might otherwise not be marked static.
391 -- Case of real static predicate
393 if Is_Real_Type
(Typ
) then
394 if Real_Or_String_Static_Predicate_Matches
395 (Val
=> Make_Real_Literal
(Sloc
(Expr
), Expr_Value_R
(Expr
)),
398 Set_Is_Static_Expression
(Expr
);
402 -- Case of string static predicate
404 elsif Is_String_Type
(Typ
) then
405 if Real_Or_String_Static_Predicate_Matches
406 (Val
=> Expr_Value_S
(Expr
), Typ
=> Typ
)
408 Set_Is_Static_Expression
(Expr
);
412 -- Case of discrete static predicate
415 pragma Assert
(Is_Discrete_Type
(Typ
));
417 -- If static predicate matches, nothing to do
419 if Choices_Match
(Expr
, Static_Discrete_Predicate
(Typ
)) = Match
then
420 Set_Is_Static_Expression
(Expr
);
425 -- Here we know that the predicate will fail
427 -- Special case of static expression failing a predicate (other than one
428 -- that was explicitly specified with a Dynamic_Predicate aspect). If
429 -- the expression comes from a qualified_expression or type_conversion
430 -- this is an error (Static_Failure_Is_Error); otherwise we only issue
431 -- a warning and the expression is no longer considered static.
433 if Is_Static_Expression
(Expr
)
434 and then not Has_Dynamic_Predicate_Aspect
(Typ
)
436 if Static_Failure_Is_Error
then
438 ("static expression fails static predicate check on &",
443 ("??static expression fails static predicate check on &",
446 ("\??expression is no longer considered static", Expr
);
448 Set_Is_Static_Expression
(Expr
, False);
451 -- In all other cases, this is just a warning that a test will fail.
452 -- It does not matter if the expression is static or not, or if the
453 -- predicate comes from a dynamic predicate aspect or not.
457 ("??expression fails predicate check on &", Expr
, Typ
);
459 -- Force a check here, which is potentially a redundant check, but
460 -- this ensures a check will be done in cases where the expression
461 -- is folded, and since this is definitely a failure, extra checks
464 if Predicate_Enabled
(Typ
) then
467 (Typ
, Duplicate_Subexpr
(Expr
)), Suppress
=> All_Checks
);
470 end Check_Expression_Against_Static_Predicate
;
472 ------------------------------
473 -- Check_Non_Static_Context --
474 ------------------------------
476 procedure Check_Non_Static_Context
(N
: Node_Id
) is
477 T
: constant Entity_Id
:= Etype
(N
);
478 Checks_On
: constant Boolean :=
479 not Index_Checks_Suppressed
(T
)
480 and not Range_Checks_Suppressed
(T
);
483 -- Ignore cases of non-scalar types, error types, or universal real
484 -- types that have no usable bounds.
487 or else not Is_Scalar_Type
(T
)
488 or else T
= Universal_Fixed
489 or else T
= Universal_Real
494 -- At this stage we have a scalar type. If we have an expression that
495 -- raises CE, then we already issued a warning or error msg so there is
496 -- nothing more to be done in this routine.
498 if Raises_Constraint_Error
(N
) then
502 -- Now we have a scalar type which is not marked as raising a constraint
503 -- error exception. The main purpose of this routine is to deal with
504 -- static expressions appearing in a non-static context. That means
505 -- that if we do not have a static expression then there is not much
506 -- to do. The one case that we deal with here is that if we have a
507 -- floating-point value that is out of range, then we post a warning
508 -- that an infinity will result.
510 if not Is_Static_Expression
(N
) then
511 if Is_Floating_Point_Type
(T
) then
512 if Is_Out_Of_Range
(N
, Base_Type
(T
), Assume_Valid
=> True) then
514 ("??float value out of range, infinity will be generated", N
);
516 -- The literal may be the result of constant-folding of a non-
517 -- static subexpression of a larger expression (e.g. a conversion
518 -- of a non-static variable whose value happens to be known). At
519 -- this point we must reduce the value of the subexpression to a
520 -- machine number (RM 4.9 (38/2)).
522 elsif Nkind
(N
) = N_Real_Literal
523 and then Nkind
(Parent
(N
)) in N_Subexpr
525 Rewrite
(N
, New_Copy
(N
));
526 Set_Realval
(N
, Machine_Number
(Base_Type
(T
), Realval
(N
), N
));
527 Set_Is_Machine_Number
(N
);
534 -- Here we have the case of outer level static expression of scalar
535 -- type, where the processing of this procedure is needed.
537 -- For real types, this is where we convert the value to a machine
538 -- number (see RM 4.9(38)). Also see ACVC test C490001. We should only
539 -- need to do this if the parent is a constant declaration, since in
540 -- other cases, gigi should do the necessary conversion correctly, but
541 -- experimentation shows that this is not the case on all machines, in
542 -- particular if we do not convert all literals to machine values in
543 -- non-static contexts, then ACVC test C490001 fails on Sparc/Solaris
546 -- This conversion is always done by GNATprove on real literals in
547 -- non-static expressions, by calling Check_Non_Static_Context from
548 -- gnat2why, as GNATprove cannot do the conversion later contrary
549 -- to gigi. The frontend computes the information about which
550 -- expressions are static, which is used by gnat2why to call
551 -- Check_Non_Static_Context on exactly those real literals that are
552 -- not subexpressions of static expressions.
554 if Nkind
(N
) = N_Real_Literal
555 and then not Is_Machine_Number
(N
)
556 and then not Is_Generic_Type
(Etype
(N
))
557 and then Etype
(N
) /= Universal_Real
559 -- Check that value is in bounds before converting to machine
560 -- number, so as not to lose case where value overflows in the
561 -- least significant bit or less. See B490001.
563 if Is_Out_Of_Range
(N
, Base_Type
(T
), Assume_Valid
=> True) then
568 -- Note: we have to copy the node, to avoid problems with conformance
569 -- of very similar numbers (see ACVC tests B4A010C and B63103A).
571 Rewrite
(N
, New_Copy
(N
));
573 if not Is_Floating_Point_Type
(T
) then
575 (N
, Corresponding_Integer_Value
(N
) * Small_Value
(T
));
577 elsif not UR_Is_Zero
(Realval
(N
)) then
578 Set_Realval
(N
, Machine_Number
(Base_Type
(T
), Realval
(N
), N
));
579 Set_Is_Machine_Number
(N
);
584 -- Check for out of range universal integer. This is a non-static
585 -- context, so the integer value must be in range of the runtime
586 -- representation of universal integers.
588 -- We do this only within an expression, because that is the only
589 -- case in which non-static universal integer values can occur, and
590 -- furthermore, Check_Non_Static_Context is currently (incorrectly???)
591 -- called in contexts like the expression of a number declaration where
592 -- we certainly want to allow out of range values.
594 -- We inhibit the warning when expansion is disabled, because the
595 -- preanalysis of a range of a 64-bit modular type may appear to
596 -- violate the constraint on non-static Universal_Integer. If there
597 -- is a true overflow it will be diagnosed during full analysis.
599 if Etype
(N
) = Universal_Integer
600 and then Nkind
(N
) = N_Integer_Literal
601 and then Nkind
(Parent
(N
)) in N_Subexpr
602 and then Expander_Active
604 (Intval
(N
) < Expr_Value
(Type_Low_Bound
(Universal_Integer
))
606 Intval
(N
) > Expr_Value
(Type_High_Bound
(Universal_Integer
)))
608 Apply_Compile_Time_Constraint_Error
609 (N
, "non-static universal integer value out of range<<",
610 CE_Range_Check_Failed
);
612 -- Check out of range of base type
614 elsif Is_Out_Of_Range
(N
, Base_Type
(T
), Assume_Valid
=> True) then
617 -- Give a warning or error on the value outside the subtype. A warning
618 -- is omitted if the expression appears in a range that could be null
619 -- (warnings are handled elsewhere for this case).
621 elsif T
/= Base_Type
(T
) and then Nkind
(Parent
(N
)) /= N_Range
then
622 if Is_In_Range
(N
, T
, Assume_Valid
=> True) then
625 elsif Is_Out_Of_Range
(N
, T
, Assume_Valid
=> True) then
626 -- Ignore out of range values for System.Priority in CodePeer
627 -- mode since the actual target compiler may provide a wider
630 if CodePeer_Mode
and then Is_RTE
(T
, RE_Priority
) then
631 Set_Do_Range_Check
(N
, False);
633 -- Determine if the out-of-range violation constitutes a warning
634 -- or an error based on context, according to RM 4.9 (34/3).
636 elsif Nkind
(Original_Node
(N
)) in
637 N_Type_Conversion | N_Qualified_Expression
638 and then Comes_From_Source
(Original_Node
(N
))
640 Apply_Compile_Time_Constraint_Error
641 (N
, "value not in range of}", CE_Range_Check_Failed
);
643 Apply_Compile_Time_Constraint_Error
644 (N
, "value not in range of}<<", CE_Range_Check_Failed
);
648 Enable_Range_Check
(N
);
651 Set_Do_Range_Check
(N
, False);
654 end Check_Non_Static_Context
;
656 -------------------------------------------
657 -- Check_Non_Static_Context_For_Overflow --
658 -------------------------------------------
660 procedure Check_Non_Static_Context_For_Overflow
666 if (not Stat
or else In_Inlined_Body
)
667 and then Is_Signed_Integer_Type
(Etype
(N
))
670 BT
: constant Entity_Id
:= Base_Type
(Etype
(N
));
671 Lo
: constant Uint
:= Expr_Value
(Type_Low_Bound
(BT
));
672 Hi
: constant Uint
:= Expr_Value
(Type_High_Bound
(BT
));
674 if Result
< Lo
or else Result
> Hi
then
675 Apply_Compile_Time_Constraint_Error
676 (N
, "value not in range of }??",
677 CE_Overflow_Check_Failed
,
682 end Check_Non_Static_Context_For_Overflow
;
684 ---------------------------------
685 -- Check_String_Literal_Length --
686 ---------------------------------
688 procedure Check_String_Literal_Length
(N
: Node_Id
; Ttype
: Entity_Id
) is
690 if not Raises_Constraint_Error
(N
) and then Is_Constrained
(Ttype
) then
691 if UI_From_Int
(String_Length
(Strval
(N
))) /= String_Type_Len
(Ttype
)
693 Apply_Compile_Time_Constraint_Error
694 (N
, "string length wrong for}??",
695 CE_Length_Check_Failed
,
700 end Check_String_Literal_Length
;
702 --------------------------------------------
703 -- Checking_Potentially_Static_Expression --
704 --------------------------------------------
706 function Checking_Potentially_Static_Expression
return Boolean is
708 return Checking_For_Potentially_Static_Expression
;
709 end Checking_Potentially_Static_Expression
;
715 function Choice_Matches
717 Choice
: Node_Id
) return Match_Result
719 Etyp
: constant Entity_Id
:= Etype
(Expr
);
725 pragma Assert
(Compile_Time_Known_Value
(Expr
));
726 pragma Assert
(Is_Scalar_Type
(Etyp
) or else Is_String_Type
(Etyp
));
728 if not Is_OK_Static_Choice
(Choice
) then
729 Set_Raises_Constraint_Error
(Choice
);
732 -- When the choice denotes a subtype with a static predictate, check the
733 -- expression against the predicate values. Different procedures apply
734 -- to discrete and non-discrete types.
736 elsif (Nkind
(Choice
) = N_Subtype_Indication
737 or else (Is_Entity_Name
(Choice
)
738 and then Is_Type
(Entity
(Choice
))))
739 and then Has_Predicates
(Etype
(Choice
))
740 and then Has_Static_Predicate
(Etype
(Choice
))
742 if Is_Discrete_Type
(Etype
(Choice
)) then
745 (Expr
, Static_Discrete_Predicate
(Etype
(Choice
)));
747 elsif Real_Or_String_Static_Predicate_Matches
(Expr
, Etype
(Choice
))
755 -- Discrete type case only
757 elsif Is_Discrete_Type
(Etyp
) then
758 Val
:= Expr_Value
(Expr
);
760 if Nkind
(Choice
) = N_Range
then
761 if Val
>= Expr_Value
(Low_Bound
(Choice
))
763 Val
<= Expr_Value
(High_Bound
(Choice
))
770 elsif Nkind
(Choice
) = N_Subtype_Indication
771 or else (Is_Entity_Name
(Choice
) and then Is_Type
(Entity
(Choice
)))
773 if Val
>= Expr_Value
(Type_Low_Bound
(Etype
(Choice
)))
775 Val
<= Expr_Value
(Type_High_Bound
(Etype
(Choice
)))
782 elsif Nkind
(Choice
) = N_Others_Choice
then
786 if Val
= Expr_Value
(Choice
) then
795 elsif Is_Real_Type
(Etyp
) then
796 ValR
:= Expr_Value_R
(Expr
);
798 if Nkind
(Choice
) = N_Range
then
799 if ValR
>= Expr_Value_R
(Low_Bound
(Choice
))
801 ValR
<= Expr_Value_R
(High_Bound
(Choice
))
808 elsif Nkind
(Choice
) = N_Subtype_Indication
809 or else (Is_Entity_Name
(Choice
) and then Is_Type
(Entity
(Choice
)))
811 if ValR
>= Expr_Value_R
(Type_Low_Bound
(Etype
(Choice
)))
813 ValR
<= Expr_Value_R
(Type_High_Bound
(Etype
(Choice
)))
821 if ValR
= Expr_Value_R
(Choice
) then
831 pragma Assert
(Is_String_Type
(Etyp
));
832 ValS
:= Expr_Value_S
(Expr
);
834 if Nkind
(Choice
) = N_Subtype_Indication
835 or else (Is_Entity_Name
(Choice
) and then Is_Type
(Entity
(Choice
)))
837 if not Is_Constrained
(Etype
(Choice
)) then
842 Typlen
: constant Uint
:=
843 String_Type_Len
(Etype
(Choice
));
844 Strlen
: constant Uint
:=
845 UI_From_Int
(String_Length
(Strval
(ValS
)));
847 if Typlen
= Strlen
then
856 if String_Equal
(Strval
(ValS
), Strval
(Expr_Value_S
(Choice
)))
870 function Choices_Match
872 Choices
: List_Id
) return Match_Result
875 Result
: Match_Result
;
878 Choice
:= First
(Choices
);
879 while Present
(Choice
) loop
880 Result
:= Choice_Matches
(Expr
, Choice
);
882 if Result
/= No_Match
then
892 --------------------------
893 -- Compile_Time_Compare --
894 --------------------------
896 function Compile_Time_Compare
898 Assume_Valid
: Boolean) return Compare_Result
900 Discard
: aliased Uint
;
902 return Compile_Time_Compare
(L
, R
, Discard
'Access, Assume_Valid
);
903 end Compile_Time_Compare
;
905 function Compile_Time_Compare
908 Assume_Valid
: Boolean;
909 Rec
: Boolean := False) return Compare_Result
911 Ltyp
: Entity_Id
:= Etype
(L
);
912 Rtyp
: Entity_Id
:= Etype
(R
);
914 Discard
: aliased Uint
;
916 procedure Compare_Decompose
920 -- This procedure decomposes the node N into an expression node and a
921 -- signed offset, so that the value of N is equal to the value of R plus
922 -- the value V (which may be negative). If no such decomposition is
923 -- possible, then on return R is a copy of N, and V is set to zero.
925 function Compare_Fixup
(N
: Node_Id
) return Node_Id
;
926 -- This function deals with replacing 'Last and 'First references with
927 -- their corresponding type bounds, which we then can compare. The
928 -- argument is the original node, the result is the identity, unless we
929 -- have a 'Last/'First reference in which case the value returned is the
930 -- appropriate type bound.
932 function Is_Known_Valid_Operand
(Opnd
: Node_Id
) return Boolean;
933 -- Even if the context does not assume that values are valid, some
934 -- simple cases can be recognized.
936 function Is_Same_Value
(L
, R
: Node_Id
) return Boolean;
937 -- Returns True iff L and R represent expressions that definitely have
938 -- identical (but not necessarily compile-time-known) values Indeed the
939 -- caller is expected to have already dealt with the cases of compile
940 -- time known values, so these are not tested here.
942 -----------------------
943 -- Compare_Decompose --
944 -----------------------
946 procedure Compare_Decompose
952 if Nkind
(N
) = N_Op_Add
953 and then Nkind
(Right_Opnd
(N
)) = N_Integer_Literal
956 V
:= Intval
(Right_Opnd
(N
));
959 elsif Nkind
(N
) = N_Op_Subtract
960 and then Nkind
(Right_Opnd
(N
)) = N_Integer_Literal
963 V
:= UI_Negate
(Intval
(Right_Opnd
(N
)));
966 elsif Nkind
(N
) = N_Attribute_Reference
then
967 if Attribute_Name
(N
) = Name_Succ
then
968 R
:= First
(Expressions
(N
));
972 elsif Attribute_Name
(N
) = Name_Pred
then
973 R
:= First
(Expressions
(N
));
981 end Compare_Decompose
;
987 function Compare_Fixup
(N
: Node_Id
) return Node_Id
is
993 -- Fixup only required for First/Last attribute reference
995 if Nkind
(N
) = N_Attribute_Reference
996 and then Attribute_Name
(N
) in Name_First | Name_Last
998 Xtyp
:= Etype
(Prefix
(N
));
1000 -- If we have no type, then just abandon the attempt to do
1001 -- a fixup, this is probably the result of some other error.
1007 -- Dereference an access type
1009 if Is_Access_Type
(Xtyp
) then
1010 Xtyp
:= Designated_Type
(Xtyp
);
1013 -- If we don't have an array type at this stage, something is
1014 -- peculiar, e.g. another error, and we abandon the attempt at
1017 if not Is_Array_Type
(Xtyp
) then
1021 -- Ignore unconstrained array, since bounds are not meaningful
1023 if not Is_Constrained
(Xtyp
) then
1027 if Ekind
(Xtyp
) = E_String_Literal_Subtype
then
1028 if Attribute_Name
(N
) = Name_First
then
1029 return String_Literal_Low_Bound
(Xtyp
);
1032 Make_Integer_Literal
(Sloc
(N
),
1033 Intval
=> Intval
(String_Literal_Low_Bound
(Xtyp
)) +
1034 String_Literal_Length
(Xtyp
));
1038 -- Find correct index type
1040 Indx
:= First_Index
(Xtyp
);
1042 if Present
(Expressions
(N
)) then
1043 Subs
:= UI_To_Int
(Expr_Value
(First
(Expressions
(N
))));
1045 for J
in 2 .. Subs
loop
1050 Xtyp
:= Etype
(Indx
);
1052 if Attribute_Name
(N
) = Name_First
then
1053 return Type_Low_Bound
(Xtyp
);
1055 return Type_High_Bound
(Xtyp
);
1062 ----------------------------
1063 -- Is_Known_Valid_Operand --
1064 ----------------------------
1066 function Is_Known_Valid_Operand
(Opnd
: Node_Id
) return Boolean is
1068 return (Is_Entity_Name
(Opnd
)
1070 (Is_Known_Valid
(Entity
(Opnd
))
1071 or else Ekind
(Entity
(Opnd
)) = E_In_Parameter
1073 (Is_Object
(Entity
(Opnd
))
1074 and then Present
(Current_Value
(Entity
(Opnd
))))))
1075 or else Is_OK_Static_Expression
(Opnd
);
1076 end Is_Known_Valid_Operand
;
1082 function Is_Same_Value
(L
, R
: Node_Id
) return Boolean is
1083 Lf
: constant Node_Id
:= Compare_Fixup
(L
);
1084 Rf
: constant Node_Id
:= Compare_Fixup
(R
);
1086 function Is_Rewritten_Loop_Entry
(N
: Node_Id
) return Boolean;
1087 -- An attribute reference to Loop_Entry may have been rewritten into
1088 -- its prefix as a way to avoid generating a constant for that
1089 -- attribute when the corresponding pragma is ignored. These nodes
1090 -- should be ignored when deciding if they can be equal to one
1093 function Is_Same_Subscript
(L
, R
: List_Id
) return Boolean;
1094 -- L, R are the Expressions values from two attribute nodes for First
1095 -- or Last attributes. Either may be set to No_List if no expressions
1096 -- are present (indicating subscript 1). The result is True if both
1097 -- expressions represent the same subscript (note one case is where
1098 -- one subscript is missing and the other is explicitly set to 1).
1100 -----------------------------
1101 -- Is_Rewritten_Loop_Entry --
1102 -----------------------------
1104 function Is_Rewritten_Loop_Entry
(N
: Node_Id
) return Boolean is
1105 Orig_N
: constant Node_Id
:= Original_Node
(N
);
1108 and then Nkind
(Orig_N
) = N_Attribute_Reference
1109 and then Get_Attribute_Id
(Attribute_Name
(Orig_N
)) =
1110 Attribute_Loop_Entry
;
1111 end Is_Rewritten_Loop_Entry
;
1113 -----------------------
1114 -- Is_Same_Subscript --
1115 -----------------------
1117 function Is_Same_Subscript
(L
, R
: List_Id
) return Boolean is
1123 return Expr_Value
(First
(R
)) = Uint_1
;
1128 return Expr_Value
(First
(L
)) = Uint_1
;
1130 return Expr_Value
(First
(L
)) = Expr_Value
(First
(R
));
1133 end Is_Same_Subscript
;
1135 -- Start of processing for Is_Same_Value
1138 -- Loop_Entry nodes rewritten into their prefix inside ignored
1139 -- pragmas should never lead to a decision of equality.
1141 if Is_Rewritten_Loop_Entry
(Lf
)
1142 or else Is_Rewritten_Loop_Entry
(Rf
)
1146 -- Values are the same if they refer to the same entity and the
1147 -- entity is nonvolatile.
1149 elsif Nkind
(Lf
) in N_Identifier | N_Expanded_Name
1150 and then Nkind
(Rf
) in N_Identifier | N_Expanded_Name
1151 and then Entity
(Lf
) = Entity
(Rf
)
1153 -- If the entity is a discriminant, the two expressions may be
1154 -- bounds of components of objects of the same discriminated type.
1155 -- The values of the discriminants are not static, and therefore
1156 -- the result is unknown.
1158 and then Ekind
(Entity
(Lf
)) /= E_Discriminant
1159 and then Present
(Entity
(Lf
))
1161 -- This does not however apply to Float types, since we may have
1162 -- two NaN values and they should never compare equal.
1164 and then not Is_Floating_Point_Type
(Etype
(L
))
1165 and then not Is_Volatile_Reference
(L
)
1166 and then not Is_Volatile_Reference
(R
)
1170 -- Or if they are compile-time-known and identical
1172 elsif Compile_Time_Known_Value
(Lf
)
1174 Compile_Time_Known_Value
(Rf
)
1175 and then Expr_Value
(Lf
) = Expr_Value
(Rf
)
1179 -- False if Nkind of the two nodes is different for remaining cases
1181 elsif Nkind
(Lf
) /= Nkind
(Rf
) then
1184 -- True if both 'First or 'Last values applying to the same entity
1185 -- (first and last don't change even if value does). Note that we
1186 -- need this even with the calls to Compare_Fixup, to handle the
1187 -- case of unconstrained array attributes where Compare_Fixup
1188 -- cannot find useful bounds.
1190 elsif Nkind
(Lf
) = N_Attribute_Reference
1191 and then Attribute_Name
(Lf
) = Attribute_Name
(Rf
)
1192 and then Attribute_Name
(Lf
) in Name_First | Name_Last
1193 and then Nkind
(Prefix
(Lf
)) in N_Identifier | N_Expanded_Name
1194 and then Nkind
(Prefix
(Rf
)) in N_Identifier | N_Expanded_Name
1195 and then Entity
(Prefix
(Lf
)) = Entity
(Prefix
(Rf
))
1196 and then Is_Same_Subscript
(Expressions
(Lf
), Expressions
(Rf
))
1200 -- True if the same selected component from the same record
1202 elsif Nkind
(Lf
) = N_Selected_Component
1203 and then Selector_Name
(Lf
) = Selector_Name
(Rf
)
1204 and then Is_Same_Value
(Prefix
(Lf
), Prefix
(Rf
))
1208 -- True if the same unary operator applied to the same operand
1210 elsif Nkind
(Lf
) in N_Unary_Op
1211 and then Is_Same_Value
(Right_Opnd
(Lf
), Right_Opnd
(Rf
))
1215 -- True if the same binary operator applied to the same operands
1217 elsif Nkind
(Lf
) in N_Binary_Op
1218 and then Is_Same_Value
(Left_Opnd
(Lf
), Left_Opnd
(Rf
))
1219 and then Is_Same_Value
(Right_Opnd
(Lf
), Right_Opnd
(Rf
))
1223 -- All other cases, we can't tell, so return False
1230 -- Start of processing for Compile_Time_Compare
1233 Diff
.all := No_Uint
;
1235 -- In preanalysis mode, always return Unknown unless the expression
1236 -- is static. It is too early to be thinking we know the result of a
1237 -- comparison, save that judgment for the full analysis. This is
1238 -- particularly important in the case of pre and postconditions, which
1239 -- otherwise can be prematurely collapsed into having True or False
1240 -- conditions when this is inappropriate.
1242 if not (Full_Analysis
1243 or else (Is_OK_Static_Expression
(L
)
1245 Is_OK_Static_Expression
(R
)))
1250 -- If either operand could raise Constraint_Error, then we cannot
1251 -- know the result at compile time (since CE may be raised).
1253 if not (Cannot_Raise_Constraint_Error
(L
)
1255 Cannot_Raise_Constraint_Error
(R
))
1260 -- Identical operands are most certainly equal
1266 -- If expressions have no types, then do not attempt to determine if
1267 -- they are the same, since something funny is going on. One case in
1268 -- which this happens is during generic template analysis, when bounds
1269 -- are not fully analyzed.
1271 if No
(Ltyp
) or else No
(Rtyp
) then
1275 -- These get reset to the base type for the case of entities where
1276 -- Is_Known_Valid is not set. This takes care of handling possible
1277 -- invalid representations using the value of the base type, in
1278 -- accordance with RM 13.9.1(10).
1280 Ltyp
:= Underlying_Type
(Ltyp
);
1281 Rtyp
:= Underlying_Type
(Rtyp
);
1283 -- Same rationale as above, but for Underlying_Type instead of Etype
1285 if No
(Ltyp
) or else No
(Rtyp
) then
1289 -- We do not attempt comparisons for packed arrays represented as
1290 -- modular types, where the semantics of comparison is quite different.
1292 if Is_Packed_Array_Impl_Type
(Ltyp
)
1293 and then Is_Modular_Integer_Type
(Ltyp
)
1297 -- For access types, the only time we know the result at compile time
1298 -- (apart from identical operands, which we handled already) is if we
1299 -- know one operand is null and the other is not, or both operands are
1302 elsif Is_Access_Type
(Ltyp
) then
1303 if Known_Null
(L
) then
1304 if Known_Null
(R
) then
1306 elsif Known_Non_Null
(R
) then
1312 elsif Known_Non_Null
(L
) and then Known_Null
(R
) then
1319 -- Case where comparison involves two compile-time-known values
1321 elsif Compile_Time_Known_Value
(L
)
1323 Compile_Time_Known_Value
(R
)
1325 -- For the floating-point case, we have to be a little careful, since
1326 -- at compile time we are dealing with universal exact values, but at
1327 -- runtime, these will be in non-exact target form. That's why the
1328 -- returned results are LE and GE below instead of LT and GT.
1330 if Is_Floating_Point_Type
(Ltyp
)
1332 Is_Floating_Point_Type
(Rtyp
)
1335 Lo
: constant Ureal
:= Expr_Value_R
(L
);
1336 Hi
: constant Ureal
:= Expr_Value_R
(R
);
1347 -- For string types, we have two string literals and we proceed to
1348 -- compare them using the Ada style dictionary string comparison.
1350 elsif not Is_Scalar_Type
(Ltyp
) then
1352 Lstring
: constant String_Id
:= Strval
(Expr_Value_S
(L
));
1353 Rstring
: constant String_Id
:= Strval
(Expr_Value_S
(R
));
1354 Llen
: constant Nat
:= String_Length
(Lstring
);
1355 Rlen
: constant Nat
:= String_Length
(Rstring
);
1358 for J
in 1 .. Nat
'Min (Llen
, Rlen
) loop
1360 LC
: constant Char_Code
:= Get_String_Char
(Lstring
, J
);
1361 RC
: constant Char_Code
:= Get_String_Char
(Rstring
, J
);
1373 elsif Llen
> Rlen
then
1380 -- For remaining scalar cases we know exactly (note that this does
1381 -- include the fixed-point case, where we know the run time integer
1386 Lo
: constant Uint
:= Expr_Value
(L
);
1387 Hi
: constant Uint
:= Expr_Value
(R
);
1390 Diff
.all := Hi
- Lo
;
1395 Diff
.all := Lo
- Hi
;
1401 -- Cases where at least one operand is not known at compile time
1404 -- Remaining checks apply only for discrete types
1406 if not Is_Discrete_Type
(Ltyp
)
1408 not Is_Discrete_Type
(Rtyp
)
1413 -- Defend against generic types, or actually any expressions that
1414 -- contain a reference to a generic type from within a generic
1415 -- template. We don't want to do any range analysis of such
1416 -- expressions for two reasons. First, the bounds of a generic type
1417 -- itself are junk and cannot be used for any kind of analysis.
1418 -- Second, we may have a case where the range at run time is indeed
1419 -- known, but we don't want to do compile time analysis in the
1420 -- template based on that range since in an instance the value may be
1421 -- static, and able to be elaborated without reference to the bounds
1422 -- of types involved. As an example, consider:
1424 -- (F'Pos (F'Last) + 1) > Integer'Last
1426 -- The expression on the left side of > is Universal_Integer and thus
1427 -- acquires the type Integer for evaluation at run time, and at run
1428 -- time it is true that this condition is always False, but within
1429 -- an instance F may be a type with a static range greater than the
1430 -- range of Integer, and the expression statically evaluates to True.
1432 if References_Generic_Formal_Type
(L
)
1434 References_Generic_Formal_Type
(R
)
1439 -- Replace types by base types for the case of values which are not
1440 -- known to have valid representations. This takes care of properly
1441 -- dealing with invalid representations.
1443 if not Assume_Valid
then
1444 if not (Is_Entity_Name
(L
)
1445 and then (Is_Known_Valid
(Entity
(L
))
1446 or else Assume_No_Invalid_Values
))
1448 Ltyp
:= Underlying_Type
(Base_Type
(Ltyp
));
1451 if not (Is_Entity_Name
(R
)
1452 and then (Is_Known_Valid
(Entity
(R
))
1453 or else Assume_No_Invalid_Values
))
1455 Rtyp
:= Underlying_Type
(Base_Type
(Rtyp
));
1459 -- First attempt is to decompose the expressions to extract a
1460 -- constant offset resulting from the use of any of the forms:
1467 -- Then we see if the two expressions are the same value, and if so
1468 -- the result is obtained by comparing the offsets.
1470 -- Note: the reason we do this test first is that it returns only
1471 -- decisive results (with diff set), where other tests, like the
1472 -- range test, may not be as so decisive. Consider for example
1473 -- J .. J + 1. This code can conclude LT with a difference of 1,
1474 -- even if the range of J is not known.
1483 Compare_Decompose
(L
, Lnode
, Loffs
);
1484 Compare_Decompose
(R
, Rnode
, Roffs
);
1486 if Is_Same_Value
(Lnode
, Rnode
) then
1487 if Loffs
= Roffs
then
1491 -- When the offsets are not equal, we can go farther only if
1492 -- the types are not modular (e.g. X < X + 1 is False if X is
1493 -- the largest number).
1495 if not Is_Modular_Integer_Type
(Ltyp
)
1496 and then not Is_Modular_Integer_Type
(Rtyp
)
1498 if Loffs
< Roffs
then
1499 Diff
.all := Roffs
- Loffs
;
1502 Diff
.all := Loffs
- Roffs
;
1509 -- Next, try range analysis and see if operand ranges are disjoint
1517 -- True if each range is a single point
1520 Determine_Range
(L
, LOK
, LLo
, LHi
, Assume_Valid
);
1521 Determine_Range
(R
, ROK
, RLo
, RHi
, Assume_Valid
);
1524 Single
:= (LLo
= LHi
) and then (RLo
= RHi
);
1527 if Single
and Assume_Valid
then
1528 Diff
.all := RLo
- LLo
;
1533 elsif RHi
< LLo
then
1534 if Single
and Assume_Valid
then
1535 Diff
.all := LLo
- RLo
;
1540 elsif Single
and then LLo
= RLo
then
1542 -- If the range includes a single literal and we can assume
1543 -- validity then the result is known even if an operand is
1546 if Assume_Valid
then
1552 elsif LHi
= RLo
then
1555 elsif RHi
= LLo
then
1558 elsif not Is_Known_Valid_Operand
(L
)
1559 and then not Assume_Valid
1561 if Is_Same_Value
(L
, R
) then
1568 -- If the range of either operand cannot be determined, nothing
1569 -- further can be inferred.
1576 -- Here is where we check for comparisons against maximum bounds of
1577 -- types, where we know that no value can be outside the bounds of
1578 -- the subtype. Note that this routine is allowed to assume that all
1579 -- expressions are within their subtype bounds. Callers wishing to
1580 -- deal with possibly invalid values must in any case take special
1581 -- steps (e.g. conversions to larger types) to avoid this kind of
1582 -- optimization, which is always considered to be valid. We do not
1583 -- attempt this optimization with generic types, since the type
1584 -- bounds may not be meaningful in this case.
1586 -- We are in danger of an infinite recursion here. It does not seem
1587 -- useful to go more than one level deep, so the parameter Rec is
1588 -- used to protect ourselves against this infinite recursion.
1592 -- See if we can get a decisive check against one operand and a
1593 -- bound of the other operand (four possible tests here). Note
1594 -- that we avoid testing junk bounds of a generic type.
1596 if not Is_Generic_Type
(Rtyp
) then
1597 case Compile_Time_Compare
(L
, Type_Low_Bound
(Rtyp
),
1599 Assume_Valid
, Rec
=> True)
1601 when LT
=> return LT
;
1602 when LE
=> return LE
;
1603 when EQ
=> return LE
;
1604 when others => null;
1607 case Compile_Time_Compare
(L
, Type_High_Bound
(Rtyp
),
1609 Assume_Valid
, Rec
=> True)
1611 when GT
=> return GT
;
1612 when GE
=> return GE
;
1613 when EQ
=> return GE
;
1614 when others => null;
1618 if not Is_Generic_Type
(Ltyp
) then
1619 case Compile_Time_Compare
(Type_Low_Bound
(Ltyp
), R
,
1621 Assume_Valid
, Rec
=> True)
1623 when GT
=> return GT
;
1624 when GE
=> return GE
;
1625 when EQ
=> return GE
;
1626 when others => null;
1629 case Compile_Time_Compare
(Type_High_Bound
(Ltyp
), R
,
1631 Assume_Valid
, Rec
=> True)
1633 when LT
=> return LT
;
1634 when LE
=> return LE
;
1635 when EQ
=> return LE
;
1636 when others => null;
1641 -- Next attempt is to see if we have an entity compared with a
1642 -- compile-time-known value, where there is a current value
1643 -- conditional for the entity which can tell us the result.
1647 -- Entity variable (left operand)
1650 -- Value (right operand)
1653 -- If False, we have reversed the operands
1656 -- Comparison operator kind from Get_Current_Value_Condition call
1659 -- Value from Get_Current_Value_Condition call
1664 Result
: Compare_Result
;
1665 -- Known result before inversion
1668 if Is_Entity_Name
(L
)
1669 and then Compile_Time_Known_Value
(R
)
1672 Val
:= Expr_Value
(R
);
1675 elsif Is_Entity_Name
(R
)
1676 and then Compile_Time_Known_Value
(L
)
1679 Val
:= Expr_Value
(L
);
1682 -- That was the last chance at finding a compile time result
1688 Get_Current_Value_Condition
(Var
, Op
, Opn
);
1690 -- That was the last chance, so if we got nothing return
1696 Opv
:= Expr_Value
(Opn
);
1698 -- We got a comparison, so we might have something interesting
1700 -- Convert LE to LT and GE to GT, just so we have fewer cases
1702 if Op
= N_Op_Le
then
1706 elsif Op
= N_Op_Ge
then
1711 -- Deal with equality case
1713 if Op
= N_Op_Eq
then
1716 elsif Opv
< Val
then
1722 -- Deal with inequality case
1724 elsif Op
= N_Op_Ne
then
1731 -- Deal with greater than case
1733 elsif Op
= N_Op_Gt
then
1736 elsif Opv
= Val
- 1 then
1742 -- Deal with less than case
1744 else pragma Assert
(Op
= N_Op_Lt
);
1747 elsif Opv
= Val
+ 1 then
1754 -- Deal with inverting result
1758 when GT
=> return LT
;
1759 when GE
=> return LE
;
1760 when LT
=> return GT
;
1761 when LE
=> return GE
;
1762 when others => return Result
;
1769 end Compile_Time_Compare
;
1771 -------------------------------
1772 -- Compile_Time_Known_Bounds --
1773 -------------------------------
1775 function Compile_Time_Known_Bounds
(T
: Entity_Id
) return Boolean is
1780 if T
= Any_Composite
or else not Is_Array_Type
(T
) then
1784 Indx
:= First_Index
(T
);
1785 while Present
(Indx
) loop
1786 Typ
:= Underlying_Type
(Etype
(Indx
));
1788 -- Never look at junk bounds of a generic type
1790 if Is_Generic_Type
(Typ
) then
1794 -- Otherwise check bounds for compile-time-known
1796 if not Compile_Time_Known_Value
(Type_Low_Bound
(Typ
)) then
1798 elsif not Compile_Time_Known_Value
(Type_High_Bound
(Typ
)) then
1806 end Compile_Time_Known_Bounds
;
1808 ------------------------------
1809 -- Compile_Time_Known_Value --
1810 ------------------------------
1812 function Compile_Time_Known_Value
(Op
: Node_Id
) return Boolean is
1813 K
: constant Node_Kind
:= Nkind
(Op
);
1814 CV_Ent
: CV_Entry
renames CV_Cache
(Nat
(Op
) mod CV_Cache_Size
);
1817 -- Never known at compile time if bad type or raises Constraint_Error
1818 -- or empty (latter case occurs only as a result of a previous error).
1821 Check_Error_Detected
;
1825 or else Etype
(Op
) = Any_Type
1826 or else Raises_Constraint_Error
(Op
)
1831 -- If we have an entity name, then see if it is the name of a constant
1832 -- and if so, test the corresponding constant value, or the name of an
1833 -- enumeration literal, which is always a constant.
1835 if Present
(Etype
(Op
)) and then Is_Entity_Name
(Op
) then
1837 Ent
: constant Entity_Id
:= Entity
(Op
);
1841 -- Never known at compile time if it is a packed array value. We
1842 -- might want to try to evaluate these at compile time one day,
1843 -- but we do not make that attempt now.
1845 if Is_Packed_Array_Impl_Type
(Etype
(Op
)) then
1848 elsif Ekind
(Ent
) = E_Enumeration_Literal
then
1851 elsif Ekind
(Ent
) = E_Constant
then
1852 Val
:= Constant_Value
(Ent
);
1854 if Present
(Val
) then
1856 -- Guard against an illegal deferred constant whose full
1857 -- view is initialized with a reference to itself. Treat
1858 -- this case as a value not known at compile time.
1860 if Is_Entity_Name
(Val
) and then Entity
(Val
) = Ent
then
1863 return Compile_Time_Known_Value
(Val
);
1866 -- Otherwise, the constant does not have a compile-time-known
1875 -- We have a value, see if it is compile-time-known
1878 -- Integer literals are worth storing in the cache
1880 if K
= N_Integer_Literal
then
1882 CV_Ent
.V
:= Intval
(Op
);
1885 -- Other literals and NULL are known at compile time
1888 N_Character_Literal | N_Real_Literal | N_String_Literal | N_Null
1892 -- Evaluate static discriminants, to eliminate dead paths and
1893 -- redundant discriminant checks.
1895 elsif Is_Static_Discriminant_Component
(Op
) then
1900 -- If we fall through, not known at compile time
1904 -- If we get an exception while trying to do this test, then some error
1905 -- has occurred, and we simply say that the value is not known after all
1909 -- With debug flag K we will get an exception unless an error has
1910 -- already occurred (useful for debugging).
1912 if Debug_Flag_K
then
1913 Check_Error_Detected
;
1917 end Compile_Time_Known_Value
;
1919 --------------------------------------
1920 -- Compile_Time_Known_Value_Or_Aggr --
1921 --------------------------------------
1923 function Compile_Time_Known_Value_Or_Aggr
(Op
: Node_Id
) return Boolean is
1925 -- If we have an entity name, then see if it is the name of a constant
1926 -- and if so, test the corresponding constant value, or the name of
1927 -- an enumeration literal, which is always a constant.
1929 if Is_Entity_Name
(Op
) then
1931 E
: constant Entity_Id
:= Entity
(Op
);
1935 if Ekind
(E
) = E_Enumeration_Literal
then
1938 elsif Ekind
(E
) /= E_Constant
then
1942 V
:= Constant_Value
(E
);
1944 and then Compile_Time_Known_Value_Or_Aggr
(V
);
1948 -- We have a value, see if it is compile-time-known
1951 if Compile_Time_Known_Value
(Op
) then
1954 elsif Nkind
(Op
) = N_Aggregate
then
1956 if Present
(Expressions
(Op
)) then
1960 Expr
:= First
(Expressions
(Op
));
1961 while Present
(Expr
) loop
1962 if not Compile_Time_Known_Value_Or_Aggr
(Expr
) then
1971 if Present
(Component_Associations
(Op
)) then
1976 Cass
:= First
(Component_Associations
(Op
));
1977 while Present
(Cass
) loop
1979 Compile_Time_Known_Value_Or_Aggr
(Expression
(Cass
))
1991 elsif Nkind
(Op
) = N_Qualified_Expression
then
1992 return Compile_Time_Known_Value_Or_Aggr
(Expression
(Op
));
1994 -- All other types of values are not known at compile time
2001 end Compile_Time_Known_Value_Or_Aggr
;
2003 ---------------------------------------
2004 -- CRT_Safe_Compile_Time_Known_Value --
2005 ---------------------------------------
2007 function CRT_Safe_Compile_Time_Known_Value
(Op
: Node_Id
) return Boolean is
2009 if (Configurable_Run_Time_Mode
or No_Run_Time_Mode
)
2010 and then not Is_OK_Static_Expression
(Op
)
2014 return Compile_Time_Known_Value
(Op
);
2016 end CRT_Safe_Compile_Time_Known_Value
;
2022 -- This is only called for actuals of functions that are not predefined
2023 -- operators (which have already been rewritten as operators at this
2024 -- stage), so the call can never be folded, and all that needs doing for
2025 -- the actual is to do the check for a non-static context.
2027 procedure Eval_Actual
(N
: Node_Id
) is
2029 Check_Non_Static_Context
(N
);
2032 --------------------
2033 -- Eval_Allocator --
2034 --------------------
2036 -- Allocators are never static, so all we have to do is to do the
2037 -- check for a non-static context if an expression is present.
2039 procedure Eval_Allocator
(N
: Node_Id
) is
2040 Expr
: constant Node_Id
:= Expression
(N
);
2042 if Nkind
(Expr
) = N_Qualified_Expression
then
2043 Check_Non_Static_Context
(Expression
(Expr
));
2047 ------------------------
2048 -- Eval_Arithmetic_Op --
2049 ------------------------
2051 -- Arithmetic operations are static functions, so the result is static
2052 -- if both operands are static (RM 4.9(7), 4.9(20)).
2054 procedure Eval_Arithmetic_Op
(N
: Node_Id
) is
2055 Left
: constant Node_Id
:= Left_Opnd
(N
);
2056 Right
: constant Node_Id
:= Right_Opnd
(N
);
2057 Ltype
: constant Entity_Id
:= Etype
(Left
);
2058 Rtype
: constant Entity_Id
:= Etype
(Right
);
2059 Otype
: Entity_Id
:= Empty
;
2064 -- If not foldable we are done
2066 Test_Expression_Is_Foldable
(N
, Left
, Right
, Stat
, Fold
);
2072 -- Otherwise attempt to fold
2074 if Is_Universal_Numeric_Type
(Etype
(Left
))
2076 Is_Universal_Numeric_Type
(Etype
(Right
))
2078 Otype
:= Find_Universal_Operator_Type
(N
);
2081 -- Fold for cases where both operands are of integer type
2083 if Is_Integer_Type
(Ltype
) and then Is_Integer_Type
(Rtype
) then
2085 Left_Int
: constant Uint
:= Expr_Value
(Left
);
2086 Right_Int
: constant Uint
:= Expr_Value
(Right
);
2092 Result
:= Left_Int
+ Right_Int
;
2094 when N_Op_Subtract
=>
2095 Result
:= Left_Int
- Right_Int
;
2097 when N_Op_Multiply
=>
2100 (Num_Bits
(Left_Int
) + Num_Bits
(Right_Int
)))
2102 Result
:= Left_Int
* Right_Int
;
2109 -- The exception Constraint_Error is raised by integer
2110 -- division, rem and mod if the right operand is zero.
2112 if Right_Int
= 0 then
2114 -- When SPARK_Mode is On, force a warning instead of
2115 -- an error in that case, as this likely corresponds
2116 -- to deactivated code.
2118 Apply_Compile_Time_Constraint_Error
2119 (N
, "division by zero", CE_Divide_By_Zero
,
2120 Warn
=> not Stat
or SPARK_Mode
= On
);
2123 -- Otherwise we can do the division
2126 Result
:= Left_Int
/ Right_Int
;
2131 -- The exception Constraint_Error is raised by integer
2132 -- division, rem and mod if the right operand is zero.
2134 if Right_Int
= 0 then
2136 -- When SPARK_Mode is On, force a warning instead of
2137 -- an error in that case, as this likely corresponds
2138 -- to deactivated code.
2140 Apply_Compile_Time_Constraint_Error
2141 (N
, "mod with zero divisor", CE_Divide_By_Zero
,
2142 Warn
=> not Stat
or SPARK_Mode
= On
);
2146 Result
:= Left_Int
mod Right_Int
;
2151 -- The exception Constraint_Error is raised by integer
2152 -- division, rem and mod if the right operand is zero.
2154 if Right_Int
= 0 then
2156 -- When SPARK_Mode is On, force a warning instead of
2157 -- an error in that case, as this likely corresponds
2158 -- to deactivated code.
2160 Apply_Compile_Time_Constraint_Error
2161 (N
, "rem with zero divisor", CE_Divide_By_Zero
,
2162 Warn
=> not Stat
or SPARK_Mode
= On
);
2166 Result
:= Left_Int
rem Right_Int
;
2170 raise Program_Error
;
2173 -- Adjust the result by the modulus if the type is a modular type
2175 if Is_Modular_Integer_Type
(Ltype
) then
2176 Result
:= Result
mod Modulus
(Ltype
);
2179 Check_Non_Static_Context_For_Overflow
(N
, Stat
, Result
);
2181 -- If we get here we can fold the result
2183 Fold_Uint
(N
, Result
, Stat
);
2186 -- Cases where at least one operand is a real. We handle the cases of
2187 -- both reals, or mixed/real integer cases (the latter happen only for
2188 -- divide and multiply, and the result is always real).
2190 elsif Is_Real_Type
(Ltype
) or else Is_Real_Type
(Rtype
) then
2197 if Is_Real_Type
(Ltype
) then
2198 Left_Real
:= Expr_Value_R
(Left
);
2200 Left_Real
:= UR_From_Uint
(Expr_Value
(Left
));
2203 if Is_Real_Type
(Rtype
) then
2204 Right_Real
:= Expr_Value_R
(Right
);
2206 Right_Real
:= UR_From_Uint
(Expr_Value
(Right
));
2209 if Nkind
(N
) = N_Op_Add
then
2210 Result
:= Left_Real
+ Right_Real
;
2212 elsif Nkind
(N
) = N_Op_Subtract
then
2213 Result
:= Left_Real
- Right_Real
;
2215 elsif Nkind
(N
) = N_Op_Multiply
then
2216 Result
:= Left_Real
* Right_Real
;
2218 else pragma Assert
(Nkind
(N
) = N_Op_Divide
);
2219 if UR_Is_Zero
(Right_Real
) then
2220 Apply_Compile_Time_Constraint_Error
2221 (N
, "division by zero", CE_Divide_By_Zero
);
2225 Result
:= Left_Real
/ Right_Real
;
2228 Fold_Ureal
(N
, Result
, Stat
);
2232 -- If the operator was resolved to a specific type, make sure that type
2233 -- is frozen even if the expression is folded into a literal (which has
2234 -- a universal type).
2236 if Present
(Otype
) then
2237 Freeze_Before
(N
, Otype
);
2239 end Eval_Arithmetic_Op
;
2241 ----------------------------
2242 -- Eval_Character_Literal --
2243 ----------------------------
2245 -- Nothing to be done
2247 procedure Eval_Character_Literal
(N
: Node_Id
) is
2248 pragma Warnings
(Off
, N
);
2251 end Eval_Character_Literal
;
2257 -- Static function calls are either calls to predefined operators
2258 -- with static arguments, or calls to functions that rename a literal.
2259 -- Only the latter case is handled here, predefined operators are
2260 -- constant-folded elsewhere.
2262 -- If the function is itself inherited the literal of the parent type must
2263 -- be explicitly converted to the return type of the function.
2265 procedure Eval_Call
(N
: Node_Id
) is
2266 Loc
: constant Source_Ptr
:= Sloc
(N
);
2267 Typ
: constant Entity_Id
:= Etype
(N
);
2271 if Nkind
(N
) = N_Function_Call
2272 and then No
(Parameter_Associations
(N
))
2273 and then Is_Entity_Name
(Name
(N
))
2274 and then Present
(Alias
(Entity
(Name
(N
))))
2275 and then Is_Enumeration_Type
(Base_Type
(Typ
))
2277 Lit
:= Ultimate_Alias
(Entity
(Name
(N
)));
2279 if Ekind
(Lit
) = E_Enumeration_Literal
then
2280 if Base_Type
(Etype
(Lit
)) /= Base_Type
(Typ
) then
2282 (N
, Convert_To
(Typ
, New_Occurrence_Of
(Lit
, Loc
)));
2284 Rewrite
(N
, New_Occurrence_Of
(Lit
, Loc
));
2290 elsif Nkind
(N
) = N_Function_Call
2291 and then Is_Entity_Name
(Name
(N
))
2292 and then Is_Intrinsic_Subprogram
(Entity
(Name
(N
)))
2294 Eval_Intrinsic_Call
(N
, Entity
(Name
(N
)));
2296 -- Ada 2022 (AI12-0075): If checking for potentially static expressions
2297 -- is enabled and we have a call to a static function, substitute a
2298 -- static value for the call, to allow folding the expression. This
2299 -- supports checking the requirement of RM 6.8(5.3/5) in
2300 -- Analyze_Expression_Function.
2302 elsif Checking_Potentially_Static_Expression
2303 and then Is_Static_Function_Call
(N
)
2305 Fold_Dummy
(N
, Typ
);
2309 --------------------------
2310 -- Eval_Case_Expression --
2311 --------------------------
2313 -- A conditional expression is static if all its conditions and dependent
2314 -- expressions are static. Note that we do not care if the dependent
2315 -- expressions raise CE, except for the one that will be selected.
2317 procedure Eval_Case_Expression
(N
: Node_Id
) is
2322 Set_Is_Static_Expression
(N
, False);
2324 if Error_Posted
(Expression
(N
))
2325 or else not Is_Static_Expression
(Expression
(N
))
2327 Check_Non_Static_Context
(Expression
(N
));
2331 -- First loop, make sure all the alternatives are static expressions
2332 -- none of which raise Constraint_Error. We make the Constraint_Error
2333 -- check because part of the legality condition for a correct static
2334 -- case expression is that the cases are covered, like any other case
2335 -- expression. And we can't do that if any of the conditions raise an
2336 -- exception, so we don't even try to evaluate if that is the case.
2338 Alt
:= First
(Alternatives
(N
));
2339 while Present
(Alt
) loop
2341 -- The expression must be static, but we don't care at this stage
2342 -- if it raises Constraint_Error (the alternative might not match,
2343 -- in which case the expression is statically unevaluated anyway).
2345 if not Is_Static_Expression
(Expression
(Alt
)) then
2346 Check_Non_Static_Context
(Expression
(Alt
));
2350 -- The choices of a case always have to be static, and cannot raise
2351 -- an exception. If this condition is not met, then the expression
2352 -- is plain illegal, so just abandon evaluation attempts. No need
2353 -- to check non-static context when we have something illegal anyway.
2355 if not Is_OK_Static_Choice_List
(Discrete_Choices
(Alt
)) then
2362 -- OK, if the above loop gets through it means that all choices are OK
2363 -- static (don't raise exceptions), so the whole case is static, and we
2364 -- can find the matching alternative.
2366 Set_Is_Static_Expression
(N
);
2368 -- Now to deal with propagating a possible Constraint_Error
2370 -- If the selecting expression raises CE, propagate and we are done
2372 if Raises_Constraint_Error
(Expression
(N
)) then
2373 Set_Raises_Constraint_Error
(N
);
2375 -- Otherwise we need to check the alternatives to find the matching
2376 -- one. CE's in other than the matching one are not relevant. But we
2377 -- do need to check the matching one. Unlike the first loop, we do not
2378 -- have to go all the way through, when we find the matching one, quit.
2381 Alt
:= First
(Alternatives
(N
));
2384 -- We must find a match among the alternatives. If not, this must
2385 -- be due to other errors, so just ignore, leaving as non-static.
2388 Set_Is_Static_Expression
(N
, False);
2392 -- Otherwise loop through choices of this alternative
2394 Choice
:= First
(Discrete_Choices
(Alt
));
2395 while Present
(Choice
) loop
2397 -- If we find a matching choice, then the Expression of this
2398 -- alternative replaces N (Raises_Constraint_Error flag is
2399 -- included, so we don't have to special case that).
2401 if Choice_Matches
(Expression
(N
), Choice
) = Match
then
2402 Rewrite
(N
, Relocate_Node
(Expression
(Alt
)));
2412 end Eval_Case_Expression
;
2414 ------------------------
2415 -- Eval_Concatenation --
2416 ------------------------
2418 -- Concatenation is a static function, so the result is static if both
2419 -- operands are static (RM 4.9(7), 4.9(21)).
2421 procedure Eval_Concatenation
(N
: Node_Id
) is
2422 Left
: constant Node_Id
:= Left_Opnd
(N
);
2423 Right
: constant Node_Id
:= Right_Opnd
(N
);
2424 C_Typ
: constant Entity_Id
:= Root_Type
(Component_Type
(Etype
(N
)));
2429 -- Concatenation is never static in Ada 83, so if Ada 83 check operand
2430 -- non-static context.
2432 if Ada_Version
= Ada_83
2433 and then Comes_From_Source
(N
)
2435 Check_Non_Static_Context
(Left
);
2436 Check_Non_Static_Context
(Right
);
2440 -- If not foldable we are done. In principle concatenation that yields
2441 -- any string type is static (i.e. an array type of character types).
2442 -- However, character types can include enumeration literals, and
2443 -- concatenation in that case cannot be described by a literal, so we
2444 -- only consider the operation static if the result is an array of
2445 -- (a descendant of) a predefined character type.
2447 Test_Expression_Is_Foldable
(N
, Left
, Right
, Stat
, Fold
);
2449 if not (Is_Standard_Character_Type
(C_Typ
) and then Fold
) then
2450 Set_Is_Static_Expression
(N
, False);
2454 -- Compile time string concatenation
2456 -- ??? Note that operands that are aggregates can be marked as static,
2457 -- so we should attempt at a later stage to fold concatenations with
2461 Left_Str
: constant Node_Id
:= Get_String_Val
(Left
);
2463 Right_Str
: constant Node_Id
:= Get_String_Val
(Right
);
2464 Folded_Val
: String_Id
:= No_String
;
2467 -- Establish new string literal, and store left operand. We make
2468 -- sure to use the special Start_String that takes an operand if
2469 -- the left operand is a string literal. Since this is optimized
2470 -- in the case where that is the most recently created string
2471 -- literal, we ensure efficient time/space behavior for the
2472 -- case of a concatenation of a series of string literals.
2474 if Nkind
(Left_Str
) = N_String_Literal
then
2475 Left_Len
:= String_Length
(Strval
(Left_Str
));
2477 -- If the left operand is the empty string, and the right operand
2478 -- is a string literal (the case of "" & "..."), the result is the
2479 -- value of the right operand. This optimization is important when
2480 -- Is_Folded_In_Parser, to avoid copying an enormous right
2483 if Left_Len
= 0 and then Nkind
(Right_Str
) = N_String_Literal
then
2484 Folded_Val
:= Strval
(Right_Str
);
2486 Start_String
(Strval
(Left_Str
));
2491 Store_String_Char
(UI_To_CC
(Char_Literal_Value
(Left_Str
)));
2495 -- Now append the characters of the right operand, unless we
2496 -- optimized the "" & "..." case above.
2498 if Nkind
(Right_Str
) = N_String_Literal
then
2499 if Left_Len
/= 0 then
2500 Store_String_Chars
(Strval
(Right_Str
));
2501 Folded_Val
:= End_String
;
2504 Store_String_Char
(UI_To_CC
(Char_Literal_Value
(Right_Str
)));
2505 Folded_Val
:= End_String
;
2508 Set_Is_Static_Expression
(N
, Stat
);
2510 -- If left operand is the empty string, the result is the
2511 -- right operand, including its bounds if anomalous.
2514 and then Is_Array_Type
(Etype
(Right
))
2515 and then Etype
(Right
) /= Any_String
2517 Set_Etype
(N
, Etype
(Right
));
2520 Fold_Str
(N
, Folded_Val
, Static
=> Stat
);
2522 end Eval_Concatenation
;
2524 ----------------------
2525 -- Eval_Entity_Name --
2526 ----------------------
2528 -- This procedure is used for identifiers and expanded names other than
2529 -- named numbers (see Eval_Named_Integer, Eval_Named_Real. These are
2530 -- static if they denote a static constant (RM 4.9(6)) or if the name
2531 -- denotes an enumeration literal (RM 4.9(22)).
2533 procedure Eval_Entity_Name
(N
: Node_Id
) is
2534 Def_Id
: constant Entity_Id
:= Entity
(N
);
2538 -- Enumeration literals are always considered to be constants
2539 -- and cannot raise Constraint_Error (RM 4.9(22)).
2541 if Ekind
(Def_Id
) = E_Enumeration_Literal
then
2542 Set_Is_Static_Expression
(N
);
2545 -- A name is static if it denotes a static constant (RM 4.9(5)), and
2546 -- we also copy Raise_Constraint_Error. Notice that even if non-static,
2547 -- it does not violate 10.2.1(8) here, since this is not a variable.
2549 elsif Ekind
(Def_Id
) = E_Constant
then
2551 -- Deferred constants must always be treated as nonstatic outside the
2552 -- scope of their full view.
2554 if Present
(Full_View
(Def_Id
))
2555 and then not In_Open_Scopes
(Scope
(Def_Id
))
2559 Val
:= Constant_Value
(Def_Id
);
2562 if Present
(Val
) then
2563 Set_Is_Static_Expression
2564 (N
, Is_Static_Expression
(Val
)
2565 and then Is_Static_Subtype
(Etype
(Def_Id
)));
2566 Set_Raises_Constraint_Error
(N
, Raises_Constraint_Error
(Val
));
2568 if not Is_Static_Expression
(N
)
2569 and then not Is_Generic_Type
(Etype
(N
))
2571 Validate_Static_Object_Name
(N
);
2574 -- Mark constant condition in SCOs
2577 and then Comes_From_Source
(N
)
2578 and then Is_Boolean_Type
(Etype
(Def_Id
))
2579 and then Compile_Time_Known_Value
(N
)
2581 Set_SCO_Condition
(N
, Expr_Value_E
(N
) = Standard_True
);
2587 -- Ada 2022 (AI12-0075): If checking for potentially static expressions
2588 -- is enabled and we have a reference to a formal parameter of mode in,
2589 -- substitute a static value for the reference, to allow folding the
2590 -- expression. This supports checking the requirement of RM 6.8(5.3/5)
2591 -- in Analyze_Expression_Function.
2593 elsif Ekind
(Def_Id
) = E_In_Parameter
2594 and then Checking_Potentially_Static_Expression
2595 and then Is_Static_Function
(Scope
(Def_Id
))
2597 Fold_Dummy
(N
, Etype
(Def_Id
));
2600 -- Fall through if the name is not static
2602 Validate_Static_Object_Name
(N
);
2603 end Eval_Entity_Name
;
2605 ------------------------
2606 -- Eval_If_Expression --
2607 ------------------------
2609 -- We can fold to a static expression if the condition and both dependent
2610 -- expressions are static. Otherwise, the only required processing is to do
2611 -- the check for non-static context for the then and else expressions.
2613 procedure Eval_If_Expression
(N
: Node_Id
) is
2614 Condition
: constant Node_Id
:= First
(Expressions
(N
));
2615 Then_Expr
: constant Node_Id
:= Next
(Condition
);
2616 Else_Expr
: constant Node_Id
:= Next
(Then_Expr
);
2618 Non_Result
: Node_Id
;
2620 Rstat
: constant Boolean :=
2621 Is_Static_Expression
(Condition
)
2623 Is_Static_Expression
(Then_Expr
)
2625 Is_Static_Expression
(Else_Expr
);
2626 -- True if result is static
2629 -- If result not static, nothing to do, otherwise set static result
2634 Set_Is_Static_Expression
(N
);
2637 -- If any operand is Any_Type, just propagate to result and do not try
2638 -- to fold, this prevents cascaded errors.
2640 if Etype
(Condition
) = Any_Type
or else
2641 Etype
(Then_Expr
) = Any_Type
or else
2642 Etype
(Else_Expr
) = Any_Type
2644 Set_Etype
(N
, Any_Type
);
2645 Set_Is_Static_Expression
(N
, False);
2649 -- If condition raises Constraint_Error then we have already signaled
2650 -- an error, and we just propagate to the result and do not fold.
2652 if Raises_Constraint_Error
(Condition
) then
2653 Set_Raises_Constraint_Error
(N
);
2657 -- Static case where we can fold. Note that we don't try to fold cases
2658 -- where the condition is known at compile time, but the result is
2659 -- non-static. This avoids possible cases of infinite recursion where
2660 -- the expander puts in a redundant test and we remove it. Instead we
2661 -- deal with these cases in the expander.
2663 -- Select result operand
2665 if Is_True
(Expr_Value
(Condition
)) then
2666 Result
:= Then_Expr
;
2667 Non_Result
:= Else_Expr
;
2669 Result
:= Else_Expr
;
2670 Non_Result
:= Then_Expr
;
2673 -- Note that it does not matter if the non-result operand raises a
2674 -- Constraint_Error, but if the result raises Constraint_Error then we
2675 -- replace the node with a raise Constraint_Error. This will properly
2676 -- propagate Raises_Constraint_Error since this flag is set in Result.
2678 if Raises_Constraint_Error
(Result
) then
2679 Rewrite_In_Raise_CE
(N
, Result
);
2680 Check_Non_Static_Context
(Non_Result
);
2682 -- Otherwise the result operand replaces the original node
2685 Rewrite
(N
, Relocate_Node
(Result
));
2686 Set_Is_Static_Expression
(N
);
2688 end Eval_If_Expression
;
2690 ----------------------------
2691 -- Eval_Indexed_Component --
2692 ----------------------------
2694 -- Indexed components are never static, so we need to perform the check
2695 -- for non-static context on the index values. Then, we check if the
2696 -- value can be obtained at compile time, even though it is non-static.
2698 procedure Eval_Indexed_Component
(N
: Node_Id
) is
2702 -- Check for non-static context on index values
2704 Expr
:= First
(Expressions
(N
));
2705 while Present
(Expr
) loop
2706 Check_Non_Static_Context
(Expr
);
2710 -- If the indexed component appears in an object renaming declaration
2711 -- then we do not want to try to evaluate it, since in this case we
2712 -- need the identity of the array element.
2714 if Nkind
(Parent
(N
)) = N_Object_Renaming_Declaration
then
2717 -- Similarly if the indexed component appears as the prefix of an
2718 -- attribute we don't want to evaluate it, because at least for
2719 -- some cases of attributes we need the identify (e.g. Access, Size).
2721 elsif Nkind
(Parent
(N
)) = N_Attribute_Reference
then
2725 -- Note: there are other cases, such as the left side of an assignment,
2726 -- or an OUT parameter for a call, where the replacement results in the
2727 -- illegal use of a constant, But these cases are illegal in the first
2728 -- place, so the replacement, though silly, is harmless.
2730 -- Now see if this is a constant array reference
2732 if List_Length
(Expressions
(N
)) = 1
2733 and then Is_Entity_Name
(Prefix
(N
))
2734 and then Ekind
(Entity
(Prefix
(N
))) = E_Constant
2735 and then Present
(Constant_Value
(Entity
(Prefix
(N
))))
2738 Loc
: constant Source_Ptr
:= Sloc
(N
);
2739 Arr
: constant Node_Id
:= Constant_Value
(Entity
(Prefix
(N
)));
2740 Sub
: constant Node_Id
:= First
(Expressions
(N
));
2746 -- Linear one's origin subscript value for array reference
2749 -- Lower bound of the first array index
2752 -- Value from constant array
2755 Atyp
:= Etype
(Arr
);
2757 if Is_Access_Type
(Atyp
) then
2758 Atyp
:= Designated_Type
(Atyp
);
2761 -- If we have an array type (we should have but perhaps there are
2762 -- error cases where this is not the case), then see if we can do
2763 -- a constant evaluation of the array reference.
2765 if Is_Array_Type
(Atyp
) and then Atyp
/= Any_Composite
then
2766 if Ekind
(Atyp
) = E_String_Literal_Subtype
then
2767 Lbd
:= String_Literal_Low_Bound
(Atyp
);
2769 Lbd
:= Type_Low_Bound
(Etype
(First_Index
(Atyp
)));
2772 if Compile_Time_Known_Value
(Sub
)
2773 and then Nkind
(Arr
) = N_Aggregate
2774 and then Compile_Time_Known_Value
(Lbd
)
2775 and then Is_Discrete_Type
(Component_Type
(Atyp
))
2777 Lin
:= UI_To_Int
(Expr_Value
(Sub
) - Expr_Value
(Lbd
)) + 1;
2779 if List_Length
(Expressions
(Arr
)) >= Lin
then
2780 Elm
:= Pick
(Expressions
(Arr
), Lin
);
2782 -- If the resulting expression is compile-time-known,
2783 -- then we can rewrite the indexed component with this
2784 -- value, being sure to mark the result as non-static.
2785 -- We also reset the Sloc, in case this generates an
2786 -- error later on (e.g. 136'Access).
2788 if Compile_Time_Known_Value
(Elm
) then
2789 Rewrite
(N
, Duplicate_Subexpr_No_Checks
(Elm
));
2790 Set_Is_Static_Expression
(N
, False);
2795 -- We can also constant-fold if the prefix is a string literal.
2796 -- This will be useful in an instantiation or an inlining.
2798 elsif Compile_Time_Known_Value
(Sub
)
2799 and then Nkind
(Arr
) = N_String_Literal
2800 and then Compile_Time_Known_Value
(Lbd
)
2801 and then Expr_Value
(Lbd
) = 1
2802 and then Expr_Value
(Sub
) <=
2803 String_Literal_Length
(Etype
(Arr
))
2806 C
: constant Char_Code
:=
2807 Get_String_Char
(Strval
(Arr
),
2808 UI_To_Int
(Expr_Value
(Sub
)));
2810 Set_Character_Literal_Name
(C
);
2813 Make_Character_Literal
(Loc
,
2815 Char_Literal_Value
=> UI_From_CC
(C
));
2816 Set_Etype
(Elm
, Component_Type
(Atyp
));
2817 Rewrite
(N
, Duplicate_Subexpr_No_Checks
(Elm
));
2818 Set_Is_Static_Expression
(N
, False);
2824 end Eval_Indexed_Component
;
2826 --------------------------
2827 -- Eval_Integer_Literal --
2828 --------------------------
2830 -- Numeric literals are static (RM 4.9(1)), and have already been marked
2831 -- as static by the analyzer. The reason we did it that early is to allow
2832 -- the possibility of turning off the Is_Static_Expression flag after
2833 -- analysis, but before resolution, when integer literals are generated in
2834 -- the expander that do not correspond to static expressions.
2836 procedure Eval_Integer_Literal
(N
: Node_Id
) is
2837 function In_Any_Integer_Context
(K
: Node_Kind
) return Boolean;
2838 -- If the literal is resolved with a specific type in a context where
2839 -- the expected type is Any_Integer, there are no range checks on the
2840 -- literal. By the time the literal is evaluated, it carries the type
2841 -- imposed by the enclosing expression, and we must recover the context
2842 -- to determine that Any_Integer is meant.
2844 ----------------------------
2845 -- In_Any_Integer_Context --
2846 ----------------------------
2848 function In_Any_Integer_Context
(K
: Node_Kind
) return Boolean is
2850 -- Any_Integer also appears in digits specifications for real types,
2851 -- but those have bounds smaller that those of any integer base type,
2852 -- so we can safely ignore these cases.
2854 return K
in N_Attribute_Definition_Clause
2855 | N_Modular_Type_Definition
2856 | N_Number_Declaration
2857 | N_Signed_Integer_Type_Definition
;
2858 end In_Any_Integer_Context
;
2862 PK
: constant Node_Kind
:= Nkind
(Parent
(N
));
2863 Typ
: constant Entity_Id
:= Etype
(N
);
2865 -- Start of processing for Eval_Integer_Literal
2868 -- If the literal appears in a non-expression context, then it is
2869 -- certainly appearing in a non-static context, so check it. This is
2870 -- actually a redundant check, since Check_Non_Static_Context would
2871 -- check it, but it seems worthwhile to optimize out the call.
2873 -- Additionally, when the literal appears within an if or case
2874 -- expression it must be checked as well. However, due to the literal
2875 -- appearing within a conditional statement, expansion greatly changes
2876 -- the nature of its context and performing some of the checks within
2877 -- Check_Non_Static_Context on an expanded literal may lead to spurious
2878 -- and misleading warnings.
2880 if (PK
not in N_Subexpr
2881 or else (PK
in N_Case_Expression_Alternative | N_If_Expression
2883 Comes_From_Source
(N
)))
2884 and then not In_Any_Integer_Context
(PK
)
2886 Check_Non_Static_Context
(N
);
2889 -- Modular integer literals must be in their base range
2891 if Is_Modular_Integer_Type
(Typ
)
2892 and then Is_Out_Of_Range
(N
, Base_Type
(Typ
), Assume_Valid
=> True)
2896 end Eval_Integer_Literal
;
2898 -------------------------
2899 -- Eval_Intrinsic_Call --
2900 -------------------------
2902 procedure Eval_Intrinsic_Call
(N
: Node_Id
; E
: Entity_Id
) is
2904 procedure Eval_Shift
(N
: Node_Id
; E
: Entity_Id
; Op
: Node_Kind
);
2905 -- Evaluate an intrinsic shift call N on the given subprogram E.
2906 -- Op is the kind for the shift node.
2912 procedure Eval_Shift
(N
: Node_Id
; E
: Entity_Id
; Op
: Node_Kind
) is
2913 Left
: constant Node_Id
:= First_Actual
(N
);
2914 Right
: constant Node_Id
:= Next_Actual
(Left
);
2915 Static
: constant Boolean := Is_Static_Function
(E
);
2919 if Checking_Potentially_Static_Expression
then
2920 Fold_Dummy
(N
, Etype
(N
));
2926 (N
, Left
, Right
, Op
, Static
=> Static
, Check_Elab
=> not Static
);
2932 -- Nothing to do if the intrinsic is handled by the back end.
2934 if Present
(Interface_Name
(E
)) then
2938 -- Intrinsic calls as part of a static function is a language extension.
2940 if Checking_Potentially_Static_Expression
2941 and then not Extensions_Allowed
2946 -- If we have a renaming, expand the call to the original operation,
2947 -- which must itself be intrinsic, since renaming requires matching
2948 -- conventions and this has already been checked.
2950 if Present
(Alias
(E
)) then
2951 Eval_Intrinsic_Call
(N
, Alias
(E
));
2955 -- If the intrinsic subprogram is generic, gets its original name
2957 if Present
(Parent
(E
))
2958 and then Present
(Generic_Parent
(Parent
(E
)))
2960 Nam
:= Chars
(Generic_Parent
(Parent
(E
)));
2966 when Name_Shift_Left
=>
2967 Eval_Shift
(N
, E
, N_Op_Shift_Left
);
2968 when Name_Shift_Right
=>
2969 Eval_Shift
(N
, E
, N_Op_Shift_Right
);
2970 when Name_Shift_Right_Arithmetic
=>
2971 Eval_Shift
(N
, E
, N_Op_Shift_Right_Arithmetic
);
2975 end Eval_Intrinsic_Call
;
2977 ---------------------
2978 -- Eval_Logical_Op --
2979 ---------------------
2981 -- Logical operations are static functions, so the result is potentially
2982 -- static if both operands are potentially static (RM 4.9(7), 4.9(20)).
2984 procedure Eval_Logical_Op
(N
: Node_Id
) is
2985 Left
: constant Node_Id
:= Left_Opnd
(N
);
2986 Right
: constant Node_Id
:= Right_Opnd
(N
);
2987 Left_Int
: Uint
:= No_Uint
;
2988 Right_Int
: Uint
:= No_Uint
;
2993 -- If not foldable we are done
2995 Test_Expression_Is_Foldable
(N
, Left
, Right
, Stat
, Fold
);
3001 -- Compile time evaluation of logical operation
3003 if Is_Modular_Integer_Type
(Etype
(N
)) then
3004 Left_Int
:= Expr_Value
(Left
);
3005 Right_Int
:= Expr_Value
(Right
);
3008 Left_Bits
: Bits
(0 .. UI_To_Int
(Esize
(Etype
(N
))) - 1);
3009 Right_Bits
: Bits
(0 .. UI_To_Int
(Esize
(Etype
(N
))) - 1);
3012 To_Bits
(Left_Int
, Left_Bits
);
3013 To_Bits
(Right_Int
, Right_Bits
);
3015 -- Note: should really be able to use array ops instead of
3016 -- these loops, but they break the build with a cryptic error
3017 -- during the bind of gnat1 likely due to a wrong computation
3018 -- of a date or checksum.
3020 if Nkind
(N
) = N_Op_And
then
3021 for J
in Left_Bits
'Range loop
3022 Left_Bits
(J
) := Left_Bits
(J
) and Right_Bits
(J
);
3025 elsif Nkind
(N
) = N_Op_Or
then
3026 for J
in Left_Bits
'Range loop
3027 Left_Bits
(J
) := Left_Bits
(J
) or Right_Bits
(J
);
3031 pragma Assert
(Nkind
(N
) = N_Op_Xor
);
3033 for J
in Left_Bits
'Range loop
3034 Left_Bits
(J
) := Left_Bits
(J
) xor Right_Bits
(J
);
3038 Fold_Uint
(N
, From_Bits
(Left_Bits
, Etype
(N
)), Stat
);
3042 pragma Assert
(Is_Boolean_Type
(Etype
(N
)));
3044 if Compile_Time_Known_Value
(Left
)
3045 and then Compile_Time_Known_Value
(Right
)
3047 Right_Int
:= Expr_Value
(Right
);
3048 Left_Int
:= Expr_Value
(Left
);
3051 if Nkind
(N
) = N_Op_And
then
3053 -- If Left or Right are not compile time known values it means
3054 -- that the result is always False as per
3055 -- Test_Expression_Is_Foldable.
3056 -- Note that in this case, both Right_Int and Left_Int are set
3057 -- to No_Uint, so need to test for both.
3059 if No
(Right_Int
) then
3060 Fold_Uint
(N
, Uint_0
, Stat
);
3063 Test
(Is_True
(Left_Int
) and then Is_True
(Right_Int
)), Stat
);
3065 elsif Nkind
(N
) = N_Op_Or
then
3067 -- If Left or Right are not compile time known values it means
3068 -- that the result is always True. as per
3069 -- Test_Expression_Is_Foldable.
3070 -- Note that in this case, both Right_Int and Left_Int are set
3071 -- to No_Uint, so need to test for both.
3073 if No
(Right_Int
) then
3074 Fold_Uint
(N
, Uint_1
, Stat
);
3077 Test
(Is_True
(Left_Int
) or else Is_True
(Right_Int
)), Stat
);
3080 pragma Assert
(Nkind
(N
) = N_Op_Xor
);
3082 Test
(Is_True
(Left_Int
) xor Is_True
(Right_Int
)), Stat
);
3085 end Eval_Logical_Op
;
3087 ------------------------
3088 -- Eval_Membership_Op --
3089 ------------------------
3091 -- A membership test is potentially static if the expression is static, and
3092 -- the range is a potentially static range, or is a subtype mark denoting a
3093 -- static subtype (RM 4.9(12)).
3095 procedure Eval_Membership_Op
(N
: Node_Id
) is
3096 Alts
: constant List_Id
:= Alternatives
(N
);
3097 Choice
: constant Node_Id
:= Right_Opnd
(N
);
3098 Expr
: constant Node_Id
:= Left_Opnd
(N
);
3099 Result
: Match_Result
;
3102 -- Ignore if error in either operand, except to make sure that Any_Type
3103 -- is properly propagated to avoid junk cascaded errors.
3105 if Etype
(Expr
) = Any_Type
3106 or else (Present
(Choice
) and then Etype
(Choice
) = Any_Type
)
3108 Set_Etype
(N
, Any_Type
);
3112 -- If left operand non-static, then nothing to do
3114 if not Is_Static_Expression
(Expr
) then
3118 -- If choice is non-static, left operand is in non-static context
3120 if (Present
(Choice
) and then not Is_Static_Choice
(Choice
))
3121 or else (Present
(Alts
) and then not Is_Static_Choice_List
(Alts
))
3123 Check_Non_Static_Context
(Expr
);
3127 -- Otherwise we definitely have a static expression
3129 Set_Is_Static_Expression
(N
);
3131 -- If left operand raises Constraint_Error, propagate and we are done
3133 if Raises_Constraint_Error
(Expr
) then
3134 Set_Raises_Constraint_Error
(N
, True);
3139 if Present
(Choice
) then
3140 Result
:= Choice_Matches
(Expr
, Choice
);
3142 Result
:= Choices_Match
(Expr
, Alts
);
3145 -- If result is Non_Static, it means that we raise Constraint_Error,
3146 -- since we already tested that the operands were themselves static.
3148 if Result
= Non_Static
then
3149 Set_Raises_Constraint_Error
(N
);
3151 -- Otherwise we have our result (flipped if NOT IN case)
3155 (N
, Test
((Result
= Match
) xor (Nkind
(N
) = N_Not_In
)), True);
3156 Warn_On_Known_Condition
(N
);
3159 end Eval_Membership_Op
;
3161 ------------------------
3162 -- Eval_Named_Integer --
3163 ------------------------
3165 procedure Eval_Named_Integer
(N
: Node_Id
) is
3168 Expr_Value
(Expression
(Declaration_Node
(Entity
(N
)))), True);
3169 end Eval_Named_Integer
;
3171 ---------------------
3172 -- Eval_Named_Real --
3173 ---------------------
3175 procedure Eval_Named_Real
(N
: Node_Id
) is
3178 Expr_Value_R
(Expression
(Declaration_Node
(Entity
(N
)))), True);
3179 end Eval_Named_Real
;
3185 -- Exponentiation is a static functions, so the result is potentially
3186 -- static if both operands are potentially static (RM 4.9(7), 4.9(20)).
3188 procedure Eval_Op_Expon
(N
: Node_Id
) is
3189 Left
: constant Node_Id
:= Left_Opnd
(N
);
3190 Right
: constant Node_Id
:= Right_Opnd
(N
);
3195 -- If not foldable we are done
3197 Test_Expression_Is_Foldable
3198 (N
, Left
, Right
, Stat
, Fold
, CRT_Safe
=> True);
3200 -- Return if not foldable
3206 if Configurable_Run_Time_Mode
and not Stat
then
3210 -- Fold exponentiation operation
3213 Right_Int
: constant Uint
:= Expr_Value
(Right
);
3218 if Is_Integer_Type
(Etype
(Left
)) then
3220 Left_Int
: constant Uint
:= Expr_Value
(Left
);
3224 -- Exponentiation of an integer raises Constraint_Error for a
3225 -- negative exponent (RM 4.5.6).
3227 if Right_Int
< 0 then
3228 Apply_Compile_Time_Constraint_Error
3229 (N
, "integer exponent negative", CE_Range_Check_Failed
,
3234 if OK_Bits
(N
, Num_Bits
(Left_Int
) * Right_Int
) then
3235 Result
:= Left_Int
** Right_Int
;
3240 if Is_Modular_Integer_Type
(Etype
(N
)) then
3241 Result
:= Result
mod Modulus
(Etype
(N
));
3244 Check_Non_Static_Context_For_Overflow
(N
, Stat
, Result
);
3246 Fold_Uint
(N
, Result
, Stat
);
3254 Left_Real
: constant Ureal
:= Expr_Value_R
(Left
);
3257 -- Cannot have a zero base with a negative exponent
3259 if UR_Is_Zero
(Left_Real
) then
3261 if Right_Int
< 0 then
3262 Apply_Compile_Time_Constraint_Error
3263 (N
, "zero ** negative integer", CE_Range_Check_Failed
,
3267 Fold_Ureal
(N
, Ureal_0
, Stat
);
3271 Fold_Ureal
(N
, Left_Real
** Right_Int
, Stat
);
3282 -- The not operation is a static function, so the result is potentially
3283 -- static if the operand is potentially static (RM 4.9(7), 4.9(20)).
3285 procedure Eval_Op_Not
(N
: Node_Id
) is
3286 Right
: constant Node_Id
:= Right_Opnd
(N
);
3291 -- If not foldable we are done
3293 Test_Expression_Is_Foldable
(N
, Right
, Stat
, Fold
);
3299 -- Fold not operation
3302 Rint
: constant Uint
:= Expr_Value
(Right
);
3303 Typ
: constant Entity_Id
:= Etype
(N
);
3306 -- Negation is equivalent to subtracting from the modulus minus one.
3307 -- For a binary modulus this is equivalent to the ones-complement of
3308 -- the original value. For a nonbinary modulus this is an arbitrary
3309 -- but consistent definition.
3311 if Is_Modular_Integer_Type
(Typ
) then
3312 Fold_Uint
(N
, Modulus
(Typ
) - 1 - Rint
, Stat
);
3313 else pragma Assert
(Is_Boolean_Type
(Typ
));
3314 Fold_Uint
(N
, Test
(not Is_True
(Rint
)), Stat
);
3317 Set_Is_Static_Expression
(N
, Stat
);
3321 -------------------------------
3322 -- Eval_Qualified_Expression --
3323 -------------------------------
3325 -- A qualified expression is potentially static if its subtype mark denotes
3326 -- a static subtype and its expression is potentially static (RM 4.9 (10)).
3328 procedure Eval_Qualified_Expression
(N
: Node_Id
) is
3329 Operand
: constant Node_Id
:= Expression
(N
);
3330 Target_Type
: constant Entity_Id
:= Entity
(Subtype_Mark
(N
));
3337 -- Can only fold if target is string or scalar and subtype is static.
3338 -- Also, do not fold if our parent is an allocator (this is because the
3339 -- qualified expression is really part of the syntactic structure of an
3340 -- allocator, and we do not want to end up with something that
3341 -- corresponds to "new 1" where the 1 is the result of folding a
3342 -- qualified expression).
3344 if not Is_Static_Subtype
(Target_Type
)
3345 or else Nkind
(Parent
(N
)) = N_Allocator
3347 Check_Non_Static_Context
(Operand
);
3349 -- If operand is known to raise Constraint_Error, set the flag on the
3350 -- expression so it does not get optimized away.
3352 if Nkind
(Operand
) = N_Raise_Constraint_Error
then
3353 Set_Raises_Constraint_Error
(N
);
3358 -- Also return if a semantic error has been posted on the node, as we
3359 -- don't want to fold in that case (for GNATprove, the node might lead
3360 -- to Constraint_Error but won't have been replaced with a raise node
3361 -- or marked as raising CE).
3363 elsif Error_Posted
(N
) then
3367 -- If not foldable we are done
3369 Test_Expression_Is_Foldable
(N
, Operand
, Stat
, Fold
);
3374 -- Don't try fold if target type has Constraint_Error bounds
3376 elsif not Is_OK_Static_Subtype
(Target_Type
) then
3377 Set_Raises_Constraint_Error
(N
);
3381 -- Fold the result of qualification
3383 if Is_Discrete_Type
(Target_Type
) then
3385 -- Save Print_In_Hex indication
3387 Hex
:= Nkind
(Operand
) = N_Integer_Literal
3388 and then Print_In_Hex
(Operand
);
3390 Fold_Uint
(N
, Expr_Value
(Operand
), Stat
);
3392 -- Preserve Print_In_Hex indication
3394 if Hex
and then Nkind
(N
) = N_Integer_Literal
then
3395 Set_Print_In_Hex
(N
);
3398 elsif Is_Real_Type
(Target_Type
) then
3399 Fold_Ureal
(N
, Expr_Value_R
(Operand
), Stat
);
3402 Fold_Str
(N
, Strval
(Get_String_Val
(Operand
)), Stat
);
3405 Set_Is_Static_Expression
(N
, False);
3407 Check_String_Literal_Length
(N
, Target_Type
);
3413 -- The expression may be foldable but not static
3415 Set_Is_Static_Expression
(N
, Stat
);
3417 if Is_Out_Of_Range
(N
, Etype
(N
), Assume_Valid
=> True) then
3420 end Eval_Qualified_Expression
;
3422 -----------------------
3423 -- Eval_Real_Literal --
3424 -----------------------
3426 -- Numeric literals are static (RM 4.9(1)), and have already been marked
3427 -- as static by the analyzer. The reason we did it that early is to allow
3428 -- the possibility of turning off the Is_Static_Expression flag after
3429 -- analysis, but before resolution, when integer literals are generated
3430 -- in the expander that do not correspond to static expressions.
3432 procedure Eval_Real_Literal
(N
: Node_Id
) is
3433 PK
: constant Node_Kind
:= Nkind
(Parent
(N
));
3436 -- If the literal appears in a non-expression context and not as part of
3437 -- a number declaration, then it is appearing in a non-static context,
3440 if PK
not in N_Subexpr
and then PK
/= N_Number_Declaration
then
3441 Check_Non_Static_Context
(N
);
3443 end Eval_Real_Literal
;
3445 ------------------------
3446 -- Eval_Relational_Op --
3447 ------------------------
3449 -- Relational operations are static functions, so the result is static if
3450 -- both operands are static (RM 4.9(7), 4.9(20)), except that up to Ada
3451 -- 2012, for strings the result is never static, even if the operands are.
3452 -- The string case was relaxed in Ada 2022, see AI12-0201.
3454 -- However, for internally generated nodes, we allow string equality and
3455 -- inequality to be static. This is because we rewrite A in "ABC" as an
3456 -- equality test A = "ABC", and the former is definitely static.
3458 procedure Eval_Relational_Op
(N
: Node_Id
) is
3459 Left
: constant Node_Id
:= Left_Opnd
(N
);
3460 Right
: constant Node_Id
:= Right_Opnd
(N
);
3462 procedure Decompose_Expr
3464 Ent
: out Entity_Id
;
3465 Kind
: out Character;
3467 Orig
: Boolean := True);
3468 -- Given expression Expr, see if it is of the form X [+/- K]. If so, Ent
3469 -- is set to the entity in X, Kind is 'F','L','E' for 'First or 'Last or
3470 -- simple entity, and Cons is the value of K. If the expression is not
3471 -- of the required form, Ent is set to Empty.
3473 -- Orig indicates whether Expr is the original expression to consider,
3474 -- or if we are handling a subexpression (e.g. recursive call to
3477 procedure Fold_General_Op
(Is_Static
: Boolean);
3478 -- Attempt to fold arbitrary relational operator N. Flag Is_Static must
3479 -- be set when the operator denotes a static expression.
3481 procedure Fold_Static_Real_Op
;
3482 -- Attempt to fold static real type relational operator N
3484 function Static_Length
(Expr
: Node_Id
) return Uint
;
3485 -- If Expr is an expression for a constrained array whose length is
3486 -- known at compile time, return the non-negative length, otherwise
3489 --------------------
3490 -- Decompose_Expr --
3491 --------------------
3493 procedure Decompose_Expr
3495 Ent
: out Entity_Id
;
3496 Kind
: out Character;
3498 Orig
: Boolean := True)
3503 -- Assume that the expression does not meet the expected form
3509 if Nkind
(Expr
) = N_Op_Add
3510 and then Compile_Time_Known_Value
(Right_Opnd
(Expr
))
3512 Exp
:= Left_Opnd
(Expr
);
3513 Cons
:= Expr_Value
(Right_Opnd
(Expr
));
3515 elsif Nkind
(Expr
) = N_Op_Subtract
3516 and then Compile_Time_Known_Value
(Right_Opnd
(Expr
))
3518 Exp
:= Left_Opnd
(Expr
);
3519 Cons
:= -Expr_Value
(Right_Opnd
(Expr
));
3521 -- If the bound is a constant created to remove side effects, recover
3522 -- the original expression to see if it has one of the recognizable
3525 elsif Nkind
(Expr
) = N_Identifier
3526 and then not Comes_From_Source
(Entity
(Expr
))
3527 and then Ekind
(Entity
(Expr
)) = E_Constant
3528 and then Nkind
(Parent
(Entity
(Expr
))) = N_Object_Declaration
3530 Exp
:= Expression
(Parent
(Entity
(Expr
)));
3531 Decompose_Expr
(Exp
, Ent
, Kind
, Cons
, Orig
=> False);
3533 -- If original expression includes an entity, create a reference
3534 -- to it for use below.
3536 if Present
(Ent
) then
3537 Exp
:= New_Occurrence_Of
(Ent
, Sloc
(Ent
));
3543 -- Only consider the case of X + 0 for a full expression, and
3544 -- not when recursing, otherwise we may end up with evaluating
3545 -- expressions not known at compile time to 0.
3555 -- At this stage Exp is set to the potential X
3557 if Nkind
(Exp
) = N_Attribute_Reference
then
3558 if Attribute_Name
(Exp
) = Name_First
then
3560 elsif Attribute_Name
(Exp
) = Name_Last
then
3566 Exp
:= Prefix
(Exp
);
3572 if Is_Entity_Name
(Exp
) and then Present
(Entity
(Exp
)) then
3573 Ent
:= Entity
(Exp
);
3577 ---------------------
3578 -- Fold_General_Op --
3579 ---------------------
3581 procedure Fold_General_Op
(Is_Static
: Boolean) is
3582 CR
: constant Compare_Result
:=
3583 Compile_Time_Compare
(Left
, Right
, Assume_Valid
=> False);
3588 if CR
= Unknown
then
3596 elsif CR
= NE
or else CR
= GT
or else CR
= LT
then
3603 if CR
= GT
or else CR
= EQ
or else CR
= GE
then
3614 elsif CR
= EQ
or else CR
= LT
or else CR
= LE
then
3621 if CR
= LT
or else CR
= EQ
or else CR
= LE
then
3632 elsif CR
= EQ
or else CR
= GT
or else CR
= GE
then
3639 if CR
= NE
or else CR
= GT
or else CR
= LT
then
3648 raise Program_Error
;
3651 -- Determine the potential outcome of the relation assuming the
3652 -- operands are valid and emit a warning when the relation yields
3653 -- True or False only in the presence of invalid values.
3655 Warn_On_Constant_Valid_Condition
(N
);
3657 Fold_Uint
(N
, Test
(Result
), Is_Static
);
3658 end Fold_General_Op
;
3660 -------------------------
3661 -- Fold_Static_Real_Op --
3662 -------------------------
3664 procedure Fold_Static_Real_Op
is
3665 Left_Real
: constant Ureal
:= Expr_Value_R
(Left
);
3666 Right_Real
: constant Ureal
:= Expr_Value_R
(Right
);
3671 when N_Op_Eq
=> Result
:= (Left_Real
= Right_Real
);
3672 when N_Op_Ge
=> Result
:= (Left_Real
>= Right_Real
);
3673 when N_Op_Gt
=> Result
:= (Left_Real
> Right_Real
);
3674 when N_Op_Le
=> Result
:= (Left_Real
<= Right_Real
);
3675 when N_Op_Lt
=> Result
:= (Left_Real
< Right_Real
);
3676 when N_Op_Ne
=> Result
:= (Left_Real
/= Right_Real
);
3677 when others => raise Program_Error
;
3680 Fold_Uint
(N
, Test
(Result
), True);
3681 end Fold_Static_Real_Op
;
3687 function Static_Length
(Expr
: Node_Id
) return Uint
is
3697 -- First easy case string literal
3699 if Nkind
(Expr
) = N_String_Literal
then
3700 return UI_From_Int
(String_Length
(Strval
(Expr
)));
3702 -- With frontend inlining as performed in GNATprove mode, a variable
3703 -- may be inserted that has a string literal subtype. Deal with this
3704 -- specially as for the previous case.
3706 elsif Ekind
(Etype
(Expr
)) = E_String_Literal_Subtype
then
3707 return String_Literal_Length
(Etype
(Expr
));
3709 -- Second easy case, not constrained subtype, so no length
3711 elsif not Is_Constrained
(Etype
(Expr
)) then
3712 return Uint_Minus_1
;
3717 Typ
:= Etype
(First_Index
(Etype
(Expr
)));
3719 -- The simple case, both bounds are known at compile time
3721 if Is_Discrete_Type
(Typ
)
3722 and then Compile_Time_Known_Value
(Type_Low_Bound
(Typ
))
3723 and then Compile_Time_Known_Value
(Type_High_Bound
(Typ
))
3726 UI_Max
(Uint_0
, Expr_Value
(Type_High_Bound
(Typ
)) -
3727 Expr_Value
(Type_Low_Bound
(Typ
)) + 1);
3730 -- A more complex case, where the bounds are of the form X [+/- K1]
3731 -- .. X [+/- K2]), where X is an expression that is either A'First or
3732 -- A'Last (with A an entity name), or X is an entity name, and the
3733 -- two X's are the same and K1 and K2 are known at compile time, in
3734 -- this case, the length can also be computed at compile time, even
3735 -- though the bounds are not known. A common case of this is e.g.
3736 -- (X'First .. X'First+5).
3739 (Original_Node
(Type_Low_Bound
(Typ
)), Ent1
, Kind1
, Cons1
);
3741 (Original_Node
(Type_High_Bound
(Typ
)), Ent2
, Kind2
, Cons2
);
3743 if Present
(Ent1
) and then Ent1
= Ent2
and then Kind1
= Kind2
then
3744 return Cons2
- Cons1
+ 1;
3746 return Uint_Minus_1
;
3752 Left_Typ
: constant Entity_Id
:= Etype
(Left
);
3753 Right_Typ
: constant Entity_Id
:= Etype
(Right
);
3756 Op_Typ
: Entity_Id
:= Empty
;
3759 Is_Static_Expression
: Boolean;
3761 -- Start of processing for Eval_Relational_Op
3764 -- One special case to deal with first. If we can tell that the result
3765 -- will be false because the lengths of one or more index subtypes are
3766 -- compile-time known and different, then we can replace the entire
3767 -- result by False. We only do this for one-dimensional arrays, because
3768 -- the case of multidimensional arrays is rare and too much trouble. If
3769 -- one of the operands is an illegal aggregate, its type might still be
3770 -- an arbitrary composite type, so nothing to do.
3772 if Is_Array_Type
(Left_Typ
)
3773 and then Left_Typ
/= Any_Composite
3774 and then Number_Dimensions
(Left_Typ
) = 1
3775 and then Nkind
(N
) in N_Op_Eq | N_Op_Ne
3777 if Raises_Constraint_Error
(Left
)
3779 Raises_Constraint_Error
(Right
)
3784 -- OK, we have the case where we may be able to do this fold
3786 Left_Len
:= Static_Length
(Left
);
3787 Right_Len
:= Static_Length
(Right
);
3789 if Left_Len
/= Uint_Minus_1
3790 and then Right_Len
/= Uint_Minus_1
3791 and then Left_Len
/= Right_Len
3793 -- AI12-0201: comparison of string is static in Ada 2022
3797 Test
(Nkind
(N
) = N_Op_Ne
),
3798 Static
=> Ada_Version
>= Ada_2022
3799 and then Is_String_Type
(Left_Typ
));
3800 Warn_On_Known_Condition
(N
);
3807 -- Initialize the value of Is_Static_Expression. The value of Fold
3808 -- returned by Test_Expression_Is_Foldable is not needed since, even
3809 -- when some operand is a variable, we can still perform the static
3810 -- evaluation of the expression in some cases (for example, for a
3811 -- variable of a subtype of Integer we statically know that any value
3812 -- stored in such variable is smaller than Integer'Last).
3814 Test_Expression_Is_Foldable
3815 (N
, Left
, Right
, Is_Static_Expression
, Fold
);
3817 -- Comparisons of scalars can give static results.
3818 -- In addition starting with Ada 2022 (AI12-0201), comparison of strings
3819 -- can also give static results, and as noted above, we also allow for
3820 -- earlier Ada versions internally generated equality and inequality for
3822 -- The Comes_From_Source test below isn't correct and will accept
3823 -- some cases that are illegal in Ada 2012 and before. Now that Ada
3824 -- 2022 has relaxed the rules, this doesn't really matter.
3826 if Is_String_Type
(Left_Typ
) then
3827 if Ada_Version
< Ada_2022
3828 and then (Comes_From_Source
(N
)
3829 or else Nkind
(N
) not in N_Op_Eq | N_Op_Ne
)
3831 Is_Static_Expression
:= False;
3832 Set_Is_Static_Expression
(N
, False);
3835 elsif not Is_Scalar_Type
(Left_Typ
) then
3836 Is_Static_Expression
:= False;
3837 Set_Is_Static_Expression
(N
, False);
3840 -- For operators on universal numeric types called as functions with an
3841 -- explicit scope, determine appropriate specific numeric type, and
3842 -- diagnose possible ambiguity.
3844 if Is_Universal_Numeric_Type
(Left_Typ
)
3846 Is_Universal_Numeric_Type
(Right_Typ
)
3848 Op_Typ
:= Find_Universal_Operator_Type
(N
);
3851 -- Attempt to fold the relational operator
3853 if Is_Static_Expression
and then Is_Real_Type
(Left_Typ
) then
3854 Fold_Static_Real_Op
;
3856 Fold_General_Op
(Is_Static_Expression
);
3859 -- For the case of a folded relational operator on a specific numeric
3860 -- type, freeze the operand type now.
3862 if Present
(Op_Typ
) then
3863 Freeze_Before
(N
, Op_Typ
);
3866 Warn_On_Known_Condition
(N
);
3867 end Eval_Relational_Op
;
3869 -----------------------------
3870 -- Eval_Selected_Component --
3871 -----------------------------
3873 procedure Eval_Selected_Component
(N
: Node_Id
) is
3880 -- If an attribute reference or a LHS, nothing to do.
3881 -- Also do not fold if N is an [in] out subprogram parameter.
3882 -- Fold will perform the other relevant tests.
3884 if Nkind
(Parent
(N
)) /= N_Attribute_Reference
3885 and then Is_LHS
(N
) = No
3886 and then not Is_Actual_Out_Or_In_Out_Parameter
(N
)
3888 -- Simplify a selected_component on an aggregate by extracting
3889 -- the field directly.
3891 Node
:= Unqualify
(Prefix
(N
));
3893 if Nkind
(Node
) = N_Aggregate
3894 and then Compile_Time_Known_Aggregate
(Node
)
3896 Comp
:= First
(Component_Associations
(Node
));
3897 Nam
:= Chars
(Selector_Name
(N
));
3899 while Present
(Comp
) loop
3900 C
:= First
(Choices
(Comp
));
3902 while Present
(C
) loop
3903 if Chars
(C
) = Nam
then
3904 Rewrite
(N
, Relocate_Node
(Expression
(Comp
)));
3917 end Eval_Selected_Component
;
3923 procedure Eval_Shift
(N
: Node_Id
) is
3925 -- This procedure is only called for compiler generated code (e.g.
3926 -- packed arrays), so there is nothing to do except attempting to fold
3929 Fold_Shift
(N
, Left_Opnd
(N
), Right_Opnd
(N
), Nkind
(N
));
3932 ------------------------
3933 -- Eval_Short_Circuit --
3934 ------------------------
3936 -- A short circuit operation is potentially static if both operands are
3937 -- potentially static (RM 4.9 (13)).
3939 procedure Eval_Short_Circuit
(N
: Node_Id
) is
3940 Kind
: constant Node_Kind
:= Nkind
(N
);
3941 Left
: constant Node_Id
:= Left_Opnd
(N
);
3942 Right
: constant Node_Id
:= Right_Opnd
(N
);
3945 Rstat
: constant Boolean :=
3946 Is_Static_Expression
(Left
)
3948 Is_Static_Expression
(Right
);
3951 -- Short circuit operations are never static in Ada 83
3953 if Ada_Version
= Ada_83
and then Comes_From_Source
(N
) then
3954 Check_Non_Static_Context
(Left
);
3955 Check_Non_Static_Context
(Right
);
3959 -- Now look at the operands, we can't quite use the normal call to
3960 -- Test_Expression_Is_Foldable here because short circuit operations
3961 -- are a special case, they can still be foldable, even if the right
3962 -- operand raises Constraint_Error.
3964 -- If either operand is Any_Type, just propagate to result and do not
3965 -- try to fold, this prevents cascaded errors.
3967 if Etype
(Left
) = Any_Type
or else Etype
(Right
) = Any_Type
then
3968 Set_Etype
(N
, Any_Type
);
3971 -- If left operand raises Constraint_Error, then replace node N with
3972 -- the raise Constraint_Error node, and we are obviously not foldable.
3973 -- Is_Static_Expression is set from the two operands in the normal way,
3974 -- and we check the right operand if it is in a non-static context.
3976 elsif Raises_Constraint_Error
(Left
) then
3978 Check_Non_Static_Context
(Right
);
3981 Rewrite_In_Raise_CE
(N
, Left
);
3982 Set_Is_Static_Expression
(N
, Rstat
);
3985 -- If the result is not static, then we won't in any case fold
3987 elsif not Rstat
then
3988 Check_Non_Static_Context
(Left
);
3989 Check_Non_Static_Context
(Right
);
3993 -- Here the result is static, note that, unlike the normal processing
3994 -- in Test_Expression_Is_Foldable, we did *not* check above to see if
3995 -- the right operand raises Constraint_Error, that's because it is not
3996 -- significant if the left operand is decisive.
3998 Set_Is_Static_Expression
(N
);
4000 -- It does not matter if the right operand raises Constraint_Error if
4001 -- it will not be evaluated. So deal specially with the cases where
4002 -- the right operand is not evaluated. Note that we will fold these
4003 -- cases even if the right operand is non-static, which is fine, but
4004 -- of course in these cases the result is not potentially static.
4006 Left_Int
:= Expr_Value
(Left
);
4008 if (Kind
= N_And_Then
and then Is_False
(Left_Int
))
4010 (Kind
= N_Or_Else
and then Is_True
(Left_Int
))
4012 Fold_Uint
(N
, Left_Int
, Rstat
);
4016 -- If first operand not decisive, then it does matter if the right
4017 -- operand raises Constraint_Error, since it will be evaluated, so
4018 -- we simply replace the node with the right operand. Note that this
4019 -- properly propagates Is_Static_Expression and Raises_Constraint_Error
4020 -- (both are set to True in Right).
4022 if Raises_Constraint_Error
(Right
) then
4023 Rewrite_In_Raise_CE
(N
, Right
);
4024 Check_Non_Static_Context
(Left
);
4028 -- Otherwise the result depends on the right operand
4030 Fold_Uint
(N
, Expr_Value
(Right
), Rstat
);
4032 end Eval_Short_Circuit
;
4038 -- Slices can never be static, so the only processing required is to check
4039 -- for non-static context if an explicit range is given.
4041 procedure Eval_Slice
(N
: Node_Id
) is
4042 Drange
: constant Node_Id
:= Discrete_Range
(N
);
4043 Name
: constant Node_Id
:= Prefix
(N
);
4046 if Nkind
(Drange
) = N_Range
then
4047 Check_Non_Static_Context
(Low_Bound
(Drange
));
4048 Check_Non_Static_Context
(High_Bound
(Drange
));
4051 -- A slice of the form A (subtype), when the subtype is the index of
4052 -- the type of A, is redundant, the slice can be replaced with A, and
4053 -- this is worth a warning.
4055 if Is_Entity_Name
(Name
) then
4057 E
: constant Entity_Id
:= Entity
(Name
);
4058 T
: constant Entity_Id
:= Etype
(E
);
4062 and then Is_Array_Type
(T
)
4063 and then Is_Entity_Name
(Drange
)
4065 if Is_Entity_Name
(Original_Node
(First_Index
(T
)))
4066 and then Entity
(Original_Node
(First_Index
(T
)))
4069 if Warn_On_Redundant_Constructs
then
4070 Error_Msg_N
("redundant slice denotes whole array?r?", N
);
4073 -- The following might be a useful optimization???
4075 -- Rewrite (N, New_Occurrence_Of (E, Sloc (N)));
4082 -------------------------
4083 -- Eval_String_Literal --
4084 -------------------------
4086 procedure Eval_String_Literal
(N
: Node_Id
) is
4087 Typ
: constant Entity_Id
:= Etype
(N
);
4088 Bas
: constant Entity_Id
:= Base_Type
(Typ
);
4094 -- Nothing to do if error type (handles cases like default expressions
4095 -- or generics where we have not yet fully resolved the type).
4097 if Bas
= Any_Type
or else Bas
= Any_String
then
4101 -- String literals are static if the subtype is static (RM 4.9(2)), so
4102 -- reset the static expression flag (it was set unconditionally in
4103 -- Analyze_String_Literal) if the subtype is non-static. We tell if
4104 -- the subtype is static by looking at the lower bound.
4106 if Ekind
(Typ
) = E_String_Literal_Subtype
then
4107 if not Is_OK_Static_Expression
(String_Literal_Low_Bound
(Typ
)) then
4108 Set_Is_Static_Expression
(N
, False);
4112 -- Here if Etype of string literal is normal Etype (not yet possible,
4113 -- but may be possible in future).
4115 elsif not Is_OK_Static_Expression
4116 (Type_Low_Bound
(Etype
(First_Index
(Typ
))))
4118 Set_Is_Static_Expression
(N
, False);
4122 -- If original node was a type conversion, then result if non-static
4123 -- up to Ada 2012. AI12-0201 changes that with Ada 2022.
4125 if Nkind
(Original_Node
(N
)) = N_Type_Conversion
4126 and then Ada_Version
<= Ada_2012
4128 Set_Is_Static_Expression
(N
, False);
4132 -- Test for illegal Ada 95 cases. A string literal is illegal in Ada 95
4133 -- if its bounds are outside the index base type and this index type is
4134 -- static. This can happen in only two ways. Either the string literal
4135 -- is too long, or it is null, and the lower bound is type'First. Either
4136 -- way it is the upper bound that is out of range of the index type.
4138 if Ada_Version
>= Ada_95
then
4139 if Is_Standard_String_Type
(Bas
) then
4140 Xtp
:= Standard_Positive
;
4142 Xtp
:= Etype
(First_Index
(Bas
));
4145 if Ekind
(Typ
) = E_String_Literal_Subtype
then
4146 Lo
:= String_Literal_Low_Bound
(Typ
);
4148 Lo
:= Type_Low_Bound
(Etype
(First_Index
(Typ
)));
4151 -- Check for string too long
4153 Len
:= String_Length
(Strval
(N
));
4155 if Len
> String_Type_Len
(Bas
) then
4157 -- Issue message. Note that this message is a warning if the
4158 -- string literal is not marked as static (happens in some cases
4159 -- of folding strings known at compile time, but not static).
4160 -- Furthermore in such cases, we reword the message, since there
4161 -- is no string literal in the source program.
4163 if Is_Static_Expression
(N
) then
4164 Apply_Compile_Time_Constraint_Error
4165 (N
, "string literal too long for}", CE_Length_Check_Failed
,
4167 Typ
=> First_Subtype
(Bas
));
4169 Apply_Compile_Time_Constraint_Error
4170 (N
, "string value too long for}", CE_Length_Check_Failed
,
4172 Typ
=> First_Subtype
(Bas
),
4176 -- Test for null string not allowed
4179 and then not Is_Generic_Type
(Xtp
)
4181 Expr_Value
(Lo
) = Expr_Value
(Type_Low_Bound
(Base_Type
(Xtp
)))
4183 -- Same specialization of message
4185 if Is_Static_Expression
(N
) then
4186 Apply_Compile_Time_Constraint_Error
4187 (N
, "null string literal not allowed for}",
4188 CE_Length_Check_Failed
,
4190 Typ
=> First_Subtype
(Bas
));
4192 Apply_Compile_Time_Constraint_Error
4193 (N
, "null string value not allowed for}",
4194 CE_Length_Check_Failed
,
4196 Typ
=> First_Subtype
(Bas
),
4201 end Eval_String_Literal
;
4203 --------------------------
4204 -- Eval_Type_Conversion --
4205 --------------------------
4207 -- A type conversion is potentially static if its subtype mark is for a
4208 -- static scalar subtype, and its operand expression is potentially static
4210 -- Also add support for static string types.
4212 procedure Eval_Type_Conversion
(N
: Node_Id
) is
4213 Operand
: constant Node_Id
:= Expression
(N
);
4214 Source_Type
: constant Entity_Id
:= Etype
(Operand
);
4215 Target_Type
: constant Entity_Id
:= Etype
(N
);
4217 function To_Be_Treated_As_Integer
(T
: Entity_Id
) return Boolean;
4218 -- Returns true if type T is an integer type, or if it is a fixed-point
4219 -- type to be treated as an integer (i.e. the flag Conversion_OK is set
4220 -- on the conversion node).
4222 function To_Be_Treated_As_Real
(T
: Entity_Id
) return Boolean;
4223 -- Returns true if type T is a floating-point type, or if it is a
4224 -- fixed-point type that is not to be treated as an integer (i.e. the
4225 -- flag Conversion_OK is not set on the conversion node).
4227 ------------------------------
4228 -- To_Be_Treated_As_Integer --
4229 ------------------------------
4231 function To_Be_Treated_As_Integer
(T
: Entity_Id
) return Boolean is
4235 or else (Is_Fixed_Point_Type
(T
) and then Conversion_OK
(N
));
4236 end To_Be_Treated_As_Integer
;
4238 ---------------------------
4239 -- To_Be_Treated_As_Real --
4240 ---------------------------
4242 function To_Be_Treated_As_Real
(T
: Entity_Id
) return Boolean is
4245 Is_Floating_Point_Type
(T
)
4246 or else (Is_Fixed_Point_Type
(T
) and then not Conversion_OK
(N
));
4247 end To_Be_Treated_As_Real
;
4254 -- Start of processing for Eval_Type_Conversion
4257 -- Cannot fold if target type is non-static or if semantic error
4259 if not Is_Static_Subtype
(Target_Type
) then
4260 Check_Non_Static_Context
(Operand
);
4262 elsif Error_Posted
(N
) then
4266 -- If not foldable we are done
4268 Test_Expression_Is_Foldable
(N
, Operand
, Stat
, Fold
);
4273 -- Don't try fold if target type has Constraint_Error bounds
4275 elsif not Is_OK_Static_Subtype
(Target_Type
) then
4276 Set_Raises_Constraint_Error
(N
);
4280 -- Remaining processing depends on operand types. Note that in the
4281 -- following type test, fixed-point counts as real unless the flag
4282 -- Conversion_OK is set, in which case it counts as integer.
4284 -- Fold conversion, case of string type. The result is static starting
4285 -- with Ada 2022 (AI12-0201).
4287 if Is_String_Type
(Target_Type
) then
4290 Strval
(Get_String_Val
(Operand
)),
4291 Static
=> Ada_Version
>= Ada_2022
);
4294 -- Fold conversion, case of integer target type
4296 elsif To_Be_Treated_As_Integer
(Target_Type
) then
4301 -- Integer to integer conversion
4303 if To_Be_Treated_As_Integer
(Source_Type
) then
4304 Result
:= Expr_Value
(Operand
);
4306 -- Real to integer conversion
4308 elsif To_Be_Treated_As_Real
(Source_Type
) then
4309 Result
:= UR_To_Uint
(Expr_Value_R
(Operand
));
4311 -- Enumeration to integer conversion, aka 'Enum_Rep
4314 Result
:= Expr_Rep_Value
(Operand
);
4317 -- If fixed-point type (Conversion_OK must be set), then the
4318 -- result is logically an integer, but we must replace the
4319 -- conversion with the corresponding real literal, since the
4320 -- type from a semantic point of view is still fixed-point.
4322 if Is_Fixed_Point_Type
(Target_Type
) then
4324 (N
, UR_From_Uint
(Result
) * Small_Value
(Target_Type
), Stat
);
4326 -- Otherwise result is integer literal
4329 Fold_Uint
(N
, Result
, Stat
);
4333 -- Fold conversion, case of real target type
4335 elsif To_Be_Treated_As_Real
(Target_Type
) then
4340 if To_Be_Treated_As_Real
(Source_Type
) then
4341 Result
:= Expr_Value_R
(Operand
);
4343 Result
:= UR_From_Uint
(Expr_Value
(Operand
));
4346 Fold_Ureal
(N
, Result
, Stat
);
4349 -- Enumeration types
4352 Fold_Uint
(N
, Expr_Value
(Operand
), Stat
);
4355 -- If the target is a static floating-point subtype, then its bounds
4356 -- are machine numbers so we must consider the machine-rounded value.
4358 if Is_Floating_Point_Type
(Target_Type
)
4359 and then Nkind
(N
) = N_Real_Literal
4360 and then not Is_Machine_Number
(N
)
4363 Lo
: constant Node_Id
:= Type_Low_Bound
(Target_Type
);
4364 Hi
: constant Node_Id
:= Type_High_Bound
(Target_Type
);
4365 Valr
: constant Ureal
:=
4366 Machine_Number
(Target_Type
, Expr_Value_R
(N
), N
);
4368 if Valr
< Expr_Value_R
(Lo
) or else Valr
> Expr_Value_R
(Hi
) then
4373 elsif Is_Out_Of_Range
(N
, Etype
(N
), Assume_Valid
=> True) then
4376 end Eval_Type_Conversion
;
4382 -- Predefined unary operators are static functions (RM 4.9(20)) and thus
4383 -- are potentially static if the operand is potentially static (RM 4.9(7)).
4385 procedure Eval_Unary_Op
(N
: Node_Id
) is
4386 Right
: constant Node_Id
:= Right_Opnd
(N
);
4387 Otype
: Entity_Id
:= Empty
;
4392 -- If not foldable we are done
4394 Test_Expression_Is_Foldable
(N
, Right
, Stat
, Fold
);
4400 if Is_Universal_Numeric_Type
(Etype
(Right
)) then
4401 Otype
:= Find_Universal_Operator_Type
(N
);
4404 -- Fold for integer case
4406 if Is_Integer_Type
(Etype
(N
)) then
4408 Rint
: constant Uint
:= Expr_Value
(Right
);
4412 -- In the case of modular unary plus and abs there is no need
4413 -- to adjust the result of the operation since if the original
4414 -- operand was in bounds the result will be in the bounds of the
4415 -- modular type. However, in the case of modular unary minus the
4416 -- result may go out of the bounds of the modular type and needs
4419 if Nkind
(N
) = N_Op_Plus
then
4422 elsif Nkind
(N
) = N_Op_Minus
then
4423 if Is_Modular_Integer_Type
(Etype
(N
)) then
4424 Result
:= (-Rint
) mod Modulus
(Etype
(N
));
4430 pragma Assert
(Nkind
(N
) = N_Op_Abs
);
4434 Check_Non_Static_Context_For_Overflow
(N
, Stat
, Result
);
4436 Fold_Uint
(N
, Result
, Stat
);
4439 -- Fold for real case
4441 elsif Is_Real_Type
(Etype
(N
)) then
4443 Rreal
: constant Ureal
:= Expr_Value_R
(Right
);
4447 if Nkind
(N
) = N_Op_Plus
then
4449 elsif Nkind
(N
) = N_Op_Minus
then
4450 Result
:= UR_Negate
(Rreal
);
4452 pragma Assert
(Nkind
(N
) = N_Op_Abs
);
4453 Result
:= abs Rreal
;
4456 Fold_Ureal
(N
, Result
, Stat
);
4460 -- If the operator was resolved to a specific type, make sure that type
4461 -- is frozen even if the expression is folded into a literal (which has
4462 -- a universal type).
4464 if Present
(Otype
) then
4465 Freeze_Before
(N
, Otype
);
4469 -------------------------------
4470 -- Eval_Unchecked_Conversion --
4471 -------------------------------
4473 -- Unchecked conversions can never be static, so the only required
4474 -- processing is to check for a non-static context for the operand.
4476 procedure Eval_Unchecked_Conversion
(N
: Node_Id
) is
4477 Target_Type
: constant Entity_Id
:= Etype
(N
);
4478 Operand
: constant Node_Id
:= Expression
(N
);
4479 Operand_Type
: constant Entity_Id
:= Etype
(Operand
);
4482 Check_Non_Static_Context
(Operand
);
4484 -- If we have a conversion of a compile time known value to a target
4485 -- type and the value is in range of the target type, then we can simply
4486 -- replace the construct by an integer literal of the correct type. We
4487 -- only apply this to discrete types being converted. Possibly it may
4488 -- apply in other cases, but it is too much trouble to worry about.
4490 -- Note that we do not do this transformation if the Kill_Range_Check
4491 -- flag is set, since then the value may be outside the expected range.
4492 -- This happens in the Normalize_Scalars case.
4494 -- We also skip this if either the target or operand type is biased
4495 -- because in this case, the unchecked conversion is supposed to
4496 -- preserve the bit pattern, not the integer value.
4498 if Is_Integer_Type
(Target_Type
)
4499 and then not Has_Biased_Representation
(Target_Type
)
4500 and then Is_Discrete_Type
(Operand_Type
)
4501 and then not Has_Biased_Representation
(Operand_Type
)
4502 and then Compile_Time_Known_Value
(Operand
)
4503 and then not Kill_Range_Check
(N
)
4506 Val
: constant Uint
:= Expr_Rep_Value
(Operand
);
4509 if Compile_Time_Known_Value
(Type_Low_Bound
(Target_Type
))
4511 Compile_Time_Known_Value
(Type_High_Bound
(Target_Type
))
4513 Val
>= Expr_Value
(Type_Low_Bound
(Target_Type
))
4515 Val
<= Expr_Value
(Type_High_Bound
(Target_Type
))
4517 Rewrite
(N
, Make_Integer_Literal
(Sloc
(N
), Val
));
4519 -- If Address is the target type, just set the type to avoid a
4520 -- spurious type error on the literal when Address is a visible
4523 if Is_Descendant_Of_Address
(Target_Type
) then
4524 Set_Etype
(N
, Target_Type
);
4526 Analyze_And_Resolve
(N
, Target_Type
);
4533 end Eval_Unchecked_Conversion
;
4535 --------------------
4536 -- Expr_Rep_Value --
4537 --------------------
4539 function Expr_Rep_Value
(N
: Node_Id
) return Uint
is
4540 Kind
: constant Node_Kind
:= Nkind
(N
);
4544 if Is_Entity_Name
(N
) then
4547 -- An enumeration literal that was either in the source or created
4548 -- as a result of static evaluation.
4550 if Ekind
(Ent
) = E_Enumeration_Literal
then
4551 return Enumeration_Rep
(Ent
);
4553 -- A user defined static constant
4556 pragma Assert
(Ekind
(Ent
) = E_Constant
);
4557 return Expr_Rep_Value
(Constant_Value
(Ent
));
4560 -- An integer literal that was either in the source or created as a
4561 -- result of static evaluation.
4563 elsif Kind
= N_Integer_Literal
then
4566 -- A real literal for a fixed-point type. This must be the fixed-point
4567 -- case, either the literal is of a fixed-point type, or it is a bound
4568 -- of a fixed-point type, with type universal real. In either case we
4569 -- obtain the desired value from Corresponding_Integer_Value.
4571 elsif Kind
= N_Real_Literal
then
4572 pragma Assert
(Is_Fixed_Point_Type
(Underlying_Type
(Etype
(N
))));
4573 return Corresponding_Integer_Value
(N
);
4575 -- The NULL access value
4577 elsif Kind
= N_Null
then
4578 pragma Assert
(Is_Access_Type
(Underlying_Type
(Etype
(N
)))
4579 or else Error_Posted
(N
));
4582 -- Character literal
4584 elsif Kind
= N_Character_Literal
then
4587 -- Since Character literals of type Standard.Character don't have any
4588 -- defining character literals built for them, they do not have their
4589 -- Entity set, so just use their Char code. Otherwise for user-
4590 -- defined character literals use their Pos value as usual which is
4591 -- the same as the Rep value.
4594 return Char_Literal_Value
(N
);
4596 return Enumeration_Rep
(Ent
);
4599 -- Unchecked conversion, which can come from System'To_Address (X)
4600 -- where X is a static integer expression. Recursively evaluate X.
4602 elsif Kind
= N_Unchecked_Type_Conversion
then
4603 return Expr_Rep_Value
(Expression
(N
));
4605 -- Static discriminant value
4607 elsif Is_Static_Discriminant_Component
(N
) then
4608 return Expr_Rep_Value
4609 (Get_Discriminant_Value
4610 (Entity
(Selector_Name
(N
)),
4612 Discriminant_Constraint
(Etype
(Prefix
(N
)))));
4615 raise Program_Error
;
4623 function Expr_Value
(N
: Node_Id
) return Uint
is
4624 Kind
: constant Node_Kind
:= Nkind
(N
);
4625 CV_Ent
: CV_Entry
renames CV_Cache
(Nat
(N
) mod CV_Cache_Size
);
4630 -- If already in cache, then we know it's compile-time-known and we can
4631 -- return the value that was previously stored in the cache since
4632 -- compile-time-known values cannot change.
4634 if CV_Ent
.N
= N
then
4638 -- Otherwise proceed to test value
4640 if Is_Entity_Name
(N
) then
4643 -- An enumeration literal that was either in the source or created as
4644 -- a result of static evaluation.
4646 if Ekind
(Ent
) = E_Enumeration_Literal
then
4647 Val
:= Enumeration_Pos
(Ent
);
4649 -- A user defined static constant
4652 pragma Assert
(Ekind
(Ent
) = E_Constant
);
4653 Val
:= Expr_Value
(Constant_Value
(Ent
));
4656 -- An integer literal that was either in the source or created as a
4657 -- result of static evaluation.
4659 elsif Kind
= N_Integer_Literal
then
4662 -- A real literal for a fixed-point type. This must be the fixed-point
4663 -- case, either the literal is of a fixed-point type, or it is a bound
4664 -- of a fixed-point type, with type universal real. In either case we
4665 -- obtain the desired value from Corresponding_Integer_Value.
4667 elsif Kind
= N_Real_Literal
then
4668 pragma Assert
(Is_Fixed_Point_Type
(Underlying_Type
(Etype
(N
))));
4669 Val
:= Corresponding_Integer_Value
(N
);
4671 -- The NULL access value
4673 elsif Kind
= N_Null
then
4674 pragma Assert
(Is_Access_Type
(Underlying_Type
(Etype
(N
)))
4675 or else Error_Posted
(N
));
4678 -- Character literal
4680 elsif Kind
= N_Character_Literal
then
4683 -- Since Character literals of type Standard.Character don't
4684 -- have any defining character literals built for them, they
4685 -- do not have their Entity set, so just use their Char
4686 -- code. Otherwise for user-defined character literals use
4687 -- their Pos value as usual.
4690 Val
:= Char_Literal_Value
(N
);
4692 Val
:= Enumeration_Pos
(Ent
);
4695 -- Unchecked conversion, which can come from System'To_Address (X)
4696 -- where X is a static integer expression. Recursively evaluate X.
4698 elsif Kind
= N_Unchecked_Type_Conversion
then
4699 Val
:= Expr_Value
(Expression
(N
));
4701 -- Static discriminant value
4703 elsif Is_Static_Discriminant_Component
(N
) then
4705 (Get_Discriminant_Value
4706 (Entity
(Selector_Name
(N
)),
4708 Discriminant_Constraint
(Etype
(Prefix
(N
)))));
4711 raise Program_Error
;
4714 -- Come here with Val set to value to be returned, set cache
4725 function Expr_Value_E
(N
: Node_Id
) return Entity_Id
is
4726 Ent
: constant Entity_Id
:= Entity
(N
);
4728 if Ekind
(Ent
) = E_Enumeration_Literal
then
4731 pragma Assert
(Ekind
(Ent
) = E_Constant
);
4733 -- We may be dealing with a enumerated character type constant, so
4734 -- handle that case here.
4736 if Nkind
(Constant_Value
(Ent
)) = N_Character_Literal
then
4739 return Expr_Value_E
(Constant_Value
(Ent
));
4748 function Expr_Value_R
(N
: Node_Id
) return Ureal
is
4749 Kind
: constant Node_Kind
:= Nkind
(N
);
4753 if Kind
= N_Real_Literal
then
4756 elsif Kind
= N_Identifier
or else Kind
= N_Expanded_Name
then
4758 pragma Assert
(Ekind
(Ent
) = E_Constant
);
4759 return Expr_Value_R
(Constant_Value
(Ent
));
4761 elsif Kind
= N_Integer_Literal
then
4762 return UR_From_Uint
(Expr_Value
(N
));
4764 -- Here, we have a node that cannot be interpreted as a compile time
4765 -- constant. That is definitely an error.
4768 raise Program_Error
;
4776 function Expr_Value_S
(N
: Node_Id
) return Node_Id
is
4778 if Nkind
(N
) = N_String_Literal
then
4781 pragma Assert
(Ekind
(Entity
(N
)) = E_Constant
);
4782 return Expr_Value_S
(Constant_Value
(Entity
(N
)));
4786 ----------------------------------
4787 -- Find_Universal_Operator_Type --
4788 ----------------------------------
4790 function Find_Universal_Operator_Type
(N
: Node_Id
) return Entity_Id
is
4791 PN
: constant Node_Id
:= Parent
(N
);
4792 Call
: constant Node_Id
:= Original_Node
(N
);
4793 Is_Int
: constant Boolean := Is_Integer_Type
(Etype
(N
));
4795 Is_Fix
: constant Boolean :=
4796 Nkind
(N
) in N_Binary_Op
4797 and then Nkind
(Right_Opnd
(N
)) /= Nkind
(Left_Opnd
(N
));
4798 -- A mixed-mode operation in this context indicates the presence of
4799 -- fixed-point type in the designated package.
4801 Is_Relational
: constant Boolean := Etype
(N
) = Standard_Boolean
;
4802 -- Case where N is a relational (or membership) operator (else it is an
4805 In_Membership
: constant Boolean :=
4806 Nkind
(PN
) in N_Membership_Test
4808 Nkind
(Right_Opnd
(PN
)) = N_Range
4810 Is_Universal_Numeric_Type
(Etype
(Left_Opnd
(PN
)))
4812 Is_Universal_Numeric_Type
4813 (Etype
(Low_Bound
(Right_Opnd
(PN
))))
4815 Is_Universal_Numeric_Type
4816 (Etype
(High_Bound
(Right_Opnd
(PN
))));
4817 -- Case where N is part of a membership test with a universal range
4821 Typ1
: Entity_Id
:= Empty
;
4824 function Is_Mixed_Mode_Operand
(Op
: Node_Id
) return Boolean;
4825 -- Check whether one operand is a mixed-mode operation that requires the
4826 -- presence of a fixed-point type. Given that all operands are universal
4827 -- and have been constant-folded, retrieve the original function call.
4829 ---------------------------
4830 -- Is_Mixed_Mode_Operand --
4831 ---------------------------
4833 function Is_Mixed_Mode_Operand
(Op
: Node_Id
) return Boolean is
4834 Onod
: constant Node_Id
:= Original_Node
(Op
);
4836 return Nkind
(Onod
) = N_Function_Call
4837 and then Present
(Next_Actual
(First_Actual
(Onod
)))
4838 and then Etype
(First_Actual
(Onod
)) /=
4839 Etype
(Next_Actual
(First_Actual
(Onod
)));
4840 end Is_Mixed_Mode_Operand
;
4842 -- Start of processing for Find_Universal_Operator_Type
4845 if Nkind
(Call
) /= N_Function_Call
4846 or else Nkind
(Name
(Call
)) /= N_Expanded_Name
4850 -- There are several cases where the context does not imply the type of
4852 -- - the universal expression appears in a type conversion;
4853 -- - the expression is a relational operator applied to universal
4855 -- - the expression is a membership test with a universal operand
4856 -- and a range with universal bounds.
4858 elsif Nkind
(Parent
(N
)) = N_Type_Conversion
4859 or else Is_Relational
4860 or else In_Membership
4862 Pack
:= Entity
(Prefix
(Name
(Call
)));
4864 -- If the prefix is a package declared elsewhere, iterate over its
4865 -- visible entities, otherwise iterate over all declarations in the
4866 -- designated scope.
4868 if Ekind
(Pack
) = E_Package
4869 and then not In_Open_Scopes
(Pack
)
4871 Priv_E
:= First_Private_Entity
(Pack
);
4877 E
:= First_Entity
(Pack
);
4878 while Present
(E
) and then E
/= Priv_E
loop
4879 if Is_Numeric_Type
(E
)
4880 and then Nkind
(Parent
(E
)) /= N_Subtype_Declaration
4881 and then Comes_From_Source
(E
)
4882 and then Is_Integer_Type
(E
) = Is_Int
4883 and then (Nkind
(N
) in N_Unary_Op
4884 or else Is_Relational
4885 or else Is_Fixed_Point_Type
(E
) = Is_Fix
)
4890 -- Before emitting an error, check for the presence of a
4891 -- mixed-mode operation that specifies a fixed point type.
4895 (Is_Mixed_Mode_Operand
(Left_Opnd
(N
))
4896 or else Is_Mixed_Mode_Operand
(Right_Opnd
(N
)))
4897 and then Is_Fixed_Point_Type
(E
) /= Is_Fixed_Point_Type
(Typ1
)
4900 if Is_Fixed_Point_Type
(E
) then
4905 -- More than one type of the proper class declared in P
4907 Error_Msg_N
("ambiguous operation", N
);
4908 Error_Msg_Sloc
:= Sloc
(Typ1
);
4909 Error_Msg_N
("\possible interpretation (inherited)#", N
);
4910 Error_Msg_Sloc
:= Sloc
(E
);
4911 Error_Msg_N
("\possible interpretation (inherited)#", N
);
4921 end Find_Universal_Operator_Type
;
4923 --------------------------
4924 -- Flag_Non_Static_Expr --
4925 --------------------------
4927 procedure Flag_Non_Static_Expr
(Msg
: String; Expr
: Node_Id
) is
4929 if Error_Posted
(Expr
) and then not All_Errors_Mode
then
4932 Error_Msg_F
(Msg
, Expr
);
4933 Why_Not_Static
(Expr
);
4935 end Flag_Non_Static_Expr
;
4941 procedure Fold
(N
: Node_Id
) is
4942 Typ
: constant Entity_Id
:= Etype
(N
);
4944 -- If not known at compile time or if already a literal, nothing to do
4946 if Nkind
(N
) in N_Numeric_Or_String_Literal
4947 or else not Compile_Time_Known_Value
(N
)
4951 elsif Is_Discrete_Type
(Typ
) then
4952 Fold_Uint
(N
, Expr_Value
(N
), Static
=> Is_Static_Expression
(N
));
4954 elsif Is_Real_Type
(Typ
) then
4955 Fold_Ureal
(N
, Expr_Value_R
(N
), Static
=> Is_Static_Expression
(N
));
4957 elsif Is_String_Type
(Typ
) then
4959 (N
, Strval
(Expr_Value_S
(N
)), Static
=> Is_Static_Expression
(N
));
4967 procedure Fold_Dummy
(N
: Node_Id
; Typ
: Entity_Id
) is
4969 if Is_Integer_Type
(Typ
) then
4970 Fold_Uint
(N
, Uint_1
, Static
=> True);
4972 elsif Is_Real_Type
(Typ
) then
4973 Fold_Ureal
(N
, Ureal_1
, Static
=> True);
4975 elsif Is_Enumeration_Type
(Typ
) then
4978 Expr_Value
(Type_Low_Bound
(Base_Type
(Typ
))),
4981 elsif Is_String_Type
(Typ
) then
4984 Strval
(Make_String_Literal
(Sloc
(N
), "")),
4993 procedure Fold_Shift
4998 Static
: Boolean := False;
4999 Check_Elab
: Boolean := False)
5001 Typ
: constant Entity_Id
:= Base_Type
(Etype
(Left
));
5003 procedure Check_Elab_Call
;
5004 -- Add checks related to calls in elaboration code
5006 ---------------------
5007 -- Check_Elab_Call --
5008 ---------------------
5010 procedure Check_Elab_Call
is
5013 if Legacy_Elaboration_Checks
then
5014 Check_Elab_Call
(N
);
5017 Build_Call_Marker
(N
);
5019 end Check_Elab_Call
;
5021 Modulus
, Val
: Uint
;
5024 if Compile_Time_Known_Value
(Left
)
5025 and then Compile_Time_Known_Value
(Right
)
5027 pragma Assert
(not Non_Binary_Modulus
(Typ
));
5029 if Op
= N_Op_Shift_Left
then
5032 if Is_Modular_Integer_Type
(Typ
) then
5033 Modulus
:= Einfo
.Entities
.Modulus
(Typ
);
5035 Modulus
:= Uint_2
** RM_Size
(Typ
);
5038 -- Fold Shift_Left (X, Y) by computing
5039 -- (X * 2**Y) rem modulus [- Modulus]
5041 Val
:= (Expr_Value
(Left
) * (Uint_2
** Expr_Value
(Right
)))
5044 if Is_Modular_Integer_Type
(Typ
)
5045 or else Val
< Modulus
/ Uint_2
5047 Fold_Uint
(N
, Val
, Static
=> Static
);
5049 Fold_Uint
(N
, Val
- Modulus
, Static
=> Static
);
5052 elsif Op
= N_Op_Shift_Right
then
5055 -- X >> 0 is a no-op
5057 if Expr_Value
(Right
) = Uint_0
then
5058 Fold_Uint
(N
, Expr_Value
(Left
), Static
=> Static
);
5060 if Is_Modular_Integer_Type
(Typ
) then
5061 Modulus
:= Einfo
.Entities
.Modulus
(Typ
);
5063 Modulus
:= Uint_2
** RM_Size
(Typ
);
5066 -- Fold X >> Y by computing (X [+ Modulus]) / 2**Y
5067 -- Note that after a Shift_Right operation (with Y > 0), the
5068 -- result is always positive, even if the original operand was
5074 if Expr_Value
(Left
) >= Uint_0
then
5082 (Expr_Value
(Left
) + M
) / (Uint_2
** Expr_Value
(Right
)),
5086 elsif Op
= N_Op_Shift_Right_Arithmetic
then
5090 Two_Y
: constant Uint
:= Uint_2
** Expr_Value
(Right
);
5092 if Is_Modular_Integer_Type
(Typ
) then
5093 Modulus
:= Einfo
.Entities
.Modulus
(Typ
);
5095 Modulus
:= Uint_2
** RM_Size
(Typ
);
5098 -- X / 2**Y if X if positive or a small enough modular integer
5100 if (Is_Modular_Integer_Type
(Typ
)
5101 and then Expr_Value
(Left
) < Modulus
/ Uint_2
)
5103 (not Is_Modular_Integer_Type
(Typ
)
5104 and then Expr_Value
(Left
) >= 0)
5106 Fold_Uint
(N
, Expr_Value
(Left
) / Two_Y
, Static
=> Static
);
5108 -- -1 (aka all 1's) if Y is larger than the number of bits
5109 -- available or if X = -1.
5111 elsif Two_Y
> Modulus
5112 or else Expr_Value
(Left
) = Uint_Minus_1
5114 if Is_Modular_Integer_Type
(Typ
) then
5115 Fold_Uint
(N
, Modulus
- Uint_1
, Static
=> Static
);
5117 Fold_Uint
(N
, Uint_Minus_1
, Static
=> Static
);
5120 -- Large modular integer, compute via multiply/divide the
5121 -- following: X >> Y + (1 << Y - 1) << (RM_Size - Y)
5123 elsif Is_Modular_Integer_Type
(Typ
) then
5126 (Expr_Value
(Left
)) / Two_Y
5128 * Uint_2
** (RM_Size
(Typ
) - Expr_Value
(Right
)),
5131 -- Negative signed integer, compute via multiple/divide the
5133 -- (Modulus + X) >> Y + (1 << Y - 1) << (RM_Size - Y) - Modulus
5138 (Modulus
+ Expr_Value
(Left
)) / Two_Y
5140 * Uint_2
** (RM_Size
(Typ
) - Expr_Value
(Right
))
5153 procedure Fold_Str
(N
: Node_Id
; Val
: String_Id
; Static
: Boolean) is
5154 Loc
: constant Source_Ptr
:= Sloc
(N
);
5155 Typ
: constant Entity_Id
:= Etype
(N
);
5158 if Raises_Constraint_Error
(N
) then
5159 Set_Is_Static_Expression
(N
, Static
);
5163 Rewrite
(N
, Make_String_Literal
(Loc
, Strval
=> Val
));
5165 -- We now have the literal with the right value, both the actual type
5166 -- and the expected type of this literal are taken from the expression
5167 -- that was evaluated. So now we do the Analyze and Resolve.
5169 -- Note that we have to reset Is_Static_Expression both after the
5170 -- analyze step (because Resolve will evaluate the literal, which
5171 -- will cause semantic errors if it is marked as static), and after
5172 -- the Resolve step (since Resolve in some cases resets this flag).
5175 Set_Is_Static_Expression
(N
, Static
);
5178 Set_Is_Static_Expression
(N
, Static
);
5185 procedure Fold_Uint
(N
: Node_Id
; Val
: Uint
; Static
: Boolean) is
5186 Loc
: constant Source_Ptr
:= Sloc
(N
);
5187 Typ
: Entity_Id
:= Etype
(N
);
5191 if Raises_Constraint_Error
(N
) then
5192 Set_Is_Static_Expression
(N
, Static
);
5196 -- If we are folding a named number, retain the entity in the literal
5197 -- in the original tree.
5199 if Is_Entity_Name
(N
) and then Ekind
(Entity
(N
)) = E_Named_Integer
then
5205 if Is_Private_Type
(Typ
) then
5206 Typ
:= Full_View
(Typ
);
5209 -- For a result of type integer, substitute an N_Integer_Literal node
5210 -- for the result of the compile time evaluation of the expression.
5211 -- Set a link to the original named number when not in a generic context
5212 -- for reference in the original tree.
5214 if Is_Integer_Type
(Typ
) then
5215 Rewrite
(N
, Make_Integer_Literal
(Loc
, Val
));
5216 Set_Original_Entity
(N
, Ent
);
5218 -- Otherwise we have an enumeration type, and we substitute either
5219 -- an N_Identifier or N_Character_Literal to represent the enumeration
5220 -- literal corresponding to the given value, which must always be in
5221 -- range, because appropriate tests have already been made for this.
5223 else pragma Assert
(Is_Enumeration_Type
(Typ
));
5224 Rewrite
(N
, Get_Enum_Lit_From_Pos
(Etype
(N
), Val
, Loc
));
5227 -- We now have the literal with the right value, both the actual type
5228 -- and the expected type of this literal are taken from the expression
5229 -- that was evaluated. So now we do the Analyze and Resolve.
5231 -- Note that we have to reset Is_Static_Expression both after the
5232 -- analyze step (because Resolve will evaluate the literal, which
5233 -- will cause semantic errors if it is marked as static), and after
5234 -- the Resolve step (since Resolve in some cases sets this flag).
5237 Set_Is_Static_Expression
(N
, Static
);
5240 Set_Is_Static_Expression
(N
, Static
);
5247 procedure Fold_Ureal
(N
: Node_Id
; Val
: Ureal
; Static
: Boolean) is
5248 Loc
: constant Source_Ptr
:= Sloc
(N
);
5249 Typ
: constant Entity_Id
:= Etype
(N
);
5253 if Raises_Constraint_Error
(N
) then
5254 Set_Is_Static_Expression
(N
, Static
);
5258 -- If we are folding a named number, retain the entity in the literal
5259 -- in the original tree.
5261 if Is_Entity_Name
(N
) and then Ekind
(Entity
(N
)) = E_Named_Real
then
5267 Rewrite
(N
, Make_Real_Literal
(Loc
, Realval
=> Val
));
5269 -- Set link to original named number
5271 Set_Original_Entity
(N
, Ent
);
5273 -- We now have the literal with the right value, both the actual type
5274 -- and the expected type of this literal are taken from the expression
5275 -- that was evaluated. So now we do the Analyze and Resolve.
5277 -- Note that we have to reset Is_Static_Expression both after the
5278 -- analyze step (because Resolve will evaluate the literal, which
5279 -- will cause semantic errors if it is marked as static), and after
5280 -- the Resolve step (since Resolve in some cases sets this flag).
5282 -- We mark the node as analyzed so that its type is not erased by
5283 -- calling Analyze_Real_Literal.
5286 Set_Is_Static_Expression
(N
, Static
);
5290 Set_Is_Static_Expression
(N
, Static
);
5297 function From_Bits
(B
: Bits
; T
: Entity_Id
) return Uint
is
5301 for J
in 0 .. B
'Last loop
5307 if Non_Binary_Modulus
(T
) then
5308 V
:= V
mod Modulus
(T
);
5314 --------------------
5315 -- Get_String_Val --
5316 --------------------
5318 function Get_String_Val
(N
: Node_Id
) return Node_Id
is
5320 if Nkind
(N
) in N_String_Literal | N_Character_Literal
then
5323 pragma Assert
(Is_Entity_Name
(N
));
5324 return Get_String_Val
(Constant_Value
(Entity
(N
)));
5332 procedure Initialize
is
5334 CV_Cache
:= (others => (Node_High_Bound
, Uint_0
));
5337 --------------------
5338 -- In_Subrange_Of --
5339 --------------------
5341 function In_Subrange_Of
5344 Fixed_Int
: Boolean := False) return Boolean
5353 if T1
= T2
or else Is_Subtype_Of
(T1
, T2
) then
5356 -- Never in range if both types are not scalar. Don't know if this can
5357 -- actually happen, but just in case.
5359 elsif not Is_Scalar_Type
(T1
) or else not Is_Scalar_Type
(T2
) then
5362 -- If T1 has infinities but T2 doesn't have infinities, then T1 is
5363 -- definitely not compatible with T2.
5365 elsif Is_Floating_Point_Type
(T1
)
5366 and then Has_Infinities
(T1
)
5367 and then Is_Floating_Point_Type
(T2
)
5368 and then not Has_Infinities
(T2
)
5373 L1
:= Type_Low_Bound
(T1
);
5374 H1
:= Type_High_Bound
(T1
);
5376 L2
:= Type_Low_Bound
(T2
);
5377 H2
:= Type_High_Bound
(T2
);
5379 -- Check bounds to see if comparison possible at compile time
5381 if Compile_Time_Compare
(L1
, L2
, Assume_Valid
=> True) in Compare_GE
5383 Compile_Time_Compare
(H1
, H2
, Assume_Valid
=> True) in Compare_LE
5388 -- If bounds not comparable at compile time, then the bounds of T2
5389 -- must be compile-time-known or we cannot answer the query.
5391 if not Compile_Time_Known_Value
(L2
)
5392 or else not Compile_Time_Known_Value
(H2
)
5397 -- If the bounds of T1 are know at compile time then use these
5398 -- ones, otherwise use the bounds of the base type (which are of
5399 -- course always static).
5401 if not Compile_Time_Known_Value
(L1
) then
5402 L1
:= Type_Low_Bound
(Base_Type
(T1
));
5405 if not Compile_Time_Known_Value
(H1
) then
5406 H1
:= Type_High_Bound
(Base_Type
(T1
));
5409 -- Fixed point types should be considered as such only if
5410 -- flag Fixed_Int is set to False.
5412 if Is_Floating_Point_Type
(T1
) or else Is_Floating_Point_Type
(T2
)
5413 or else (Is_Fixed_Point_Type
(T1
) and then not Fixed_Int
)
5414 or else (Is_Fixed_Point_Type
(T2
) and then not Fixed_Int
)
5417 Expr_Value_R
(L2
) <= Expr_Value_R
(L1
)
5419 Expr_Value_R
(H2
) >= Expr_Value_R
(H1
);
5423 Expr_Value
(L2
) <= Expr_Value
(L1
)
5425 Expr_Value
(H2
) >= Expr_Value
(H1
);
5430 -- If any exception occurs, it means that we have some bug in the compiler
5431 -- possibly triggered by a previous error, or by some unforeseen peculiar
5432 -- occurrence. However, this is only an optimization attempt, so there is
5433 -- really no point in crashing the compiler. Instead we just decide, too
5434 -- bad, we can't figure out the answer in this case after all.
5438 -- With debug flag K we will get an exception unless an error has
5439 -- already occurred (useful for debugging).
5441 if Debug_Flag_K
then
5442 Check_Error_Detected
;
5452 function Is_In_Range
5455 Assume_Valid
: Boolean := False;
5456 Fixed_Int
: Boolean := False;
5457 Int_Real
: Boolean := False) return Boolean
5461 Test_In_Range
(N
, Typ
, Assume_Valid
, Fixed_Int
, Int_Real
) = In_Range
;
5468 function Is_Null_Range
(Lo
: Node_Id
; Hi
: Node_Id
) return Boolean is
5470 if Compile_Time_Known_Value
(Lo
)
5471 and then Compile_Time_Known_Value
(Hi
)
5474 Typ
: Entity_Id
:= Etype
(Lo
);
5476 -- When called from the frontend, as part of the analysis of
5477 -- potentially static expressions, Typ will be the full view of a
5478 -- type with all the info needed to answer this query. When called
5479 -- from the backend, for example to know whether a range of a loop
5480 -- is null, Typ might be a private type and we need to explicitly
5481 -- switch to its corresponding full view to access the same info.
5483 if Is_Incomplete_Or_Private_Type
(Typ
)
5484 and then Present
(Full_View
(Typ
))
5486 Typ
:= Full_View
(Typ
);
5489 if Is_Discrete_Type
(Typ
) then
5490 return Expr_Value
(Lo
) > Expr_Value
(Hi
);
5491 else pragma Assert
(Is_Real_Type
(Typ
));
5492 return Expr_Value_R
(Lo
) > Expr_Value_R
(Hi
);
5500 -------------------------
5501 -- Is_OK_Static_Choice --
5502 -------------------------
5504 function Is_OK_Static_Choice
(Choice
: Node_Id
) return Boolean is
5506 -- Check various possibilities for choice
5508 -- Note: for membership tests, we test more cases than are possible
5509 -- (in particular subtype indication), but it doesn't matter because
5510 -- it just won't occur (we have already done a syntax check).
5512 if Nkind
(Choice
) = N_Others_Choice
then
5515 elsif Nkind
(Choice
) = N_Range
then
5516 return Is_OK_Static_Range
(Choice
);
5518 elsif Nkind
(Choice
) = N_Subtype_Indication
5519 or else (Is_Entity_Name
(Choice
) and then Is_Type
(Entity
(Choice
)))
5521 return Is_OK_Static_Subtype
(Etype
(Choice
));
5524 return Is_OK_Static_Expression
(Choice
);
5526 end Is_OK_Static_Choice
;
5528 ------------------------------
5529 -- Is_OK_Static_Choice_List --
5530 ------------------------------
5532 function Is_OK_Static_Choice_List
(Choices
: List_Id
) return Boolean is
5536 if not Is_Static_Choice_List
(Choices
) then
5540 Choice
:= First
(Choices
);
5541 while Present
(Choice
) loop
5542 if not Is_OK_Static_Choice
(Choice
) then
5543 Set_Raises_Constraint_Error
(Choice
);
5551 end Is_OK_Static_Choice_List
;
5553 -----------------------------
5554 -- Is_OK_Static_Expression --
5555 -----------------------------
5557 function Is_OK_Static_Expression
(N
: Node_Id
) return Boolean is
5559 return Is_Static_Expression
(N
) and then not Raises_Constraint_Error
(N
);
5560 end Is_OK_Static_Expression
;
5562 ------------------------
5563 -- Is_OK_Static_Range --
5564 ------------------------
5566 -- A static range is a range whose bounds are static expressions, or a
5567 -- Range_Attribute_Reference equivalent to such a range (RM 4.9(26)).
5568 -- We have already converted range attribute references, so we get the
5569 -- "or" part of this rule without needing a special test.
5571 function Is_OK_Static_Range
(N
: Node_Id
) return Boolean is
5573 return Is_OK_Static_Expression
(Low_Bound
(N
))
5574 and then Is_OK_Static_Expression
(High_Bound
(N
));
5575 end Is_OK_Static_Range
;
5577 --------------------------
5578 -- Is_OK_Static_Subtype --
5579 --------------------------
5581 -- Determines if Typ is a static subtype as defined in (RM 4.9(26)) where
5582 -- neither bound raises Constraint_Error when evaluated.
5584 function Is_OK_Static_Subtype
(Typ
: Entity_Id
) return Boolean is
5585 Base_T
: constant Entity_Id
:= Base_Type
(Typ
);
5586 Anc_Subt
: Entity_Id
;
5589 -- First a quick check on the non static subtype flag. As described
5590 -- in further detail in Einfo, this flag is not decisive in all cases,
5591 -- but if it is set, then the subtype is definitely non-static.
5593 if Is_Non_Static_Subtype
(Typ
) then
5597 -- Then, check if the subtype is strictly static. This takes care of
5598 -- checking for generics and predicates.
5600 if not Is_Static_Subtype
(Typ
) then
5606 if Is_String_Type
(Typ
) then
5608 Ekind
(Typ
) = E_String_Literal_Subtype
5610 (Is_OK_Static_Subtype
(Component_Type
(Typ
))
5611 and then Is_OK_Static_Subtype
(Etype
(First_Index
(Typ
))));
5615 elsif Is_Scalar_Type
(Typ
) then
5616 if Base_T
= Typ
then
5620 Anc_Subt
:= Ancestor_Subtype
(Typ
);
5622 if No
(Anc_Subt
) then
5626 -- Scalar_Range (Typ) might be an N_Subtype_Indication, so use
5627 -- Get_Type_{Low,High}_Bound.
5629 return Is_OK_Static_Subtype
(Anc_Subt
)
5630 and then Is_OK_Static_Expression
(Type_Low_Bound
(Typ
))
5631 and then Is_OK_Static_Expression
(Type_High_Bound
(Typ
));
5634 -- Types other than string and scalar types are never static
5639 end Is_OK_Static_Subtype
;
5641 ---------------------
5642 -- Is_Out_Of_Range --
5643 ---------------------
5645 function Is_Out_Of_Range
5648 Assume_Valid
: Boolean := False;
5649 Fixed_Int
: Boolean := False;
5650 Int_Real
: Boolean := False) return Boolean
5653 return Test_In_Range
(N
, Typ
, Assume_Valid
, Fixed_Int
, Int_Real
) =
5655 end Is_Out_Of_Range
;
5657 ----------------------
5658 -- Is_Static_Choice --
5659 ----------------------
5661 function Is_Static_Choice
(Choice
: Node_Id
) return Boolean is
5663 -- Check various possibilities for choice
5665 -- Note: for membership tests, we test more cases than are possible
5666 -- (in particular subtype indication), but it doesn't matter because
5667 -- it just won't occur (we have already done a syntax check).
5669 if Nkind
(Choice
) = N_Others_Choice
then
5672 elsif Nkind
(Choice
) = N_Range
then
5673 return Is_Static_Range
(Choice
);
5675 elsif Nkind
(Choice
) = N_Subtype_Indication
5676 or else (Is_Entity_Name
(Choice
) and then Is_Type
(Entity
(Choice
)))
5678 return Is_Static_Subtype
(Etype
(Choice
));
5681 return Is_Static_Expression
(Choice
);
5683 end Is_Static_Choice
;
5685 ---------------------------
5686 -- Is_Static_Choice_List --
5687 ---------------------------
5689 function Is_Static_Choice_List
(Choices
: List_Id
) return Boolean is
5693 Choice
:= First
(Choices
);
5694 while Present
(Choice
) loop
5695 if not Is_Static_Choice
(Choice
) then
5703 end Is_Static_Choice_List
;
5705 ---------------------
5706 -- Is_Static_Range --
5707 ---------------------
5709 -- A static range is a range whose bounds are static expressions, or a
5710 -- Range_Attribute_Reference equivalent to such a range (RM 4.9(26)).
5711 -- We have already converted range attribute references, so we get the
5712 -- "or" part of this rule without needing a special test.
5714 function Is_Static_Range
(N
: Node_Id
) return Boolean is
5716 return Is_Static_Expression
(Low_Bound
(N
))
5718 Is_Static_Expression
(High_Bound
(N
));
5719 end Is_Static_Range
;
5721 -----------------------
5722 -- Is_Static_Subtype --
5723 -----------------------
5725 -- Determines if Typ is a static subtype as defined in (RM 4.9(26))
5727 function Is_Static_Subtype
(Typ
: Entity_Id
) return Boolean is
5728 Base_T
: constant Entity_Id
:= Base_Type
(Typ
);
5729 Anc_Subt
: Entity_Id
;
5732 -- First a quick check on the non static subtype flag. As described
5733 -- in further detail in Einfo, this flag is not decisive in all cases,
5734 -- but if it is set, then the subtype is definitely non-static.
5736 if Is_Non_Static_Subtype
(Typ
) then
5740 Anc_Subt
:= Ancestor_Subtype
(Typ
);
5742 if Anc_Subt
= Empty
then
5746 if Is_Generic_Type
(Root_Type
(Base_T
))
5747 or else Is_Generic_Actual_Type
(Base_T
)
5751 -- If there is a dynamic predicate for the type (declared or inherited)
5752 -- the expression is not static.
5754 elsif Has_Dynamic_Predicate_Aspect
(Typ
)
5755 or else (Is_Derived_Type
(Typ
)
5756 and then Has_Aspect
(Typ
, Aspect_Dynamic_Predicate
))
5757 or else (Has_Aspect
(Typ
, Aspect_Predicate
)
5758 and then not Has_Static_Predicate
(Typ
))
5764 elsif Is_String_Type
(Typ
) then
5766 Ekind
(Typ
) = E_String_Literal_Subtype
5767 or else (Is_Static_Subtype
(Component_Type
(Typ
))
5768 and then Is_Static_Subtype
(Etype
(First_Index
(Typ
))));
5772 elsif Is_Scalar_Type
(Typ
) then
5773 if Base_T
= Typ
then
5777 return Is_Static_Subtype
(Anc_Subt
)
5778 and then Is_Static_Expression
(Type_Low_Bound
(Typ
))
5779 and then Is_Static_Expression
(Type_High_Bound
(Typ
));
5782 -- Types other than string and scalar types are never static
5787 end Is_Static_Subtype
;
5789 -------------------------------
5790 -- Is_Statically_Unevaluated --
5791 -------------------------------
5793 function Is_Statically_Unevaluated
(Expr
: Node_Id
) return Boolean is
5794 function Check_Case_Expr_Alternative
5795 (CEA
: Node_Id
) return Match_Result
;
5796 -- We have a message emanating from the Expression of a case expression
5797 -- alternative. We examine this alternative, as follows:
5799 -- If the selecting expression of the parent case is non-static, or
5800 -- if any of the discrete choices of the given case alternative are
5801 -- non-static or raise Constraint_Error, return Non_Static.
5803 -- Otherwise check if the selecting expression matches any of the given
5804 -- discrete choices. If so, the alternative is executed and we return
5805 -- Match, otherwise, the alternative can never be executed, and so we
5808 ---------------------------------
5809 -- Check_Case_Expr_Alternative --
5810 ---------------------------------
5812 function Check_Case_Expr_Alternative
5813 (CEA
: Node_Id
) return Match_Result
5815 Case_Exp
: constant Node_Id
:= Parent
(CEA
);
5820 pragma Assert
(Nkind
(Case_Exp
) = N_Case_Expression
);
5822 -- Check that selecting expression is static
5824 if not Is_OK_Static_Expression
(Expression
(Case_Exp
)) then
5828 if not Is_OK_Static_Choice_List
(Discrete_Choices
(CEA
)) then
5832 -- All choices are now known to be static. Now see if alternative
5833 -- matches one of the choices.
5835 Choice
:= First
(Discrete_Choices
(CEA
));
5836 while Present
(Choice
) loop
5838 -- Check various possibilities for choice, returning Match if we
5839 -- find the selecting value matches any of the choices. Note that
5840 -- we know we are the last choice, so we don't have to keep going.
5842 if Nkind
(Choice
) = N_Others_Choice
then
5844 -- Others choice is a bit annoying, it matches if none of the
5845 -- previous alternatives matches (note that we know we are the
5846 -- last alternative in this case, so we can just go backwards
5847 -- from us to see if any previous one matches).
5849 Prev_CEA
:= Prev
(CEA
);
5850 while Present
(Prev_CEA
) loop
5851 if Check_Case_Expr_Alternative
(Prev_CEA
) = Match
then
5860 -- Else we have a normal static choice
5862 elsif Choice_Matches
(Expression
(Case_Exp
), Choice
) = Match
then
5866 -- If we fall through, it means that the discrete choice did not
5867 -- match the selecting expression, so continue.
5872 -- If we get through that loop then all choices were static, and none
5873 -- of them matched the selecting expression. So return No_Match.
5876 end Check_Case_Expr_Alternative
;
5884 -- Start of processing for Is_Statically_Unevaluated
5887 -- The (32.x) references here are from RM section 4.9
5889 -- (32.1) An expression is statically unevaluated if it is part of ...
5891 -- This means we have to climb the tree looking for one of the cases
5898 -- (32.2) The right operand of a static short-circuit control form
5899 -- whose value is determined by its left operand.
5901 -- AND THEN with False as left operand
5903 if Nkind
(P
) = N_And_Then
5904 and then Compile_Time_Known_Value
(Left_Opnd
(P
))
5905 and then Is_False
(Expr_Value
(Left_Opnd
(P
)))
5909 -- OR ELSE with True as left operand
5911 elsif Nkind
(P
) = N_Or_Else
5912 and then Compile_Time_Known_Value
(Left_Opnd
(P
))
5913 and then Is_True
(Expr_Value
(Left_Opnd
(P
)))
5917 -- (32.3) A dependent_expression of an if_expression whose associated
5918 -- condition is static and equals False.
5920 elsif Nkind
(P
) = N_If_Expression
then
5922 Cond
: constant Node_Id
:= First
(Expressions
(P
));
5923 Texp
: constant Node_Id
:= Next
(Cond
);
5924 Fexp
: constant Node_Id
:= Next
(Texp
);
5927 if Compile_Time_Known_Value
(Cond
) then
5929 -- Condition is True and we are in the right operand
5931 if Is_True
(Expr_Value
(Cond
)) and then OldP
= Fexp
then
5934 -- Condition is False and we are in the left operand
5936 elsif Is_False
(Expr_Value
(Cond
)) and then OldP
= Texp
then
5942 -- (32.4) A condition or dependent_expression of an if_expression
5943 -- where the condition corresponding to at least one preceding
5944 -- dependent_expression of the if_expression is static and equals
5947 -- This refers to cases like
5949 -- (if True then 1 elsif 1/0=2 then 2 else 3)
5951 -- But we expand elsif's out anyway, so the above looks like:
5953 -- (if True then 1 else (if 1/0=2 then 2 else 3))
5955 -- So for us this is caught by the above check for the 32.3 case.
5957 -- (32.5) A dependent_expression of a case_expression whose
5958 -- selecting_expression is static and whose value is not covered
5959 -- by the corresponding discrete_choice_list.
5961 elsif Nkind
(P
) = N_Case_Expression_Alternative
then
5963 -- First, we have to be in the expression to suppress messages.
5964 -- If we are within one of the choices, we want the message.
5966 if OldP
= Expression
(P
) then
5968 -- Statically unevaluated if alternative does not match
5970 if Check_Case_Expr_Alternative
(P
) = No_Match
then
5975 -- (32.6) A choice_expression (or a simple_expression of a range
5976 -- that occurs as a membership_choice of a membership_choice_list)
5977 -- of a static membership test that is preceded in the enclosing
5978 -- membership_choice_list by another item whose individual
5979 -- membership test (see (RM 4.5.2)) statically yields True.
5981 elsif Nkind
(P
) in N_Membership_Test
then
5983 -- Only possibly unevaluated if simple expression is static
5985 if not Is_OK_Static_Expression
(Left_Opnd
(P
)) then
5988 -- All members of the choice list must be static
5990 elsif (Present
(Right_Opnd
(P
))
5991 and then not Is_OK_Static_Choice
(Right_Opnd
(P
)))
5992 or else (Present
(Alternatives
(P
))
5994 not Is_OK_Static_Choice_List
(Alternatives
(P
)))
5998 -- If expression is the one and only alternative, then it is
5999 -- definitely not statically unevaluated, so we only have to
6000 -- test the case where there are alternatives present.
6002 elsif Present
(Alternatives
(P
)) then
6004 -- Look for previous matching Choice
6006 Choice
:= First
(Alternatives
(P
));
6007 while Present
(Choice
) loop
6009 -- If we reached us and no previous choices matched, this
6010 -- is not the case where we are statically unevaluated.
6012 exit when OldP
= Choice
;
6014 -- If a previous choice matches, then that is the case where
6015 -- we know our choice is statically unevaluated.
6017 if Choice_Matches
(Left_Opnd
(P
), Choice
) = Match
then
6024 -- If we fall through the loop, we were not one of the choices,
6025 -- we must have been the expression, so that is not covered by
6026 -- this rule, and we keep going.
6032 -- OK, not statically unevaluated at this level, see if we should
6033 -- keep climbing to look for a higher level reason.
6035 -- Special case for component association in aggregates, where
6036 -- we want to keep climbing up to the parent aggregate.
6038 if Nkind
(P
) = N_Component_Association
6039 and then Nkind
(Parent
(P
)) = N_Aggregate
6043 -- All done if not still within subexpression
6046 exit when Nkind
(P
) not in N_Subexpr
;
6050 -- If we fall through the loop, not one of the cases covered!
6053 end Is_Statically_Unevaluated
;
6055 --------------------
6056 -- Machine_Number --
6057 --------------------
6059 -- Historical note: RM 4.9(38) originally specified biased rounding but
6060 -- this has been modified by AI-268 to prevent confusing differences in
6061 -- rounding between static and nonstatic expressions. This AI specifies
6062 -- that the effect of such rounding is implementation-dependent instead,
6063 -- and in GNAT we round to nearest even to match the run-time behavior.
6064 -- Note that this applies to floating-point literals, not fixed-point
6065 -- ones, even though their representation is also a universal real.
6067 function Machine_Number
6070 N
: Node_Id
) return Ureal
6073 return Machine
(Typ
, Val
, Round_Even
, N
);
6076 --------------------
6077 -- Not_Null_Range --
6078 --------------------
6080 function Not_Null_Range
(Lo
: Node_Id
; Hi
: Node_Id
) return Boolean is
6082 if Compile_Time_Known_Value
(Lo
)
6083 and then Compile_Time_Known_Value
(Hi
)
6086 Typ
: Entity_Id
:= Etype
(Lo
);
6088 -- When called from the frontend, as part of the analysis of
6089 -- potentially static expressions, Typ will be the full view of a
6090 -- type with all the info needed to answer this query. When called
6091 -- from the backend, for example to know whether a range of a loop
6092 -- is null, Typ might be a private type and we need to explicitly
6093 -- switch to its corresponding full view to access the same info.
6095 if Is_Incomplete_Or_Private_Type
(Typ
)
6096 and then Present
(Full_View
(Typ
))
6098 Typ
:= Full_View
(Typ
);
6101 if Is_Discrete_Type
(Typ
) then
6102 return Expr_Value
(Lo
) <= Expr_Value
(Hi
);
6103 else pragma Assert
(Is_Real_Type
(Typ
));
6104 return Expr_Value_R
(Lo
) <= Expr_Value_R
(Hi
);
6117 function OK_Bits
(N
: Node_Id
; Bits
: Uint
) return Boolean is
6119 -- We allow a maximum of 500,000 bits which seems a reasonable limit
6121 if Bits
< 500_000
then
6124 -- Error if this maximum is exceeded
6127 Error_Msg_N
("static value too large, capacity exceeded", N
);
6136 procedure Out_Of_Range
(N
: Node_Id
) is
6138 -- If we have the static expression case, then this is an illegality
6139 -- in Ada 95 mode, except that in an instance, we never generate an
6140 -- error (if the error is legitimate, it was already diagnosed in the
6143 if Is_Static_Expression
(N
)
6144 and then not In_Instance
6145 and then not In_Inlined_Body
6146 and then Ada_Version
>= Ada_95
6148 -- No message if we are statically unevaluated
6150 if Is_Statically_Unevaluated
(N
) then
6153 -- The expression to compute the length of a packed array is attached
6154 -- to the array type itself, and deserves a separate message.
6156 elsif Nkind
(Parent
(N
)) = N_Defining_Identifier
6157 and then Is_Array_Type
(Parent
(N
))
6158 and then Present
(Packed_Array_Impl_Type
(Parent
(N
)))
6159 and then Present
(First_Rep_Item
(Parent
(N
)))
6162 ("length of packed array must not exceed Integer''Last",
6163 First_Rep_Item
(Parent
(N
)));
6164 Rewrite
(N
, Make_Integer_Literal
(Sloc
(N
), Uint_1
));
6166 -- All cases except the special array case.
6167 -- No message if we are dealing with System.Priority values in
6168 -- CodePeer mode where the target runtime may have more priorities.
6170 elsif not CodePeer_Mode
6171 or else not Is_RTE
(Etype
(N
), RE_Priority
)
6173 -- Determine if the out-of-range violation constitutes a warning
6174 -- or an error based on context, according to RM 4.9 (34/3).
6176 if Nkind
(Original_Node
(N
)) = N_Type_Conversion
6177 and then not Comes_From_Source
(Original_Node
(N
))
6179 Apply_Compile_Time_Constraint_Error
6180 (N
, "value not in range of}??", CE_Range_Check_Failed
);
6182 Apply_Compile_Time_Constraint_Error
6183 (N
, "value not in range of}", CE_Range_Check_Failed
);
6187 -- Here we generate a warning for the Ada 83 case, or when we are in an
6188 -- instance, or when we have a non-static expression case.
6191 Apply_Compile_Time_Constraint_Error
6192 (N
, "value not in range of}??", CE_Range_Check_Failed
);
6196 ---------------------------
6197 -- Predicates_Compatible --
6198 ---------------------------
6200 function Predicates_Compatible
(T1
, T2
: Entity_Id
) return Boolean is
6202 function T2_Rep_Item_Applies_To_T1
(Nam
: Name_Id
) return Boolean;
6203 -- Return True if the rep item for Nam is either absent on T2 or also
6206 -------------------------------
6207 -- T2_Rep_Item_Applies_To_T1 --
6208 -------------------------------
6210 function T2_Rep_Item_Applies_To_T1
(Nam
: Name_Id
) return Boolean is
6211 Rep_Item
: constant Node_Id
:= Get_Rep_Item
(T2
, Nam
);
6214 return No
(Rep_Item
) or else Get_Rep_Item
(T1
, Nam
) = Rep_Item
;
6215 end T2_Rep_Item_Applies_To_T1
;
6217 -- Start of processing for Predicates_Compatible
6220 if Ada_Version
< Ada_2012
then
6223 -- If T2 has no predicates, there is no compatibility issue
6225 elsif not Has_Predicates
(T2
) then
6228 -- T2 has predicates, if T1 has none then we defer to the static check
6230 elsif not Has_Predicates
(T1
) then
6233 -- Both T2 and T1 have predicates, check that all predicates that apply
6234 -- to T2 apply also to T1 (RM 4.9.1(9/3)).
6236 elsif T2_Rep_Item_Applies_To_T1
(Name_Static_Predicate
)
6237 and then T2_Rep_Item_Applies_To_T1
(Name_Dynamic_Predicate
)
6238 and then T2_Rep_Item_Applies_To_T1
(Name_Predicate
)
6243 -- Implement the static check prescribed by RM 4.9.1(10/3)
6245 if Is_Static_Subtype
(T1
) and then Is_Static_Subtype
(T2
) then
6246 -- We just need to query Interval_Lists for discrete types
6248 if Is_Discrete_Type
(T1
) and then Is_Discrete_Type
(T2
) then
6250 Interval_List1
: constant Interval_Lists
.Discrete_Interval_List
6251 := Interval_Lists
.Type_Intervals
(T1
);
6252 Interval_List2
: constant Interval_Lists
.Discrete_Interval_List
6253 := Interval_Lists
.Type_Intervals
(T2
);
6255 return Interval_Lists
.Is_Subset
(Interval_List1
, Interval_List2
)
6256 and then not (Has_Predicates
(T1
)
6257 and then not Predicate_Checks_Suppressed
(T2
)
6258 and then Predicate_Checks_Suppressed
(T1
));
6262 -- ??? Need to implement Interval_Lists for real types
6267 -- If either subtype is not static, the predicates are not compatible
6272 end Predicates_Compatible
;
6274 ----------------------
6275 -- Predicates_Match --
6276 ----------------------
6278 function Predicates_Match
(T1
, T2
: Entity_Id
) return Boolean is
6280 function Have_Same_Rep_Item
(Nam
: Name_Id
) return Boolean;
6281 -- Return True if T1 and T2 have the same rep item for Nam
6283 ------------------------
6284 -- Have_Same_Rep_Item --
6285 ------------------------
6287 function Have_Same_Rep_Item
(Nam
: Name_Id
) return Boolean is
6289 return Get_Rep_Item
(T1
, Nam
) = Get_Rep_Item
(T2
, Nam
);
6290 end Have_Same_Rep_Item
;
6292 -- Start of processing for Predicates_Match
6295 if Ada_Version
< Ada_2012
then
6298 -- If T2 has no predicates, match if and only if T1 has none
6300 elsif not Has_Predicates
(T2
) then
6301 return not Has_Predicates
(T1
);
6303 -- T2 has predicates, no match if T1 has none
6305 elsif not Has_Predicates
(T1
) then
6308 -- Both T2 and T1 have predicates, check that they all come
6309 -- from the same declarations.
6312 return Have_Same_Rep_Item
(Name_Static_Predicate
)
6313 and then Have_Same_Rep_Item
(Name_Dynamic_Predicate
)
6314 and then Have_Same_Rep_Item
(Name_Predicate
);
6316 end Predicates_Match
;
6318 ---------------------------------------------
6319 -- Real_Or_String_Static_Predicate_Matches --
6320 ---------------------------------------------
6322 function Real_Or_String_Static_Predicate_Matches
6324 Typ
: Entity_Id
) return Boolean
6326 Expr
: constant Node_Id
:= Static_Real_Or_String_Predicate
(Typ
);
6327 -- The predicate expression from the type
6329 Pfun
: constant Entity_Id
:= Predicate_Function
(Typ
);
6330 -- The entity for the predicate function
6332 Ent_Name
: constant Name_Id
:= Chars
(First_Formal
(Pfun
));
6333 -- The name of the formal of the predicate function. Occurrences of the
6334 -- type name in Expr have been rewritten as references to this formal,
6335 -- and it has a unique name, so we can identify references by this name.
6338 -- Copy of the predicate function tree
6340 function Process
(N
: Node_Id
) return Traverse_Result
;
6341 -- Function used to process nodes during the traversal in which we will
6342 -- find occurrences of the entity name, and replace such occurrences
6343 -- by a real literal with the value to be tested.
6345 procedure Traverse
is new Traverse_Proc
(Process
);
6346 -- The actual traversal procedure
6352 function Process
(N
: Node_Id
) return Traverse_Result
is
6354 if Nkind
(N
) = N_Identifier
and then Chars
(N
) = Ent_Name
then
6356 Nod
: constant Node_Id
:= New_Copy
(Val
);
6358 Set_Sloc
(Nod
, Sloc
(N
));
6363 -- The predicate function may contain string-comparison operations
6364 -- that have been converted into calls to run-time array-comparison
6365 -- routines. To evaluate the predicate statically, we recover the
6366 -- original comparison operation and replace the occurrence of the
6367 -- formal by the static string value. The actuals of the generated
6368 -- call are of the form X'Address.
6370 elsif Nkind
(N
) in N_Op_Compare
6371 and then Nkind
(Left_Opnd
(N
)) = N_Function_Call
6374 C
: constant Node_Id
:= Left_Opnd
(N
);
6375 F
: constant Node_Id
:= First
(Parameter_Associations
(C
));
6376 L
: constant Node_Id
:= Prefix
(F
);
6377 R
: constant Node_Id
:= Prefix
(Next
(F
));
6380 -- If an operand is an entity name, it is the formal of the
6381 -- predicate function, so replace it with the string value.
6382 -- It may be either operand in the call. The other operand
6383 -- is a static string from the original predicate.
6385 if Is_Entity_Name
(L
) then
6386 Rewrite
(Left_Opnd
(N
), New_Copy
(Val
));
6387 Rewrite
(Right_Opnd
(N
), New_Copy
(R
));
6390 Rewrite
(Left_Opnd
(N
), New_Copy
(L
));
6391 Rewrite
(Right_Opnd
(N
), New_Copy
(Val
));
6402 -- Start of processing for Real_Or_String_Static_Predicate_Matches
6405 -- First deal with special case of inherited predicate, where the
6406 -- predicate expression looks like:
6408 -- xxPredicate (typ (Ent)) and then Expr
6410 -- where Expr is the predicate expression for this level, and the
6411 -- left operand is the call to evaluate the inherited predicate.
6413 if Nkind
(Expr
) = N_And_Then
6414 and then Nkind
(Left_Opnd
(Expr
)) = N_Function_Call
6415 and then Is_Predicate_Function
(Entity
(Name
(Left_Opnd
(Expr
))))
6417 -- OK we have the inherited case, so make a call to evaluate the
6418 -- inherited predicate. If that fails, so do we!
6421 Real_Or_String_Static_Predicate_Matches
6423 Typ
=> Etype
(First_Formal
(Entity
(Name
(Left_Opnd
(Expr
))))))
6428 -- Use the right operand for the continued processing
6430 Copy
:= Copy_Separate_Tree
(Right_Opnd
(Expr
));
6432 -- Case where call to predicate function appears on its own (this means
6433 -- that the predicate at this level is just inherited from the parent).
6435 elsif Nkind
(Expr
) = N_Function_Call
then
6437 Typ
: constant Entity_Id
:=
6438 Etype
(First_Formal
(Entity
(Name
(Expr
))));
6441 -- If the inherited predicate is dynamic, just ignore it. We can't
6442 -- go trying to evaluate a dynamic predicate as a static one!
6444 if Has_Dynamic_Predicate_Aspect
(Typ
) then
6447 -- Otherwise inherited predicate is static, check for match
6450 return Real_Or_String_Static_Predicate_Matches
(Val
, Typ
);
6454 -- If not just an inherited predicate, copy whole expression
6457 Copy
:= Copy_Separate_Tree
(Expr
);
6460 -- Now we replace occurrences of the entity by the value
6464 -- And analyze the resulting static expression to see if it is True
6466 Analyze_And_Resolve
(Copy
, Standard_Boolean
);
6467 return Is_True
(Expr_Value
(Copy
));
6468 end Real_Or_String_Static_Predicate_Matches
;
6470 -------------------------
6471 -- Rewrite_In_Raise_CE --
6472 -------------------------
6474 procedure Rewrite_In_Raise_CE
(N
: Node_Id
; Exp
: Node_Id
) is
6475 Stat
: constant Boolean := Is_Static_Expression
(N
);
6476 Typ
: constant Entity_Id
:= Etype
(N
);
6479 -- If we want to raise CE in the condition of a N_Raise_CE node, we
6480 -- can just clear the condition if the reason is appropriate. We do
6481 -- not do this operation if the parent has a reason other than range
6482 -- check failed, because otherwise we would change the reason.
6484 if Present
(Parent
(N
))
6485 and then Nkind
(Parent
(N
)) = N_Raise_Constraint_Error
6486 and then Reason
(Parent
(N
)) =
6487 UI_From_Int
(RT_Exception_Code
'Pos (CE_Range_Check_Failed
))
6489 Set_Condition
(Parent
(N
), Empty
);
6491 -- Else build an explicit N_Raise_CE
6494 if Nkind
(Exp
) = N_Raise_Constraint_Error
then
6496 Make_Raise_Constraint_Error
(Sloc
(Exp
),
6497 Reason
=> Reason
(Exp
)));
6500 Make_Raise_Constraint_Error
(Sloc
(Exp
),
6501 Reason
=> CE_Range_Check_Failed
));
6504 Set_Raises_Constraint_Error
(N
);
6508 -- Set proper flags in result
6510 Set_Raises_Constraint_Error
(N
, True);
6511 Set_Is_Static_Expression
(N
, Stat
);
6512 end Rewrite_In_Raise_CE
;
6514 ------------------------------------------------
6515 -- Set_Checking_Potentially_Static_Expression --
6516 ------------------------------------------------
6518 procedure Set_Checking_Potentially_Static_Expression
(Value
: Boolean) is
6520 -- Verify that we only start/stop checking for a potentially static
6521 -- expression and do not start or stop it twice in a row.
6523 pragma Assert
(Checking_For_Potentially_Static_Expression
/= Value
);
6525 Checking_For_Potentially_Static_Expression
:= Value
;
6526 end Set_Checking_Potentially_Static_Expression
;
6528 ---------------------
6529 -- String_Type_Len --
6530 ---------------------
6532 function String_Type_Len
(Stype
: Entity_Id
) return Uint
is
6533 NT
: constant Entity_Id
:= Etype
(First_Index
(Stype
));
6537 if Is_OK_Static_Subtype
(NT
) then
6540 T
:= Base_Type
(NT
);
6543 return Expr_Value
(Type_High_Bound
(T
)) -
6544 Expr_Value
(Type_Low_Bound
(T
)) + 1;
6545 end String_Type_Len
;
6547 ------------------------------------
6548 -- Subtypes_Statically_Compatible --
6549 ------------------------------------
6551 function Subtypes_Statically_Compatible
6554 Formal_Derived_Matching
: Boolean := False) return Boolean
6557 -- A type is always statically compatible with itself
6562 -- Not compatible if predicates are not compatible
6564 elsif not Predicates_Compatible
(T1
, T2
) then
6569 elsif Is_Scalar_Type
(T1
) then
6571 -- Definitely compatible if we match
6573 if Subtypes_Statically_Match
(T1
, T2
) then
6576 -- A scalar subtype S1 is compatible with S2 if their bounds
6577 -- are static and compatible, even if S1 has dynamic predicates
6578 -- and is thus non-static. Predicate compatibility has been
6581 elsif not Is_Static_Range
(Scalar_Range
(T1
))
6582 or else not Is_Static_Range
(Scalar_Range
(T2
))
6586 -- Base types must match, but we don't check that (should we???) but
6587 -- we do at least check that both types are real, or both types are
6590 elsif Is_Real_Type
(T1
) /= Is_Real_Type
(T2
) then
6593 -- Here we check the bounds
6597 LB1
: constant Node_Id
:= Type_Low_Bound
(T1
);
6598 HB1
: constant Node_Id
:= Type_High_Bound
(T1
);
6599 LB2
: constant Node_Id
:= Type_Low_Bound
(T2
);
6600 HB2
: constant Node_Id
:= Type_High_Bound
(T2
);
6603 if Is_Real_Type
(T1
) then
6605 Expr_Value_R
(LB1
) > Expr_Value_R
(HB1
)
6607 (Expr_Value_R
(LB2
) <= Expr_Value_R
(LB1
)
6608 and then Expr_Value_R
(HB1
) <= Expr_Value_R
(HB2
));
6612 Expr_Value
(LB1
) > Expr_Value
(HB1
)
6614 (Expr_Value
(LB2
) <= Expr_Value
(LB1
)
6615 and then Expr_Value
(HB1
) <= Expr_Value
(HB2
));
6622 elsif Is_Access_Type
(T1
) then
6624 (not Is_Constrained
(T2
)
6625 or else Subtypes_Statically_Match
6626 (Designated_Type
(T1
), Designated_Type
(T2
)))
6627 and then not (Can_Never_Be_Null
(T2
)
6628 and then not Can_Never_Be_Null
(T1
));
6630 -- Private types without discriminants can be handled specially.
6631 -- Predicate matching has been checked above.
6633 elsif Is_Private_Type
(T1
)
6634 and then not Has_Discriminants
(T1
)
6636 return not Has_Discriminants
(T2
);
6642 (Is_Composite_Type
(T1
) and then not Is_Constrained
(T2
))
6643 or else Subtypes_Statically_Match
6644 (T1
, T2
, Formal_Derived_Matching
);
6646 end Subtypes_Statically_Compatible
;
6648 -------------------------------
6649 -- Subtypes_Statically_Match --
6650 -------------------------------
6652 -- Subtypes statically match if they have statically matching constraints
6653 -- (RM 4.9.1(2)). Constraints statically match if there are none, or if
6654 -- they are the same identical constraint, or if they are static and the
6655 -- values match (RM 4.9.1(1)).
6657 -- In addition, in GNAT, the object size (Esize) values of the types must
6658 -- match if they are set (unless checking an actual for a formal derived
6659 -- type). The use of 'Object_Size can cause this to be false even if the
6660 -- types would otherwise match in the Ada 95 RM sense, but this deviation
6661 -- is adopted by AI12-059 which introduces Object_Size in Ada 2022.
6663 function Subtypes_Statically_Match
6666 Formal_Derived_Matching
: Boolean := False) return Boolean
6669 -- A type always statically matches itself
6674 -- No match if sizes different (from use of 'Object_Size). This test
6675 -- is excluded if Formal_Derived_Matching is True, as the base types
6676 -- can be different in that case and typically have different sizes.
6678 elsif not Formal_Derived_Matching
6679 and then Known_Static_Esize
(T1
)
6680 and then Known_Static_Esize
(T2
)
6681 and then Esize
(T1
) /= Esize
(T2
)
6685 -- No match if predicates do not match
6687 elsif not Predicates_Match
(T1
, T2
) then
6692 elsif Is_Scalar_Type
(T1
) then
6694 -- Base types must be the same
6696 if Base_Type
(T1
) /= Base_Type
(T2
) then
6700 -- A constrained numeric subtype never matches an unconstrained
6701 -- subtype, i.e. both types must be constrained or unconstrained.
6703 -- To understand the requirement for this test, see RM 4.9.1(1).
6704 -- As is made clear in RM 3.5.4(11), type Integer, for example is
6705 -- a constrained subtype with constraint bounds matching the bounds
6706 -- of its corresponding unconstrained base type. In this situation,
6707 -- Integer and Integer'Base do not statically match, even though
6708 -- they have the same bounds.
6710 -- We only apply this test to types in Standard and types that appear
6711 -- in user programs. That way, we do not have to be too careful about
6712 -- setting Is_Constrained right for Itypes.
6714 if Is_Numeric_Type
(T1
)
6715 and then (Is_Constrained
(T1
) /= Is_Constrained
(T2
))
6716 and then (Scope
(T1
) = Standard_Standard
6717 or else Comes_From_Source
(T1
))
6718 and then (Scope
(T2
) = Standard_Standard
6719 or else Comes_From_Source
(T2
))
6723 -- A generic scalar type does not statically match its base type
6724 -- (AI-311). In this case we make sure that the formals, which are
6725 -- first subtypes of their bases, are constrained.
6727 elsif Is_Generic_Type
(T1
)
6728 and then Is_Generic_Type
(T2
)
6729 and then (Is_Constrained
(T1
) /= Is_Constrained
(T2
))
6734 -- If there was an error in either range, then just assume the types
6735 -- statically match to avoid further junk errors.
6737 if No
(Scalar_Range
(T1
)) or else No
(Scalar_Range
(T2
))
6738 or else Error_Posted
(Scalar_Range
(T1
))
6739 or else Error_Posted
(Scalar_Range
(T2
))
6744 -- Otherwise both types have bounds that can be compared
6747 LB1
: constant Node_Id
:= Type_Low_Bound
(T1
);
6748 HB1
: constant Node_Id
:= Type_High_Bound
(T1
);
6749 LB2
: constant Node_Id
:= Type_Low_Bound
(T2
);
6750 HB2
: constant Node_Id
:= Type_High_Bound
(T2
);
6753 -- If the bounds are the same tree node, then match (common case)
6755 if LB1
= LB2
and then HB1
= HB2
then
6758 -- Otherwise bounds must be static and identical value
6761 if not Is_OK_Static_Subtype
(T1
)
6763 not Is_OK_Static_Subtype
(T2
)
6767 elsif Is_Real_Type
(T1
) then
6769 Expr_Value_R
(LB1
) = Expr_Value_R
(LB2
)
6771 Expr_Value_R
(HB1
) = Expr_Value_R
(HB2
);
6775 Expr_Value
(LB1
) = Expr_Value
(LB2
)
6777 Expr_Value
(HB1
) = Expr_Value
(HB2
);
6782 -- Type with discriminants
6784 elsif Has_Discriminants
(T1
) or else Has_Discriminants
(T2
) then
6786 -- Handle derivations of private subtypes. For example S1 statically
6787 -- matches the full view of T1 in the following example:
6789 -- type T1(<>) is new Root with private;
6790 -- subtype S1 is new T1;
6791 -- overriding proc P1 (P : S1);
6793 -- type T1 (D : Disc) is new Root with ...
6795 if Ekind
(T2
) = E_Record_Subtype_With_Private
6796 and then not Has_Discriminants
(T2
)
6797 and then Partial_View_Has_Unknown_Discr
(T1
)
6798 and then Etype
(T2
) = T1
6802 elsif Ekind
(T1
) = E_Record_Subtype_With_Private
6803 and then not Has_Discriminants
(T1
)
6804 and then Partial_View_Has_Unknown_Discr
(T2
)
6805 and then Etype
(T1
) = T2
6809 -- Because of view exchanges in multiple instantiations, conformance
6810 -- checking might try to match a partial view of a type with no
6811 -- discriminants with a full view that has defaulted discriminants.
6812 -- In such a case, use the discriminant constraint of the full view,
6813 -- which must exist because we know that the two subtypes have the
6816 elsif Has_Discriminants
(T1
) /= Has_Discriminants
(T2
) then
6818 if Is_Private_Type
(T2
)
6819 and then Present
(Full_View
(T2
))
6820 and then Has_Discriminants
(Full_View
(T2
))
6822 return Subtypes_Statically_Match
(T1
, Full_View
(T2
));
6824 elsif Is_Private_Type
(T1
)
6825 and then Present
(Full_View
(T1
))
6826 and then Has_Discriminants
(Full_View
(T1
))
6828 return Subtypes_Statically_Match
(Full_View
(T1
), T2
);
6840 function Original_Discriminant_Constraint
6841 (Typ
: Entity_Id
) return Elist_Id
;
6842 -- Returns Typ's discriminant constraint, or if the constraint
6843 -- is inherited from an ancestor type, then climbs the parent
6844 -- types to locate and return the constraint farthest up the
6845 -- parent chain that Typ's constraint is ultimately inherited
6846 -- from (stopping before a parent that doesn't impose a constraint
6847 -- or a parent that has new discriminants). This ensures a proper
6848 -- result from the equality comparison of Elist_Ids below (as
6849 -- otherwise, derived types that inherit constraints may appear
6850 -- to be unequal, because each level of derivation can have its
6851 -- own copy of the constraint).
6853 function Original_Discriminant_Constraint
6854 (Typ
: Entity_Id
) return Elist_Id
6857 if not Has_Discriminants
(Typ
) then
6860 -- If Typ is not a derived type, then directly return the
6863 elsif not Is_Derived_Type
(Typ
) then
6864 return Discriminant_Constraint
(Typ
);
6866 -- If the parent type doesn't have discriminants, doesn't
6867 -- have a constraint, or has new discriminants, then stop
6868 -- and return Typ's constraint.
6870 elsif not Has_Discriminants
(Etype
(Typ
))
6872 -- No constraint on the parent type
6874 or else not Present
(Discriminant_Constraint
(Etype
(Typ
)))
6875 or else Is_Empty_Elmt_List
6876 (Discriminant_Constraint
(Etype
(Typ
)))
6878 -- The parent type defines new discriminants
6881 (Is_Base_Type
(Etype
(Typ
))
6882 and then Present
(Discriminant_Specifications
6883 (Parent
(Etype
(Typ
)))))
6885 return Discriminant_Constraint
(Typ
);
6887 -- Otherwise, make a recursive call on the parent type
6890 return Original_Discriminant_Constraint
(Etype
(Typ
));
6892 end Original_Discriminant_Constraint
;
6896 DL1
: constant Elist_Id
:= Original_Discriminant_Constraint
(T1
);
6897 DL2
: constant Elist_Id
:= Original_Discriminant_Constraint
(T2
);
6905 elsif Is_Constrained
(T1
) /= Is_Constrained
(T2
) then
6909 -- Now loop through the discriminant constraints
6911 -- Note: the guard here seems necessary, since it is possible at
6912 -- least for DL1 to be No_Elist. Not clear this is reasonable ???
6914 if Present
(DL1
) and then Present
(DL2
) then
6915 DA1
:= First_Elmt
(DL1
);
6916 DA2
:= First_Elmt
(DL2
);
6917 while Present
(DA1
) loop
6919 Expr1
: constant Node_Id
:= Node
(DA1
);
6920 Expr2
: constant Node_Id
:= Node
(DA2
);
6923 if not Is_OK_Static_Expression
(Expr1
)
6924 or else not Is_OK_Static_Expression
(Expr2
)
6928 -- If either expression raised a Constraint_Error,
6929 -- consider the expressions as matching, since this
6930 -- helps to prevent cascading errors.
6932 elsif Raises_Constraint_Error
(Expr1
)
6933 or else Raises_Constraint_Error
(Expr2
)
6937 elsif Expr_Value
(Expr1
) /= Expr_Value
(Expr2
) then
6950 -- A definite type does not match an indefinite or classwide type.
6951 -- However, a generic type with unknown discriminants may be
6952 -- instantiated with a type with no discriminants, and conformance
6953 -- checking on an inherited operation may compare the actual with the
6954 -- subtype that renames it in the instance.
6956 elsif Has_Unknown_Discriminants
(T1
) /= Has_Unknown_Discriminants
(T2
)
6959 Is_Generic_Actual_Type
(T1
) or else Is_Generic_Actual_Type
(T2
);
6963 elsif Is_Array_Type
(T1
) then
6965 -- If either subtype is unconstrained then both must be, and if both
6966 -- are unconstrained then no further checking is needed.
6968 if not Is_Constrained
(T1
) or else not Is_Constrained
(T2
) then
6969 return not (Is_Constrained
(T1
) or else Is_Constrained
(T2
));
6972 -- Both subtypes are constrained, so check that the index subtypes
6973 -- statically match.
6976 Index1
: Node_Id
:= First_Index
(T1
);
6977 Index2
: Node_Id
:= First_Index
(T2
);
6980 while Present
(Index1
) loop
6982 Subtypes_Statically_Match
(Etype
(Index1
), Etype
(Index2
))
6987 Next_Index
(Index1
);
6988 Next_Index
(Index2
);
6994 elsif Is_Access_Type
(T1
) then
6995 if Can_Never_Be_Null
(T1
) /= Can_Never_Be_Null
(T2
) then
6998 elsif Ekind
(T1
) in E_Access_Subprogram_Type
6999 | E_Anonymous_Access_Subprogram_Type
7003 (Designated_Type
(T1
),
7004 Designated_Type
(T2
));
7007 Subtypes_Statically_Match
7008 (Designated_Type
(T1
),
7009 Designated_Type
(T2
))
7010 and then Is_Access_Constant
(T1
) = Is_Access_Constant
(T2
);
7013 -- All other types definitely match
7018 end Subtypes_Statically_Match
;
7024 function Test
(Cond
: Boolean) return Uint
is
7033 ---------------------
7034 -- Test_Comparison --
7035 ---------------------
7037 procedure Test_Comparison
7039 Assume_Valid
: Boolean;
7040 True_Result
: out Boolean;
7041 False_Result
: out Boolean)
7043 Left
: constant Node_Id
:= Left_Opnd
(Op
);
7044 Left_Typ
: constant Entity_Id
:= Etype
(Left
);
7045 Orig_Op
: constant Node_Id
:= Original_Node
(Op
);
7047 procedure Replacement_Warning
(Msg
: String);
7048 -- Emit a warning on a comparison that can be replaced by '='
7050 -------------------------
7051 -- Replacement_Warning --
7052 -------------------------
7054 procedure Replacement_Warning
(Msg
: String) is
7056 if Constant_Condition_Warnings
7057 and then Comes_From_Source
(Orig_Op
)
7058 and then Is_Integer_Type
(Left_Typ
)
7059 and then not Error_Posted
(Op
)
7060 and then not Has_Warnings_Off
(Left_Typ
)
7061 and then not In_Instance
7063 Error_Msg_N
(Msg
, Op
);
7065 end Replacement_Warning
;
7069 Res
: constant Compare_Result
:=
7070 Compile_Time_Compare
(Left
, Right_Opnd
(Op
), Assume_Valid
);
7072 -- Start of processing for Test_Comparison
7075 case N_Op_Compare
(Nkind
(Op
)) is
7077 True_Result
:= Res
= EQ
;
7078 False_Result
:= Res
= LT
or else Res
= GT
or else Res
= NE
;
7081 True_Result
:= Res
in Compare_GE
;
7082 False_Result
:= Res
= LT
;
7084 if Res
= LE
and then Nkind
(Orig_Op
) = N_Op_Ge
then
7086 ("can never be greater than, could replace by ""'=""?c?");
7090 True_Result
:= Res
= GT
;
7091 False_Result
:= Res
in Compare_LE
;
7094 True_Result
:= Res
in Compare_LE
;
7095 False_Result
:= Res
= GT
;
7097 if Res
= GE
and then Nkind
(Orig_Op
) = N_Op_Le
then
7099 ("can never be less than, could replace by ""'=""?c?");
7103 True_Result
:= Res
= LT
;
7104 False_Result
:= Res
in Compare_GE
;
7107 True_Result
:= Res
= NE
or else Res
= GT
or else Res
= LT
;
7108 False_Result
:= Res
= EQ
;
7110 end Test_Comparison
;
7112 ---------------------------------
7113 -- Test_Expression_Is_Foldable --
7114 ---------------------------------
7118 procedure Test_Expression_Is_Foldable
7128 if Debug_Flag_Dot_F
and then In_Extended_Main_Source_Unit
(N
) then
7132 -- If operand is Any_Type, just propagate to result and do not
7133 -- try to fold, this prevents cascaded errors.
7135 if Etype
(Op1
) = Any_Type
then
7136 Set_Etype
(N
, Any_Type
);
7139 -- If operand raises Constraint_Error, then replace node N with the
7140 -- raise Constraint_Error node, and we are obviously not foldable.
7141 -- Note that this replacement inherits the Is_Static_Expression flag
7142 -- from the operand.
7144 elsif Raises_Constraint_Error
(Op1
) then
7145 Rewrite_In_Raise_CE
(N
, Op1
);
7148 -- If the operand is not static, then the result is not static, and
7149 -- all we have to do is to check the operand since it is now known
7150 -- to appear in a non-static context.
7152 elsif not Is_Static_Expression
(Op1
) then
7153 Check_Non_Static_Context
(Op1
);
7154 Fold
:= Compile_Time_Known_Value
(Op1
);
7157 -- An expression of a formal modular type is not foldable because
7158 -- the modulus is unknown.
7160 elsif Is_Modular_Integer_Type
(Etype
(Op1
))
7161 and then Is_Generic_Type
(Etype
(Op1
))
7163 Check_Non_Static_Context
(Op1
);
7166 -- Here we have the case of an operand whose type is OK, which is
7167 -- static, and which does not raise Constraint_Error, we can fold.
7170 Set_Is_Static_Expression
(N
);
7174 end Test_Expression_Is_Foldable
;
7178 procedure Test_Expression_Is_Foldable
7184 CRT_Safe
: Boolean := False)
7186 Rstat
: constant Boolean := Is_Static_Expression
(Op1
)
7188 Is_Static_Expression
(Op2
);
7194 -- Inhibit folding if -gnatd.f flag set
7196 if Debug_Flag_Dot_F
and then In_Extended_Main_Source_Unit
(N
) then
7200 -- If either operand is Any_Type, just propagate to result and
7201 -- do not try to fold, this prevents cascaded errors.
7203 if Etype
(Op1
) = Any_Type
or else Etype
(Op2
) = Any_Type
then
7204 Set_Etype
(N
, Any_Type
);
7207 -- If left operand raises Constraint_Error, then replace node N with the
7208 -- Raise_Constraint_Error node, and we are obviously not foldable.
7209 -- Is_Static_Expression is set from the two operands in the normal way,
7210 -- and we check the right operand if it is in a non-static context.
7212 elsif Raises_Constraint_Error
(Op1
) then
7214 Check_Non_Static_Context
(Op2
);
7217 Rewrite_In_Raise_CE
(N
, Op1
);
7218 Set_Is_Static_Expression
(N
, Rstat
);
7221 -- Similar processing for the case of the right operand. Note that we
7222 -- don't use this routine for the short-circuit case, so we do not have
7223 -- to worry about that special case here.
7225 elsif Raises_Constraint_Error
(Op2
) then
7227 Check_Non_Static_Context
(Op1
);
7230 Rewrite_In_Raise_CE
(N
, Op2
);
7231 Set_Is_Static_Expression
(N
, Rstat
);
7234 -- Exclude expressions of a generic modular type, as above
7236 elsif Is_Modular_Integer_Type
(Etype
(Op1
))
7237 and then Is_Generic_Type
(Etype
(Op1
))
7239 Check_Non_Static_Context
(Op1
);
7242 -- If result is not static, then check non-static contexts on operands
7243 -- since one of them may be static and the other one may not be static.
7245 elsif not Rstat
then
7246 Check_Non_Static_Context
(Op1
);
7247 Check_Non_Static_Context
(Op2
);
7250 Fold
:= CRT_Safe_Compile_Time_Known_Value
(Op1
)
7251 and then CRT_Safe_Compile_Time_Known_Value
(Op2
);
7253 Fold
:= Compile_Time_Known_Value
(Op1
)
7254 and then Compile_Time_Known_Value
(Op2
);
7258 and then not Is_Modular_Integer_Type
(Etype
(N
))
7263 -- (False and XXX) = (XXX and False) = False
7266 (Compile_Time_Known_Value
(Op1
)
7267 and then Is_False
(Expr_Value
(Op1
))
7268 and then Side_Effect_Free
(Op2
))
7269 or else (Compile_Time_Known_Value
(Op2
)
7270 and then Is_False
(Expr_Value
(Op2
))
7271 and then Side_Effect_Free
(Op1
));
7275 -- (True and XXX) = (XXX and True) = True
7278 (Compile_Time_Known_Value
(Op1
)
7279 and then Is_True
(Expr_Value
(Op1
))
7280 and then Side_Effect_Free
(Op2
))
7281 or else (Compile_Time_Known_Value
(Op2
)
7282 and then Is_True
(Expr_Value
(Op2
))
7283 and then Side_Effect_Free
(Op1
));
7285 when others => null;
7291 -- Else result is static and foldable. Both operands are static, and
7292 -- neither raises Constraint_Error, so we can definitely fold.
7295 Set_Is_Static_Expression
(N
);
7300 end Test_Expression_Is_Foldable
;
7306 function Test_In_Range
7309 Assume_Valid
: Boolean;
7310 Fixed_Int
: Boolean;
7311 Int_Real
: Boolean) return Range_Membership
7316 pragma Warnings
(Off
, Assume_Valid
);
7317 -- For now Assume_Valid is unreferenced since the current implementation
7318 -- always returns Unknown if N is not a compile-time-known value, but we
7319 -- keep the parameter to allow for future enhancements in which we try
7320 -- to get the information in the variable case as well.
7323 -- If an error was posted on expression, then return Unknown, we do not
7324 -- want cascaded errors based on some false analysis of a junk node.
7326 if Error_Posted
(N
) then
7329 -- Expression that raises Constraint_Error is an odd case. We certainly
7330 -- do not want to consider it to be in range. It might make sense to
7331 -- consider it always out of range, but this causes incorrect error
7332 -- messages about static expressions out of range. So we just return
7333 -- Unknown, which is always safe.
7335 elsif Raises_Constraint_Error
(N
) then
7338 -- Universal types have no range limits, so always in range
7340 elsif Is_Universal_Numeric_Type
(Typ
) then
7343 -- Never known if not scalar type. Don't know if this can actually
7344 -- happen, but our spec allows it, so we must check.
7346 elsif not Is_Scalar_Type
(Typ
) then
7349 -- Never known if this is a generic type, since the bounds of generic
7350 -- types are junk. Note that if we only checked for static expressions
7351 -- (instead of compile-time-known values) below, we would not need this
7352 -- check, because values of a generic type can never be static, but they
7353 -- can be known at compile time.
7355 elsif Is_Generic_Type
(Typ
) then
7358 -- Case of a known compile time value, where we can check if it is in
7359 -- the bounds of the given type.
7361 elsif Compile_Time_Known_Value
(N
) then
7363 Lo
: constant Node_Id
:= Type_Low_Bound
(Typ
);
7364 Hi
: constant Node_Id
:= Type_High_Bound
(Typ
);
7365 LB_Known
: constant Boolean := Compile_Time_Known_Value
(Lo
);
7366 HB_Known
: constant Boolean := Compile_Time_Known_Value
(Hi
);
7369 -- Fixed point types should be considered as such only if flag
7370 -- Fixed_Int is set to False.
7372 if Is_Floating_Point_Type
(Typ
)
7373 or else (Is_Fixed_Point_Type
(Typ
) and then not Fixed_Int
)
7376 Valr
:= Expr_Value_R
(N
);
7378 if LB_Known
and HB_Known
then
7379 if Valr
>= Expr_Value_R
(Lo
)
7381 Valr
<= Expr_Value_R
(Hi
)
7385 return Out_Of_Range
;
7388 elsif (LB_Known
and then Valr
< Expr_Value_R
(Lo
))
7390 (HB_Known
and then Valr
> Expr_Value_R
(Hi
))
7392 return Out_Of_Range
;
7399 Val
:= Expr_Value
(N
);
7401 if LB_Known
and HB_Known
then
7402 if Val
>= Expr_Value
(Lo
) and then Val
<= Expr_Value
(Hi
)
7406 return Out_Of_Range
;
7409 elsif (LB_Known
and then Val
< Expr_Value
(Lo
))
7411 (HB_Known
and then Val
> Expr_Value
(Hi
))
7413 return Out_Of_Range
;
7421 -- Here for value not known at compile time. Case of expression subtype
7422 -- is Typ or is a subtype of Typ, and we can assume expression is valid.
7423 -- In this case we know it is in range without knowing its value.
7426 and then (Etype
(N
) = Typ
or else Is_Subtype_Of
(Etype
(N
), Typ
))
7430 -- Another special case. For signed integer types, if the target type
7431 -- has Is_Known_Valid set, and the source type does not have a larger
7432 -- size, then the source value must be in range. We exclude biased
7433 -- types, because they bizarrely can generate out of range values.
7435 elsif Is_Signed_Integer_Type
(Etype
(N
))
7436 and then Is_Known_Valid
(Typ
)
7437 and then Esize
(Etype
(N
)) <= Esize
(Typ
)
7438 and then not Has_Biased_Representation
(Etype
(N
))
7442 -- For all other cases, result is unknown
7453 procedure To_Bits
(U
: Uint
; B
: out Bits
) is
7455 for J
in 0 .. B
'Last loop
7456 B
(J
) := (U
/ (2 ** J
)) mod 2 /= 0;
7460 --------------------
7461 -- Why_Not_Static --
7462 --------------------
7464 procedure Why_Not_Static
(Expr
: Node_Id
) is
7465 N
: constant Node_Id
:= Original_Node
(Expr
);
7466 Typ
: Entity_Id
:= Empty
;
7471 procedure Why_Not_Static_List
(L
: List_Id
);
7472 -- A version that can be called on a list of expressions. Finds all
7473 -- non-static violations in any element of the list.
7475 -------------------------
7476 -- Why_Not_Static_List --
7477 -------------------------
7479 procedure Why_Not_Static_List
(L
: List_Id
) is
7482 if Is_Non_Empty_List
(L
) then
7484 while Present
(N
) loop
7489 end Why_Not_Static_List
;
7491 -- Start of processing for Why_Not_Static
7494 -- Ignore call on error or empty node
7496 if No
(Expr
) or else Nkind
(Expr
) = N_Error
then
7500 -- Preprocessing for sub expressions
7502 if Nkind
(Expr
) in N_Subexpr
then
7504 -- Nothing to do if expression is static
7506 if Is_OK_Static_Expression
(Expr
) then
7510 -- Test for Constraint_Error raised
7512 if Raises_Constraint_Error
(Expr
) then
7514 -- Special case membership to find out which piece to flag
7516 if Nkind
(N
) in N_Membership_Test
then
7517 if Raises_Constraint_Error
(Left_Opnd
(N
)) then
7518 Why_Not_Static
(Left_Opnd
(N
));
7521 elsif Present
(Right_Opnd
(N
))
7522 and then Raises_Constraint_Error
(Right_Opnd
(N
))
7524 Why_Not_Static
(Right_Opnd
(N
));
7528 pragma Assert
(Present
(Alternatives
(N
)));
7530 Alt
:= First
(Alternatives
(N
));
7531 while Present
(Alt
) loop
7532 if Raises_Constraint_Error
(Alt
) then
7533 Why_Not_Static
(Alt
);
7541 -- Special case a range to find out which bound to flag
7543 elsif Nkind
(N
) = N_Range
then
7544 if Raises_Constraint_Error
(Low_Bound
(N
)) then
7545 Why_Not_Static
(Low_Bound
(N
));
7548 elsif Raises_Constraint_Error
(High_Bound
(N
)) then
7549 Why_Not_Static
(High_Bound
(N
));
7553 -- Special case attribute to see which part to flag
7555 elsif Nkind
(N
) = N_Attribute_Reference
then
7556 if Raises_Constraint_Error
(Prefix
(N
)) then
7557 Why_Not_Static
(Prefix
(N
));
7561 if Present
(Expressions
(N
)) then
7562 Exp
:= First
(Expressions
(N
));
7563 while Present
(Exp
) loop
7564 if Raises_Constraint_Error
(Exp
) then
7565 Why_Not_Static
(Exp
);
7573 -- Special case a subtype name
7575 elsif Is_Entity_Name
(Expr
) and then Is_Type
(Entity
(Expr
)) then
7577 ("!& is not a static subtype (RM 4.9(26))", N
, Entity
(Expr
));
7581 -- End of special cases
7584 ("!expression raises exception, cannot be static (RM 4.9(34))",
7589 -- If no type, then something is pretty wrong, so ignore
7591 Typ
:= Etype
(Expr
);
7597 -- Type must be scalar or string type (but allow Bignum, since this
7598 -- is really a scalar type from our point of view in this diagnosis).
7600 if not Is_Scalar_Type
(Typ
)
7601 and then not Is_String_Type
(Typ
)
7602 and then not Is_RTE
(Typ
, RE_Bignum
)
7605 ("!static expression must have scalar or string type " &
7611 -- If we got through those checks, test particular node kind
7617 when N_Expanded_Name
7623 if Is_Named_Number
(E
) then
7626 elsif Ekind
(E
) = E_Constant
then
7628 -- One case we can give a better message is when we have a
7629 -- string literal created by concatenating an aggregate with
7630 -- an others expression.
7632 Entity_Case
: declare
7633 CV
: constant Node_Id
:= Constant_Value
(E
);
7634 CO
: constant Node_Id
:= Original_Node
(CV
);
7636 function Is_Aggregate
(N
: Node_Id
) return Boolean;
7637 -- See if node N came from an others aggregate, if so
7638 -- return True and set Error_Msg_Sloc to aggregate.
7644 function Is_Aggregate
(N
: Node_Id
) return Boolean is
7646 if Nkind
(Original_Node
(N
)) = N_Aggregate
then
7647 Error_Msg_Sloc
:= Sloc
(Original_Node
(N
));
7650 elsif Is_Entity_Name
(N
)
7651 and then Ekind
(Entity
(N
)) = E_Constant
7653 Nkind
(Original_Node
(Constant_Value
(Entity
(N
)))) =
7657 Sloc
(Original_Node
(Constant_Value
(Entity
(N
))));
7665 -- Start of processing for Entity_Case
7668 if Is_Aggregate
(CV
)
7669 or else (Nkind
(CO
) = N_Op_Concat
7670 and then (Is_Aggregate
(Left_Opnd
(CO
))
7672 Is_Aggregate
(Right_Opnd
(CO
))))
7674 Error_Msg_N
("!aggregate (#) is never static", N
);
7676 elsif No
(CV
) or else not Is_Static_Expression
(CV
) then
7678 ("!& is not a static constant (RM 4.9(5))", N
, E
);
7682 elsif Is_Type
(E
) then
7684 ("!& is not a static subtype (RM 4.9(26))", N
, E
);
7688 ("!& is not static constant or named number "
7689 & "(RM 4.9(5))", N
, E
);
7698 if Nkind
(N
) in N_Op_Shift
then
7700 ("!shift functions are never static (RM 4.9(6,18))", N
);
7702 Why_Not_Static
(Left_Opnd
(N
));
7703 Why_Not_Static
(Right_Opnd
(N
));
7709 Why_Not_Static
(Right_Opnd
(N
));
7711 -- Attribute reference
7713 when N_Attribute_Reference
=>
7714 Why_Not_Static_List
(Expressions
(N
));
7716 E
:= Etype
(Prefix
(N
));
7718 if E
= Standard_Void_Type
then
7722 -- Special case non-scalar'Size since this is a common error
7724 if Attribute_Name
(N
) = Name_Size
then
7726 ("!size attribute is only static for static scalar type "
7727 & "(RM 4.9(7,8))", N
);
7731 elsif Is_Array_Type
(E
) then
7732 if Attribute_Name
(N
)
7733 not in Name_First | Name_Last | Name_Length
7736 ("!static array attribute must be Length, First, or Last "
7737 & "(RM 4.9(8))", N
);
7739 -- Since we know the expression is not-static (we already
7740 -- tested for this, must mean array is not static).
7744 ("!prefix is non-static array (RM 4.9(8))", Prefix
(N
));
7749 -- Special case generic types, since again this is a common source
7752 elsif Is_Generic_Actual_Type
(E
) or else Is_Generic_Type
(E
) then
7754 ("!attribute of generic type is never static "
7755 & "(RM 4.9(7,8))", N
);
7757 elsif Is_OK_Static_Subtype
(E
) then
7760 elsif Is_Scalar_Type
(E
) then
7762 ("!prefix type for attribute is not static scalar subtype "
7763 & "(RM 4.9(7))", N
);
7767 ("!static attribute must apply to array/scalar type "
7768 & "(RM 4.9(7,8))", N
);
7773 when N_String_Literal
=>
7775 ("!subtype of string literal is non-static (RM 4.9(4))", N
);
7777 -- Explicit dereference
7779 when N_Explicit_Dereference
=>
7781 ("!explicit dereference is never static (RM 4.9)", N
);
7785 when N_Function_Call
=>
7786 Why_Not_Static_List
(Parameter_Associations
(N
));
7788 -- Complain about non-static function call unless we have Bignum
7789 -- which means that the underlying expression is really some
7790 -- scalar arithmetic operation.
7792 if not Is_RTE
(Typ
, RE_Bignum
) then
7793 Error_Msg_N
("!non-static function call (RM 4.9(6,18))", N
);
7796 -- Parameter assocation (test actual parameter)
7798 when N_Parameter_Association
=>
7799 Why_Not_Static
(Explicit_Actual_Parameter
(N
));
7801 -- Indexed component
7803 when N_Indexed_Component
=>
7804 Error_Msg_N
("!indexed component is never static (RM 4.9)", N
);
7808 when N_Procedure_Call_Statement
=>
7809 Error_Msg_N
("!procedure call is never static (RM 4.9)", N
);
7811 -- Qualified expression (test expression)
7813 when N_Qualified_Expression
=>
7814 Why_Not_Static
(Expression
(N
));
7819 | N_Extension_Aggregate
7821 Error_Msg_N
("!an aggregate is never static (RM 4.9)", N
);
7826 Why_Not_Static
(Low_Bound
(N
));
7827 Why_Not_Static
(High_Bound
(N
));
7829 -- Range constraint, test range expression
7831 when N_Range_Constraint
=>
7832 Why_Not_Static
(Range_Expression
(N
));
7834 -- Subtype indication, test constraint
7836 when N_Subtype_Indication
=>
7837 Why_Not_Static
(Constraint
(N
));
7839 -- Selected component
7841 when N_Selected_Component
=>
7842 Error_Msg_N
("!selected component is never static (RM 4.9)", N
);
7847 Error_Msg_N
("!slice is never static (RM 4.9)", N
);
7849 when N_Type_Conversion
=>
7850 Why_Not_Static
(Expression
(N
));
7852 if not Is_Scalar_Type
(Entity
(Subtype_Mark
(N
)))
7853 or else not Is_OK_Static_Subtype
(Entity
(Subtype_Mark
(N
)))
7856 ("!static conversion requires static scalar subtype result "
7857 & "(RM 4.9(9))", N
);
7860 -- Unchecked type conversion
7862 when N_Unchecked_Type_Conversion
=>
7864 ("!unchecked type conversion is never static (RM 4.9)", N
);
7866 -- All other cases, no reason to give