1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 with Atree
; use Atree
;
27 with Checks
; use Checks
;
28 with Debug
; use Debug
;
29 with Einfo
; use Einfo
;
30 with Elists
; use Elists
;
31 with Errout
; use Errout
;
32 with Eval_Fat
; use Eval_Fat
;
33 with Exp_Util
; use Exp_Util
;
34 with Freeze
; use Freeze
;
36 with Namet
; use Namet
;
37 with Nmake
; use Nmake
;
38 with Nlists
; use Nlists
;
40 with Par_SCO
; use Par_SCO
;
41 with Rtsfind
; use Rtsfind
;
43 with Sem_Aux
; use Sem_Aux
;
44 with Sem_Cat
; use Sem_Cat
;
45 with Sem_Ch6
; use Sem_Ch6
;
46 with Sem_Ch8
; use Sem_Ch8
;
47 with Sem_Res
; use Sem_Res
;
48 with Sem_Util
; use Sem_Util
;
49 with Sem_Type
; use Sem_Type
;
50 with Sem_Warn
; use Sem_Warn
;
51 with Sinfo
; use Sinfo
;
52 with Snames
; use Snames
;
53 with Stand
; use Stand
;
54 with Stringt
; use Stringt
;
55 with Tbuild
; use Tbuild
;
57 package body Sem_Eval
is
59 -----------------------------------------
60 -- Handling of Compile Time Evaluation --
61 -----------------------------------------
63 -- The compile time evaluation of expressions is distributed over several
64 -- Eval_xxx procedures. These procedures are called immediately after
65 -- a subexpression is resolved and is therefore accomplished in a bottom
66 -- up fashion. The flags are synthesized using the following approach.
68 -- Is_Static_Expression is determined by following the detailed rules
69 -- in RM 4.9(4-14). This involves testing the Is_Static_Expression
70 -- flag of the operands in many cases.
72 -- Raises_Constraint_Error is set if any of the operands have the flag
73 -- set or if an attempt to compute the value of the current expression
74 -- results in detection of a runtime constraint error.
76 -- As described in the spec, the requirement is that Is_Static_Expression
77 -- be accurately set, and in addition for nodes for which this flag is set,
78 -- Raises_Constraint_Error must also be set. Furthermore a node which has
79 -- Is_Static_Expression set, and Raises_Constraint_Error clear, then the
80 -- requirement is that the expression value must be precomputed, and the
81 -- node is either a literal, or the name of a constant entity whose value
82 -- is a static expression.
84 -- The general approach is as follows. First compute Is_Static_Expression.
85 -- If the node is not static, then the flag is left off in the node and
86 -- we are all done. Otherwise for a static node, we test if any of the
87 -- operands will raise constraint error, and if so, propagate the flag
88 -- Raises_Constraint_Error to the result node and we are done (since the
89 -- error was already posted at a lower level).
91 -- For the case of a static node whose operands do not raise constraint
92 -- error, we attempt to evaluate the node. If this evaluation succeeds,
93 -- then the node is replaced by the result of this computation. If the
94 -- evaluation raises constraint error, then we rewrite the node with
95 -- Apply_Compile_Time_Constraint_Error to raise the exception and also
96 -- to post appropriate error messages.
102 type Bits
is array (Nat
range <>) of Boolean;
103 -- Used to convert unsigned (modular) values for folding logical ops
105 -- The following declarations are used to maintain a cache of nodes that
106 -- have compile time known values. The cache is maintained only for
107 -- discrete types (the most common case), and is populated by calls to
108 -- Compile_Time_Known_Value and Expr_Value, but only used by Expr_Value
109 -- since it is possible for the status to change (in particular it is
110 -- possible for a node to get replaced by a constraint error node).
112 CV_Bits
: constant := 5;
113 -- Number of low order bits of Node_Id value used to reference entries
114 -- in the cache table.
116 CV_Cache_Size
: constant Nat
:= 2 ** CV_Bits
;
117 -- Size of cache for compile time values
119 subtype CV_Range
is Nat
range 0 .. CV_Cache_Size
;
121 type CV_Entry
is record
126 type Match_Result
is (Match
, No_Match
, Non_Static
);
127 -- Result returned from functions that test for a matching result. If the
128 -- operands are not OK_Static then Non_Static will be returned. Otherwise
129 -- Match/No_Match is returned depending on whether the match succeeds.
131 type CV_Cache_Array
is array (CV_Range
) of CV_Entry
;
133 CV_Cache
: CV_Cache_Array
:= (others => (Node_High_Bound
, Uint_0
));
134 -- This is the actual cache, with entries consisting of node/value pairs,
135 -- and the impossible value Node_High_Bound used for unset entries.
137 type Range_Membership
is (In_Range
, Out_Of_Range
, Unknown
);
138 -- Range membership may either be statically known to be in range or out
139 -- of range, or not statically known. Used for Test_In_Range below.
141 -----------------------
142 -- Local Subprograms --
143 -----------------------
145 function Choice_Matches
147 Choice
: Node_Id
) return Match_Result
;
148 -- Determines whether given value Expr matches the given Choice. The Expr
149 -- can be of discrete, real, or string type and must be a compile time
150 -- known value (it is an error to make the call if these conditions are
151 -- not met). The choice can be a range, subtype name, subtype indication,
152 -- or expression. The returned result is Non_Static if Choice is not
153 -- OK_Static, otherwise either Match or No_Match is returned depending
154 -- on whether Choice matches Expr. This is used for case expression
155 -- alternatives, and also for membership tests. In each case, more
156 -- possibilities are tested than the syntax allows (e.g. membership allows
157 -- subtype indications and non-discrete types, and case allows an OTHERS
158 -- choice), but it does not matter, since we have already done a full
159 -- semantic and syntax check of the construct, so the extra possibilities
160 -- just will not arise for correct expressions.
162 -- Note: if Choice_Matches finds that a choice raises Constraint_Error, e.g
163 -- a reference to a type, one of whose bounds raises Constraint_Error, then
164 -- it also sets the Raises_Constraint_Error flag on the Choice itself.
166 function Choices_Match
168 Choices
: List_Id
) return Match_Result
;
169 -- This function applies Choice_Matches to each element of Choices. If the
170 -- result is No_Match, then it continues and checks the next element. If
171 -- the result is Match or Non_Static, this result is immediately given
172 -- as the result without checking the rest of the list. Expr can be of
173 -- discrete, real, or string type and must be a compile time known value
174 -- (it is an error to make the call if these conditions are not met).
176 function Find_Universal_Operator_Type
(N
: Node_Id
) return Entity_Id
;
177 -- Check whether an arithmetic operation with universal operands which is a
178 -- rewritten function call with an explicit scope indication is ambiguous:
179 -- P."+" (1, 2) will be ambiguous if there is more than one visible numeric
180 -- type declared in P and the context does not impose a type on the result
181 -- (e.g. in the expression of a type conversion). If ambiguous, emit an
182 -- error and return Empty, else return the result type of the operator.
184 function From_Bits
(B
: Bits
; T
: Entity_Id
) return Uint
;
185 -- Converts a bit string of length B'Length to a Uint value to be used for
186 -- a target of type T, which is a modular type. This procedure includes the
187 -- necessary reduction by the modulus in the case of a nonbinary modulus
188 -- (for a binary modulus, the bit string is the right length any way so all
191 function Get_String_Val
(N
: Node_Id
) return Node_Id
;
192 -- Given a tree node for a folded string or character value, returns the
193 -- corresponding string literal or character literal (one of the two must
194 -- be available, or the operand would not have been marked as foldable in
195 -- the earlier analysis of the operation).
197 function Is_OK_Static_Choice
(Choice
: Node_Id
) return Boolean;
198 -- Given a choice (from a case expression or membership test), returns
199 -- True if the choice is static and does not raise a Constraint_Error.
201 function Is_OK_Static_Choice_List
(Choices
: List_Id
) return Boolean;
202 -- Given a choice list (from a case expression or membership test), return
203 -- True if all choices are static in the sense of Is_OK_Static_Choice.
205 function Is_Static_Choice
(Choice
: Node_Id
) return Boolean;
206 -- Given a choice (from a case expression or membership test), returns
207 -- True if the choice is static. No test is made for raising of constraint
208 -- error, so this function is used only for legality tests.
210 function Is_Static_Choice_List
(Choices
: List_Id
) return Boolean;
211 -- Given a choice list (from a case expression or membership test), return
212 -- True if all choices are static in the sense of Is_Static_Choice.
214 function Is_Static_Range
(N
: Node_Id
) return Boolean;
215 -- Determine if range is static, as defined in RM 4.9(26). The only allowed
216 -- argument is an N_Range node (but note that the semantic analysis of
217 -- equivalent range attribute references already turned them into the
218 -- equivalent range). This differs from Is_OK_Static_Range (which is what
219 -- must be used by clients) in that it does not care whether the bounds
220 -- raise Constraint_Error or not. Used for checking whether expressions are
221 -- static in the 4.9 sense (without worrying about exceptions).
223 function OK_Bits
(N
: Node_Id
; Bits
: Uint
) return Boolean;
224 -- Bits represents the number of bits in an integer value to be computed
225 -- (but the value has not been computed yet). If this value in Bits is
226 -- reasonable, a result of True is returned, with the implication that the
227 -- caller should go ahead and complete the calculation. If the value in
228 -- Bits is unreasonably large, then an error is posted on node N, and
229 -- False is returned (and the caller skips the proposed calculation).
231 procedure Out_Of_Range
(N
: Node_Id
);
232 -- This procedure is called if it is determined that node N, which appears
233 -- in a non-static context, is a compile time known value which is outside
234 -- its range, i.e. the range of Etype. This is used in contexts where
235 -- this is an illegality if N is static, and should generate a warning
238 function Real_Or_String_Static_Predicate_Matches
240 Typ
: Entity_Id
) return Boolean;
241 -- This is the function used to evaluate real or string static predicates.
242 -- Val is an unanalyzed N_Real_Literal or N_String_Literal node, which
243 -- represents the value to be tested against the predicate. Typ is the
244 -- type with the predicate, from which the predicate expression can be
245 -- extracted. The result returned is True if the given value satisfies
248 procedure Rewrite_In_Raise_CE
(N
: Node_Id
; Exp
: Node_Id
);
249 -- N and Exp are nodes representing an expression, Exp is known to raise
250 -- CE. N is rewritten in term of Exp in the optimal way.
252 function String_Type_Len
(Stype
: Entity_Id
) return Uint
;
253 -- Given a string type, determines the length of the index type, or, if
254 -- this index type is non-static, the length of the base type of this index
255 -- type. Note that if the string type is itself static, then the index type
256 -- is static, so the second case applies only if the string type passed is
259 function Test
(Cond
: Boolean) return Uint
;
260 pragma Inline
(Test
);
261 -- This function simply returns the appropriate Boolean'Pos value
262 -- corresponding to the value of Cond as a universal integer. It is
263 -- used for producing the result of the static evaluation of the
266 procedure Test_Expression_Is_Foldable
271 -- Tests to see if expression N whose single operand is Op1 is foldable,
272 -- i.e. the operand value is known at compile time. If the operation is
273 -- foldable, then Fold is True on return, and Stat indicates whether the
274 -- result is static (i.e. the operand was static). Note that it is quite
275 -- possible for Fold to be True, and Stat to be False, since there are
276 -- cases in which we know the value of an operand even though it is not
277 -- technically static (e.g. the static lower bound of a range whose upper
278 -- bound is non-static).
280 -- If Stat is set False on return, then Test_Expression_Is_Foldable makes
281 -- a call to Check_Non_Static_Context on the operand. If Fold is False on
282 -- return, then all processing is complete, and the caller should return,
283 -- since there is nothing else to do.
285 -- If Stat is set True on return, then Is_Static_Expression is also set
286 -- true in node N. There are some cases where this is over-enthusiastic,
287 -- e.g. in the two operand case below, for string comparison, the result is
288 -- not static even though the two operands are static. In such cases, the
289 -- caller must reset the Is_Static_Expression flag in N.
291 -- If Fold and Stat are both set to False then this routine performs also
292 -- the following extra actions:
294 -- If either operand is Any_Type then propagate it to result to prevent
297 -- If some operand raises constraint error, then replace the node N
298 -- with the raise constraint error node. This replacement inherits the
299 -- Is_Static_Expression flag from the operands.
301 procedure Test_Expression_Is_Foldable
307 CRT_Safe
: Boolean := False);
308 -- Same processing, except applies to an expression N with two operands
309 -- Op1 and Op2. The result is static only if both operands are static. If
310 -- CRT_Safe is set True, then CRT_Safe_Compile_Time_Known_Value is used
311 -- for the tests that the two operands are known at compile time. See
312 -- spec of this routine for further details.
314 function Test_In_Range
317 Assume_Valid
: Boolean;
319 Int_Real
: Boolean) return Range_Membership
;
320 -- Common processing for Is_In_Range and Is_Out_Of_Range: Returns In_Range
321 -- or Out_Of_Range if it can be guaranteed at compile time that expression
322 -- N is known to be in or out of range of the subtype Typ. If not compile
323 -- time known, Unknown is returned. See documentation of Is_In_Range for
324 -- complete description of parameters.
326 procedure To_Bits
(U
: Uint
; B
: out Bits
);
327 -- Converts a Uint value to a bit string of length B'Length
329 -----------------------------------------------
330 -- Check_Expression_Against_Static_Predicate --
331 -----------------------------------------------
333 procedure Check_Expression_Against_Static_Predicate
338 -- Nothing to do if expression is not known at compile time, or the
339 -- type has no static predicate set (will be the case for all non-scalar
340 -- types, so no need to make a special test for that).
342 if not (Has_Static_Predicate
(Typ
)
343 and then Compile_Time_Known_Value
(Expr
))
348 -- Here we have a static predicate (note that it could have arisen from
349 -- an explicitly specified Dynamic_Predicate whose expression met the
350 -- rules for being predicate-static).
352 -- Case of real static predicate
354 if Is_Real_Type
(Typ
) then
355 if Real_Or_String_Static_Predicate_Matches
356 (Val
=> Make_Real_Literal
(Sloc
(Expr
), Expr_Value_R
(Expr
)),
362 -- Case of string static predicate
364 elsif Is_String_Type
(Typ
) then
365 if Real_Or_String_Static_Predicate_Matches
366 (Val
=> Expr_Value_S
(Expr
), Typ
=> Typ
)
371 -- Case of discrete static predicate
374 pragma Assert
(Is_Discrete_Type
(Typ
));
376 -- If static predicate matches, nothing to do
378 if Choices_Match
(Expr
, Static_Discrete_Predicate
(Typ
)) = Match
then
383 -- Here we know that the predicate will fail
385 -- Special case of static expression failing a predicate (other than one
386 -- that was explicitly specified with a Dynamic_Predicate aspect). This
387 -- is the case where the expression is no longer considered static.
389 if Is_Static_Expression
(Expr
)
390 and then not Has_Dynamic_Predicate_Aspect
(Typ
)
393 ("??static expression fails static predicate check on &",
396 ("\??expression is no longer considered static", Expr
);
397 Set_Is_Static_Expression
(Expr
, False);
399 -- In all other cases, this is just a warning that a test will fail.
400 -- It does not matter if the expression is static or not, or if the
401 -- predicate comes from a dynamic predicate aspect or not.
405 ("??expression fails predicate check on &", Expr
, Typ
);
407 end Check_Expression_Against_Static_Predicate
;
409 ------------------------------
410 -- Check_Non_Static_Context --
411 ------------------------------
413 procedure Check_Non_Static_Context
(N
: Node_Id
) is
414 T
: constant Entity_Id
:= Etype
(N
);
415 Checks_On
: constant Boolean :=
416 not Index_Checks_Suppressed
(T
)
417 and not Range_Checks_Suppressed
(T
);
420 -- Ignore cases of non-scalar types, error types, or universal real
421 -- types that have no usable bounds.
424 or else not Is_Scalar_Type
(T
)
425 or else T
= Universal_Fixed
426 or else T
= Universal_Real
431 -- At this stage we have a scalar type. If we have an expression that
432 -- raises CE, then we already issued a warning or error msg so there is
433 -- nothing more to be done in this routine.
435 if Raises_Constraint_Error
(N
) then
439 -- Now we have a scalar type which is not marked as raising a constraint
440 -- error exception. The main purpose of this routine is to deal with
441 -- static expressions appearing in a non-static context. That means
442 -- that if we do not have a static expression then there is not much
443 -- to do. The one case that we deal with here is that if we have a
444 -- floating-point value that is out of range, then we post a warning
445 -- that an infinity will result.
447 if not Is_Static_Expression
(N
) then
448 if Is_Floating_Point_Type
(T
) then
449 if Is_Out_Of_Range
(N
, Base_Type
(T
), Assume_Valid
=> True) then
451 ("??float value out of range, infinity will be generated", N
);
453 -- The literal may be the result of constant-folding of a non-
454 -- static subexpression of a larger expression (e.g. a conversion
455 -- of a non-static variable whose value happens to be known). At
456 -- this point we must reduce the value of the subexpression to a
457 -- machine number (RM 4.9 (38/2)).
459 elsif Nkind
(N
) = N_Real_Literal
460 and then Nkind
(Parent
(N
)) in N_Subexpr
462 Rewrite
(N
, New_Copy
(N
));
464 (N
, Machine
(Base_Type
(T
), Realval
(N
), Round_Even
, N
));
471 -- Here we have the case of outer level static expression of scalar
472 -- type, where the processing of this procedure is needed.
474 -- For real types, this is where we convert the value to a machine
475 -- number (see RM 4.9(38)). Also see ACVC test C490001. We should only
476 -- need to do this if the parent is a constant declaration, since in
477 -- other cases, gigi should do the necessary conversion correctly, but
478 -- experimentation shows that this is not the case on all machines, in
479 -- particular if we do not convert all literals to machine values in
480 -- non-static contexts, then ACVC test C490001 fails on Sparc/Solaris
483 -- This conversion is always done by GNATprove on real literals in
484 -- non-static expressions, by calling Check_Non_Static_Context from
485 -- gnat2why, as GNATprove cannot do the conversion later contrary
486 -- to gigi. The frontend computes the information about which
487 -- expressions are static, which is used by gnat2why to call
488 -- Check_Non_Static_Context on exactly those real literals that are
489 -- not sub-expressions of static expressions.
491 if Nkind
(N
) = N_Real_Literal
492 and then not Is_Machine_Number
(N
)
493 and then not Is_Generic_Type
(Etype
(N
))
494 and then Etype
(N
) /= Universal_Real
496 -- Check that value is in bounds before converting to machine
497 -- number, so as not to lose case where value overflows in the
498 -- least significant bit or less. See B490001.
500 if Is_Out_Of_Range
(N
, Base_Type
(T
), Assume_Valid
=> True) then
505 -- Note: we have to copy the node, to avoid problems with conformance
506 -- of very similar numbers (see ACVC tests B4A010C and B63103A).
508 Rewrite
(N
, New_Copy
(N
));
510 if not Is_Floating_Point_Type
(T
) then
512 (N
, Corresponding_Integer_Value
(N
) * Small_Value
(T
));
514 elsif not UR_Is_Zero
(Realval
(N
)) then
516 -- Note: even though RM 4.9(38) specifies biased rounding, this
517 -- has been modified by AI-100 in order to prevent confusing
518 -- differences in rounding between static and non-static
519 -- expressions. AI-100 specifies that the effect of such rounding
520 -- is implementation dependent, and in GNAT we round to nearest
521 -- even to match the run-time behavior. Note that this applies
522 -- to floating point literals, not fixed points ones, even though
523 -- their compiler representation is also as a universal real.
526 (N
, Machine
(Base_Type
(T
), Realval
(N
), Round_Even
, N
));
527 Set_Is_Machine_Number
(N
);
532 -- Check for out of range universal integer. This is a non-static
533 -- context, so the integer value must be in range of the runtime
534 -- representation of universal integers.
536 -- We do this only within an expression, because that is the only
537 -- case in which non-static universal integer values can occur, and
538 -- furthermore, Check_Non_Static_Context is currently (incorrectly???)
539 -- called in contexts like the expression of a number declaration where
540 -- we certainly want to allow out of range values.
542 if Etype
(N
) = Universal_Integer
543 and then Nkind
(N
) = N_Integer_Literal
544 and then Nkind
(Parent
(N
)) in N_Subexpr
546 (Intval
(N
) < Expr_Value
(Type_Low_Bound
(Universal_Integer
))
548 Intval
(N
) > Expr_Value
(Type_High_Bound
(Universal_Integer
)))
550 Apply_Compile_Time_Constraint_Error
551 (N
, "non-static universal integer value out of range<<",
552 CE_Range_Check_Failed
);
554 -- Check out of range of base type
556 elsif Is_Out_Of_Range
(N
, Base_Type
(T
), Assume_Valid
=> True) then
559 -- Give warning if outside subtype (where one or both of the bounds of
560 -- the subtype is static). This warning is omitted if the expression
561 -- appears in a range that could be null (warnings are handled elsewhere
564 elsif T
/= Base_Type
(T
) and then Nkind
(Parent
(N
)) /= N_Range
then
565 if Is_In_Range
(N
, T
, Assume_Valid
=> True) then
568 elsif Is_Out_Of_Range
(N
, T
, Assume_Valid
=> True) then
569 Apply_Compile_Time_Constraint_Error
570 (N
, "value not in range of}<<", CE_Range_Check_Failed
);
573 Enable_Range_Check
(N
);
576 Set_Do_Range_Check
(N
, False);
579 end Check_Non_Static_Context
;
581 ---------------------------------
582 -- Check_String_Literal_Length --
583 ---------------------------------
585 procedure Check_String_Literal_Length
(N
: Node_Id
; Ttype
: Entity_Id
) is
587 if not Raises_Constraint_Error
(N
) and then Is_Constrained
(Ttype
) then
588 if UI_From_Int
(String_Length
(Strval
(N
))) /= String_Type_Len
(Ttype
)
590 Apply_Compile_Time_Constraint_Error
591 (N
, "string length wrong for}??",
592 CE_Length_Check_Failed
,
597 end Check_String_Literal_Length
;
603 function Choice_Matches
605 Choice
: Node_Id
) return Match_Result
607 Etyp
: constant Entity_Id
:= Etype
(Expr
);
613 pragma Assert
(Compile_Time_Known_Value
(Expr
));
614 pragma Assert
(Is_Scalar_Type
(Etyp
) or else Is_String_Type
(Etyp
));
616 if not Is_OK_Static_Choice
(Choice
) then
617 Set_Raises_Constraint_Error
(Choice
);
620 -- When the choice denotes a subtype with a static predictate, check the
621 -- expression against the predicate values.
623 elsif (Nkind
(Choice
) = N_Subtype_Indication
624 or else (Is_Entity_Name
(Choice
)
625 and then Is_Type
(Entity
(Choice
))))
626 and then Has_Predicates
(Etype
(Choice
))
627 and then Has_Static_Predicate
(Etype
(Choice
))
630 Choices_Match
(Expr
, Static_Discrete_Predicate
(Etype
(Choice
)));
632 -- Discrete type case
634 elsif Is_Discrete_Type
(Etyp
) then
635 Val
:= Expr_Value
(Expr
);
637 if Nkind
(Choice
) = N_Range
then
638 if Val
>= Expr_Value
(Low_Bound
(Choice
))
640 Val
<= Expr_Value
(High_Bound
(Choice
))
647 elsif Nkind
(Choice
) = N_Subtype_Indication
648 or else (Is_Entity_Name
(Choice
) and then Is_Type
(Entity
(Choice
)))
650 if Val
>= Expr_Value
(Type_Low_Bound
(Etype
(Choice
)))
652 Val
<= Expr_Value
(Type_High_Bound
(Etype
(Choice
)))
659 elsif Nkind
(Choice
) = N_Others_Choice
then
663 if Val
= Expr_Value
(Choice
) then
672 elsif Is_Real_Type
(Etyp
) then
673 ValR
:= Expr_Value_R
(Expr
);
675 if Nkind
(Choice
) = N_Range
then
676 if ValR
>= Expr_Value_R
(Low_Bound
(Choice
))
678 ValR
<= Expr_Value_R
(High_Bound
(Choice
))
685 elsif Nkind
(Choice
) = N_Subtype_Indication
686 or else (Is_Entity_Name
(Choice
) and then Is_Type
(Entity
(Choice
)))
688 if ValR
>= Expr_Value_R
(Type_Low_Bound
(Etype
(Choice
)))
690 ValR
<= Expr_Value_R
(Type_High_Bound
(Etype
(Choice
)))
698 if ValR
= Expr_Value_R
(Choice
) then
708 pragma Assert
(Is_String_Type
(Etyp
));
709 ValS
:= Expr_Value_S
(Expr
);
711 if Nkind
(Choice
) = N_Subtype_Indication
712 or else (Is_Entity_Name
(Choice
) and then Is_Type
(Entity
(Choice
)))
714 if not Is_Constrained
(Etype
(Choice
)) then
719 Typlen
: constant Uint
:=
720 String_Type_Len
(Etype
(Choice
));
721 Strlen
: constant Uint
:=
722 UI_From_Int
(String_Length
(Strval
(ValS
)));
724 if Typlen
= Strlen
then
733 if String_Equal
(Strval
(ValS
), Strval
(Expr_Value_S
(Choice
)))
747 function Choices_Match
749 Choices
: List_Id
) return Match_Result
752 Result
: Match_Result
;
755 Choice
:= First
(Choices
);
756 while Present
(Choice
) loop
757 Result
:= Choice_Matches
(Expr
, Choice
);
759 if Result
/= No_Match
then
769 --------------------------
770 -- Compile_Time_Compare --
771 --------------------------
773 function Compile_Time_Compare
775 Assume_Valid
: Boolean) return Compare_Result
777 Discard
: aliased Uint
;
779 return Compile_Time_Compare
(L
, R
, Discard
'Access, Assume_Valid
);
780 end Compile_Time_Compare
;
782 function Compile_Time_Compare
785 Assume_Valid
: Boolean;
786 Rec
: Boolean := False) return Compare_Result
788 Ltyp
: Entity_Id
:= Etype
(L
);
789 Rtyp
: Entity_Id
:= Etype
(R
);
791 Discard
: aliased Uint
;
793 procedure Compare_Decompose
797 -- This procedure decomposes the node N into an expression node and a
798 -- signed offset, so that the value of N is equal to the value of R plus
799 -- the value V (which may be negative). If no such decomposition is
800 -- possible, then on return R is a copy of N, and V is set to zero.
802 function Compare_Fixup
(N
: Node_Id
) return Node_Id
;
803 -- This function deals with replacing 'Last and 'First references with
804 -- their corresponding type bounds, which we then can compare. The
805 -- argument is the original node, the result is the identity, unless we
806 -- have a 'Last/'First reference in which case the value returned is the
807 -- appropriate type bound.
809 function Is_Known_Valid_Operand
(Opnd
: Node_Id
) return Boolean;
810 -- Even if the context does not assume that values are valid, some
811 -- simple cases can be recognized.
813 function Is_Same_Value
(L
, R
: Node_Id
) return Boolean;
814 -- Returns True iff L and R represent expressions that definitely have
815 -- identical (but not necessarily compile time known) values Indeed the
816 -- caller is expected to have already dealt with the cases of compile
817 -- time known values, so these are not tested here.
819 -----------------------
820 -- Compare_Decompose --
821 -----------------------
823 procedure Compare_Decompose
829 if Nkind
(N
) = N_Op_Add
830 and then Nkind
(Right_Opnd
(N
)) = N_Integer_Literal
833 V
:= Intval
(Right_Opnd
(N
));
836 elsif Nkind
(N
) = N_Op_Subtract
837 and then Nkind
(Right_Opnd
(N
)) = N_Integer_Literal
840 V
:= UI_Negate
(Intval
(Right_Opnd
(N
)));
843 elsif Nkind
(N
) = N_Attribute_Reference
then
844 if Attribute_Name
(N
) = Name_Succ
then
845 R
:= First
(Expressions
(N
));
849 elsif Attribute_Name
(N
) = Name_Pred
then
850 R
:= First
(Expressions
(N
));
858 end Compare_Decompose
;
864 function Compare_Fixup
(N
: Node_Id
) return Node_Id
is
870 -- Fixup only required for First/Last attribute reference
872 if Nkind
(N
) = N_Attribute_Reference
873 and then Nam_In
(Attribute_Name
(N
), Name_First
, Name_Last
)
875 Xtyp
:= Etype
(Prefix
(N
));
877 -- If we have no type, then just abandon the attempt to do
878 -- a fixup, this is probably the result of some other error.
884 -- Dereference an access type
886 if Is_Access_Type
(Xtyp
) then
887 Xtyp
:= Designated_Type
(Xtyp
);
890 -- If we don't have an array type at this stage, something is
891 -- peculiar, e.g. another error, and we abandon the attempt at
894 if not Is_Array_Type
(Xtyp
) then
898 -- Ignore unconstrained array, since bounds are not meaningful
900 if not Is_Constrained
(Xtyp
) then
904 if Ekind
(Xtyp
) = E_String_Literal_Subtype
then
905 if Attribute_Name
(N
) = Name_First
then
906 return String_Literal_Low_Bound
(Xtyp
);
909 Make_Integer_Literal
(Sloc
(N
),
910 Intval
=> Intval
(String_Literal_Low_Bound
(Xtyp
)) +
911 String_Literal_Length
(Xtyp
));
915 -- Find correct index type
917 Indx
:= First_Index
(Xtyp
);
919 if Present
(Expressions
(N
)) then
920 Subs
:= UI_To_Int
(Expr_Value
(First
(Expressions
(N
))));
922 for J
in 2 .. Subs
loop
923 Indx
:= Next_Index
(Indx
);
927 Xtyp
:= Etype
(Indx
);
929 if Attribute_Name
(N
) = Name_First
then
930 return Type_Low_Bound
(Xtyp
);
932 return Type_High_Bound
(Xtyp
);
939 ----------------------------
940 -- Is_Known_Valid_Operand --
941 ----------------------------
943 function Is_Known_Valid_Operand
(Opnd
: Node_Id
) return Boolean is
945 return (Is_Entity_Name
(Opnd
)
947 (Is_Known_Valid
(Entity
(Opnd
))
948 or else Ekind
(Entity
(Opnd
)) = E_In_Parameter
950 (Ekind
(Entity
(Opnd
)) in Object_Kind
951 and then Present
(Current_Value
(Entity
(Opnd
))))))
952 or else Is_OK_Static_Expression
(Opnd
);
953 end Is_Known_Valid_Operand
;
959 function Is_Same_Value
(L
, R
: Node_Id
) return Boolean is
960 Lf
: constant Node_Id
:= Compare_Fixup
(L
);
961 Rf
: constant Node_Id
:= Compare_Fixup
(R
);
963 function Is_Same_Subscript
(L
, R
: List_Id
) return Boolean;
964 -- L, R are the Expressions values from two attribute nodes for First
965 -- or Last attributes. Either may be set to No_List if no expressions
966 -- are present (indicating subscript 1). The result is True if both
967 -- expressions represent the same subscript (note one case is where
968 -- one subscript is missing and the other is explicitly set to 1).
970 -----------------------
971 -- Is_Same_Subscript --
972 -----------------------
974 function Is_Same_Subscript
(L
, R
: List_Id
) return Boolean is
980 return Expr_Value
(First
(R
)) = Uint_1
;
985 return Expr_Value
(First
(L
)) = Uint_1
;
987 return Expr_Value
(First
(L
)) = Expr_Value
(First
(R
));
990 end Is_Same_Subscript
;
992 -- Start of processing for Is_Same_Value
995 -- Values are the same if they refer to the same entity and the
996 -- entity is non-volatile. This does not however apply to Float
997 -- types, since we may have two NaN values and they should never
1000 -- If the entity is a discriminant, the two expressions may be bounds
1001 -- of components of objects of the same discriminated type. The
1002 -- values of the discriminants are not static, and therefore the
1003 -- result is unknown.
1005 -- It would be better to comment individual branches of this test ???
1007 if Nkind_In
(Lf
, N_Identifier
, N_Expanded_Name
)
1008 and then Nkind_In
(Rf
, N_Identifier
, N_Expanded_Name
)
1009 and then Entity
(Lf
) = Entity
(Rf
)
1010 and then Ekind
(Entity
(Lf
)) /= E_Discriminant
1011 and then Present
(Entity
(Lf
))
1012 and then not Is_Floating_Point_Type
(Etype
(L
))
1013 and then not Is_Volatile_Reference
(L
)
1014 and then not Is_Volatile_Reference
(R
)
1018 -- Or if they are compile time known and identical
1020 elsif Compile_Time_Known_Value
(Lf
)
1022 Compile_Time_Known_Value
(Rf
)
1023 and then Expr_Value
(Lf
) = Expr_Value
(Rf
)
1027 -- False if Nkind of the two nodes is different for remaining cases
1029 elsif Nkind
(Lf
) /= Nkind
(Rf
) then
1032 -- True if both 'First or 'Last values applying to the same entity
1033 -- (first and last don't change even if value does). Note that we
1034 -- need this even with the calls to Compare_Fixup, to handle the
1035 -- case of unconstrained array attributes where Compare_Fixup
1036 -- cannot find useful bounds.
1038 elsif Nkind
(Lf
) = N_Attribute_Reference
1039 and then Attribute_Name
(Lf
) = Attribute_Name
(Rf
)
1040 and then Nam_In
(Attribute_Name
(Lf
), Name_First
, Name_Last
)
1041 and then Nkind_In
(Prefix
(Lf
), N_Identifier
, N_Expanded_Name
)
1042 and then Nkind_In
(Prefix
(Rf
), N_Identifier
, N_Expanded_Name
)
1043 and then Entity
(Prefix
(Lf
)) = Entity
(Prefix
(Rf
))
1044 and then Is_Same_Subscript
(Expressions
(Lf
), Expressions
(Rf
))
1048 -- True if the same selected component from the same record
1050 elsif Nkind
(Lf
) = N_Selected_Component
1051 and then Selector_Name
(Lf
) = Selector_Name
(Rf
)
1052 and then Is_Same_Value
(Prefix
(Lf
), Prefix
(Rf
))
1056 -- True if the same unary operator applied to the same operand
1058 elsif Nkind
(Lf
) in N_Unary_Op
1059 and then Is_Same_Value
(Right_Opnd
(Lf
), Right_Opnd
(Rf
))
1063 -- True if the same binary operator applied to the same operands
1065 elsif Nkind
(Lf
) in N_Binary_Op
1066 and then Is_Same_Value
(Left_Opnd
(Lf
), Left_Opnd
(Rf
))
1067 and then Is_Same_Value
(Right_Opnd
(Lf
), Right_Opnd
(Rf
))
1071 -- All other cases, we can't tell, so return False
1078 -- Start of processing for Compile_Time_Compare
1081 Diff
.all := No_Uint
;
1083 -- In preanalysis mode, always return Unknown unless the expression
1084 -- is static. It is too early to be thinking we know the result of a
1085 -- comparison, save that judgment for the full analysis. This is
1086 -- particularly important in the case of pre and postconditions, which
1087 -- otherwise can be prematurely collapsed into having True or False
1088 -- conditions when this is inappropriate.
1090 if not (Full_Analysis
1091 or else (Is_OK_Static_Expression
(L
)
1093 Is_OK_Static_Expression
(R
)))
1098 -- If either operand could raise constraint error, then we cannot
1099 -- know the result at compile time (since CE may be raised).
1101 if not (Cannot_Raise_Constraint_Error
(L
)
1103 Cannot_Raise_Constraint_Error
(R
))
1108 -- Identical operands are most certainly equal
1114 -- If expressions have no types, then do not attempt to determine if
1115 -- they are the same, since something funny is going on. One case in
1116 -- which this happens is during generic template analysis, when bounds
1117 -- are not fully analyzed.
1119 if No
(Ltyp
) or else No
(Rtyp
) then
1123 -- These get reset to the base type for the case of entities where
1124 -- Is_Known_Valid is not set. This takes care of handling possible
1125 -- invalid representations using the value of the base type, in
1126 -- accordance with RM 13.9.1(10).
1128 Ltyp
:= Underlying_Type
(Ltyp
);
1129 Rtyp
:= Underlying_Type
(Rtyp
);
1131 -- Same rationale as above, but for Underlying_Type instead of Etype
1133 if No
(Ltyp
) or else No
(Rtyp
) then
1137 -- We do not attempt comparisons for packed arrays arrays represented as
1138 -- modular types, where the semantics of comparison is quite different.
1140 if Is_Packed_Array_Impl_Type
(Ltyp
)
1141 and then Is_Modular_Integer_Type
(Ltyp
)
1145 -- For access types, the only time we know the result at compile time
1146 -- (apart from identical operands, which we handled already) is if we
1147 -- know one operand is null and the other is not, or both operands are
1150 elsif Is_Access_Type
(Ltyp
) then
1151 if Known_Null
(L
) then
1152 if Known_Null
(R
) then
1154 elsif Known_Non_Null
(R
) then
1160 elsif Known_Non_Null
(L
) and then Known_Null
(R
) then
1167 -- Case where comparison involves two compile time known values
1169 elsif Compile_Time_Known_Value
(L
)
1171 Compile_Time_Known_Value
(R
)
1173 -- For the floating-point case, we have to be a little careful, since
1174 -- at compile time we are dealing with universal exact values, but at
1175 -- runtime, these will be in non-exact target form. That's why the
1176 -- returned results are LE and GE below instead of LT and GT.
1178 if Is_Floating_Point_Type
(Ltyp
)
1180 Is_Floating_Point_Type
(Rtyp
)
1183 Lo
: constant Ureal
:= Expr_Value_R
(L
);
1184 Hi
: constant Ureal
:= Expr_Value_R
(R
);
1195 -- For string types, we have two string literals and we proceed to
1196 -- compare them using the Ada style dictionary string comparison.
1198 elsif not Is_Scalar_Type
(Ltyp
) then
1200 Lstring
: constant String_Id
:= Strval
(Expr_Value_S
(L
));
1201 Rstring
: constant String_Id
:= Strval
(Expr_Value_S
(R
));
1202 Llen
: constant Nat
:= String_Length
(Lstring
);
1203 Rlen
: constant Nat
:= String_Length
(Rstring
);
1206 for J
in 1 .. Nat
'Min (Llen
, Rlen
) loop
1208 LC
: constant Char_Code
:= Get_String_Char
(Lstring
, J
);
1209 RC
: constant Char_Code
:= Get_String_Char
(Rstring
, J
);
1221 elsif Llen
> Rlen
then
1228 -- For remaining scalar cases we know exactly (note that this does
1229 -- include the fixed-point case, where we know the run time integer
1234 Lo
: constant Uint
:= Expr_Value
(L
);
1235 Hi
: constant Uint
:= Expr_Value
(R
);
1238 Diff
.all := Hi
- Lo
;
1243 Diff
.all := Lo
- Hi
;
1249 -- Cases where at least one operand is not known at compile time
1252 -- Remaining checks apply only for discrete types
1254 if not Is_Discrete_Type
(Ltyp
)
1256 not Is_Discrete_Type
(Rtyp
)
1261 -- Defend against generic types, or actually any expressions that
1262 -- contain a reference to a generic type from within a generic
1263 -- template. We don't want to do any range analysis of such
1264 -- expressions for two reasons. First, the bounds of a generic type
1265 -- itself are junk and cannot be used for any kind of analysis.
1266 -- Second, we may have a case where the range at run time is indeed
1267 -- known, but we don't want to do compile time analysis in the
1268 -- template based on that range since in an instance the value may be
1269 -- static, and able to be elaborated without reference to the bounds
1270 -- of types involved. As an example, consider:
1272 -- (F'Pos (F'Last) + 1) > Integer'Last
1274 -- The expression on the left side of > is Universal_Integer and thus
1275 -- acquires the type Integer for evaluation at run time, and at run
1276 -- time it is true that this condition is always False, but within
1277 -- an instance F may be a type with a static range greater than the
1278 -- range of Integer, and the expression statically evaluates to True.
1280 if References_Generic_Formal_Type
(L
)
1282 References_Generic_Formal_Type
(R
)
1287 -- Replace types by base types for the case of values which are not
1288 -- known to have valid representations. This takes care of properly
1289 -- dealing with invalid representations.
1291 if not Assume_Valid
then
1292 if not (Is_Entity_Name
(L
)
1293 and then (Is_Known_Valid
(Entity
(L
))
1294 or else Assume_No_Invalid_Values
))
1296 Ltyp
:= Underlying_Type
(Base_Type
(Ltyp
));
1299 if not (Is_Entity_Name
(R
)
1300 and then (Is_Known_Valid
(Entity
(R
))
1301 or else Assume_No_Invalid_Values
))
1303 Rtyp
:= Underlying_Type
(Base_Type
(Rtyp
));
1307 -- First attempt is to decompose the expressions to extract a
1308 -- constant offset resulting from the use of any of the forms:
1315 -- Then we see if the two expressions are the same value, and if so
1316 -- the result is obtained by comparing the offsets.
1318 -- Note: the reason we do this test first is that it returns only
1319 -- decisive results (with diff set), where other tests, like the
1320 -- range test, may not be as so decisive. Consider for example
1321 -- J .. J + 1. This code can conclude LT with a difference of 1,
1322 -- even if the range of J is not known.
1331 Compare_Decompose
(L
, Lnode
, Loffs
);
1332 Compare_Decompose
(R
, Rnode
, Roffs
);
1334 if Is_Same_Value
(Lnode
, Rnode
) then
1335 if Loffs
= Roffs
then
1337 elsif Loffs
< Roffs
then
1338 Diff
.all := Roffs
- Loffs
;
1341 Diff
.all := Loffs
- Roffs
;
1347 -- Next, try range analysis and see if operand ranges are disjoint
1355 -- True if each range is a single point
1358 Determine_Range
(L
, LOK
, LLo
, LHi
, Assume_Valid
);
1359 Determine_Range
(R
, ROK
, RLo
, RHi
, Assume_Valid
);
1362 Single
:= (LLo
= LHi
) and then (RLo
= RHi
);
1365 if Single
and Assume_Valid
then
1366 Diff
.all := RLo
- LLo
;
1371 elsif RHi
< LLo
then
1372 if Single
and Assume_Valid
then
1373 Diff
.all := LLo
- RLo
;
1378 elsif Single
and then LLo
= RLo
then
1380 -- If the range includes a single literal and we can assume
1381 -- validity then the result is known even if an operand is
1384 if Assume_Valid
then
1390 elsif LHi
= RLo
then
1393 elsif RHi
= LLo
then
1396 elsif not Is_Known_Valid_Operand
(L
)
1397 and then not Assume_Valid
1399 if Is_Same_Value
(L
, R
) then
1406 -- If the range of either operand cannot be determined, nothing
1407 -- further can be inferred.
1414 -- Here is where we check for comparisons against maximum bounds of
1415 -- types, where we know that no value can be outside the bounds of
1416 -- the subtype. Note that this routine is allowed to assume that all
1417 -- expressions are within their subtype bounds. Callers wishing to
1418 -- deal with possibly invalid values must in any case take special
1419 -- steps (e.g. conversions to larger types) to avoid this kind of
1420 -- optimization, which is always considered to be valid. We do not
1421 -- attempt this optimization with generic types, since the type
1422 -- bounds may not be meaningful in this case.
1424 -- We are in danger of an infinite recursion here. It does not seem
1425 -- useful to go more than one level deep, so the parameter Rec is
1426 -- used to protect ourselves against this infinite recursion.
1430 -- See if we can get a decisive check against one operand and a
1431 -- bound of the other operand (four possible tests here). Note
1432 -- that we avoid testing junk bounds of a generic type.
1434 if not Is_Generic_Type
(Rtyp
) then
1435 case Compile_Time_Compare
(L
, Type_Low_Bound
(Rtyp
),
1437 Assume_Valid
, Rec
=> True)
1439 when LT
=> return LT
;
1440 when LE
=> return LE
;
1441 when EQ
=> return LE
;
1442 when others => null;
1445 case Compile_Time_Compare
(L
, Type_High_Bound
(Rtyp
),
1447 Assume_Valid
, Rec
=> True)
1449 when GT
=> return GT
;
1450 when GE
=> return GE
;
1451 when EQ
=> return GE
;
1452 when others => null;
1456 if not Is_Generic_Type
(Ltyp
) then
1457 case Compile_Time_Compare
(Type_Low_Bound
(Ltyp
), R
,
1459 Assume_Valid
, Rec
=> True)
1461 when GT
=> return GT
;
1462 when GE
=> return GE
;
1463 when EQ
=> return GE
;
1464 when others => null;
1467 case Compile_Time_Compare
(Type_High_Bound
(Ltyp
), R
,
1469 Assume_Valid
, Rec
=> True)
1471 when LT
=> return LT
;
1472 when LE
=> return LE
;
1473 when EQ
=> return LE
;
1474 when others => null;
1479 -- Next attempt is to see if we have an entity compared with a
1480 -- compile time known value, where there is a current value
1481 -- conditional for the entity which can tell us the result.
1485 -- Entity variable (left operand)
1488 -- Value (right operand)
1491 -- If False, we have reversed the operands
1494 -- Comparison operator kind from Get_Current_Value_Condition call
1497 -- Value from Get_Current_Value_Condition call
1502 Result
: Compare_Result
;
1503 -- Known result before inversion
1506 if Is_Entity_Name
(L
)
1507 and then Compile_Time_Known_Value
(R
)
1510 Val
:= Expr_Value
(R
);
1513 elsif Is_Entity_Name
(R
)
1514 and then Compile_Time_Known_Value
(L
)
1517 Val
:= Expr_Value
(L
);
1520 -- That was the last chance at finding a compile time result
1526 Get_Current_Value_Condition
(Var
, Op
, Opn
);
1528 -- That was the last chance, so if we got nothing return
1534 Opv
:= Expr_Value
(Opn
);
1536 -- We got a comparison, so we might have something interesting
1538 -- Convert LE to LT and GE to GT, just so we have fewer cases
1540 if Op
= N_Op_Le
then
1544 elsif Op
= N_Op_Ge
then
1549 -- Deal with equality case
1551 if Op
= N_Op_Eq
then
1554 elsif Opv
< Val
then
1560 -- Deal with inequality case
1562 elsif Op
= N_Op_Ne
then
1569 -- Deal with greater than case
1571 elsif Op
= N_Op_Gt
then
1574 elsif Opv
= Val
- 1 then
1580 -- Deal with less than case
1582 else pragma Assert
(Op
= N_Op_Lt
);
1585 elsif Opv
= Val
+ 1 then
1592 -- Deal with inverting result
1596 when GT
=> return LT
;
1597 when GE
=> return LE
;
1598 when LT
=> return GT
;
1599 when LE
=> return GE
;
1600 when others => return Result
;
1607 end Compile_Time_Compare
;
1609 -------------------------------
1610 -- Compile_Time_Known_Bounds --
1611 -------------------------------
1613 function Compile_Time_Known_Bounds
(T
: Entity_Id
) return Boolean is
1618 if T
= Any_Composite
or else not Is_Array_Type
(T
) then
1622 Indx
:= First_Index
(T
);
1623 while Present
(Indx
) loop
1624 Typ
:= Underlying_Type
(Etype
(Indx
));
1626 -- Never look at junk bounds of a generic type
1628 if Is_Generic_Type
(Typ
) then
1632 -- Otherwise check bounds for compile time known
1634 if not Compile_Time_Known_Value
(Type_Low_Bound
(Typ
)) then
1636 elsif not Compile_Time_Known_Value
(Type_High_Bound
(Typ
)) then
1644 end Compile_Time_Known_Bounds
;
1646 ------------------------------
1647 -- Compile_Time_Known_Value --
1648 ------------------------------
1650 function Compile_Time_Known_Value
(Op
: Node_Id
) return Boolean is
1651 K
: constant Node_Kind
:= Nkind
(Op
);
1652 CV_Ent
: CV_Entry
renames CV_Cache
(Nat
(Op
) mod CV_Cache_Size
);
1655 -- Never known at compile time if bad type or raises constraint error
1656 -- or empty (latter case occurs only as a result of a previous error).
1659 Check_Error_Detected
;
1663 or else Etype
(Op
) = Any_Type
1664 or else Raises_Constraint_Error
(Op
)
1669 -- If we have an entity name, then see if it is the name of a constant
1670 -- and if so, test the corresponding constant value, or the name of
1671 -- an enumeration literal, which is always a constant.
1673 if Present
(Etype
(Op
)) and then Is_Entity_Name
(Op
) then
1675 E
: constant Entity_Id
:= Entity
(Op
);
1679 -- Never known at compile time if it is a packed array value.
1680 -- We might want to try to evaluate these at compile time one
1681 -- day, but we do not make that attempt now.
1683 if Is_Packed_Array_Impl_Type
(Etype
(Op
)) then
1687 if Ekind
(E
) = E_Enumeration_Literal
then
1690 elsif Ekind
(E
) = E_Constant
then
1691 V
:= Constant_Value
(E
);
1692 return Present
(V
) and then Compile_Time_Known_Value
(V
);
1696 -- We have a value, see if it is compile time known
1699 -- Integer literals are worth storing in the cache
1701 if K
= N_Integer_Literal
then
1703 CV_Ent
.V
:= Intval
(Op
);
1706 -- Other literals and NULL are known at compile time
1709 Nkind_In
(K
, N_Character_Literal
,
1718 -- If we fall through, not known at compile time
1722 -- If we get an exception while trying to do this test, then some error
1723 -- has occurred, and we simply say that the value is not known after all
1728 end Compile_Time_Known_Value
;
1730 --------------------------------------
1731 -- Compile_Time_Known_Value_Or_Aggr --
1732 --------------------------------------
1734 function Compile_Time_Known_Value_Or_Aggr
(Op
: Node_Id
) return Boolean is
1736 -- If we have an entity name, then see if it is the name of a constant
1737 -- and if so, test the corresponding constant value, or the name of
1738 -- an enumeration literal, which is always a constant.
1740 if Is_Entity_Name
(Op
) then
1742 E
: constant Entity_Id
:= Entity
(Op
);
1746 if Ekind
(E
) = E_Enumeration_Literal
then
1749 elsif Ekind
(E
) /= E_Constant
then
1753 V
:= Constant_Value
(E
);
1755 and then Compile_Time_Known_Value_Or_Aggr
(V
);
1759 -- We have a value, see if it is compile time known
1762 if Compile_Time_Known_Value
(Op
) then
1765 elsif Nkind
(Op
) = N_Aggregate
then
1767 if Present
(Expressions
(Op
)) then
1771 Expr
:= First
(Expressions
(Op
));
1772 while Present
(Expr
) loop
1773 if not Compile_Time_Known_Value_Or_Aggr
(Expr
) then
1782 if Present
(Component_Associations
(Op
)) then
1787 Cass
:= First
(Component_Associations
(Op
));
1788 while Present
(Cass
) loop
1790 Compile_Time_Known_Value_Or_Aggr
(Expression
(Cass
))
1802 -- All other types of values are not known at compile time
1809 end Compile_Time_Known_Value_Or_Aggr
;
1811 ---------------------------------------
1812 -- CRT_Safe_Compile_Time_Known_Value --
1813 ---------------------------------------
1815 function CRT_Safe_Compile_Time_Known_Value
(Op
: Node_Id
) return Boolean is
1817 if (Configurable_Run_Time_Mode
or No_Run_Time_Mode
)
1818 and then not Is_OK_Static_Expression
(Op
)
1822 return Compile_Time_Known_Value
(Op
);
1824 end CRT_Safe_Compile_Time_Known_Value
;
1830 -- This is only called for actuals of functions that are not predefined
1831 -- operators (which have already been rewritten as operators at this
1832 -- stage), so the call can never be folded, and all that needs doing for
1833 -- the actual is to do the check for a non-static context.
1835 procedure Eval_Actual
(N
: Node_Id
) is
1837 Check_Non_Static_Context
(N
);
1840 --------------------
1841 -- Eval_Allocator --
1842 --------------------
1844 -- Allocators are never static, so all we have to do is to do the
1845 -- check for a non-static context if an expression is present.
1847 procedure Eval_Allocator
(N
: Node_Id
) is
1848 Expr
: constant Node_Id
:= Expression
(N
);
1850 if Nkind
(Expr
) = N_Qualified_Expression
then
1851 Check_Non_Static_Context
(Expression
(Expr
));
1855 ------------------------
1856 -- Eval_Arithmetic_Op --
1857 ------------------------
1859 -- Arithmetic operations are static functions, so the result is static
1860 -- if both operands are static (RM 4.9(7), 4.9(20)).
1862 procedure Eval_Arithmetic_Op
(N
: Node_Id
) is
1863 Left
: constant Node_Id
:= Left_Opnd
(N
);
1864 Right
: constant Node_Id
:= Right_Opnd
(N
);
1865 Ltype
: constant Entity_Id
:= Etype
(Left
);
1866 Rtype
: constant Entity_Id
:= Etype
(Right
);
1867 Otype
: Entity_Id
:= Empty
;
1872 -- If not foldable we are done
1874 Test_Expression_Is_Foldable
(N
, Left
, Right
, Stat
, Fold
);
1880 -- Otherwise attempt to fold
1882 if Is_Universal_Numeric_Type
(Etype
(Left
))
1884 Is_Universal_Numeric_Type
(Etype
(Right
))
1886 Otype
:= Find_Universal_Operator_Type
(N
);
1889 -- Fold for cases where both operands are of integer type
1891 if Is_Integer_Type
(Ltype
) and then Is_Integer_Type
(Rtype
) then
1893 Left_Int
: constant Uint
:= Expr_Value
(Left
);
1894 Right_Int
: constant Uint
:= Expr_Value
(Right
);
1900 Result
:= Left_Int
+ Right_Int
;
1902 when N_Op_Subtract
=>
1903 Result
:= Left_Int
- Right_Int
;
1905 when N_Op_Multiply
=>
1908 (Num_Bits
(Left_Int
) + Num_Bits
(Right_Int
)))
1910 Result
:= Left_Int
* Right_Int
;
1917 -- The exception Constraint_Error is raised by integer
1918 -- division, rem and mod if the right operand is zero.
1920 if Right_Int
= 0 then
1922 -- When SPARK_Mode is On, force a warning instead of
1923 -- an error in that case, as this likely corresponds
1924 -- to deactivated code.
1926 Apply_Compile_Time_Constraint_Error
1927 (N
, "division by zero", CE_Divide_By_Zero
,
1928 Warn
=> not Stat
or SPARK_Mode
= On
);
1929 Set_Raises_Constraint_Error
(N
);
1932 -- Otherwise we can do the division
1935 Result
:= Left_Int
/ Right_Int
;
1940 -- The exception Constraint_Error is raised by integer
1941 -- division, rem and mod if the right operand is zero.
1943 if Right_Int
= 0 then
1945 -- When SPARK_Mode is On, force a warning instead of
1946 -- an error in that case, as this likely corresponds
1947 -- to deactivated code.
1949 Apply_Compile_Time_Constraint_Error
1950 (N
, "mod with zero divisor", CE_Divide_By_Zero
,
1951 Warn
=> not Stat
or SPARK_Mode
= On
);
1955 Result
:= Left_Int
mod Right_Int
;
1960 -- The exception Constraint_Error is raised by integer
1961 -- division, rem and mod if the right operand is zero.
1963 if Right_Int
= 0 then
1965 -- When SPARK_Mode is On, force a warning instead of
1966 -- an error in that case, as this likely corresponds
1967 -- to deactivated code.
1969 Apply_Compile_Time_Constraint_Error
1970 (N
, "rem with zero divisor", CE_Divide_By_Zero
,
1971 Warn
=> not Stat
or SPARK_Mode
= On
);
1975 Result
:= Left_Int
rem Right_Int
;
1979 raise Program_Error
;
1982 -- Adjust the result by the modulus if the type is a modular type
1984 if Is_Modular_Integer_Type
(Ltype
) then
1985 Result
:= Result
mod Modulus
(Ltype
);
1987 -- For a signed integer type, check non-static overflow
1989 elsif (not Stat
) and then Is_Signed_Integer_Type
(Ltype
) then
1991 BT
: constant Entity_Id
:= Base_Type
(Ltype
);
1992 Lo
: constant Uint
:= Expr_Value
(Type_Low_Bound
(BT
));
1993 Hi
: constant Uint
:= Expr_Value
(Type_High_Bound
(BT
));
1995 if Result
< Lo
or else Result
> Hi
then
1996 Apply_Compile_Time_Constraint_Error
1997 (N
, "value not in range of }??",
1998 CE_Overflow_Check_Failed
,
2005 -- If we get here we can fold the result
2007 Fold_Uint
(N
, Result
, Stat
);
2010 -- Cases where at least one operand is a real. We handle the cases of
2011 -- both reals, or mixed/real integer cases (the latter happen only for
2012 -- divide and multiply, and the result is always real).
2014 elsif Is_Real_Type
(Ltype
) or else Is_Real_Type
(Rtype
) then
2021 if Is_Real_Type
(Ltype
) then
2022 Left_Real
:= Expr_Value_R
(Left
);
2024 Left_Real
:= UR_From_Uint
(Expr_Value
(Left
));
2027 if Is_Real_Type
(Rtype
) then
2028 Right_Real
:= Expr_Value_R
(Right
);
2030 Right_Real
:= UR_From_Uint
(Expr_Value
(Right
));
2033 if Nkind
(N
) = N_Op_Add
then
2034 Result
:= Left_Real
+ Right_Real
;
2036 elsif Nkind
(N
) = N_Op_Subtract
then
2037 Result
:= Left_Real
- Right_Real
;
2039 elsif Nkind
(N
) = N_Op_Multiply
then
2040 Result
:= Left_Real
* Right_Real
;
2042 else pragma Assert
(Nkind
(N
) = N_Op_Divide
);
2043 if UR_Is_Zero
(Right_Real
) then
2044 Apply_Compile_Time_Constraint_Error
2045 (N
, "division by zero", CE_Divide_By_Zero
);
2049 Result
:= Left_Real
/ Right_Real
;
2052 Fold_Ureal
(N
, Result
, Stat
);
2056 -- If the operator was resolved to a specific type, make sure that type
2057 -- is frozen even if the expression is folded into a literal (which has
2058 -- a universal type).
2060 if Present
(Otype
) then
2061 Freeze_Before
(N
, Otype
);
2063 end Eval_Arithmetic_Op
;
2065 ----------------------------
2066 -- Eval_Character_Literal --
2067 ----------------------------
2069 -- Nothing to be done
2071 procedure Eval_Character_Literal
(N
: Node_Id
) is
2072 pragma Warnings
(Off
, N
);
2075 end Eval_Character_Literal
;
2081 -- Static function calls are either calls to predefined operators
2082 -- with static arguments, or calls to functions that rename a literal.
2083 -- Only the latter case is handled here, predefined operators are
2084 -- constant-folded elsewhere.
2086 -- If the function is itself inherited (see 7423-001) the literal of
2087 -- the parent type must be explicitly converted to the return type
2090 procedure Eval_Call
(N
: Node_Id
) is
2091 Loc
: constant Source_Ptr
:= Sloc
(N
);
2092 Typ
: constant Entity_Id
:= Etype
(N
);
2096 if Nkind
(N
) = N_Function_Call
2097 and then No
(Parameter_Associations
(N
))
2098 and then Is_Entity_Name
(Name
(N
))
2099 and then Present
(Alias
(Entity
(Name
(N
))))
2100 and then Is_Enumeration_Type
(Base_Type
(Typ
))
2102 Lit
:= Ultimate_Alias
(Entity
(Name
(N
)));
2104 if Ekind
(Lit
) = E_Enumeration_Literal
then
2105 if Base_Type
(Etype
(Lit
)) /= Base_Type
(Typ
) then
2107 (N
, Convert_To
(Typ
, New_Occurrence_Of
(Lit
, Loc
)));
2109 Rewrite
(N
, New_Occurrence_Of
(Lit
, Loc
));
2117 --------------------------
2118 -- Eval_Case_Expression --
2119 --------------------------
2121 -- A conditional expression is static if all its conditions and dependent
2122 -- expressions are static. Note that we do not care if the dependent
2123 -- expressions raise CE, except for the one that will be selected.
2125 procedure Eval_Case_Expression
(N
: Node_Id
) is
2130 Set_Is_Static_Expression
(N
, False);
2132 if not Is_Static_Expression
(Expression
(N
)) then
2133 Check_Non_Static_Context
(Expression
(N
));
2137 -- First loop, make sure all the alternatives are static expressions
2138 -- none of which raise Constraint_Error. We make the constraint error
2139 -- check because part of the legality condition for a correct static
2140 -- case expression is that the cases are covered, like any other case
2141 -- expression. And we can't do that if any of the conditions raise an
2142 -- exception, so we don't even try to evaluate if that is the case.
2144 Alt
:= First
(Alternatives
(N
));
2145 while Present
(Alt
) loop
2147 -- The expression must be static, but we don't care at this stage
2148 -- if it raises Constraint_Error (the alternative might not match,
2149 -- in which case the expression is statically unevaluated anyway).
2151 if not Is_Static_Expression
(Expression
(Alt
)) then
2152 Check_Non_Static_Context
(Expression
(Alt
));
2156 -- The choices of a case always have to be static, and cannot raise
2157 -- an exception. If this condition is not met, then the expression
2158 -- is plain illegal, so just abandon evaluation attempts. No need
2159 -- to check non-static context when we have something illegal anyway.
2161 if not Is_OK_Static_Choice_List
(Discrete_Choices
(Alt
)) then
2168 -- OK, if the above loop gets through it means that all choices are OK
2169 -- static (don't raise exceptions), so the whole case is static, and we
2170 -- can find the matching alternative.
2172 Set_Is_Static_Expression
(N
);
2174 -- Now to deal with propagating a possible constraint error
2176 -- If the selecting expression raises CE, propagate and we are done
2178 if Raises_Constraint_Error
(Expression
(N
)) then
2179 Set_Raises_Constraint_Error
(N
);
2181 -- Otherwise we need to check the alternatives to find the matching
2182 -- one. CE's in other than the matching one are not relevant. But we
2183 -- do need to check the matching one. Unlike the first loop, we do not
2184 -- have to go all the way through, when we find the matching one, quit.
2187 Alt
:= First
(Alternatives
(N
));
2190 -- We must find a match among the alternatives. If not, this must
2191 -- be due to other errors, so just ignore, leaving as non-static.
2194 Set_Is_Static_Expression
(N
, False);
2198 -- Otherwise loop through choices of this alternative
2200 Choice
:= First
(Discrete_Choices
(Alt
));
2201 while Present
(Choice
) loop
2203 -- If we find a matching choice, then the Expression of this
2204 -- alternative replaces N (Raises_Constraint_Error flag is
2205 -- included, so we don't have to special case that).
2207 if Choice_Matches
(Expression
(N
), Choice
) = Match
then
2208 Rewrite
(N
, Relocate_Node
(Expression
(Alt
)));
2218 end Eval_Case_Expression
;
2220 ------------------------
2221 -- Eval_Concatenation --
2222 ------------------------
2224 -- Concatenation is a static function, so the result is static if both
2225 -- operands are static (RM 4.9(7), 4.9(21)).
2227 procedure Eval_Concatenation
(N
: Node_Id
) is
2228 Left
: constant Node_Id
:= Left_Opnd
(N
);
2229 Right
: constant Node_Id
:= Right_Opnd
(N
);
2230 C_Typ
: constant Entity_Id
:= Root_Type
(Component_Type
(Etype
(N
)));
2235 -- Concatenation is never static in Ada 83, so if Ada 83 check operand
2236 -- non-static context.
2238 if Ada_Version
= Ada_83
2239 and then Comes_From_Source
(N
)
2241 Check_Non_Static_Context
(Left
);
2242 Check_Non_Static_Context
(Right
);
2246 -- If not foldable we are done. In principle concatenation that yields
2247 -- any string type is static (i.e. an array type of character types).
2248 -- However, character types can include enumeration literals, and
2249 -- concatenation in that case cannot be described by a literal, so we
2250 -- only consider the operation static if the result is an array of
2251 -- (a descendant of) a predefined character type.
2253 Test_Expression_Is_Foldable
(N
, Left
, Right
, Stat
, Fold
);
2255 if not (Is_Standard_Character_Type
(C_Typ
) and then Fold
) then
2256 Set_Is_Static_Expression
(N
, False);
2260 -- Compile time string concatenation
2262 -- ??? Note that operands that are aggregates can be marked as static,
2263 -- so we should attempt at a later stage to fold concatenations with
2267 Left_Str
: constant Node_Id
:= Get_String_Val
(Left
);
2269 Right_Str
: constant Node_Id
:= Get_String_Val
(Right
);
2270 Folded_Val
: String_Id
;
2273 -- Establish new string literal, and store left operand. We make
2274 -- sure to use the special Start_String that takes an operand if
2275 -- the left operand is a string literal. Since this is optimized
2276 -- in the case where that is the most recently created string
2277 -- literal, we ensure efficient time/space behavior for the
2278 -- case of a concatenation of a series of string literals.
2280 if Nkind
(Left_Str
) = N_String_Literal
then
2281 Left_Len
:= String_Length
(Strval
(Left_Str
));
2283 -- If the left operand is the empty string, and the right operand
2284 -- is a string literal (the case of "" & "..."), the result is the
2285 -- value of the right operand. This optimization is important when
2286 -- Is_Folded_In_Parser, to avoid copying an enormous right
2289 if Left_Len
= 0 and then Nkind
(Right_Str
) = N_String_Literal
then
2290 Folded_Val
:= Strval
(Right_Str
);
2292 Start_String
(Strval
(Left_Str
));
2297 Store_String_Char
(UI_To_CC
(Char_Literal_Value
(Left_Str
)));
2301 -- Now append the characters of the right operand, unless we
2302 -- optimized the "" & "..." case above.
2304 if Nkind
(Right_Str
) = N_String_Literal
then
2305 if Left_Len
/= 0 then
2306 Store_String_Chars
(Strval
(Right_Str
));
2307 Folded_Val
:= End_String
;
2310 Store_String_Char
(UI_To_CC
(Char_Literal_Value
(Right_Str
)));
2311 Folded_Val
:= End_String
;
2314 Set_Is_Static_Expression
(N
, Stat
);
2316 -- If left operand is the empty string, the result is the
2317 -- right operand, including its bounds if anomalous.
2320 and then Is_Array_Type
(Etype
(Right
))
2321 and then Etype
(Right
) /= Any_String
2323 Set_Etype
(N
, Etype
(Right
));
2326 Fold_Str
(N
, Folded_Val
, Static
=> Stat
);
2328 end Eval_Concatenation
;
2330 ----------------------
2331 -- Eval_Entity_Name --
2332 ----------------------
2334 -- This procedure is used for identifiers and expanded names other than
2335 -- named numbers (see Eval_Named_Integer, Eval_Named_Real. These are
2336 -- static if they denote a static constant (RM 4.9(6)) or if the name
2337 -- denotes an enumeration literal (RM 4.9(22)).
2339 procedure Eval_Entity_Name
(N
: Node_Id
) is
2340 Def_Id
: constant Entity_Id
:= Entity
(N
);
2344 -- Enumeration literals are always considered to be constants
2345 -- and cannot raise constraint error (RM 4.9(22)).
2347 if Ekind
(Def_Id
) = E_Enumeration_Literal
then
2348 Set_Is_Static_Expression
(N
);
2351 -- A name is static if it denotes a static constant (RM 4.9(5)), and
2352 -- we also copy Raise_Constraint_Error. Notice that even if non-static,
2353 -- it does not violate 10.2.1(8) here, since this is not a variable.
2355 elsif Ekind
(Def_Id
) = E_Constant
then
2357 -- Deferred constants must always be treated as nonstatic outside the
2358 -- scope of their full view.
2360 if Present
(Full_View
(Def_Id
))
2361 and then not In_Open_Scopes
(Scope
(Def_Id
))
2365 Val
:= Constant_Value
(Def_Id
);
2368 if Present
(Val
) then
2369 Set_Is_Static_Expression
2370 (N
, Is_Static_Expression
(Val
)
2371 and then Is_Static_Subtype
(Etype
(Def_Id
)));
2372 Set_Raises_Constraint_Error
(N
, Raises_Constraint_Error
(Val
));
2374 if not Is_Static_Expression
(N
)
2375 and then not Is_Generic_Type
(Etype
(N
))
2377 Validate_Static_Object_Name
(N
);
2380 -- Mark constant condition in SCOs
2383 and then Comes_From_Source
(N
)
2384 and then Is_Boolean_Type
(Etype
(Def_Id
))
2385 and then Compile_Time_Known_Value
(N
)
2387 Set_SCO_Condition
(N
, Expr_Value_E
(N
) = Standard_True
);
2394 -- Fall through if the name is not static
2396 Validate_Static_Object_Name
(N
);
2397 end Eval_Entity_Name
;
2399 ------------------------
2400 -- Eval_If_Expression --
2401 ------------------------
2403 -- We can fold to a static expression if the condition and both dependent
2404 -- expressions are static. Otherwise, the only required processing is to do
2405 -- the check for non-static context for the then and else expressions.
2407 procedure Eval_If_Expression
(N
: Node_Id
) is
2408 Condition
: constant Node_Id
:= First
(Expressions
(N
));
2409 Then_Expr
: constant Node_Id
:= Next
(Condition
);
2410 Else_Expr
: constant Node_Id
:= Next
(Then_Expr
);
2412 Non_Result
: Node_Id
;
2414 Rstat
: constant Boolean :=
2415 Is_Static_Expression
(Condition
)
2417 Is_Static_Expression
(Then_Expr
)
2419 Is_Static_Expression
(Else_Expr
);
2420 -- True if result is static
2423 -- If result not static, nothing to do, otherwise set static result
2428 Set_Is_Static_Expression
(N
);
2431 -- If any operand is Any_Type, just propagate to result and do not try
2432 -- to fold, this prevents cascaded errors.
2434 if Etype
(Condition
) = Any_Type
or else
2435 Etype
(Then_Expr
) = Any_Type
or else
2436 Etype
(Else_Expr
) = Any_Type
2438 Set_Etype
(N
, Any_Type
);
2439 Set_Is_Static_Expression
(N
, False);
2443 -- If condition raises constraint error then we have already signaled
2444 -- an error, and we just propagate to the result and do not fold.
2446 if Raises_Constraint_Error
(Condition
) then
2447 Set_Raises_Constraint_Error
(N
);
2451 -- Static case where we can fold. Note that we don't try to fold cases
2452 -- where the condition is known at compile time, but the result is
2453 -- non-static. This avoids possible cases of infinite recursion where
2454 -- the expander puts in a redundant test and we remove it. Instead we
2455 -- deal with these cases in the expander.
2457 -- Select result operand
2459 if Is_True
(Expr_Value
(Condition
)) then
2460 Result
:= Then_Expr
;
2461 Non_Result
:= Else_Expr
;
2463 Result
:= Else_Expr
;
2464 Non_Result
:= Then_Expr
;
2467 -- Note that it does not matter if the non-result operand raises a
2468 -- Constraint_Error, but if the result raises constraint error then we
2469 -- replace the node with a raise constraint error. This will properly
2470 -- propagate Raises_Constraint_Error since this flag is set in Result.
2472 if Raises_Constraint_Error
(Result
) then
2473 Rewrite_In_Raise_CE
(N
, Result
);
2474 Check_Non_Static_Context
(Non_Result
);
2476 -- Otherwise the result operand replaces the original node
2479 Rewrite
(N
, Relocate_Node
(Result
));
2480 Set_Is_Static_Expression
(N
);
2482 end Eval_If_Expression
;
2484 ----------------------------
2485 -- Eval_Indexed_Component --
2486 ----------------------------
2488 -- Indexed components are never static, so we need to perform the check
2489 -- for non-static context on the index values. Then, we check if the
2490 -- value can be obtained at compile time, even though it is non-static.
2492 procedure Eval_Indexed_Component
(N
: Node_Id
) is
2496 -- Check for non-static context on index values
2498 Expr
:= First
(Expressions
(N
));
2499 while Present
(Expr
) loop
2500 Check_Non_Static_Context
(Expr
);
2504 -- If the indexed component appears in an object renaming declaration
2505 -- then we do not want to try to evaluate it, since in this case we
2506 -- need the identity of the array element.
2508 if Nkind
(Parent
(N
)) = N_Object_Renaming_Declaration
then
2511 -- Similarly if the indexed component appears as the prefix of an
2512 -- attribute we don't want to evaluate it, because at least for
2513 -- some cases of attributes we need the identify (e.g. Access, Size)
2515 elsif Nkind
(Parent
(N
)) = N_Attribute_Reference
then
2519 -- Note: there are other cases, such as the left side of an assignment,
2520 -- or an OUT parameter for a call, where the replacement results in the
2521 -- illegal use of a constant, But these cases are illegal in the first
2522 -- place, so the replacement, though silly, is harmless.
2524 -- Now see if this is a constant array reference
2526 if List_Length
(Expressions
(N
)) = 1
2527 and then Is_Entity_Name
(Prefix
(N
))
2528 and then Ekind
(Entity
(Prefix
(N
))) = E_Constant
2529 and then Present
(Constant_Value
(Entity
(Prefix
(N
))))
2532 Loc
: constant Source_Ptr
:= Sloc
(N
);
2533 Arr
: constant Node_Id
:= Constant_Value
(Entity
(Prefix
(N
)));
2534 Sub
: constant Node_Id
:= First
(Expressions
(N
));
2540 -- Linear one's origin subscript value for array reference
2543 -- Lower bound of the first array index
2546 -- Value from constant array
2549 Atyp
:= Etype
(Arr
);
2551 if Is_Access_Type
(Atyp
) then
2552 Atyp
:= Designated_Type
(Atyp
);
2555 -- If we have an array type (we should have but perhaps there are
2556 -- error cases where this is not the case), then see if we can do
2557 -- a constant evaluation of the array reference.
2559 if Is_Array_Type
(Atyp
) and then Atyp
/= Any_Composite
then
2560 if Ekind
(Atyp
) = E_String_Literal_Subtype
then
2561 Lbd
:= String_Literal_Low_Bound
(Atyp
);
2563 Lbd
:= Type_Low_Bound
(Etype
(First_Index
(Atyp
)));
2566 if Compile_Time_Known_Value
(Sub
)
2567 and then Nkind
(Arr
) = N_Aggregate
2568 and then Compile_Time_Known_Value
(Lbd
)
2569 and then Is_Discrete_Type
(Component_Type
(Atyp
))
2571 Lin
:= UI_To_Int
(Expr_Value
(Sub
) - Expr_Value
(Lbd
)) + 1;
2573 if List_Length
(Expressions
(Arr
)) >= Lin
then
2574 Elm
:= Pick
(Expressions
(Arr
), Lin
);
2576 -- If the resulting expression is compile time known,
2577 -- then we can rewrite the indexed component with this
2578 -- value, being sure to mark the result as non-static.
2579 -- We also reset the Sloc, in case this generates an
2580 -- error later on (e.g. 136'Access).
2582 if Compile_Time_Known_Value
(Elm
) then
2583 Rewrite
(N
, Duplicate_Subexpr_No_Checks
(Elm
));
2584 Set_Is_Static_Expression
(N
, False);
2589 -- We can also constant-fold if the prefix is a string literal.
2590 -- This will be useful in an instantiation or an inlining.
2592 elsif Compile_Time_Known_Value
(Sub
)
2593 and then Nkind
(Arr
) = N_String_Literal
2594 and then Compile_Time_Known_Value
(Lbd
)
2595 and then Expr_Value
(Lbd
) = 1
2596 and then Expr_Value
(Sub
) <=
2597 String_Literal_Length
(Etype
(Arr
))
2600 C
: constant Char_Code
:=
2601 Get_String_Char
(Strval
(Arr
),
2602 UI_To_Int
(Expr_Value
(Sub
)));
2604 Set_Character_Literal_Name
(C
);
2607 Make_Character_Literal
(Loc
,
2609 Char_Literal_Value
=> UI_From_CC
(C
));
2610 Set_Etype
(Elm
, Component_Type
(Atyp
));
2611 Rewrite
(N
, Duplicate_Subexpr_No_Checks
(Elm
));
2612 Set_Is_Static_Expression
(N
, False);
2618 end Eval_Indexed_Component
;
2620 --------------------------
2621 -- Eval_Integer_Literal --
2622 --------------------------
2624 -- Numeric literals are static (RM 4.9(1)), and have already been marked
2625 -- as static by the analyzer. The reason we did it that early is to allow
2626 -- the possibility of turning off the Is_Static_Expression flag after
2627 -- analysis, but before resolution, when integer literals are generated in
2628 -- the expander that do not correspond to static expressions.
2630 procedure Eval_Integer_Literal
(N
: Node_Id
) is
2631 T
: constant Entity_Id
:= Etype
(N
);
2633 function In_Any_Integer_Context
return Boolean;
2634 -- If the literal is resolved with a specific type in a context where
2635 -- the expected type is Any_Integer, there are no range checks on the
2636 -- literal. By the time the literal is evaluated, it carries the type
2637 -- imposed by the enclosing expression, and we must recover the context
2638 -- to determine that Any_Integer is meant.
2640 ----------------------------
2641 -- In_Any_Integer_Context --
2642 ----------------------------
2644 function In_Any_Integer_Context
return Boolean is
2645 Par
: constant Node_Id
:= Parent
(N
);
2646 K
: constant Node_Kind
:= Nkind
(Par
);
2649 -- Any_Integer also appears in digits specifications for real types,
2650 -- but those have bounds smaller that those of any integer base type,
2651 -- so we can safely ignore these cases.
2653 return Nkind_In
(K
, N_Number_Declaration
,
2654 N_Attribute_Reference
,
2655 N_Attribute_Definition_Clause
,
2656 N_Modular_Type_Definition
,
2657 N_Signed_Integer_Type_Definition
);
2658 end In_Any_Integer_Context
;
2660 -- Start of processing for Eval_Integer_Literal
2664 -- If the literal appears in a non-expression context, then it is
2665 -- certainly appearing in a non-static context, so check it. This is
2666 -- actually a redundant check, since Check_Non_Static_Context would
2667 -- check it, but it seems worth while avoiding the call.
2669 if Nkind
(Parent
(N
)) not in N_Subexpr
2670 and then not In_Any_Integer_Context
2672 Check_Non_Static_Context
(N
);
2675 -- Modular integer literals must be in their base range
2677 if Is_Modular_Integer_Type
(T
)
2678 and then Is_Out_Of_Range
(N
, Base_Type
(T
), Assume_Valid
=> True)
2682 end Eval_Integer_Literal
;
2684 ---------------------
2685 -- Eval_Logical_Op --
2686 ---------------------
2688 -- Logical operations are static functions, so the result is potentially
2689 -- static if both operands are potentially static (RM 4.9(7), 4.9(20)).
2691 procedure Eval_Logical_Op
(N
: Node_Id
) is
2692 Left
: constant Node_Id
:= Left_Opnd
(N
);
2693 Right
: constant Node_Id
:= Right_Opnd
(N
);
2698 -- If not foldable we are done
2700 Test_Expression_Is_Foldable
(N
, Left
, Right
, Stat
, Fold
);
2706 -- Compile time evaluation of logical operation
2709 Left_Int
: constant Uint
:= Expr_Value
(Left
);
2710 Right_Int
: constant Uint
:= Expr_Value
(Right
);
2713 if Is_Modular_Integer_Type
(Etype
(N
)) then
2715 Left_Bits
: Bits
(0 .. UI_To_Int
(Esize
(Etype
(N
))) - 1);
2716 Right_Bits
: Bits
(0 .. UI_To_Int
(Esize
(Etype
(N
))) - 1);
2719 To_Bits
(Left_Int
, Left_Bits
);
2720 To_Bits
(Right_Int
, Right_Bits
);
2722 -- Note: should really be able to use array ops instead of
2723 -- these loops, but they weren't working at the time ???
2725 if Nkind
(N
) = N_Op_And
then
2726 for J
in Left_Bits
'Range loop
2727 Left_Bits
(J
) := Left_Bits
(J
) and Right_Bits
(J
);
2730 elsif Nkind
(N
) = N_Op_Or
then
2731 for J
in Left_Bits
'Range loop
2732 Left_Bits
(J
) := Left_Bits
(J
) or Right_Bits
(J
);
2736 pragma Assert
(Nkind
(N
) = N_Op_Xor
);
2738 for J
in Left_Bits
'Range loop
2739 Left_Bits
(J
) := Left_Bits
(J
) xor Right_Bits
(J
);
2743 Fold_Uint
(N
, From_Bits
(Left_Bits
, Etype
(N
)), Stat
);
2747 pragma Assert
(Is_Boolean_Type
(Etype
(N
)));
2749 if Nkind
(N
) = N_Op_And
then
2751 Test
(Is_True
(Left_Int
) and then Is_True
(Right_Int
)), Stat
);
2753 elsif Nkind
(N
) = N_Op_Or
then
2755 Test
(Is_True
(Left_Int
) or else Is_True
(Right_Int
)), Stat
);
2758 pragma Assert
(Nkind
(N
) = N_Op_Xor
);
2760 Test
(Is_True
(Left_Int
) xor Is_True
(Right_Int
)), Stat
);
2764 end Eval_Logical_Op
;
2766 ------------------------
2767 -- Eval_Membership_Op --
2768 ------------------------
2770 -- A membership test is potentially static if the expression is static, and
2771 -- the range is a potentially static range, or is a subtype mark denoting a
2772 -- static subtype (RM 4.9(12)).
2774 procedure Eval_Membership_Op
(N
: Node_Id
) is
2775 Alts
: constant List_Id
:= Alternatives
(N
);
2776 Choice
: constant Node_Id
:= Right_Opnd
(N
);
2777 Expr
: constant Node_Id
:= Left_Opnd
(N
);
2778 Result
: Match_Result
;
2781 -- Ignore if error in either operand, except to make sure that Any_Type
2782 -- is properly propagated to avoid junk cascaded errors.
2784 if Etype
(Expr
) = Any_Type
2785 or else (Present
(Choice
) and then Etype
(Choice
) = Any_Type
)
2787 Set_Etype
(N
, Any_Type
);
2791 -- If left operand non-static, then nothing to do
2793 if not Is_Static_Expression
(Expr
) then
2797 -- If choice is non-static, left operand is in non-static context
2799 if (Present
(Choice
) and then not Is_Static_Choice
(Choice
))
2800 or else (Present
(Alts
) and then not Is_Static_Choice_List
(Alts
))
2802 Check_Non_Static_Context
(Expr
);
2806 -- Otherwise we definitely have a static expression
2808 Set_Is_Static_Expression
(N
);
2810 -- If left operand raises constraint error, propagate and we are done
2812 if Raises_Constraint_Error
(Expr
) then
2813 Set_Raises_Constraint_Error
(N
, True);
2818 if Present
(Choice
) then
2819 Result
:= Choice_Matches
(Expr
, Choice
);
2821 Result
:= Choices_Match
(Expr
, Alts
);
2824 -- If result is Non_Static, it means that we raise Constraint_Error,
2825 -- since we already tested that the operands were themselves static.
2827 if Result
= Non_Static
then
2828 Set_Raises_Constraint_Error
(N
);
2830 -- Otherwise we have our result (flipped if NOT IN case)
2834 (N
, Test
((Result
= Match
) xor (Nkind
(N
) = N_Not_In
)), True);
2835 Warn_On_Known_Condition
(N
);
2838 end Eval_Membership_Op
;
2840 ------------------------
2841 -- Eval_Named_Integer --
2842 ------------------------
2844 procedure Eval_Named_Integer
(N
: Node_Id
) is
2847 Expr_Value
(Expression
(Declaration_Node
(Entity
(N
)))), True);
2848 end Eval_Named_Integer
;
2850 ---------------------
2851 -- Eval_Named_Real --
2852 ---------------------
2854 procedure Eval_Named_Real
(N
: Node_Id
) is
2857 Expr_Value_R
(Expression
(Declaration_Node
(Entity
(N
)))), True);
2858 end Eval_Named_Real
;
2864 -- Exponentiation is a static functions, so the result is potentially
2865 -- static if both operands are potentially static (RM 4.9(7), 4.9(20)).
2867 procedure Eval_Op_Expon
(N
: Node_Id
) is
2868 Left
: constant Node_Id
:= Left_Opnd
(N
);
2869 Right
: constant Node_Id
:= Right_Opnd
(N
);
2874 -- If not foldable we are done
2876 Test_Expression_Is_Foldable
2877 (N
, Left
, Right
, Stat
, Fold
, CRT_Safe
=> True);
2879 -- Return if not foldable
2885 if Configurable_Run_Time_Mode
and not Stat
then
2889 -- Fold exponentiation operation
2892 Right_Int
: constant Uint
:= Expr_Value
(Right
);
2897 if Is_Integer_Type
(Etype
(Left
)) then
2899 Left_Int
: constant Uint
:= Expr_Value
(Left
);
2903 -- Exponentiation of an integer raises Constraint_Error for a
2904 -- negative exponent (RM 4.5.6).
2906 if Right_Int
< 0 then
2907 Apply_Compile_Time_Constraint_Error
2908 (N
, "integer exponent negative", CE_Range_Check_Failed
,
2913 if OK_Bits
(N
, Num_Bits
(Left_Int
) * Right_Int
) then
2914 Result
:= Left_Int
** Right_Int
;
2919 if Is_Modular_Integer_Type
(Etype
(N
)) then
2920 Result
:= Result
mod Modulus
(Etype
(N
));
2923 Fold_Uint
(N
, Result
, Stat
);
2931 Left_Real
: constant Ureal
:= Expr_Value_R
(Left
);
2934 -- Cannot have a zero base with a negative exponent
2936 if UR_Is_Zero
(Left_Real
) then
2938 if Right_Int
< 0 then
2939 Apply_Compile_Time_Constraint_Error
2940 (N
, "zero ** negative integer", CE_Range_Check_Failed
,
2944 Fold_Ureal
(N
, Ureal_0
, Stat
);
2948 Fold_Ureal
(N
, Left_Real
** Right_Int
, Stat
);
2959 -- The not operation is a static functions, so the result is potentially
2960 -- static if the operand is potentially static (RM 4.9(7), 4.9(20)).
2962 procedure Eval_Op_Not
(N
: Node_Id
) is
2963 Right
: constant Node_Id
:= Right_Opnd
(N
);
2968 -- If not foldable we are done
2970 Test_Expression_Is_Foldable
(N
, Right
, Stat
, Fold
);
2976 -- Fold not operation
2979 Rint
: constant Uint
:= Expr_Value
(Right
);
2980 Typ
: constant Entity_Id
:= Etype
(N
);
2983 -- Negation is equivalent to subtracting from the modulus minus one.
2984 -- For a binary modulus this is equivalent to the ones-complement of
2985 -- the original value. For a nonbinary modulus this is an arbitrary
2986 -- but consistent definition.
2988 if Is_Modular_Integer_Type
(Typ
) then
2989 Fold_Uint
(N
, Modulus
(Typ
) - 1 - Rint
, Stat
);
2990 else pragma Assert
(Is_Boolean_Type
(Typ
));
2991 Fold_Uint
(N
, Test
(not Is_True
(Rint
)), Stat
);
2994 Set_Is_Static_Expression
(N
, Stat
);
2998 -------------------------------
2999 -- Eval_Qualified_Expression --
3000 -------------------------------
3002 -- A qualified expression is potentially static if its subtype mark denotes
3003 -- a static subtype and its expression is potentially static (RM 4.9 (11)).
3005 procedure Eval_Qualified_Expression
(N
: Node_Id
) is
3006 Operand
: constant Node_Id
:= Expression
(N
);
3007 Target_Type
: constant Entity_Id
:= Entity
(Subtype_Mark
(N
));
3014 -- Can only fold if target is string or scalar and subtype is static.
3015 -- Also, do not fold if our parent is an allocator (this is because the
3016 -- qualified expression is really part of the syntactic structure of an
3017 -- allocator, and we do not want to end up with something that
3018 -- corresponds to "new 1" where the 1 is the result of folding a
3019 -- qualified expression).
3021 if not Is_Static_Subtype
(Target_Type
)
3022 or else Nkind
(Parent
(N
)) = N_Allocator
3024 Check_Non_Static_Context
(Operand
);
3026 -- If operand is known to raise constraint_error, set the flag on the
3027 -- expression so it does not get optimized away.
3029 if Nkind
(Operand
) = N_Raise_Constraint_Error
then
3030 Set_Raises_Constraint_Error
(N
);
3036 -- If not foldable we are done
3038 Test_Expression_Is_Foldable
(N
, Operand
, Stat
, Fold
);
3043 -- Don't try fold if target type has constraint error bounds
3045 elsif not Is_OK_Static_Subtype
(Target_Type
) then
3046 Set_Raises_Constraint_Error
(N
);
3050 -- Here we will fold, save Print_In_Hex indication
3052 Hex
:= Nkind
(Operand
) = N_Integer_Literal
3053 and then Print_In_Hex
(Operand
);
3055 -- Fold the result of qualification
3057 if Is_Discrete_Type
(Target_Type
) then
3058 Fold_Uint
(N
, Expr_Value
(Operand
), Stat
);
3060 -- Preserve Print_In_Hex indication
3062 if Hex
and then Nkind
(N
) = N_Integer_Literal
then
3063 Set_Print_In_Hex
(N
);
3066 elsif Is_Real_Type
(Target_Type
) then
3067 Fold_Ureal
(N
, Expr_Value_R
(Operand
), Stat
);
3070 Fold_Str
(N
, Strval
(Get_String_Val
(Operand
)), Stat
);
3073 Set_Is_Static_Expression
(N
, False);
3075 Check_String_Literal_Length
(N
, Target_Type
);
3081 -- The expression may be foldable but not static
3083 Set_Is_Static_Expression
(N
, Stat
);
3085 if Is_Out_Of_Range
(N
, Etype
(N
), Assume_Valid
=> True) then
3088 end Eval_Qualified_Expression
;
3090 -----------------------
3091 -- Eval_Real_Literal --
3092 -----------------------
3094 -- Numeric literals are static (RM 4.9(1)), and have already been marked
3095 -- as static by the analyzer. The reason we did it that early is to allow
3096 -- the possibility of turning off the Is_Static_Expression flag after
3097 -- analysis, but before resolution, when integer literals are generated
3098 -- in the expander that do not correspond to static expressions.
3100 procedure Eval_Real_Literal
(N
: Node_Id
) is
3101 PK
: constant Node_Kind
:= Nkind
(Parent
(N
));
3104 -- If the literal appears in a non-expression context and not as part of
3105 -- a number declaration, then it is appearing in a non-static context,
3108 if PK
not in N_Subexpr
and then PK
/= N_Number_Declaration
then
3109 Check_Non_Static_Context
(N
);
3111 end Eval_Real_Literal
;
3113 ------------------------
3114 -- Eval_Relational_Op --
3115 ------------------------
3117 -- Relational operations are static functions, so the result is static if
3118 -- both operands are static (RM 4.9(7), 4.9(20)), except that for strings,
3119 -- the result is never static, even if the operands are.
3121 -- However, for internally generated nodes, we allow string equality and
3122 -- inequality to be static. This is because we rewrite A in "ABC" as an
3123 -- equality test A = "ABC", and the former is definitely static.
3125 procedure Eval_Relational_Op
(N
: Node_Id
) is
3126 Left
: constant Node_Id
:= Left_Opnd
(N
);
3127 Right
: constant Node_Id
:= Right_Opnd
(N
);
3128 Typ
: constant Entity_Id
:= Etype
(Left
);
3129 Otype
: Entity_Id
:= Empty
;
3133 -- One special case to deal with first. If we can tell that the result
3134 -- will be false because the lengths of one or more index subtypes are
3135 -- compile time known and different, then we can replace the entire
3136 -- result by False. We only do this for one dimensional arrays, because
3137 -- the case of multi-dimensional arrays is rare and too much trouble. If
3138 -- one of the operands is an illegal aggregate, its type might still be
3139 -- an arbitrary composite type, so nothing to do.
3141 if Is_Array_Type
(Typ
)
3142 and then Typ
/= Any_Composite
3143 and then Number_Dimensions
(Typ
) = 1
3144 and then (Nkind
(N
) = N_Op_Eq
or else Nkind
(N
) = N_Op_Ne
)
3146 if Raises_Constraint_Error
(Left
)
3148 Raises_Constraint_Error
(Right
)
3153 -- OK, we have the case where we may be able to do this fold
3155 Length_Mismatch
: declare
3156 procedure Get_Static_Length
(Op
: Node_Id
; Len
: out Uint
);
3157 -- If Op is an expression for a constrained array with a known at
3158 -- compile time length, then Len is set to this (non-negative
3159 -- length). Otherwise Len is set to minus 1.
3161 -----------------------
3162 -- Get_Static_Length --
3163 -----------------------
3165 procedure Get_Static_Length
(Op
: Node_Id
; Len
: out Uint
) is
3169 -- First easy case string literal
3171 if Nkind
(Op
) = N_String_Literal
then
3172 Len
:= UI_From_Int
(String_Length
(Strval
(Op
)));
3176 -- Second easy case, not constrained subtype, so no length
3178 if not Is_Constrained
(Etype
(Op
)) then
3179 Len
:= Uint_Minus_1
;
3185 T
:= Etype
(First_Index
(Etype
(Op
)));
3187 -- The simple case, both bounds are known at compile time
3189 if Is_Discrete_Type
(T
)
3190 and then Compile_Time_Known_Value
(Type_Low_Bound
(T
))
3191 and then Compile_Time_Known_Value
(Type_High_Bound
(T
))
3193 Len
:= UI_Max
(Uint_0
,
3194 Expr_Value
(Type_High_Bound
(T
)) -
3195 Expr_Value
(Type_Low_Bound
(T
)) + 1);
3199 -- A more complex case, where the bounds are of the form
3200 -- X [+/- K1] .. X [+/- K2]), where X is an expression that is
3201 -- either A'First or A'Last (with A an entity name), or X is an
3202 -- entity name, and the two X's are the same and K1 and K2 are
3203 -- known at compile time, in this case, the length can also be
3204 -- computed at compile time, even though the bounds are not
3205 -- known. A common case of this is e.g. (X'First .. X'First+5).
3207 Extract_Length
: declare
3208 procedure Decompose_Expr
3210 Ent
: out Entity_Id
;
3211 Kind
: out Character;
3213 Orig
: Boolean := True);
3214 -- Given an expression see if it is of the form given above,
3215 -- X [+/- K]. If so Ent is set to the entity in X, Kind is
3216 -- 'F','L','E' for 'First/'Last/simple entity, and Cons is
3217 -- the value of K. If the expression is not of the required
3218 -- form, Ent is set to Empty.
3220 -- Orig indicates whether Expr is the original expression
3221 -- to consider, or if we are handling a sub-expression
3222 -- (e.g. recursive call to Decompose_Expr).
3224 --------------------
3225 -- Decompose_Expr --
3226 --------------------
3228 procedure Decompose_Expr
3230 Ent
: out Entity_Id
;
3231 Kind
: out Character;
3233 Orig
: Boolean := True)
3245 if Nkind
(Expr
) = N_Op_Add
3246 and then Compile_Time_Known_Value
(Right_Opnd
(Expr
))
3248 Exp
:= Left_Opnd
(Expr
);
3249 Cons
:= Expr_Value
(Right_Opnd
(Expr
));
3251 elsif Nkind
(Expr
) = N_Op_Subtract
3252 and then Compile_Time_Known_Value
(Right_Opnd
(Expr
))
3254 Exp
:= Left_Opnd
(Expr
);
3255 Cons
:= -Expr_Value
(Right_Opnd
(Expr
));
3257 -- If the bound is a constant created to remove side
3258 -- effects, recover original expression to see if it has
3259 -- one of the recognizable forms.
3261 elsif Nkind
(Expr
) = N_Identifier
3262 and then not Comes_From_Source
(Entity
(Expr
))
3263 and then Ekind
(Entity
(Expr
)) = E_Constant
3265 Nkind
(Parent
(Entity
(Expr
))) = N_Object_Declaration
3267 Exp
:= Expression
(Parent
(Entity
(Expr
)));
3268 Decompose_Expr
(Exp
, Ent
, Kind
, Cons
, Orig
=> False);
3270 -- If original expression includes an entity, create a
3271 -- reference to it for use below.
3273 if Present
(Ent
) then
3274 Exp
:= New_Occurrence_Of
(Ent
, Sloc
(Ent
));
3280 -- Only consider the case of X + 0 for a full
3281 -- expression, and not when recursing, otherwise we
3282 -- may end up with evaluating expressions not known
3283 -- at compile time to 0.
3293 -- At this stage Exp is set to the potential X
3295 if Nkind
(Exp
) = N_Attribute_Reference
then
3296 if Attribute_Name
(Exp
) = Name_First
then
3298 elsif Attribute_Name
(Exp
) = Name_Last
then
3304 Exp
:= Prefix
(Exp
);
3310 if Is_Entity_Name
(Exp
)
3311 and then Present
(Entity
(Exp
))
3313 Ent
:= Entity
(Exp
);
3319 Ent1
, Ent2
: Entity_Id
;
3320 Kind1
, Kind2
: Character;
3321 Cons1
, Cons2
: Uint
;
3323 -- Start of processing for Extract_Length
3327 (Original_Node
(Type_Low_Bound
(T
)), Ent1
, Kind1
, Cons1
);
3329 (Original_Node
(Type_High_Bound
(T
)), Ent2
, Kind2
, Cons2
);
3332 and then Ent1
= Ent2
3333 and then Kind1
= Kind2
3335 Len
:= Cons2
- Cons1
+ 1;
3337 Len
:= Uint_Minus_1
;
3340 end Get_Static_Length
;
3347 -- Start of processing for Length_Mismatch
3350 Get_Static_Length
(Left
, Len_L
);
3351 Get_Static_Length
(Right
, Len_R
);
3353 if Len_L
/= Uint_Minus_1
3354 and then Len_R
/= Uint_Minus_1
3355 and then Len_L
/= Len_R
3357 Fold_Uint
(N
, Test
(Nkind
(N
) = N_Op_Ne
), False);
3358 Warn_On_Known_Condition
(N
);
3361 end Length_Mismatch
;
3365 Is_Static_Expression
: Boolean;
3367 Is_Foldable
: Boolean;
3368 pragma Unreferenced
(Is_Foldable
);
3371 -- Initialize the value of Is_Static_Expression. The value of
3372 -- Is_Foldable returned by Test_Expression_Is_Foldable is not needed
3373 -- since, even when some operand is a variable, we can still perform
3374 -- the static evaluation of the expression in some cases (for
3375 -- example, for a variable of a subtype of Integer we statically
3376 -- know that any value stored in such variable is smaller than
3379 Test_Expression_Is_Foldable
3380 (N
, Left
, Right
, Is_Static_Expression
, Is_Foldable
);
3382 -- Only comparisons of scalars can give static results. In
3383 -- particular, comparisons of strings never yield a static
3384 -- result, even if both operands are static strings, except that
3385 -- as noted above, we allow equality/inequality for strings.
3387 if Is_String_Type
(Typ
)
3388 and then not Comes_From_Source
(N
)
3389 and then Nkind_In
(N
, N_Op_Eq
, N_Op_Ne
)
3393 elsif not Is_Scalar_Type
(Typ
) then
3394 Is_Static_Expression
:= False;
3395 Set_Is_Static_Expression
(N
, False);
3398 -- For operators on universal numeric types called as functions with
3399 -- an explicit scope, determine appropriate specific numeric type,
3400 -- and diagnose possible ambiguity.
3402 if Is_Universal_Numeric_Type
(Etype
(Left
))
3404 Is_Universal_Numeric_Type
(Etype
(Right
))
3406 Otype
:= Find_Universal_Operator_Type
(N
);
3409 -- For static real type expressions, do not use Compile_Time_Compare
3410 -- since it worries about run-time results which are not exact.
3412 if Is_Static_Expression
and then Is_Real_Type
(Typ
) then
3414 Left_Real
: constant Ureal
:= Expr_Value_R
(Left
);
3415 Right_Real
: constant Ureal
:= Expr_Value_R
(Right
);
3419 when N_Op_Eq
=> Result
:= (Left_Real
= Right_Real
);
3420 when N_Op_Ne
=> Result
:= (Left_Real
/= Right_Real
);
3421 when N_Op_Lt
=> Result
:= (Left_Real
< Right_Real
);
3422 when N_Op_Le
=> Result
:= (Left_Real
<= Right_Real
);
3423 when N_Op_Gt
=> Result
:= (Left_Real
> Right_Real
);
3424 when N_Op_Ge
=> Result
:= (Left_Real
>= Right_Real
);
3427 raise Program_Error
;
3430 Fold_Uint
(N
, Test
(Result
), True);
3433 -- For all other cases, we use Compile_Time_Compare to do the compare
3437 CR
: constant Compare_Result
:=
3438 Compile_Time_Compare
3439 (Left
, Right
, Assume_Valid
=> False);
3442 if CR
= Unknown
then
3450 elsif CR
= NE
or else CR
= GT
or else CR
= LT
then
3457 if CR
= NE
or else CR
= GT
or else CR
= LT
then
3468 elsif CR
= EQ
or else CR
= GT
or else CR
= GE
then
3475 if CR
= LT
or else CR
= EQ
or else CR
= LE
then
3486 elsif CR
= EQ
or else CR
= LT
or else CR
= LE
then
3493 if CR
= GT
or else CR
= EQ
or else CR
= GE
then
3502 raise Program_Error
;
3506 Fold_Uint
(N
, Test
(Result
), Is_Static_Expression
);
3510 -- For the case of a folded relational operator on a specific numeric
3511 -- type, freeze operand type now.
3513 if Present
(Otype
) then
3514 Freeze_Before
(N
, Otype
);
3517 Warn_On_Known_Condition
(N
);
3518 end Eval_Relational_Op
;
3524 -- Shift operations are intrinsic operations that can never be static, so
3525 -- the only processing required is to perform the required check for a non
3526 -- static context for the two operands.
3528 -- Actually we could do some compile time evaluation here some time ???
3530 procedure Eval_Shift
(N
: Node_Id
) is
3532 Check_Non_Static_Context
(Left_Opnd
(N
));
3533 Check_Non_Static_Context
(Right_Opnd
(N
));
3536 ------------------------
3537 -- Eval_Short_Circuit --
3538 ------------------------
3540 -- A short circuit operation is potentially static if both operands are
3541 -- potentially static (RM 4.9 (13)).
3543 procedure Eval_Short_Circuit
(N
: Node_Id
) is
3544 Kind
: constant Node_Kind
:= Nkind
(N
);
3545 Left
: constant Node_Id
:= Left_Opnd
(N
);
3546 Right
: constant Node_Id
:= Right_Opnd
(N
);
3549 Rstat
: constant Boolean :=
3550 Is_Static_Expression
(Left
)
3552 Is_Static_Expression
(Right
);
3555 -- Short circuit operations are never static in Ada 83
3557 if Ada_Version
= Ada_83
and then Comes_From_Source
(N
) then
3558 Check_Non_Static_Context
(Left
);
3559 Check_Non_Static_Context
(Right
);
3563 -- Now look at the operands, we can't quite use the normal call to
3564 -- Test_Expression_Is_Foldable here because short circuit operations
3565 -- are a special case, they can still be foldable, even if the right
3566 -- operand raises constraint error.
3568 -- If either operand is Any_Type, just propagate to result and do not
3569 -- try to fold, this prevents cascaded errors.
3571 if Etype
(Left
) = Any_Type
or else Etype
(Right
) = Any_Type
then
3572 Set_Etype
(N
, Any_Type
);
3575 -- If left operand raises constraint error, then replace node N with
3576 -- the raise constraint error node, and we are obviously not foldable.
3577 -- Is_Static_Expression is set from the two operands in the normal way,
3578 -- and we check the right operand if it is in a non-static context.
3580 elsif Raises_Constraint_Error
(Left
) then
3582 Check_Non_Static_Context
(Right
);
3585 Rewrite_In_Raise_CE
(N
, Left
);
3586 Set_Is_Static_Expression
(N
, Rstat
);
3589 -- If the result is not static, then we won't in any case fold
3591 elsif not Rstat
then
3592 Check_Non_Static_Context
(Left
);
3593 Check_Non_Static_Context
(Right
);
3597 -- Here the result is static, note that, unlike the normal processing
3598 -- in Test_Expression_Is_Foldable, we did *not* check above to see if
3599 -- the right operand raises constraint error, that's because it is not
3600 -- significant if the left operand is decisive.
3602 Set_Is_Static_Expression
(N
);
3604 -- It does not matter if the right operand raises constraint error if
3605 -- it will not be evaluated. So deal specially with the cases where
3606 -- the right operand is not evaluated. Note that we will fold these
3607 -- cases even if the right operand is non-static, which is fine, but
3608 -- of course in these cases the result is not potentially static.
3610 Left_Int
:= Expr_Value
(Left
);
3612 if (Kind
= N_And_Then
and then Is_False
(Left_Int
))
3614 (Kind
= N_Or_Else
and then Is_True
(Left_Int
))
3616 Fold_Uint
(N
, Left_Int
, Rstat
);
3620 -- If first operand not decisive, then it does matter if the right
3621 -- operand raises constraint error, since it will be evaluated, so
3622 -- we simply replace the node with the right operand. Note that this
3623 -- properly propagates Is_Static_Expression and Raises_Constraint_Error
3624 -- (both are set to True in Right).
3626 if Raises_Constraint_Error
(Right
) then
3627 Rewrite_In_Raise_CE
(N
, Right
);
3628 Check_Non_Static_Context
(Left
);
3632 -- Otherwise the result depends on the right operand
3634 Fold_Uint
(N
, Expr_Value
(Right
), Rstat
);
3636 end Eval_Short_Circuit
;
3642 -- Slices can never be static, so the only processing required is to check
3643 -- for non-static context if an explicit range is given.
3645 procedure Eval_Slice
(N
: Node_Id
) is
3646 Drange
: constant Node_Id
:= Discrete_Range
(N
);
3649 if Nkind
(Drange
) = N_Range
then
3650 Check_Non_Static_Context
(Low_Bound
(Drange
));
3651 Check_Non_Static_Context
(High_Bound
(Drange
));
3654 -- A slice of the form A (subtype), when the subtype is the index of
3655 -- the type of A, is redundant, the slice can be replaced with A, and
3656 -- this is worth a warning.
3658 if Is_Entity_Name
(Prefix
(N
)) then
3660 E
: constant Entity_Id
:= Entity
(Prefix
(N
));
3661 T
: constant Entity_Id
:= Etype
(E
);
3664 if Ekind
(E
) = E_Constant
3665 and then Is_Array_Type
(T
)
3666 and then Is_Entity_Name
(Drange
)
3668 if Is_Entity_Name
(Original_Node
(First_Index
(T
)))
3669 and then Entity
(Original_Node
(First_Index
(T
)))
3672 if Warn_On_Redundant_Constructs
then
3673 Error_Msg_N
("redundant slice denotes whole array?r?", N
);
3676 -- The following might be a useful optimization???
3678 -- Rewrite (N, New_Occurrence_Of (E, Sloc (N)));
3685 -------------------------
3686 -- Eval_String_Literal --
3687 -------------------------
3689 procedure Eval_String_Literal
(N
: Node_Id
) is
3690 Typ
: constant Entity_Id
:= Etype
(N
);
3691 Bas
: constant Entity_Id
:= Base_Type
(Typ
);
3697 -- Nothing to do if error type (handles cases like default expressions
3698 -- or generics where we have not yet fully resolved the type).
3700 if Bas
= Any_Type
or else Bas
= Any_String
then
3704 -- String literals are static if the subtype is static (RM 4.9(2)), so
3705 -- reset the static expression flag (it was set unconditionally in
3706 -- Analyze_String_Literal) if the subtype is non-static. We tell if
3707 -- the subtype is static by looking at the lower bound.
3709 if Ekind
(Typ
) = E_String_Literal_Subtype
then
3710 if not Is_OK_Static_Expression
(String_Literal_Low_Bound
(Typ
)) then
3711 Set_Is_Static_Expression
(N
, False);
3715 -- Here if Etype of string literal is normal Etype (not yet possible,
3716 -- but may be possible in future).
3718 elsif not Is_OK_Static_Expression
3719 (Type_Low_Bound
(Etype
(First_Index
(Typ
))))
3721 Set_Is_Static_Expression
(N
, False);
3725 -- If original node was a type conversion, then result if non-static
3727 if Nkind
(Original_Node
(N
)) = N_Type_Conversion
then
3728 Set_Is_Static_Expression
(N
, False);
3732 -- Test for illegal Ada 95 cases. A string literal is illegal in Ada 95
3733 -- if its bounds are outside the index base type and this index type is
3734 -- static. This can happen in only two ways. Either the string literal
3735 -- is too long, or it is null, and the lower bound is type'First. Either
3736 -- way it is the upper bound that is out of range of the index type.
3738 if Ada_Version
>= Ada_95
then
3739 if Is_Standard_String_Type
(Bas
) then
3740 Xtp
:= Standard_Positive
;
3742 Xtp
:= Etype
(First_Index
(Bas
));
3745 if Ekind
(Typ
) = E_String_Literal_Subtype
then
3746 Lo
:= String_Literal_Low_Bound
(Typ
);
3748 Lo
:= Type_Low_Bound
(Etype
(First_Index
(Typ
)));
3751 -- Check for string too long
3753 Len
:= String_Length
(Strval
(N
));
3755 if UI_From_Int
(Len
) > String_Type_Len
(Bas
) then
3757 -- Issue message. Note that this message is a warning if the
3758 -- string literal is not marked as static (happens in some cases
3759 -- of folding strings known at compile time, but not static).
3760 -- Furthermore in such cases, we reword the message, since there
3761 -- is no string literal in the source program.
3763 if Is_Static_Expression
(N
) then
3764 Apply_Compile_Time_Constraint_Error
3765 (N
, "string literal too long for}", CE_Length_Check_Failed
,
3767 Typ
=> First_Subtype
(Bas
));
3769 Apply_Compile_Time_Constraint_Error
3770 (N
, "string value too long for}", CE_Length_Check_Failed
,
3772 Typ
=> First_Subtype
(Bas
),
3776 -- Test for null string not allowed
3779 and then not Is_Generic_Type
(Xtp
)
3781 Expr_Value
(Lo
) = Expr_Value
(Type_Low_Bound
(Base_Type
(Xtp
)))
3783 -- Same specialization of message
3785 if Is_Static_Expression
(N
) then
3786 Apply_Compile_Time_Constraint_Error
3787 (N
, "null string literal not allowed for}",
3788 CE_Length_Check_Failed
,
3790 Typ
=> First_Subtype
(Bas
));
3792 Apply_Compile_Time_Constraint_Error
3793 (N
, "null string value not allowed for}",
3794 CE_Length_Check_Failed
,
3796 Typ
=> First_Subtype
(Bas
),
3801 end Eval_String_Literal
;
3803 --------------------------
3804 -- Eval_Type_Conversion --
3805 --------------------------
3807 -- A type conversion is potentially static if its subtype mark is for a
3808 -- static scalar subtype, and its operand expression is potentially static
3811 procedure Eval_Type_Conversion
(N
: Node_Id
) is
3812 Operand
: constant Node_Id
:= Expression
(N
);
3813 Source_Type
: constant Entity_Id
:= Etype
(Operand
);
3814 Target_Type
: constant Entity_Id
:= Etype
(N
);
3816 function To_Be_Treated_As_Integer
(T
: Entity_Id
) return Boolean;
3817 -- Returns true if type T is an integer type, or if it is a fixed-point
3818 -- type to be treated as an integer (i.e. the flag Conversion_OK is set
3819 -- on the conversion node).
3821 function To_Be_Treated_As_Real
(T
: Entity_Id
) return Boolean;
3822 -- Returns true if type T is a floating-point type, or if it is a
3823 -- fixed-point type that is not to be treated as an integer (i.e. the
3824 -- flag Conversion_OK is not set on the conversion node).
3826 ------------------------------
3827 -- To_Be_Treated_As_Integer --
3828 ------------------------------
3830 function To_Be_Treated_As_Integer
(T
: Entity_Id
) return Boolean is
3834 or else (Is_Fixed_Point_Type
(T
) and then Conversion_OK
(N
));
3835 end To_Be_Treated_As_Integer
;
3837 ---------------------------
3838 -- To_Be_Treated_As_Real --
3839 ---------------------------
3841 function To_Be_Treated_As_Real
(T
: Entity_Id
) return Boolean is
3844 Is_Floating_Point_Type
(T
)
3845 or else (Is_Fixed_Point_Type
(T
) and then not Conversion_OK
(N
));
3846 end To_Be_Treated_As_Real
;
3853 -- Start of processing for Eval_Type_Conversion
3856 -- Cannot fold if target type is non-static or if semantic error
3858 if not Is_Static_Subtype
(Target_Type
) then
3859 Check_Non_Static_Context
(Operand
);
3861 elsif Error_Posted
(N
) then
3865 -- If not foldable we are done
3867 Test_Expression_Is_Foldable
(N
, Operand
, Stat
, Fold
);
3872 -- Don't try fold if target type has constraint error bounds
3874 elsif not Is_OK_Static_Subtype
(Target_Type
) then
3875 Set_Raises_Constraint_Error
(N
);
3879 -- Remaining processing depends on operand types. Note that in the
3880 -- following type test, fixed-point counts as real unless the flag
3881 -- Conversion_OK is set, in which case it counts as integer.
3883 -- Fold conversion, case of string type. The result is not static
3885 if Is_String_Type
(Target_Type
) then
3886 Fold_Str
(N
, Strval
(Get_String_Val
(Operand
)), Static
=> False);
3889 -- Fold conversion, case of integer target type
3891 elsif To_Be_Treated_As_Integer
(Target_Type
) then
3896 -- Integer to integer conversion
3898 if To_Be_Treated_As_Integer
(Source_Type
) then
3899 Result
:= Expr_Value
(Operand
);
3901 -- Real to integer conversion
3904 Result
:= UR_To_Uint
(Expr_Value_R
(Operand
));
3907 -- If fixed-point type (Conversion_OK must be set), then the
3908 -- result is logically an integer, but we must replace the
3909 -- conversion with the corresponding real literal, since the
3910 -- type from a semantic point of view is still fixed-point.
3912 if Is_Fixed_Point_Type
(Target_Type
) then
3914 (N
, UR_From_Uint
(Result
) * Small_Value
(Target_Type
), Stat
);
3916 -- Otherwise result is integer literal
3919 Fold_Uint
(N
, Result
, Stat
);
3923 -- Fold conversion, case of real target type
3925 elsif To_Be_Treated_As_Real
(Target_Type
) then
3930 if To_Be_Treated_As_Real
(Source_Type
) then
3931 Result
:= Expr_Value_R
(Operand
);
3933 Result
:= UR_From_Uint
(Expr_Value
(Operand
));
3936 Fold_Ureal
(N
, Result
, Stat
);
3939 -- Enumeration types
3942 Fold_Uint
(N
, Expr_Value
(Operand
), Stat
);
3945 if Is_Out_Of_Range
(N
, Etype
(N
), Assume_Valid
=> True) then
3949 end Eval_Type_Conversion
;
3955 -- Predefined unary operators are static functions (RM 4.9(20)) and thus
3956 -- are potentially static if the operand is potentially static (RM 4.9(7)).
3958 procedure Eval_Unary_Op
(N
: Node_Id
) is
3959 Right
: constant Node_Id
:= Right_Opnd
(N
);
3960 Otype
: Entity_Id
:= Empty
;
3965 -- If not foldable we are done
3967 Test_Expression_Is_Foldable
(N
, Right
, Stat
, Fold
);
3973 if Etype
(Right
) = Universal_Integer
3975 Etype
(Right
) = Universal_Real
3977 Otype
:= Find_Universal_Operator_Type
(N
);
3980 -- Fold for integer case
3982 if Is_Integer_Type
(Etype
(N
)) then
3984 Rint
: constant Uint
:= Expr_Value
(Right
);
3988 -- In the case of modular unary plus and abs there is no need
3989 -- to adjust the result of the operation since if the original
3990 -- operand was in bounds the result will be in the bounds of the
3991 -- modular type. However, in the case of modular unary minus the
3992 -- result may go out of the bounds of the modular type and needs
3995 if Nkind
(N
) = N_Op_Plus
then
3998 elsif Nkind
(N
) = N_Op_Minus
then
3999 if Is_Modular_Integer_Type
(Etype
(N
)) then
4000 Result
:= (-Rint
) mod Modulus
(Etype
(N
));
4006 pragma Assert
(Nkind
(N
) = N_Op_Abs
);
4010 Fold_Uint
(N
, Result
, Stat
);
4013 -- Fold for real case
4015 elsif Is_Real_Type
(Etype
(N
)) then
4017 Rreal
: constant Ureal
:= Expr_Value_R
(Right
);
4021 if Nkind
(N
) = N_Op_Plus
then
4023 elsif Nkind
(N
) = N_Op_Minus
then
4024 Result
:= UR_Negate
(Rreal
);
4026 pragma Assert
(Nkind
(N
) = N_Op_Abs
);
4027 Result
:= abs Rreal
;
4030 Fold_Ureal
(N
, Result
, Stat
);
4034 -- If the operator was resolved to a specific type, make sure that type
4035 -- is frozen even if the expression is folded into a literal (which has
4036 -- a universal type).
4038 if Present
(Otype
) then
4039 Freeze_Before
(N
, Otype
);
4043 -------------------------------
4044 -- Eval_Unchecked_Conversion --
4045 -------------------------------
4047 -- Unchecked conversions can never be static, so the only required
4048 -- processing is to check for a non-static context for the operand.
4050 procedure Eval_Unchecked_Conversion
(N
: Node_Id
) is
4052 Check_Non_Static_Context
(Expression
(N
));
4053 end Eval_Unchecked_Conversion
;
4055 --------------------
4056 -- Expr_Rep_Value --
4057 --------------------
4059 function Expr_Rep_Value
(N
: Node_Id
) return Uint
is
4060 Kind
: constant Node_Kind
:= Nkind
(N
);
4064 if Is_Entity_Name
(N
) then
4067 -- An enumeration literal that was either in the source or created
4068 -- as a result of static evaluation.
4070 if Ekind
(Ent
) = E_Enumeration_Literal
then
4071 return Enumeration_Rep
(Ent
);
4073 -- A user defined static constant
4076 pragma Assert
(Ekind
(Ent
) = E_Constant
);
4077 return Expr_Rep_Value
(Constant_Value
(Ent
));
4080 -- An integer literal that was either in the source or created as a
4081 -- result of static evaluation.
4083 elsif Kind
= N_Integer_Literal
then
4086 -- A real literal for a fixed-point type. This must be the fixed-point
4087 -- case, either the literal is of a fixed-point type, or it is a bound
4088 -- of a fixed-point type, with type universal real. In either case we
4089 -- obtain the desired value from Corresponding_Integer_Value.
4091 elsif Kind
= N_Real_Literal
then
4092 pragma Assert
(Is_Fixed_Point_Type
(Underlying_Type
(Etype
(N
))));
4093 return Corresponding_Integer_Value
(N
);
4095 -- Otherwise must be character literal
4098 pragma Assert
(Kind
= N_Character_Literal
);
4101 -- Since Character literals of type Standard.Character don't have any
4102 -- defining character literals built for them, they do not have their
4103 -- Entity set, so just use their Char code. Otherwise for user-
4104 -- defined character literals use their Pos value as usual which is
4105 -- the same as the Rep value.
4108 return Char_Literal_Value
(N
);
4110 return Enumeration_Rep
(Ent
);
4119 function Expr_Value
(N
: Node_Id
) return Uint
is
4120 Kind
: constant Node_Kind
:= Nkind
(N
);
4121 CV_Ent
: CV_Entry
renames CV_Cache
(Nat
(N
) mod CV_Cache_Size
);
4126 -- If already in cache, then we know it's compile time known and we can
4127 -- return the value that was previously stored in the cache since
4128 -- compile time known values cannot change.
4130 if CV_Ent
.N
= N
then
4134 -- Otherwise proceed to test value
4136 if Is_Entity_Name
(N
) then
4139 -- An enumeration literal that was either in the source or created as
4140 -- a result of static evaluation.
4142 if Ekind
(Ent
) = E_Enumeration_Literal
then
4143 Val
:= Enumeration_Pos
(Ent
);
4145 -- A user defined static constant
4148 pragma Assert
(Ekind
(Ent
) = E_Constant
);
4149 Val
:= Expr_Value
(Constant_Value
(Ent
));
4152 -- An integer literal that was either in the source or created as a
4153 -- result of static evaluation.
4155 elsif Kind
= N_Integer_Literal
then
4158 -- A real literal for a fixed-point type. This must be the fixed-point
4159 -- case, either the literal is of a fixed-point type, or it is a bound
4160 -- of a fixed-point type, with type universal real. In either case we
4161 -- obtain the desired value from Corresponding_Integer_Value.
4163 elsif Kind
= N_Real_Literal
then
4164 pragma Assert
(Is_Fixed_Point_Type
(Underlying_Type
(Etype
(N
))));
4165 Val
:= Corresponding_Integer_Value
(N
);
4167 -- Otherwise must be character literal
4170 pragma Assert
(Kind
= N_Character_Literal
);
4173 -- Since Character literals of type Standard.Character don't
4174 -- have any defining character literals built for them, they
4175 -- do not have their Entity set, so just use their Char
4176 -- code. Otherwise for user-defined character literals use
4177 -- their Pos value as usual.
4180 Val
:= Char_Literal_Value
(N
);
4182 Val
:= Enumeration_Pos
(Ent
);
4186 -- Come here with Val set to value to be returned, set cache
4197 function Expr_Value_E
(N
: Node_Id
) return Entity_Id
is
4198 Ent
: constant Entity_Id
:= Entity
(N
);
4200 if Ekind
(Ent
) = E_Enumeration_Literal
then
4203 pragma Assert
(Ekind
(Ent
) = E_Constant
);
4204 return Expr_Value_E
(Constant_Value
(Ent
));
4212 function Expr_Value_R
(N
: Node_Id
) return Ureal
is
4213 Kind
: constant Node_Kind
:= Nkind
(N
);
4217 if Kind
= N_Real_Literal
then
4220 elsif Kind
= N_Identifier
or else Kind
= N_Expanded_Name
then
4222 pragma Assert
(Ekind
(Ent
) = E_Constant
);
4223 return Expr_Value_R
(Constant_Value
(Ent
));
4225 elsif Kind
= N_Integer_Literal
then
4226 return UR_From_Uint
(Expr_Value
(N
));
4228 -- Here, we have a node that cannot be interpreted as a compile time
4229 -- constant. That is definitely an error.
4232 raise Program_Error
;
4240 function Expr_Value_S
(N
: Node_Id
) return Node_Id
is
4242 if Nkind
(N
) = N_String_Literal
then
4245 pragma Assert
(Ekind
(Entity
(N
)) = E_Constant
);
4246 return Expr_Value_S
(Constant_Value
(Entity
(N
)));
4250 ----------------------------------
4251 -- Find_Universal_Operator_Type --
4252 ----------------------------------
4254 function Find_Universal_Operator_Type
(N
: Node_Id
) return Entity_Id
is
4255 PN
: constant Node_Id
:= Parent
(N
);
4256 Call
: constant Node_Id
:= Original_Node
(N
);
4257 Is_Int
: constant Boolean := Is_Integer_Type
(Etype
(N
));
4259 Is_Fix
: constant Boolean :=
4260 Nkind
(N
) in N_Binary_Op
4261 and then Nkind
(Right_Opnd
(N
)) /= Nkind
(Left_Opnd
(N
));
4262 -- A mixed-mode operation in this context indicates the presence of
4263 -- fixed-point type in the designated package.
4265 Is_Relational
: constant Boolean := Etype
(N
) = Standard_Boolean
;
4266 -- Case where N is a relational (or membership) operator (else it is an
4269 In_Membership
: constant Boolean :=
4270 Nkind
(PN
) in N_Membership_Test
4272 Nkind
(Right_Opnd
(PN
)) = N_Range
4274 Is_Universal_Numeric_Type
(Etype
(Left_Opnd
(PN
)))
4276 Is_Universal_Numeric_Type
4277 (Etype
(Low_Bound
(Right_Opnd
(PN
))))
4279 Is_Universal_Numeric_Type
4280 (Etype
(High_Bound
(Right_Opnd
(PN
))));
4281 -- Case where N is part of a membership test with a universal range
4285 Typ1
: Entity_Id
:= Empty
;
4288 function Is_Mixed_Mode_Operand
(Op
: Node_Id
) return Boolean;
4289 -- Check whether one operand is a mixed-mode operation that requires the
4290 -- presence of a fixed-point type. Given that all operands are universal
4291 -- and have been constant-folded, retrieve the original function call.
4293 ---------------------------
4294 -- Is_Mixed_Mode_Operand --
4295 ---------------------------
4297 function Is_Mixed_Mode_Operand
(Op
: Node_Id
) return Boolean is
4298 Onod
: constant Node_Id
:= Original_Node
(Op
);
4300 return Nkind
(Onod
) = N_Function_Call
4301 and then Present
(Next_Actual
(First_Actual
(Onod
)))
4302 and then Etype
(First_Actual
(Onod
)) /=
4303 Etype
(Next_Actual
(First_Actual
(Onod
)));
4304 end Is_Mixed_Mode_Operand
;
4306 -- Start of processing for Find_Universal_Operator_Type
4309 if Nkind
(Call
) /= N_Function_Call
4310 or else Nkind
(Name
(Call
)) /= N_Expanded_Name
4314 -- There are several cases where the context does not imply the type of
4316 -- - the universal expression appears in a type conversion;
4317 -- - the expression is a relational operator applied to universal
4319 -- - the expression is a membership test with a universal operand
4320 -- and a range with universal bounds.
4322 elsif Nkind
(Parent
(N
)) = N_Type_Conversion
4323 or else Is_Relational
4324 or else In_Membership
4326 Pack
:= Entity
(Prefix
(Name
(Call
)));
4328 -- If the prefix is a package declared elsewhere, iterate over its
4329 -- visible entities, otherwise iterate over all declarations in the
4330 -- designated scope.
4332 if Ekind
(Pack
) = E_Package
4333 and then not In_Open_Scopes
(Pack
)
4335 Priv_E
:= First_Private_Entity
(Pack
);
4341 E
:= First_Entity
(Pack
);
4342 while Present
(E
) and then E
/= Priv_E
loop
4343 if Is_Numeric_Type
(E
)
4344 and then Nkind
(Parent
(E
)) /= N_Subtype_Declaration
4345 and then Comes_From_Source
(E
)
4346 and then Is_Integer_Type
(E
) = Is_Int
4347 and then (Nkind
(N
) in N_Unary_Op
4348 or else Is_Relational
4349 or else Is_Fixed_Point_Type
(E
) = Is_Fix
)
4354 -- Before emitting an error, check for the presence of a
4355 -- mixed-mode operation that specifies a fixed point type.
4359 (Is_Mixed_Mode_Operand
(Left_Opnd
(N
))
4360 or else Is_Mixed_Mode_Operand
(Right_Opnd
(N
)))
4361 and then Is_Fixed_Point_Type
(E
) /= Is_Fixed_Point_Type
(Typ1
)
4364 if Is_Fixed_Point_Type
(E
) then
4369 -- More than one type of the proper class declared in P
4371 Error_Msg_N
("ambiguous operation", N
);
4372 Error_Msg_Sloc
:= Sloc
(Typ1
);
4373 Error_Msg_N
("\possible interpretation (inherited)#", N
);
4374 Error_Msg_Sloc
:= Sloc
(E
);
4375 Error_Msg_N
("\possible interpretation (inherited)#", N
);
4385 end Find_Universal_Operator_Type
;
4387 --------------------------
4388 -- Flag_Non_Static_Expr --
4389 --------------------------
4391 procedure Flag_Non_Static_Expr
(Msg
: String; Expr
: Node_Id
) is
4393 if Error_Posted
(Expr
) and then not All_Errors_Mode
then
4396 Error_Msg_F
(Msg
, Expr
);
4397 Why_Not_Static
(Expr
);
4399 end Flag_Non_Static_Expr
;
4405 procedure Fold_Str
(N
: Node_Id
; Val
: String_Id
; Static
: Boolean) is
4406 Loc
: constant Source_Ptr
:= Sloc
(N
);
4407 Typ
: constant Entity_Id
:= Etype
(N
);
4410 if Raises_Constraint_Error
(N
) then
4411 Set_Is_Static_Expression
(N
, Static
);
4415 Rewrite
(N
, Make_String_Literal
(Loc
, Strval
=> Val
));
4417 -- We now have the literal with the right value, both the actual type
4418 -- and the expected type of this literal are taken from the expression
4419 -- that was evaluated. So now we do the Analyze and Resolve.
4421 -- Note that we have to reset Is_Static_Expression both after the
4422 -- analyze step (because Resolve will evaluate the literal, which
4423 -- will cause semantic errors if it is marked as static), and after
4424 -- the Resolve step (since Resolve in some cases resets this flag).
4427 Set_Is_Static_Expression
(N
, Static
);
4430 Set_Is_Static_Expression
(N
, Static
);
4437 procedure Fold_Uint
(N
: Node_Id
; Val
: Uint
; Static
: Boolean) is
4438 Loc
: constant Source_Ptr
:= Sloc
(N
);
4439 Typ
: Entity_Id
:= Etype
(N
);
4443 if Raises_Constraint_Error
(N
) then
4444 Set_Is_Static_Expression
(N
, Static
);
4448 -- If we are folding a named number, retain the entity in the literal,
4451 if Is_Entity_Name
(N
) and then Ekind
(Entity
(N
)) = E_Named_Integer
then
4457 if Is_Private_Type
(Typ
) then
4458 Typ
:= Full_View
(Typ
);
4461 -- For a result of type integer, substitute an N_Integer_Literal node
4462 -- for the result of the compile time evaluation of the expression.
4463 -- For ASIS use, set a link to the original named number when not in
4464 -- a generic context.
4466 if Is_Integer_Type
(Typ
) then
4467 Rewrite
(N
, Make_Integer_Literal
(Loc
, Val
));
4468 Set_Original_Entity
(N
, Ent
);
4470 -- Otherwise we have an enumeration type, and we substitute either
4471 -- an N_Identifier or N_Character_Literal to represent the enumeration
4472 -- literal corresponding to the given value, which must always be in
4473 -- range, because appropriate tests have already been made for this.
4475 else pragma Assert
(Is_Enumeration_Type
(Typ
));
4476 Rewrite
(N
, Get_Enum_Lit_From_Pos
(Etype
(N
), Val
, Loc
));
4479 -- We now have the literal with the right value, both the actual type
4480 -- and the expected type of this literal are taken from the expression
4481 -- that was evaluated. So now we do the Analyze and Resolve.
4483 -- Note that we have to reset Is_Static_Expression both after the
4484 -- analyze step (because Resolve will evaluate the literal, which
4485 -- will cause semantic errors if it is marked as static), and after
4486 -- the Resolve step (since Resolve in some cases sets this flag).
4489 Set_Is_Static_Expression
(N
, Static
);
4492 Set_Is_Static_Expression
(N
, Static
);
4499 procedure Fold_Ureal
(N
: Node_Id
; Val
: Ureal
; Static
: Boolean) is
4500 Loc
: constant Source_Ptr
:= Sloc
(N
);
4501 Typ
: constant Entity_Id
:= Etype
(N
);
4505 if Raises_Constraint_Error
(N
) then
4506 Set_Is_Static_Expression
(N
, Static
);
4510 -- If we are folding a named number, retain the entity in the literal,
4513 if Is_Entity_Name
(N
) and then Ekind
(Entity
(N
)) = E_Named_Real
then
4519 Rewrite
(N
, Make_Real_Literal
(Loc
, Realval
=> Val
));
4521 -- Set link to original named number, for ASIS use
4523 Set_Original_Entity
(N
, Ent
);
4525 -- We now have the literal with the right value, both the actual type
4526 -- and the expected type of this literal are taken from the expression
4527 -- that was evaluated. So now we do the Analyze and Resolve.
4529 -- Note that we have to reset Is_Static_Expression both after the
4530 -- analyze step (because Resolve will evaluate the literal, which
4531 -- will cause semantic errors if it is marked as static), and after
4532 -- the Resolve step (since Resolve in some cases sets this flag).
4535 Set_Is_Static_Expression
(N
, Static
);
4538 Set_Is_Static_Expression
(N
, Static
);
4545 function From_Bits
(B
: Bits
; T
: Entity_Id
) return Uint
is
4549 for J
in 0 .. B
'Last loop
4555 if Non_Binary_Modulus
(T
) then
4556 V
:= V
mod Modulus
(T
);
4562 --------------------
4563 -- Get_String_Val --
4564 --------------------
4566 function Get_String_Val
(N
: Node_Id
) return Node_Id
is
4568 if Nkind_In
(N
, N_String_Literal
, N_Character_Literal
) then
4571 pragma Assert
(Is_Entity_Name
(N
));
4572 return Get_String_Val
(Constant_Value
(Entity
(N
)));
4580 procedure Initialize
is
4582 CV_Cache
:= (others => (Node_High_Bound
, Uint_0
));
4585 --------------------
4586 -- In_Subrange_Of --
4587 --------------------
4589 function In_Subrange_Of
4592 Fixed_Int
: Boolean := False) return Boolean
4601 if T1
= T2
or else Is_Subtype_Of
(T1
, T2
) then
4604 -- Never in range if both types are not scalar. Don't know if this can
4605 -- actually happen, but just in case.
4607 elsif not Is_Scalar_Type
(T1
) or else not Is_Scalar_Type
(T2
) then
4610 -- If T1 has infinities but T2 doesn't have infinities, then T1 is
4611 -- definitely not compatible with T2.
4613 elsif Is_Floating_Point_Type
(T1
)
4614 and then Has_Infinities
(T1
)
4615 and then Is_Floating_Point_Type
(T2
)
4616 and then not Has_Infinities
(T2
)
4621 L1
:= Type_Low_Bound
(T1
);
4622 H1
:= Type_High_Bound
(T1
);
4624 L2
:= Type_Low_Bound
(T2
);
4625 H2
:= Type_High_Bound
(T2
);
4627 -- Check bounds to see if comparison possible at compile time
4629 if Compile_Time_Compare
(L1
, L2
, Assume_Valid
=> True) in Compare_GE
4631 Compile_Time_Compare
(H1
, H2
, Assume_Valid
=> True) in Compare_LE
4636 -- If bounds not comparable at compile time, then the bounds of T2
4637 -- must be compile time known or we cannot answer the query.
4639 if not Compile_Time_Known_Value
(L2
)
4640 or else not Compile_Time_Known_Value
(H2
)
4645 -- If the bounds of T1 are know at compile time then use these
4646 -- ones, otherwise use the bounds of the base type (which are of
4647 -- course always static).
4649 if not Compile_Time_Known_Value
(L1
) then
4650 L1
:= Type_Low_Bound
(Base_Type
(T1
));
4653 if not Compile_Time_Known_Value
(H1
) then
4654 H1
:= Type_High_Bound
(Base_Type
(T1
));
4657 -- Fixed point types should be considered as such only if
4658 -- flag Fixed_Int is set to False.
4660 if Is_Floating_Point_Type
(T1
) or else Is_Floating_Point_Type
(T2
)
4661 or else (Is_Fixed_Point_Type
(T1
) and then not Fixed_Int
)
4662 or else (Is_Fixed_Point_Type
(T2
) and then not Fixed_Int
)
4665 Expr_Value_R
(L2
) <= Expr_Value_R
(L1
)
4667 Expr_Value_R
(H2
) >= Expr_Value_R
(H1
);
4671 Expr_Value
(L2
) <= Expr_Value
(L1
)
4673 Expr_Value
(H2
) >= Expr_Value
(H1
);
4678 -- If any exception occurs, it means that we have some bug in the compiler
4679 -- possibly triggered by a previous error, or by some unforeseen peculiar
4680 -- occurrence. However, this is only an optimization attempt, so there is
4681 -- really no point in crashing the compiler. Instead we just decide, too
4682 -- bad, we can't figure out the answer in this case after all.
4687 -- Debug flag K disables this behavior (useful for debugging)
4689 if Debug_Flag_K
then
4700 function Is_In_Range
4703 Assume_Valid
: Boolean := False;
4704 Fixed_Int
: Boolean := False;
4705 Int_Real
: Boolean := False) return Boolean
4709 Test_In_Range
(N
, Typ
, Assume_Valid
, Fixed_Int
, Int_Real
) = In_Range
;
4716 function Is_Null_Range
(Lo
: Node_Id
; Hi
: Node_Id
) return Boolean is
4717 Typ
: constant Entity_Id
:= Etype
(Lo
);
4720 if not Compile_Time_Known_Value
(Lo
)
4721 or else not Compile_Time_Known_Value
(Hi
)
4726 if Is_Discrete_Type
(Typ
) then
4727 return Expr_Value
(Lo
) > Expr_Value
(Hi
);
4728 else pragma Assert
(Is_Real_Type
(Typ
));
4729 return Expr_Value_R
(Lo
) > Expr_Value_R
(Hi
);
4733 -------------------------
4734 -- Is_OK_Static_Choice --
4735 -------------------------
4737 function Is_OK_Static_Choice
(Choice
: Node_Id
) return Boolean is
4739 -- Check various possibilities for choice
4741 -- Note: for membership tests, we test more cases than are possible
4742 -- (in particular subtype indication), but it doesn't matter because
4743 -- it just won't occur (we have already done a syntax check).
4745 if Nkind
(Choice
) = N_Others_Choice
then
4748 elsif Nkind
(Choice
) = N_Range
then
4749 return Is_OK_Static_Range
(Choice
);
4751 elsif Nkind
(Choice
) = N_Subtype_Indication
4752 or else (Is_Entity_Name
(Choice
) and then Is_Type
(Entity
(Choice
)))
4754 return Is_OK_Static_Subtype
(Etype
(Choice
));
4757 return Is_OK_Static_Expression
(Choice
);
4759 end Is_OK_Static_Choice
;
4761 ------------------------------
4762 -- Is_OK_Static_Choice_List --
4763 ------------------------------
4765 function Is_OK_Static_Choice_List
(Choices
: List_Id
) return Boolean is
4769 if not Is_Static_Choice_List
(Choices
) then
4773 Choice
:= First
(Choices
);
4774 while Present
(Choice
) loop
4775 if not Is_OK_Static_Choice
(Choice
) then
4776 Set_Raises_Constraint_Error
(Choice
);
4784 end Is_OK_Static_Choice_List
;
4786 -----------------------------
4787 -- Is_OK_Static_Expression --
4788 -----------------------------
4790 function Is_OK_Static_Expression
(N
: Node_Id
) return Boolean is
4792 return Is_Static_Expression
(N
) and then not Raises_Constraint_Error
(N
);
4793 end Is_OK_Static_Expression
;
4795 ------------------------
4796 -- Is_OK_Static_Range --
4797 ------------------------
4799 -- A static range is a range whose bounds are static expressions, or a
4800 -- Range_Attribute_Reference equivalent to such a range (RM 4.9(26)).
4801 -- We have already converted range attribute references, so we get the
4802 -- "or" part of this rule without needing a special test.
4804 function Is_OK_Static_Range
(N
: Node_Id
) return Boolean is
4806 return Is_OK_Static_Expression
(Low_Bound
(N
))
4807 and then Is_OK_Static_Expression
(High_Bound
(N
));
4808 end Is_OK_Static_Range
;
4810 --------------------------
4811 -- Is_OK_Static_Subtype --
4812 --------------------------
4814 -- Determines if Typ is a static subtype as defined in (RM 4.9(26)) where
4815 -- neither bound raises constraint error when evaluated.
4817 function Is_OK_Static_Subtype
(Typ
: Entity_Id
) return Boolean is
4818 Base_T
: constant Entity_Id
:= Base_Type
(Typ
);
4819 Anc_Subt
: Entity_Id
;
4822 -- First a quick check on the non static subtype flag. As described
4823 -- in further detail in Einfo, this flag is not decisive in all cases,
4824 -- but if it is set, then the subtype is definitely non-static.
4826 if Is_Non_Static_Subtype
(Typ
) then
4830 Anc_Subt
:= Ancestor_Subtype
(Typ
);
4832 if Anc_Subt
= Empty
then
4836 if Is_Generic_Type
(Root_Type
(Base_T
))
4837 or else Is_Generic_Actual_Type
(Base_T
)
4841 elsif Has_Dynamic_Predicate_Aspect
(Typ
) then
4846 elsif Is_String_Type
(Typ
) then
4848 Ekind
(Typ
) = E_String_Literal_Subtype
4850 (Is_OK_Static_Subtype
(Component_Type
(Typ
))
4851 and then Is_OK_Static_Subtype
(Etype
(First_Index
(Typ
))));
4855 elsif Is_Scalar_Type
(Typ
) then
4856 if Base_T
= Typ
then
4860 -- Scalar_Range (Typ) might be an N_Subtype_Indication, so use
4861 -- Get_Type_{Low,High}_Bound.
4863 return Is_OK_Static_Subtype
(Anc_Subt
)
4864 and then Is_OK_Static_Expression
(Type_Low_Bound
(Typ
))
4865 and then Is_OK_Static_Expression
(Type_High_Bound
(Typ
));
4868 -- Types other than string and scalar types are never static
4873 end Is_OK_Static_Subtype
;
4875 ---------------------
4876 -- Is_Out_Of_Range --
4877 ---------------------
4879 function Is_Out_Of_Range
4882 Assume_Valid
: Boolean := False;
4883 Fixed_Int
: Boolean := False;
4884 Int_Real
: Boolean := False) return Boolean
4887 return Test_In_Range
(N
, Typ
, Assume_Valid
, Fixed_Int
, Int_Real
) =
4889 end Is_Out_Of_Range
;
4891 ----------------------
4892 -- Is_Static_Choice --
4893 ----------------------
4895 function Is_Static_Choice
(Choice
: Node_Id
) return Boolean is
4897 -- Check various possibilities for choice
4899 -- Note: for membership tests, we test more cases than are possible
4900 -- (in particular subtype indication), but it doesn't matter because
4901 -- it just won't occur (we have already done a syntax check).
4903 if Nkind
(Choice
) = N_Others_Choice
then
4906 elsif Nkind
(Choice
) = N_Range
then
4907 return Is_Static_Range
(Choice
);
4909 elsif Nkind
(Choice
) = N_Subtype_Indication
4910 or else (Is_Entity_Name
(Choice
) and then Is_Type
(Entity
(Choice
)))
4912 return Is_Static_Subtype
(Etype
(Choice
));
4915 return Is_Static_Expression
(Choice
);
4917 end Is_Static_Choice
;
4919 ---------------------------
4920 -- Is_Static_Choice_List --
4921 ---------------------------
4923 function Is_Static_Choice_List
(Choices
: List_Id
) return Boolean is
4927 Choice
:= First
(Choices
);
4928 while Present
(Choice
) loop
4929 if not Is_Static_Choice
(Choice
) then
4937 end Is_Static_Choice_List
;
4939 ---------------------
4940 -- Is_Static_Range --
4941 ---------------------
4943 -- A static range is a range whose bounds are static expressions, or a
4944 -- Range_Attribute_Reference equivalent to such a range (RM 4.9(26)).
4945 -- We have already converted range attribute references, so we get the
4946 -- "or" part of this rule without needing a special test.
4948 function Is_Static_Range
(N
: Node_Id
) return Boolean is
4950 return Is_Static_Expression
(Low_Bound
(N
))
4952 Is_Static_Expression
(High_Bound
(N
));
4953 end Is_Static_Range
;
4955 -----------------------
4956 -- Is_Static_Subtype --
4957 -----------------------
4959 -- Determines if Typ is a static subtype as defined in (RM 4.9(26))
4961 function Is_Static_Subtype
(Typ
: Entity_Id
) return Boolean is
4962 Base_T
: constant Entity_Id
:= Base_Type
(Typ
);
4963 Anc_Subt
: Entity_Id
;
4966 -- First a quick check on the non static subtype flag. As described
4967 -- in further detail in Einfo, this flag is not decisive in all cases,
4968 -- but if it is set, then the subtype is definitely non-static.
4970 if Is_Non_Static_Subtype
(Typ
) then
4974 Anc_Subt
:= Ancestor_Subtype
(Typ
);
4976 if Anc_Subt
= Empty
then
4980 if Is_Generic_Type
(Root_Type
(Base_T
))
4981 or else Is_Generic_Actual_Type
(Base_T
)
4985 elsif Has_Dynamic_Predicate_Aspect
(Typ
) then
4990 elsif Is_String_Type
(Typ
) then
4992 Ekind
(Typ
) = E_String_Literal_Subtype
4993 or else (Is_Static_Subtype
(Component_Type
(Typ
))
4994 and then Is_Static_Subtype
(Etype
(First_Index
(Typ
))));
4998 elsif Is_Scalar_Type
(Typ
) then
4999 if Base_T
= Typ
then
5003 return Is_Static_Subtype
(Anc_Subt
)
5004 and then Is_Static_Expression
(Type_Low_Bound
(Typ
))
5005 and then Is_Static_Expression
(Type_High_Bound
(Typ
));
5008 -- Types other than string and scalar types are never static
5013 end Is_Static_Subtype
;
5015 -------------------------------
5016 -- Is_Statically_Unevaluated --
5017 -------------------------------
5019 function Is_Statically_Unevaluated
(Expr
: Node_Id
) return Boolean is
5020 function Check_Case_Expr_Alternative
5021 (CEA
: Node_Id
) return Match_Result
;
5022 -- We have a message emanating from the Expression of a case expression
5023 -- alternative. We examine this alternative, as follows:
5025 -- If the selecting expression of the parent case is non-static, or
5026 -- if any of the discrete choices of the given case alternative are
5027 -- non-static or raise Constraint_Error, return Non_Static.
5029 -- Otherwise check if the selecting expression matches any of the given
5030 -- discrete choices. If so, the alternative is executed and we return
5031 -- Match, otherwise, the alternative can never be executed, and so we
5034 ---------------------------------
5035 -- Check_Case_Expr_Alternative --
5036 ---------------------------------
5038 function Check_Case_Expr_Alternative
5039 (CEA
: Node_Id
) return Match_Result
5041 Case_Exp
: constant Node_Id
:= Parent
(CEA
);
5046 pragma Assert
(Nkind
(Case_Exp
) = N_Case_Expression
);
5048 -- Check that selecting expression is static
5050 if not Is_OK_Static_Expression
(Expression
(Case_Exp
)) then
5054 if not Is_OK_Static_Choice_List
(Discrete_Choices
(CEA
)) then
5058 -- All choices are now known to be static. Now see if alternative
5059 -- matches one of the choices.
5061 Choice
:= First
(Discrete_Choices
(CEA
));
5062 while Present
(Choice
) loop
5064 -- Check various possibilities for choice, returning Match if we
5065 -- find the selecting value matches any of the choices. Note that
5066 -- we know we are the last choice, so we don't have to keep going.
5068 if Nkind
(Choice
) = N_Others_Choice
then
5070 -- Others choice is a bit annoying, it matches if none of the
5071 -- previous alternatives matches (note that we know we are the
5072 -- last alternative in this case, so we can just go backwards
5073 -- from us to see if any previous one matches).
5075 Prev_CEA
:= Prev
(CEA
);
5076 while Present
(Prev_CEA
) loop
5077 if Check_Case_Expr_Alternative
(Prev_CEA
) = Match
then
5086 -- Else we have a normal static choice
5088 elsif Choice_Matches
(Expression
(Case_Exp
), Choice
) = Match
then
5092 -- If we fall through, it means that the discrete choice did not
5093 -- match the selecting expression, so continue.
5098 -- If we get through that loop then all choices were static, and none
5099 -- of them matched the selecting expression. So return No_Match.
5102 end Check_Case_Expr_Alternative
;
5110 -- Start of processing for Is_Statically_Unevaluated
5113 -- The (32.x) references here are from RM section 4.9
5115 -- (32.1) An expression is statically unevaluated if it is part of ...
5117 -- This means we have to climb the tree looking for one of the cases
5124 -- (32.2) The right operand of a static short-circuit control form
5125 -- whose value is determined by its left operand.
5127 -- AND THEN with False as left operand
5129 if Nkind
(P
) = N_And_Then
5130 and then Compile_Time_Known_Value
(Left_Opnd
(P
))
5131 and then Is_False
(Expr_Value
(Left_Opnd
(P
)))
5135 -- OR ELSE with True as left operand
5137 elsif Nkind
(P
) = N_Or_Else
5138 and then Compile_Time_Known_Value
(Left_Opnd
(P
))
5139 and then Is_True
(Expr_Value
(Left_Opnd
(P
)))
5143 -- (32.3) A dependent_expression of an if_expression whose associated
5144 -- condition is static and equals False.
5146 elsif Nkind
(P
) = N_If_Expression
then
5148 Cond
: constant Node_Id
:= First
(Expressions
(P
));
5149 Texp
: constant Node_Id
:= Next
(Cond
);
5150 Fexp
: constant Node_Id
:= Next
(Texp
);
5153 if Compile_Time_Known_Value
(Cond
) then
5155 -- Condition is True and we are in the right operand
5157 if Is_True
(Expr_Value
(Cond
)) and then OldP
= Fexp
then
5160 -- Condition is False and we are in the left operand
5162 elsif Is_False
(Expr_Value
(Cond
)) and then OldP
= Texp
then
5168 -- (32.4) A condition or dependent_expression of an if_expression
5169 -- where the condition corresponding to at least one preceding
5170 -- dependent_expression of the if_expression is static and equals
5173 -- This refers to cases like
5175 -- (if True then 1 elsif 1/0=2 then 2 else 3)
5177 -- But we expand elsif's out anyway, so the above looks like:
5179 -- (if True then 1 else (if 1/0=2 then 2 else 3))
5181 -- So for us this is caught by the above check for the 32.3 case.
5183 -- (32.5) A dependent_expression of a case_expression whose
5184 -- selecting_expression is static and whose value is not covered
5185 -- by the corresponding discrete_choice_list.
5187 elsif Nkind
(P
) = N_Case_Expression_Alternative
then
5189 -- First, we have to be in the expression to suppress messages.
5190 -- If we are within one of the choices, we want the message.
5192 if OldP
= Expression
(P
) then
5194 -- Statically unevaluated if alternative does not match
5196 if Check_Case_Expr_Alternative
(P
) = No_Match
then
5201 -- (32.6) A choice_expression (or a simple_expression of a range
5202 -- that occurs as a membership_choice of a membership_choice_list)
5203 -- of a static membership test that is preceded in the enclosing
5204 -- membership_choice_list by another item whose individual
5205 -- membership test (see (RM 4.5.2)) statically yields True.
5207 elsif Nkind
(P
) in N_Membership_Test
then
5209 -- Only possibly unevaluated if simple expression is static
5211 if not Is_OK_Static_Expression
(Left_Opnd
(P
)) then
5214 -- All members of the choice list must be static
5216 elsif (Present
(Right_Opnd
(P
))
5217 and then not Is_OK_Static_Choice
(Right_Opnd
(P
)))
5218 or else (Present
(Alternatives
(P
))
5220 not Is_OK_Static_Choice_List
(Alternatives
(P
)))
5224 -- If expression is the one and only alternative, then it is
5225 -- definitely not statically unevaluated, so we only have to
5226 -- test the case where there are alternatives present.
5228 elsif Present
(Alternatives
(P
)) then
5230 -- Look for previous matching Choice
5232 Choice
:= First
(Alternatives
(P
));
5233 while Present
(Choice
) loop
5235 -- If we reached us and no previous choices matched, this
5236 -- is not the case where we are statically unevaluated.
5238 exit when OldP
= Choice
;
5240 -- If a previous choice matches, then that is the case where
5241 -- we know our choice is statically unevaluated.
5243 if Choice_Matches
(Left_Opnd
(P
), Choice
) = Match
then
5250 -- If we fall through the loop, we were not one of the choices,
5251 -- we must have been the expression, so that is not covered by
5252 -- this rule, and we keep going.
5258 -- OK, not statically unevaluated at this level, see if we should
5259 -- keep climbing to look for a higher level reason.
5261 -- Special case for component association in aggregates, where
5262 -- we want to keep climbing up to the parent aggregate.
5264 if Nkind
(P
) = N_Component_Association
5265 and then Nkind
(Parent
(P
)) = N_Aggregate
5269 -- All done if not still within subexpression
5272 exit when Nkind
(P
) not in N_Subexpr
;
5276 -- If we fall through the loop, not one of the cases covered!
5279 end Is_Statically_Unevaluated
;
5281 --------------------
5282 -- Not_Null_Range --
5283 --------------------
5285 function Not_Null_Range
(Lo
: Node_Id
; Hi
: Node_Id
) return Boolean is
5286 Typ
: constant Entity_Id
:= Etype
(Lo
);
5289 if not Compile_Time_Known_Value
(Lo
)
5290 or else not Compile_Time_Known_Value
(Hi
)
5295 if Is_Discrete_Type
(Typ
) then
5296 return Expr_Value
(Lo
) <= Expr_Value
(Hi
);
5297 else pragma Assert
(Is_Real_Type
(Typ
));
5298 return Expr_Value_R
(Lo
) <= Expr_Value_R
(Hi
);
5306 function OK_Bits
(N
: Node_Id
; Bits
: Uint
) return Boolean is
5308 -- We allow a maximum of 500,000 bits which seems a reasonable limit
5310 if Bits
< 500_000
then
5313 -- Error if this maximum is exceeded
5316 Error_Msg_N
("static value too large, capacity exceeded", N
);
5325 procedure Out_Of_Range
(N
: Node_Id
) is
5327 -- If we have the static expression case, then this is an illegality
5328 -- in Ada 95 mode, except that in an instance, we never generate an
5329 -- error (if the error is legitimate, it was already diagnosed in the
5332 if Is_Static_Expression
(N
)
5333 and then not In_Instance
5334 and then not In_Inlined_Body
5335 and then Ada_Version
>= Ada_95
5337 -- No message if we are statically unevaluated
5339 if Is_Statically_Unevaluated
(N
) then
5342 -- The expression to compute the length of a packed array is attached
5343 -- to the array type itself, and deserves a separate message.
5345 elsif Nkind
(Parent
(N
)) = N_Defining_Identifier
5346 and then Is_Array_Type
(Parent
(N
))
5347 and then Present
(Packed_Array_Impl_Type
(Parent
(N
)))
5348 and then Present
(First_Rep_Item
(Parent
(N
)))
5351 ("length of packed array must not exceed Integer''Last",
5352 First_Rep_Item
(Parent
(N
)));
5353 Rewrite
(N
, Make_Integer_Literal
(Sloc
(N
), Uint_1
));
5355 -- All cases except the special array case
5358 Apply_Compile_Time_Constraint_Error
5359 (N
, "value not in range of}", CE_Range_Check_Failed
);
5362 -- Here we generate a warning for the Ada 83 case, or when we are in an
5363 -- instance, or when we have a non-static expression case.
5366 Apply_Compile_Time_Constraint_Error
5367 (N
, "value not in range of}??", CE_Range_Check_Failed
);
5371 ----------------------
5372 -- Predicates_Match --
5373 ----------------------
5375 function Predicates_Match
(T1
, T2
: Entity_Id
) return Boolean is
5380 if Ada_Version
< Ada_2012
then
5383 -- Both types must have predicates or lack them
5385 elsif Has_Predicates
(T1
) /= Has_Predicates
(T2
) then
5388 -- Check matching predicates
5393 (T1
, Name_Static_Predicate
, Check_Parents
=> False);
5396 (T2
, Name_Static_Predicate
, Check_Parents
=> False);
5398 -- Subtypes statically match if the predicate comes from the
5399 -- same declaration, which can only happen if one is a subtype
5400 -- of the other and has no explicit predicate.
5402 -- Suppress warnings on order of actuals, which is otherwise
5403 -- triggered by one of the two calls below.
5405 pragma Warnings
(Off
);
5406 return Pred1
= Pred2
5407 or else (No
(Pred1
) and then Is_Subtype_Of
(T1
, T2
))
5408 or else (No
(Pred2
) and then Is_Subtype_Of
(T2
, T1
));
5409 pragma Warnings
(On
);
5411 end Predicates_Match
;
5413 ---------------------------------------------
5414 -- Real_Or_String_Static_Predicate_Matches --
5415 ---------------------------------------------
5417 function Real_Or_String_Static_Predicate_Matches
5419 Typ
: Entity_Id
) return Boolean
5421 Expr
: constant Node_Id
:= Static_Real_Or_String_Predicate
(Typ
);
5422 -- The predicate expression from the type
5424 Pfun
: constant Entity_Id
:= Predicate_Function
(Typ
);
5425 -- The entity for the predicate function
5427 Ent_Name
: constant Name_Id
:= Chars
(First_Formal
(Pfun
));
5428 -- The name of the formal of the predicate function. Occurrences of the
5429 -- type name in Expr have been rewritten as references to this formal,
5430 -- and it has a unique name, so we can identify references by this name.
5433 -- Copy of the predicate function tree
5435 function Process
(N
: Node_Id
) return Traverse_Result
;
5436 -- Function used to process nodes during the traversal in which we will
5437 -- find occurrences of the entity name, and replace such occurrences
5438 -- by a real literal with the value to be tested.
5440 procedure Traverse
is new Traverse_Proc
(Process
);
5441 -- The actual traversal procedure
5447 function Process
(N
: Node_Id
) return Traverse_Result
is
5449 if Nkind
(N
) = N_Identifier
and then Chars
(N
) = Ent_Name
then
5451 Nod
: constant Node_Id
:= New_Copy
(Val
);
5453 Set_Sloc
(Nod
, Sloc
(N
));
5463 -- Start of processing for Real_Or_String_Static_Predicate_Matches
5466 -- First deal with special case of inherited predicate, where the
5467 -- predicate expression looks like:
5469 -- xxPredicate (typ (Ent)) and then Expr
5471 -- where Expr is the predicate expression for this level, and the
5472 -- left operand is the call to evaluate the inherited predicate.
5474 if Nkind
(Expr
) = N_And_Then
5475 and then Nkind
(Left_Opnd
(Expr
)) = N_Function_Call
5476 and then Is_Predicate_Function
(Entity
(Name
(Left_Opnd
(Expr
))))
5478 -- OK we have the inherited case, so make a call to evaluate the
5479 -- inherited predicate. If that fails, so do we!
5482 Real_Or_String_Static_Predicate_Matches
5484 Typ
=> Etype
(First_Formal
(Entity
(Name
(Left_Opnd
(Expr
))))))
5489 -- Use the right operand for the continued processing
5491 Copy
:= Copy_Separate_Tree
(Right_Opnd
(Expr
));
5493 -- Case where call to predicate function appears on its own (this means
5494 -- that the predicate at this level is just inherited from the parent).
5496 elsif Nkind
(Expr
) = N_Function_Call
then
5498 Typ
: constant Entity_Id
:=
5499 Etype
(First_Formal
(Entity
(Name
(Expr
))));
5502 -- If the inherited predicate is dynamic, just ignore it. We can't
5503 -- go trying to evaluate a dynamic predicate as a static one!
5505 if Has_Dynamic_Predicate_Aspect
(Typ
) then
5508 -- Otherwise inherited predicate is static, check for match
5511 return Real_Or_String_Static_Predicate_Matches
(Val
, Typ
);
5515 -- If not just an inherited predicate, copy whole expression
5518 Copy
:= Copy_Separate_Tree
(Expr
);
5521 -- Now we replace occurrences of the entity by the value
5525 -- And analyze the resulting static expression to see if it is True
5527 Analyze_And_Resolve
(Copy
, Standard_Boolean
);
5528 return Is_True
(Expr_Value
(Copy
));
5529 end Real_Or_String_Static_Predicate_Matches
;
5531 -------------------------
5532 -- Rewrite_In_Raise_CE --
5533 -------------------------
5535 procedure Rewrite_In_Raise_CE
(N
: Node_Id
; Exp
: Node_Id
) is
5536 Typ
: constant Entity_Id
:= Etype
(N
);
5537 Stat
: constant Boolean := Is_Static_Expression
(N
);
5540 -- If we want to raise CE in the condition of a N_Raise_CE node, we
5541 -- can just clear the condition if the reason is appropriate. We do
5542 -- not do this operation if the parent has a reason other than range
5543 -- check failed, because otherwise we would change the reason.
5545 if Present
(Parent
(N
))
5546 and then Nkind
(Parent
(N
)) = N_Raise_Constraint_Error
5547 and then Reason
(Parent
(N
)) =
5548 UI_From_Int
(RT_Exception_Code
'Pos (CE_Range_Check_Failed
))
5550 Set_Condition
(Parent
(N
), Empty
);
5552 -- Else build an explicit N_Raise_CE
5556 Make_Raise_Constraint_Error
(Sloc
(Exp
),
5557 Reason
=> CE_Range_Check_Failed
));
5558 Set_Raises_Constraint_Error
(N
);
5562 -- Set proper flags in result
5564 Set_Raises_Constraint_Error
(N
, True);
5565 Set_Is_Static_Expression
(N
, Stat
);
5566 end Rewrite_In_Raise_CE
;
5568 ---------------------
5569 -- String_Type_Len --
5570 ---------------------
5572 function String_Type_Len
(Stype
: Entity_Id
) return Uint
is
5573 NT
: constant Entity_Id
:= Etype
(First_Index
(Stype
));
5577 if Is_OK_Static_Subtype
(NT
) then
5580 T
:= Base_Type
(NT
);
5583 return Expr_Value
(Type_High_Bound
(T
)) -
5584 Expr_Value
(Type_Low_Bound
(T
)) + 1;
5585 end String_Type_Len
;
5587 ------------------------------------
5588 -- Subtypes_Statically_Compatible --
5589 ------------------------------------
5591 function Subtypes_Statically_Compatible
5594 Formal_Derived_Matching
: Boolean := False) return Boolean
5599 if Is_Scalar_Type
(T1
) then
5601 -- Definitely compatible if we match
5603 if Subtypes_Statically_Match
(T1
, T2
) then
5606 -- If either subtype is nonstatic then they're not compatible
5608 elsif not Is_OK_Static_Subtype
(T1
)
5610 not Is_OK_Static_Subtype
(T2
)
5614 -- If either type has constraint error bounds, then consider that
5615 -- they match to avoid junk cascaded errors here.
5617 elsif not Is_OK_Static_Subtype
(T1
)
5618 or else not Is_OK_Static_Subtype
(T2
)
5622 -- Base types must match, but we don't check that (should we???) but
5623 -- we do at least check that both types are real, or both types are
5626 elsif Is_Real_Type
(T1
) /= Is_Real_Type
(T2
) then
5629 -- Here we check the bounds
5633 LB1
: constant Node_Id
:= Type_Low_Bound
(T1
);
5634 HB1
: constant Node_Id
:= Type_High_Bound
(T1
);
5635 LB2
: constant Node_Id
:= Type_Low_Bound
(T2
);
5636 HB2
: constant Node_Id
:= Type_High_Bound
(T2
);
5639 if Is_Real_Type
(T1
) then
5641 (Expr_Value_R
(LB1
) > Expr_Value_R
(HB1
))
5643 (Expr_Value_R
(LB2
) <= Expr_Value_R
(LB1
)
5645 Expr_Value_R
(HB1
) <= Expr_Value_R
(HB2
));
5649 (Expr_Value
(LB1
) > Expr_Value
(HB1
))
5651 (Expr_Value
(LB2
) <= Expr_Value
(LB1
)
5653 Expr_Value
(HB1
) <= Expr_Value
(HB2
));
5660 elsif Is_Access_Type
(T1
) then
5661 return (not Is_Constrained
(T2
)
5662 or else (Subtypes_Statically_Match
5663 (Designated_Type
(T1
), Designated_Type
(T2
))))
5664 and then not (Can_Never_Be_Null
(T2
)
5665 and then not Can_Never_Be_Null
(T1
));
5670 return (Is_Composite_Type
(T1
) and then not Is_Constrained
(T2
))
5671 or else Subtypes_Statically_Match
(T1
, T2
, Formal_Derived_Matching
);
5673 end Subtypes_Statically_Compatible
;
5675 -------------------------------
5676 -- Subtypes_Statically_Match --
5677 -------------------------------
5679 -- Subtypes statically match if they have statically matching constraints
5680 -- (RM 4.9.1(2)). Constraints statically match if there are none, or if
5681 -- they are the same identical constraint, or if they are static and the
5682 -- values match (RM 4.9.1(1)).
5684 -- In addition, in GNAT, the object size (Esize) values of the types must
5685 -- match if they are set (unless checking an actual for a formal derived
5686 -- type). The use of 'Object_Size can cause this to be false even if the
5687 -- types would otherwise match in the RM sense.
5689 function Subtypes_Statically_Match
5692 Formal_Derived_Matching
: Boolean := False) return Boolean
5695 -- A type always statically matches itself
5700 -- No match if sizes different (from use of 'Object_Size). This test
5701 -- is excluded if Formal_Derived_Matching is True, as the base types
5702 -- can be different in that case and typically have different sizes
5703 -- (and Esizes can be set when Frontend_Layout_On_Target is True).
5705 elsif not Formal_Derived_Matching
5706 and then Known_Static_Esize
(T1
)
5707 and then Known_Static_Esize
(T2
)
5708 and then Esize
(T1
) /= Esize
(T2
)
5712 -- No match if predicates do not match
5714 elsif not Predicates_Match
(T1
, T2
) then
5719 elsif Is_Scalar_Type
(T1
) then
5721 -- Base types must be the same
5723 if Base_Type
(T1
) /= Base_Type
(T2
) then
5727 -- A constrained numeric subtype never matches an unconstrained
5728 -- subtype, i.e. both types must be constrained or unconstrained.
5730 -- To understand the requirement for this test, see RM 4.9.1(1).
5731 -- As is made clear in RM 3.5.4(11), type Integer, for example is
5732 -- a constrained subtype with constraint bounds matching the bounds
5733 -- of its corresponding unconstrained base type. In this situation,
5734 -- Integer and Integer'Base do not statically match, even though
5735 -- they have the same bounds.
5737 -- We only apply this test to types in Standard and types that appear
5738 -- in user programs. That way, we do not have to be too careful about
5739 -- setting Is_Constrained right for Itypes.
5741 if Is_Numeric_Type
(T1
)
5742 and then (Is_Constrained
(T1
) /= Is_Constrained
(T2
))
5743 and then (Scope
(T1
) = Standard_Standard
5744 or else Comes_From_Source
(T1
))
5745 and then (Scope
(T2
) = Standard_Standard
5746 or else Comes_From_Source
(T2
))
5750 -- A generic scalar type does not statically match its base type
5751 -- (AI-311). In this case we make sure that the formals, which are
5752 -- first subtypes of their bases, are constrained.
5754 elsif Is_Generic_Type
(T1
)
5755 and then Is_Generic_Type
(T2
)
5756 and then (Is_Constrained
(T1
) /= Is_Constrained
(T2
))
5761 -- If there was an error in either range, then just assume the types
5762 -- statically match to avoid further junk errors.
5764 if No
(Scalar_Range
(T1
)) or else No
(Scalar_Range
(T2
))
5765 or else Error_Posted
(Scalar_Range
(T1
))
5766 or else Error_Posted
(Scalar_Range
(T2
))
5771 -- Otherwise both types have bounds that can be compared
5774 LB1
: constant Node_Id
:= Type_Low_Bound
(T1
);
5775 HB1
: constant Node_Id
:= Type_High_Bound
(T1
);
5776 LB2
: constant Node_Id
:= Type_Low_Bound
(T2
);
5777 HB2
: constant Node_Id
:= Type_High_Bound
(T2
);
5780 -- If the bounds are the same tree node, then match (common case)
5782 if LB1
= LB2
and then HB1
= HB2
then
5785 -- Otherwise bounds must be static and identical value
5788 if not Is_OK_Static_Subtype
(T1
)
5789 or else not Is_OK_Static_Subtype
(T2
)
5793 -- If either type has constraint error bounds, then say that
5794 -- they match to avoid junk cascaded errors here.
5796 elsif not Is_OK_Static_Subtype
(T1
)
5797 or else not Is_OK_Static_Subtype
(T2
)
5801 elsif Is_Real_Type
(T1
) then
5803 (Expr_Value_R
(LB1
) = Expr_Value_R
(LB2
))
5805 (Expr_Value_R
(HB1
) = Expr_Value_R
(HB2
));
5809 Expr_Value
(LB1
) = Expr_Value
(LB2
)
5811 Expr_Value
(HB1
) = Expr_Value
(HB2
);
5816 -- Type with discriminants
5818 elsif Has_Discriminants
(T1
) or else Has_Discriminants
(T2
) then
5820 -- Because of view exchanges in multiple instantiations, conformance
5821 -- checking might try to match a partial view of a type with no
5822 -- discriminants with a full view that has defaulted discriminants.
5823 -- In such a case, use the discriminant constraint of the full view,
5824 -- which must exist because we know that the two subtypes have the
5827 if Has_Discriminants
(T1
) /= Has_Discriminants
(T2
) then
5828 -- A generic actual type is declared through a subtype declaration
5829 -- and may have an inconsistent indication of the presence of
5830 -- discriminants, so check the type it renames.
5832 if Is_Generic_Actual_Type
(T1
)
5833 and then not Has_Discriminants
(Etype
(T1
))
5834 and then not Has_Discriminants
(T2
)
5838 elsif In_Instance
then
5839 if Is_Private_Type
(T2
)
5840 and then Present
(Full_View
(T2
))
5841 and then Has_Discriminants
(Full_View
(T2
))
5843 return Subtypes_Statically_Match
(T1
, Full_View
(T2
));
5845 elsif Is_Private_Type
(T1
)
5846 and then Present
(Full_View
(T1
))
5847 and then Has_Discriminants
(Full_View
(T1
))
5849 return Subtypes_Statically_Match
(Full_View
(T1
), T2
);
5860 DL1
: constant Elist_Id
:= Discriminant_Constraint
(T1
);
5861 DL2
: constant Elist_Id
:= Discriminant_Constraint
(T2
);
5869 elsif Is_Constrained
(T1
) /= Is_Constrained
(T2
) then
5873 -- Now loop through the discriminant constraints
5875 -- Note: the guard here seems necessary, since it is possible at
5876 -- least for DL1 to be No_Elist. Not clear this is reasonable ???
5878 if Present
(DL1
) and then Present
(DL2
) then
5879 DA1
:= First_Elmt
(DL1
);
5880 DA2
:= First_Elmt
(DL2
);
5881 while Present
(DA1
) loop
5883 Expr1
: constant Node_Id
:= Node
(DA1
);
5884 Expr2
: constant Node_Id
:= Node
(DA2
);
5887 if not Is_OK_Static_Expression
(Expr1
)
5888 or else not Is_OK_Static_Expression
(Expr2
)
5892 -- If either expression raised a constraint error,
5893 -- consider the expressions as matching, since this
5894 -- helps to prevent cascading errors.
5896 elsif Raises_Constraint_Error
(Expr1
)
5897 or else Raises_Constraint_Error
(Expr2
)
5901 elsif Expr_Value
(Expr1
) /= Expr_Value
(Expr2
) then
5914 -- A definite type does not match an indefinite or classwide type.
5915 -- However, a generic type with unknown discriminants may be
5916 -- instantiated with a type with no discriminants, and conformance
5917 -- checking on an inherited operation may compare the actual with the
5918 -- subtype that renames it in the instance.
5920 elsif Has_Unknown_Discriminants
(T1
) /= Has_Unknown_Discriminants
(T2
)
5923 Is_Generic_Actual_Type
(T1
) or else Is_Generic_Actual_Type
(T2
);
5927 elsif Is_Array_Type
(T1
) then
5929 -- If either subtype is unconstrained then both must be, and if both
5930 -- are unconstrained then no further checking is needed.
5932 if not Is_Constrained
(T1
) or else not Is_Constrained
(T2
) then
5933 return not (Is_Constrained
(T1
) or else Is_Constrained
(T2
));
5936 -- Both subtypes are constrained, so check that the index subtypes
5937 -- statically match.
5940 Index1
: Node_Id
:= First_Index
(T1
);
5941 Index2
: Node_Id
:= First_Index
(T2
);
5944 while Present
(Index1
) loop
5946 Subtypes_Statically_Match
(Etype
(Index1
), Etype
(Index2
))
5951 Next_Index
(Index1
);
5952 Next_Index
(Index2
);
5958 elsif Is_Access_Type
(T1
) then
5959 if Can_Never_Be_Null
(T1
) /= Can_Never_Be_Null
(T2
) then
5962 elsif Ekind_In
(T1
, E_Access_Subprogram_Type
,
5963 E_Anonymous_Access_Subprogram_Type
)
5967 (Designated_Type
(T1
),
5968 Designated_Type
(T2
));
5971 Subtypes_Statically_Match
5972 (Designated_Type
(T1
),
5973 Designated_Type
(T2
))
5974 and then Is_Access_Constant
(T1
) = Is_Access_Constant
(T2
);
5977 -- All other types definitely match
5982 end Subtypes_Statically_Match
;
5988 function Test
(Cond
: Boolean) return Uint
is
5997 ---------------------------------
5998 -- Test_Expression_Is_Foldable --
5999 ---------------------------------
6003 procedure Test_Expression_Is_Foldable
6013 if Debug_Flag_Dot_F
and then In_Extended_Main_Source_Unit
(N
) then
6017 -- If operand is Any_Type, just propagate to result and do not
6018 -- try to fold, this prevents cascaded errors.
6020 if Etype
(Op1
) = Any_Type
then
6021 Set_Etype
(N
, Any_Type
);
6024 -- If operand raises constraint error, then replace node N with the
6025 -- raise constraint error node, and we are obviously not foldable.
6026 -- Note that this replacement inherits the Is_Static_Expression flag
6027 -- from the operand.
6029 elsif Raises_Constraint_Error
(Op1
) then
6030 Rewrite_In_Raise_CE
(N
, Op1
);
6033 -- If the operand is not static, then the result is not static, and
6034 -- all we have to do is to check the operand since it is now known
6035 -- to appear in a non-static context.
6037 elsif not Is_Static_Expression
(Op1
) then
6038 Check_Non_Static_Context
(Op1
);
6039 Fold
:= Compile_Time_Known_Value
(Op1
);
6042 -- An expression of a formal modular type is not foldable because
6043 -- the modulus is unknown.
6045 elsif Is_Modular_Integer_Type
(Etype
(Op1
))
6046 and then Is_Generic_Type
(Etype
(Op1
))
6048 Check_Non_Static_Context
(Op1
);
6051 -- Here we have the case of an operand whose type is OK, which is
6052 -- static, and which does not raise constraint error, we can fold.
6055 Set_Is_Static_Expression
(N
);
6059 end Test_Expression_Is_Foldable
;
6063 procedure Test_Expression_Is_Foldable
6069 CRT_Safe
: Boolean := False)
6071 Rstat
: constant Boolean := Is_Static_Expression
(Op1
)
6073 Is_Static_Expression
(Op2
);
6079 -- Inhibit folding if -gnatd.f flag set
6081 if Debug_Flag_Dot_F
and then In_Extended_Main_Source_Unit
(N
) then
6085 -- If either operand is Any_Type, just propagate to result and
6086 -- do not try to fold, this prevents cascaded errors.
6088 if Etype
(Op1
) = Any_Type
or else Etype
(Op2
) = Any_Type
then
6089 Set_Etype
(N
, Any_Type
);
6092 -- If left operand raises constraint error, then replace node N with the
6093 -- Raise_Constraint_Error node, and we are obviously not foldable.
6094 -- Is_Static_Expression is set from the two operands in the normal way,
6095 -- and we check the right operand if it is in a non-static context.
6097 elsif Raises_Constraint_Error
(Op1
) then
6099 Check_Non_Static_Context
(Op2
);
6102 Rewrite_In_Raise_CE
(N
, Op1
);
6103 Set_Is_Static_Expression
(N
, Rstat
);
6106 -- Similar processing for the case of the right operand. Note that we
6107 -- don't use this routine for the short-circuit case, so we do not have
6108 -- to worry about that special case here.
6110 elsif Raises_Constraint_Error
(Op2
) then
6112 Check_Non_Static_Context
(Op1
);
6115 Rewrite_In_Raise_CE
(N
, Op2
);
6116 Set_Is_Static_Expression
(N
, Rstat
);
6119 -- Exclude expressions of a generic modular type, as above
6121 elsif Is_Modular_Integer_Type
(Etype
(Op1
))
6122 and then Is_Generic_Type
(Etype
(Op1
))
6124 Check_Non_Static_Context
(Op1
);
6127 -- If result is not static, then check non-static contexts on operands
6128 -- since one of them may be static and the other one may not be static.
6130 elsif not Rstat
then
6131 Check_Non_Static_Context
(Op1
);
6132 Check_Non_Static_Context
(Op2
);
6135 Fold
:= CRT_Safe_Compile_Time_Known_Value
(Op1
)
6136 and then CRT_Safe_Compile_Time_Known_Value
(Op2
);
6138 Fold
:= Compile_Time_Known_Value
(Op1
)
6139 and then Compile_Time_Known_Value
(Op2
);
6144 -- Else result is static and foldable. Both operands are static, and
6145 -- neither raises constraint error, so we can definitely fold.
6148 Set_Is_Static_Expression
(N
);
6153 end Test_Expression_Is_Foldable
;
6159 function Test_In_Range
6162 Assume_Valid
: Boolean;
6163 Fixed_Int
: Boolean;
6164 Int_Real
: Boolean) return Range_Membership
6169 pragma Warnings
(Off
, Assume_Valid
);
6170 -- For now Assume_Valid is unreferenced since the current implementation
6171 -- always returns Unknown if N is not a compile time known value, but we
6172 -- keep the parameter to allow for future enhancements in which we try
6173 -- to get the information in the variable case as well.
6176 -- If an error was posted on expression, then return Unknown, we do not
6177 -- want cascaded errors based on some false analysis of a junk node.
6179 if Error_Posted
(N
) then
6182 -- Expression that raises constraint error is an odd case. We certainly
6183 -- do not want to consider it to be in range. It might make sense to
6184 -- consider it always out of range, but this causes incorrect error
6185 -- messages about static expressions out of range. So we just return
6186 -- Unknown, which is always safe.
6188 elsif Raises_Constraint_Error
(N
) then
6191 -- Universal types have no range limits, so always in range
6193 elsif Typ
= Universal_Integer
or else Typ
= Universal_Real
then
6196 -- Never known if not scalar type. Don't know if this can actually
6197 -- happen, but our spec allows it, so we must check.
6199 elsif not Is_Scalar_Type
(Typ
) then
6202 -- Never known if this is a generic type, since the bounds of generic
6203 -- types are junk. Note that if we only checked for static expressions
6204 -- (instead of compile time known values) below, we would not need this
6205 -- check, because values of a generic type can never be static, but they
6206 -- can be known at compile time.
6208 elsif Is_Generic_Type
(Typ
) then
6211 -- Case of a known compile time value, where we can check if it is in
6212 -- the bounds of the given type.
6214 elsif Compile_Time_Known_Value
(N
) then
6223 Lo
:= Type_Low_Bound
(Typ
);
6224 Hi
:= Type_High_Bound
(Typ
);
6226 LB_Known
:= Compile_Time_Known_Value
(Lo
);
6227 HB_Known
:= Compile_Time_Known_Value
(Hi
);
6229 -- Fixed point types should be considered as such only if flag
6230 -- Fixed_Int is set to False.
6232 if Is_Floating_Point_Type
(Typ
)
6233 or else (Is_Fixed_Point_Type
(Typ
) and then not Fixed_Int
)
6236 Valr
:= Expr_Value_R
(N
);
6238 if LB_Known
and HB_Known
then
6239 if Valr
>= Expr_Value_R
(Lo
)
6241 Valr
<= Expr_Value_R
(Hi
)
6245 return Out_Of_Range
;
6248 elsif (LB_Known
and then Valr
< Expr_Value_R
(Lo
))
6250 (HB_Known
and then Valr
> Expr_Value_R
(Hi
))
6252 return Out_Of_Range
;
6259 Val
:= Expr_Value
(N
);
6261 if LB_Known
and HB_Known
then
6262 if Val
>= Expr_Value
(Lo
) and then Val
<= Expr_Value
(Hi
)
6266 return Out_Of_Range
;
6269 elsif (LB_Known
and then Val
< Expr_Value
(Lo
))
6271 (HB_Known
and then Val
> Expr_Value
(Hi
))
6273 return Out_Of_Range
;
6281 -- Here for value not known at compile time. Case of expression subtype
6282 -- is Typ or is a subtype of Typ, and we can assume expression is valid.
6283 -- In this case we know it is in range without knowing its value.
6286 and then (Etype
(N
) = Typ
or else Is_Subtype_Of
(Etype
(N
), Typ
))
6290 -- Another special case. For signed integer types, if the target type
6291 -- has Is_Known_Valid set, and the source type does not have a larger
6292 -- size, then the source value must be in range. We exclude biased
6293 -- types, because they bizarrely can generate out of range values.
6295 elsif Is_Signed_Integer_Type
(Etype
(N
))
6296 and then Is_Known_Valid
(Typ
)
6297 and then Esize
(Etype
(N
)) <= Esize
(Typ
)
6298 and then not Has_Biased_Representation
(Etype
(N
))
6302 -- For all other cases, result is unknown
6313 procedure To_Bits
(U
: Uint
; B
: out Bits
) is
6315 for J
in 0 .. B
'Last loop
6316 B
(J
) := (U
/ (2 ** J
)) mod 2 /= 0;
6320 --------------------
6321 -- Why_Not_Static --
6322 --------------------
6324 procedure Why_Not_Static
(Expr
: Node_Id
) is
6325 N
: constant Node_Id
:= Original_Node
(Expr
);
6331 procedure Why_Not_Static_List
(L
: List_Id
);
6332 -- A version that can be called on a list of expressions. Finds all
6333 -- non-static violations in any element of the list.
6335 -------------------------
6336 -- Why_Not_Static_List --
6337 -------------------------
6339 procedure Why_Not_Static_List
(L
: List_Id
) is
6342 if Is_Non_Empty_List
(L
) then
6344 while Present
(N
) loop
6349 end Why_Not_Static_List
;
6351 -- Start of processing for Why_Not_Static
6354 -- Ignore call on error or empty node
6356 if No
(Expr
) or else Nkind
(Expr
) = N_Error
then
6360 -- Preprocessing for sub expressions
6362 if Nkind
(Expr
) in N_Subexpr
then
6364 -- Nothing to do if expression is static
6366 if Is_OK_Static_Expression
(Expr
) then
6370 -- Test for constraint error raised
6372 if Raises_Constraint_Error
(Expr
) then
6374 -- Special case membership to find out which piece to flag
6376 if Nkind
(N
) in N_Membership_Test
then
6377 if Raises_Constraint_Error
(Left_Opnd
(N
)) then
6378 Why_Not_Static
(Left_Opnd
(N
));
6381 elsif Present
(Right_Opnd
(N
))
6382 and then Raises_Constraint_Error
(Right_Opnd
(N
))
6384 Why_Not_Static
(Right_Opnd
(N
));
6388 pragma Assert
(Present
(Alternatives
(N
)));
6390 Alt
:= First
(Alternatives
(N
));
6391 while Present
(Alt
) loop
6392 if Raises_Constraint_Error
(Alt
) then
6393 Why_Not_Static
(Alt
);
6401 -- Special case a range to find out which bound to flag
6403 elsif Nkind
(N
) = N_Range
then
6404 if Raises_Constraint_Error
(Low_Bound
(N
)) then
6405 Why_Not_Static
(Low_Bound
(N
));
6408 elsif Raises_Constraint_Error
(High_Bound
(N
)) then
6409 Why_Not_Static
(High_Bound
(N
));
6413 -- Special case attribute to see which part to flag
6415 elsif Nkind
(N
) = N_Attribute_Reference
then
6416 if Raises_Constraint_Error
(Prefix
(N
)) then
6417 Why_Not_Static
(Prefix
(N
));
6421 if Present
(Expressions
(N
)) then
6422 Exp
:= First
(Expressions
(N
));
6423 while Present
(Exp
) loop
6424 if Raises_Constraint_Error
(Exp
) then
6425 Why_Not_Static
(Exp
);
6433 -- Special case a subtype name
6435 elsif Is_Entity_Name
(Expr
) and then Is_Type
(Entity
(Expr
)) then
6437 ("!& is not a static subtype (RM 4.9(26))", N
, Entity
(Expr
));
6441 -- End of special cases
6444 ("!expression raises exception, cannot be static (RM 4.9(34))",
6449 -- If no type, then something is pretty wrong, so ignore
6451 Typ
:= Etype
(Expr
);
6457 -- Type must be scalar or string type (but allow Bignum, since this
6458 -- is really a scalar type from our point of view in this diagnosis).
6460 if not Is_Scalar_Type
(Typ
)
6461 and then not Is_String_Type
(Typ
)
6462 and then not Is_RTE
(Typ
, RE_Bignum
)
6465 ("!static expression must have scalar or string type " &
6471 -- If we got through those checks, test particular node kind
6477 when N_Expanded_Name | N_Identifier | N_Operator_Symbol
=>
6480 if Is_Named_Number
(E
) then
6483 elsif Ekind
(E
) = E_Constant
then
6485 -- One case we can give a metter message is when we have a
6486 -- string literal created by concatenating an aggregate with
6487 -- an others expression.
6489 Entity_Case
: declare
6490 CV
: constant Node_Id
:= Constant_Value
(E
);
6491 CO
: constant Node_Id
:= Original_Node
(CV
);
6493 function Is_Aggregate
(N
: Node_Id
) return Boolean;
6494 -- See if node N came from an others aggregate, if so
6495 -- return True and set Error_Msg_Sloc to aggregate.
6501 function Is_Aggregate
(N
: Node_Id
) return Boolean is
6503 if Nkind
(Original_Node
(N
)) = N_Aggregate
then
6504 Error_Msg_Sloc
:= Sloc
(Original_Node
(N
));
6507 elsif Is_Entity_Name
(N
)
6508 and then Ekind
(Entity
(N
)) = E_Constant
6510 Nkind
(Original_Node
(Constant_Value
(Entity
(N
)))) =
6514 Sloc
(Original_Node
(Constant_Value
(Entity
(N
))));
6522 -- Start of processing for Entity_Case
6525 if Is_Aggregate
(CV
)
6526 or else (Nkind
(CO
) = N_Op_Concat
6527 and then (Is_Aggregate
(Left_Opnd
(CO
))
6529 Is_Aggregate
(Right_Opnd
(CO
))))
6531 Error_Msg_N
("!aggregate (#) is never static", N
);
6533 elsif No
(CV
) or else not Is_Static_Expression
(CV
) then
6535 ("!& is not a static constant (RM 4.9(5))", N
, E
);
6539 elsif Is_Type
(E
) then
6541 ("!& is not a static subtype (RM 4.9(26))", N
, E
);
6545 ("!& is not static constant or named number "
6546 & "(RM 4.9(5))", N
, E
);
6551 when N_Binary_Op | N_Short_Circuit | N_Membership_Test
=>
6552 if Nkind
(N
) in N_Op_Shift
then
6554 ("!shift functions are never static (RM 4.9(6,18))", N
);
6556 Why_Not_Static
(Left_Opnd
(N
));
6557 Why_Not_Static
(Right_Opnd
(N
));
6563 Why_Not_Static
(Right_Opnd
(N
));
6565 -- Attribute reference
6567 when N_Attribute_Reference
=>
6568 Why_Not_Static_List
(Expressions
(N
));
6570 E
:= Etype
(Prefix
(N
));
6572 if E
= Standard_Void_Type
then
6576 -- Special case non-scalar'Size since this is a common error
6578 if Attribute_Name
(N
) = Name_Size
then
6580 ("!size attribute is only static for static scalar type "
6581 & "(RM 4.9(7,8))", N
);
6585 elsif Is_Array_Type
(E
) then
6586 if not Nam_In
(Attribute_Name
(N
), Name_First
,
6591 ("!static array attribute must be Length, First, or Last "
6592 & "(RM 4.9(8))", N
);
6594 -- Since we know the expression is not-static (we already
6595 -- tested for this, must mean array is not static).
6599 ("!prefix is non-static array (RM 4.9(8))", Prefix
(N
));
6604 -- Special case generic types, since again this is a common source
6607 elsif Is_Generic_Actual_Type
(E
) or else Is_Generic_Type
(E
) then
6609 ("!attribute of generic type is never static "
6610 & "(RM 4.9(7,8))", N
);
6612 elsif Is_OK_Static_Subtype
(E
) then
6615 elsif Is_Scalar_Type
(E
) then
6617 ("!prefix type for attribute is not static scalar subtype "
6618 & "(RM 4.9(7))", N
);
6622 ("!static attribute must apply to array/scalar type "
6623 & "(RM 4.9(7,8))", N
);
6628 when N_String_Literal
=>
6630 ("!subtype of string literal is non-static (RM 4.9(4))", N
);
6632 -- Explicit dereference
6634 when N_Explicit_Dereference
=>
6636 ("!explicit dereference is never static (RM 4.9)", N
);
6640 when N_Function_Call
=>
6641 Why_Not_Static_List
(Parameter_Associations
(N
));
6643 -- Complain about non-static function call unless we have Bignum
6644 -- which means that the underlying expression is really some
6645 -- scalar arithmetic operation.
6647 if not Is_RTE
(Typ
, RE_Bignum
) then
6648 Error_Msg_N
("!non-static function call (RM 4.9(6,18))", N
);
6651 -- Parameter assocation (test actual parameter)
6653 when N_Parameter_Association
=>
6654 Why_Not_Static
(Explicit_Actual_Parameter
(N
));
6656 -- Indexed component
6658 when N_Indexed_Component
=>
6659 Error_Msg_N
("!indexed component is never static (RM 4.9)", N
);
6663 when N_Procedure_Call_Statement
=>
6664 Error_Msg_N
("!procedure call is never static (RM 4.9)", N
);
6666 -- Qualified expression (test expression)
6668 when N_Qualified_Expression
=>
6669 Why_Not_Static
(Expression
(N
));
6673 when N_Aggregate | N_Extension_Aggregate
=>
6674 Error_Msg_N
("!an aggregate is never static (RM 4.9)", N
);
6679 Why_Not_Static
(Low_Bound
(N
));
6680 Why_Not_Static
(High_Bound
(N
));
6682 -- Range constraint, test range expression
6684 when N_Range_Constraint
=>
6685 Why_Not_Static
(Range_Expression
(N
));
6687 -- Subtype indication, test constraint
6689 when N_Subtype_Indication
=>
6690 Why_Not_Static
(Constraint
(N
));
6692 -- Selected component
6694 when N_Selected_Component
=>
6695 Error_Msg_N
("!selected component is never static (RM 4.9)", N
);
6700 Error_Msg_N
("!slice is never static (RM 4.9)", N
);
6702 when N_Type_Conversion
=>
6703 Why_Not_Static
(Expression
(N
));
6705 if not Is_Scalar_Type
(Entity
(Subtype_Mark
(N
)))
6706 or else not Is_OK_Static_Subtype
(Entity
(Subtype_Mark
(N
)))
6709 ("!static conversion requires static scalar subtype result "
6710 & "(RM 4.9(9))", N
);
6713 -- Unchecked type conversion
6715 when N_Unchecked_Type_Conversion
=>
6717 ("!unchecked type conversion is never static (RM 4.9)", N
);
6719 -- All other cases, no reason to give