1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 with Atree
; use Atree
;
27 with Checks
; use Checks
;
28 with Debug
; use Debug
;
29 with Einfo
; use Einfo
;
30 with Elists
; use Elists
;
31 with Errout
; use Errout
;
32 with Eval_Fat
; use Eval_Fat
;
33 with Exp_Util
; use Exp_Util
;
34 with Freeze
; use Freeze
;
36 with Namet
; use Namet
;
37 with Nmake
; use Nmake
;
38 with Nlists
; use Nlists
;
40 with Par_SCO
; use Par_SCO
;
41 with Rtsfind
; use Rtsfind
;
43 with Sem_Aux
; use Sem_Aux
;
44 with Sem_Cat
; use Sem_Cat
;
45 with Sem_Ch6
; use Sem_Ch6
;
46 with Sem_Ch8
; use Sem_Ch8
;
47 with Sem_Res
; use Sem_Res
;
48 with Sem_Util
; use Sem_Util
;
49 with Sem_Type
; use Sem_Type
;
50 with Sem_Warn
; use Sem_Warn
;
51 with Sinfo
; use Sinfo
;
52 with Snames
; use Snames
;
53 with Stand
; use Stand
;
54 with Stringt
; use Stringt
;
55 with Tbuild
; use Tbuild
;
57 package body Sem_Eval
is
59 -----------------------------------------
60 -- Handling of Compile Time Evaluation --
61 -----------------------------------------
63 -- The compile time evaluation of expressions is distributed over several
64 -- Eval_xxx procedures. These procedures are called immediately after
65 -- a subexpression is resolved and is therefore accomplished in a bottom
66 -- up fashion. The flags are synthesized using the following approach.
68 -- Is_Static_Expression is determined by following the detailed rules
69 -- in RM 4.9(4-14). This involves testing the Is_Static_Expression
70 -- flag of the operands in many cases.
72 -- Raises_Constraint_Error is set if any of the operands have the flag
73 -- set or if an attempt to compute the value of the current expression
74 -- results in detection of a runtime constraint error.
76 -- As described in the spec, the requirement is that Is_Static_Expression
77 -- be accurately set, and in addition for nodes for which this flag is set,
78 -- Raises_Constraint_Error must also be set. Furthermore a node which has
79 -- Is_Static_Expression set, and Raises_Constraint_Error clear, then the
80 -- requirement is that the expression value must be precomputed, and the
81 -- node is either a literal, or the name of a constant entity whose value
82 -- is a static expression.
84 -- The general approach is as follows. First compute Is_Static_Expression.
85 -- If the node is not static, then the flag is left off in the node and
86 -- we are all done. Otherwise for a static node, we test if any of the
87 -- operands will raise constraint error, and if so, propagate the flag
88 -- Raises_Constraint_Error to the result node and we are done (since the
89 -- error was already posted at a lower level).
91 -- For the case of a static node whose operands do not raise constraint
92 -- error, we attempt to evaluate the node. If this evaluation succeeds,
93 -- then the node is replaced by the result of this computation. If the
94 -- evaluation raises constraint error, then we rewrite the node with
95 -- Apply_Compile_Time_Constraint_Error to raise the exception and also
96 -- to post appropriate error messages.
102 type Bits
is array (Nat
range <>) of Boolean;
103 -- Used to convert unsigned (modular) values for folding logical ops
105 -- The following declarations are used to maintain a cache of nodes that
106 -- have compile time known values. The cache is maintained only for
107 -- discrete types (the most common case), and is populated by calls to
108 -- Compile_Time_Known_Value and Expr_Value, but only used by Expr_Value
109 -- since it is possible for the status to change (in particular it is
110 -- possible for a node to get replaced by a constraint error node).
112 CV_Bits
: constant := 5;
113 -- Number of low order bits of Node_Id value used to reference entries
114 -- in the cache table.
116 CV_Cache_Size
: constant Nat
:= 2 ** CV_Bits
;
117 -- Size of cache for compile time values
119 subtype CV_Range
is Nat
range 0 .. CV_Cache_Size
;
121 type CV_Entry
is record
126 type Match_Result
is (Match
, No_Match
, Non_Static
);
127 -- Result returned from functions that test for a matching result. If the
128 -- operands are not OK_Static then Non_Static will be returned. Otherwise
129 -- Match/No_Match is returned depending on whether the match succeeds.
131 type CV_Cache_Array
is array (CV_Range
) of CV_Entry
;
133 CV_Cache
: CV_Cache_Array
:= (others => (Node_High_Bound
, Uint_0
));
134 -- This is the actual cache, with entries consisting of node/value pairs,
135 -- and the impossible value Node_High_Bound used for unset entries.
137 type Range_Membership
is (In_Range
, Out_Of_Range
, Unknown
);
138 -- Range membership may either be statically known to be in range or out
139 -- of range, or not statically known. Used for Test_In_Range below.
141 -----------------------
142 -- Local Subprograms --
143 -----------------------
145 function Choice_Matches
147 Choice
: Node_Id
) return Match_Result
;
148 -- Determines whether given value Expr matches the given Choice. The Expr
149 -- can be of discrete, real, or string type and must be a compile time
150 -- known value (it is an error to make the call if these conditions are
151 -- not met). The choice can be a range, subtype name, subtype indication,
152 -- or expression. The returned result is Non_Static if Choice is not
153 -- OK_Static, otherwise either Match or No_Match is returned depending
154 -- on whether Choice matches Expr. This is used for case expression
155 -- alternatives, and also for membership tests. In each case, more
156 -- possibilities are tested than the syntax allows (e.g. membership allows
157 -- subtype indications and non-discrete types, and case allows an OTHERS
158 -- choice), but it does not matter, since we have already done a full
159 -- semantic and syntax check of the construct, so the extra possibilities
160 -- just will not arise for correct expressions.
162 -- Note: if Choice_Matches finds that a choice raises Constraint_Error, e.g
163 -- a reference to a type, one of whose bounds raises Constraint_Error, then
164 -- it also sets the Raises_Constraint_Error flag on the Choice itself.
166 function Choices_Match
168 Choices
: List_Id
) return Match_Result
;
169 -- This function applies Choice_Matches to each element of Choices. If the
170 -- result is No_Match, then it continues and checks the next element. If
171 -- the result is Match or Non_Static, this result is immediately given
172 -- as the result without checking the rest of the list. Expr can be of
173 -- discrete, real, or string type and must be a compile time known value
174 -- (it is an error to make the call if these conditions are not met).
176 function From_Bits
(B
: Bits
; T
: Entity_Id
) return Uint
;
177 -- Converts a bit string of length B'Length to a Uint value to be used for
178 -- a target of type T, which is a modular type. This procedure includes the
179 -- necessary reduction by the modulus in the case of a nonbinary modulus
180 -- (for a binary modulus, the bit string is the right length any way so all
183 function Is_Static_Choice
(Choice
: Node_Id
) return Boolean;
184 -- Given a choice (from a case expression or membership test), returns
185 -- True if the choice is static. No test is made for raising of constraint
186 -- error, so this function is used only for legality tests.
188 function Is_Static_Choice_List
(Choices
: List_Id
) return Boolean;
189 -- Given a choice list (from a case expression or membership test), return
190 -- True if all choices are static in the sense of Is_Static_Choice.
192 function Is_OK_Static_Choice
(Choice
: Node_Id
) return Boolean;
193 -- Given a choice (from a case expression or membership test), returns
194 -- True if the choice is static and does not raise a Constraint_Error.
196 function Is_OK_Static_Choice_List
(Choices
: List_Id
) return Boolean;
197 -- Given a choice list (from a case expression or membership test), return
198 -- True if all choices are static in the sense of Is_OK_Static_Choice.
200 function Is_Static_Range
(N
: Node_Id
) return Boolean;
201 -- Determine if range is static, as defined in RM 4.9(26). The only allowed
202 -- argument is an N_Range node (but note that the semantic analysis of
203 -- equivalent range attribute references already turned them into the
204 -- equivalent range). This differs from Is_OK_Static_Range (which is what
205 -- must be used by clients) in that it does not care whether the bounds
206 -- raise Constraint_Error or not. Used for checking whether expressions are
207 -- static in the 4.9 sense (without worrying about exceptions).
209 function Get_String_Val
(N
: Node_Id
) return Node_Id
;
210 -- Given a tree node for a folded string or character value, returns the
211 -- corresponding string literal or character literal (one of the two must
212 -- be available, or the operand would not have been marked as foldable in
213 -- the earlier analysis of the operation).
215 function OK_Bits
(N
: Node_Id
; Bits
: Uint
) return Boolean;
216 -- Bits represents the number of bits in an integer value to be computed
217 -- (but the value has not been computed yet). If this value in Bits is
218 -- reasonable, a result of True is returned, with the implication that the
219 -- caller should go ahead and complete the calculation. If the value in
220 -- Bits is unreasonably large, then an error is posted on node N, and
221 -- False is returned (and the caller skips the proposed calculation).
223 procedure Out_Of_Range
(N
: Node_Id
);
224 -- This procedure is called if it is determined that node N, which appears
225 -- in a non-static context, is a compile time known value which is outside
226 -- its range, i.e. the range of Etype. This is used in contexts where
227 -- this is an illegality if N is static, and should generate a warning
230 function Real_Or_String_Static_Predicate_Matches
232 Typ
: Entity_Id
) return Boolean;
233 -- This is the function used to evaluate real or string static predicates.
234 -- Val is an unanalyzed N_Real_Literal or N_String_Literal node, which
235 -- represents the value to be tested against the predicate. Typ is the
236 -- type with the predicate, from which the predicate expression can be
237 -- extracted. The result returned is True if the given value satisfies
240 procedure Rewrite_In_Raise_CE
(N
: Node_Id
; Exp
: Node_Id
);
241 -- N and Exp are nodes representing an expression, Exp is known to raise
242 -- CE. N is rewritten in term of Exp in the optimal way.
244 function String_Type_Len
(Stype
: Entity_Id
) return Uint
;
245 -- Given a string type, determines the length of the index type, or, if
246 -- this index type is non-static, the length of the base type of this index
247 -- type. Note that if the string type is itself static, then the index type
248 -- is static, so the second case applies only if the string type passed is
251 function Test
(Cond
: Boolean) return Uint
;
252 pragma Inline
(Test
);
253 -- This function simply returns the appropriate Boolean'Pos value
254 -- corresponding to the value of Cond as a universal integer. It is
255 -- used for producing the result of the static evaluation of the
258 function Find_Universal_Operator_Type
(N
: Node_Id
) return Entity_Id
;
259 -- Check whether an arithmetic operation with universal operands which is a
260 -- rewritten function call with an explicit scope indication is ambiguous:
261 -- P."+" (1, 2) will be ambiguous if there is more than one visible numeric
262 -- type declared in P and the context does not impose a type on the result
263 -- (e.g. in the expression of a type conversion). If ambiguous, emit an
264 -- error and return Empty, else return the result type of the operator.
266 procedure Test_Expression_Is_Foldable
271 -- Tests to see if expression N whose single operand is Op1 is foldable,
272 -- i.e. the operand value is known at compile time. If the operation is
273 -- foldable, then Fold is True on return, and Stat indicates whether the
274 -- result is static (i.e. the operand was static). Note that it is quite
275 -- possible for Fold to be True, and Stat to be False, since there are
276 -- cases in which we know the value of an operand even though it is not
277 -- technically static (e.g. the static lower bound of a range whose upper
278 -- bound is non-static).
280 -- If Stat is set False on return, then Test_Expression_Is_Foldable makes
281 -- a call to Check_Non_Static_Context on the operand. If Fold is False on
282 -- return, then all processing is complete, and the caller should return,
283 -- since there is nothing else to do.
285 -- If Stat is set True on return, then Is_Static_Expression is also set
286 -- true in node N. There are some cases where this is over-enthusiastic,
287 -- e.g. in the two operand case below, for string comparison, the result is
288 -- not static even though the two operands are static. In such cases, the
289 -- caller must reset the Is_Static_Expression flag in N.
291 -- If Fold and Stat are both set to False then this routine performs also
292 -- the following extra actions:
294 -- If either operand is Any_Type then propagate it to result to prevent
297 -- If some operand raises constraint error, then replace the node N
298 -- with the raise constraint error node. This replacement inherits the
299 -- Is_Static_Expression flag from the operands.
301 procedure Test_Expression_Is_Foldable
307 CRT_Safe
: Boolean := False);
308 -- Same processing, except applies to an expression N with two operands
309 -- Op1 and Op2. The result is static only if both operands are static. If
310 -- CRT_Safe is set True, then CRT_Safe_Compile_Time_Known_Value is used
311 -- for the tests that the two operands are known at compile time. See
312 -- spec of this routine for further details.
314 function Test_In_Range
317 Assume_Valid
: Boolean;
319 Int_Real
: Boolean) return Range_Membership
;
320 -- Common processing for Is_In_Range and Is_Out_Of_Range: Returns In_Range
321 -- or Out_Of_Range if it can be guaranteed at compile time that expression
322 -- N is known to be in or out of range of the subtype Typ. If not compile
323 -- time known, Unknown is returned. See documentation of Is_In_Range for
324 -- complete description of parameters.
326 procedure To_Bits
(U
: Uint
; B
: out Bits
);
327 -- Converts a Uint value to a bit string of length B'Length
329 -----------------------------------------------
330 -- Check_Expression_Against_Static_Predicate --
331 -----------------------------------------------
333 procedure Check_Expression_Against_Static_Predicate
338 -- Nothing to do if expression is not known at compile time, or the
339 -- type has no static predicate set (will be the case for all non-scalar
340 -- types, so no need to make a special test for that).
342 if not (Has_Static_Predicate
(Typ
)
343 and then Compile_Time_Known_Value
(Expr
))
348 -- Here we have a static predicate (note that it could have arisen from
349 -- an explicitly specified Dynamic_Predicate whose expression met the
350 -- rules for being predicate-static).
352 -- Case of real static predicate
354 if Is_Real_Type
(Typ
) then
355 if Real_Or_String_Static_Predicate_Matches
356 (Val
=> Make_Real_Literal
(Sloc
(Expr
), Expr_Value_R
(Expr
)),
362 -- Case of string static predicate
364 elsif Is_String_Type
(Typ
) then
365 if Real_Or_String_Static_Predicate_Matches
366 (Val
=> Expr_Value_S
(Expr
), Typ
=> Typ
)
371 -- Case of discrete static predicate
374 pragma Assert
(Is_Discrete_Type
(Typ
));
376 -- If static predicate matches, nothing to do
378 if Choices_Match
(Expr
, Static_Discrete_Predicate
(Typ
)) = Match
then
383 -- Here we know that the predicate will fail
385 -- Special case of static expression failing a predicate (other than one
386 -- that was explicitly specified with a Dynamic_Predicate aspect). This
387 -- is the case where the expression is no longer considered static.
389 if Is_Static_Expression
(Expr
)
390 and then not Has_Dynamic_Predicate_Aspect
(Typ
)
393 ("??static expression fails static predicate check on &",
396 ("\??expression is no longer considered static", Expr
);
397 Set_Is_Static_Expression
(Expr
, False);
399 -- In all other cases, this is just a warning that a test will fail.
400 -- It does not matter if the expression is static or not, or if the
401 -- predicate comes from a dynamic predicate aspect or not.
405 ("??expression fails predicate check on &", Expr
, Typ
);
407 end Check_Expression_Against_Static_Predicate
;
409 ------------------------------
410 -- Check_Non_Static_Context --
411 ------------------------------
413 procedure Check_Non_Static_Context
(N
: Node_Id
) is
414 T
: constant Entity_Id
:= Etype
(N
);
415 Checks_On
: constant Boolean :=
416 not Index_Checks_Suppressed
(T
)
417 and not Range_Checks_Suppressed
(T
);
420 -- Ignore cases of non-scalar types, error types, or universal real
421 -- types that have no usable bounds.
424 or else not Is_Scalar_Type
(T
)
425 or else T
= Universal_Fixed
426 or else T
= Universal_Real
431 -- At this stage we have a scalar type. If we have an expression that
432 -- raises CE, then we already issued a warning or error msg so there is
433 -- nothing more to be done in this routine.
435 if Raises_Constraint_Error
(N
) then
439 -- Now we have a scalar type which is not marked as raising a constraint
440 -- error exception. The main purpose of this routine is to deal with
441 -- static expressions appearing in a non-static context. That means
442 -- that if we do not have a static expression then there is not much
443 -- to do. The one case that we deal with here is that if we have a
444 -- floating-point value that is out of range, then we post a warning
445 -- that an infinity will result.
447 if not Is_Static_Expression
(N
) then
448 if Is_Floating_Point_Type
(T
)
449 and then Is_Out_Of_Range
(N
, Base_Type
(T
), Assume_Valid
=> True)
452 ("??float value out of range, infinity will be generated", N
);
458 -- Here we have the case of outer level static expression of scalar
459 -- type, where the processing of this procedure is needed.
461 -- For real types, this is where we convert the value to a machine
462 -- number (see RM 4.9(38)). Also see ACVC test C490001. We should only
463 -- need to do this if the parent is a constant declaration, since in
464 -- other cases, gigi should do the necessary conversion correctly, but
465 -- experimentation shows that this is not the case on all machines, in
466 -- particular if we do not convert all literals to machine values in
467 -- non-static contexts, then ACVC test C490001 fails on Sparc/Solaris
470 if Nkind
(N
) = N_Real_Literal
471 and then not Is_Machine_Number
(N
)
472 and then not Is_Generic_Type
(Etype
(N
))
473 and then Etype
(N
) /= Universal_Real
475 -- Check that value is in bounds before converting to machine
476 -- number, so as not to lose case where value overflows in the
477 -- least significant bit or less. See B490001.
479 if Is_Out_Of_Range
(N
, Base_Type
(T
), Assume_Valid
=> True) then
484 -- Note: we have to copy the node, to avoid problems with conformance
485 -- of very similar numbers (see ACVC tests B4A010C and B63103A).
487 Rewrite
(N
, New_Copy
(N
));
489 if not Is_Floating_Point_Type
(T
) then
491 (N
, Corresponding_Integer_Value
(N
) * Small_Value
(T
));
493 elsif not UR_Is_Zero
(Realval
(N
)) then
495 -- Note: even though RM 4.9(38) specifies biased rounding, this
496 -- has been modified by AI-100 in order to prevent confusing
497 -- differences in rounding between static and non-static
498 -- expressions. AI-100 specifies that the effect of such rounding
499 -- is implementation dependent, and in GNAT we round to nearest
500 -- even to match the run-time behavior. Note that this applies
501 -- to floating point literals, not fixed points ones, even though
502 -- their compiler representation is also as a universal real.
505 (N
, Machine
(Base_Type
(T
), Realval
(N
), Round_Even
, N
));
506 Set_Is_Machine_Number
(N
);
511 -- Check for out of range universal integer. This is a non-static
512 -- context, so the integer value must be in range of the runtime
513 -- representation of universal integers.
515 -- We do this only within an expression, because that is the only
516 -- case in which non-static universal integer values can occur, and
517 -- furthermore, Check_Non_Static_Context is currently (incorrectly???)
518 -- called in contexts like the expression of a number declaration where
519 -- we certainly want to allow out of range values.
521 if Etype
(N
) = Universal_Integer
522 and then Nkind
(N
) = N_Integer_Literal
523 and then Nkind
(Parent
(N
)) in N_Subexpr
525 (Intval
(N
) < Expr_Value
(Type_Low_Bound
(Universal_Integer
))
527 Intval
(N
) > Expr_Value
(Type_High_Bound
(Universal_Integer
)))
529 Apply_Compile_Time_Constraint_Error
530 (N
, "non-static universal integer value out of range<<",
531 CE_Range_Check_Failed
);
533 -- Check out of range of base type
535 elsif Is_Out_Of_Range
(N
, Base_Type
(T
), Assume_Valid
=> True) then
538 -- Give warning if outside subtype (where one or both of the bounds of
539 -- the subtype is static). This warning is omitted if the expression
540 -- appears in a range that could be null (warnings are handled elsewhere
543 elsif T
/= Base_Type
(T
) and then Nkind
(Parent
(N
)) /= N_Range
then
544 if Is_In_Range
(N
, T
, Assume_Valid
=> True) then
547 elsif Is_Out_Of_Range
(N
, T
, Assume_Valid
=> True) then
548 Apply_Compile_Time_Constraint_Error
549 (N
, "value not in range of}<<", CE_Range_Check_Failed
);
552 Enable_Range_Check
(N
);
555 Set_Do_Range_Check
(N
, False);
558 end Check_Non_Static_Context
;
560 ---------------------------------
561 -- Check_String_Literal_Length --
562 ---------------------------------
564 procedure Check_String_Literal_Length
(N
: Node_Id
; Ttype
: Entity_Id
) is
566 if not Raises_Constraint_Error
(N
) and then Is_Constrained
(Ttype
) then
567 if UI_From_Int
(String_Length
(Strval
(N
))) /= String_Type_Len
(Ttype
)
569 Apply_Compile_Time_Constraint_Error
570 (N
, "string length wrong for}??",
571 CE_Length_Check_Failed
,
576 end Check_String_Literal_Length
;
582 function Choice_Matches
584 Choice
: Node_Id
) return Match_Result
586 Etyp
: constant Entity_Id
:= Etype
(Expr
);
592 pragma Assert
(Compile_Time_Known_Value
(Expr
));
593 pragma Assert
(Is_Scalar_Type
(Etyp
) or else Is_String_Type
(Etyp
));
595 if not Is_OK_Static_Choice
(Choice
) then
596 Set_Raises_Constraint_Error
(Choice
);
599 -- Discrete type case
601 elsif Is_Discrete_Type
(Etype
(Expr
)) then
602 Val
:= Expr_Value
(Expr
);
604 if Nkind
(Choice
) = N_Range
then
605 if Val
>= Expr_Value
(Low_Bound
(Choice
))
607 Val
<= Expr_Value
(High_Bound
(Choice
))
614 elsif Nkind
(Choice
) = N_Subtype_Indication
616 (Is_Entity_Name
(Choice
) and then Is_Type
(Entity
(Choice
)))
618 if Val
>= Expr_Value
(Type_Low_Bound
(Etype
(Choice
)))
620 Val
<= Expr_Value
(Type_High_Bound
(Etype
(Choice
)))
627 elsif Nkind
(Choice
) = N_Others_Choice
then
631 if Val
= Expr_Value
(Choice
) then
640 elsif Is_Real_Type
(Etype
(Expr
)) then
641 ValR
:= Expr_Value_R
(Expr
);
643 if Nkind
(Choice
) = N_Range
then
644 if ValR
>= Expr_Value_R
(Low_Bound
(Choice
))
646 ValR
<= Expr_Value_R
(High_Bound
(Choice
))
653 elsif Nkind
(Choice
) = N_Subtype_Indication
655 (Is_Entity_Name
(Choice
) and then Is_Type
(Entity
(Choice
)))
657 if ValR
>= Expr_Value_R
(Type_Low_Bound
(Etype
(Choice
)))
659 ValR
<= Expr_Value_R
(Type_High_Bound
(Etype
(Choice
)))
667 if ValR
= Expr_Value_R
(Choice
) then
677 pragma Assert
(Is_String_Type
(Etype
(Expr
)));
678 ValS
:= Expr_Value_S
(Expr
);
680 if Nkind
(Choice
) = N_Subtype_Indication
682 (Is_Entity_Name
(Choice
) and then Is_Type
(Entity
(Choice
)))
684 if not Is_Constrained
(Etype
(Choice
)) then
689 Typlen
: constant Uint
:=
690 String_Type_Len
(Etype
(Choice
));
691 Strlen
: constant Uint
:=
692 UI_From_Int
(String_Length
(Strval
(ValS
)));
694 if Typlen
= Strlen
then
703 if String_Equal
(Strval
(ValS
), Strval
(Expr_Value_S
(Choice
)))
717 function Choices_Match
719 Choices
: List_Id
) return Match_Result
722 Result
: Match_Result
;
725 Choice
:= First
(Choices
);
726 while Present
(Choice
) loop
727 Result
:= Choice_Matches
(Expr
, Choice
);
729 if Result
/= No_Match
then
739 --------------------------
740 -- Compile_Time_Compare --
741 --------------------------
743 function Compile_Time_Compare
745 Assume_Valid
: Boolean) return Compare_Result
747 Discard
: aliased Uint
;
749 return Compile_Time_Compare
(L
, R
, Discard
'Access, Assume_Valid
);
750 end Compile_Time_Compare
;
752 function Compile_Time_Compare
755 Assume_Valid
: Boolean;
756 Rec
: Boolean := False) return Compare_Result
758 Ltyp
: Entity_Id
:= Underlying_Type
(Etype
(L
));
759 Rtyp
: Entity_Id
:= Underlying_Type
(Etype
(R
));
760 -- These get reset to the base type for the case of entities where
761 -- Is_Known_Valid is not set. This takes care of handling possible
762 -- invalid representations using the value of the base type, in
763 -- accordance with RM 13.9.1(10).
765 Discard
: aliased Uint
;
767 procedure Compare_Decompose
771 -- This procedure decomposes the node N into an expression node and a
772 -- signed offset, so that the value of N is equal to the value of R plus
773 -- the value V (which may be negative). If no such decomposition is
774 -- possible, then on return R is a copy of N, and V is set to zero.
776 function Compare_Fixup
(N
: Node_Id
) return Node_Id
;
777 -- This function deals with replacing 'Last and 'First references with
778 -- their corresponding type bounds, which we then can compare. The
779 -- argument is the original node, the result is the identity, unless we
780 -- have a 'Last/'First reference in which case the value returned is the
781 -- appropriate type bound.
783 function Is_Known_Valid_Operand
(Opnd
: Node_Id
) return Boolean;
784 -- Even if the context does not assume that values are valid, some
785 -- simple cases can be recognized.
787 function Is_Same_Value
(L
, R
: Node_Id
) return Boolean;
788 -- Returns True iff L and R represent expressions that definitely have
789 -- identical (but not necessarily compile time known) values Indeed the
790 -- caller is expected to have already dealt with the cases of compile
791 -- time known values, so these are not tested here.
793 -----------------------
794 -- Compare_Decompose --
795 -----------------------
797 procedure Compare_Decompose
803 if Nkind
(N
) = N_Op_Add
804 and then Nkind
(Right_Opnd
(N
)) = N_Integer_Literal
807 V
:= Intval
(Right_Opnd
(N
));
810 elsif Nkind
(N
) = N_Op_Subtract
811 and then Nkind
(Right_Opnd
(N
)) = N_Integer_Literal
814 V
:= UI_Negate
(Intval
(Right_Opnd
(N
)));
817 elsif Nkind
(N
) = N_Attribute_Reference
then
818 if Attribute_Name
(N
) = Name_Succ
then
819 R
:= First
(Expressions
(N
));
823 elsif Attribute_Name
(N
) = Name_Pred
then
824 R
:= First
(Expressions
(N
));
832 end Compare_Decompose
;
838 function Compare_Fixup
(N
: Node_Id
) return Node_Id
is
844 -- Fixup only required for First/Last attribute reference
846 if Nkind
(N
) = N_Attribute_Reference
847 and then Nam_In
(Attribute_Name
(N
), Name_First
, Name_Last
)
849 Xtyp
:= Etype
(Prefix
(N
));
851 -- If we have no type, then just abandon the attempt to do
852 -- a fixup, this is probably the result of some other error.
858 -- Dereference an access type
860 if Is_Access_Type
(Xtyp
) then
861 Xtyp
:= Designated_Type
(Xtyp
);
864 -- If we don't have an array type at this stage, something is
865 -- peculiar, e.g. another error, and we abandon the attempt at
868 if not Is_Array_Type
(Xtyp
) then
872 -- Ignore unconstrained array, since bounds are not meaningful
874 if not Is_Constrained
(Xtyp
) then
878 if Ekind
(Xtyp
) = E_String_Literal_Subtype
then
879 if Attribute_Name
(N
) = Name_First
then
880 return String_Literal_Low_Bound
(Xtyp
);
883 Make_Integer_Literal
(Sloc
(N
),
884 Intval
=> Intval
(String_Literal_Low_Bound
(Xtyp
)) +
885 String_Literal_Length
(Xtyp
));
889 -- Find correct index type
891 Indx
:= First_Index
(Xtyp
);
893 if Present
(Expressions
(N
)) then
894 Subs
:= UI_To_Int
(Expr_Value
(First
(Expressions
(N
))));
896 for J
in 2 .. Subs
loop
897 Indx
:= Next_Index
(Indx
);
901 Xtyp
:= Etype
(Indx
);
903 if Attribute_Name
(N
) = Name_First
then
904 return Type_Low_Bound
(Xtyp
);
906 return Type_High_Bound
(Xtyp
);
913 ----------------------------
914 -- Is_Known_Valid_Operand --
915 ----------------------------
917 function Is_Known_Valid_Operand
(Opnd
: Node_Id
) return Boolean is
919 return (Is_Entity_Name
(Opnd
)
921 (Is_Known_Valid
(Entity
(Opnd
))
922 or else Ekind
(Entity
(Opnd
)) = E_In_Parameter
924 (Ekind
(Entity
(Opnd
)) in Object_Kind
925 and then Present
(Current_Value
(Entity
(Opnd
))))))
926 or else Is_OK_Static_Expression
(Opnd
);
927 end Is_Known_Valid_Operand
;
933 function Is_Same_Value
(L
, R
: Node_Id
) return Boolean is
934 Lf
: constant Node_Id
:= Compare_Fixup
(L
);
935 Rf
: constant Node_Id
:= Compare_Fixup
(R
);
937 function Is_Same_Subscript
(L
, R
: List_Id
) return Boolean;
938 -- L, R are the Expressions values from two attribute nodes for First
939 -- or Last attributes. Either may be set to No_List if no expressions
940 -- are present (indicating subscript 1). The result is True if both
941 -- expressions represent the same subscript (note one case is where
942 -- one subscript is missing and the other is explicitly set to 1).
944 -----------------------
945 -- Is_Same_Subscript --
946 -----------------------
948 function Is_Same_Subscript
(L
, R
: List_Id
) return Boolean is
954 return Expr_Value
(First
(R
)) = Uint_1
;
959 return Expr_Value
(First
(L
)) = Uint_1
;
961 return Expr_Value
(First
(L
)) = Expr_Value
(First
(R
));
964 end Is_Same_Subscript
;
966 -- Start of processing for Is_Same_Value
969 -- Values are the same if they refer to the same entity and the
970 -- entity is non-volatile. This does not however apply to Float
971 -- types, since we may have two NaN values and they should never
974 -- If the entity is a discriminant, the two expressions may be bounds
975 -- of components of objects of the same discriminated type. The
976 -- values of the discriminants are not static, and therefore the
977 -- result is unknown.
979 -- It would be better to comment individual branches of this test ???
981 if Nkind_In
(Lf
, N_Identifier
, N_Expanded_Name
)
982 and then Nkind_In
(Rf
, N_Identifier
, N_Expanded_Name
)
983 and then Entity
(Lf
) = Entity
(Rf
)
984 and then Ekind
(Entity
(Lf
)) /= E_Discriminant
985 and then Present
(Entity
(Lf
))
986 and then not Is_Floating_Point_Type
(Etype
(L
))
987 and then not Is_Volatile_Reference
(L
)
988 and then not Is_Volatile_Reference
(R
)
992 -- Or if they are compile time known and identical
994 elsif Compile_Time_Known_Value
(Lf
)
996 Compile_Time_Known_Value
(Rf
)
997 and then Expr_Value
(Lf
) = Expr_Value
(Rf
)
1001 -- False if Nkind of the two nodes is different for remaining cases
1003 elsif Nkind
(Lf
) /= Nkind
(Rf
) then
1006 -- True if both 'First or 'Last values applying to the same entity
1007 -- (first and last don't change even if value does). Note that we
1008 -- need this even with the calls to Compare_Fixup, to handle the
1009 -- case of unconstrained array attributes where Compare_Fixup
1010 -- cannot find useful bounds.
1012 elsif Nkind
(Lf
) = N_Attribute_Reference
1013 and then Attribute_Name
(Lf
) = Attribute_Name
(Rf
)
1014 and then Nam_In
(Attribute_Name
(Lf
), Name_First
, Name_Last
)
1015 and then Nkind_In
(Prefix
(Lf
), N_Identifier
, N_Expanded_Name
)
1016 and then Nkind_In
(Prefix
(Rf
), N_Identifier
, N_Expanded_Name
)
1017 and then Entity
(Prefix
(Lf
)) = Entity
(Prefix
(Rf
))
1018 and then Is_Same_Subscript
(Expressions
(Lf
), Expressions
(Rf
))
1022 -- True if the same selected component from the same record
1024 elsif Nkind
(Lf
) = N_Selected_Component
1025 and then Selector_Name
(Lf
) = Selector_Name
(Rf
)
1026 and then Is_Same_Value
(Prefix
(Lf
), Prefix
(Rf
))
1030 -- True if the same unary operator applied to the same operand
1032 elsif Nkind
(Lf
) in N_Unary_Op
1033 and then Is_Same_Value
(Right_Opnd
(Lf
), Right_Opnd
(Rf
))
1037 -- True if the same binary operator applied to the same operands
1039 elsif Nkind
(Lf
) in N_Binary_Op
1040 and then Is_Same_Value
(Left_Opnd
(Lf
), Left_Opnd
(Rf
))
1041 and then Is_Same_Value
(Right_Opnd
(Lf
), Right_Opnd
(Rf
))
1045 -- All other cases, we can't tell, so return False
1052 -- Start of processing for Compile_Time_Compare
1055 Diff
.all := No_Uint
;
1057 -- In preanalysis mode, always return Unknown unless the expression
1058 -- is static. It is too early to be thinking we know the result of a
1059 -- comparison, save that judgment for the full analysis. This is
1060 -- particularly important in the case of pre and postconditions, which
1061 -- otherwise can be prematurely collapsed into having True or False
1062 -- conditions when this is inappropriate.
1064 if not (Full_Analysis
1065 or else (Is_OK_Static_Expression
(L
)
1067 Is_OK_Static_Expression
(R
)))
1072 -- If either operand could raise constraint error, then we cannot
1073 -- know the result at compile time (since CE may be raised).
1075 if not (Cannot_Raise_Constraint_Error
(L
)
1077 Cannot_Raise_Constraint_Error
(R
))
1082 -- Identical operands are most certainly equal
1087 -- If expressions have no types, then do not attempt to determine if
1088 -- they are the same, since something funny is going on. One case in
1089 -- which this happens is during generic template analysis, when bounds
1090 -- are not fully analyzed.
1092 elsif No
(Ltyp
) or else No
(Rtyp
) then
1095 -- We do not attempt comparisons for packed arrays represented as
1096 -- modular types, where the semantics of comparison is quite different.
1098 elsif Is_Packed_Array_Impl_Type
(Ltyp
)
1099 and then Is_Modular_Integer_Type
(Ltyp
)
1103 -- For access types, the only time we know the result at compile time
1104 -- (apart from identical operands, which we handled already) is if we
1105 -- know one operand is null and the other is not, or both operands are
1108 elsif Is_Access_Type
(Ltyp
) then
1109 if Known_Null
(L
) then
1110 if Known_Null
(R
) then
1112 elsif Known_Non_Null
(R
) then
1118 elsif Known_Non_Null
(L
) and then Known_Null
(R
) then
1125 -- Case where comparison involves two compile time known values
1127 elsif Compile_Time_Known_Value
(L
)
1129 Compile_Time_Known_Value
(R
)
1131 -- For the floating-point case, we have to be a little careful, since
1132 -- at compile time we are dealing with universal exact values, but at
1133 -- runtime, these will be in non-exact target form. That's why the
1134 -- returned results are LE and GE below instead of LT and GT.
1136 if Is_Floating_Point_Type
(Ltyp
)
1138 Is_Floating_Point_Type
(Rtyp
)
1141 Lo
: constant Ureal
:= Expr_Value_R
(L
);
1142 Hi
: constant Ureal
:= Expr_Value_R
(R
);
1153 -- For string types, we have two string literals and we proceed to
1154 -- compare them using the Ada style dictionary string comparison.
1156 elsif not Is_Scalar_Type
(Ltyp
) then
1158 Lstring
: constant String_Id
:= Strval
(Expr_Value_S
(L
));
1159 Rstring
: constant String_Id
:= Strval
(Expr_Value_S
(R
));
1160 Llen
: constant Nat
:= String_Length
(Lstring
);
1161 Rlen
: constant Nat
:= String_Length
(Rstring
);
1164 for J
in 1 .. Nat
'Min (Llen
, Rlen
) loop
1166 LC
: constant Char_Code
:= Get_String_Char
(Lstring
, J
);
1167 RC
: constant Char_Code
:= Get_String_Char
(Rstring
, J
);
1179 elsif Llen
> Rlen
then
1186 -- For remaining scalar cases we know exactly (note that this does
1187 -- include the fixed-point case, where we know the run time integer
1192 Lo
: constant Uint
:= Expr_Value
(L
);
1193 Hi
: constant Uint
:= Expr_Value
(R
);
1196 Diff
.all := Hi
- Lo
;
1201 Diff
.all := Lo
- Hi
;
1207 -- Cases where at least one operand is not known at compile time
1210 -- Remaining checks apply only for discrete types
1212 if not Is_Discrete_Type
(Ltyp
)
1214 not Is_Discrete_Type
(Rtyp
)
1219 -- Defend against generic types, or actually any expressions that
1220 -- contain a reference to a generic type from within a generic
1221 -- template. We don't want to do any range analysis of such
1222 -- expressions for two reasons. First, the bounds of a generic type
1223 -- itself are junk and cannot be used for any kind of analysis.
1224 -- Second, we may have a case where the range at run time is indeed
1225 -- known, but we don't want to do compile time analysis in the
1226 -- template based on that range since in an instance the value may be
1227 -- static, and able to be elaborated without reference to the bounds
1228 -- of types involved. As an example, consider:
1230 -- (F'Pos (F'Last) + 1) > Integer'Last
1232 -- The expression on the left side of > is Universal_Integer and thus
1233 -- acquires the type Integer for evaluation at run time, and at run
1234 -- time it is true that this condition is always False, but within
1235 -- an instance F may be a type with a static range greater than the
1236 -- range of Integer, and the expression statically evaluates to True.
1238 if References_Generic_Formal_Type
(L
)
1240 References_Generic_Formal_Type
(R
)
1245 -- Replace types by base types for the case of values which are not
1246 -- known to have valid representations. This takes care of properly
1247 -- dealing with invalid representations.
1249 if not Assume_Valid
then
1250 if not (Is_Entity_Name
(L
)
1251 and then (Is_Known_Valid
(Entity
(L
))
1252 or else Assume_No_Invalid_Values
))
1254 Ltyp
:= Underlying_Type
(Base_Type
(Ltyp
));
1257 if not (Is_Entity_Name
(R
)
1258 and then (Is_Known_Valid
(Entity
(R
))
1259 or else Assume_No_Invalid_Values
))
1261 Rtyp
:= Underlying_Type
(Base_Type
(Rtyp
));
1265 -- First attempt is to decompose the expressions to extract a
1266 -- constant offset resulting from the use of any of the forms:
1273 -- Then we see if the two expressions are the same value, and if so
1274 -- the result is obtained by comparing the offsets.
1276 -- Note: the reason we do this test first is that it returns only
1277 -- decisive results (with diff set), where other tests, like the
1278 -- range test, may not be as so decisive. Consider for example
1279 -- J .. J + 1. This code can conclude LT with a difference of 1,
1280 -- even if the range of J is not known.
1289 Compare_Decompose
(L
, Lnode
, Loffs
);
1290 Compare_Decompose
(R
, Rnode
, Roffs
);
1292 if Is_Same_Value
(Lnode
, Rnode
) then
1293 if Loffs
= Roffs
then
1295 elsif Loffs
< Roffs
then
1296 Diff
.all := Roffs
- Loffs
;
1299 Diff
.all := Loffs
- Roffs
;
1305 -- Next, try range analysis and see if operand ranges are disjoint
1313 -- True if each range is a single point
1316 Determine_Range
(L
, LOK
, LLo
, LHi
, Assume_Valid
);
1317 Determine_Range
(R
, ROK
, RLo
, RHi
, Assume_Valid
);
1320 Single
:= (LLo
= LHi
) and then (RLo
= RHi
);
1323 if Single
and Assume_Valid
then
1324 Diff
.all := RLo
- LLo
;
1329 elsif RHi
< LLo
then
1330 if Single
and Assume_Valid
then
1331 Diff
.all := LLo
- RLo
;
1336 elsif Single
and then LLo
= RLo
then
1338 -- If the range includes a single literal and we can assume
1339 -- validity then the result is known even if an operand is
1342 if Assume_Valid
then
1348 elsif LHi
= RLo
then
1351 elsif RHi
= LLo
then
1354 elsif not Is_Known_Valid_Operand
(L
)
1355 and then not Assume_Valid
1357 if Is_Same_Value
(L
, R
) then
1364 -- If the range of either operand cannot be determined, nothing
1365 -- further can be inferred.
1372 -- Here is where we check for comparisons against maximum bounds of
1373 -- types, where we know that no value can be outside the bounds of
1374 -- the subtype. Note that this routine is allowed to assume that all
1375 -- expressions are within their subtype bounds. Callers wishing to
1376 -- deal with possibly invalid values must in any case take special
1377 -- steps (e.g. conversions to larger types) to avoid this kind of
1378 -- optimization, which is always considered to be valid. We do not
1379 -- attempt this optimization with generic types, since the type
1380 -- bounds may not be meaningful in this case.
1382 -- We are in danger of an infinite recursion here. It does not seem
1383 -- useful to go more than one level deep, so the parameter Rec is
1384 -- used to protect ourselves against this infinite recursion.
1388 -- See if we can get a decisive check against one operand and a
1389 -- bound of the other operand (four possible tests here). Note
1390 -- that we avoid testing junk bounds of a generic type.
1392 if not Is_Generic_Type
(Rtyp
) then
1393 case Compile_Time_Compare
(L
, Type_Low_Bound
(Rtyp
),
1395 Assume_Valid
, Rec
=> True)
1397 when LT
=> return LT
;
1398 when LE
=> return LE
;
1399 when EQ
=> return LE
;
1400 when others => null;
1403 case Compile_Time_Compare
(L
, Type_High_Bound
(Rtyp
),
1405 Assume_Valid
, Rec
=> True)
1407 when GT
=> return GT
;
1408 when GE
=> return GE
;
1409 when EQ
=> return GE
;
1410 when others => null;
1414 if not Is_Generic_Type
(Ltyp
) then
1415 case Compile_Time_Compare
(Type_Low_Bound
(Ltyp
), R
,
1417 Assume_Valid
, Rec
=> True)
1419 when GT
=> return GT
;
1420 when GE
=> return GE
;
1421 when EQ
=> return GE
;
1422 when others => null;
1425 case Compile_Time_Compare
(Type_High_Bound
(Ltyp
), R
,
1427 Assume_Valid
, Rec
=> True)
1429 when LT
=> return LT
;
1430 when LE
=> return LE
;
1431 when EQ
=> return LE
;
1432 when others => null;
1437 -- Next attempt is to see if we have an entity compared with a
1438 -- compile time known value, where there is a current value
1439 -- conditional for the entity which can tell us the result.
1443 -- Entity variable (left operand)
1446 -- Value (right operand)
1449 -- If False, we have reversed the operands
1452 -- Comparison operator kind from Get_Current_Value_Condition call
1455 -- Value from Get_Current_Value_Condition call
1460 Result
: Compare_Result
;
1461 -- Known result before inversion
1464 if Is_Entity_Name
(L
)
1465 and then Compile_Time_Known_Value
(R
)
1468 Val
:= Expr_Value
(R
);
1471 elsif Is_Entity_Name
(R
)
1472 and then Compile_Time_Known_Value
(L
)
1475 Val
:= Expr_Value
(L
);
1478 -- That was the last chance at finding a compile time result
1484 Get_Current_Value_Condition
(Var
, Op
, Opn
);
1486 -- That was the last chance, so if we got nothing return
1492 Opv
:= Expr_Value
(Opn
);
1494 -- We got a comparison, so we might have something interesting
1496 -- Convert LE to LT and GE to GT, just so we have fewer cases
1498 if Op
= N_Op_Le
then
1502 elsif Op
= N_Op_Ge
then
1507 -- Deal with equality case
1509 if Op
= N_Op_Eq
then
1512 elsif Opv
< Val
then
1518 -- Deal with inequality case
1520 elsif Op
= N_Op_Ne
then
1527 -- Deal with greater than case
1529 elsif Op
= N_Op_Gt
then
1532 elsif Opv
= Val
- 1 then
1538 -- Deal with less than case
1540 else pragma Assert
(Op
= N_Op_Lt
);
1543 elsif Opv
= Val
+ 1 then
1550 -- Deal with inverting result
1554 when GT
=> return LT
;
1555 when GE
=> return LE
;
1556 when LT
=> return GT
;
1557 when LE
=> return GE
;
1558 when others => return Result
;
1565 end Compile_Time_Compare
;
1567 -------------------------------
1568 -- Compile_Time_Known_Bounds --
1569 -------------------------------
1571 function Compile_Time_Known_Bounds
(T
: Entity_Id
) return Boolean is
1576 if T
= Any_Composite
or else not Is_Array_Type
(T
) then
1580 Indx
:= First_Index
(T
);
1581 while Present
(Indx
) loop
1582 Typ
:= Underlying_Type
(Etype
(Indx
));
1584 -- Never look at junk bounds of a generic type
1586 if Is_Generic_Type
(Typ
) then
1590 -- Otherwise check bounds for compile time known
1592 if not Compile_Time_Known_Value
(Type_Low_Bound
(Typ
)) then
1594 elsif not Compile_Time_Known_Value
(Type_High_Bound
(Typ
)) then
1602 end Compile_Time_Known_Bounds
;
1604 ------------------------------
1605 -- Compile_Time_Known_Value --
1606 ------------------------------
1608 function Compile_Time_Known_Value
(Op
: Node_Id
) return Boolean is
1609 K
: constant Node_Kind
:= Nkind
(Op
);
1610 CV_Ent
: CV_Entry
renames CV_Cache
(Nat
(Op
) mod CV_Cache_Size
);
1613 -- Never known at compile time if bad type or raises constraint error
1614 -- or empty (latter case occurs only as a result of a previous error).
1617 Check_Error_Detected
;
1621 or else Etype
(Op
) = Any_Type
1622 or else Raises_Constraint_Error
(Op
)
1627 -- If we have an entity name, then see if it is the name of a constant
1628 -- and if so, test the corresponding constant value, or the name of
1629 -- an enumeration literal, which is always a constant.
1631 if Present
(Etype
(Op
)) and then Is_Entity_Name
(Op
) then
1633 E
: constant Entity_Id
:= Entity
(Op
);
1637 -- Never known at compile time if it is a packed array value.
1638 -- We might want to try to evaluate these at compile time one
1639 -- day, but we do not make that attempt now.
1641 if Is_Packed_Array_Impl_Type
(Etype
(Op
)) then
1645 if Ekind
(E
) = E_Enumeration_Literal
then
1648 elsif Ekind
(E
) = E_Constant
then
1649 V
:= Constant_Value
(E
);
1650 return Present
(V
) and then Compile_Time_Known_Value
(V
);
1654 -- We have a value, see if it is compile time known
1657 -- Integer literals are worth storing in the cache
1659 if K
= N_Integer_Literal
then
1661 CV_Ent
.V
:= Intval
(Op
);
1664 -- Other literals and NULL are known at compile time
1667 Nkind_In
(K
, N_Character_Literal
,
1676 -- If we fall through, not known at compile time
1680 -- If we get an exception while trying to do this test, then some error
1681 -- has occurred, and we simply say that the value is not known after all
1686 end Compile_Time_Known_Value
;
1688 --------------------------------------
1689 -- Compile_Time_Known_Value_Or_Aggr --
1690 --------------------------------------
1692 function Compile_Time_Known_Value_Or_Aggr
(Op
: Node_Id
) return Boolean is
1694 -- If we have an entity name, then see if it is the name of a constant
1695 -- and if so, test the corresponding constant value, or the name of
1696 -- an enumeration literal, which is always a constant.
1698 if Is_Entity_Name
(Op
) then
1700 E
: constant Entity_Id
:= Entity
(Op
);
1704 if Ekind
(E
) = E_Enumeration_Literal
then
1707 elsif Ekind
(E
) /= E_Constant
then
1711 V
:= Constant_Value
(E
);
1713 and then Compile_Time_Known_Value_Or_Aggr
(V
);
1717 -- We have a value, see if it is compile time known
1720 if Compile_Time_Known_Value
(Op
) then
1723 elsif Nkind
(Op
) = N_Aggregate
then
1725 if Present
(Expressions
(Op
)) then
1729 Expr
:= First
(Expressions
(Op
));
1730 while Present
(Expr
) loop
1731 if not Compile_Time_Known_Value_Or_Aggr
(Expr
) then
1740 if Present
(Component_Associations
(Op
)) then
1745 Cass
:= First
(Component_Associations
(Op
));
1746 while Present
(Cass
) loop
1748 Compile_Time_Known_Value_Or_Aggr
(Expression
(Cass
))
1760 -- All other types of values are not known at compile time
1767 end Compile_Time_Known_Value_Or_Aggr
;
1769 ---------------------------------------
1770 -- CRT_Safe_Compile_Time_Known_Value --
1771 ---------------------------------------
1773 function CRT_Safe_Compile_Time_Known_Value
(Op
: Node_Id
) return Boolean is
1775 if (Configurable_Run_Time_Mode
or No_Run_Time_Mode
)
1776 and then not Is_OK_Static_Expression
(Op
)
1780 return Compile_Time_Known_Value
(Op
);
1782 end CRT_Safe_Compile_Time_Known_Value
;
1788 -- This is only called for actuals of functions that are not predefined
1789 -- operators (which have already been rewritten as operators at this
1790 -- stage), so the call can never be folded, and all that needs doing for
1791 -- the actual is to do the check for a non-static context.
1793 procedure Eval_Actual
(N
: Node_Id
) is
1795 Check_Non_Static_Context
(N
);
1798 --------------------
1799 -- Eval_Allocator --
1800 --------------------
1802 -- Allocators are never static, so all we have to do is to do the
1803 -- check for a non-static context if an expression is present.
1805 procedure Eval_Allocator
(N
: Node_Id
) is
1806 Expr
: constant Node_Id
:= Expression
(N
);
1808 if Nkind
(Expr
) = N_Qualified_Expression
then
1809 Check_Non_Static_Context
(Expression
(Expr
));
1813 ------------------------
1814 -- Eval_Arithmetic_Op --
1815 ------------------------
1817 -- Arithmetic operations are static functions, so the result is static
1818 -- if both operands are static (RM 4.9(7), 4.9(20)).
1820 procedure Eval_Arithmetic_Op
(N
: Node_Id
) is
1821 Left
: constant Node_Id
:= Left_Opnd
(N
);
1822 Right
: constant Node_Id
:= Right_Opnd
(N
);
1823 Ltype
: constant Entity_Id
:= Etype
(Left
);
1824 Rtype
: constant Entity_Id
:= Etype
(Right
);
1825 Otype
: Entity_Id
:= Empty
;
1830 -- If not foldable we are done
1832 Test_Expression_Is_Foldable
(N
, Left
, Right
, Stat
, Fold
);
1838 -- Otherwise attempt to fold
1840 if Is_Universal_Numeric_Type
(Etype
(Left
))
1842 Is_Universal_Numeric_Type
(Etype
(Right
))
1844 Otype
:= Find_Universal_Operator_Type
(N
);
1847 -- Fold for cases where both operands are of integer type
1849 if Is_Integer_Type
(Ltype
) and then Is_Integer_Type
(Rtype
) then
1851 Left_Int
: constant Uint
:= Expr_Value
(Left
);
1852 Right_Int
: constant Uint
:= Expr_Value
(Right
);
1858 Result
:= Left_Int
+ Right_Int
;
1860 when N_Op_Subtract
=>
1861 Result
:= Left_Int
- Right_Int
;
1863 when N_Op_Multiply
=>
1866 (Num_Bits
(Left_Int
) + Num_Bits
(Right_Int
)))
1868 Result
:= Left_Int
* Right_Int
;
1875 -- The exception Constraint_Error is raised by integer
1876 -- division, rem and mod if the right operand is zero.
1878 if Right_Int
= 0 then
1879 Apply_Compile_Time_Constraint_Error
1880 (N
, "division by zero", CE_Divide_By_Zero
,
1882 Set_Raises_Constraint_Error
(N
);
1885 -- Otherwise we can do the division
1888 Result
:= Left_Int
/ Right_Int
;
1893 -- The exception Constraint_Error is raised by integer
1894 -- division, rem and mod if the right operand is zero.
1896 if Right_Int
= 0 then
1897 Apply_Compile_Time_Constraint_Error
1898 (N
, "mod with zero divisor", CE_Divide_By_Zero
,
1902 Result
:= Left_Int
mod Right_Int
;
1907 -- The exception Constraint_Error is raised by integer
1908 -- division, rem and mod if the right operand is zero.
1910 if Right_Int
= 0 then
1911 Apply_Compile_Time_Constraint_Error
1912 (N
, "rem with zero divisor", CE_Divide_By_Zero
,
1917 Result
:= Left_Int
rem Right_Int
;
1921 raise Program_Error
;
1924 -- Adjust the result by the modulus if the type is a modular type
1926 if Is_Modular_Integer_Type
(Ltype
) then
1927 Result
:= Result
mod Modulus
(Ltype
);
1929 -- For a signed integer type, check non-static overflow
1931 elsif (not Stat
) and then Is_Signed_Integer_Type
(Ltype
) then
1933 BT
: constant Entity_Id
:= Base_Type
(Ltype
);
1934 Lo
: constant Uint
:= Expr_Value
(Type_Low_Bound
(BT
));
1935 Hi
: constant Uint
:= Expr_Value
(Type_High_Bound
(BT
));
1937 if Result
< Lo
or else Result
> Hi
then
1938 Apply_Compile_Time_Constraint_Error
1939 (N
, "value not in range of }??",
1940 CE_Overflow_Check_Failed
,
1947 -- If we get here we can fold the result
1949 Fold_Uint
(N
, Result
, Stat
);
1952 -- Cases where at least one operand is a real. We handle the cases of
1953 -- both reals, or mixed/real integer cases (the latter happen only for
1954 -- divide and multiply, and the result is always real).
1956 elsif Is_Real_Type
(Ltype
) or else Is_Real_Type
(Rtype
) then
1963 if Is_Real_Type
(Ltype
) then
1964 Left_Real
:= Expr_Value_R
(Left
);
1966 Left_Real
:= UR_From_Uint
(Expr_Value
(Left
));
1969 if Is_Real_Type
(Rtype
) then
1970 Right_Real
:= Expr_Value_R
(Right
);
1972 Right_Real
:= UR_From_Uint
(Expr_Value
(Right
));
1975 if Nkind
(N
) = N_Op_Add
then
1976 Result
:= Left_Real
+ Right_Real
;
1978 elsif Nkind
(N
) = N_Op_Subtract
then
1979 Result
:= Left_Real
- Right_Real
;
1981 elsif Nkind
(N
) = N_Op_Multiply
then
1982 Result
:= Left_Real
* Right_Real
;
1984 else pragma Assert
(Nkind
(N
) = N_Op_Divide
);
1985 if UR_Is_Zero
(Right_Real
) then
1986 Apply_Compile_Time_Constraint_Error
1987 (N
, "division by zero", CE_Divide_By_Zero
);
1991 Result
:= Left_Real
/ Right_Real
;
1994 Fold_Ureal
(N
, Result
, Stat
);
1998 -- If the operator was resolved to a specific type, make sure that type
1999 -- is frozen even if the expression is folded into a literal (which has
2000 -- a universal type).
2002 if Present
(Otype
) then
2003 Freeze_Before
(N
, Otype
);
2005 end Eval_Arithmetic_Op
;
2007 ----------------------------
2008 -- Eval_Character_Literal --
2009 ----------------------------
2011 -- Nothing to be done
2013 procedure Eval_Character_Literal
(N
: Node_Id
) is
2014 pragma Warnings
(Off
, N
);
2017 end Eval_Character_Literal
;
2023 -- Static function calls are either calls to predefined operators
2024 -- with static arguments, or calls to functions that rename a literal.
2025 -- Only the latter case is handled here, predefined operators are
2026 -- constant-folded elsewhere.
2028 -- If the function is itself inherited (see 7423-001) the literal of
2029 -- the parent type must be explicitly converted to the return type
2032 procedure Eval_Call
(N
: Node_Id
) is
2033 Loc
: constant Source_Ptr
:= Sloc
(N
);
2034 Typ
: constant Entity_Id
:= Etype
(N
);
2038 if Nkind
(N
) = N_Function_Call
2039 and then No
(Parameter_Associations
(N
))
2040 and then Is_Entity_Name
(Name
(N
))
2041 and then Present
(Alias
(Entity
(Name
(N
))))
2042 and then Is_Enumeration_Type
(Base_Type
(Typ
))
2044 Lit
:= Ultimate_Alias
(Entity
(Name
(N
)));
2046 if Ekind
(Lit
) = E_Enumeration_Literal
then
2047 if Base_Type
(Etype
(Lit
)) /= Base_Type
(Typ
) then
2049 (N
, Convert_To
(Typ
, New_Occurrence_Of
(Lit
, Loc
)));
2051 Rewrite
(N
, New_Occurrence_Of
(Lit
, Loc
));
2059 --------------------------
2060 -- Eval_Case_Expression --
2061 --------------------------
2063 -- A conditional expression is static if all its conditions and dependent
2064 -- expressions are static. Note that we do not care if the dependent
2065 -- expressions raise CE, except for the one that will be selected.
2067 procedure Eval_Case_Expression
(N
: Node_Id
) is
2072 Set_Is_Static_Expression
(N
, False);
2074 if not Is_Static_Expression
(Expression
(N
)) then
2075 Check_Non_Static_Context
(Expression
(N
));
2079 -- First loop, make sure all the alternatives are static expressions
2080 -- none of which raise Constraint_Error. We make the constraint error
2081 -- check because part of the legality condition for a correct static
2082 -- case expression is that the cases are covered, like any other case
2083 -- expression. And we can't do that if any of the conditions raise an
2084 -- exception, so we don't even try to evaluate if that is the case.
2086 Alt
:= First
(Alternatives
(N
));
2087 while Present
(Alt
) loop
2089 -- The expression must be static, but we don't care at this stage
2090 -- if it raises Constraint_Error (the alternative might not match,
2091 -- in which case the expression is statically unevaluated anyway).
2093 if not Is_Static_Expression
(Expression
(Alt
)) then
2094 Check_Non_Static_Context
(Expression
(Alt
));
2098 -- The choices of a case always have to be static, and cannot raise
2099 -- an exception. If this condition is not met, then the expression
2100 -- is plain illegal, so just abandon evaluation attempts. No need
2101 -- to check non-static context when we have something illegal anyway.
2103 if not Is_OK_Static_Choice_List
(Discrete_Choices
(Alt
)) then
2110 -- OK, if the above loop gets through it means that all choices are OK
2111 -- static (don't raise exceptions), so the whole case is static, and we
2112 -- can find the matching alternative.
2114 Set_Is_Static_Expression
(N
);
2116 -- Now to deal with propagating a possible constraint error
2118 -- If the selecting expression raises CE, propagate and we are done
2120 if Raises_Constraint_Error
(Expression
(N
)) then
2121 Set_Raises_Constraint_Error
(N
);
2123 -- Otherwise we need to check the alternatives to find the matching
2124 -- one. CE's in other than the matching one are not relevant. But we
2125 -- do need to check the matching one. Unlike the first loop, we do not
2126 -- have to go all the way through, when we find the matching one, quit.
2129 Alt
:= First
(Alternatives
(N
));
2132 -- We must find a match among the alternatives. If not, this must
2133 -- be due to other errors, so just ignore, leaving as non-static.
2136 Set_Is_Static_Expression
(N
, False);
2140 -- Otherwise loop through choices of this alternative
2142 Choice
:= First
(Discrete_Choices
(Alt
));
2143 while Present
(Choice
) loop
2145 -- If we find a matching choice, then the Expression of this
2146 -- alternative replaces N (Raises_Constraint_Error flag is
2147 -- included, so we don't have to special case that).
2149 if Choice_Matches
(Expression
(N
), Choice
) = Match
then
2150 Rewrite
(N
, Relocate_Node
(Expression
(Alt
)));
2160 end Eval_Case_Expression
;
2162 ------------------------
2163 -- Eval_Concatenation --
2164 ------------------------
2166 -- Concatenation is a static function, so the result is static if both
2167 -- operands are static (RM 4.9(7), 4.9(21)).
2169 procedure Eval_Concatenation
(N
: Node_Id
) is
2170 Left
: constant Node_Id
:= Left_Opnd
(N
);
2171 Right
: constant Node_Id
:= Right_Opnd
(N
);
2172 C_Typ
: constant Entity_Id
:= Root_Type
(Component_Type
(Etype
(N
)));
2177 -- Concatenation is never static in Ada 83, so if Ada 83 check operand
2178 -- non-static context.
2180 if Ada_Version
= Ada_83
2181 and then Comes_From_Source
(N
)
2183 Check_Non_Static_Context
(Left
);
2184 Check_Non_Static_Context
(Right
);
2188 -- If not foldable we are done. In principle concatenation that yields
2189 -- any string type is static (i.e. an array type of character types).
2190 -- However, character types can include enumeration literals, and
2191 -- concatenation in that case cannot be described by a literal, so we
2192 -- only consider the operation static if the result is an array of
2193 -- (a descendant of) a predefined character type.
2195 Test_Expression_Is_Foldable
(N
, Left
, Right
, Stat
, Fold
);
2197 if not (Is_Standard_Character_Type
(C_Typ
) and then Fold
) then
2198 Set_Is_Static_Expression
(N
, False);
2202 -- Compile time string concatenation
2204 -- ??? Note that operands that are aggregates can be marked as static,
2205 -- so we should attempt at a later stage to fold concatenations with
2209 Left_Str
: constant Node_Id
:= Get_String_Val
(Left
);
2211 Right_Str
: constant Node_Id
:= Get_String_Val
(Right
);
2212 Folded_Val
: String_Id
;
2215 -- Establish new string literal, and store left operand. We make
2216 -- sure to use the special Start_String that takes an operand if
2217 -- the left operand is a string literal. Since this is optimized
2218 -- in the case where that is the most recently created string
2219 -- literal, we ensure efficient time/space behavior for the
2220 -- case of a concatenation of a series of string literals.
2222 if Nkind
(Left_Str
) = N_String_Literal
then
2223 Left_Len
:= String_Length
(Strval
(Left_Str
));
2225 -- If the left operand is the empty string, and the right operand
2226 -- is a string literal (the case of "" & "..."), the result is the
2227 -- value of the right operand. This optimization is important when
2228 -- Is_Folded_In_Parser, to avoid copying an enormous right
2231 if Left_Len
= 0 and then Nkind
(Right_Str
) = N_String_Literal
then
2232 Folded_Val
:= Strval
(Right_Str
);
2234 Start_String
(Strval
(Left_Str
));
2239 Store_String_Char
(UI_To_CC
(Char_Literal_Value
(Left_Str
)));
2243 -- Now append the characters of the right operand, unless we
2244 -- optimized the "" & "..." case above.
2246 if Nkind
(Right_Str
) = N_String_Literal
then
2247 if Left_Len
/= 0 then
2248 Store_String_Chars
(Strval
(Right_Str
));
2249 Folded_Val
:= End_String
;
2252 Store_String_Char
(UI_To_CC
(Char_Literal_Value
(Right_Str
)));
2253 Folded_Val
:= End_String
;
2256 Set_Is_Static_Expression
(N
, Stat
);
2258 -- If left operand is the empty string, the result is the
2259 -- right operand, including its bounds if anomalous.
2262 and then Is_Array_Type
(Etype
(Right
))
2263 and then Etype
(Right
) /= Any_String
2265 Set_Etype
(N
, Etype
(Right
));
2268 Fold_Str
(N
, Folded_Val
, Static
=> Stat
);
2270 end Eval_Concatenation
;
2272 ----------------------
2273 -- Eval_Entity_Name --
2274 ----------------------
2276 -- This procedure is used for identifiers and expanded names other than
2277 -- named numbers (see Eval_Named_Integer, Eval_Named_Real. These are
2278 -- static if they denote a static constant (RM 4.9(6)) or if the name
2279 -- denotes an enumeration literal (RM 4.9(22)).
2281 procedure Eval_Entity_Name
(N
: Node_Id
) is
2282 Def_Id
: constant Entity_Id
:= Entity
(N
);
2286 -- Enumeration literals are always considered to be constants
2287 -- and cannot raise constraint error (RM 4.9(22)).
2289 if Ekind
(Def_Id
) = E_Enumeration_Literal
then
2290 Set_Is_Static_Expression
(N
);
2293 -- A name is static if it denotes a static constant (RM 4.9(5)), and
2294 -- we also copy Raise_Constraint_Error. Notice that even if non-static,
2295 -- it does not violate 10.2.1(8) here, since this is not a variable.
2297 elsif Ekind
(Def_Id
) = E_Constant
then
2299 -- Deferred constants must always be treated as nonstatic outside the
2300 -- scope of their full view.
2302 if Present
(Full_View
(Def_Id
))
2303 and then not In_Open_Scopes
(Scope
(Def_Id
))
2307 Val
:= Constant_Value
(Def_Id
);
2310 if Present
(Val
) then
2311 Set_Is_Static_Expression
2312 (N
, Is_Static_Expression
(Val
)
2313 and then Is_Static_Subtype
(Etype
(Def_Id
)));
2314 Set_Raises_Constraint_Error
(N
, Raises_Constraint_Error
(Val
));
2316 if not Is_Static_Expression
(N
)
2317 and then not Is_Generic_Type
(Etype
(N
))
2319 Validate_Static_Object_Name
(N
);
2322 -- Mark constant condition in SCOs
2325 and then Comes_From_Source
(N
)
2326 and then Is_Boolean_Type
(Etype
(Def_Id
))
2327 and then Compile_Time_Known_Value
(N
)
2329 Set_SCO_Condition
(N
, Expr_Value_E
(N
) = Standard_True
);
2336 -- Fall through if the name is not static
2338 Validate_Static_Object_Name
(N
);
2339 end Eval_Entity_Name
;
2341 ------------------------
2342 -- Eval_If_Expression --
2343 ------------------------
2345 -- We can fold to a static expression if the condition and both dependent
2346 -- expressions are static. Otherwise, the only required processing is to do
2347 -- the check for non-static context for the then and else expressions.
2349 procedure Eval_If_Expression
(N
: Node_Id
) is
2350 Condition
: constant Node_Id
:= First
(Expressions
(N
));
2351 Then_Expr
: constant Node_Id
:= Next
(Condition
);
2352 Else_Expr
: constant Node_Id
:= Next
(Then_Expr
);
2354 Non_Result
: Node_Id
;
2356 Rstat
: constant Boolean :=
2357 Is_Static_Expression
(Condition
)
2359 Is_Static_Expression
(Then_Expr
)
2361 Is_Static_Expression
(Else_Expr
);
2362 -- True if result is static
2365 -- If result not static, nothing to do, otherwise set static result
2370 Set_Is_Static_Expression
(N
);
2373 -- If any operand is Any_Type, just propagate to result and do not try
2374 -- to fold, this prevents cascaded errors.
2376 if Etype
(Condition
) = Any_Type
or else
2377 Etype
(Then_Expr
) = Any_Type
or else
2378 Etype
(Else_Expr
) = Any_Type
2380 Set_Etype
(N
, Any_Type
);
2381 Set_Is_Static_Expression
(N
, False);
2385 -- If condition raises constraint error then we have already signaled
2386 -- an error, and we just propagate to the result and do not fold.
2388 if Raises_Constraint_Error
(Condition
) then
2389 Set_Raises_Constraint_Error
(N
);
2393 -- Static case where we can fold. Note that we don't try to fold cases
2394 -- where the condition is known at compile time, but the result is
2395 -- non-static. This avoids possible cases of infinite recursion where
2396 -- the expander puts in a redundant test and we remove it. Instead we
2397 -- deal with these cases in the expander.
2399 -- Select result operand
2401 if Is_True
(Expr_Value
(Condition
)) then
2402 Result
:= Then_Expr
;
2403 Non_Result
:= Else_Expr
;
2405 Result
:= Else_Expr
;
2406 Non_Result
:= Then_Expr
;
2409 -- Note that it does not matter if the non-result operand raises a
2410 -- Constraint_Error, but if the result raises constraint error then we
2411 -- replace the node with a raise constraint error. This will properly
2412 -- propagate Raises_Constraint_Error since this flag is set in Result.
2414 if Raises_Constraint_Error
(Result
) then
2415 Rewrite_In_Raise_CE
(N
, Result
);
2416 Check_Non_Static_Context
(Non_Result
);
2418 -- Otherwise the result operand replaces the original node
2421 Rewrite
(N
, Relocate_Node
(Result
));
2422 Set_Is_Static_Expression
(N
);
2424 end Eval_If_Expression
;
2426 ----------------------------
2427 -- Eval_Indexed_Component --
2428 ----------------------------
2430 -- Indexed components are never static, so we need to perform the check
2431 -- for non-static context on the index values. Then, we check if the
2432 -- value can be obtained at compile time, even though it is non-static.
2434 procedure Eval_Indexed_Component
(N
: Node_Id
) is
2438 -- Check for non-static context on index values
2440 Expr
:= First
(Expressions
(N
));
2441 while Present
(Expr
) loop
2442 Check_Non_Static_Context
(Expr
);
2446 -- If the indexed component appears in an object renaming declaration
2447 -- then we do not want to try to evaluate it, since in this case we
2448 -- need the identity of the array element.
2450 if Nkind
(Parent
(N
)) = N_Object_Renaming_Declaration
then
2453 -- Similarly if the indexed component appears as the prefix of an
2454 -- attribute we don't want to evaluate it, because at least for
2455 -- some cases of attributes we need the identify (e.g. Access, Size)
2457 elsif Nkind
(Parent
(N
)) = N_Attribute_Reference
then
2461 -- Note: there are other cases, such as the left side of an assignment,
2462 -- or an OUT parameter for a call, where the replacement results in the
2463 -- illegal use of a constant, But these cases are illegal in the first
2464 -- place, so the replacement, though silly, is harmless.
2466 -- Now see if this is a constant array reference
2468 if List_Length
(Expressions
(N
)) = 1
2469 and then Is_Entity_Name
(Prefix
(N
))
2470 and then Ekind
(Entity
(Prefix
(N
))) = E_Constant
2471 and then Present
(Constant_Value
(Entity
(Prefix
(N
))))
2474 Loc
: constant Source_Ptr
:= Sloc
(N
);
2475 Arr
: constant Node_Id
:= Constant_Value
(Entity
(Prefix
(N
)));
2476 Sub
: constant Node_Id
:= First
(Expressions
(N
));
2482 -- Linear one's origin subscript value for array reference
2485 -- Lower bound of the first array index
2488 -- Value from constant array
2491 Atyp
:= Etype
(Arr
);
2493 if Is_Access_Type
(Atyp
) then
2494 Atyp
:= Designated_Type
(Atyp
);
2497 -- If we have an array type (we should have but perhaps there are
2498 -- error cases where this is not the case), then see if we can do
2499 -- a constant evaluation of the array reference.
2501 if Is_Array_Type
(Atyp
) and then Atyp
/= Any_Composite
then
2502 if Ekind
(Atyp
) = E_String_Literal_Subtype
then
2503 Lbd
:= String_Literal_Low_Bound
(Atyp
);
2505 Lbd
:= Type_Low_Bound
(Etype
(First_Index
(Atyp
)));
2508 if Compile_Time_Known_Value
(Sub
)
2509 and then Nkind
(Arr
) = N_Aggregate
2510 and then Compile_Time_Known_Value
(Lbd
)
2511 and then Is_Discrete_Type
(Component_Type
(Atyp
))
2513 Lin
:= UI_To_Int
(Expr_Value
(Sub
) - Expr_Value
(Lbd
)) + 1;
2515 if List_Length
(Expressions
(Arr
)) >= Lin
then
2516 Elm
:= Pick
(Expressions
(Arr
), Lin
);
2518 -- If the resulting expression is compile time known,
2519 -- then we can rewrite the indexed component with this
2520 -- value, being sure to mark the result as non-static.
2521 -- We also reset the Sloc, in case this generates an
2522 -- error later on (e.g. 136'Access).
2524 if Compile_Time_Known_Value
(Elm
) then
2525 Rewrite
(N
, Duplicate_Subexpr_No_Checks
(Elm
));
2526 Set_Is_Static_Expression
(N
, False);
2531 -- We can also constant-fold if the prefix is a string literal.
2532 -- This will be useful in an instantiation or an inlining.
2534 elsif Compile_Time_Known_Value
(Sub
)
2535 and then Nkind
(Arr
) = N_String_Literal
2536 and then Compile_Time_Known_Value
(Lbd
)
2537 and then Expr_Value
(Lbd
) = 1
2538 and then Expr_Value
(Sub
) <=
2539 String_Literal_Length
(Etype
(Arr
))
2542 C
: constant Char_Code
:=
2543 Get_String_Char
(Strval
(Arr
),
2544 UI_To_Int
(Expr_Value
(Sub
)));
2546 Set_Character_Literal_Name
(C
);
2549 Make_Character_Literal
(Loc
,
2551 Char_Literal_Value
=> UI_From_CC
(C
));
2552 Set_Etype
(Elm
, Component_Type
(Atyp
));
2553 Rewrite
(N
, Duplicate_Subexpr_No_Checks
(Elm
));
2554 Set_Is_Static_Expression
(N
, False);
2560 end Eval_Indexed_Component
;
2562 --------------------------
2563 -- Eval_Integer_Literal --
2564 --------------------------
2566 -- Numeric literals are static (RM 4.9(1)), and have already been marked
2567 -- as static by the analyzer. The reason we did it that early is to allow
2568 -- the possibility of turning off the Is_Static_Expression flag after
2569 -- analysis, but before resolution, when integer literals are generated in
2570 -- the expander that do not correspond to static expressions.
2572 procedure Eval_Integer_Literal
(N
: Node_Id
) is
2573 T
: constant Entity_Id
:= Etype
(N
);
2575 function In_Any_Integer_Context
return Boolean;
2576 -- If the literal is resolved with a specific type in a context where
2577 -- the expected type is Any_Integer, there are no range checks on the
2578 -- literal. By the time the literal is evaluated, it carries the type
2579 -- imposed by the enclosing expression, and we must recover the context
2580 -- to determine that Any_Integer is meant.
2582 ----------------------------
2583 -- In_Any_Integer_Context --
2584 ----------------------------
2586 function In_Any_Integer_Context
return Boolean is
2587 Par
: constant Node_Id
:= Parent
(N
);
2588 K
: constant Node_Kind
:= Nkind
(Par
);
2591 -- Any_Integer also appears in digits specifications for real types,
2592 -- but those have bounds smaller that those of any integer base type,
2593 -- so we can safely ignore these cases.
2595 return Nkind_In
(K
, N_Number_Declaration
,
2596 N_Attribute_Reference
,
2597 N_Attribute_Definition_Clause
,
2598 N_Modular_Type_Definition
,
2599 N_Signed_Integer_Type_Definition
);
2600 end In_Any_Integer_Context
;
2602 -- Start of processing for Eval_Integer_Literal
2606 -- If the literal appears in a non-expression context, then it is
2607 -- certainly appearing in a non-static context, so check it. This is
2608 -- actually a redundant check, since Check_Non_Static_Context would
2609 -- check it, but it seems worth while avoiding the call.
2611 if Nkind
(Parent
(N
)) not in N_Subexpr
2612 and then not In_Any_Integer_Context
2614 Check_Non_Static_Context
(N
);
2617 -- Modular integer literals must be in their base range
2619 if Is_Modular_Integer_Type
(T
)
2620 and then Is_Out_Of_Range
(N
, Base_Type
(T
), Assume_Valid
=> True)
2624 end Eval_Integer_Literal
;
2626 ---------------------
2627 -- Eval_Logical_Op --
2628 ---------------------
2630 -- Logical operations are static functions, so the result is potentially
2631 -- static if both operands are potentially static (RM 4.9(7), 4.9(20)).
2633 procedure Eval_Logical_Op
(N
: Node_Id
) is
2634 Left
: constant Node_Id
:= Left_Opnd
(N
);
2635 Right
: constant Node_Id
:= Right_Opnd
(N
);
2640 -- If not foldable we are done
2642 Test_Expression_Is_Foldable
(N
, Left
, Right
, Stat
, Fold
);
2648 -- Compile time evaluation of logical operation
2651 Left_Int
: constant Uint
:= Expr_Value
(Left
);
2652 Right_Int
: constant Uint
:= Expr_Value
(Right
);
2655 if Is_Modular_Integer_Type
(Etype
(N
)) then
2657 Left_Bits
: Bits
(0 .. UI_To_Int
(Esize
(Etype
(N
))) - 1);
2658 Right_Bits
: Bits
(0 .. UI_To_Int
(Esize
(Etype
(N
))) - 1);
2661 To_Bits
(Left_Int
, Left_Bits
);
2662 To_Bits
(Right_Int
, Right_Bits
);
2664 -- Note: should really be able to use array ops instead of
2665 -- these loops, but they weren't working at the time ???
2667 if Nkind
(N
) = N_Op_And
then
2668 for J
in Left_Bits
'Range loop
2669 Left_Bits
(J
) := Left_Bits
(J
) and Right_Bits
(J
);
2672 elsif Nkind
(N
) = N_Op_Or
then
2673 for J
in Left_Bits
'Range loop
2674 Left_Bits
(J
) := Left_Bits
(J
) or Right_Bits
(J
);
2678 pragma Assert
(Nkind
(N
) = N_Op_Xor
);
2680 for J
in Left_Bits
'Range loop
2681 Left_Bits
(J
) := Left_Bits
(J
) xor Right_Bits
(J
);
2685 Fold_Uint
(N
, From_Bits
(Left_Bits
, Etype
(N
)), Stat
);
2689 pragma Assert
(Is_Boolean_Type
(Etype
(N
)));
2691 if Nkind
(N
) = N_Op_And
then
2693 Test
(Is_True
(Left_Int
) and then Is_True
(Right_Int
)), Stat
);
2695 elsif Nkind
(N
) = N_Op_Or
then
2697 Test
(Is_True
(Left_Int
) or else Is_True
(Right_Int
)), Stat
);
2700 pragma Assert
(Nkind
(N
) = N_Op_Xor
);
2702 Test
(Is_True
(Left_Int
) xor Is_True
(Right_Int
)), Stat
);
2706 end Eval_Logical_Op
;
2708 ------------------------
2709 -- Eval_Membership_Op --
2710 ------------------------
2712 -- A membership test is potentially static if the expression is static, and
2713 -- the range is a potentially static range, or is a subtype mark denoting a
2714 -- static subtype (RM 4.9(12)).
2716 procedure Eval_Membership_Op
(N
: Node_Id
) is
2717 Left
: constant Node_Id
:= Left_Opnd
(N
);
2718 Right
: constant Node_Id
:= Right_Opnd
(N
);
2719 Alts
: constant List_Id
:= Alternatives
(N
);
2720 Result
: Match_Result
;
2723 -- Ignore if error in either operand, except to make sure that Any_Type
2724 -- is properly propagated to avoid junk cascaded errors.
2726 if Etype
(Left
) = Any_Type
2727 or else (Present
(Right
) and then Etype
(Right
) = Any_Type
)
2729 Set_Etype
(N
, Any_Type
);
2733 -- Ignore if types involved have predicates
2734 -- Is this right for static predicates ???
2735 -- And what about the alternatives ???
2737 if Present
(Predicate_Function
(Etype
(Left
)))
2738 or else (Present
(Right
)
2739 and then Present
(Predicate_Function
(Etype
(Right
))))
2744 -- If left operand non-static, then nothing to do
2746 if not Is_Static_Expression
(Left
) then
2750 -- If choice is non-static, left operand is in non-static context
2752 if (Present
(Right
) and then not Is_Static_Choice
(Right
))
2753 or else (Present
(Alts
) and then not Is_Static_Choice_List
(Alts
))
2755 Check_Non_Static_Context
(Left
);
2759 -- Otherwise we definitely have a static expression
2761 Set_Is_Static_Expression
(N
);
2763 -- If left operand raises constraint error, propagate and we are done
2765 if Raises_Constraint_Error
(Left
) then
2766 Set_Raises_Constraint_Error
(N
, True);
2771 if Present
(Right
) then
2772 Result
:= Choice_Matches
(Left
, Right
);
2774 Result
:= Choices_Match
(Left
, Alts
);
2777 -- If result is Non_Static, it means that we raise Constraint_Error,
2778 -- since we already tested that the operands were themselves static.
2780 if Result
= Non_Static
then
2781 Set_Raises_Constraint_Error
(N
);
2783 -- Otherwise we have our result (flipped if NOT IN case)
2787 (N
, Test
((Result
= Match
) xor (Nkind
(N
) = N_Not_In
)), True);
2788 Warn_On_Known_Condition
(N
);
2791 end Eval_Membership_Op
;
2793 ------------------------
2794 -- Eval_Named_Integer --
2795 ------------------------
2797 procedure Eval_Named_Integer
(N
: Node_Id
) is
2800 Expr_Value
(Expression
(Declaration_Node
(Entity
(N
)))), True);
2801 end Eval_Named_Integer
;
2803 ---------------------
2804 -- Eval_Named_Real --
2805 ---------------------
2807 procedure Eval_Named_Real
(N
: Node_Id
) is
2810 Expr_Value_R
(Expression
(Declaration_Node
(Entity
(N
)))), True);
2811 end Eval_Named_Real
;
2817 -- Exponentiation is a static functions, so the result is potentially
2818 -- static if both operands are potentially static (RM 4.9(7), 4.9(20)).
2820 procedure Eval_Op_Expon
(N
: Node_Id
) is
2821 Left
: constant Node_Id
:= Left_Opnd
(N
);
2822 Right
: constant Node_Id
:= Right_Opnd
(N
);
2827 -- If not foldable we are done
2829 Test_Expression_Is_Foldable
2830 (N
, Left
, Right
, Stat
, Fold
, CRT_Safe
=> True);
2832 -- Return if not foldable
2838 if Configurable_Run_Time_Mode
and not Stat
then
2842 -- Fold exponentiation operation
2845 Right_Int
: constant Uint
:= Expr_Value
(Right
);
2850 if Is_Integer_Type
(Etype
(Left
)) then
2852 Left_Int
: constant Uint
:= Expr_Value
(Left
);
2856 -- Exponentiation of an integer raises Constraint_Error for a
2857 -- negative exponent (RM 4.5.6).
2859 if Right_Int
< 0 then
2860 Apply_Compile_Time_Constraint_Error
2861 (N
, "integer exponent negative", CE_Range_Check_Failed
,
2866 if OK_Bits
(N
, Num_Bits
(Left_Int
) * Right_Int
) then
2867 Result
:= Left_Int
** Right_Int
;
2872 if Is_Modular_Integer_Type
(Etype
(N
)) then
2873 Result
:= Result
mod Modulus
(Etype
(N
));
2876 Fold_Uint
(N
, Result
, Stat
);
2884 Left_Real
: constant Ureal
:= Expr_Value_R
(Left
);
2887 -- Cannot have a zero base with a negative exponent
2889 if UR_Is_Zero
(Left_Real
) then
2891 if Right_Int
< 0 then
2892 Apply_Compile_Time_Constraint_Error
2893 (N
, "zero ** negative integer", CE_Range_Check_Failed
,
2897 Fold_Ureal
(N
, Ureal_0
, Stat
);
2901 Fold_Ureal
(N
, Left_Real
** Right_Int
, Stat
);
2912 -- The not operation is a static functions, so the result is potentially
2913 -- static if the operand is potentially static (RM 4.9(7), 4.9(20)).
2915 procedure Eval_Op_Not
(N
: Node_Id
) is
2916 Right
: constant Node_Id
:= Right_Opnd
(N
);
2921 -- If not foldable we are done
2923 Test_Expression_Is_Foldable
(N
, Right
, Stat
, Fold
);
2929 -- Fold not operation
2932 Rint
: constant Uint
:= Expr_Value
(Right
);
2933 Typ
: constant Entity_Id
:= Etype
(N
);
2936 -- Negation is equivalent to subtracting from the modulus minus one.
2937 -- For a binary modulus this is equivalent to the ones-complement of
2938 -- the original value. For a nonbinary modulus this is an arbitrary
2939 -- but consistent definition.
2941 if Is_Modular_Integer_Type
(Typ
) then
2942 Fold_Uint
(N
, Modulus
(Typ
) - 1 - Rint
, Stat
);
2943 else pragma Assert
(Is_Boolean_Type
(Typ
));
2944 Fold_Uint
(N
, Test
(not Is_True
(Rint
)), Stat
);
2947 Set_Is_Static_Expression
(N
, Stat
);
2951 -------------------------------
2952 -- Eval_Qualified_Expression --
2953 -------------------------------
2955 -- A qualified expression is potentially static if its subtype mark denotes
2956 -- a static subtype and its expression is potentially static (RM 4.9 (11)).
2958 procedure Eval_Qualified_Expression
(N
: Node_Id
) is
2959 Operand
: constant Node_Id
:= Expression
(N
);
2960 Target_Type
: constant Entity_Id
:= Entity
(Subtype_Mark
(N
));
2967 -- Can only fold if target is string or scalar and subtype is static.
2968 -- Also, do not fold if our parent is an allocator (this is because the
2969 -- qualified expression is really part of the syntactic structure of an
2970 -- allocator, and we do not want to end up with something that
2971 -- corresponds to "new 1" where the 1 is the result of folding a
2972 -- qualified expression).
2974 if not Is_Static_Subtype
(Target_Type
)
2975 or else Nkind
(Parent
(N
)) = N_Allocator
2977 Check_Non_Static_Context
(Operand
);
2979 -- If operand is known to raise constraint_error, set the flag on the
2980 -- expression so it does not get optimized away.
2982 if Nkind
(Operand
) = N_Raise_Constraint_Error
then
2983 Set_Raises_Constraint_Error
(N
);
2989 -- If not foldable we are done
2991 Test_Expression_Is_Foldable
(N
, Operand
, Stat
, Fold
);
2996 -- Don't try fold if target type has constraint error bounds
2998 elsif not Is_OK_Static_Subtype
(Target_Type
) then
2999 Set_Raises_Constraint_Error
(N
);
3003 -- Here we will fold, save Print_In_Hex indication
3005 Hex
:= Nkind
(Operand
) = N_Integer_Literal
3006 and then Print_In_Hex
(Operand
);
3008 -- Fold the result of qualification
3010 if Is_Discrete_Type
(Target_Type
) then
3011 Fold_Uint
(N
, Expr_Value
(Operand
), Stat
);
3013 -- Preserve Print_In_Hex indication
3015 if Hex
and then Nkind
(N
) = N_Integer_Literal
then
3016 Set_Print_In_Hex
(N
);
3019 elsif Is_Real_Type
(Target_Type
) then
3020 Fold_Ureal
(N
, Expr_Value_R
(Operand
), Stat
);
3023 Fold_Str
(N
, Strval
(Get_String_Val
(Operand
)), Stat
);
3026 Set_Is_Static_Expression
(N
, False);
3028 Check_String_Literal_Length
(N
, Target_Type
);
3034 -- The expression may be foldable but not static
3036 Set_Is_Static_Expression
(N
, Stat
);
3038 if Is_Out_Of_Range
(N
, Etype
(N
), Assume_Valid
=> True) then
3041 end Eval_Qualified_Expression
;
3043 -----------------------
3044 -- Eval_Real_Literal --
3045 -----------------------
3047 -- Numeric literals are static (RM 4.9(1)), and have already been marked
3048 -- as static by the analyzer. The reason we did it that early is to allow
3049 -- the possibility of turning off the Is_Static_Expression flag after
3050 -- analysis, but before resolution, when integer literals are generated
3051 -- in the expander that do not correspond to static expressions.
3053 procedure Eval_Real_Literal
(N
: Node_Id
) is
3054 PK
: constant Node_Kind
:= Nkind
(Parent
(N
));
3057 -- If the literal appears in a non-expression context and not as part of
3058 -- a number declaration, then it is appearing in a non-static context,
3061 if PK
not in N_Subexpr
and then PK
/= N_Number_Declaration
then
3062 Check_Non_Static_Context
(N
);
3064 end Eval_Real_Literal
;
3066 ------------------------
3067 -- Eval_Relational_Op --
3068 ------------------------
3070 -- Relational operations are static functions, so the result is static if
3071 -- both operands are static (RM 4.9(7), 4.9(20)), except that for strings,
3072 -- the result is never static, even if the operands are.
3074 -- However, for internally generated nodes, we allow string equality and
3075 -- inequality to be static. This is because we rewrite A in "ABC" as an
3076 -- equality test A = "ABC", and the former is definitely static.
3078 procedure Eval_Relational_Op
(N
: Node_Id
) is
3079 Left
: constant Node_Id
:= Left_Opnd
(N
);
3080 Right
: constant Node_Id
:= Right_Opnd
(N
);
3081 Typ
: constant Entity_Id
:= Etype
(Left
);
3082 Otype
: Entity_Id
:= Empty
;
3086 -- One special case to deal with first. If we can tell that the result
3087 -- will be false because the lengths of one or more index subtypes are
3088 -- compile time known and different, then we can replace the entire
3089 -- result by False. We only do this for one dimensional arrays, because
3090 -- the case of multi-dimensional arrays is rare and too much trouble. If
3091 -- one of the operands is an illegal aggregate, its type might still be
3092 -- an arbitrary composite type, so nothing to do.
3094 if Is_Array_Type
(Typ
)
3095 and then Typ
/= Any_Composite
3096 and then Number_Dimensions
(Typ
) = 1
3097 and then (Nkind
(N
) = N_Op_Eq
or else Nkind
(N
) = N_Op_Ne
)
3099 if Raises_Constraint_Error
(Left
)
3101 Raises_Constraint_Error
(Right
)
3106 -- OK, we have the case where we may be able to do this fold
3108 Length_Mismatch
: declare
3109 procedure Get_Static_Length
(Op
: Node_Id
; Len
: out Uint
);
3110 -- If Op is an expression for a constrained array with a known at
3111 -- compile time length, then Len is set to this (non-negative
3112 -- length). Otherwise Len is set to minus 1.
3114 -----------------------
3115 -- Get_Static_Length --
3116 -----------------------
3118 procedure Get_Static_Length
(Op
: Node_Id
; Len
: out Uint
) is
3122 -- First easy case string literal
3124 if Nkind
(Op
) = N_String_Literal
then
3125 Len
:= UI_From_Int
(String_Length
(Strval
(Op
)));
3129 -- Second easy case, not constrained subtype, so no length
3131 if not Is_Constrained
(Etype
(Op
)) then
3132 Len
:= Uint_Minus_1
;
3138 T
:= Etype
(First_Index
(Etype
(Op
)));
3140 -- The simple case, both bounds are known at compile time
3142 if Is_Discrete_Type
(T
)
3143 and then Compile_Time_Known_Value
(Type_Low_Bound
(T
))
3144 and then Compile_Time_Known_Value
(Type_High_Bound
(T
))
3146 Len
:= UI_Max
(Uint_0
,
3147 Expr_Value
(Type_High_Bound
(T
)) -
3148 Expr_Value
(Type_Low_Bound
(T
)) + 1);
3152 -- A more complex case, where the bounds are of the form
3153 -- X [+/- K1] .. X [+/- K2]), where X is an expression that is
3154 -- either A'First or A'Last (with A an entity name), or X is an
3155 -- entity name, and the two X's are the same and K1 and K2 are
3156 -- known at compile time, in this case, the length can also be
3157 -- computed at compile time, even though the bounds are not
3158 -- known. A common case of this is e.g. (X'First .. X'First+5).
3160 Extract_Length
: declare
3161 procedure Decompose_Expr
3163 Ent
: out Entity_Id
;
3164 Kind
: out Character;
3166 Orig
: Boolean := True);
3167 -- Given an expression see if it is of the form given above,
3168 -- X [+/- K]. If so Ent is set to the entity in X, Kind is
3169 -- 'F','L','E' for 'First/'Last/simple entity, and Cons is
3170 -- the value of K. If the expression is not of the required
3171 -- form, Ent is set to Empty.
3173 -- Orig indicates whether Expr is the original expression
3174 -- to consider, or if we are handling a sub-expression
3175 -- (e.g. recursive call to Decompose_Expr).
3177 --------------------
3178 -- Decompose_Expr --
3179 --------------------
3181 procedure Decompose_Expr
3183 Ent
: out Entity_Id
;
3184 Kind
: out Character;
3186 Orig
: Boolean := True)
3193 if Nkind
(Expr
) = N_Op_Add
3194 and then Compile_Time_Known_Value
(Right_Opnd
(Expr
))
3196 Exp
:= Left_Opnd
(Expr
);
3197 Cons
:= Expr_Value
(Right_Opnd
(Expr
));
3199 elsif Nkind
(Expr
) = N_Op_Subtract
3200 and then Compile_Time_Known_Value
(Right_Opnd
(Expr
))
3202 Exp
:= Left_Opnd
(Expr
);
3203 Cons
:= -Expr_Value
(Right_Opnd
(Expr
));
3205 -- If the bound is a constant created to remove side
3206 -- effects, recover original expression to see if it has
3207 -- one of the recognizable forms.
3209 elsif Nkind
(Expr
) = N_Identifier
3210 and then not Comes_From_Source
(Entity
(Expr
))
3211 and then Ekind
(Entity
(Expr
)) = E_Constant
3213 Nkind
(Parent
(Entity
(Expr
))) = N_Object_Declaration
3215 Exp
:= Expression
(Parent
(Entity
(Expr
)));
3216 Decompose_Expr
(Exp
, Ent
, Kind
, Cons
, Orig
=> False);
3218 -- If original expression includes an entity, create a
3219 -- reference to it for use below.
3221 if Present
(Ent
) then
3222 Exp
:= New_Occurrence_Of
(Ent
, Sloc
(Ent
));
3228 -- Only consider the case of X + 0 for a full
3229 -- expression, and not when recursing, otherwise we
3230 -- may end up with evaluating expressions not known
3231 -- at compile time to 0.
3241 -- At this stage Exp is set to the potential X
3243 if Nkind
(Exp
) = N_Attribute_Reference
then
3244 if Attribute_Name
(Exp
) = Name_First
then
3246 elsif Attribute_Name
(Exp
) = Name_Last
then
3252 Exp
:= Prefix
(Exp
);
3258 if Is_Entity_Name
(Exp
)
3259 and then Present
(Entity
(Exp
))
3261 Ent
:= Entity
(Exp
);
3267 Ent1
, Ent2
: Entity_Id
;
3268 Kind1
, Kind2
: Character;
3269 Cons1
, Cons2
: Uint
;
3271 -- Start of processing for Extract_Length
3275 (Original_Node
(Type_Low_Bound
(T
)), Ent1
, Kind1
, Cons1
);
3277 (Original_Node
(Type_High_Bound
(T
)), Ent2
, Kind2
, Cons2
);
3280 and then Kind1
= Kind2
3281 and then Ent1
= Ent2
3283 Len
:= Cons2
- Cons1
+ 1;
3285 Len
:= Uint_Minus_1
;
3288 end Get_Static_Length
;
3295 -- Start of processing for Length_Mismatch
3298 Get_Static_Length
(Left
, Len_L
);
3299 Get_Static_Length
(Right
, Len_R
);
3301 if Len_L
/= Uint_Minus_1
3302 and then Len_R
/= Uint_Minus_1
3303 and then Len_L
/= Len_R
3305 Fold_Uint
(N
, Test
(Nkind
(N
) = N_Op_Ne
), False);
3306 Warn_On_Known_Condition
(N
);
3309 end Length_Mismatch
;
3313 Is_Static_Expression
: Boolean;
3315 Is_Foldable
: Boolean;
3316 pragma Unreferenced
(Is_Foldable
);
3319 -- Initialize the value of Is_Static_Expression. The value of
3320 -- Is_Foldable returned by Test_Expression_Is_Foldable is not needed
3321 -- since, even when some operand is a variable, we can still perform
3322 -- the static evaluation of the expression in some cases (for
3323 -- example, for a variable of a subtype of Integer we statically
3324 -- know that any value stored in such variable is smaller than
3327 Test_Expression_Is_Foldable
3328 (N
, Left
, Right
, Is_Static_Expression
, Is_Foldable
);
3330 -- Only comparisons of scalars can give static results. In
3331 -- particular, comparisons of strings never yield a static
3332 -- result, even if both operands are static strings, except that
3333 -- as noted above, we allow equality/inequality for strings.
3335 if Is_String_Type
(Typ
)
3336 and then not Comes_From_Source
(N
)
3337 and then Nkind_In
(N
, N_Op_Eq
, N_Op_Ne
)
3341 elsif not Is_Scalar_Type
(Typ
) then
3342 Is_Static_Expression
:= False;
3343 Set_Is_Static_Expression
(N
, False);
3346 -- For operators on universal numeric types called as functions with
3347 -- an explicit scope, determine appropriate specific numeric type,
3348 -- and diagnose possible ambiguity.
3350 if Is_Universal_Numeric_Type
(Etype
(Left
))
3352 Is_Universal_Numeric_Type
(Etype
(Right
))
3354 Otype
:= Find_Universal_Operator_Type
(N
);
3357 -- For static real type expressions, do not use Compile_Time_Compare
3358 -- since it worries about run-time results which are not exact.
3360 if Is_Static_Expression
and then Is_Real_Type
(Typ
) then
3362 Left_Real
: constant Ureal
:= Expr_Value_R
(Left
);
3363 Right_Real
: constant Ureal
:= Expr_Value_R
(Right
);
3367 when N_Op_Eq
=> Result
:= (Left_Real
= Right_Real
);
3368 when N_Op_Ne
=> Result
:= (Left_Real
/= Right_Real
);
3369 when N_Op_Lt
=> Result
:= (Left_Real
< Right_Real
);
3370 when N_Op_Le
=> Result
:= (Left_Real
<= Right_Real
);
3371 when N_Op_Gt
=> Result
:= (Left_Real
> Right_Real
);
3372 when N_Op_Ge
=> Result
:= (Left_Real
>= Right_Real
);
3375 raise Program_Error
;
3378 Fold_Uint
(N
, Test
(Result
), True);
3381 -- For all other cases, we use Compile_Time_Compare to do the compare
3385 CR
: constant Compare_Result
:=
3386 Compile_Time_Compare
3387 (Left
, Right
, Assume_Valid
=> False);
3390 if CR
= Unknown
then
3398 elsif CR
= NE
or else CR
= GT
or else CR
= LT
then
3405 if CR
= NE
or else CR
= GT
or else CR
= LT
then
3416 elsif CR
= EQ
or else CR
= GT
or else CR
= GE
then
3423 if CR
= LT
or else CR
= EQ
or else CR
= LE
then
3434 elsif CR
= EQ
or else CR
= LT
or else CR
= LE
then
3441 if CR
= GT
or else CR
= EQ
or else CR
= GE
then
3450 raise Program_Error
;
3454 Fold_Uint
(N
, Test
(Result
), Is_Static_Expression
);
3458 -- For the case of a folded relational operator on a specific numeric
3459 -- type, freeze operand type now.
3461 if Present
(Otype
) then
3462 Freeze_Before
(N
, Otype
);
3465 Warn_On_Known_Condition
(N
);
3466 end Eval_Relational_Op
;
3472 -- Shift operations are intrinsic operations that can never be static, so
3473 -- the only processing required is to perform the required check for a non
3474 -- static context for the two operands.
3476 -- Actually we could do some compile time evaluation here some time ???
3478 procedure Eval_Shift
(N
: Node_Id
) is
3480 Check_Non_Static_Context
(Left_Opnd
(N
));
3481 Check_Non_Static_Context
(Right_Opnd
(N
));
3484 ------------------------
3485 -- Eval_Short_Circuit --
3486 ------------------------
3488 -- A short circuit operation is potentially static if both operands are
3489 -- potentially static (RM 4.9 (13)).
3491 procedure Eval_Short_Circuit
(N
: Node_Id
) is
3492 Kind
: constant Node_Kind
:= Nkind
(N
);
3493 Left
: constant Node_Id
:= Left_Opnd
(N
);
3494 Right
: constant Node_Id
:= Right_Opnd
(N
);
3497 Rstat
: constant Boolean :=
3498 Is_Static_Expression
(Left
)
3500 Is_Static_Expression
(Right
);
3503 -- Short circuit operations are never static in Ada 83
3505 if Ada_Version
= Ada_83
and then Comes_From_Source
(N
) then
3506 Check_Non_Static_Context
(Left
);
3507 Check_Non_Static_Context
(Right
);
3511 -- Now look at the operands, we can't quite use the normal call to
3512 -- Test_Expression_Is_Foldable here because short circuit operations
3513 -- are a special case, they can still be foldable, even if the right
3514 -- operand raises constraint error.
3516 -- If either operand is Any_Type, just propagate to result and do not
3517 -- try to fold, this prevents cascaded errors.
3519 if Etype
(Left
) = Any_Type
or else Etype
(Right
) = Any_Type
then
3520 Set_Etype
(N
, Any_Type
);
3523 -- If left operand raises constraint error, then replace node N with
3524 -- the raise constraint error node, and we are obviously not foldable.
3525 -- Is_Static_Expression is set from the two operands in the normal way,
3526 -- and we check the right operand if it is in a non-static context.
3528 elsif Raises_Constraint_Error
(Left
) then
3530 Check_Non_Static_Context
(Right
);
3533 Rewrite_In_Raise_CE
(N
, Left
);
3534 Set_Is_Static_Expression
(N
, Rstat
);
3537 -- If the result is not static, then we won't in any case fold
3539 elsif not Rstat
then
3540 Check_Non_Static_Context
(Left
);
3541 Check_Non_Static_Context
(Right
);
3545 -- Here the result is static, note that, unlike the normal processing
3546 -- in Test_Expression_Is_Foldable, we did *not* check above to see if
3547 -- the right operand raises constraint error, that's because it is not
3548 -- significant if the left operand is decisive.
3550 Set_Is_Static_Expression
(N
);
3552 -- It does not matter if the right operand raises constraint error if
3553 -- it will not be evaluated. So deal specially with the cases where
3554 -- the right operand is not evaluated. Note that we will fold these
3555 -- cases even if the right operand is non-static, which is fine, but
3556 -- of course in these cases the result is not potentially static.
3558 Left_Int
:= Expr_Value
(Left
);
3560 if (Kind
= N_And_Then
and then Is_False
(Left_Int
))
3562 (Kind
= N_Or_Else
and then Is_True
(Left_Int
))
3564 Fold_Uint
(N
, Left_Int
, Rstat
);
3568 -- If first operand not decisive, then it does matter if the right
3569 -- operand raises constraint error, since it will be evaluated, so
3570 -- we simply replace the node with the right operand. Note that this
3571 -- properly propagates Is_Static_Expression and Raises_Constraint_Error
3572 -- (both are set to True in Right).
3574 if Raises_Constraint_Error
(Right
) then
3575 Rewrite_In_Raise_CE
(N
, Right
);
3576 Check_Non_Static_Context
(Left
);
3580 -- Otherwise the result depends on the right operand
3582 Fold_Uint
(N
, Expr_Value
(Right
), Rstat
);
3584 end Eval_Short_Circuit
;
3590 -- Slices can never be static, so the only processing required is to check
3591 -- for non-static context if an explicit range is given.
3593 procedure Eval_Slice
(N
: Node_Id
) is
3594 Drange
: constant Node_Id
:= Discrete_Range
(N
);
3597 if Nkind
(Drange
) = N_Range
then
3598 Check_Non_Static_Context
(Low_Bound
(Drange
));
3599 Check_Non_Static_Context
(High_Bound
(Drange
));
3602 -- A slice of the form A (subtype), when the subtype is the index of
3603 -- the type of A, is redundant, the slice can be replaced with A, and
3604 -- this is worth a warning.
3606 if Is_Entity_Name
(Prefix
(N
)) then
3608 E
: constant Entity_Id
:= Entity
(Prefix
(N
));
3609 T
: constant Entity_Id
:= Etype
(E
);
3612 if Ekind
(E
) = E_Constant
3613 and then Is_Array_Type
(T
)
3614 and then Is_Entity_Name
(Drange
)
3616 if Is_Entity_Name
(Original_Node
(First_Index
(T
)))
3617 and then Entity
(Original_Node
(First_Index
(T
)))
3620 if Warn_On_Redundant_Constructs
then
3621 Error_Msg_N
("redundant slice denotes whole array?r?", N
);
3624 -- The following might be a useful optimization???
3626 -- Rewrite (N, New_Occurrence_Of (E, Sloc (N)));
3633 -------------------------
3634 -- Eval_String_Literal --
3635 -------------------------
3637 procedure Eval_String_Literal
(N
: Node_Id
) is
3638 Typ
: constant Entity_Id
:= Etype
(N
);
3639 Bas
: constant Entity_Id
:= Base_Type
(Typ
);
3645 -- Nothing to do if error type (handles cases like default expressions
3646 -- or generics where we have not yet fully resolved the type).
3648 if Bas
= Any_Type
or else Bas
= Any_String
then
3652 -- String literals are static if the subtype is static (RM 4.9(2)), so
3653 -- reset the static expression flag (it was set unconditionally in
3654 -- Analyze_String_Literal) if the subtype is non-static. We tell if
3655 -- the subtype is static by looking at the lower bound.
3657 if Ekind
(Typ
) = E_String_Literal_Subtype
then
3658 if not Is_OK_Static_Expression
(String_Literal_Low_Bound
(Typ
)) then
3659 Set_Is_Static_Expression
(N
, False);
3663 -- Here if Etype of string literal is normal Etype (not yet possible,
3664 -- but may be possible in future).
3666 elsif not Is_OK_Static_Expression
3667 (Type_Low_Bound
(Etype
(First_Index
(Typ
))))
3669 Set_Is_Static_Expression
(N
, False);
3673 -- If original node was a type conversion, then result if non-static
3675 if Nkind
(Original_Node
(N
)) = N_Type_Conversion
then
3676 Set_Is_Static_Expression
(N
, False);
3680 -- Test for illegal Ada 95 cases. A string literal is illegal in Ada 95
3681 -- if its bounds are outside the index base type and this index type is
3682 -- static. This can happen in only two ways. Either the string literal
3683 -- is too long, or it is null, and the lower bound is type'First. Either
3684 -- way it is the upper bound that is out of range of the index type.
3686 if Ada_Version
>= Ada_95
then
3687 if Is_Standard_String_Type
(Bas
) then
3688 Xtp
:= Standard_Positive
;
3690 Xtp
:= Etype
(First_Index
(Bas
));
3693 if Ekind
(Typ
) = E_String_Literal_Subtype
then
3694 Lo
:= String_Literal_Low_Bound
(Typ
);
3696 Lo
:= Type_Low_Bound
(Etype
(First_Index
(Typ
)));
3699 -- Check for string too long
3701 Len
:= String_Length
(Strval
(N
));
3703 if UI_From_Int
(Len
) > String_Type_Len
(Bas
) then
3705 -- Issue message. Note that this message is a warning if the
3706 -- string literal is not marked as static (happens in some cases
3707 -- of folding strings known at compile time, but not static).
3708 -- Furthermore in such cases, we reword the message, since there
3709 -- is no string literal in the source program.
3711 if Is_Static_Expression
(N
) then
3712 Apply_Compile_Time_Constraint_Error
3713 (N
, "string literal too long for}", CE_Length_Check_Failed
,
3715 Typ
=> First_Subtype
(Bas
));
3717 Apply_Compile_Time_Constraint_Error
3718 (N
, "string value too long for}", CE_Length_Check_Failed
,
3720 Typ
=> First_Subtype
(Bas
),
3724 -- Test for null string not allowed
3727 and then not Is_Generic_Type
(Xtp
)
3729 Expr_Value
(Lo
) = Expr_Value
(Type_Low_Bound
(Base_Type
(Xtp
)))
3731 -- Same specialization of message
3733 if Is_Static_Expression
(N
) then
3734 Apply_Compile_Time_Constraint_Error
3735 (N
, "null string literal not allowed for}",
3736 CE_Length_Check_Failed
,
3738 Typ
=> First_Subtype
(Bas
));
3740 Apply_Compile_Time_Constraint_Error
3741 (N
, "null string value not allowed for}",
3742 CE_Length_Check_Failed
,
3744 Typ
=> First_Subtype
(Bas
),
3749 end Eval_String_Literal
;
3751 --------------------------
3752 -- Eval_Type_Conversion --
3753 --------------------------
3755 -- A type conversion is potentially static if its subtype mark is for a
3756 -- static scalar subtype, and its operand expression is potentially static
3759 procedure Eval_Type_Conversion
(N
: Node_Id
) is
3760 Operand
: constant Node_Id
:= Expression
(N
);
3761 Source_Type
: constant Entity_Id
:= Etype
(Operand
);
3762 Target_Type
: constant Entity_Id
:= Etype
(N
);
3764 function To_Be_Treated_As_Integer
(T
: Entity_Id
) return Boolean;
3765 -- Returns true if type T is an integer type, or if it is a fixed-point
3766 -- type to be treated as an integer (i.e. the flag Conversion_OK is set
3767 -- on the conversion node).
3769 function To_Be_Treated_As_Real
(T
: Entity_Id
) return Boolean;
3770 -- Returns true if type T is a floating-point type, or if it is a
3771 -- fixed-point type that is not to be treated as an integer (i.e. the
3772 -- flag Conversion_OK is not set on the conversion node).
3774 ------------------------------
3775 -- To_Be_Treated_As_Integer --
3776 ------------------------------
3778 function To_Be_Treated_As_Integer
(T
: Entity_Id
) return Boolean is
3782 or else (Is_Fixed_Point_Type
(T
) and then Conversion_OK
(N
));
3783 end To_Be_Treated_As_Integer
;
3785 ---------------------------
3786 -- To_Be_Treated_As_Real --
3787 ---------------------------
3789 function To_Be_Treated_As_Real
(T
: Entity_Id
) return Boolean is
3792 Is_Floating_Point_Type
(T
)
3793 or else (Is_Fixed_Point_Type
(T
) and then not Conversion_OK
(N
));
3794 end To_Be_Treated_As_Real
;
3801 -- Start of processing for Eval_Type_Conversion
3804 -- Cannot fold if target type is non-static or if semantic error
3806 if not Is_Static_Subtype
(Target_Type
) then
3807 Check_Non_Static_Context
(Operand
);
3809 elsif Error_Posted
(N
) then
3813 -- If not foldable we are done
3815 Test_Expression_Is_Foldable
(N
, Operand
, Stat
, Fold
);
3820 -- Don't try fold if target type has constraint error bounds
3822 elsif not Is_OK_Static_Subtype
(Target_Type
) then
3823 Set_Raises_Constraint_Error
(N
);
3827 -- Remaining processing depends on operand types. Note that in the
3828 -- following type test, fixed-point counts as real unless the flag
3829 -- Conversion_OK is set, in which case it counts as integer.
3831 -- Fold conversion, case of string type. The result is not static
3833 if Is_String_Type
(Target_Type
) then
3834 Fold_Str
(N
, Strval
(Get_String_Val
(Operand
)), Static
=> False);
3837 -- Fold conversion, case of integer target type
3839 elsif To_Be_Treated_As_Integer
(Target_Type
) then
3844 -- Integer to integer conversion
3846 if To_Be_Treated_As_Integer
(Source_Type
) then
3847 Result
:= Expr_Value
(Operand
);
3849 -- Real to integer conversion
3852 Result
:= UR_To_Uint
(Expr_Value_R
(Operand
));
3855 -- If fixed-point type (Conversion_OK must be set), then the
3856 -- result is logically an integer, but we must replace the
3857 -- conversion with the corresponding real literal, since the
3858 -- type from a semantic point of view is still fixed-point.
3860 if Is_Fixed_Point_Type
(Target_Type
) then
3862 (N
, UR_From_Uint
(Result
) * Small_Value
(Target_Type
), Stat
);
3864 -- Otherwise result is integer literal
3867 Fold_Uint
(N
, Result
, Stat
);
3871 -- Fold conversion, case of real target type
3873 elsif To_Be_Treated_As_Real
(Target_Type
) then
3878 if To_Be_Treated_As_Real
(Source_Type
) then
3879 Result
:= Expr_Value_R
(Operand
);
3881 Result
:= UR_From_Uint
(Expr_Value
(Operand
));
3884 Fold_Ureal
(N
, Result
, Stat
);
3887 -- Enumeration types
3890 Fold_Uint
(N
, Expr_Value
(Operand
), Stat
);
3893 if Is_Out_Of_Range
(N
, Etype
(N
), Assume_Valid
=> True) then
3897 end Eval_Type_Conversion
;
3903 -- Predefined unary operators are static functions (RM 4.9(20)) and thus
3904 -- are potentially static if the operand is potentially static (RM 4.9(7)).
3906 procedure Eval_Unary_Op
(N
: Node_Id
) is
3907 Right
: constant Node_Id
:= Right_Opnd
(N
);
3908 Otype
: Entity_Id
:= Empty
;
3913 -- If not foldable we are done
3915 Test_Expression_Is_Foldable
(N
, Right
, Stat
, Fold
);
3921 if Etype
(Right
) = Universal_Integer
3923 Etype
(Right
) = Universal_Real
3925 Otype
:= Find_Universal_Operator_Type
(N
);
3928 -- Fold for integer case
3930 if Is_Integer_Type
(Etype
(N
)) then
3932 Rint
: constant Uint
:= Expr_Value
(Right
);
3936 -- In the case of modular unary plus and abs there is no need
3937 -- to adjust the result of the operation since if the original
3938 -- operand was in bounds the result will be in the bounds of the
3939 -- modular type. However, in the case of modular unary minus the
3940 -- result may go out of the bounds of the modular type and needs
3943 if Nkind
(N
) = N_Op_Plus
then
3946 elsif Nkind
(N
) = N_Op_Minus
then
3947 if Is_Modular_Integer_Type
(Etype
(N
)) then
3948 Result
:= (-Rint
) mod Modulus
(Etype
(N
));
3954 pragma Assert
(Nkind
(N
) = N_Op_Abs
);
3958 Fold_Uint
(N
, Result
, Stat
);
3961 -- Fold for real case
3963 elsif Is_Real_Type
(Etype
(N
)) then
3965 Rreal
: constant Ureal
:= Expr_Value_R
(Right
);
3969 if Nkind
(N
) = N_Op_Plus
then
3971 elsif Nkind
(N
) = N_Op_Minus
then
3972 Result
:= UR_Negate
(Rreal
);
3974 pragma Assert
(Nkind
(N
) = N_Op_Abs
);
3975 Result
:= abs Rreal
;
3978 Fold_Ureal
(N
, Result
, Stat
);
3982 -- If the operator was resolved to a specific type, make sure that type
3983 -- is frozen even if the expression is folded into a literal (which has
3984 -- a universal type).
3986 if Present
(Otype
) then
3987 Freeze_Before
(N
, Otype
);
3991 -------------------------------
3992 -- Eval_Unchecked_Conversion --
3993 -------------------------------
3995 -- Unchecked conversions can never be static, so the only required
3996 -- processing is to check for a non-static context for the operand.
3998 procedure Eval_Unchecked_Conversion
(N
: Node_Id
) is
4000 Check_Non_Static_Context
(Expression
(N
));
4001 end Eval_Unchecked_Conversion
;
4003 --------------------
4004 -- Expr_Rep_Value --
4005 --------------------
4007 function Expr_Rep_Value
(N
: Node_Id
) return Uint
is
4008 Kind
: constant Node_Kind
:= Nkind
(N
);
4012 if Is_Entity_Name
(N
) then
4015 -- An enumeration literal that was either in the source or created
4016 -- as a result of static evaluation.
4018 if Ekind
(Ent
) = E_Enumeration_Literal
then
4019 return Enumeration_Rep
(Ent
);
4021 -- A user defined static constant
4024 pragma Assert
(Ekind
(Ent
) = E_Constant
);
4025 return Expr_Rep_Value
(Constant_Value
(Ent
));
4028 -- An integer literal that was either in the source or created as a
4029 -- result of static evaluation.
4031 elsif Kind
= N_Integer_Literal
then
4034 -- A real literal for a fixed-point type. This must be the fixed-point
4035 -- case, either the literal is of a fixed-point type, or it is a bound
4036 -- of a fixed-point type, with type universal real. In either case we
4037 -- obtain the desired value from Corresponding_Integer_Value.
4039 elsif Kind
= N_Real_Literal
then
4040 pragma Assert
(Is_Fixed_Point_Type
(Underlying_Type
(Etype
(N
))));
4041 return Corresponding_Integer_Value
(N
);
4043 -- Otherwise must be character literal
4046 pragma Assert
(Kind
= N_Character_Literal
);
4049 -- Since Character literals of type Standard.Character don't have any
4050 -- defining character literals built for them, they do not have their
4051 -- Entity set, so just use their Char code. Otherwise for user-
4052 -- defined character literals use their Pos value as usual which is
4053 -- the same as the Rep value.
4056 return Char_Literal_Value
(N
);
4058 return Enumeration_Rep
(Ent
);
4067 function Expr_Value
(N
: Node_Id
) return Uint
is
4068 Kind
: constant Node_Kind
:= Nkind
(N
);
4069 CV_Ent
: CV_Entry
renames CV_Cache
(Nat
(N
) mod CV_Cache_Size
);
4074 -- If already in cache, then we know it's compile time known and we can
4075 -- return the value that was previously stored in the cache since
4076 -- compile time known values cannot change.
4078 if CV_Ent
.N
= N
then
4082 -- Otherwise proceed to test value
4084 if Is_Entity_Name
(N
) then
4087 -- An enumeration literal that was either in the source or created as
4088 -- a result of static evaluation.
4090 if Ekind
(Ent
) = E_Enumeration_Literal
then
4091 Val
:= Enumeration_Pos
(Ent
);
4093 -- A user defined static constant
4096 pragma Assert
(Ekind
(Ent
) = E_Constant
);
4097 Val
:= Expr_Value
(Constant_Value
(Ent
));
4100 -- An integer literal that was either in the source or created as a
4101 -- result of static evaluation.
4103 elsif Kind
= N_Integer_Literal
then
4106 -- A real literal for a fixed-point type. This must be the fixed-point
4107 -- case, either the literal is of a fixed-point type, or it is a bound
4108 -- of a fixed-point type, with type universal real. In either case we
4109 -- obtain the desired value from Corresponding_Integer_Value.
4111 elsif Kind
= N_Real_Literal
then
4112 pragma Assert
(Is_Fixed_Point_Type
(Underlying_Type
(Etype
(N
))));
4113 Val
:= Corresponding_Integer_Value
(N
);
4115 -- Otherwise must be character literal
4118 pragma Assert
(Kind
= N_Character_Literal
);
4121 -- Since Character literals of type Standard.Character don't
4122 -- have any defining character literals built for them, they
4123 -- do not have their Entity set, so just use their Char
4124 -- code. Otherwise for user-defined character literals use
4125 -- their Pos value as usual.
4128 Val
:= Char_Literal_Value
(N
);
4130 Val
:= Enumeration_Pos
(Ent
);
4134 -- Come here with Val set to value to be returned, set cache
4145 function Expr_Value_E
(N
: Node_Id
) return Entity_Id
is
4146 Ent
: constant Entity_Id
:= Entity
(N
);
4148 if Ekind
(Ent
) = E_Enumeration_Literal
then
4151 pragma Assert
(Ekind
(Ent
) = E_Constant
);
4152 return Expr_Value_E
(Constant_Value
(Ent
));
4160 function Expr_Value_R
(N
: Node_Id
) return Ureal
is
4161 Kind
: constant Node_Kind
:= Nkind
(N
);
4165 if Kind
= N_Real_Literal
then
4168 elsif Kind
= N_Identifier
or else Kind
= N_Expanded_Name
then
4170 pragma Assert
(Ekind
(Ent
) = E_Constant
);
4171 return Expr_Value_R
(Constant_Value
(Ent
));
4173 elsif Kind
= N_Integer_Literal
then
4174 return UR_From_Uint
(Expr_Value
(N
));
4176 -- Here, we have a node that cannot be interpreted as a compile time
4177 -- constant. That is definitely an error.
4180 raise Program_Error
;
4188 function Expr_Value_S
(N
: Node_Id
) return Node_Id
is
4190 if Nkind
(N
) = N_String_Literal
then
4193 pragma Assert
(Ekind
(Entity
(N
)) = E_Constant
);
4194 return Expr_Value_S
(Constant_Value
(Entity
(N
)));
4198 ----------------------------------
4199 -- Find_Universal_Operator_Type --
4200 ----------------------------------
4202 function Find_Universal_Operator_Type
(N
: Node_Id
) return Entity_Id
is
4203 PN
: constant Node_Id
:= Parent
(N
);
4204 Call
: constant Node_Id
:= Original_Node
(N
);
4205 Is_Int
: constant Boolean := Is_Integer_Type
(Etype
(N
));
4207 Is_Fix
: constant Boolean :=
4208 Nkind
(N
) in N_Binary_Op
4209 and then Nkind
(Right_Opnd
(N
)) /= Nkind
(Left_Opnd
(N
));
4210 -- A mixed-mode operation in this context indicates the presence of
4211 -- fixed-point type in the designated package.
4213 Is_Relational
: constant Boolean := Etype
(N
) = Standard_Boolean
;
4214 -- Case where N is a relational (or membership) operator (else it is an
4217 In_Membership
: constant Boolean :=
4218 Nkind
(PN
) in N_Membership_Test
4220 Nkind
(Right_Opnd
(PN
)) = N_Range
4222 Is_Universal_Numeric_Type
(Etype
(Left_Opnd
(PN
)))
4224 Is_Universal_Numeric_Type
4225 (Etype
(Low_Bound
(Right_Opnd
(PN
))))
4227 Is_Universal_Numeric_Type
4228 (Etype
(High_Bound
(Right_Opnd
(PN
))));
4229 -- Case where N is part of a membership test with a universal range
4233 Typ1
: Entity_Id
:= Empty
;
4236 function Is_Mixed_Mode_Operand
(Op
: Node_Id
) return Boolean;
4237 -- Check whether one operand is a mixed-mode operation that requires the
4238 -- presence of a fixed-point type. Given that all operands are universal
4239 -- and have been constant-folded, retrieve the original function call.
4241 ---------------------------
4242 -- Is_Mixed_Mode_Operand --
4243 ---------------------------
4245 function Is_Mixed_Mode_Operand
(Op
: Node_Id
) return Boolean is
4246 Onod
: constant Node_Id
:= Original_Node
(Op
);
4248 return Nkind
(Onod
) = N_Function_Call
4249 and then Present
(Next_Actual
(First_Actual
(Onod
)))
4250 and then Etype
(First_Actual
(Onod
)) /=
4251 Etype
(Next_Actual
(First_Actual
(Onod
)));
4252 end Is_Mixed_Mode_Operand
;
4254 -- Start of processing for Find_Universal_Operator_Type
4257 if Nkind
(Call
) /= N_Function_Call
4258 or else Nkind
(Name
(Call
)) /= N_Expanded_Name
4262 -- There are several cases where the context does not imply the type of
4264 -- - the universal expression appears in a type conversion;
4265 -- - the expression is a relational operator applied to universal
4267 -- - the expression is a membership test with a universal operand
4268 -- and a range with universal bounds.
4270 elsif Nkind
(Parent
(N
)) = N_Type_Conversion
4271 or else Is_Relational
4272 or else In_Membership
4274 Pack
:= Entity
(Prefix
(Name
(Call
)));
4276 -- If the prefix is a package declared elsewhere, iterate over its
4277 -- visible entities, otherwise iterate over all declarations in the
4278 -- designated scope.
4280 if Ekind
(Pack
) = E_Package
4281 and then not In_Open_Scopes
(Pack
)
4283 Priv_E
:= First_Private_Entity
(Pack
);
4289 E
:= First_Entity
(Pack
);
4290 while Present
(E
) and then E
/= Priv_E
loop
4291 if Is_Numeric_Type
(E
)
4292 and then Nkind
(Parent
(E
)) /= N_Subtype_Declaration
4293 and then Comes_From_Source
(E
)
4294 and then Is_Integer_Type
(E
) = Is_Int
4295 and then (Nkind
(N
) in N_Unary_Op
4296 or else Is_Relational
4297 or else Is_Fixed_Point_Type
(E
) = Is_Fix
)
4302 -- Before emitting an error, check for the presence of a
4303 -- mixed-mode operation that specifies a fixed point type.
4307 (Is_Mixed_Mode_Operand
(Left_Opnd
(N
))
4308 or else Is_Mixed_Mode_Operand
(Right_Opnd
(N
)))
4309 and then Is_Fixed_Point_Type
(E
) /= Is_Fixed_Point_Type
(Typ1
)
4312 if Is_Fixed_Point_Type
(E
) then
4317 -- More than one type of the proper class declared in P
4319 Error_Msg_N
("ambiguous operation", N
);
4320 Error_Msg_Sloc
:= Sloc
(Typ1
);
4321 Error_Msg_N
("\possible interpretation (inherited)#", N
);
4322 Error_Msg_Sloc
:= Sloc
(E
);
4323 Error_Msg_N
("\possible interpretation (inherited)#", N
);
4333 end Find_Universal_Operator_Type
;
4335 --------------------------
4336 -- Flag_Non_Static_Expr --
4337 --------------------------
4339 procedure Flag_Non_Static_Expr
(Msg
: String; Expr
: Node_Id
) is
4341 if Error_Posted
(Expr
) and then not All_Errors_Mode
then
4344 Error_Msg_F
(Msg
, Expr
);
4345 Why_Not_Static
(Expr
);
4347 end Flag_Non_Static_Expr
;
4353 procedure Fold_Str
(N
: Node_Id
; Val
: String_Id
; Static
: Boolean) is
4354 Loc
: constant Source_Ptr
:= Sloc
(N
);
4355 Typ
: constant Entity_Id
:= Etype
(N
);
4358 if Raises_Constraint_Error
(N
) then
4359 Set_Is_Static_Expression
(N
, Static
);
4363 Rewrite
(N
, Make_String_Literal
(Loc
, Strval
=> Val
));
4365 -- We now have the literal with the right value, both the actual type
4366 -- and the expected type of this literal are taken from the expression
4367 -- that was evaluated. So now we do the Analyze and Resolve.
4369 -- Note that we have to reset Is_Static_Expression both after the
4370 -- analyze step (because Resolve will evaluate the literal, which
4371 -- will cause semantic errors if it is marked as static), and after
4372 -- the Resolve step (since Resolve in some cases resets this flag).
4375 Set_Is_Static_Expression
(N
, Static
);
4378 Set_Is_Static_Expression
(N
, Static
);
4385 procedure Fold_Uint
(N
: Node_Id
; Val
: Uint
; Static
: Boolean) is
4386 Loc
: constant Source_Ptr
:= Sloc
(N
);
4387 Typ
: Entity_Id
:= Etype
(N
);
4391 if Raises_Constraint_Error
(N
) then
4392 Set_Is_Static_Expression
(N
, Static
);
4396 -- If we are folding a named number, retain the entity in the literal,
4399 if Is_Entity_Name
(N
) and then Ekind
(Entity
(N
)) = E_Named_Integer
then
4405 if Is_Private_Type
(Typ
) then
4406 Typ
:= Full_View
(Typ
);
4409 -- For a result of type integer, substitute an N_Integer_Literal node
4410 -- for the result of the compile time evaluation of the expression.
4411 -- For ASIS use, set a link to the original named number when not in
4412 -- a generic context.
4414 if Is_Integer_Type
(Typ
) then
4415 Rewrite
(N
, Make_Integer_Literal
(Loc
, Val
));
4416 Set_Original_Entity
(N
, Ent
);
4418 -- Otherwise we have an enumeration type, and we substitute either
4419 -- an N_Identifier or N_Character_Literal to represent the enumeration
4420 -- literal corresponding to the given value, which must always be in
4421 -- range, because appropriate tests have already been made for this.
4423 else pragma Assert
(Is_Enumeration_Type
(Typ
));
4424 Rewrite
(N
, Get_Enum_Lit_From_Pos
(Etype
(N
), Val
, Loc
));
4427 -- We now have the literal with the right value, both the actual type
4428 -- and the expected type of this literal are taken from the expression
4429 -- that was evaluated. So now we do the Analyze and Resolve.
4431 -- Note that we have to reset Is_Static_Expression both after the
4432 -- analyze step (because Resolve will evaluate the literal, which
4433 -- will cause semantic errors if it is marked as static), and after
4434 -- the Resolve step (since Resolve in some cases sets this flag).
4437 Set_Is_Static_Expression
(N
, Static
);
4440 Set_Is_Static_Expression
(N
, Static
);
4447 procedure Fold_Ureal
(N
: Node_Id
; Val
: Ureal
; Static
: Boolean) is
4448 Loc
: constant Source_Ptr
:= Sloc
(N
);
4449 Typ
: constant Entity_Id
:= Etype
(N
);
4453 if Raises_Constraint_Error
(N
) then
4454 Set_Is_Static_Expression
(N
, Static
);
4458 -- If we are folding a named number, retain the entity in the literal,
4461 if Is_Entity_Name
(N
) and then Ekind
(Entity
(N
)) = E_Named_Real
then
4467 Rewrite
(N
, Make_Real_Literal
(Loc
, Realval
=> Val
));
4469 -- Set link to original named number, for ASIS use
4471 Set_Original_Entity
(N
, Ent
);
4473 -- We now have the literal with the right value, both the actual type
4474 -- and the expected type of this literal are taken from the expression
4475 -- that was evaluated. So now we do the Analyze and Resolve.
4477 -- Note that we have to reset Is_Static_Expression both after the
4478 -- analyze step (because Resolve will evaluate the literal, which
4479 -- will cause semantic errors if it is marked as static), and after
4480 -- the Resolve step (since Resolve in some cases sets this flag).
4483 Set_Is_Static_Expression
(N
, Static
);
4486 Set_Is_Static_Expression
(N
, Static
);
4493 function From_Bits
(B
: Bits
; T
: Entity_Id
) return Uint
is
4497 for J
in 0 .. B
'Last loop
4503 if Non_Binary_Modulus
(T
) then
4504 V
:= V
mod Modulus
(T
);
4510 --------------------
4511 -- Get_String_Val --
4512 --------------------
4514 function Get_String_Val
(N
: Node_Id
) return Node_Id
is
4516 if Nkind_In
(N
, N_String_Literal
, N_Character_Literal
) then
4519 pragma Assert
(Is_Entity_Name
(N
));
4520 return Get_String_Val
(Constant_Value
(Entity
(N
)));
4528 procedure Initialize
is
4530 CV_Cache
:= (others => (Node_High_Bound
, Uint_0
));
4533 --------------------
4534 -- In_Subrange_Of --
4535 --------------------
4537 function In_Subrange_Of
4540 Fixed_Int
: Boolean := False) return Boolean
4549 if T1
= T2
or else Is_Subtype_Of
(T1
, T2
) then
4552 -- Never in range if both types are not scalar. Don't know if this can
4553 -- actually happen, but just in case.
4555 elsif not Is_Scalar_Type
(T1
) or else not Is_Scalar_Type
(T2
) then
4558 -- If T1 has infinities but T2 doesn't have infinities, then T1 is
4559 -- definitely not compatible with T2.
4561 elsif Is_Floating_Point_Type
(T1
)
4562 and then Has_Infinities
(T1
)
4563 and then Is_Floating_Point_Type
(T2
)
4564 and then not Has_Infinities
(T2
)
4569 L1
:= Type_Low_Bound
(T1
);
4570 H1
:= Type_High_Bound
(T1
);
4572 L2
:= Type_Low_Bound
(T2
);
4573 H2
:= Type_High_Bound
(T2
);
4575 -- Check bounds to see if comparison possible at compile time
4577 if Compile_Time_Compare
(L1
, L2
, Assume_Valid
=> True) in Compare_GE
4579 Compile_Time_Compare
(H1
, H2
, Assume_Valid
=> True) in Compare_LE
4584 -- If bounds not comparable at compile time, then the bounds of T2
4585 -- must be compile time known or we cannot answer the query.
4587 if not Compile_Time_Known_Value
(L2
)
4588 or else not Compile_Time_Known_Value
(H2
)
4593 -- If the bounds of T1 are know at compile time then use these
4594 -- ones, otherwise use the bounds of the base type (which are of
4595 -- course always static).
4597 if not Compile_Time_Known_Value
(L1
) then
4598 L1
:= Type_Low_Bound
(Base_Type
(T1
));
4601 if not Compile_Time_Known_Value
(H1
) then
4602 H1
:= Type_High_Bound
(Base_Type
(T1
));
4605 -- Fixed point types should be considered as such only if
4606 -- flag Fixed_Int is set to False.
4608 if Is_Floating_Point_Type
(T1
) or else Is_Floating_Point_Type
(T2
)
4609 or else (Is_Fixed_Point_Type
(T1
) and then not Fixed_Int
)
4610 or else (Is_Fixed_Point_Type
(T2
) and then not Fixed_Int
)
4613 Expr_Value_R
(L2
) <= Expr_Value_R
(L1
)
4615 Expr_Value_R
(H2
) >= Expr_Value_R
(H1
);
4619 Expr_Value
(L2
) <= Expr_Value
(L1
)
4621 Expr_Value
(H2
) >= Expr_Value
(H1
);
4626 -- If any exception occurs, it means that we have some bug in the compiler
4627 -- possibly triggered by a previous error, or by some unforeseen peculiar
4628 -- occurrence. However, this is only an optimization attempt, so there is
4629 -- really no point in crashing the compiler. Instead we just decide, too
4630 -- bad, we can't figure out the answer in this case after all.
4635 -- Debug flag K disables this behavior (useful for debugging)
4637 if Debug_Flag_K
then
4648 function Is_In_Range
4651 Assume_Valid
: Boolean := False;
4652 Fixed_Int
: Boolean := False;
4653 Int_Real
: Boolean := False) return Boolean
4657 Test_In_Range
(N
, Typ
, Assume_Valid
, Fixed_Int
, Int_Real
) = In_Range
;
4664 function Is_Null_Range
(Lo
: Node_Id
; Hi
: Node_Id
) return Boolean is
4665 Typ
: constant Entity_Id
:= Etype
(Lo
);
4668 if not Compile_Time_Known_Value
(Lo
)
4669 or else not Compile_Time_Known_Value
(Hi
)
4674 if Is_Discrete_Type
(Typ
) then
4675 return Expr_Value
(Lo
) > Expr_Value
(Hi
);
4676 else pragma Assert
(Is_Real_Type
(Typ
));
4677 return Expr_Value_R
(Lo
) > Expr_Value_R
(Hi
);
4681 -------------------------
4682 -- Is_OK_Static_Choice --
4683 -------------------------
4685 function Is_OK_Static_Choice
(Choice
: Node_Id
) return Boolean is
4687 -- Check various possibilities for choice
4689 -- Note: for membership tests, we test more cases than are possible
4690 -- (in particular subtype indication), but it doesn't matter because
4691 -- it just won't occur (we have already done a syntax check).
4693 if Nkind
(Choice
) = N_Others_Choice
then
4696 elsif Nkind
(Choice
) = N_Range
then
4697 return Is_OK_Static_Range
(Choice
);
4699 elsif Nkind
(Choice
) = N_Subtype_Indication
4701 (Is_Entity_Name
(Choice
) and then Is_Type
(Entity
(Choice
)))
4703 return Is_OK_Static_Subtype
(Etype
(Choice
));
4706 return Is_OK_Static_Expression
(Choice
);
4708 end Is_OK_Static_Choice
;
4710 ------------------------------
4711 -- Is_OK_Static_Choice_List --
4712 ------------------------------
4714 function Is_OK_Static_Choice_List
(Choices
: List_Id
) return Boolean is
4718 if not Is_Static_Choice_List
(Choices
) then
4722 Choice
:= First
(Choices
);
4723 while Present
(Choice
) loop
4724 if not Is_OK_Static_Choice
(Choice
) then
4725 Set_Raises_Constraint_Error
(Choice
);
4733 end Is_OK_Static_Choice_List
;
4735 -----------------------------
4736 -- Is_OK_Static_Expression --
4737 -----------------------------
4739 function Is_OK_Static_Expression
(N
: Node_Id
) return Boolean is
4741 return Is_Static_Expression
(N
) and then not Raises_Constraint_Error
(N
);
4742 end Is_OK_Static_Expression
;
4744 ------------------------
4745 -- Is_OK_Static_Range --
4746 ------------------------
4748 -- A static range is a range whose bounds are static expressions, or a
4749 -- Range_Attribute_Reference equivalent to such a range (RM 4.9(26)).
4750 -- We have already converted range attribute references, so we get the
4751 -- "or" part of this rule without needing a special test.
4753 function Is_OK_Static_Range
(N
: Node_Id
) return Boolean is
4755 return Is_OK_Static_Expression
(Low_Bound
(N
))
4756 and then Is_OK_Static_Expression
(High_Bound
(N
));
4757 end Is_OK_Static_Range
;
4759 --------------------------
4760 -- Is_OK_Static_Subtype --
4761 --------------------------
4763 -- Determines if Typ is a static subtype as defined in (RM 4.9(26)) where
4764 -- neither bound raises constraint error when evaluated.
4766 function Is_OK_Static_Subtype
(Typ
: Entity_Id
) return Boolean is
4767 Base_T
: constant Entity_Id
:= Base_Type
(Typ
);
4768 Anc_Subt
: Entity_Id
;
4771 -- First a quick check on the non static subtype flag. As described
4772 -- in further detail in Einfo, this flag is not decisive in all cases,
4773 -- but if it is set, then the subtype is definitely non-static.
4775 if Is_Non_Static_Subtype
(Typ
) then
4779 Anc_Subt
:= Ancestor_Subtype
(Typ
);
4781 if Anc_Subt
= Empty
then
4785 if Is_Generic_Type
(Root_Type
(Base_T
))
4786 or else Is_Generic_Actual_Type
(Base_T
)
4792 elsif Is_String_Type
(Typ
) then
4794 Ekind
(Typ
) = E_String_Literal_Subtype
4796 (Is_OK_Static_Subtype
(Component_Type
(Typ
))
4797 and then Is_OK_Static_Subtype
(Etype
(First_Index
(Typ
))));
4801 elsif Is_Scalar_Type
(Typ
) then
4802 if Base_T
= Typ
then
4806 -- Scalar_Range (Typ) might be an N_Subtype_Indication, so use
4807 -- Get_Type_{Low,High}_Bound.
4809 return Is_OK_Static_Subtype
(Anc_Subt
)
4810 and then Is_OK_Static_Expression
(Type_Low_Bound
(Typ
))
4811 and then Is_OK_Static_Expression
(Type_High_Bound
(Typ
));
4814 -- Types other than string and scalar types are never static
4819 end Is_OK_Static_Subtype
;
4821 ---------------------
4822 -- Is_Out_Of_Range --
4823 ---------------------
4825 function Is_Out_Of_Range
4828 Assume_Valid
: Boolean := False;
4829 Fixed_Int
: Boolean := False;
4830 Int_Real
: Boolean := False) return Boolean
4833 return Test_In_Range
(N
, Typ
, Assume_Valid
, Fixed_Int
, Int_Real
) =
4835 end Is_Out_Of_Range
;
4837 ----------------------
4838 -- Is_Static_Choice --
4839 ----------------------
4841 function Is_Static_Choice
(Choice
: Node_Id
) return Boolean is
4843 -- Check various possibilities for choice
4845 -- Note: for membership tests, we test more cases than are possible
4846 -- (in particular subtype indication), but it doesn't matter because
4847 -- it just won't occur (we have already done a syntax check).
4849 if Nkind
(Choice
) = N_Others_Choice
then
4852 elsif Nkind
(Choice
) = N_Range
then
4853 return Is_Static_Range
(Choice
);
4855 elsif Nkind
(Choice
) = N_Subtype_Indication
4857 (Is_Entity_Name
(Choice
) and then Is_Type
(Entity
(Choice
)))
4859 return Is_Static_Subtype
(Etype
(Choice
));
4862 return Is_Static_Expression
(Choice
);
4864 end Is_Static_Choice
;
4866 ---------------------------
4867 -- Is_Static_Choice_List --
4868 ---------------------------
4870 function Is_Static_Choice_List
(Choices
: List_Id
) return Boolean is
4874 Choice
:= First
(Choices
);
4875 while Present
(Choice
) loop
4876 if not Is_Static_Choice
(Choice
) then
4884 end Is_Static_Choice_List
;
4886 ---------------------
4887 -- Is_Static_Range --
4888 ---------------------
4890 -- A static range is a range whose bounds are static expressions, or a
4891 -- Range_Attribute_Reference equivalent to such a range (RM 4.9(26)).
4892 -- We have already converted range attribute references, so we get the
4893 -- "or" part of this rule without needing a special test.
4895 function Is_Static_Range
(N
: Node_Id
) return Boolean is
4897 return Is_Static_Expression
(Low_Bound
(N
))
4899 Is_Static_Expression
(High_Bound
(N
));
4900 end Is_Static_Range
;
4902 -----------------------
4903 -- Is_Static_Subtype --
4904 -----------------------
4906 -- Determines if Typ is a static subtype as defined in (RM 4.9(26))
4908 function Is_Static_Subtype
(Typ
: Entity_Id
) return Boolean is
4909 Base_T
: constant Entity_Id
:= Base_Type
(Typ
);
4910 Anc_Subt
: Entity_Id
;
4913 -- First a quick check on the non static subtype flag. As described
4914 -- in further detail in Einfo, this flag is not decisive in all cases,
4915 -- but if it is set, then the subtype is definitely non-static.
4917 if Is_Non_Static_Subtype
(Typ
) then
4921 Anc_Subt
:= Ancestor_Subtype
(Typ
);
4923 if Anc_Subt
= Empty
then
4927 if Is_Generic_Type
(Root_Type
(Base_T
))
4928 or else Is_Generic_Actual_Type
(Base_T
)
4934 elsif Is_String_Type
(Typ
) then
4936 Ekind
(Typ
) = E_String_Literal_Subtype
4937 or else (Is_Static_Subtype
(Component_Type
(Typ
))
4938 and then Is_Static_Subtype
(Etype
(First_Index
(Typ
))));
4942 elsif Is_Scalar_Type
(Typ
) then
4943 if Base_T
= Typ
then
4947 return Is_Static_Subtype
(Anc_Subt
)
4948 and then Is_Static_Expression
(Type_Low_Bound
(Typ
))
4949 and then Is_Static_Expression
(Type_High_Bound
(Typ
));
4952 -- Types other than string and scalar types are never static
4957 end Is_Static_Subtype
;
4959 -------------------------------
4960 -- Is_Statically_Unevaluated --
4961 -------------------------------
4963 function Is_Statically_Unevaluated
(Expr
: Node_Id
) return Boolean is
4964 function Check_Case_Expr_Alternative
4965 (CEA
: Node_Id
) return Match_Result
;
4966 -- We have a message emanating from the Expression of a case expression
4967 -- alternative. We examine this alternative, as follows:
4969 -- If the selecting expression of the parent case is non-static, or
4970 -- if any of the discrete choices of the given case alternative are
4971 -- non-static or raise Constraint_Error, return Non_Static.
4973 -- Otherwise check if the selecting expression matches any of the given
4974 -- discrete choices. If so, the alternative is executed and we return
4975 -- Match, otherwise, the alternative can never be executed, and so we
4978 ---------------------------------
4979 -- Check_Case_Expr_Alternative --
4980 ---------------------------------
4982 function Check_Case_Expr_Alternative
4983 (CEA
: Node_Id
) return Match_Result
4985 Case_Exp
: constant Node_Id
:= Parent
(CEA
);
4990 pragma Assert
(Nkind
(Case_Exp
) = N_Case_Expression
);
4992 -- Check that selecting expression is static
4994 if not Is_OK_Static_Expression
(Expression
(Case_Exp
)) then
4998 if not Is_OK_Static_Choice_List
(Discrete_Choices
(CEA
)) then
5002 -- All choices are now known to be static. Now see if alternative
5003 -- matches one of the choices.
5005 Choice
:= First
(Discrete_Choices
(CEA
));
5006 while Present
(Choice
) loop
5008 -- Check various possibilities for choice, returning Match if we
5009 -- find the selecting value matches any of the choices. Note that
5010 -- we know we are the last choice, so we don't have to keep going.
5012 if Nkind
(Choice
) = N_Others_Choice
then
5014 -- Others choice is a bit annoying, it matches if none of the
5015 -- previous alternatives matches (note that we know we are the
5016 -- last alternative in this case, so we can just go backwards
5017 -- from us to see if any previous one matches).
5019 Prev_CEA
:= Prev
(CEA
);
5020 while Present
(Prev_CEA
) loop
5021 if Check_Case_Expr_Alternative
(Prev_CEA
) = Match
then
5030 -- Else we have a normal static choice
5032 elsif Choice_Matches
(Expression
(Case_Exp
), Choice
) = Match
then
5036 -- If we fall through, it means that the discrete choice did not
5037 -- match the selecting expression, so continue.
5042 -- If we get through that loop then all choices were static, and none
5043 -- of them matched the selecting expression. So return No_Match.
5046 end Check_Case_Expr_Alternative
;
5054 -- Start of processing for Is_Statically_Unevaluated
5057 -- The (32.x) references here are from RM section 4.9
5059 -- (32.1) An expression is statically unevaluated if it is part of ...
5061 -- This means we have to climb the tree looking for one of the cases
5068 -- (32.2) The right operand of a static short-circuit control form
5069 -- whose value is determined by its left operand.
5071 -- AND THEN with False as left operand
5073 if Nkind
(P
) = N_And_Then
5074 and then Compile_Time_Known_Value
(Left_Opnd
(P
))
5075 and then Is_False
(Expr_Value
(Left_Opnd
(P
)))
5079 -- OR ELSE with True as left operand
5081 elsif Nkind
(P
) = N_Or_Else
5082 and then Compile_Time_Known_Value
(Left_Opnd
(P
))
5083 and then Is_True
(Expr_Value
(Left_Opnd
(P
)))
5087 -- (32.3) A dependent_expression of an if_expression whose associated
5088 -- condition is static and equals False.
5090 elsif Nkind
(P
) = N_If_Expression
then
5092 Cond
: constant Node_Id
:= First
(Expressions
(P
));
5093 Texp
: constant Node_Id
:= Next
(Cond
);
5094 Fexp
: constant Node_Id
:= Next
(Texp
);
5097 if Compile_Time_Known_Value
(Cond
) then
5099 -- Condition is True and we are in the right operand
5101 if Is_True
(Expr_Value
(Cond
)) and then OldP
= Fexp
then
5104 -- Condition is False and we are in the left operand
5106 elsif Is_False
(Expr_Value
(Cond
)) and then OldP
= Texp
then
5112 -- (32.4) A condition or dependent_expression of an if_expression
5113 -- where the condition corresponding to at least one preceding
5114 -- dependent_expression of the if_expression is static and equals
5117 -- This refers to cases like
5119 -- (if True then 1 elsif 1/0=2 then 2 else 3)
5121 -- But we expand elsif's out anyway, so the above looks like:
5123 -- (if True then 1 else (if 1/0=2 then 2 else 3))
5125 -- So for us this is caught by the above check for the 32.3 case.
5127 -- (32.5) A dependent_expression of a case_expression whose
5128 -- selecting_expression is static and whose value is not covered
5129 -- by the corresponding discrete_choice_list.
5131 elsif Nkind
(P
) = N_Case_Expression_Alternative
then
5133 -- First, we have to be in the expression to suppress messages.
5134 -- If we are within one of the choices, we want the message.
5136 if OldP
= Expression
(P
) then
5138 -- Statically unevaluated if alternative does not match
5140 if Check_Case_Expr_Alternative
(P
) = No_Match
then
5145 -- (32.6) A choice_expression (or a simple_expression of a range
5146 -- that occurs as a membership_choice of a membership_choice_list)
5147 -- of a static membership test that is preceded in the enclosing
5148 -- membership_choice_list by another item whose individual
5149 -- membership test (see (RM 4.5.2)) statically yields True.
5151 elsif Nkind
(P
) in N_Membership_Test
then
5153 -- Only possibly unevaluated if simple expression is static
5155 if not Is_OK_Static_Expression
(Left_Opnd
(P
)) then
5158 -- All members of the choice list must be static
5160 elsif (Present
(Right_Opnd
(P
))
5161 and then not Is_OK_Static_Choice
(Right_Opnd
(P
)))
5162 or else (Present
(Alternatives
(P
))
5164 not Is_OK_Static_Choice_List
(Alternatives
(P
)))
5168 -- If expression is the one and only alternative, then it is
5169 -- definitely not statically unevaluated, so we only have to
5170 -- test the case where there are alternatives present.
5172 elsif Present
(Alternatives
(P
)) then
5174 -- Look for previous matching Choice
5176 Choice
:= First
(Alternatives
(P
));
5177 while Present
(Choice
) loop
5179 -- If we reached us and no previous choices matched, this
5180 -- is not the case where we are statically unevaluated.
5182 exit when OldP
= Choice
;
5184 -- If a previous choice matches, then that is the case where
5185 -- we know our choice is statically unevaluated.
5187 if Choice_Matches
(Left_Opnd
(P
), Choice
) = Match
then
5194 -- If we fall through the loop, we were not one of the choices,
5195 -- we must have been the expression, so that is not covered by
5196 -- this rule, and we keep going.
5202 -- OK, not statically unevaluated at this level, see if we should
5203 -- keep climbing to look for a higher level reason.
5205 -- Special case for component association in aggregates, where
5206 -- we want to keep climbing up to the parent aggregate.
5208 if Nkind
(P
) = N_Component_Association
5209 and then Nkind
(Parent
(P
)) = N_Aggregate
5213 -- All done if not still within subexpression
5216 exit when Nkind
(P
) not in N_Subexpr
;
5220 -- If we fall through the loop, not one of the cases covered!
5223 end Is_Statically_Unevaluated
;
5225 --------------------
5226 -- Not_Null_Range --
5227 --------------------
5229 function Not_Null_Range
(Lo
: Node_Id
; Hi
: Node_Id
) return Boolean is
5230 Typ
: constant Entity_Id
:= Etype
(Lo
);
5233 if not Compile_Time_Known_Value
(Lo
)
5234 or else not Compile_Time_Known_Value
(Hi
)
5239 if Is_Discrete_Type
(Typ
) then
5240 return Expr_Value
(Lo
) <= Expr_Value
(Hi
);
5241 else pragma Assert
(Is_Real_Type
(Typ
));
5242 return Expr_Value_R
(Lo
) <= Expr_Value_R
(Hi
);
5250 function OK_Bits
(N
: Node_Id
; Bits
: Uint
) return Boolean is
5252 -- We allow a maximum of 500,000 bits which seems a reasonable limit
5254 if Bits
< 500_000
then
5257 -- Error if this maximum is exceeded
5260 Error_Msg_N
("static value too large, capacity exceeded", N
);
5269 procedure Out_Of_Range
(N
: Node_Id
) is
5271 -- If we have the static expression case, then this is an illegality
5272 -- in Ada 95 mode, except that in an instance, we never generate an
5273 -- error (if the error is legitimate, it was already diagnosed in the
5276 if Is_Static_Expression
(N
)
5277 and then not In_Instance
5278 and then not In_Inlined_Body
5279 and then Ada_Version
>= Ada_95
5281 -- No message if we are statically unevaluated
5283 if Is_Statically_Unevaluated
(N
) then
5286 -- The expression to compute the length of a packed array is attached
5287 -- to the array type itself, and deserves a separate message.
5289 elsif Nkind
(Parent
(N
)) = N_Defining_Identifier
5290 and then Is_Array_Type
(Parent
(N
))
5291 and then Present
(Packed_Array_Impl_Type
(Parent
(N
)))
5292 and then Present
(First_Rep_Item
(Parent
(N
)))
5295 ("length of packed array must not exceed Integer''Last",
5296 First_Rep_Item
(Parent
(N
)));
5297 Rewrite
(N
, Make_Integer_Literal
(Sloc
(N
), Uint_1
));
5299 -- All cases except the special array case
5302 Apply_Compile_Time_Constraint_Error
5303 (N
, "value not in range of}", CE_Range_Check_Failed
);
5306 -- Here we generate a warning for the Ada 83 case, or when we are in an
5307 -- instance, or when we have a non-static expression case.
5310 Apply_Compile_Time_Constraint_Error
5311 (N
, "value not in range of}??", CE_Range_Check_Failed
);
5315 ----------------------
5316 -- Predicates_Match --
5317 ----------------------
5319 function Predicates_Match
(T1
, T2
: Entity_Id
) return Boolean is
5324 if Ada_Version
< Ada_2012
then
5327 -- Both types must have predicates or lack them
5329 elsif Has_Predicates
(T1
) /= Has_Predicates
(T2
) then
5332 -- Check matching predicates
5337 (T1
, Name_Static_Predicate
, Check_Parents
=> False);
5340 (T2
, Name_Static_Predicate
, Check_Parents
=> False);
5342 -- Subtypes statically match if the predicate comes from the
5343 -- same declaration, which can only happen if one is a subtype
5344 -- of the other and has no explicit predicate.
5346 -- Suppress warnings on order of actuals, which is otherwise
5347 -- triggered by one of the two calls below.
5349 pragma Warnings
(Off
);
5350 return Pred1
= Pred2
5351 or else (No
(Pred1
) and then Is_Subtype_Of
(T1
, T2
))
5352 or else (No
(Pred2
) and then Is_Subtype_Of
(T2
, T1
));
5353 pragma Warnings
(On
);
5355 end Predicates_Match
;
5357 ---------------------------------------------
5358 -- Real_Or_String_Static_Predicate_Matches --
5359 ---------------------------------------------
5361 function Real_Or_String_Static_Predicate_Matches
5363 Typ
: Entity_Id
) return Boolean
5365 Expr
: constant Node_Id
:= Static_Real_Or_String_Predicate
(Typ
);
5366 -- The predicate expression from the type
5368 Pfun
: constant Entity_Id
:= Predicate_Function
(Typ
);
5369 -- The entity for the predicate function
5371 Ent_Name
: constant Name_Id
:= Chars
(First_Formal
(Pfun
));
5372 -- The name of the formal of the predicate function. Occurrences of the
5373 -- type name in Expr have been rewritten as references to this formal,
5374 -- and it has a unique name, so we can identify references by this name.
5377 -- Copy of the predicate function tree
5379 function Process
(N
: Node_Id
) return Traverse_Result
;
5380 -- Function used to process nodes during the traversal in which we will
5381 -- find occurrences of the entity name, and replace such occurrences
5382 -- by a real literal with the value to be tested.
5384 procedure Traverse
is new Traverse_Proc
(Process
);
5385 -- The actual traversal procedure
5391 function Process
(N
: Node_Id
) return Traverse_Result
is
5393 if Nkind
(N
) = N_Identifier
and then Chars
(N
) = Ent_Name
then
5395 Nod
: constant Node_Id
:= New_Copy
(Val
);
5397 Set_Sloc
(Nod
, Sloc
(N
));
5407 -- Start of processing for Real_Or_String_Static_Predicate_Matches
5410 -- First deal with special case of inherited predicate, where the
5411 -- predicate expression looks like:
5413 -- xxPredicate (typ (Ent)) and then Expr
5415 -- where Expr is the predicate expression for this level, and the
5416 -- left operand is the call to evaluate the inherited predicate.
5418 if Nkind
(Expr
) = N_And_Then
5419 and then Nkind
(Left_Opnd
(Expr
)) = N_Function_Call
5420 and then Is_Predicate_Function
(Entity
(Name
(Left_Opnd
(Expr
))))
5422 -- OK we have the inherited case, so make a call to evaluate the
5423 -- inherited predicate. If that fails, so do we!
5426 Real_Or_String_Static_Predicate_Matches
5428 Typ
=> Etype
(First_Formal
(Entity
(Name
(Left_Opnd
(Expr
))))))
5433 -- Use the right operand for the continued processing
5435 Copy
:= Copy_Separate_Tree
(Right_Opnd
(Expr
));
5437 -- Case where call to predicate function appears on its own (this means
5438 -- that the predicate at this level is just inherited from the parent).
5440 elsif Nkind
(Expr
) = N_Function_Call
then
5442 Typ
: constant Entity_Id
:=
5443 Etype
(First_Formal
(Entity
(Name
(Expr
))));
5446 -- If the inherited predicate is dynamic, just ignore it. We can't
5447 -- go trying to evaluate a dynamic predicate as a static one!
5449 if Has_Dynamic_Predicate_Aspect
(Typ
) then
5452 -- Otherwise inherited predicate is static, check for match
5455 return Real_Or_String_Static_Predicate_Matches
(Val
, Typ
);
5459 -- If not just an inherited predicate, copy whole expression
5462 Copy
:= Copy_Separate_Tree
(Expr
);
5465 -- Now we replace occurrences of the entity by the value
5469 -- And analyze the resulting static expression to see if it is True
5471 Analyze_And_Resolve
(Copy
, Standard_Boolean
);
5472 return Is_True
(Expr_Value
(Copy
));
5473 end Real_Or_String_Static_Predicate_Matches
;
5475 -------------------------
5476 -- Rewrite_In_Raise_CE --
5477 -------------------------
5479 procedure Rewrite_In_Raise_CE
(N
: Node_Id
; Exp
: Node_Id
) is
5480 Typ
: constant Entity_Id
:= Etype
(N
);
5481 Stat
: constant Boolean := Is_Static_Expression
(N
);
5484 -- If we want to raise CE in the condition of a N_Raise_CE node, we
5485 -- can just clear the condition if the reason is appropriate. We do
5486 -- not do this operation if the parent has a reason other than range
5487 -- check failed, because otherwise we would change the reason.
5489 if Present
(Parent
(N
))
5490 and then Nkind
(Parent
(N
)) = N_Raise_Constraint_Error
5491 and then Reason
(Parent
(N
)) =
5492 UI_From_Int
(RT_Exception_Code
'Pos (CE_Range_Check_Failed
))
5494 Set_Condition
(Parent
(N
), Empty
);
5496 -- Else build an explicit N_Raise_CE
5500 Make_Raise_Constraint_Error
(Sloc
(Exp
),
5501 Reason
=> CE_Range_Check_Failed
));
5502 Set_Raises_Constraint_Error
(N
);
5506 -- Set proper flags in result
5508 Set_Raises_Constraint_Error
(N
, True);
5509 Set_Is_Static_Expression
(N
, Stat
);
5510 end Rewrite_In_Raise_CE
;
5512 ---------------------
5513 -- String_Type_Len --
5514 ---------------------
5516 function String_Type_Len
(Stype
: Entity_Id
) return Uint
is
5517 NT
: constant Entity_Id
:= Etype
(First_Index
(Stype
));
5521 if Is_OK_Static_Subtype
(NT
) then
5524 T
:= Base_Type
(NT
);
5527 return Expr_Value
(Type_High_Bound
(T
)) -
5528 Expr_Value
(Type_Low_Bound
(T
)) + 1;
5529 end String_Type_Len
;
5531 ------------------------------------
5532 -- Subtypes_Statically_Compatible --
5533 ------------------------------------
5535 function Subtypes_Statically_Compatible
5538 Formal_Derived_Matching
: Boolean := False) return Boolean
5543 if Is_Scalar_Type
(T1
) then
5545 -- Definitely compatible if we match
5547 if Subtypes_Statically_Match
(T1
, T2
) then
5550 -- If either subtype is nonstatic then they're not compatible
5552 elsif not Is_OK_Static_Subtype
(T1
)
5554 not Is_OK_Static_Subtype
(T2
)
5558 -- If either type has constraint error bounds, then consider that
5559 -- they match to avoid junk cascaded errors here.
5561 elsif not Is_OK_Static_Subtype
(T1
)
5562 or else not Is_OK_Static_Subtype
(T2
)
5566 -- Base types must match, but we don't check that (should we???) but
5567 -- we do at least check that both types are real, or both types are
5570 elsif Is_Real_Type
(T1
) /= Is_Real_Type
(T2
) then
5573 -- Here we check the bounds
5577 LB1
: constant Node_Id
:= Type_Low_Bound
(T1
);
5578 HB1
: constant Node_Id
:= Type_High_Bound
(T1
);
5579 LB2
: constant Node_Id
:= Type_Low_Bound
(T2
);
5580 HB2
: constant Node_Id
:= Type_High_Bound
(T2
);
5583 if Is_Real_Type
(T1
) then
5585 (Expr_Value_R
(LB1
) > Expr_Value_R
(HB1
))
5587 (Expr_Value_R
(LB2
) <= Expr_Value_R
(LB1
)
5589 Expr_Value_R
(HB1
) <= Expr_Value_R
(HB2
));
5593 (Expr_Value
(LB1
) > Expr_Value
(HB1
))
5595 (Expr_Value
(LB2
) <= Expr_Value
(LB1
)
5597 Expr_Value
(HB1
) <= Expr_Value
(HB2
));
5604 elsif Is_Access_Type
(T1
) then
5605 return (not Is_Constrained
(T2
)
5606 or else (Subtypes_Statically_Match
5607 (Designated_Type
(T1
), Designated_Type
(T2
))))
5608 and then not (Can_Never_Be_Null
(T2
)
5609 and then not Can_Never_Be_Null
(T1
));
5614 return (Is_Composite_Type
(T1
) and then not Is_Constrained
(T2
))
5615 or else Subtypes_Statically_Match
(T1
, T2
, Formal_Derived_Matching
);
5617 end Subtypes_Statically_Compatible
;
5619 -------------------------------
5620 -- Subtypes_Statically_Match --
5621 -------------------------------
5623 -- Subtypes statically match if they have statically matching constraints
5624 -- (RM 4.9.1(2)). Constraints statically match if there are none, or if
5625 -- they are the same identical constraint, or if they are static and the
5626 -- values match (RM 4.9.1(1)).
5628 -- In addition, in GNAT, the object size (Esize) values of the types must
5629 -- match if they are set (unless checking an actual for a formal derived
5630 -- type). The use of 'Object_Size can cause this to be false even if the
5631 -- types would otherwise match in the RM sense.
5633 function Subtypes_Statically_Match
5636 Formal_Derived_Matching
: Boolean := False) return Boolean
5639 -- A type always statically matches itself
5644 -- No match if sizes different (from use of 'Object_Size). This test
5645 -- is excluded if Formal_Derived_Matching is True, as the base types
5646 -- can be different in that case and typically have different sizes
5647 -- (and Esizes can be set when Frontend_Layout_On_Target is True).
5649 elsif not Formal_Derived_Matching
5650 and then Known_Static_Esize
(T1
)
5651 and then Known_Static_Esize
(T2
)
5652 and then Esize
(T1
) /= Esize
(T2
)
5656 -- No match if predicates do not match
5658 elsif not Predicates_Match
(T1
, T2
) then
5663 elsif Is_Scalar_Type
(T1
) then
5665 -- Base types must be the same
5667 if Base_Type
(T1
) /= Base_Type
(T2
) then
5671 -- A constrained numeric subtype never matches an unconstrained
5672 -- subtype, i.e. both types must be constrained or unconstrained.
5674 -- To understand the requirement for this test, see RM 4.9.1(1).
5675 -- As is made clear in RM 3.5.4(11), type Integer, for example is
5676 -- a constrained subtype with constraint bounds matching the bounds
5677 -- of its corresponding unconstrained base type. In this situation,
5678 -- Integer and Integer'Base do not statically match, even though
5679 -- they have the same bounds.
5681 -- We only apply this test to types in Standard and types that appear
5682 -- in user programs. That way, we do not have to be too careful about
5683 -- setting Is_Constrained right for Itypes.
5685 if Is_Numeric_Type
(T1
)
5686 and then (Is_Constrained
(T1
) /= Is_Constrained
(T2
))
5687 and then (Scope
(T1
) = Standard_Standard
5688 or else Comes_From_Source
(T1
))
5689 and then (Scope
(T2
) = Standard_Standard
5690 or else Comes_From_Source
(T2
))
5694 -- A generic scalar type does not statically match its base type
5695 -- (AI-311). In this case we make sure that the formals, which are
5696 -- first subtypes of their bases, are constrained.
5698 elsif Is_Generic_Type
(T1
)
5699 and then Is_Generic_Type
(T2
)
5700 and then (Is_Constrained
(T1
) /= Is_Constrained
(T2
))
5705 -- If there was an error in either range, then just assume the types
5706 -- statically match to avoid further junk errors.
5708 if No
(Scalar_Range
(T1
)) or else No
(Scalar_Range
(T2
))
5709 or else Error_Posted
(Scalar_Range
(T1
))
5710 or else Error_Posted
(Scalar_Range
(T2
))
5715 -- Otherwise both types have bounds that can be compared
5718 LB1
: constant Node_Id
:= Type_Low_Bound
(T1
);
5719 HB1
: constant Node_Id
:= Type_High_Bound
(T1
);
5720 LB2
: constant Node_Id
:= Type_Low_Bound
(T2
);
5721 HB2
: constant Node_Id
:= Type_High_Bound
(T2
);
5724 -- If the bounds are the same tree node, then match (common case)
5726 if LB1
= LB2
and then HB1
= HB2
then
5729 -- Otherwise bounds must be static and identical value
5732 if not Is_OK_Static_Subtype
(T1
)
5733 or else not Is_OK_Static_Subtype
(T2
)
5737 -- If either type has constraint error bounds, then say that
5738 -- they match to avoid junk cascaded errors here.
5740 elsif not Is_OK_Static_Subtype
(T1
)
5741 or else not Is_OK_Static_Subtype
(T2
)
5745 elsif Is_Real_Type
(T1
) then
5747 (Expr_Value_R
(LB1
) = Expr_Value_R
(LB2
))
5749 (Expr_Value_R
(HB1
) = Expr_Value_R
(HB2
));
5753 Expr_Value
(LB1
) = Expr_Value
(LB2
)
5755 Expr_Value
(HB1
) = Expr_Value
(HB2
);
5760 -- Type with discriminants
5762 elsif Has_Discriminants
(T1
) or else Has_Discriminants
(T2
) then
5764 -- Because of view exchanges in multiple instantiations, conformance
5765 -- checking might try to match a partial view of a type with no
5766 -- discriminants with a full view that has defaulted discriminants.
5767 -- In such a case, use the discriminant constraint of the full view,
5768 -- which must exist because we know that the two subtypes have the
5771 if Has_Discriminants
(T1
) /= Has_Discriminants
(T2
) then
5772 -- A generic actual type is declared through a subtype declaration
5773 -- and may have an inconsistent indication of the presence of
5774 -- discriminants, so check the type it renames.
5776 if Is_Generic_Actual_Type
(T1
)
5777 and then not Has_Discriminants
(Etype
(T1
))
5778 and then not Has_Discriminants
(T2
)
5782 elsif In_Instance
then
5783 if Is_Private_Type
(T2
)
5784 and then Present
(Full_View
(T2
))
5785 and then Has_Discriminants
(Full_View
(T2
))
5787 return Subtypes_Statically_Match
(T1
, Full_View
(T2
));
5789 elsif Is_Private_Type
(T1
)
5790 and then Present
(Full_View
(T1
))
5791 and then Has_Discriminants
(Full_View
(T1
))
5793 return Subtypes_Statically_Match
(Full_View
(T1
), T2
);
5804 DL1
: constant Elist_Id
:= Discriminant_Constraint
(T1
);
5805 DL2
: constant Elist_Id
:= Discriminant_Constraint
(T2
);
5813 elsif Is_Constrained
(T1
) /= Is_Constrained
(T2
) then
5817 -- Now loop through the discriminant constraints
5819 -- Note: the guard here seems necessary, since it is possible at
5820 -- least for DL1 to be No_Elist. Not clear this is reasonable ???
5822 if Present
(DL1
) and then Present
(DL2
) then
5823 DA1
:= First_Elmt
(DL1
);
5824 DA2
:= First_Elmt
(DL2
);
5825 while Present
(DA1
) loop
5827 Expr1
: constant Node_Id
:= Node
(DA1
);
5828 Expr2
: constant Node_Id
:= Node
(DA2
);
5831 if not Is_OK_Static_Expression
(Expr1
)
5832 or else not Is_OK_Static_Expression
(Expr2
)
5836 -- If either expression raised a constraint error,
5837 -- consider the expressions as matching, since this
5838 -- helps to prevent cascading errors.
5840 elsif Raises_Constraint_Error
(Expr1
)
5841 or else Raises_Constraint_Error
(Expr2
)
5845 elsif Expr_Value
(Expr1
) /= Expr_Value
(Expr2
) then
5858 -- A definite type does not match an indefinite or classwide type.
5859 -- However, a generic type with unknown discriminants may be
5860 -- instantiated with a type with no discriminants, and conformance
5861 -- checking on an inherited operation may compare the actual with the
5862 -- subtype that renames it in the instance.
5864 elsif Has_Unknown_Discriminants
(T1
) /= Has_Unknown_Discriminants
(T2
)
5867 Is_Generic_Actual_Type
(T1
) or else Is_Generic_Actual_Type
(T2
);
5871 elsif Is_Array_Type
(T1
) then
5873 -- If either subtype is unconstrained then both must be, and if both
5874 -- are unconstrained then no further checking is needed.
5876 if not Is_Constrained
(T1
) or else not Is_Constrained
(T2
) then
5877 return not (Is_Constrained
(T1
) or else Is_Constrained
(T2
));
5880 -- Both subtypes are constrained, so check that the index subtypes
5881 -- statically match.
5884 Index1
: Node_Id
:= First_Index
(T1
);
5885 Index2
: Node_Id
:= First_Index
(T2
);
5888 while Present
(Index1
) loop
5890 Subtypes_Statically_Match
(Etype
(Index1
), Etype
(Index2
))
5895 Next_Index
(Index1
);
5896 Next_Index
(Index2
);
5902 elsif Is_Access_Type
(T1
) then
5903 if Can_Never_Be_Null
(T1
) /= Can_Never_Be_Null
(T2
) then
5906 elsif Ekind_In
(T1
, E_Access_Subprogram_Type
,
5907 E_Anonymous_Access_Subprogram_Type
)
5911 (Designated_Type
(T1
),
5912 Designated_Type
(T2
));
5915 Subtypes_Statically_Match
5916 (Designated_Type
(T1
),
5917 Designated_Type
(T2
))
5918 and then Is_Access_Constant
(T1
) = Is_Access_Constant
(T2
);
5921 -- All other types definitely match
5926 end Subtypes_Statically_Match
;
5932 function Test
(Cond
: Boolean) return Uint
is
5941 ---------------------------------
5942 -- Test_Expression_Is_Foldable --
5943 ---------------------------------
5947 procedure Test_Expression_Is_Foldable
5957 if Debug_Flag_Dot_F
and then In_Extended_Main_Source_Unit
(N
) then
5961 -- If operand is Any_Type, just propagate to result and do not
5962 -- try to fold, this prevents cascaded errors.
5964 if Etype
(Op1
) = Any_Type
then
5965 Set_Etype
(N
, Any_Type
);
5968 -- If operand raises constraint error, then replace node N with the
5969 -- raise constraint error node, and we are obviously not foldable.
5970 -- Note that this replacement inherits the Is_Static_Expression flag
5971 -- from the operand.
5973 elsif Raises_Constraint_Error
(Op1
) then
5974 Rewrite_In_Raise_CE
(N
, Op1
);
5977 -- If the operand is not static, then the result is not static, and
5978 -- all we have to do is to check the operand since it is now known
5979 -- to appear in a non-static context.
5981 elsif not Is_Static_Expression
(Op1
) then
5982 Check_Non_Static_Context
(Op1
);
5983 Fold
:= Compile_Time_Known_Value
(Op1
);
5986 -- An expression of a formal modular type is not foldable because
5987 -- the modulus is unknown.
5989 elsif Is_Modular_Integer_Type
(Etype
(Op1
))
5990 and then Is_Generic_Type
(Etype
(Op1
))
5992 Check_Non_Static_Context
(Op1
);
5995 -- Here we have the case of an operand whose type is OK, which is
5996 -- static, and which does not raise constraint error, we can fold.
5999 Set_Is_Static_Expression
(N
);
6003 end Test_Expression_Is_Foldable
;
6007 procedure Test_Expression_Is_Foldable
6013 CRT_Safe
: Boolean := False)
6015 Rstat
: constant Boolean := Is_Static_Expression
(Op1
)
6017 Is_Static_Expression
(Op2
);
6023 -- Inhibit folding if -gnatd.f flag set
6025 if Debug_Flag_Dot_F
and then In_Extended_Main_Source_Unit
(N
) then
6029 -- If either operand is Any_Type, just propagate to result and
6030 -- do not try to fold, this prevents cascaded errors.
6032 if Etype
(Op1
) = Any_Type
or else Etype
(Op2
) = Any_Type
then
6033 Set_Etype
(N
, Any_Type
);
6036 -- If left operand raises constraint error, then replace node N with the
6037 -- Raise_Constraint_Error node, and we are obviously not foldable.
6038 -- Is_Static_Expression is set from the two operands in the normal way,
6039 -- and we check the right operand if it is in a non-static context.
6041 elsif Raises_Constraint_Error
(Op1
) then
6043 Check_Non_Static_Context
(Op2
);
6046 Rewrite_In_Raise_CE
(N
, Op1
);
6047 Set_Is_Static_Expression
(N
, Rstat
);
6050 -- Similar processing for the case of the right operand. Note that we
6051 -- don't use this routine for the short-circuit case, so we do not have
6052 -- to worry about that special case here.
6054 elsif Raises_Constraint_Error
(Op2
) then
6056 Check_Non_Static_Context
(Op1
);
6059 Rewrite_In_Raise_CE
(N
, Op2
);
6060 Set_Is_Static_Expression
(N
, Rstat
);
6063 -- Exclude expressions of a generic modular type, as above
6065 elsif Is_Modular_Integer_Type
(Etype
(Op1
))
6066 and then Is_Generic_Type
(Etype
(Op1
))
6068 Check_Non_Static_Context
(Op1
);
6071 -- If result is not static, then check non-static contexts on operands
6072 -- since one of them may be static and the other one may not be static.
6074 elsif not Rstat
then
6075 Check_Non_Static_Context
(Op1
);
6076 Check_Non_Static_Context
(Op2
);
6079 Fold
:= CRT_Safe_Compile_Time_Known_Value
(Op1
)
6080 and then CRT_Safe_Compile_Time_Known_Value
(Op2
);
6082 Fold
:= Compile_Time_Known_Value
(Op1
)
6083 and then Compile_Time_Known_Value
(Op2
);
6088 -- Else result is static and foldable. Both operands are static, and
6089 -- neither raises constraint error, so we can definitely fold.
6092 Set_Is_Static_Expression
(N
);
6097 end Test_Expression_Is_Foldable
;
6103 function Test_In_Range
6106 Assume_Valid
: Boolean;
6107 Fixed_Int
: Boolean;
6108 Int_Real
: Boolean) return Range_Membership
6113 pragma Warnings
(Off
, Assume_Valid
);
6114 -- For now Assume_Valid is unreferenced since the current implementation
6115 -- always returns Unknown if N is not a compile time known value, but we
6116 -- keep the parameter to allow for future enhancements in which we try
6117 -- to get the information in the variable case as well.
6120 -- If an error was posted on expression, then return Unknown, we do not
6121 -- want cascaded errors based on some false analysis of a junk node.
6123 if Error_Posted
(N
) then
6126 -- Expression that raises constraint error is an odd case. We certainly
6127 -- do not want to consider it to be in range. It might make sense to
6128 -- consider it always out of range, but this causes incorrect error
6129 -- messages about static expressions out of range. So we just return
6130 -- Unknown, which is always safe.
6132 elsif Raises_Constraint_Error
(N
) then
6135 -- Universal types have no range limits, so always in range
6137 elsif Typ
= Universal_Integer
or else Typ
= Universal_Real
then
6140 -- Never known if not scalar type. Don't know if this can actually
6141 -- happen, but our spec allows it, so we must check.
6143 elsif not Is_Scalar_Type
(Typ
) then
6146 -- Never known if this is a generic type, since the bounds of generic
6147 -- types are junk. Note that if we only checked for static expressions
6148 -- (instead of compile time known values) below, we would not need this
6149 -- check, because values of a generic type can never be static, but they
6150 -- can be known at compile time.
6152 elsif Is_Generic_Type
(Typ
) then
6155 -- Case of a known compile time value, where we can check if it is in
6156 -- the bounds of the given type.
6158 elsif Compile_Time_Known_Value
(N
) then
6167 Lo
:= Type_Low_Bound
(Typ
);
6168 Hi
:= Type_High_Bound
(Typ
);
6170 LB_Known
:= Compile_Time_Known_Value
(Lo
);
6171 HB_Known
:= Compile_Time_Known_Value
(Hi
);
6173 -- Fixed point types should be considered as such only if flag
6174 -- Fixed_Int is set to False.
6176 if Is_Floating_Point_Type
(Typ
)
6177 or else (Is_Fixed_Point_Type
(Typ
) and then not Fixed_Int
)
6180 Valr
:= Expr_Value_R
(N
);
6182 if LB_Known
and HB_Known
then
6183 if Valr
>= Expr_Value_R
(Lo
)
6185 Valr
<= Expr_Value_R
(Hi
)
6189 return Out_Of_Range
;
6192 elsif (LB_Known
and then Valr
< Expr_Value_R
(Lo
))
6194 (HB_Known
and then Valr
> Expr_Value_R
(Hi
))
6196 return Out_Of_Range
;
6203 Val
:= Expr_Value
(N
);
6205 if LB_Known
and HB_Known
then
6206 if Val
>= Expr_Value
(Lo
) and then Val
<= Expr_Value
(Hi
)
6210 return Out_Of_Range
;
6213 elsif (LB_Known
and then Val
< Expr_Value
(Lo
))
6215 (HB_Known
and then Val
> Expr_Value
(Hi
))
6217 return Out_Of_Range
;
6225 -- Here for value not known at compile time. Case of expression subtype
6226 -- is Typ or is a subtype of Typ, and we can assume expression is valid.
6227 -- In this case we know it is in range without knowing its value.
6230 and then (Etype
(N
) = Typ
or else Is_Subtype_Of
(Etype
(N
), Typ
))
6234 -- Another special case. For signed integer types, if the target type
6235 -- has Is_Known_Valid set, and the source type does not have a larger
6236 -- size, then the source value must be in range. We exclude biased
6237 -- types, because they bizarrely can generate out of range values.
6239 elsif Is_Signed_Integer_Type
(Etype
(N
))
6240 and then Is_Known_Valid
(Typ
)
6241 and then Esize
(Etype
(N
)) <= Esize
(Typ
)
6242 and then not Has_Biased_Representation
(Etype
(N
))
6246 -- For all other cases, result is unknown
6257 procedure To_Bits
(U
: Uint
; B
: out Bits
) is
6259 for J
in 0 .. B
'Last loop
6260 B
(J
) := (U
/ (2 ** J
)) mod 2 /= 0;
6264 --------------------
6265 -- Why_Not_Static --
6266 --------------------
6268 procedure Why_Not_Static
(Expr
: Node_Id
) is
6269 N
: constant Node_Id
:= Original_Node
(Expr
);
6275 procedure Why_Not_Static_List
(L
: List_Id
);
6276 -- A version that can be called on a list of expressions. Finds all
6277 -- non-static violations in any element of the list.
6279 -------------------------
6280 -- Why_Not_Static_List --
6281 -------------------------
6283 procedure Why_Not_Static_List
(L
: List_Id
) is
6286 if Is_Non_Empty_List
(L
) then
6288 while Present
(N
) loop
6293 end Why_Not_Static_List
;
6295 -- Start of processing for Why_Not_Static
6298 -- Ignore call on error or empty node
6300 if No
(Expr
) or else Nkind
(Expr
) = N_Error
then
6304 -- Preprocessing for sub expressions
6306 if Nkind
(Expr
) in N_Subexpr
then
6308 -- Nothing to do if expression is static
6310 if Is_OK_Static_Expression
(Expr
) then
6314 -- Test for constraint error raised
6316 if Raises_Constraint_Error
(Expr
) then
6318 -- Special case membership to find out which piece to flag
6320 if Nkind
(N
) in N_Membership_Test
then
6321 if Raises_Constraint_Error
(Left_Opnd
(N
)) then
6322 Why_Not_Static
(Left_Opnd
(N
));
6325 elsif Present
(Right_Opnd
(N
))
6326 and then Raises_Constraint_Error
(Right_Opnd
(N
))
6328 Why_Not_Static
(Right_Opnd
(N
));
6332 pragma Assert
(Present
(Alternatives
(N
)));
6334 Alt
:= First
(Alternatives
(N
));
6335 while Present
(Alt
) loop
6336 if Raises_Constraint_Error
(Alt
) then
6337 Why_Not_Static
(Alt
);
6345 -- Special case a range to find out which bound to flag
6347 elsif Nkind
(N
) = N_Range
then
6348 if Raises_Constraint_Error
(Low_Bound
(N
)) then
6349 Why_Not_Static
(Low_Bound
(N
));
6352 elsif Raises_Constraint_Error
(High_Bound
(N
)) then
6353 Why_Not_Static
(High_Bound
(N
));
6357 -- Special case attribute to see which part to flag
6359 elsif Nkind
(N
) = N_Attribute_Reference
then
6360 if Raises_Constraint_Error
(Prefix
(N
)) then
6361 Why_Not_Static
(Prefix
(N
));
6365 if Present
(Expressions
(N
)) then
6366 Exp
:= First
(Expressions
(N
));
6367 while Present
(Exp
) loop
6368 if Raises_Constraint_Error
(Exp
) then
6369 Why_Not_Static
(Exp
);
6377 -- Special case a subtype name
6379 elsif Is_Entity_Name
(Expr
) and then Is_Type
(Entity
(Expr
)) then
6381 ("!& is not a static subtype (RM 4.9(26))", N
, Entity
(Expr
));
6385 -- End of special cases
6388 ("!expression raises exception, cannot be static (RM 4.9(34))",
6393 -- If no type, then something is pretty wrong, so ignore
6395 Typ
:= Etype
(Expr
);
6401 -- Type must be scalar or string type (but allow Bignum, since this
6402 -- is really a scalar type from our point of view in this diagnosis).
6404 if not Is_Scalar_Type
(Typ
)
6405 and then not Is_String_Type
(Typ
)
6406 and then not Is_RTE
(Typ
, RE_Bignum
)
6409 ("!static expression must have scalar or string type " &
6415 -- If we got through those checks, test particular node kind
6421 when N_Expanded_Name | N_Identifier | N_Operator_Symbol
=>
6424 if Is_Named_Number
(E
) then
6427 elsif Ekind
(E
) = E_Constant
then
6429 -- One case we can give a metter message is when we have a
6430 -- string literal created by concatenating an aggregate with
6431 -- an others expression.
6433 Entity_Case
: declare
6434 CV
: constant Node_Id
:= Constant_Value
(E
);
6435 CO
: constant Node_Id
:= Original_Node
(CV
);
6437 function Is_Aggregate
(N
: Node_Id
) return Boolean;
6438 -- See if node N came from an others aggregate, if so
6439 -- return True and set Error_Msg_Sloc to aggregate.
6445 function Is_Aggregate
(N
: Node_Id
) return Boolean is
6447 if Nkind
(Original_Node
(N
)) = N_Aggregate
then
6448 Error_Msg_Sloc
:= Sloc
(Original_Node
(N
));
6451 elsif Is_Entity_Name
(N
)
6452 and then Ekind
(Entity
(N
)) = E_Constant
6454 Nkind
(Original_Node
(Constant_Value
(Entity
(N
)))) =
6458 Sloc
(Original_Node
(Constant_Value
(Entity
(N
))));
6466 -- Start of processing for Entity_Case
6469 if Is_Aggregate
(CV
)
6470 or else (Nkind
(CO
) = N_Op_Concat
6471 and then (Is_Aggregate
(Left_Opnd
(CO
))
6473 Is_Aggregate
(Right_Opnd
(CO
))))
6475 Error_Msg_N
("!aggregate (#) is never static", N
);
6477 elsif No
(CV
) or else not Is_Static_Expression
(CV
) then
6479 ("!& is not a static constant (RM 4.9(5))", N
, E
);
6483 elsif Is_Type
(E
) then
6485 ("!& is not a static subtype (RM 4.9(26))", N
, E
);
6489 ("!& is not static constant or named number "
6490 & "(RM 4.9(5))", N
, E
);
6495 when N_Binary_Op | N_Short_Circuit | N_Membership_Test
=>
6496 if Nkind
(N
) in N_Op_Shift
then
6498 ("!shift functions are never static (RM 4.9(6,18))", N
);
6500 Why_Not_Static
(Left_Opnd
(N
));
6501 Why_Not_Static
(Right_Opnd
(N
));
6507 Why_Not_Static
(Right_Opnd
(N
));
6509 -- Attribute reference
6511 when N_Attribute_Reference
=>
6512 Why_Not_Static_List
(Expressions
(N
));
6514 E
:= Etype
(Prefix
(N
));
6516 if E
= Standard_Void_Type
then
6520 -- Special case non-scalar'Size since this is a common error
6522 if Attribute_Name
(N
) = Name_Size
then
6524 ("!size attribute is only static for static scalar type "
6525 & "(RM 4.9(7,8))", N
);
6529 elsif Is_Array_Type
(E
) then
6530 if not Nam_In
(Attribute_Name
(N
), Name_First
,
6535 ("!static array attribute must be Length, First, or Last "
6536 & "(RM 4.9(8))", N
);
6538 -- Since we know the expression is not-static (we already
6539 -- tested for this, must mean array is not static).
6543 ("!prefix is non-static array (RM 4.9(8))", Prefix
(N
));
6548 -- Special case generic types, since again this is a common source
6551 elsif Is_Generic_Actual_Type
(E
) or else Is_Generic_Type
(E
) then
6553 ("!attribute of generic type is never static "
6554 & "(RM 4.9(7,8))", N
);
6556 elsif Is_OK_Static_Subtype
(E
) then
6559 elsif Is_Scalar_Type
(E
) then
6561 ("!prefix type for attribute is not static scalar subtype "
6562 & "(RM 4.9(7))", N
);
6566 ("!static attribute must apply to array/scalar type "
6567 & "(RM 4.9(7,8))", N
);
6572 when N_String_Literal
=>
6574 ("!subtype of string literal is non-static (RM 4.9(4))", N
);
6576 -- Explicit dereference
6578 when N_Explicit_Dereference
=>
6580 ("!explicit dereference is never static (RM 4.9)", N
);
6584 when N_Function_Call
=>
6585 Why_Not_Static_List
(Parameter_Associations
(N
));
6587 -- Complain about non-static function call unless we have Bignum
6588 -- which means that the underlying expression is really some
6589 -- scalar arithmetic operation.
6591 if not Is_RTE
(Typ
, RE_Bignum
) then
6592 Error_Msg_N
("!non-static function call (RM 4.9(6,18))", N
);
6595 -- Parameter assocation (test actual parameter)
6597 when N_Parameter_Association
=>
6598 Why_Not_Static
(Explicit_Actual_Parameter
(N
));
6600 -- Indexed component
6602 when N_Indexed_Component
=>
6603 Error_Msg_N
("!indexed component is never static (RM 4.9)", N
);
6607 when N_Procedure_Call_Statement
=>
6608 Error_Msg_N
("!procedure call is never static (RM 4.9)", N
);
6610 -- Qualified expression (test expression)
6612 when N_Qualified_Expression
=>
6613 Why_Not_Static
(Expression
(N
));
6617 when N_Aggregate | N_Extension_Aggregate
=>
6618 Error_Msg_N
("!an aggregate is never static (RM 4.9)", N
);
6623 Why_Not_Static
(Low_Bound
(N
));
6624 Why_Not_Static
(High_Bound
(N
));
6626 -- Range constraint, test range expression
6628 when N_Range_Constraint
=>
6629 Why_Not_Static
(Range_Expression
(N
));
6631 -- Subtype indication, test constraint
6633 when N_Subtype_Indication
=>
6634 Why_Not_Static
(Constraint
(N
));
6636 -- Selected component
6638 when N_Selected_Component
=>
6639 Error_Msg_N
("!selected component is never static (RM 4.9)", N
);
6644 Error_Msg_N
("!slice is never static (RM 4.9)", N
);
6646 when N_Type_Conversion
=>
6647 Why_Not_Static
(Expression
(N
));
6649 if not Is_Scalar_Type
(Entity
(Subtype_Mark
(N
)))
6650 or else not Is_OK_Static_Subtype
(Entity
(Subtype_Mark
(N
)))
6653 ("!static conversion requires static scalar subtype result "
6654 & "(RM 4.9(9))", N
);
6657 -- Unchecked type conversion
6659 when N_Unchecked_Type_Conversion
=>
6661 ("!unchecked type conversion is never static (RM 4.9)", N
);
6663 -- All other cases, no reason to give