1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2013, 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 definitions 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 CV_Cache_Array
is array (CV_Range
) of CV_Entry
;
128 CV_Cache
: CV_Cache_Array
:= (others => (Node_High_Bound
, Uint_0
));
129 -- This is the actual cache, with entries consisting of node/value pairs,
130 -- and the impossible value Node_High_Bound used for unset entries.
132 type Range_Membership
is (In_Range
, Out_Of_Range
, Unknown
);
133 -- Range membership may either be statically known to be in range or out
134 -- of range, or not statically known. Used for Test_In_Range below.
136 -----------------------
137 -- Local Subprograms --
138 -----------------------
140 function From_Bits
(B
: Bits
; T
: Entity_Id
) return Uint
;
141 -- Converts a bit string of length B'Length to a Uint value to be used
142 -- for a target of type T, which is a modular type. This procedure
143 -- includes the necessary reduction by the modulus in the case of a
144 -- non-binary modulus (for a binary modulus, the bit string is the
145 -- right length any way so all is well).
147 function Get_String_Val
(N
: Node_Id
) return Node_Id
;
148 -- Given a tree node for a folded string or character value, returns
149 -- the corresponding string literal or character literal (one of the
150 -- two must be available, or the operand would not have been marked
151 -- as foldable in the earlier analysis of the operation).
153 function OK_Bits
(N
: Node_Id
; Bits
: Uint
) return Boolean;
154 -- Bits represents the number of bits in an integer value to be computed
155 -- (but the value has not been computed yet). If this value in Bits is
156 -- reasonable, a result of True is returned, with the implication that
157 -- the caller should go ahead and complete the calculation. If the value
158 -- in Bits is unreasonably large, then an error is posted on node N, and
159 -- False is returned (and the caller skips the proposed calculation).
161 procedure Out_Of_Range
(N
: Node_Id
);
162 -- This procedure is called if it is determined that node N, which
163 -- appears in a non-static context, is a compile time known value
164 -- which is outside its range, i.e. the range of Etype. This is used
165 -- in contexts where this is an illegality if N is static, and should
166 -- generate a warning otherwise.
168 procedure Rewrite_In_Raise_CE
(N
: Node_Id
; Exp
: Node_Id
);
169 -- N and Exp are nodes representing an expression, Exp is known
170 -- to raise CE. N is rewritten in term of Exp in the optimal way.
172 function String_Type_Len
(Stype
: Entity_Id
) return Uint
;
173 -- Given a string type, determines the length of the index type, or,
174 -- if this index type is non-static, the length of the base type of
175 -- this index type. Note that if the string type is itself static,
176 -- then the index type is static, so the second case applies only
177 -- if the string type passed is non-static.
179 function Test
(Cond
: Boolean) return Uint
;
180 pragma Inline
(Test
);
181 -- This function simply returns the appropriate Boolean'Pos value
182 -- corresponding to the value of Cond as a universal integer. It is
183 -- used for producing the result of the static evaluation of the
186 function Find_Universal_Operator_Type
(N
: Node_Id
) return Entity_Id
;
187 -- Check whether an arithmetic operation with universal operands which
188 -- is a rewritten function call with an explicit scope indication is
189 -- ambiguous: P."+" (1, 2) will be ambiguous if there is more than one
190 -- visible numeric type declared in P and the context does not impose a
191 -- type on the result (e.g. in the expression of a type conversion).
192 -- If ambiguous, emit an error and return Empty, else return the result
193 -- type of the operator.
195 procedure Test_Expression_Is_Foldable
200 -- Tests to see if expression N whose single operand is Op1 is foldable,
201 -- i.e. the operand value is known at compile time. If the operation is
202 -- foldable, then Fold is True on return, and Stat indicates whether
203 -- the result is static (i.e. the operand was static). Note that it
204 -- is quite possible for Fold to be True, and Stat to be False, since
205 -- there are cases in which we know the value of an operand even though
206 -- it is not technically static (e.g. the static lower bound of a range
207 -- whose upper bound is non-static).
209 -- If Stat is set False on return, then Test_Expression_Is_Foldable makes a
210 -- call to Check_Non_Static_Context on the operand. If Fold is False on
211 -- return, then all processing is complete, and the caller should
212 -- return, since there is nothing else to do.
214 -- If Stat is set True on return, then Is_Static_Expression is also set
215 -- true in node N. There are some cases where this is over-enthusiastic,
216 -- e.g. in the two operand case below, for string comparison, the result
217 -- is not static even though the two operands are static. In such cases,
218 -- the caller must reset the Is_Static_Expression flag in N.
220 -- If Fold and Stat are both set to False then this routine performs also
221 -- the following extra actions:
223 -- If either operand is Any_Type then propagate it to result to
224 -- prevent cascaded errors.
226 -- If some operand raises constraint error, then replace the node N
227 -- with the raise constraint error node. This replacement inherits the
228 -- Is_Static_Expression flag from the operands.
230 procedure Test_Expression_Is_Foldable
236 CRT_Safe
: Boolean := False);
237 -- Same processing, except applies to an expression N with two operands
238 -- Op1 and Op2. The result is static only if both operands are static. If
239 -- CRT_Safe is set True, then CRT_Safe_Compile_Time_Known_Value is used
240 -- for the tests that the two operands are known at compile time. See
241 -- spec of this routine for further details.
243 function Test_In_Range
246 Assume_Valid
: Boolean;
248 Int_Real
: Boolean) return Range_Membership
;
249 -- Common processing for Is_In_Range and Is_Out_Of_Range: Returns In_Range
250 -- or Out_Of_Range if it can be guaranteed at compile time that expression
251 -- N is known to be in or out of range of the subtype Typ. If not compile
252 -- time known, Unknown is returned. See documentation of Is_In_Range for
253 -- complete description of parameters.
255 procedure To_Bits
(U
: Uint
; B
: out Bits
);
256 -- Converts a Uint value to a bit string of length B'Length
258 ------------------------------
259 -- Check_Non_Static_Context --
260 ------------------------------
262 procedure Check_Non_Static_Context
(N
: Node_Id
) is
263 T
: constant Entity_Id
:= Etype
(N
);
264 Checks_On
: constant Boolean :=
265 not Index_Checks_Suppressed
(T
)
266 and not Range_Checks_Suppressed
(T
);
269 -- Ignore cases of non-scalar types, error types, or universal real
270 -- types that have no usable bounds.
273 or else not Is_Scalar_Type
(T
)
274 or else T
= Universal_Fixed
275 or else T
= Universal_Real
280 -- At this stage we have a scalar type. If we have an expression that
281 -- raises CE, then we already issued a warning or error msg so there
282 -- is nothing more to be done in this routine.
284 if Raises_Constraint_Error
(N
) then
288 -- Now we have a scalar type which is not marked as raising a constraint
289 -- error exception. The main purpose of this routine is to deal with
290 -- static expressions appearing in a non-static context. That means
291 -- that if we do not have a static expression then there is not much
292 -- to do. The one case that we deal with here is that if we have a
293 -- floating-point value that is out of range, then we post a warning
294 -- that an infinity will result.
296 if not Is_Static_Expression
(N
) then
297 if Is_Floating_Point_Type
(T
)
298 and then Is_Out_Of_Range
(N
, Base_Type
(T
), Assume_Valid
=> True)
301 ("??float value out of range, infinity will be generated", N
);
307 -- Here we have the case of outer level static expression of scalar
308 -- type, where the processing of this procedure is needed.
310 -- For real types, this is where we convert the value to a machine
311 -- number (see RM 4.9(38)). Also see ACVC test C490001. We should only
312 -- need to do this if the parent is a constant declaration, since in
313 -- other cases, gigi should do the necessary conversion correctly, but
314 -- experimentation shows that this is not the case on all machines, in
315 -- particular if we do not convert all literals to machine values in
316 -- non-static contexts, then ACVC test C490001 fails on Sparc/Solaris
319 if Nkind
(N
) = N_Real_Literal
320 and then not Is_Machine_Number
(N
)
321 and then not Is_Generic_Type
(Etype
(N
))
322 and then Etype
(N
) /= Universal_Real
324 -- Check that value is in bounds before converting to machine
325 -- number, so as not to lose case where value overflows in the
326 -- least significant bit or less. See B490001.
328 if Is_Out_Of_Range
(N
, Base_Type
(T
), Assume_Valid
=> True) then
333 -- Note: we have to copy the node, to avoid problems with conformance
334 -- of very similar numbers (see ACVC tests B4A010C and B63103A).
336 Rewrite
(N
, New_Copy
(N
));
338 if not Is_Floating_Point_Type
(T
) then
340 (N
, Corresponding_Integer_Value
(N
) * Small_Value
(T
));
342 elsif not UR_Is_Zero
(Realval
(N
)) then
344 -- Note: even though RM 4.9(38) specifies biased rounding, this
345 -- has been modified by AI-100 in order to prevent confusing
346 -- differences in rounding between static and non-static
347 -- expressions. AI-100 specifies that the effect of such rounding
348 -- is implementation dependent, and in GNAT we round to nearest
349 -- even to match the run-time behavior.
352 (N
, Machine
(Base_Type
(T
), Realval
(N
), Round_Even
, N
));
355 Set_Is_Machine_Number
(N
);
358 -- Check for out of range universal integer. This is a non-static
359 -- context, so the integer value must be in range of the runtime
360 -- representation of universal integers.
362 -- We do this only within an expression, because that is the only
363 -- case in which non-static universal integer values can occur, and
364 -- furthermore, Check_Non_Static_Context is currently (incorrectly???)
365 -- called in contexts like the expression of a number declaration where
366 -- we certainly want to allow out of range values.
368 if Etype
(N
) = Universal_Integer
369 and then Nkind
(N
) = N_Integer_Literal
370 and then Nkind
(Parent
(N
)) in N_Subexpr
372 (Intval
(N
) < Expr_Value
(Type_Low_Bound
(Universal_Integer
))
374 Intval
(N
) > Expr_Value
(Type_High_Bound
(Universal_Integer
)))
376 Apply_Compile_Time_Constraint_Error
377 (N
, "non-static universal integer value out of range<<",
378 CE_Range_Check_Failed
);
380 -- Check out of range of base type
382 elsif Is_Out_Of_Range
(N
, Base_Type
(T
), Assume_Valid
=> True) then
385 -- Give warning if outside subtype (where one or both of the bounds of
386 -- the subtype is static). This warning is omitted if the expression
387 -- appears in a range that could be null (warnings are handled elsewhere
390 elsif T
/= Base_Type
(T
)
391 and then Nkind
(Parent
(N
)) /= N_Range
393 if Is_In_Range
(N
, T
, Assume_Valid
=> True) then
396 elsif Is_Out_Of_Range
(N
, T
, Assume_Valid
=> True) then
397 Apply_Compile_Time_Constraint_Error
398 (N
, "value not in range of}<<", CE_Range_Check_Failed
);
401 Enable_Range_Check
(N
);
404 Set_Do_Range_Check
(N
, False);
407 end Check_Non_Static_Context
;
409 ---------------------------------
410 -- Check_String_Literal_Length --
411 ---------------------------------
413 procedure Check_String_Literal_Length
(N
: Node_Id
; Ttype
: Entity_Id
) is
415 if not Raises_Constraint_Error
(N
) and then Is_Constrained
(Ttype
) then
417 UI_From_Int
(String_Length
(Strval
(N
))) /= String_Type_Len
(Ttype
)
419 Apply_Compile_Time_Constraint_Error
420 (N
, "string length wrong for}??",
421 CE_Length_Check_Failed
,
426 end Check_String_Literal_Length
;
428 --------------------------
429 -- Compile_Time_Compare --
430 --------------------------
432 function Compile_Time_Compare
434 Assume_Valid
: Boolean) return Compare_Result
436 Discard
: aliased Uint
;
438 return Compile_Time_Compare
(L
, R
, Discard
'Access, Assume_Valid
);
439 end Compile_Time_Compare
;
441 function Compile_Time_Compare
444 Assume_Valid
: Boolean;
445 Rec
: Boolean := False) return Compare_Result
447 Ltyp
: Entity_Id
:= Underlying_Type
(Etype
(L
));
448 Rtyp
: Entity_Id
:= Underlying_Type
(Etype
(R
));
449 -- These get reset to the base type for the case of entities where
450 -- Is_Known_Valid is not set. This takes care of handling possible
451 -- invalid representations using the value of the base type, in
452 -- accordance with RM 13.9.1(10).
454 Discard
: aliased Uint
;
456 procedure Compare_Decompose
460 -- This procedure decomposes the node N into an expression node and a
461 -- signed offset, so that the value of N is equal to the value of R plus
462 -- the value V (which may be negative). If no such decomposition is
463 -- possible, then on return R is a copy of N, and V is set to zero.
465 function Compare_Fixup
(N
: Node_Id
) return Node_Id
;
466 -- This function deals with replacing 'Last and 'First references with
467 -- their corresponding type bounds, which we then can compare. The
468 -- argument is the original node, the result is the identity, unless we
469 -- have a 'Last/'First reference in which case the value returned is the
470 -- appropriate type bound.
472 function Is_Known_Valid_Operand
(Opnd
: Node_Id
) return Boolean;
473 -- Even if the context does not assume that values are valid, some
474 -- simple cases can be recognized.
476 function Is_Same_Value
(L
, R
: Node_Id
) return Boolean;
477 -- Returns True iff L and R represent expressions that definitely have
478 -- identical (but not necessarily compile time known) values Indeed the
479 -- caller is expected to have already dealt with the cases of compile
480 -- time known values, so these are not tested here.
482 -----------------------
483 -- Compare_Decompose --
484 -----------------------
486 procedure Compare_Decompose
492 if Nkind
(N
) = N_Op_Add
493 and then Nkind
(Right_Opnd
(N
)) = N_Integer_Literal
496 V
:= Intval
(Right_Opnd
(N
));
499 elsif Nkind
(N
) = N_Op_Subtract
500 and then Nkind
(Right_Opnd
(N
)) = N_Integer_Literal
503 V
:= UI_Negate
(Intval
(Right_Opnd
(N
)));
506 elsif Nkind
(N
) = N_Attribute_Reference
then
507 if Attribute_Name
(N
) = Name_Succ
then
508 R
:= First
(Expressions
(N
));
512 elsif Attribute_Name
(N
) = Name_Pred
then
513 R
:= First
(Expressions
(N
));
521 end Compare_Decompose
;
527 function Compare_Fixup
(N
: Node_Id
) return Node_Id
is
533 -- Fixup only required for First/Last attribute reference
535 if Nkind
(N
) = N_Attribute_Reference
536 and then Nam_In
(Attribute_Name
(N
), Name_First
, Name_Last
)
538 Xtyp
:= Etype
(Prefix
(N
));
540 -- If we have no type, then just abandon the attempt to do
541 -- a fixup, this is probably the result of some other error.
547 -- Dereference an access type
549 if Is_Access_Type
(Xtyp
) then
550 Xtyp
:= Designated_Type
(Xtyp
);
553 -- If we don't have an array type at this stage, something
554 -- is peculiar, e.g. another error, and we abandon the attempt
557 if not Is_Array_Type
(Xtyp
) then
561 -- Ignore unconstrained array, since bounds are not meaningful
563 if not Is_Constrained
(Xtyp
) then
567 if Ekind
(Xtyp
) = E_String_Literal_Subtype
then
568 if Attribute_Name
(N
) = Name_First
then
569 return String_Literal_Low_Bound
(Xtyp
);
572 return Make_Integer_Literal
(Sloc
(N
),
573 Intval
=> Intval
(String_Literal_Low_Bound
(Xtyp
))
574 + String_Literal_Length
(Xtyp
));
578 -- Find correct index type
580 Indx
:= First_Index
(Xtyp
);
582 if Present
(Expressions
(N
)) then
583 Subs
:= UI_To_Int
(Expr_Value
(First
(Expressions
(N
))));
585 for J
in 2 .. Subs
loop
586 Indx
:= Next_Index
(Indx
);
590 Xtyp
:= Etype
(Indx
);
592 if Attribute_Name
(N
) = Name_First
then
593 return Type_Low_Bound
(Xtyp
);
595 return Type_High_Bound
(Xtyp
);
602 ----------------------------
603 -- Is_Known_Valid_Operand --
604 ----------------------------
606 function Is_Known_Valid_Operand
(Opnd
: Node_Id
) return Boolean is
608 return (Is_Entity_Name
(Opnd
)
610 (Is_Known_Valid
(Entity
(Opnd
))
611 or else Ekind
(Entity
(Opnd
)) = E_In_Parameter
613 (Ekind
(Entity
(Opnd
)) in Object_Kind
614 and then Present
(Current_Value
(Entity
(Opnd
))))))
615 or else Is_OK_Static_Expression
(Opnd
);
616 end Is_Known_Valid_Operand
;
622 function Is_Same_Value
(L
, R
: Node_Id
) return Boolean is
623 Lf
: constant Node_Id
:= Compare_Fixup
(L
);
624 Rf
: constant Node_Id
:= Compare_Fixup
(R
);
626 function Is_Same_Subscript
(L
, R
: List_Id
) return Boolean;
627 -- L, R are the Expressions values from two attribute nodes for First
628 -- or Last attributes. Either may be set to No_List if no expressions
629 -- are present (indicating subscript 1). The result is True if both
630 -- expressions represent the same subscript (note one case is where
631 -- one subscript is missing and the other is explicitly set to 1).
633 -----------------------
634 -- Is_Same_Subscript --
635 -----------------------
637 function Is_Same_Subscript
(L
, R
: List_Id
) return Boolean is
643 return Expr_Value
(First
(R
)) = Uint_1
;
648 return Expr_Value
(First
(L
)) = Uint_1
;
650 return Expr_Value
(First
(L
)) = Expr_Value
(First
(R
));
653 end Is_Same_Subscript
;
655 -- Start of processing for Is_Same_Value
658 -- Values are the same if they refer to the same entity and the
659 -- entity is non-volatile. This does not however apply to Float
660 -- types, since we may have two NaN values and they should never
663 -- If the entity is a discriminant, the two expressions may be bounds
664 -- of components of objects of the same discriminated type. The
665 -- values of the discriminants are not static, and therefore the
666 -- result is unknown.
668 -- It would be better to comment individual branches of this test ???
670 if Nkind_In
(Lf
, N_Identifier
, N_Expanded_Name
)
671 and then Nkind_In
(Rf
, N_Identifier
, N_Expanded_Name
)
672 and then Entity
(Lf
) = Entity
(Rf
)
673 and then Ekind
(Entity
(Lf
)) /= E_Discriminant
674 and then Present
(Entity
(Lf
))
675 and then not Is_Floating_Point_Type
(Etype
(L
))
676 and then not Is_Volatile_Reference
(L
)
677 and then not Is_Volatile_Reference
(R
)
681 -- Or if they are compile time known and identical
683 elsif Compile_Time_Known_Value
(Lf
)
685 Compile_Time_Known_Value
(Rf
)
686 and then Expr_Value
(Lf
) = Expr_Value
(Rf
)
690 -- False if Nkind of the two nodes is different for remaining cases
692 elsif Nkind
(Lf
) /= Nkind
(Rf
) then
695 -- True if both 'First or 'Last values applying to the same entity
696 -- (first and last don't change even if value does). Note that we
697 -- need this even with the calls to Compare_Fixup, to handle the
698 -- case of unconstrained array attributes where Compare_Fixup
699 -- cannot find useful bounds.
701 elsif Nkind
(Lf
) = N_Attribute_Reference
702 and then Attribute_Name
(Lf
) = Attribute_Name
(Rf
)
703 and then Nam_In
(Attribute_Name
(Lf
), Name_First
, Name_Last
)
704 and then Nkind_In
(Prefix
(Lf
), N_Identifier
, N_Expanded_Name
)
705 and then Nkind_In
(Prefix
(Rf
), N_Identifier
, N_Expanded_Name
)
706 and then Entity
(Prefix
(Lf
)) = Entity
(Prefix
(Rf
))
707 and then Is_Same_Subscript
(Expressions
(Lf
), Expressions
(Rf
))
711 -- True if the same selected component from the same record
713 elsif Nkind
(Lf
) = N_Selected_Component
714 and then Selector_Name
(Lf
) = Selector_Name
(Rf
)
715 and then Is_Same_Value
(Prefix
(Lf
), Prefix
(Rf
))
719 -- True if the same unary operator applied to the same operand
721 elsif Nkind
(Lf
) in N_Unary_Op
722 and then Is_Same_Value
(Right_Opnd
(Lf
), Right_Opnd
(Rf
))
726 -- True if the same binary operator applied to the same operands
728 elsif Nkind
(Lf
) in N_Binary_Op
729 and then Is_Same_Value
(Left_Opnd
(Lf
), Left_Opnd
(Rf
))
730 and then Is_Same_Value
(Right_Opnd
(Lf
), Right_Opnd
(Rf
))
734 -- All other cases, we can't tell, so return False
741 -- Start of processing for Compile_Time_Compare
746 -- In preanalysis mode, always return Unknown unless the expression
747 -- is static. It is too early to be thinking we know the result of a
748 -- comparison, save that judgment for the full analysis. This is
749 -- particularly important in the case of pre and postconditions, which
750 -- otherwise can be prematurely collapsed into having True or False
751 -- conditions when this is inappropriate.
753 if not (Full_Analysis
754 or else (Is_Static_Expression
(L
)
756 Is_Static_Expression
(R
)))
761 -- If either operand could raise constraint error, then we cannot
762 -- know the result at compile time (since CE may be raised).
764 if not (Cannot_Raise_Constraint_Error
(L
)
766 Cannot_Raise_Constraint_Error
(R
))
771 -- Identical operands are most certainly equal
776 -- If expressions have no types, then do not attempt to determine if
777 -- they are the same, since something funny is going on. One case in
778 -- which this happens is during generic template analysis, when bounds
779 -- are not fully analyzed.
781 elsif No
(Ltyp
) or else No
(Rtyp
) then
784 -- We do not attempt comparisons for packed arrays arrays represented as
785 -- modular types, where the semantics of comparison is quite different.
787 elsif Is_Packed_Array_Type
(Ltyp
)
788 and then Is_Modular_Integer_Type
(Ltyp
)
792 -- For access types, the only time we know the result at compile time
793 -- (apart from identical operands, which we handled already) is if we
794 -- know one operand is null and the other is not, or both operands are
797 elsif Is_Access_Type
(Ltyp
) then
798 if Known_Null
(L
) then
799 if Known_Null
(R
) then
801 elsif Known_Non_Null
(R
) then
807 elsif Known_Non_Null
(L
) and then Known_Null
(R
) then
814 -- Case where comparison involves two compile time known values
816 elsif Compile_Time_Known_Value
(L
)
817 and then Compile_Time_Known_Value
(R
)
819 -- For the floating-point case, we have to be a little careful, since
820 -- at compile time we are dealing with universal exact values, but at
821 -- runtime, these will be in non-exact target form. That's why the
822 -- returned results are LE and GE below instead of LT and GT.
824 if Is_Floating_Point_Type
(Ltyp
)
826 Is_Floating_Point_Type
(Rtyp
)
829 Lo
: constant Ureal
:= Expr_Value_R
(L
);
830 Hi
: constant Ureal
:= Expr_Value_R
(R
);
842 -- For string types, we have two string literals and we proceed to
843 -- compare them using the Ada style dictionary string comparison.
845 elsif not Is_Scalar_Type
(Ltyp
) then
847 Lstring
: constant String_Id
:= Strval
(Expr_Value_S
(L
));
848 Rstring
: constant String_Id
:= Strval
(Expr_Value_S
(R
));
849 Llen
: constant Nat
:= String_Length
(Lstring
);
850 Rlen
: constant Nat
:= String_Length
(Rstring
);
853 for J
in 1 .. Nat
'Min (Llen
, Rlen
) loop
855 LC
: constant Char_Code
:= Get_String_Char
(Lstring
, J
);
856 RC
: constant Char_Code
:= Get_String_Char
(Rstring
, J
);
868 elsif Llen
> Rlen
then
875 -- For remaining scalar cases we know exactly (note that this does
876 -- include the fixed-point case, where we know the run time integer
881 Lo
: constant Uint
:= Expr_Value
(L
);
882 Hi
: constant Uint
:= Expr_Value
(R
);
899 -- Cases where at least one operand is not known at compile time
902 -- Remaining checks apply only for discrete types
904 if not Is_Discrete_Type
(Ltyp
)
905 or else not Is_Discrete_Type
(Rtyp
)
910 -- Defend against generic types, or actually any expressions that
911 -- contain a reference to a generic type from within a generic
912 -- template. We don't want to do any range analysis of such
913 -- expressions for two reasons. First, the bounds of a generic type
914 -- itself are junk and cannot be used for any kind of analysis.
915 -- Second, we may have a case where the range at run time is indeed
916 -- known, but we don't want to do compile time analysis in the
917 -- template based on that range since in an instance the value may be
918 -- static, and able to be elaborated without reference to the bounds
919 -- of types involved. As an example, consider:
921 -- (F'Pos (F'Last) + 1) > Integer'Last
923 -- The expression on the left side of > is Universal_Integer and thus
924 -- acquires the type Integer for evaluation at run time, and at run
925 -- time it is true that this condition is always False, but within
926 -- an instance F may be a type with a static range greater than the
927 -- range of Integer, and the expression statically evaluates to True.
929 if References_Generic_Formal_Type
(L
)
931 References_Generic_Formal_Type
(R
)
936 -- Replace types by base types for the case of entities which are
937 -- not known to have valid representations. This takes care of
938 -- properly dealing with invalid representations.
940 if not Assume_Valid
and then not Assume_No_Invalid_Values
then
941 if Is_Entity_Name
(L
) and then not Is_Known_Valid
(Entity
(L
)) then
942 Ltyp
:= Underlying_Type
(Base_Type
(Ltyp
));
945 if Is_Entity_Name
(R
) and then not Is_Known_Valid
(Entity
(R
)) then
946 Rtyp
:= Underlying_Type
(Base_Type
(Rtyp
));
950 -- First attempt is to decompose the expressions to extract a
951 -- constant offset resulting from the use of any of the forms:
958 -- Then we see if the two expressions are the same value, and if so
959 -- the result is obtained by comparing the offsets.
961 -- Note: the reason we do this test first is that it returns only
962 -- decisive results (with diff set), where other tests, like the
963 -- range test, may not be as so decisive. Consider for example
964 -- J .. J + 1. This code can conclude LT with a difference of 1,
965 -- even if the range of J is not known.
974 Compare_Decompose
(L
, Lnode
, Loffs
);
975 Compare_Decompose
(R
, Rnode
, Roffs
);
977 if Is_Same_Value
(Lnode
, Rnode
) then
978 if Loffs
= Roffs
then
981 elsif Loffs
< Roffs
then
982 Diff
.all := Roffs
- Loffs
;
986 Diff
.all := Loffs
- Roffs
;
992 -- Next, try range analysis and see if operand ranges are disjoint
1000 -- True if each range is a single point
1003 Determine_Range
(L
, LOK
, LLo
, LHi
, Assume_Valid
);
1004 Determine_Range
(R
, ROK
, RLo
, RHi
, Assume_Valid
);
1007 Single
:= (LLo
= LHi
) and then (RLo
= RHi
);
1010 if Single
and Assume_Valid
then
1011 Diff
.all := RLo
- LLo
;
1016 elsif RHi
< LLo
then
1017 if Single
and Assume_Valid
then
1018 Diff
.all := LLo
- RLo
;
1023 elsif Single
and then LLo
= RLo
then
1025 -- If the range includes a single literal and we can assume
1026 -- validity then the result is known even if an operand is
1029 if Assume_Valid
then
1035 elsif LHi
= RLo
then
1038 elsif RHi
= LLo
then
1041 elsif not Is_Known_Valid_Operand
(L
)
1042 and then not Assume_Valid
1044 if Is_Same_Value
(L
, R
) then
1051 -- If the range of either operand cannot be determined, nothing
1052 -- further can be inferred.
1059 -- Here is where we check for comparisons against maximum bounds of
1060 -- types, where we know that no value can be outside the bounds of
1061 -- the subtype. Note that this routine is allowed to assume that all
1062 -- expressions are within their subtype bounds. Callers wishing to
1063 -- deal with possibly invalid values must in any case take special
1064 -- steps (e.g. conversions to larger types) to avoid this kind of
1065 -- optimization, which is always considered to be valid. We do not
1066 -- attempt this optimization with generic types, since the type
1067 -- bounds may not be meaningful in this case.
1069 -- We are in danger of an infinite recursion here. It does not seem
1070 -- useful to go more than one level deep, so the parameter Rec is
1071 -- used to protect ourselves against this infinite recursion.
1075 -- See if we can get a decisive check against one operand and
1076 -- a bound of the other operand (four possible tests here).
1077 -- Note that we avoid testing junk bounds of a generic type.
1079 if not Is_Generic_Type
(Rtyp
) then
1080 case Compile_Time_Compare
(L
, Type_Low_Bound
(Rtyp
),
1082 Assume_Valid
, Rec
=> True)
1084 when LT
=> return LT
;
1085 when LE
=> return LE
;
1086 when EQ
=> return LE
;
1087 when others => null;
1090 case Compile_Time_Compare
(L
, Type_High_Bound
(Rtyp
),
1092 Assume_Valid
, Rec
=> True)
1094 when GT
=> return GT
;
1095 when GE
=> return GE
;
1096 when EQ
=> return GE
;
1097 when others => null;
1101 if not Is_Generic_Type
(Ltyp
) then
1102 case Compile_Time_Compare
(Type_Low_Bound
(Ltyp
), R
,
1104 Assume_Valid
, Rec
=> True)
1106 when GT
=> return GT
;
1107 when GE
=> return GE
;
1108 when EQ
=> return GE
;
1109 when others => null;
1112 case Compile_Time_Compare
(Type_High_Bound
(Ltyp
), R
,
1114 Assume_Valid
, Rec
=> True)
1116 when LT
=> return LT
;
1117 when LE
=> return LE
;
1118 when EQ
=> return LE
;
1119 when others => null;
1124 -- Next attempt is to see if we have an entity compared with a
1125 -- compile time known value, where there is a current value
1126 -- conditional for the entity which can tell us the result.
1130 -- Entity variable (left operand)
1133 -- Value (right operand)
1136 -- If False, we have reversed the operands
1139 -- Comparison operator kind from Get_Current_Value_Condition call
1142 -- Value from Get_Current_Value_Condition call
1147 Result
: Compare_Result
;
1148 -- Known result before inversion
1151 if Is_Entity_Name
(L
)
1152 and then Compile_Time_Known_Value
(R
)
1155 Val
:= Expr_Value
(R
);
1158 elsif Is_Entity_Name
(R
)
1159 and then Compile_Time_Known_Value
(L
)
1162 Val
:= Expr_Value
(L
);
1165 -- That was the last chance at finding a compile time result
1171 Get_Current_Value_Condition
(Var
, Op
, Opn
);
1173 -- That was the last chance, so if we got nothing return
1179 Opv
:= Expr_Value
(Opn
);
1181 -- We got a comparison, so we might have something interesting
1183 -- Convert LE to LT and GE to GT, just so we have fewer cases
1185 if Op
= N_Op_Le
then
1189 elsif Op
= N_Op_Ge
then
1194 -- Deal with equality case
1196 if Op
= N_Op_Eq
then
1199 elsif Opv
< Val
then
1205 -- Deal with inequality case
1207 elsif Op
= N_Op_Ne
then
1214 -- Deal with greater than case
1216 elsif Op
= N_Op_Gt
then
1219 elsif Opv
= Val
- 1 then
1225 -- Deal with less than case
1227 else pragma Assert
(Op
= N_Op_Lt
);
1230 elsif Opv
= Val
+ 1 then
1237 -- Deal with inverting result
1241 when GT
=> return LT
;
1242 when GE
=> return LE
;
1243 when LT
=> return GT
;
1244 when LE
=> return GE
;
1245 when others => return Result
;
1252 end Compile_Time_Compare
;
1254 -------------------------------
1255 -- Compile_Time_Known_Bounds --
1256 -------------------------------
1258 function Compile_Time_Known_Bounds
(T
: Entity_Id
) return Boolean is
1263 if T
= Any_Composite
or else not Is_Array_Type
(T
) then
1267 Indx
:= First_Index
(T
);
1268 while Present
(Indx
) loop
1269 Typ
:= Underlying_Type
(Etype
(Indx
));
1271 -- Never look at junk bounds of a generic type
1273 if Is_Generic_Type
(Typ
) then
1277 -- Otherwise check bounds for compile time known
1279 if not Compile_Time_Known_Value
(Type_Low_Bound
(Typ
)) then
1281 elsif not Compile_Time_Known_Value
(Type_High_Bound
(Typ
)) then
1289 end Compile_Time_Known_Bounds
;
1291 ------------------------------
1292 -- Compile_Time_Known_Value --
1293 ------------------------------
1295 function Compile_Time_Known_Value
(Op
: Node_Id
) return Boolean is
1296 K
: constant Node_Kind
:= Nkind
(Op
);
1297 CV_Ent
: CV_Entry
renames CV_Cache
(Nat
(Op
) mod CV_Cache_Size
);
1300 -- Never known at compile time if bad type or raises constraint error
1301 -- or empty (latter case occurs only as a result of a previous error).
1304 Check_Error_Detected
;
1308 or else Etype
(Op
) = Any_Type
1309 or else Raises_Constraint_Error
(Op
)
1314 -- If we have an entity name, then see if it is the name of a constant
1315 -- and if so, test the corresponding constant value, or the name of
1316 -- an enumeration literal, which is always a constant.
1318 if Present
(Etype
(Op
)) and then Is_Entity_Name
(Op
) then
1320 E
: constant Entity_Id
:= Entity
(Op
);
1324 -- Never known at compile time if it is a packed array value.
1325 -- We might want to try to evaluate these at compile time one
1326 -- day, but we do not make that attempt now.
1328 if Is_Packed_Array_Type
(Etype
(Op
)) then
1332 if Ekind
(E
) = E_Enumeration_Literal
then
1335 elsif Ekind
(E
) = E_Constant
then
1336 V
:= Constant_Value
(E
);
1337 return Present
(V
) and then Compile_Time_Known_Value
(V
);
1341 -- We have a value, see if it is compile time known
1344 -- Integer literals are worth storing in the cache
1346 if K
= N_Integer_Literal
then
1348 CV_Ent
.V
:= Intval
(Op
);
1351 -- Other literals and NULL are known at compile time
1354 K
= N_Character_Literal
1358 K
= N_String_Literal
1364 -- Any reference to Null_Parameter is known at compile time. No
1365 -- other attribute references (that have not already been folded)
1366 -- are known at compile time.
1368 elsif K
= N_Attribute_Reference
then
1369 return Attribute_Name
(Op
) = Name_Null_Parameter
;
1373 -- If we fall through, not known at compile time
1377 -- If we get an exception while trying to do this test, then some error
1378 -- has occurred, and we simply say that the value is not known after all
1383 end Compile_Time_Known_Value
;
1385 --------------------------------------
1386 -- Compile_Time_Known_Value_Or_Aggr --
1387 --------------------------------------
1389 function Compile_Time_Known_Value_Or_Aggr
(Op
: Node_Id
) return Boolean is
1391 -- If we have an entity name, then see if it is the name of a constant
1392 -- and if so, test the corresponding constant value, or the name of
1393 -- an enumeration literal, which is always a constant.
1395 if Is_Entity_Name
(Op
) then
1397 E
: constant Entity_Id
:= Entity
(Op
);
1401 if Ekind
(E
) = E_Enumeration_Literal
then
1404 elsif Ekind
(E
) /= E_Constant
then
1408 V
:= Constant_Value
(E
);
1410 and then Compile_Time_Known_Value_Or_Aggr
(V
);
1414 -- We have a value, see if it is compile time known
1417 if Compile_Time_Known_Value
(Op
) then
1420 elsif Nkind
(Op
) = N_Aggregate
then
1422 if Present
(Expressions
(Op
)) then
1427 Expr
:= First
(Expressions
(Op
));
1428 while Present
(Expr
) loop
1429 if not Compile_Time_Known_Value_Or_Aggr
(Expr
) then
1438 if Present
(Component_Associations
(Op
)) then
1443 Cass
:= First
(Component_Associations
(Op
));
1444 while Present
(Cass
) loop
1446 Compile_Time_Known_Value_Or_Aggr
(Expression
(Cass
))
1458 -- All other types of values are not known at compile time
1465 end Compile_Time_Known_Value_Or_Aggr
;
1467 ---------------------------------------
1468 -- CRT_Safe_Compile_Time_Known_Value --
1469 ---------------------------------------
1471 function CRT_Safe_Compile_Time_Known_Value
(Op
: Node_Id
) return Boolean is
1473 if (Configurable_Run_Time_Mode
or No_Run_Time_Mode
)
1474 and then not Is_OK_Static_Expression
(Op
)
1478 return Compile_Time_Known_Value
(Op
);
1480 end CRT_Safe_Compile_Time_Known_Value
;
1486 -- This is only called for actuals of functions that are not predefined
1487 -- operators (which have already been rewritten as operators at this
1488 -- stage), so the call can never be folded, and all that needs doing for
1489 -- the actual is to do the check for a non-static context.
1491 procedure Eval_Actual
(N
: Node_Id
) is
1493 Check_Non_Static_Context
(N
);
1496 --------------------
1497 -- Eval_Allocator --
1498 --------------------
1500 -- Allocators are never static, so all we have to do is to do the
1501 -- check for a non-static context if an expression is present.
1503 procedure Eval_Allocator
(N
: Node_Id
) is
1504 Expr
: constant Node_Id
:= Expression
(N
);
1507 if Nkind
(Expr
) = N_Qualified_Expression
then
1508 Check_Non_Static_Context
(Expression
(Expr
));
1512 ------------------------
1513 -- Eval_Arithmetic_Op --
1514 ------------------------
1516 -- Arithmetic operations are static functions, so the result is static
1517 -- if both operands are static (RM 4.9(7), 4.9(20)).
1519 procedure Eval_Arithmetic_Op
(N
: Node_Id
) is
1520 Left
: constant Node_Id
:= Left_Opnd
(N
);
1521 Right
: constant Node_Id
:= Right_Opnd
(N
);
1522 Ltype
: constant Entity_Id
:= Etype
(Left
);
1523 Rtype
: constant Entity_Id
:= Etype
(Right
);
1524 Otype
: Entity_Id
:= Empty
;
1529 -- If not foldable we are done
1531 Test_Expression_Is_Foldable
(N
, Left
, Right
, Stat
, Fold
);
1537 -- Otherwise attempt to fold
1539 if Is_Universal_Numeric_Type
(Etype
(Left
))
1541 Is_Universal_Numeric_Type
(Etype
(Right
))
1543 Otype
:= Find_Universal_Operator_Type
(N
);
1546 -- Fold for cases where both operands are of integer type
1548 if Is_Integer_Type
(Ltype
) and then Is_Integer_Type
(Rtype
) then
1550 Left_Int
: constant Uint
:= Expr_Value
(Left
);
1551 Right_Int
: constant Uint
:= Expr_Value
(Right
);
1558 Result
:= Left_Int
+ Right_Int
;
1560 when N_Op_Subtract
=>
1561 Result
:= Left_Int
- Right_Int
;
1563 when N_Op_Multiply
=>
1566 (Num_Bits
(Left_Int
) + Num_Bits
(Right_Int
)))
1568 Result
:= Left_Int
* Right_Int
;
1575 -- The exception Constraint_Error is raised by integer
1576 -- division, rem and mod if the right operand is zero.
1578 if Right_Int
= 0 then
1579 Apply_Compile_Time_Constraint_Error
1580 (N
, "division by zero",
1586 Result
:= Left_Int
/ Right_Int
;
1591 -- The exception Constraint_Error is raised by integer
1592 -- division, rem and mod if the right operand is zero.
1594 if Right_Int
= 0 then
1595 Apply_Compile_Time_Constraint_Error
1596 (N
, "mod with zero divisor",
1601 Result
:= Left_Int
mod Right_Int
;
1606 -- The exception Constraint_Error is raised by integer
1607 -- division, rem and mod if the right operand is zero.
1609 if Right_Int
= 0 then
1610 Apply_Compile_Time_Constraint_Error
1611 (N
, "rem with zero divisor",
1617 Result
:= Left_Int
rem Right_Int
;
1621 raise Program_Error
;
1624 -- Adjust the result by the modulus if the type is a modular type
1626 if Is_Modular_Integer_Type
(Ltype
) then
1627 Result
:= Result
mod Modulus
(Ltype
);
1629 -- For a signed integer type, check non-static overflow
1631 elsif (not Stat
) and then Is_Signed_Integer_Type
(Ltype
) then
1633 BT
: constant Entity_Id
:= Base_Type
(Ltype
);
1634 Lo
: constant Uint
:= Expr_Value
(Type_Low_Bound
(BT
));
1635 Hi
: constant Uint
:= Expr_Value
(Type_High_Bound
(BT
));
1637 if Result
< Lo
or else Result
> Hi
then
1638 Apply_Compile_Time_Constraint_Error
1639 (N
, "value not in range of }??",
1640 CE_Overflow_Check_Failed
,
1647 -- If we get here we can fold the result
1649 Fold_Uint
(N
, Result
, Stat
);
1652 -- Cases where at least one operand is a real. We handle the cases of
1653 -- both reals, or mixed/real integer cases (the latter happen only for
1654 -- divide and multiply, and the result is always real).
1656 elsif Is_Real_Type
(Ltype
) or else Is_Real_Type
(Rtype
) then
1663 if Is_Real_Type
(Ltype
) then
1664 Left_Real
:= Expr_Value_R
(Left
);
1666 Left_Real
:= UR_From_Uint
(Expr_Value
(Left
));
1669 if Is_Real_Type
(Rtype
) then
1670 Right_Real
:= Expr_Value_R
(Right
);
1672 Right_Real
:= UR_From_Uint
(Expr_Value
(Right
));
1675 if Nkind
(N
) = N_Op_Add
then
1676 Result
:= Left_Real
+ Right_Real
;
1678 elsif Nkind
(N
) = N_Op_Subtract
then
1679 Result
:= Left_Real
- Right_Real
;
1681 elsif Nkind
(N
) = N_Op_Multiply
then
1682 Result
:= Left_Real
* Right_Real
;
1684 else pragma Assert
(Nkind
(N
) = N_Op_Divide
);
1685 if UR_Is_Zero
(Right_Real
) then
1686 Apply_Compile_Time_Constraint_Error
1687 (N
, "division by zero", CE_Divide_By_Zero
);
1691 Result
:= Left_Real
/ Right_Real
;
1694 Fold_Ureal
(N
, Result
, Stat
);
1698 -- If the operator was resolved to a specific type, make sure that type
1699 -- is frozen even if the expression is folded into a literal (which has
1700 -- a universal type).
1702 if Present
(Otype
) then
1703 Freeze_Before
(N
, Otype
);
1705 end Eval_Arithmetic_Op
;
1707 ----------------------------
1708 -- Eval_Character_Literal --
1709 ----------------------------
1711 -- Nothing to be done
1713 procedure Eval_Character_Literal
(N
: Node_Id
) is
1714 pragma Warnings
(Off
, N
);
1717 end Eval_Character_Literal
;
1723 -- Static function calls are either calls to predefined operators
1724 -- with static arguments, or calls to functions that rename a literal.
1725 -- Only the latter case is handled here, predefined operators are
1726 -- constant-folded elsewhere.
1728 -- If the function is itself inherited (see 7423-001) the literal of
1729 -- the parent type must be explicitly converted to the return type
1732 procedure Eval_Call
(N
: Node_Id
) is
1733 Loc
: constant Source_Ptr
:= Sloc
(N
);
1734 Typ
: constant Entity_Id
:= Etype
(N
);
1738 if Nkind
(N
) = N_Function_Call
1739 and then No
(Parameter_Associations
(N
))
1740 and then Is_Entity_Name
(Name
(N
))
1741 and then Present
(Alias
(Entity
(Name
(N
))))
1742 and then Is_Enumeration_Type
(Base_Type
(Typ
))
1744 Lit
:= Ultimate_Alias
(Entity
(Name
(N
)));
1746 if Ekind
(Lit
) = E_Enumeration_Literal
then
1747 if Base_Type
(Etype
(Lit
)) /= Base_Type
(Typ
) then
1749 (N
, Convert_To
(Typ
, New_Occurrence_Of
(Lit
, Loc
)));
1751 Rewrite
(N
, New_Occurrence_Of
(Lit
, Loc
));
1759 --------------------------
1760 -- Eval_Case_Expression --
1761 --------------------------
1763 -- A conditional expression is static if all its conditions and dependent
1764 -- expressions are static.
1766 procedure Eval_Case_Expression
(N
: Node_Id
) is
1769 Is_Static
: Boolean;
1777 if Is_Static_Expression
(Expression
(N
)) then
1778 Val
:= Expr_Value
(Expression
(N
));
1781 Check_Non_Static_Context
(Expression
(N
));
1785 Alt
:= First
(Alternatives
(N
));
1787 Search
: while Present
(Alt
) loop
1789 or else not Is_Static_Expression
(Expression
(Alt
))
1791 Check_Non_Static_Context
(Expression
(Alt
));
1795 Choice
:= First
(Discrete_Choices
(Alt
));
1796 while Present
(Choice
) loop
1797 if Nkind
(Choice
) = N_Others_Choice
then
1798 Result
:= Expression
(Alt
);
1801 elsif Expr_Value
(Choice
) = Val
then
1802 Result
:= Expression
(Alt
);
1815 Rewrite
(N
, Relocate_Node
(Result
));
1818 Set_Is_Static_Expression
(N
, False);
1820 end Eval_Case_Expression
;
1822 ------------------------
1823 -- Eval_Concatenation --
1824 ------------------------
1826 -- Concatenation is a static function, so the result is static if both
1827 -- operands are static (RM 4.9(7), 4.9(21)).
1829 procedure Eval_Concatenation
(N
: Node_Id
) is
1830 Left
: constant Node_Id
:= Left_Opnd
(N
);
1831 Right
: constant Node_Id
:= Right_Opnd
(N
);
1832 C_Typ
: constant Entity_Id
:= Root_Type
(Component_Type
(Etype
(N
)));
1837 -- Concatenation is never static in Ada 83, so if Ada 83 check operand
1838 -- non-static context.
1840 if Ada_Version
= Ada_83
1841 and then Comes_From_Source
(N
)
1843 Check_Non_Static_Context
(Left
);
1844 Check_Non_Static_Context
(Right
);
1848 -- If not foldable we are done. In principle concatenation that yields
1849 -- any string type is static (i.e. an array type of character types).
1850 -- However, character types can include enumeration literals, and
1851 -- concatenation in that case cannot be described by a literal, so we
1852 -- only consider the operation static if the result is an array of
1853 -- (a descendant of) a predefined character type.
1855 Test_Expression_Is_Foldable
(N
, Left
, Right
, Stat
, Fold
);
1857 if not (Is_Standard_Character_Type
(C_Typ
) and then Fold
) then
1858 Set_Is_Static_Expression
(N
, False);
1862 -- Compile time string concatenation
1864 -- ??? Note that operands that are aggregates can be marked as static,
1865 -- so we should attempt at a later stage to fold concatenations with
1869 Left_Str
: constant Node_Id
:= Get_String_Val
(Left
);
1871 Right_Str
: constant Node_Id
:= Get_String_Val
(Right
);
1872 Folded_Val
: String_Id
;
1875 -- Establish new string literal, and store left operand. We make
1876 -- sure to use the special Start_String that takes an operand if
1877 -- the left operand is a string literal. Since this is optimized
1878 -- in the case where that is the most recently created string
1879 -- literal, we ensure efficient time/space behavior for the
1880 -- case of a concatenation of a series of string literals.
1882 if Nkind
(Left_Str
) = N_String_Literal
then
1883 Left_Len
:= String_Length
(Strval
(Left_Str
));
1885 -- If the left operand is the empty string, and the right operand
1886 -- is a string literal (the case of "" & "..."), the result is the
1887 -- value of the right operand. This optimization is important when
1888 -- Is_Folded_In_Parser, to avoid copying an enormous right
1891 if Left_Len
= 0 and then Nkind
(Right_Str
) = N_String_Literal
then
1892 Folded_Val
:= Strval
(Right_Str
);
1894 Start_String
(Strval
(Left_Str
));
1899 Store_String_Char
(UI_To_CC
(Char_Literal_Value
(Left_Str
)));
1903 -- Now append the characters of the right operand, unless we
1904 -- optimized the "" & "..." case above.
1906 if Nkind
(Right_Str
) = N_String_Literal
then
1907 if Left_Len
/= 0 then
1908 Store_String_Chars
(Strval
(Right_Str
));
1909 Folded_Val
:= End_String
;
1912 Store_String_Char
(UI_To_CC
(Char_Literal_Value
(Right_Str
)));
1913 Folded_Val
:= End_String
;
1916 Set_Is_Static_Expression
(N
, Stat
);
1918 -- If left operand is the empty string, the result is the
1919 -- right operand, including its bounds if anomalous.
1922 and then Is_Array_Type
(Etype
(Right
))
1923 and then Etype
(Right
) /= Any_String
1925 Set_Etype
(N
, Etype
(Right
));
1928 Fold_Str
(N
, Folded_Val
, Static
=> Stat
);
1930 end Eval_Concatenation
;
1932 ----------------------
1933 -- Eval_Entity_Name --
1934 ----------------------
1936 -- This procedure is used for identifiers and expanded names other than
1937 -- named numbers (see Eval_Named_Integer, Eval_Named_Real. These are
1938 -- static if they denote a static constant (RM 4.9(6)) or if the name
1939 -- denotes an enumeration literal (RM 4.9(22)).
1941 procedure Eval_Entity_Name
(N
: Node_Id
) is
1942 Def_Id
: constant Entity_Id
:= Entity
(N
);
1946 -- Enumeration literals are always considered to be constants
1947 -- and cannot raise constraint error (RM 4.9(22)).
1949 if Ekind
(Def_Id
) = E_Enumeration_Literal
then
1950 Set_Is_Static_Expression
(N
);
1953 -- A name is static if it denotes a static constant (RM 4.9(5)), and
1954 -- we also copy Raise_Constraint_Error. Notice that even if non-static,
1955 -- it does not violate 10.2.1(8) here, since this is not a variable.
1957 elsif Ekind
(Def_Id
) = E_Constant
then
1959 -- Deferred constants must always be treated as nonstatic outside the
1960 -- scope of their full view.
1962 if Present
(Full_View
(Def_Id
))
1963 and then not In_Open_Scopes
(Scope
(Def_Id
))
1967 Val
:= Constant_Value
(Def_Id
);
1970 if Present
(Val
) then
1971 Set_Is_Static_Expression
1972 (N
, Is_Static_Expression
(Val
)
1973 and then Is_Static_Subtype
(Etype
(Def_Id
)));
1974 Set_Raises_Constraint_Error
(N
, Raises_Constraint_Error
(Val
));
1976 if not Is_Static_Expression
(N
)
1977 and then not Is_Generic_Type
(Etype
(N
))
1979 Validate_Static_Object_Name
(N
);
1982 -- Mark constant condition in SCOs
1985 and then Comes_From_Source
(N
)
1986 and then Is_Boolean_Type
(Etype
(Def_Id
))
1987 and then Compile_Time_Known_Value
(N
)
1989 Set_SCO_Condition
(N
, Expr_Value_E
(N
) = Standard_True
);
1996 -- Fall through if the name is not static
1998 Validate_Static_Object_Name
(N
);
1999 end Eval_Entity_Name
;
2001 ------------------------
2002 -- Eval_If_Expression --
2003 ------------------------
2005 -- We can fold to a static expression if the condition and both dependent
2006 -- expressions are static. Otherwise, the only required processing is to do
2007 -- the check for non-static context for the then and else expressions.
2009 procedure Eval_If_Expression
(N
: Node_Id
) is
2010 Condition
: constant Node_Id
:= First
(Expressions
(N
));
2011 Then_Expr
: constant Node_Id
:= Next
(Condition
);
2012 Else_Expr
: constant Node_Id
:= Next
(Then_Expr
);
2014 Non_Result
: Node_Id
;
2016 Rstat
: constant Boolean :=
2017 Is_Static_Expression
(Condition
)
2019 Is_Static_Expression
(Then_Expr
)
2021 Is_Static_Expression
(Else_Expr
);
2024 -- If any operand is Any_Type, just propagate to result and do not try
2025 -- to fold, this prevents cascaded errors.
2027 if Etype
(Condition
) = Any_Type
or else
2028 Etype
(Then_Expr
) = Any_Type
or else
2029 Etype
(Else_Expr
) = Any_Type
2031 Set_Etype
(N
, Any_Type
);
2032 Set_Is_Static_Expression
(N
, False);
2035 -- Static case where we can fold. Note that we don't try to fold cases
2036 -- where the condition is known at compile time, but the result is
2037 -- non-static. This avoids possible cases of infinite recursion where
2038 -- the expander puts in a redundant test and we remove it. Instead we
2039 -- deal with these cases in the expander.
2043 -- Select result operand
2045 if Is_True
(Expr_Value
(Condition
)) then
2046 Result
:= Then_Expr
;
2047 Non_Result
:= Else_Expr
;
2049 Result
:= Else_Expr
;
2050 Non_Result
:= Then_Expr
;
2053 -- Note that it does not matter if the non-result operand raises a
2054 -- Constraint_Error, but if the result raises constraint error then
2055 -- we replace the node with a raise constraint error. This will
2056 -- properly propagate Raises_Constraint_Error since this flag is
2059 if Raises_Constraint_Error
(Result
) then
2060 Rewrite_In_Raise_CE
(N
, Result
);
2061 Check_Non_Static_Context
(Non_Result
);
2063 -- Otherwise the result operand replaces the original node
2066 Rewrite
(N
, Relocate_Node
(Result
));
2069 -- Case of condition not known at compile time
2072 Check_Non_Static_Context
(Condition
);
2073 Check_Non_Static_Context
(Then_Expr
);
2074 Check_Non_Static_Context
(Else_Expr
);
2077 Set_Is_Static_Expression
(N
, Rstat
);
2078 end Eval_If_Expression
;
2080 ----------------------------
2081 -- Eval_Indexed_Component --
2082 ----------------------------
2084 -- Indexed components are never static, so we need to perform the check
2085 -- for non-static context on the index values. Then, we check if the
2086 -- value can be obtained at compile time, even though it is non-static.
2088 procedure Eval_Indexed_Component
(N
: Node_Id
) is
2092 -- Check for non-static context on index values
2094 Expr
:= First
(Expressions
(N
));
2095 while Present
(Expr
) loop
2096 Check_Non_Static_Context
(Expr
);
2100 -- If the indexed component appears in an object renaming declaration
2101 -- then we do not want to try to evaluate it, since in this case we
2102 -- need the identity of the array element.
2104 if Nkind
(Parent
(N
)) = N_Object_Renaming_Declaration
then
2107 -- Similarly if the indexed component appears as the prefix of an
2108 -- attribute we don't want to evaluate it, because at least for
2109 -- some cases of attributes we need the identify (e.g. Access, Size)
2111 elsif Nkind
(Parent
(N
)) = N_Attribute_Reference
then
2115 -- Note: there are other cases, such as the left side of an assignment,
2116 -- or an OUT parameter for a call, where the replacement results in the
2117 -- illegal use of a constant, But these cases are illegal in the first
2118 -- place, so the replacement, though silly, is harmless.
2120 -- Now see if this is a constant array reference
2122 if List_Length
(Expressions
(N
)) = 1
2123 and then Is_Entity_Name
(Prefix
(N
))
2124 and then Ekind
(Entity
(Prefix
(N
))) = E_Constant
2125 and then Present
(Constant_Value
(Entity
(Prefix
(N
))))
2128 Loc
: constant Source_Ptr
:= Sloc
(N
);
2129 Arr
: constant Node_Id
:= Constant_Value
(Entity
(Prefix
(N
)));
2130 Sub
: constant Node_Id
:= First
(Expressions
(N
));
2136 -- Linear one's origin subscript value for array reference
2139 -- Lower bound of the first array index
2142 -- Value from constant array
2145 Atyp
:= Etype
(Arr
);
2147 if Is_Access_Type
(Atyp
) then
2148 Atyp
:= Designated_Type
(Atyp
);
2151 -- If we have an array type (we should have but perhaps there are
2152 -- error cases where this is not the case), then see if we can do
2153 -- a constant evaluation of the array reference.
2155 if Is_Array_Type
(Atyp
) and then Atyp
/= Any_Composite
then
2156 if Ekind
(Atyp
) = E_String_Literal_Subtype
then
2157 Lbd
:= String_Literal_Low_Bound
(Atyp
);
2159 Lbd
:= Type_Low_Bound
(Etype
(First_Index
(Atyp
)));
2162 if Compile_Time_Known_Value
(Sub
)
2163 and then Nkind
(Arr
) = N_Aggregate
2164 and then Compile_Time_Known_Value
(Lbd
)
2165 and then Is_Discrete_Type
(Component_Type
(Atyp
))
2167 Lin
:= UI_To_Int
(Expr_Value
(Sub
) - Expr_Value
(Lbd
)) + 1;
2169 if List_Length
(Expressions
(Arr
)) >= Lin
then
2170 Elm
:= Pick
(Expressions
(Arr
), Lin
);
2172 -- If the resulting expression is compile time known,
2173 -- then we can rewrite the indexed component with this
2174 -- value, being sure to mark the result as non-static.
2175 -- We also reset the Sloc, in case this generates an
2176 -- error later on (e.g. 136'Access).
2178 if Compile_Time_Known_Value
(Elm
) then
2179 Rewrite
(N
, Duplicate_Subexpr_No_Checks
(Elm
));
2180 Set_Is_Static_Expression
(N
, False);
2185 -- We can also constant-fold if the prefix is a string literal.
2186 -- This will be useful in an instantiation or an inlining.
2188 elsif Compile_Time_Known_Value
(Sub
)
2189 and then Nkind
(Arr
) = N_String_Literal
2190 and then Compile_Time_Known_Value
(Lbd
)
2191 and then Expr_Value
(Lbd
) = 1
2192 and then Expr_Value
(Sub
) <=
2193 String_Literal_Length
(Etype
(Arr
))
2196 C
: constant Char_Code
:=
2197 Get_String_Char
(Strval
(Arr
),
2198 UI_To_Int
(Expr_Value
(Sub
)));
2200 Set_Character_Literal_Name
(C
);
2203 Make_Character_Literal
(Loc
,
2205 Char_Literal_Value
=> UI_From_CC
(C
));
2206 Set_Etype
(Elm
, Component_Type
(Atyp
));
2207 Rewrite
(N
, Duplicate_Subexpr_No_Checks
(Elm
));
2208 Set_Is_Static_Expression
(N
, False);
2214 end Eval_Indexed_Component
;
2216 --------------------------
2217 -- Eval_Integer_Literal --
2218 --------------------------
2220 -- Numeric literals are static (RM 4.9(1)), and have already been marked
2221 -- as static by the analyzer. The reason we did it that early is to allow
2222 -- the possibility of turning off the Is_Static_Expression flag after
2223 -- analysis, but before resolution, when integer literals are generated in
2224 -- the expander that do not correspond to static expressions.
2226 procedure Eval_Integer_Literal
(N
: Node_Id
) is
2227 T
: constant Entity_Id
:= Etype
(N
);
2229 function In_Any_Integer_Context
return Boolean;
2230 -- If the literal is resolved with a specific type in a context where
2231 -- the expected type is Any_Integer, there are no range checks on the
2232 -- literal. By the time the literal is evaluated, it carries the type
2233 -- imposed by the enclosing expression, and we must recover the context
2234 -- to determine that Any_Integer is meant.
2236 ----------------------------
2237 -- In_Any_Integer_Context --
2238 ----------------------------
2240 function In_Any_Integer_Context
return Boolean is
2241 Par
: constant Node_Id
:= Parent
(N
);
2242 K
: constant Node_Kind
:= Nkind
(Par
);
2245 -- Any_Integer also appears in digits specifications for real types,
2246 -- but those have bounds smaller that those of any integer base type,
2247 -- so we can safely ignore these cases.
2249 return K
= N_Number_Declaration
2250 or else K
= N_Attribute_Reference
2251 or else K
= N_Attribute_Definition_Clause
2252 or else K
= N_Modular_Type_Definition
2253 or else K
= N_Signed_Integer_Type_Definition
;
2254 end In_Any_Integer_Context
;
2256 -- Start of processing for Eval_Integer_Literal
2260 -- If the literal appears in a non-expression context, then it is
2261 -- certainly appearing in a non-static context, so check it. This is
2262 -- actually a redundant check, since Check_Non_Static_Context would
2263 -- check it, but it seems worth while avoiding the call.
2265 if Nkind
(Parent
(N
)) not in N_Subexpr
2266 and then not In_Any_Integer_Context
2268 Check_Non_Static_Context
(N
);
2271 -- Modular integer literals must be in their base range
2273 if Is_Modular_Integer_Type
(T
)
2274 and then Is_Out_Of_Range
(N
, Base_Type
(T
), Assume_Valid
=> True)
2278 end Eval_Integer_Literal
;
2280 ---------------------
2281 -- Eval_Logical_Op --
2282 ---------------------
2284 -- Logical operations are static functions, so the result is potentially
2285 -- static if both operands are potentially static (RM 4.9(7), 4.9(20)).
2287 procedure Eval_Logical_Op
(N
: Node_Id
) is
2288 Left
: constant Node_Id
:= Left_Opnd
(N
);
2289 Right
: constant Node_Id
:= Right_Opnd
(N
);
2294 -- If not foldable we are done
2296 Test_Expression_Is_Foldable
(N
, Left
, Right
, Stat
, Fold
);
2302 -- Compile time evaluation of logical operation
2305 Left_Int
: constant Uint
:= Expr_Value
(Left
);
2306 Right_Int
: constant Uint
:= Expr_Value
(Right
);
2309 -- VMS includes bitwise operations on signed types
2311 if Is_Modular_Integer_Type
(Etype
(N
))
2312 or else Is_VMS_Operator
(Entity
(N
))
2315 Left_Bits
: Bits
(0 .. UI_To_Int
(Esize
(Etype
(N
))) - 1);
2316 Right_Bits
: Bits
(0 .. UI_To_Int
(Esize
(Etype
(N
))) - 1);
2319 To_Bits
(Left_Int
, Left_Bits
);
2320 To_Bits
(Right_Int
, Right_Bits
);
2322 -- Note: should really be able to use array ops instead of
2323 -- these loops, but they weren't working at the time ???
2325 if Nkind
(N
) = N_Op_And
then
2326 for J
in Left_Bits
'Range loop
2327 Left_Bits
(J
) := Left_Bits
(J
) and Right_Bits
(J
);
2330 elsif Nkind
(N
) = N_Op_Or
then
2331 for J
in Left_Bits
'Range loop
2332 Left_Bits
(J
) := Left_Bits
(J
) or Right_Bits
(J
);
2336 pragma Assert
(Nkind
(N
) = N_Op_Xor
);
2338 for J
in Left_Bits
'Range loop
2339 Left_Bits
(J
) := Left_Bits
(J
) xor Right_Bits
(J
);
2343 Fold_Uint
(N
, From_Bits
(Left_Bits
, Etype
(N
)), Stat
);
2347 pragma Assert
(Is_Boolean_Type
(Etype
(N
)));
2349 if Nkind
(N
) = N_Op_And
then
2351 Test
(Is_True
(Left_Int
) and then Is_True
(Right_Int
)), Stat
);
2353 elsif Nkind
(N
) = N_Op_Or
then
2355 Test
(Is_True
(Left_Int
) or else Is_True
(Right_Int
)), Stat
);
2358 pragma Assert
(Nkind
(N
) = N_Op_Xor
);
2360 Test
(Is_True
(Left_Int
) xor Is_True
(Right_Int
)), Stat
);
2364 end Eval_Logical_Op
;
2366 ------------------------
2367 -- Eval_Membership_Op --
2368 ------------------------
2370 -- A membership test is potentially static if the expression is static, and
2371 -- the range is a potentially static range, or is a subtype mark denoting a
2372 -- static subtype (RM 4.9(12)).
2374 procedure Eval_Membership_Op
(N
: Node_Id
) is
2375 Left
: constant Node_Id
:= Left_Opnd
(N
);
2376 Right
: constant Node_Id
:= Right_Opnd
(N
);
2385 -- Ignore if error in either operand, except to make sure that Any_Type
2386 -- is properly propagated to avoid junk cascaded errors.
2388 if Etype
(Left
) = Any_Type
or else Etype
(Right
) = Any_Type
then
2389 Set_Etype
(N
, Any_Type
);
2393 -- Ignore if types involved have predicates
2395 if Present
(Predicate_Function
(Etype
(Left
)))
2397 Present
(Predicate_Function
(Etype
(Right
)))
2402 -- Case of right operand is a subtype name
2404 if Is_Entity_Name
(Right
) then
2405 Def_Id
:= Entity
(Right
);
2407 if (Is_Scalar_Type
(Def_Id
) or else Is_String_Type
(Def_Id
))
2408 and then Is_OK_Static_Subtype
(Def_Id
)
2410 Test_Expression_Is_Foldable
(N
, Left
, Stat
, Fold
);
2412 if not Fold
or else not Stat
then
2416 Check_Non_Static_Context
(Left
);
2420 -- For string membership tests we will check the length further on
2422 if not Is_String_Type
(Def_Id
) then
2423 Lo
:= Type_Low_Bound
(Def_Id
);
2424 Hi
:= Type_High_Bound
(Def_Id
);
2431 -- Case of right operand is a range
2434 if Is_Static_Range
(Right
) then
2435 Test_Expression_Is_Foldable
(N
, Left
, Stat
, Fold
);
2437 if not Fold
or else not Stat
then
2440 -- If one bound of range raises CE, then don't try to fold
2442 elsif not Is_OK_Static_Range
(Right
) then
2443 Check_Non_Static_Context
(Left
);
2448 Check_Non_Static_Context
(Left
);
2452 -- Here we know range is an OK static range
2454 Lo
:= Low_Bound
(Right
);
2455 Hi
:= High_Bound
(Right
);
2458 -- For strings we check that the length of the string expression is
2459 -- compatible with the string subtype if the subtype is constrained,
2460 -- or if unconstrained then the test is always true.
2462 if Is_String_Type
(Etype
(Right
)) then
2463 if not Is_Constrained
(Etype
(Right
)) then
2468 Typlen
: constant Uint
:= String_Type_Len
(Etype
(Right
));
2469 Strlen
: constant Uint
:=
2471 (String_Length
(Strval
(Get_String_Val
(Left
))));
2473 Result
:= (Typlen
= Strlen
);
2477 -- Fold the membership test. We know we have a static range and Lo and
2478 -- Hi are set to the expressions for the end points of this range.
2480 elsif Is_Real_Type
(Etype
(Right
)) then
2482 Leftval
: constant Ureal
:= Expr_Value_R
(Left
);
2485 Result
:= Expr_Value_R
(Lo
) <= Leftval
2486 and then Leftval
<= Expr_Value_R
(Hi
);
2491 Leftval
: constant Uint
:= Expr_Value
(Left
);
2494 Result
:= Expr_Value
(Lo
) <= Leftval
2495 and then Leftval
<= Expr_Value
(Hi
);
2499 if Nkind
(N
) = N_Not_In
then
2500 Result
:= not Result
;
2503 Fold_Uint
(N
, Test
(Result
), True);
2505 Warn_On_Known_Condition
(N
);
2506 end Eval_Membership_Op
;
2508 ------------------------
2509 -- Eval_Named_Integer --
2510 ------------------------
2512 procedure Eval_Named_Integer
(N
: Node_Id
) is
2515 Expr_Value
(Expression
(Declaration_Node
(Entity
(N
)))), True);
2516 end Eval_Named_Integer
;
2518 ---------------------
2519 -- Eval_Named_Real --
2520 ---------------------
2522 procedure Eval_Named_Real
(N
: Node_Id
) is
2525 Expr_Value_R
(Expression
(Declaration_Node
(Entity
(N
)))), True);
2526 end Eval_Named_Real
;
2532 -- Exponentiation is a static functions, so the result is potentially
2533 -- static if both operands are potentially static (RM 4.9(7), 4.9(20)).
2535 procedure Eval_Op_Expon
(N
: Node_Id
) is
2536 Left
: constant Node_Id
:= Left_Opnd
(N
);
2537 Right
: constant Node_Id
:= Right_Opnd
(N
);
2542 -- If not foldable we are done
2544 Test_Expression_Is_Foldable
2545 (N
, Left
, Right
, Stat
, Fold
, CRT_Safe
=> True);
2547 -- Return if not foldable
2553 if Configurable_Run_Time_Mode
and not Stat
then
2557 -- Fold exponentiation operation
2560 Right_Int
: constant Uint
:= Expr_Value
(Right
);
2565 if Is_Integer_Type
(Etype
(Left
)) then
2567 Left_Int
: constant Uint
:= Expr_Value
(Left
);
2571 -- Exponentiation of an integer raises Constraint_Error for a
2572 -- negative exponent (RM 4.5.6).
2574 if Right_Int
< 0 then
2575 Apply_Compile_Time_Constraint_Error
2576 (N
, "integer exponent negative",
2577 CE_Range_Check_Failed
,
2582 if OK_Bits
(N
, Num_Bits
(Left_Int
) * Right_Int
) then
2583 Result
:= Left_Int
** Right_Int
;
2588 if Is_Modular_Integer_Type
(Etype
(N
)) then
2589 Result
:= Result
mod Modulus
(Etype
(N
));
2592 Fold_Uint
(N
, Result
, Stat
);
2600 Left_Real
: constant Ureal
:= Expr_Value_R
(Left
);
2603 -- Cannot have a zero base with a negative exponent
2605 if UR_Is_Zero
(Left_Real
) then
2607 if Right_Int
< 0 then
2608 Apply_Compile_Time_Constraint_Error
2609 (N
, "zero ** negative integer",
2610 CE_Range_Check_Failed
,
2614 Fold_Ureal
(N
, Ureal_0
, Stat
);
2618 Fold_Ureal
(N
, Left_Real
** Right_Int
, Stat
);
2629 -- The not operation is a static functions, so the result is potentially
2630 -- static if the operand is potentially static (RM 4.9(7), 4.9(20)).
2632 procedure Eval_Op_Not
(N
: Node_Id
) is
2633 Right
: constant Node_Id
:= Right_Opnd
(N
);
2638 -- If not foldable we are done
2640 Test_Expression_Is_Foldable
(N
, Right
, Stat
, Fold
);
2646 -- Fold not operation
2649 Rint
: constant Uint
:= Expr_Value
(Right
);
2650 Typ
: constant Entity_Id
:= Etype
(N
);
2653 -- Negation is equivalent to subtracting from the modulus minus one.
2654 -- For a binary modulus this is equivalent to the ones-complement of
2655 -- the original value. For non-binary modulus this is an arbitrary
2656 -- but consistent definition.
2658 if Is_Modular_Integer_Type
(Typ
) then
2659 Fold_Uint
(N
, Modulus
(Typ
) - 1 - Rint
, Stat
);
2662 pragma Assert
(Is_Boolean_Type
(Typ
));
2663 Fold_Uint
(N
, Test
(not Is_True
(Rint
)), Stat
);
2666 Set_Is_Static_Expression
(N
, Stat
);
2670 -------------------------------
2671 -- Eval_Qualified_Expression --
2672 -------------------------------
2674 -- A qualified expression is potentially static if its subtype mark denotes
2675 -- a static subtype and its expression is potentially static (RM 4.9 (11)).
2677 procedure Eval_Qualified_Expression
(N
: Node_Id
) is
2678 Operand
: constant Node_Id
:= Expression
(N
);
2679 Target_Type
: constant Entity_Id
:= Entity
(Subtype_Mark
(N
));
2686 -- Can only fold if target is string or scalar and subtype is static.
2687 -- Also, do not fold if our parent is an allocator (this is because the
2688 -- qualified expression is really part of the syntactic structure of an
2689 -- allocator, and we do not want to end up with something that
2690 -- corresponds to "new 1" where the 1 is the result of folding a
2691 -- qualified expression).
2693 if not Is_Static_Subtype
(Target_Type
)
2694 or else Nkind
(Parent
(N
)) = N_Allocator
2696 Check_Non_Static_Context
(Operand
);
2698 -- If operand is known to raise constraint_error, set the flag on the
2699 -- expression so it does not get optimized away.
2701 if Nkind
(Operand
) = N_Raise_Constraint_Error
then
2702 Set_Raises_Constraint_Error
(N
);
2708 -- If not foldable we are done
2710 Test_Expression_Is_Foldable
(N
, Operand
, Stat
, Fold
);
2715 -- Don't try fold if target type has constraint error bounds
2717 elsif not Is_OK_Static_Subtype
(Target_Type
) then
2718 Set_Raises_Constraint_Error
(N
);
2722 -- Here we will fold, save Print_In_Hex indication
2724 Hex
:= Nkind
(Operand
) = N_Integer_Literal
2725 and then Print_In_Hex
(Operand
);
2727 -- Fold the result of qualification
2729 if Is_Discrete_Type
(Target_Type
) then
2730 Fold_Uint
(N
, Expr_Value
(Operand
), Stat
);
2732 -- Preserve Print_In_Hex indication
2734 if Hex
and then Nkind
(N
) = N_Integer_Literal
then
2735 Set_Print_In_Hex
(N
);
2738 elsif Is_Real_Type
(Target_Type
) then
2739 Fold_Ureal
(N
, Expr_Value_R
(Operand
), Stat
);
2742 Fold_Str
(N
, Strval
(Get_String_Val
(Operand
)), Stat
);
2745 Set_Is_Static_Expression
(N
, False);
2747 Check_String_Literal_Length
(N
, Target_Type
);
2753 -- The expression may be foldable but not static
2755 Set_Is_Static_Expression
(N
, Stat
);
2757 if Is_Out_Of_Range
(N
, Etype
(N
), Assume_Valid
=> True) then
2760 end Eval_Qualified_Expression
;
2762 -----------------------
2763 -- Eval_Real_Literal --
2764 -----------------------
2766 -- Numeric literals are static (RM 4.9(1)), and have already been marked
2767 -- as static by the analyzer. The reason we did it that early is to allow
2768 -- the possibility of turning off the Is_Static_Expression flag after
2769 -- analysis, but before resolution, when integer literals are generated
2770 -- in the expander that do not correspond to static expressions.
2772 procedure Eval_Real_Literal
(N
: Node_Id
) is
2773 PK
: constant Node_Kind
:= Nkind
(Parent
(N
));
2776 -- If the literal appears in a non-expression context and not as part of
2777 -- a number declaration, then it is appearing in a non-static context,
2780 if PK
not in N_Subexpr
and then PK
/= N_Number_Declaration
then
2781 Check_Non_Static_Context
(N
);
2783 end Eval_Real_Literal
;
2785 ------------------------
2786 -- Eval_Relational_Op --
2787 ------------------------
2789 -- Relational operations are static functions, so the result is static if
2790 -- both operands are static (RM 4.9(7), 4.9(20)), except that for strings,
2791 -- the result is never static, even if the operands are.
2793 procedure Eval_Relational_Op
(N
: Node_Id
) is
2794 Left
: constant Node_Id
:= Left_Opnd
(N
);
2795 Right
: constant Node_Id
:= Right_Opnd
(N
);
2796 Typ
: constant Entity_Id
:= Etype
(Left
);
2797 Otype
: Entity_Id
:= Empty
;
2801 -- One special case to deal with first. If we can tell that the result
2802 -- will be false because the lengths of one or more index subtypes are
2803 -- compile time known and different, then we can replace the entire
2804 -- result by False. We only do this for one dimensional arrays, because
2805 -- the case of multi-dimensional arrays is rare and too much trouble. If
2806 -- one of the operands is an illegal aggregate, its type might still be
2807 -- an arbitrary composite type, so nothing to do.
2809 if Is_Array_Type
(Typ
)
2810 and then Typ
/= Any_Composite
2811 and then Number_Dimensions
(Typ
) = 1
2812 and then (Nkind
(N
) = N_Op_Eq
or else Nkind
(N
) = N_Op_Ne
)
2814 if Raises_Constraint_Error
(Left
)
2815 or else Raises_Constraint_Error
(Right
)
2820 -- OK, we have the case where we may be able to do this fold
2822 Length_Mismatch
: declare
2823 procedure Get_Static_Length
(Op
: Node_Id
; Len
: out Uint
);
2824 -- If Op is an expression for a constrained array with a known at
2825 -- compile time length, then Len is set to this (non-negative
2826 -- length). Otherwise Len is set to minus 1.
2828 -----------------------
2829 -- Get_Static_Length --
2830 -----------------------
2832 procedure Get_Static_Length
(Op
: Node_Id
; Len
: out Uint
) is
2836 -- First easy case string literal
2838 if Nkind
(Op
) = N_String_Literal
then
2839 Len
:= UI_From_Int
(String_Length
(Strval
(Op
)));
2843 -- Second easy case, not constrained subtype, so no length
2845 if not Is_Constrained
(Etype
(Op
)) then
2846 Len
:= Uint_Minus_1
;
2852 T
:= Etype
(First_Index
(Etype
(Op
)));
2854 -- The simple case, both bounds are known at compile time
2856 if Is_Discrete_Type
(T
)
2858 Compile_Time_Known_Value
(Type_Low_Bound
(T
))
2860 Compile_Time_Known_Value
(Type_High_Bound
(T
))
2862 Len
:= UI_Max
(Uint_0
,
2863 Expr_Value
(Type_High_Bound
(T
)) -
2864 Expr_Value
(Type_Low_Bound
(T
)) + 1);
2868 -- A more complex case, where the bounds are of the form
2869 -- X [+/- K1] .. X [+/- K2]), where X is an expression that is
2870 -- either A'First or A'Last (with A an entity name), or X is an
2871 -- entity name, and the two X's are the same and K1 and K2 are
2872 -- known at compile time, in this case, the length can also be
2873 -- computed at compile time, even though the bounds are not
2874 -- known. A common case of this is e.g. (X'First .. X'First+5).
2876 Extract_Length
: declare
2877 procedure Decompose_Expr
2879 Ent
: out Entity_Id
;
2880 Kind
: out Character;
2882 -- Given an expression, see if is of the form above,
2883 -- X [+/- K]. If so Ent is set to the entity in X,
2884 -- Kind is 'F','L','E' for 'First/'Last/simple entity,
2885 -- and Cons is the value of K. If the expression is
2886 -- not of the required form, Ent is set to Empty.
2888 --------------------
2889 -- Decompose_Expr --
2890 --------------------
2892 procedure Decompose_Expr
2894 Ent
: out Entity_Id
;
2895 Kind
: out Character;
2901 if Nkind
(Expr
) = N_Op_Add
2902 and then Compile_Time_Known_Value
(Right_Opnd
(Expr
))
2904 Exp
:= Left_Opnd
(Expr
);
2905 Cons
:= Expr_Value
(Right_Opnd
(Expr
));
2907 elsif Nkind
(Expr
) = N_Op_Subtract
2908 and then Compile_Time_Known_Value
(Right_Opnd
(Expr
))
2910 Exp
:= Left_Opnd
(Expr
);
2911 Cons
:= -Expr_Value
(Right_Opnd
(Expr
));
2913 -- If the bound is a constant created to remove side
2914 -- effects, recover original expression to see if it has
2915 -- one of the recognizable forms.
2917 elsif Nkind
(Expr
) = N_Identifier
2918 and then not Comes_From_Source
(Entity
(Expr
))
2919 and then Ekind
(Entity
(Expr
)) = E_Constant
2921 Nkind
(Parent
(Entity
(Expr
))) = N_Object_Declaration
2923 Exp
:= Expression
(Parent
(Entity
(Expr
)));
2924 Decompose_Expr
(Exp
, Ent
, Kind
, Cons
);
2926 -- If original expression includes an entity, create a
2927 -- reference to it for use below.
2929 if Present
(Ent
) then
2930 Exp
:= New_Occurrence_Of
(Ent
, Sloc
(Ent
));
2938 -- At this stage Exp is set to the potential X
2940 if Nkind
(Exp
) = N_Attribute_Reference
then
2941 if Attribute_Name
(Exp
) = Name_First
then
2944 elsif Attribute_Name
(Exp
) = Name_Last
then
2952 Exp
:= Prefix
(Exp
);
2958 if Is_Entity_Name
(Exp
)
2959 and then Present
(Entity
(Exp
))
2961 Ent
:= Entity
(Exp
);
2969 Ent1
, Ent2
: Entity_Id
;
2970 Kind1
, Kind2
: Character;
2971 Cons1
, Cons2
: Uint
;
2973 -- Start of processing for Extract_Length
2977 (Original_Node
(Type_Low_Bound
(T
)), Ent1
, Kind1
, Cons1
);
2979 (Original_Node
(Type_High_Bound
(T
)), Ent2
, Kind2
, Cons2
);
2982 and then Kind1
= Kind2
2983 and then Ent1
= Ent2
2985 Len
:= Cons2
- Cons1
+ 1;
2987 Len
:= Uint_Minus_1
;
2990 end Get_Static_Length
;
2997 -- Start of processing for Length_Mismatch
3000 Get_Static_Length
(Left
, Len_L
);
3001 Get_Static_Length
(Right
, Len_R
);
3003 if Len_L
/= Uint_Minus_1
3004 and then Len_R
/= Uint_Minus_1
3005 and then Len_L
/= Len_R
3007 Fold_Uint
(N
, Test
(Nkind
(N
) = N_Op_Ne
), False);
3008 Warn_On_Known_Condition
(N
);
3011 end Length_Mismatch
;
3015 Is_Static_Expression
: Boolean;
3016 Is_Foldable
: Boolean;
3017 pragma Unreferenced
(Is_Foldable
);
3020 -- Initialize the value of Is_Static_Expression. The value of
3021 -- Is_Foldable returned by Test_Expression_Is_Foldable is not needed
3022 -- since, even when some operand is a variable, we can still perform
3023 -- the static evaluation of the expression in some cases (for
3024 -- example, for a variable of a subtype of Integer we statically
3025 -- know that any value stored in such variable is smaller than
3028 Test_Expression_Is_Foldable
3029 (N
, Left
, Right
, Is_Static_Expression
, Is_Foldable
);
3031 -- Only comparisons of scalars can give static results. In
3032 -- particular, comparisons of strings never yield a static
3033 -- result, even if both operands are static strings.
3035 if not Is_Scalar_Type
(Typ
) then
3036 Is_Static_Expression
:= False;
3037 Set_Is_Static_Expression
(N
, False);
3040 -- For operators on universal numeric types called as functions with
3041 -- an explicit scope, determine appropriate specific numeric type,
3042 -- and diagnose possible ambiguity.
3044 if Is_Universal_Numeric_Type
(Etype
(Left
))
3046 Is_Universal_Numeric_Type
(Etype
(Right
))
3048 Otype
:= Find_Universal_Operator_Type
(N
);
3051 -- For static real type expressions, we cannot use
3052 -- Compile_Time_Compare since it worries about run-time
3053 -- results which are not exact.
3055 if Is_Static_Expression
and then Is_Real_Type
(Typ
) then
3057 Left_Real
: constant Ureal
:= Expr_Value_R
(Left
);
3058 Right_Real
: constant Ureal
:= Expr_Value_R
(Right
);
3062 when N_Op_Eq
=> Result
:= (Left_Real
= Right_Real
);
3063 when N_Op_Ne
=> Result
:= (Left_Real
/= Right_Real
);
3064 when N_Op_Lt
=> Result
:= (Left_Real
< Right_Real
);
3065 when N_Op_Le
=> Result
:= (Left_Real
<= Right_Real
);
3066 when N_Op_Gt
=> Result
:= (Left_Real
> Right_Real
);
3067 when N_Op_Ge
=> Result
:= (Left_Real
>= Right_Real
);
3070 raise Program_Error
;
3073 Fold_Uint
(N
, Test
(Result
), True);
3076 -- For all other cases, we use Compile_Time_Compare to do the compare
3080 CR
: constant Compare_Result
:=
3081 Compile_Time_Compare
3082 (Left
, Right
, Assume_Valid
=> False);
3085 if CR
= Unknown
then
3093 elsif CR
= NE
or else CR
= GT
or else CR
= LT
then
3100 if CR
= NE
or else CR
= GT
or else CR
= LT
then
3111 elsif CR
= EQ
or else CR
= GT
or else CR
= GE
then
3118 if CR
= LT
or else CR
= EQ
or else CR
= LE
then
3129 elsif CR
= EQ
or else CR
= LT
or else CR
= LE
then
3136 if CR
= GT
or else CR
= EQ
or else CR
= GE
then
3145 raise Program_Error
;
3149 Fold_Uint
(N
, Test
(Result
), Is_Static_Expression
);
3153 -- For the case of a folded relational operator on a specific numeric
3154 -- type, freeze operand type now.
3156 if Present
(Otype
) then
3157 Freeze_Before
(N
, Otype
);
3160 Warn_On_Known_Condition
(N
);
3161 end Eval_Relational_Op
;
3167 -- Shift operations are intrinsic operations that can never be static, so
3168 -- the only processing required is to perform the required check for a non
3169 -- static context for the two operands.
3171 -- Actually we could do some compile time evaluation here some time ???
3173 procedure Eval_Shift
(N
: Node_Id
) is
3175 Check_Non_Static_Context
(Left_Opnd
(N
));
3176 Check_Non_Static_Context
(Right_Opnd
(N
));
3179 ------------------------
3180 -- Eval_Short_Circuit --
3181 ------------------------
3183 -- A short circuit operation is potentially static if both operands are
3184 -- potentially static (RM 4.9 (13)).
3186 procedure Eval_Short_Circuit
(N
: Node_Id
) is
3187 Kind
: constant Node_Kind
:= Nkind
(N
);
3188 Left
: constant Node_Id
:= Left_Opnd
(N
);
3189 Right
: constant Node_Id
:= Right_Opnd
(N
);
3192 Rstat
: constant Boolean :=
3193 Is_Static_Expression
(Left
)
3195 Is_Static_Expression
(Right
);
3198 -- Short circuit operations are never static in Ada 83
3200 if Ada_Version
= Ada_83
and then Comes_From_Source
(N
) then
3201 Check_Non_Static_Context
(Left
);
3202 Check_Non_Static_Context
(Right
);
3206 -- Now look at the operands, we can't quite use the normal call to
3207 -- Test_Expression_Is_Foldable here because short circuit operations
3208 -- are a special case, they can still be foldable, even if the right
3209 -- operand raises constraint error.
3211 -- If either operand is Any_Type, just propagate to result and do not
3212 -- try to fold, this prevents cascaded errors.
3214 if Etype
(Left
) = Any_Type
or else Etype
(Right
) = Any_Type
then
3215 Set_Etype
(N
, Any_Type
);
3218 -- If left operand raises constraint error, then replace node N with
3219 -- the raise constraint error node, and we are obviously not foldable.
3220 -- Is_Static_Expression is set from the two operands in the normal way,
3221 -- and we check the right operand if it is in a non-static context.
3223 elsif Raises_Constraint_Error
(Left
) then
3225 Check_Non_Static_Context
(Right
);
3228 Rewrite_In_Raise_CE
(N
, Left
);
3229 Set_Is_Static_Expression
(N
, Rstat
);
3232 -- If the result is not static, then we won't in any case fold
3234 elsif not Rstat
then
3235 Check_Non_Static_Context
(Left
);
3236 Check_Non_Static_Context
(Right
);
3240 -- Here the result is static, note that, unlike the normal processing
3241 -- in Test_Expression_Is_Foldable, we did *not* check above to see if
3242 -- the right operand raises constraint error, that's because it is not
3243 -- significant if the left operand is decisive.
3245 Set_Is_Static_Expression
(N
);
3247 -- It does not matter if the right operand raises constraint error if
3248 -- it will not be evaluated. So deal specially with the cases where
3249 -- the right operand is not evaluated. Note that we will fold these
3250 -- cases even if the right operand is non-static, which is fine, but
3251 -- of course in these cases the result is not potentially static.
3253 Left_Int
:= Expr_Value
(Left
);
3255 if (Kind
= N_And_Then
and then Is_False
(Left_Int
))
3257 (Kind
= N_Or_Else
and then Is_True
(Left_Int
))
3259 Fold_Uint
(N
, Left_Int
, Rstat
);
3263 -- If first operand not decisive, then it does matter if the right
3264 -- operand raises constraint error, since it will be evaluated, so
3265 -- we simply replace the node with the right operand. Note that this
3266 -- properly propagates Is_Static_Expression and Raises_Constraint_Error
3267 -- (both are set to True in Right).
3269 if Raises_Constraint_Error
(Right
) then
3270 Rewrite_In_Raise_CE
(N
, Right
);
3271 Check_Non_Static_Context
(Left
);
3275 -- Otherwise the result depends on the right operand
3277 Fold_Uint
(N
, Expr_Value
(Right
), Rstat
);
3279 end Eval_Short_Circuit
;
3285 -- Slices can never be static, so the only processing required is to check
3286 -- for non-static context if an explicit range is given.
3288 procedure Eval_Slice
(N
: Node_Id
) is
3289 Drange
: constant Node_Id
:= Discrete_Range
(N
);
3291 if Nkind
(Drange
) = N_Range
then
3292 Check_Non_Static_Context
(Low_Bound
(Drange
));
3293 Check_Non_Static_Context
(High_Bound
(Drange
));
3296 -- A slice of the form A (subtype), when the subtype is the index of
3297 -- the type of A, is redundant, the slice can be replaced with A, and
3298 -- this is worth a warning.
3300 if Is_Entity_Name
(Prefix
(N
)) then
3302 E
: constant Entity_Id
:= Entity
(Prefix
(N
));
3303 T
: constant Entity_Id
:= Etype
(E
);
3305 if Ekind
(E
) = E_Constant
3306 and then Is_Array_Type
(T
)
3307 and then Is_Entity_Name
(Drange
)
3309 if Is_Entity_Name
(Original_Node
(First_Index
(T
)))
3310 and then Entity
(Original_Node
(First_Index
(T
)))
3313 if Warn_On_Redundant_Constructs
then
3314 Error_Msg_N
("redundant slice denotes whole array?r?", N
);
3317 -- The following might be a useful optimization???
3319 -- Rewrite (N, New_Occurrence_Of (E, Sloc (N)));
3326 ---------------------------------
3327 -- Eval_Static_Predicate_Check --
3328 ---------------------------------
3330 function Eval_Static_Predicate_Check
3332 Typ
: Entity_Id
) return Boolean
3334 Loc
: constant Source_Ptr
:= Sloc
(N
);
3335 Pred
: constant List_Id
:= Static_Predicate
(Typ
);
3343 -- The static predicate is a list of alternatives in the proper format
3344 -- for an Ada 2012 membership test. If the argument is a literal, the
3345 -- membership test can be evaluated statically. The caller transforms
3346 -- a result of False into a static contraint error.
3348 Test
:= Make_In
(Loc
,
3349 Left_Opnd
=> New_Copy_Tree
(N
),
3350 Right_Opnd
=> Empty
,
3351 Alternatives
=> Pred
);
3352 Analyze_And_Resolve
(Test
, Standard_Boolean
);
3354 return Nkind
(Test
) = N_Identifier
3355 and then Entity
(Test
) = Standard_True
;
3356 end Eval_Static_Predicate_Check
;
3358 -------------------------
3359 -- Eval_String_Literal --
3360 -------------------------
3362 procedure Eval_String_Literal
(N
: Node_Id
) is
3363 Typ
: constant Entity_Id
:= Etype
(N
);
3364 Bas
: constant Entity_Id
:= Base_Type
(Typ
);
3370 -- Nothing to do if error type (handles cases like default expressions
3371 -- or generics where we have not yet fully resolved the type).
3373 if Bas
= Any_Type
or else Bas
= Any_String
then
3377 -- String literals are static if the subtype is static (RM 4.9(2)), so
3378 -- reset the static expression flag (it was set unconditionally in
3379 -- Analyze_String_Literal) if the subtype is non-static. We tell if
3380 -- the subtype is static by looking at the lower bound.
3382 if Ekind
(Typ
) = E_String_Literal_Subtype
then
3383 if not Is_OK_Static_Expression
(String_Literal_Low_Bound
(Typ
)) then
3384 Set_Is_Static_Expression
(N
, False);
3388 -- Here if Etype of string literal is normal Etype (not yet possible,
3389 -- but may be possible in future).
3391 elsif not Is_OK_Static_Expression
3392 (Type_Low_Bound
(Etype
(First_Index
(Typ
))))
3394 Set_Is_Static_Expression
(N
, False);
3398 -- If original node was a type conversion, then result if non-static
3400 if Nkind
(Original_Node
(N
)) = N_Type_Conversion
then
3401 Set_Is_Static_Expression
(N
, False);
3405 -- Test for illegal Ada 95 cases. A string literal is illegal in Ada 95
3406 -- if its bounds are outside the index base type and this index type is
3407 -- static. This can happen in only two ways. Either the string literal
3408 -- is too long, or it is null, and the lower bound is type'First. In
3409 -- either case it is the upper bound that is out of range of the index
3411 if Ada_Version
>= Ada_95
then
3412 if Root_Type
(Bas
) = Standard_String
3414 Root_Type
(Bas
) = Standard_Wide_String
3416 Root_Type
(Bas
) = Standard_Wide_Wide_String
3418 Xtp
:= Standard_Positive
;
3420 Xtp
:= Etype
(First_Index
(Bas
));
3423 if Ekind
(Typ
) = E_String_Literal_Subtype
then
3424 Lo
:= String_Literal_Low_Bound
(Typ
);
3426 Lo
:= Type_Low_Bound
(Etype
(First_Index
(Typ
)));
3429 -- Check for string too long
3431 Len
:= String_Length
(Strval
(N
));
3433 if UI_From_Int
(Len
) > String_Type_Len
(Bas
) then
3435 -- Issue message. Note that this message is a warning if the
3436 -- string literal is not marked as static (happens in some cases
3437 -- of folding strings known at compile time, but not static).
3438 -- Furthermore in such cases, we reword the message, since there
3439 -- is no string literal in the source program.
3441 if Is_Static_Expression
(N
) then
3442 Apply_Compile_Time_Constraint_Error
3443 (N
, "string literal too long for}", CE_Length_Check_Failed
,
3445 Typ
=> First_Subtype
(Bas
));
3447 Apply_Compile_Time_Constraint_Error
3448 (N
, "string value too long for}", CE_Length_Check_Failed
,
3450 Typ
=> First_Subtype
(Bas
),
3454 -- Test for null string not allowed
3457 and then not Is_Generic_Type
(Xtp
)
3459 Expr_Value
(Lo
) = Expr_Value
(Type_Low_Bound
(Base_Type
(Xtp
)))
3461 -- Same specialization of message
3463 if Is_Static_Expression
(N
) then
3464 Apply_Compile_Time_Constraint_Error
3465 (N
, "null string literal not allowed for}",
3466 CE_Length_Check_Failed
,
3468 Typ
=> First_Subtype
(Bas
));
3470 Apply_Compile_Time_Constraint_Error
3471 (N
, "null string value not allowed for}",
3472 CE_Length_Check_Failed
,
3474 Typ
=> First_Subtype
(Bas
),
3479 end Eval_String_Literal
;
3481 --------------------------
3482 -- Eval_Type_Conversion --
3483 --------------------------
3485 -- A type conversion is potentially static if its subtype mark is for a
3486 -- static scalar subtype, and its operand expression is potentially static
3489 procedure Eval_Type_Conversion
(N
: Node_Id
) is
3490 Operand
: constant Node_Id
:= Expression
(N
);
3491 Source_Type
: constant Entity_Id
:= Etype
(Operand
);
3492 Target_Type
: constant Entity_Id
:= Etype
(N
);
3497 function To_Be_Treated_As_Integer
(T
: Entity_Id
) return Boolean;
3498 -- Returns true if type T is an integer type, or if it is a fixed-point
3499 -- type to be treated as an integer (i.e. the flag Conversion_OK is set
3500 -- on the conversion node).
3502 function To_Be_Treated_As_Real
(T
: Entity_Id
) return Boolean;
3503 -- Returns true if type T is a floating-point type, or if it is a
3504 -- fixed-point type that is not to be treated as an integer (i.e. the
3505 -- flag Conversion_OK is not set on the conversion node).
3507 ------------------------------
3508 -- To_Be_Treated_As_Integer --
3509 ------------------------------
3511 function To_Be_Treated_As_Integer
(T
: Entity_Id
) return Boolean is
3515 or else (Is_Fixed_Point_Type
(T
) and then Conversion_OK
(N
));
3516 end To_Be_Treated_As_Integer
;
3518 ---------------------------
3519 -- To_Be_Treated_As_Real --
3520 ---------------------------
3522 function To_Be_Treated_As_Real
(T
: Entity_Id
) return Boolean is
3525 Is_Floating_Point_Type
(T
)
3526 or else (Is_Fixed_Point_Type
(T
) and then not Conversion_OK
(N
));
3527 end To_Be_Treated_As_Real
;
3529 -- Start of processing for Eval_Type_Conversion
3532 -- Cannot fold if target type is non-static or if semantic error
3534 if not Is_Static_Subtype
(Target_Type
) then
3535 Check_Non_Static_Context
(Operand
);
3538 elsif Error_Posted
(N
) then
3542 -- If not foldable we are done
3544 Test_Expression_Is_Foldable
(N
, Operand
, Stat
, Fold
);
3549 -- Don't try fold if target type has constraint error bounds
3551 elsif not Is_OK_Static_Subtype
(Target_Type
) then
3552 Set_Raises_Constraint_Error
(N
);
3556 -- Remaining processing depends on operand types. Note that in the
3557 -- following type test, fixed-point counts as real unless the flag
3558 -- Conversion_OK is set, in which case it counts as integer.
3560 -- Fold conversion, case of string type. The result is not static
3562 if Is_String_Type
(Target_Type
) then
3563 Fold_Str
(N
, Strval
(Get_String_Val
(Operand
)), Static
=> False);
3567 -- Fold conversion, case of integer target type
3569 elsif To_Be_Treated_As_Integer
(Target_Type
) then
3574 -- Integer to integer conversion
3576 if To_Be_Treated_As_Integer
(Source_Type
) then
3577 Result
:= Expr_Value
(Operand
);
3579 -- Real to integer conversion
3582 Result
:= UR_To_Uint
(Expr_Value_R
(Operand
));
3585 -- If fixed-point type (Conversion_OK must be set), then the
3586 -- result is logically an integer, but we must replace the
3587 -- conversion with the corresponding real literal, since the
3588 -- type from a semantic point of view is still fixed-point.
3590 if Is_Fixed_Point_Type
(Target_Type
) then
3592 (N
, UR_From_Uint
(Result
) * Small_Value
(Target_Type
), Stat
);
3594 -- Otherwise result is integer literal
3597 Fold_Uint
(N
, Result
, Stat
);
3601 -- Fold conversion, case of real target type
3603 elsif To_Be_Treated_As_Real
(Target_Type
) then
3608 if To_Be_Treated_As_Real
(Source_Type
) then
3609 Result
:= Expr_Value_R
(Operand
);
3611 Result
:= UR_From_Uint
(Expr_Value
(Operand
));
3614 Fold_Ureal
(N
, Result
, Stat
);
3617 -- Enumeration types
3620 Fold_Uint
(N
, Expr_Value
(Operand
), Stat
);
3623 if Is_Out_Of_Range
(N
, Etype
(N
), Assume_Valid
=> True) then
3627 end Eval_Type_Conversion
;
3633 -- Predefined unary operators are static functions (RM 4.9(20)) and thus
3634 -- are potentially static if the operand is potentially static (RM 4.9(7)).
3636 procedure Eval_Unary_Op
(N
: Node_Id
) is
3637 Right
: constant Node_Id
:= Right_Opnd
(N
);
3638 Otype
: Entity_Id
:= Empty
;
3643 -- If not foldable we are done
3645 Test_Expression_Is_Foldable
(N
, Right
, Stat
, Fold
);
3651 if Etype
(Right
) = Universal_Integer
3653 Etype
(Right
) = Universal_Real
3655 Otype
:= Find_Universal_Operator_Type
(N
);
3658 -- Fold for integer case
3660 if Is_Integer_Type
(Etype
(N
)) then
3662 Rint
: constant Uint
:= Expr_Value
(Right
);
3666 -- In the case of modular unary plus and abs there is no need
3667 -- to adjust the result of the operation since if the original
3668 -- operand was in bounds the result will be in the bounds of the
3669 -- modular type. However, in the case of modular unary minus the
3670 -- result may go out of the bounds of the modular type and needs
3673 if Nkind
(N
) = N_Op_Plus
then
3676 elsif Nkind
(N
) = N_Op_Minus
then
3677 if Is_Modular_Integer_Type
(Etype
(N
)) then
3678 Result
:= (-Rint
) mod Modulus
(Etype
(N
));
3684 pragma Assert
(Nkind
(N
) = N_Op_Abs
);
3688 Fold_Uint
(N
, Result
, Stat
);
3691 -- Fold for real case
3693 elsif Is_Real_Type
(Etype
(N
)) then
3695 Rreal
: constant Ureal
:= Expr_Value_R
(Right
);
3699 if Nkind
(N
) = N_Op_Plus
then
3702 elsif Nkind
(N
) = N_Op_Minus
then
3703 Result
:= UR_Negate
(Rreal
);
3706 pragma Assert
(Nkind
(N
) = N_Op_Abs
);
3707 Result
:= abs Rreal
;
3710 Fold_Ureal
(N
, Result
, Stat
);
3714 -- If the operator was resolved to a specific type, make sure that type
3715 -- is frozen even if the expression is folded into a literal (which has
3716 -- a universal type).
3718 if Present
(Otype
) then
3719 Freeze_Before
(N
, Otype
);
3723 -------------------------------
3724 -- Eval_Unchecked_Conversion --
3725 -------------------------------
3727 -- Unchecked conversions can never be static, so the only required
3728 -- processing is to check for a non-static context for the operand.
3730 procedure Eval_Unchecked_Conversion
(N
: Node_Id
) is
3732 Check_Non_Static_Context
(Expression
(N
));
3733 end Eval_Unchecked_Conversion
;
3735 --------------------
3736 -- Expr_Rep_Value --
3737 --------------------
3739 function Expr_Rep_Value
(N
: Node_Id
) return Uint
is
3740 Kind
: constant Node_Kind
:= Nkind
(N
);
3744 if Is_Entity_Name
(N
) then
3747 -- An enumeration literal that was either in the source or created
3748 -- as a result of static evaluation.
3750 if Ekind
(Ent
) = E_Enumeration_Literal
then
3751 return Enumeration_Rep
(Ent
);
3753 -- A user defined static constant
3756 pragma Assert
(Ekind
(Ent
) = E_Constant
);
3757 return Expr_Rep_Value
(Constant_Value
(Ent
));
3760 -- An integer literal that was either in the source or created as a
3761 -- result of static evaluation.
3763 elsif Kind
= N_Integer_Literal
then
3766 -- A real literal for a fixed-point type. This must be the fixed-point
3767 -- case, either the literal is of a fixed-point type, or it is a bound
3768 -- of a fixed-point type, with type universal real. In either case we
3769 -- obtain the desired value from Corresponding_Integer_Value.
3771 elsif Kind
= N_Real_Literal
then
3772 pragma Assert
(Is_Fixed_Point_Type
(Underlying_Type
(Etype
(N
))));
3773 return Corresponding_Integer_Value
(N
);
3775 -- Peculiar VMS case, if we have xxx'Null_Parameter, return zero
3777 elsif Kind
= N_Attribute_Reference
3778 and then Attribute_Name
(N
) = Name_Null_Parameter
3782 -- Otherwise must be character literal
3785 pragma Assert
(Kind
= N_Character_Literal
);
3788 -- Since Character literals of type Standard.Character don't have any
3789 -- defining character literals built for them, they do not have their
3790 -- Entity set, so just use their Char code. Otherwise for user-
3791 -- defined character literals use their Pos value as usual which is
3792 -- the same as the Rep value.
3795 return Char_Literal_Value
(N
);
3797 return Enumeration_Rep
(Ent
);
3806 function Expr_Value
(N
: Node_Id
) return Uint
is
3807 Kind
: constant Node_Kind
:= Nkind
(N
);
3808 CV_Ent
: CV_Entry
renames CV_Cache
(Nat
(N
) mod CV_Cache_Size
);
3813 -- If already in cache, then we know it's compile time known and we can
3814 -- return the value that was previously stored in the cache since
3815 -- compile time known values cannot change.
3817 if CV_Ent
.N
= N
then
3821 -- Otherwise proceed to test value
3823 if Is_Entity_Name
(N
) then
3826 -- An enumeration literal that was either in the source or created as
3827 -- a result of static evaluation.
3829 if Ekind
(Ent
) = E_Enumeration_Literal
then
3830 Val
:= Enumeration_Pos
(Ent
);
3832 -- A user defined static constant
3835 pragma Assert
(Ekind
(Ent
) = E_Constant
);
3836 Val
:= Expr_Value
(Constant_Value
(Ent
));
3839 -- An integer literal that was either in the source or created as a
3840 -- result of static evaluation.
3842 elsif Kind
= N_Integer_Literal
then
3845 -- A real literal for a fixed-point type. This must be the fixed-point
3846 -- case, either the literal is of a fixed-point type, or it is a bound
3847 -- of a fixed-point type, with type universal real. In either case we
3848 -- obtain the desired value from Corresponding_Integer_Value.
3850 elsif Kind
= N_Real_Literal
then
3852 pragma Assert
(Is_Fixed_Point_Type
(Underlying_Type
(Etype
(N
))));
3853 Val
:= Corresponding_Integer_Value
(N
);
3855 -- Peculiar VMS case, if we have xxx'Null_Parameter, return zero
3857 elsif Kind
= N_Attribute_Reference
3858 and then Attribute_Name
(N
) = Name_Null_Parameter
3862 -- Otherwise must be character literal
3865 pragma Assert
(Kind
= N_Character_Literal
);
3868 -- Since Character literals of type Standard.Character don't
3869 -- have any defining character literals built for them, they
3870 -- do not have their Entity set, so just use their Char
3871 -- code. Otherwise for user-defined character literals use
3872 -- their Pos value as usual.
3875 Val
:= Char_Literal_Value
(N
);
3877 Val
:= Enumeration_Pos
(Ent
);
3881 -- Come here with Val set to value to be returned, set cache
3892 function Expr_Value_E
(N
: Node_Id
) return Entity_Id
is
3893 Ent
: constant Entity_Id
:= Entity
(N
);
3896 if Ekind
(Ent
) = E_Enumeration_Literal
then
3899 pragma Assert
(Ekind
(Ent
) = E_Constant
);
3900 return Expr_Value_E
(Constant_Value
(Ent
));
3908 function Expr_Value_R
(N
: Node_Id
) return Ureal
is
3909 Kind
: constant Node_Kind
:= Nkind
(N
);
3913 if Kind
= N_Real_Literal
then
3916 elsif Kind
= N_Identifier
or else Kind
= N_Expanded_Name
then
3918 pragma Assert
(Ekind
(Ent
) = E_Constant
);
3919 return Expr_Value_R
(Constant_Value
(Ent
));
3921 elsif Kind
= N_Integer_Literal
then
3922 return UR_From_Uint
(Expr_Value
(N
));
3924 -- Peculiar VMS case, if we have xxx'Null_Parameter, return 0.0
3926 elsif Kind
= N_Attribute_Reference
3927 and then Attribute_Name
(N
) = Name_Null_Parameter
3932 -- If we fall through, we have a node that cannot be interpreted as a
3933 -- compile time constant. That is definitely an error.
3935 raise Program_Error
;
3942 function Expr_Value_S
(N
: Node_Id
) return Node_Id
is
3944 if Nkind
(N
) = N_String_Literal
then
3947 pragma Assert
(Ekind
(Entity
(N
)) = E_Constant
);
3948 return Expr_Value_S
(Constant_Value
(Entity
(N
)));
3952 ----------------------------------
3953 -- Find_Universal_Operator_Type --
3954 ----------------------------------
3956 function Find_Universal_Operator_Type
(N
: Node_Id
) return Entity_Id
is
3957 PN
: constant Node_Id
:= Parent
(N
);
3958 Call
: constant Node_Id
:= Original_Node
(N
);
3959 Is_Int
: constant Boolean := Is_Integer_Type
(Etype
(N
));
3961 Is_Fix
: constant Boolean :=
3962 Nkind
(N
) in N_Binary_Op
3963 and then Nkind
(Right_Opnd
(N
)) /= Nkind
(Left_Opnd
(N
));
3964 -- A mixed-mode operation in this context indicates the presence of
3965 -- fixed-point type in the designated package.
3967 Is_Relational
: constant Boolean := Etype
(N
) = Standard_Boolean
;
3968 -- Case where N is a relational (or membership) operator (else it is an
3971 In_Membership
: constant Boolean :=
3972 Nkind
(PN
) in N_Membership_Test
3974 Nkind
(Right_Opnd
(PN
)) = N_Range
3976 Is_Universal_Numeric_Type
(Etype
(Left_Opnd
(PN
)))
3978 Is_Universal_Numeric_Type
3979 (Etype
(Low_Bound
(Right_Opnd
(PN
))))
3981 Is_Universal_Numeric_Type
3982 (Etype
(High_Bound
(Right_Opnd
(PN
))));
3983 -- Case where N is part of a membership test with a universal range
3987 Typ1
: Entity_Id
:= Empty
;
3990 function Is_Mixed_Mode_Operand
(Op
: Node_Id
) return Boolean;
3991 -- Check whether one operand is a mixed-mode operation that requires the
3992 -- presence of a fixed-point type. Given that all operands are universal
3993 -- and have been constant-folded, retrieve the original function call.
3995 ---------------------------
3996 -- Is_Mixed_Mode_Operand --
3997 ---------------------------
3999 function Is_Mixed_Mode_Operand
(Op
: Node_Id
) return Boolean is
4000 Onod
: constant Node_Id
:= Original_Node
(Op
);
4002 return Nkind
(Onod
) = N_Function_Call
4003 and then Present
(Next_Actual
(First_Actual
(Onod
)))
4004 and then Etype
(First_Actual
(Onod
)) /=
4005 Etype
(Next_Actual
(First_Actual
(Onod
)));
4006 end Is_Mixed_Mode_Operand
;
4008 -- Start of processing for Find_Universal_Operator_Type
4011 if Nkind
(Call
) /= N_Function_Call
4012 or else Nkind
(Name
(Call
)) /= N_Expanded_Name
4016 -- There are several cases where the context does not imply the type of
4018 -- - the universal expression appears in a type conversion;
4019 -- - the expression is a relational operator applied to universal
4021 -- - the expression is a membership test with a universal operand
4022 -- and a range with universal bounds.
4024 elsif Nkind
(Parent
(N
)) = N_Type_Conversion
4025 or else Is_Relational
4026 or else In_Membership
4028 Pack
:= Entity
(Prefix
(Name
(Call
)));
4030 -- If the prefix is a package declared elsewhere, iterate over its
4031 -- visible entities, otherwise iterate over all declarations in the
4032 -- designated scope.
4034 if Ekind
(Pack
) = E_Package
4035 and then not In_Open_Scopes
(Pack
)
4037 Priv_E
:= First_Private_Entity
(Pack
);
4043 E
:= First_Entity
(Pack
);
4044 while Present
(E
) and then E
/= Priv_E
loop
4045 if Is_Numeric_Type
(E
)
4046 and then Nkind
(Parent
(E
)) /= N_Subtype_Declaration
4047 and then Comes_From_Source
(E
)
4048 and then Is_Integer_Type
(E
) = Is_Int
4050 (Nkind
(N
) in N_Unary_Op
4051 or else Is_Relational
4052 or else Is_Fixed_Point_Type
(E
) = Is_Fix
)
4057 -- Before emitting an error, check for the presence of a
4058 -- mixed-mode operation that specifies a fixed point type.
4062 (Is_Mixed_Mode_Operand
(Left_Opnd
(N
))
4063 or else Is_Mixed_Mode_Operand
(Right_Opnd
(N
)))
4064 and then Is_Fixed_Point_Type
(E
) /= Is_Fixed_Point_Type
(Typ1
)
4067 if Is_Fixed_Point_Type
(E
) then
4072 -- More than one type of the proper class declared in P
4074 Error_Msg_N
("ambiguous operation", N
);
4075 Error_Msg_Sloc
:= Sloc
(Typ1
);
4076 Error_Msg_N
("\possible interpretation (inherited)#", N
);
4077 Error_Msg_Sloc
:= Sloc
(E
);
4078 Error_Msg_N
("\possible interpretation (inherited)#", N
);
4088 end Find_Universal_Operator_Type
;
4090 --------------------------
4091 -- Flag_Non_Static_Expr --
4092 --------------------------
4094 procedure Flag_Non_Static_Expr
(Msg
: String; Expr
: Node_Id
) is
4096 if Error_Posted
(Expr
) and then not All_Errors_Mode
then
4099 Error_Msg_F
(Msg
, Expr
);
4100 Why_Not_Static
(Expr
);
4102 end Flag_Non_Static_Expr
;
4108 procedure Fold_Str
(N
: Node_Id
; Val
: String_Id
; Static
: Boolean) is
4109 Loc
: constant Source_Ptr
:= Sloc
(N
);
4110 Typ
: constant Entity_Id
:= Etype
(N
);
4113 Rewrite
(N
, Make_String_Literal
(Loc
, Strval
=> Val
));
4115 -- We now have the literal with the right value, both the actual type
4116 -- and the expected type of this literal are taken from the expression
4117 -- that was evaluated. So now we do the Analyze and Resolve.
4119 -- Note that we have to reset Is_Static_Expression both after the
4120 -- analyze step (because Resolve will evaluate the literal, which
4121 -- will cause semantic errors if it is marked as static), and after
4122 -- the Resolve step (since Resolve in some cases resets this flag).
4125 Set_Is_Static_Expression
(N
, Static
);
4128 Set_Is_Static_Expression
(N
, Static
);
4135 procedure Fold_Uint
(N
: Node_Id
; Val
: Uint
; Static
: Boolean) is
4136 Loc
: constant Source_Ptr
:= Sloc
(N
);
4137 Typ
: Entity_Id
:= Etype
(N
);
4141 -- If we are folding a named number, retain the entity in the literal,
4144 if Is_Entity_Name
(N
)
4145 and then Ekind
(Entity
(N
)) = E_Named_Integer
4152 if Is_Private_Type
(Typ
) then
4153 Typ
:= Full_View
(Typ
);
4156 -- For a result of type integer, substitute an N_Integer_Literal node
4157 -- for the result of the compile time evaluation of the expression.
4158 -- For ASIS use, set a link to the original named number when not in
4159 -- a generic context.
4161 if Is_Integer_Type
(Typ
) then
4162 Rewrite
(N
, Make_Integer_Literal
(Loc
, Val
));
4164 Set_Original_Entity
(N
, Ent
);
4166 -- Otherwise we have an enumeration type, and we substitute either
4167 -- an N_Identifier or N_Character_Literal to represent the enumeration
4168 -- literal corresponding to the given value, which must always be in
4169 -- range, because appropriate tests have already been made for this.
4171 else pragma Assert
(Is_Enumeration_Type
(Typ
));
4172 Rewrite
(N
, Get_Enum_Lit_From_Pos
(Etype
(N
), Val
, Loc
));
4175 -- We now have the literal with the right value, both the actual type
4176 -- and the expected type of this literal are taken from the expression
4177 -- that was evaluated. So now we do the Analyze and Resolve.
4179 -- Note that we have to reset Is_Static_Expression both after the
4180 -- analyze step (because Resolve will evaluate the literal, which
4181 -- will cause semantic errors if it is marked as static), and after
4182 -- the Resolve step (since Resolve in some cases sets this flag).
4185 Set_Is_Static_Expression
(N
, Static
);
4188 Set_Is_Static_Expression
(N
, Static
);
4195 procedure Fold_Ureal
(N
: Node_Id
; Val
: Ureal
; Static
: Boolean) is
4196 Loc
: constant Source_Ptr
:= Sloc
(N
);
4197 Typ
: constant Entity_Id
:= Etype
(N
);
4201 -- If we are folding a named number, retain the entity in the literal,
4204 if Is_Entity_Name
(N
)
4205 and then Ekind
(Entity
(N
)) = E_Named_Real
4212 Rewrite
(N
, Make_Real_Literal
(Loc
, Realval
=> Val
));
4214 -- Set link to original named number, for ASIS use
4216 Set_Original_Entity
(N
, Ent
);
4218 -- We now have the literal with the right value, both the actual type
4219 -- and the expected type of this literal are taken from the expression
4220 -- that was evaluated. So now we do the Analyze and Resolve.
4222 -- Note that we have to reset Is_Static_Expression both after the
4223 -- analyze step (because Resolve will evaluate the literal, which
4224 -- will cause semantic errors if it is marked as static), and after
4225 -- the Resolve step (since Resolve in some cases sets this flag).
4228 Set_Is_Static_Expression
(N
, Static
);
4231 Set_Is_Static_Expression
(N
, Static
);
4238 function From_Bits
(B
: Bits
; T
: Entity_Id
) return Uint
is
4242 for J
in 0 .. B
'Last loop
4248 if Non_Binary_Modulus
(T
) then
4249 V
:= V
mod Modulus
(T
);
4255 --------------------
4256 -- Get_String_Val --
4257 --------------------
4259 function Get_String_Val
(N
: Node_Id
) return Node_Id
is
4261 if Nkind
(N
) = N_String_Literal
then
4264 elsif Nkind
(N
) = N_Character_Literal
then
4268 pragma Assert
(Is_Entity_Name
(N
));
4269 return Get_String_Val
(Constant_Value
(Entity
(N
)));
4277 procedure Initialize
is
4279 CV_Cache
:= (others => (Node_High_Bound
, Uint_0
));
4282 --------------------
4283 -- In_Subrange_Of --
4284 --------------------
4286 function In_Subrange_Of
4289 Fixed_Int
: Boolean := False) return Boolean
4298 if T1
= T2
or else Is_Subtype_Of
(T1
, T2
) then
4301 -- Never in range if both types are not scalar. Don't know if this can
4302 -- actually happen, but just in case.
4304 elsif not Is_Scalar_Type
(T1
) or else not Is_Scalar_Type
(T2
) then
4307 -- If T1 has infinities but T2 doesn't have infinities, then T1 is
4308 -- definitely not compatible with T2.
4310 elsif Is_Floating_Point_Type
(T1
)
4311 and then Has_Infinities
(T1
)
4312 and then Is_Floating_Point_Type
(T2
)
4313 and then not Has_Infinities
(T2
)
4318 L1
:= Type_Low_Bound
(T1
);
4319 H1
:= Type_High_Bound
(T1
);
4321 L2
:= Type_Low_Bound
(T2
);
4322 H2
:= Type_High_Bound
(T2
);
4324 -- Check bounds to see if comparison possible at compile time
4326 if Compile_Time_Compare
(L1
, L2
, Assume_Valid
=> True) in Compare_GE
4328 Compile_Time_Compare
(H1
, H2
, Assume_Valid
=> True) in Compare_LE
4333 -- If bounds not comparable at compile time, then the bounds of T2
4334 -- must be compile time known or we cannot answer the query.
4336 if not Compile_Time_Known_Value
(L2
)
4337 or else not Compile_Time_Known_Value
(H2
)
4342 -- If the bounds of T1 are know at compile time then use these
4343 -- ones, otherwise use the bounds of the base type (which are of
4344 -- course always static).
4346 if not Compile_Time_Known_Value
(L1
) then
4347 L1
:= Type_Low_Bound
(Base_Type
(T1
));
4350 if not Compile_Time_Known_Value
(H1
) then
4351 H1
:= Type_High_Bound
(Base_Type
(T1
));
4354 -- Fixed point types should be considered as such only if
4355 -- flag Fixed_Int is set to False.
4357 if Is_Floating_Point_Type
(T1
) or else Is_Floating_Point_Type
(T2
)
4358 or else (Is_Fixed_Point_Type
(T1
) and then not Fixed_Int
)
4359 or else (Is_Fixed_Point_Type
(T2
) and then not Fixed_Int
)
4362 Expr_Value_R
(L2
) <= Expr_Value_R
(L1
)
4364 Expr_Value_R
(H2
) >= Expr_Value_R
(H1
);
4368 Expr_Value
(L2
) <= Expr_Value
(L1
)
4370 Expr_Value
(H2
) >= Expr_Value
(H1
);
4375 -- If any exception occurs, it means that we have some bug in the compiler
4376 -- possibly triggered by a previous error, or by some unforeseen peculiar
4377 -- occurrence. However, this is only an optimization attempt, so there is
4378 -- really no point in crashing the compiler. Instead we just decide, too
4379 -- bad, we can't figure out the answer in this case after all.
4384 -- Debug flag K disables this behavior (useful for debugging)
4386 if Debug_Flag_K
then
4397 function Is_In_Range
4400 Assume_Valid
: Boolean := False;
4401 Fixed_Int
: Boolean := False;
4402 Int_Real
: Boolean := False) return Boolean
4405 return Test_In_Range
(N
, Typ
, Assume_Valid
, Fixed_Int
, Int_Real
)
4413 function Is_Null_Range
(Lo
: Node_Id
; Hi
: Node_Id
) return Boolean is
4414 Typ
: constant Entity_Id
:= Etype
(Lo
);
4417 if not Compile_Time_Known_Value
(Lo
)
4418 or else not Compile_Time_Known_Value
(Hi
)
4423 if Is_Discrete_Type
(Typ
) then
4424 return Expr_Value
(Lo
) > Expr_Value
(Hi
);
4427 pragma Assert
(Is_Real_Type
(Typ
));
4428 return Expr_Value_R
(Lo
) > Expr_Value_R
(Hi
);
4432 -----------------------------
4433 -- Is_OK_Static_Expression --
4434 -----------------------------
4436 function Is_OK_Static_Expression
(N
: Node_Id
) return Boolean is
4438 return Is_Static_Expression
(N
)
4439 and then not Raises_Constraint_Error
(N
);
4440 end Is_OK_Static_Expression
;
4442 ------------------------
4443 -- Is_OK_Static_Range --
4444 ------------------------
4446 -- A static range is a range whose bounds are static expressions, or a
4447 -- Range_Attribute_Reference equivalent to such a range (RM 4.9(26)).
4448 -- We have already converted range attribute references, so we get the
4449 -- "or" part of this rule without needing a special test.
4451 function Is_OK_Static_Range
(N
: Node_Id
) return Boolean is
4453 return Is_OK_Static_Expression
(Low_Bound
(N
))
4454 and then Is_OK_Static_Expression
(High_Bound
(N
));
4455 end Is_OK_Static_Range
;
4457 --------------------------
4458 -- Is_OK_Static_Subtype --
4459 --------------------------
4461 -- Determines if Typ is a static subtype as defined in (RM 4.9(26)) where
4462 -- neither bound raises constraint error when evaluated.
4464 function Is_OK_Static_Subtype
(Typ
: Entity_Id
) return Boolean is
4465 Base_T
: constant Entity_Id
:= Base_Type
(Typ
);
4466 Anc_Subt
: Entity_Id
;
4469 -- First a quick check on the non static subtype flag. As described
4470 -- in further detail in Einfo, this flag is not decisive in all cases,
4471 -- but if it is set, then the subtype is definitely non-static.
4473 if Is_Non_Static_Subtype
(Typ
) then
4477 Anc_Subt
:= Ancestor_Subtype
(Typ
);
4479 if Anc_Subt
= Empty
then
4483 if Is_Generic_Type
(Root_Type
(Base_T
))
4484 or else Is_Generic_Actual_Type
(Base_T
)
4490 elsif Is_String_Type
(Typ
) then
4492 Ekind
(Typ
) = E_String_Literal_Subtype
4494 (Is_OK_Static_Subtype
(Component_Type
(Typ
))
4495 and then Is_OK_Static_Subtype
(Etype
(First_Index
(Typ
))));
4499 elsif Is_Scalar_Type
(Typ
) then
4500 if Base_T
= Typ
then
4504 -- Scalar_Range (Typ) might be an N_Subtype_Indication, so use
4505 -- Get_Type_{Low,High}_Bound.
4507 return Is_OK_Static_Subtype
(Anc_Subt
)
4508 and then Is_OK_Static_Expression
(Type_Low_Bound
(Typ
))
4509 and then Is_OK_Static_Expression
(Type_High_Bound
(Typ
));
4512 -- Types other than string and scalar types are never static
4517 end Is_OK_Static_Subtype
;
4519 ---------------------
4520 -- Is_Out_Of_Range --
4521 ---------------------
4523 function Is_Out_Of_Range
4526 Assume_Valid
: Boolean := False;
4527 Fixed_Int
: Boolean := False;
4528 Int_Real
: Boolean := False) return Boolean
4531 return Test_In_Range
(N
, Typ
, Assume_Valid
, Fixed_Int
, Int_Real
)
4533 end Is_Out_Of_Range
;
4535 ---------------------
4536 -- Is_Static_Range --
4537 ---------------------
4539 -- A static range is a range whose bounds are static expressions, or a
4540 -- Range_Attribute_Reference equivalent to such a range (RM 4.9(26)).
4541 -- We have already converted range attribute references, so we get the
4542 -- "or" part of this rule without needing a special test.
4544 function Is_Static_Range
(N
: Node_Id
) return Boolean is
4546 return Is_Static_Expression
(Low_Bound
(N
))
4547 and then Is_Static_Expression
(High_Bound
(N
));
4548 end Is_Static_Range
;
4550 -----------------------
4551 -- Is_Static_Subtype --
4552 -----------------------
4554 -- Determines if Typ is a static subtype as defined in (RM 4.9(26))
4556 function Is_Static_Subtype
(Typ
: Entity_Id
) return Boolean is
4557 Base_T
: constant Entity_Id
:= Base_Type
(Typ
);
4558 Anc_Subt
: Entity_Id
;
4561 -- First a quick check on the non static subtype flag. As described
4562 -- in further detail in Einfo, this flag is not decisive in all cases,
4563 -- but if it is set, then the subtype is definitely non-static.
4565 if Is_Non_Static_Subtype
(Typ
) then
4569 Anc_Subt
:= Ancestor_Subtype
(Typ
);
4571 if Anc_Subt
= Empty
then
4575 if Is_Generic_Type
(Root_Type
(Base_T
))
4576 or else Is_Generic_Actual_Type
(Base_T
)
4582 elsif Is_String_Type
(Typ
) then
4584 Ekind
(Typ
) = E_String_Literal_Subtype
4585 or else (Is_Static_Subtype
(Component_Type
(Typ
))
4586 and then Is_Static_Subtype
(Etype
(First_Index
(Typ
))));
4590 elsif Is_Scalar_Type
(Typ
) then
4591 if Base_T
= Typ
then
4595 return Is_Static_Subtype
(Anc_Subt
)
4596 and then Is_Static_Expression
(Type_Low_Bound
(Typ
))
4597 and then Is_Static_Expression
(Type_High_Bound
(Typ
));
4600 -- Types other than string and scalar types are never static
4605 end Is_Static_Subtype
;
4607 --------------------
4608 -- Not_Null_Range --
4609 --------------------
4611 function Not_Null_Range
(Lo
: Node_Id
; Hi
: Node_Id
) return Boolean is
4612 Typ
: constant Entity_Id
:= Etype
(Lo
);
4615 if not Compile_Time_Known_Value
(Lo
)
4616 or else not Compile_Time_Known_Value
(Hi
)
4621 if Is_Discrete_Type
(Typ
) then
4622 return Expr_Value
(Lo
) <= Expr_Value
(Hi
);
4625 pragma Assert
(Is_Real_Type
(Typ
));
4627 return Expr_Value_R
(Lo
) <= Expr_Value_R
(Hi
);
4635 function OK_Bits
(N
: Node_Id
; Bits
: Uint
) return Boolean is
4637 -- We allow a maximum of 500,000 bits which seems a reasonable limit
4639 if Bits
< 500_000
then
4643 Error_Msg_N
("static value too large, capacity exceeded", N
);
4652 procedure Out_Of_Range
(N
: Node_Id
) is
4654 -- If we have the static expression case, then this is an illegality
4655 -- in Ada 95 mode, except that in an instance, we never generate an
4656 -- error (if the error is legitimate, it was already diagnosed in the
4657 -- template). The expression to compute the length of a packed array is
4658 -- attached to the array type itself, and deserves a separate message.
4660 if Is_Static_Expression
(N
)
4661 and then not In_Instance
4662 and then not In_Inlined_Body
4663 and then Ada_Version
>= Ada_95
4665 if Nkind
(Parent
(N
)) = N_Defining_Identifier
4666 and then Is_Array_Type
(Parent
(N
))
4667 and then Present
(Packed_Array_Type
(Parent
(N
)))
4668 and then Present
(First_Rep_Item
(Parent
(N
)))
4671 ("length of packed array must not exceed Integer''Last",
4672 First_Rep_Item
(Parent
(N
)));
4673 Rewrite
(N
, Make_Integer_Literal
(Sloc
(N
), Uint_1
));
4676 Apply_Compile_Time_Constraint_Error
4677 (N
, "value not in range of}", CE_Range_Check_Failed
);
4680 -- Here we generate a warning for the Ada 83 case, or when we are in an
4681 -- instance, or when we have a non-static expression case.
4684 Apply_Compile_Time_Constraint_Error
4685 (N
, "value not in range of}??", CE_Range_Check_Failed
);
4689 ----------------------
4690 -- Predicates_Match --
4691 ----------------------
4693 function Predicates_Match
(T1
, T2
: Entity_Id
) return Boolean is
4698 if Ada_Version
< Ada_2012
then
4701 -- Both types must have predicates or lack them
4703 elsif Has_Predicates
(T1
) /= Has_Predicates
(T2
) then
4706 -- Check matching predicates
4711 (T1
, Name_Static_Predicate
, Check_Parents
=> False);
4714 (T2
, Name_Static_Predicate
, Check_Parents
=> False);
4716 -- Subtypes statically match if the predicate comes from the
4717 -- same declaration, which can only happen if one is a subtype
4718 -- of the other and has no explicit predicate.
4720 -- Suppress warnings on order of actuals, which is otherwise
4721 -- triggered by one of the two calls below.
4723 pragma Warnings
(Off
);
4724 return Pred1
= Pred2
4725 or else (No
(Pred1
) and then Is_Subtype_Of
(T1
, T2
))
4726 or else (No
(Pred2
) and then Is_Subtype_Of
(T2
, T1
));
4727 pragma Warnings
(On
);
4729 end Predicates_Match
;
4731 -------------------------
4732 -- Rewrite_In_Raise_CE --
4733 -------------------------
4735 procedure Rewrite_In_Raise_CE
(N
: Node_Id
; Exp
: Node_Id
) is
4736 Typ
: constant Entity_Id
:= Etype
(N
);
4739 -- If we want to raise CE in the condition of a N_Raise_CE node
4740 -- we may as well get rid of the condition.
4742 if Present
(Parent
(N
))
4743 and then Nkind
(Parent
(N
)) = N_Raise_Constraint_Error
4745 Set_Condition
(Parent
(N
), Empty
);
4747 -- If the expression raising CE is a N_Raise_CE node, we can use that
4748 -- one. We just preserve the type of the context.
4750 elsif Nkind
(Exp
) = N_Raise_Constraint_Error
then
4754 -- Else build an explcit N_Raise_CE
4758 Make_Raise_Constraint_Error
(Sloc
(Exp
),
4759 Reason
=> CE_Range_Check_Failed
));
4760 Set_Raises_Constraint_Error
(N
);
4763 end Rewrite_In_Raise_CE
;
4765 ---------------------
4766 -- String_Type_Len --
4767 ---------------------
4769 function String_Type_Len
(Stype
: Entity_Id
) return Uint
is
4770 NT
: constant Entity_Id
:= Etype
(First_Index
(Stype
));
4774 if Is_OK_Static_Subtype
(NT
) then
4777 T
:= Base_Type
(NT
);
4780 return Expr_Value
(Type_High_Bound
(T
)) -
4781 Expr_Value
(Type_Low_Bound
(T
)) + 1;
4782 end String_Type_Len
;
4784 ------------------------------------
4785 -- Subtypes_Statically_Compatible --
4786 ------------------------------------
4788 function Subtypes_Statically_Compatible
4791 Formal_Derived_Matching
: Boolean := False) return Boolean
4796 if Is_Scalar_Type
(T1
) then
4798 -- Definitely compatible if we match
4800 if Subtypes_Statically_Match
(T1
, T2
) then
4803 -- If either subtype is nonstatic then they're not compatible
4805 elsif not Is_Static_Subtype
(T1
)
4807 not Is_Static_Subtype
(T2
)
4811 -- If either type has constraint error bounds, then consider that
4812 -- they match to avoid junk cascaded errors here.
4814 elsif not Is_OK_Static_Subtype
(T1
)
4815 or else not Is_OK_Static_Subtype
(T2
)
4819 -- Base types must match, but we don't check that (should we???) but
4820 -- we do at least check that both types are real, or both types are
4823 elsif Is_Real_Type
(T1
) /= Is_Real_Type
(T2
) then
4826 -- Here we check the bounds
4830 LB1
: constant Node_Id
:= Type_Low_Bound
(T1
);
4831 HB1
: constant Node_Id
:= Type_High_Bound
(T1
);
4832 LB2
: constant Node_Id
:= Type_Low_Bound
(T2
);
4833 HB2
: constant Node_Id
:= Type_High_Bound
(T2
);
4836 if Is_Real_Type
(T1
) then
4838 (Expr_Value_R
(LB1
) > Expr_Value_R
(HB1
))
4840 (Expr_Value_R
(LB2
) <= Expr_Value_R
(LB1
)
4842 Expr_Value_R
(HB1
) <= Expr_Value_R
(HB2
));
4846 (Expr_Value
(LB1
) > Expr_Value
(HB1
))
4848 (Expr_Value
(LB2
) <= Expr_Value
(LB1
)
4850 Expr_Value
(HB1
) <= Expr_Value
(HB2
));
4857 elsif Is_Access_Type
(T1
) then
4858 return (not Is_Constrained
(T2
)
4859 or else (Subtypes_Statically_Match
4860 (Designated_Type
(T1
), Designated_Type
(T2
))))
4861 and then not (Can_Never_Be_Null
(T2
)
4862 and then not Can_Never_Be_Null
(T1
));
4867 return (Is_Composite_Type
(T1
) and then not Is_Constrained
(T2
))
4868 or else Subtypes_Statically_Match
(T1
, T2
, Formal_Derived_Matching
);
4870 end Subtypes_Statically_Compatible
;
4872 -------------------------------
4873 -- Subtypes_Statically_Match --
4874 -------------------------------
4876 -- Subtypes statically match if they have statically matching constraints
4877 -- (RM 4.9.1(2)). Constraints statically match if there are none, or if
4878 -- they are the same identical constraint, or if they are static and the
4879 -- values match (RM 4.9.1(1)).
4881 -- In addition, in GNAT, the object size (Esize) values of the types must
4882 -- match if they are set (unless checking an actual for a formal derived
4883 -- type). The use of 'Object_Size can cause this to be false even if the
4884 -- types would otherwise match in the RM sense.
4886 function Subtypes_Statically_Match
4889 Formal_Derived_Matching
: Boolean := False) return Boolean
4892 -- A type always statically matches itself
4897 -- No match if sizes different (from use of 'Object_Size). This test
4898 -- is excluded if Formal_Derived_Matching is True, as the base types
4899 -- can be different in that case and typically have different sizes
4900 -- (and Esizes can be set when Frontend_Layout_On_Target is True).
4902 elsif not Formal_Derived_Matching
4903 and then Known_Static_Esize
(T1
)
4904 and then Known_Static_Esize
(T2
)
4905 and then Esize
(T1
) /= Esize
(T2
)
4909 -- No match if predicates do not match
4911 elsif not Predicates_Match
(T1
, T2
) then
4916 elsif Is_Scalar_Type
(T1
) then
4918 -- Base types must be the same
4920 if Base_Type
(T1
) /= Base_Type
(T2
) then
4924 -- A constrained numeric subtype never matches an unconstrained
4925 -- subtype, i.e. both types must be constrained or unconstrained.
4927 -- To understand the requirement for this test, see RM 4.9.1(1).
4928 -- As is made clear in RM 3.5.4(11), type Integer, for example is
4929 -- a constrained subtype with constraint bounds matching the bounds
4930 -- of its corresponding unconstrained base type. In this situation,
4931 -- Integer and Integer'Base do not statically match, even though
4932 -- they have the same bounds.
4934 -- We only apply this test to types in Standard and types that appear
4935 -- in user programs. That way, we do not have to be too careful about
4936 -- setting Is_Constrained right for Itypes.
4938 if Is_Numeric_Type
(T1
)
4939 and then (Is_Constrained
(T1
) /= Is_Constrained
(T2
))
4940 and then (Scope
(T1
) = Standard_Standard
4941 or else Comes_From_Source
(T1
))
4942 and then (Scope
(T2
) = Standard_Standard
4943 or else Comes_From_Source
(T2
))
4947 -- A generic scalar type does not statically match its base type
4948 -- (AI-311). In this case we make sure that the formals, which are
4949 -- first subtypes of their bases, are constrained.
4951 elsif Is_Generic_Type
(T1
)
4952 and then Is_Generic_Type
(T2
)
4953 and then (Is_Constrained
(T1
) /= Is_Constrained
(T2
))
4958 -- If there was an error in either range, then just assume the types
4959 -- statically match to avoid further junk errors.
4961 if No
(Scalar_Range
(T1
)) or else No
(Scalar_Range
(T2
))
4962 or else Error_Posted
(Scalar_Range
(T1
))
4963 or else Error_Posted
(Scalar_Range
(T2
))
4968 -- Otherwise both types have bounds that can be compared
4971 LB1
: constant Node_Id
:= Type_Low_Bound
(T1
);
4972 HB1
: constant Node_Id
:= Type_High_Bound
(T1
);
4973 LB2
: constant Node_Id
:= Type_Low_Bound
(T2
);
4974 HB2
: constant Node_Id
:= Type_High_Bound
(T2
);
4977 -- If the bounds are the same tree node, then match (common case)
4979 if LB1
= LB2
and then HB1
= HB2
then
4982 -- Otherwise bounds must be static and identical value
4985 if not Is_Static_Subtype
(T1
)
4986 or else not Is_Static_Subtype
(T2
)
4990 -- If either type has constraint error bounds, then say that
4991 -- they match to avoid junk cascaded errors here.
4993 elsif not Is_OK_Static_Subtype
(T1
)
4994 or else not Is_OK_Static_Subtype
(T2
)
4998 elsif Is_Real_Type
(T1
) then
5000 (Expr_Value_R
(LB1
) = Expr_Value_R
(LB2
))
5002 (Expr_Value_R
(HB1
) = Expr_Value_R
(HB2
));
5006 Expr_Value
(LB1
) = Expr_Value
(LB2
)
5008 Expr_Value
(HB1
) = Expr_Value
(HB2
);
5013 -- Type with discriminants
5015 elsif Has_Discriminants
(T1
) or else Has_Discriminants
(T2
) then
5017 -- Because of view exchanges in multiple instantiations, conformance
5018 -- checking might try to match a partial view of a type with no
5019 -- discriminants with a full view that has defaulted discriminants.
5020 -- In such a case, use the discriminant constraint of the full view,
5021 -- which must exist because we know that the two subtypes have the
5024 if Has_Discriminants
(T1
) /= Has_Discriminants
(T2
) then
5026 if Is_Private_Type
(T2
)
5027 and then Present
(Full_View
(T2
))
5028 and then Has_Discriminants
(Full_View
(T2
))
5030 return Subtypes_Statically_Match
(T1
, Full_View
(T2
));
5032 elsif Is_Private_Type
(T1
)
5033 and then Present
(Full_View
(T1
))
5034 and then Has_Discriminants
(Full_View
(T1
))
5036 return Subtypes_Statically_Match
(Full_View
(T1
), T2
);
5047 DL1
: constant Elist_Id
:= Discriminant_Constraint
(T1
);
5048 DL2
: constant Elist_Id
:= Discriminant_Constraint
(T2
);
5056 elsif Is_Constrained
(T1
) /= Is_Constrained
(T2
) then
5060 -- Now loop through the discriminant constraints
5062 -- Note: the guard here seems necessary, since it is possible at
5063 -- least for DL1 to be No_Elist. Not clear this is reasonable ???
5065 if Present
(DL1
) and then Present
(DL2
) then
5066 DA1
:= First_Elmt
(DL1
);
5067 DA2
:= First_Elmt
(DL2
);
5068 while Present
(DA1
) loop
5070 Expr1
: constant Node_Id
:= Node
(DA1
);
5071 Expr2
: constant Node_Id
:= Node
(DA2
);
5074 if not Is_Static_Expression
(Expr1
)
5075 or else not Is_Static_Expression
(Expr2
)
5079 -- If either expression raised a constraint error,
5080 -- consider the expressions as matching, since this
5081 -- helps to prevent cascading errors.
5083 elsif Raises_Constraint_Error
(Expr1
)
5084 or else Raises_Constraint_Error
(Expr2
)
5088 elsif Expr_Value
(Expr1
) /= Expr_Value
(Expr2
) then
5101 -- A definite type does not match an indefinite or classwide type.
5102 -- However, a generic type with unknown discriminants may be
5103 -- instantiated with a type with no discriminants, and conformance
5104 -- checking on an inherited operation may compare the actual with the
5105 -- subtype that renames it in the instance.
5108 Has_Unknown_Discriminants
(T1
) /= Has_Unknown_Discriminants
(T2
)
5111 Is_Generic_Actual_Type
(T1
) or else Is_Generic_Actual_Type
(T2
);
5115 elsif Is_Array_Type
(T1
) then
5117 -- If either subtype is unconstrained then both must be, and if both
5118 -- are unconstrained then no further checking is needed.
5120 if not Is_Constrained
(T1
) or else not Is_Constrained
(T2
) then
5121 return not (Is_Constrained
(T1
) or else Is_Constrained
(T2
));
5124 -- Both subtypes are constrained, so check that the index subtypes
5125 -- statically match.
5128 Index1
: Node_Id
:= First_Index
(T1
);
5129 Index2
: Node_Id
:= First_Index
(T2
);
5132 while Present
(Index1
) loop
5134 Subtypes_Statically_Match
(Etype
(Index1
), Etype
(Index2
))
5139 Next_Index
(Index1
);
5140 Next_Index
(Index2
);
5146 elsif Is_Access_Type
(T1
) then
5147 if Can_Never_Be_Null
(T1
) /= Can_Never_Be_Null
(T2
) then
5150 elsif Ekind_In
(T1
, E_Access_Subprogram_Type
,
5151 E_Anonymous_Access_Subprogram_Type
)
5155 (Designated_Type
(T1
),
5156 Designated_Type
(T2
));
5159 Subtypes_Statically_Match
5160 (Designated_Type
(T1
),
5161 Designated_Type
(T2
))
5162 and then Is_Access_Constant
(T1
) = Is_Access_Constant
(T2
);
5165 -- All other types definitely match
5170 end Subtypes_Statically_Match
;
5176 function Test
(Cond
: Boolean) return Uint
is
5185 ---------------------------------
5186 -- Test_Expression_Is_Foldable --
5187 ---------------------------------
5191 procedure Test_Expression_Is_Foldable
5201 if Debug_Flag_Dot_F
and then In_Extended_Main_Source_Unit
(N
) then
5205 -- If operand is Any_Type, just propagate to result and do not
5206 -- try to fold, this prevents cascaded errors.
5208 if Etype
(Op1
) = Any_Type
then
5209 Set_Etype
(N
, Any_Type
);
5212 -- If operand raises constraint error, then replace node N with the
5213 -- raise constraint error node, and we are obviously not foldable.
5214 -- Note that this replacement inherits the Is_Static_Expression flag
5215 -- from the operand.
5217 elsif Raises_Constraint_Error
(Op1
) then
5218 Rewrite_In_Raise_CE
(N
, Op1
);
5221 -- If the operand is not static, then the result is not static, and
5222 -- all we have to do is to check the operand since it is now known
5223 -- to appear in a non-static context.
5225 elsif not Is_Static_Expression
(Op1
) then
5226 Check_Non_Static_Context
(Op1
);
5227 Fold
:= Compile_Time_Known_Value
(Op1
);
5230 -- An expression of a formal modular type is not foldable because
5231 -- the modulus is unknown.
5233 elsif Is_Modular_Integer_Type
(Etype
(Op1
))
5234 and then Is_Generic_Type
(Etype
(Op1
))
5236 Check_Non_Static_Context
(Op1
);
5239 -- Here we have the case of an operand whose type is OK, which is
5240 -- static, and which does not raise constraint error, we can fold.
5243 Set_Is_Static_Expression
(N
);
5247 end Test_Expression_Is_Foldable
;
5251 procedure Test_Expression_Is_Foldable
5257 CRT_Safe
: Boolean := False)
5259 Rstat
: constant Boolean := Is_Static_Expression
(Op1
)
5260 and then Is_Static_Expression
(Op2
);
5266 -- Inhibit folding if -gnatd.f flag set
5268 if Debug_Flag_Dot_F
and then In_Extended_Main_Source_Unit
(N
) then
5272 -- If either operand is Any_Type, just propagate to result and
5273 -- do not try to fold, this prevents cascaded errors.
5275 if Etype
(Op1
) = Any_Type
or else Etype
(Op2
) = Any_Type
then
5276 Set_Etype
(N
, Any_Type
);
5279 -- If left operand raises constraint error, then replace node N with the
5280 -- Raise_Constraint_Error node, and we are obviously not foldable.
5281 -- Is_Static_Expression is set from the two operands in the normal way,
5282 -- and we check the right operand if it is in a non-static context.
5284 elsif Raises_Constraint_Error
(Op1
) then
5286 Check_Non_Static_Context
(Op2
);
5289 Rewrite_In_Raise_CE
(N
, Op1
);
5290 Set_Is_Static_Expression
(N
, Rstat
);
5293 -- Similar processing for the case of the right operand. Note that we
5294 -- don't use this routine for the short-circuit case, so we do not have
5295 -- to worry about that special case here.
5297 elsif Raises_Constraint_Error
(Op2
) then
5299 Check_Non_Static_Context
(Op1
);
5302 Rewrite_In_Raise_CE
(N
, Op2
);
5303 Set_Is_Static_Expression
(N
, Rstat
);
5306 -- Exclude expressions of a generic modular type, as above
5308 elsif Is_Modular_Integer_Type
(Etype
(Op1
))
5309 and then Is_Generic_Type
(Etype
(Op1
))
5311 Check_Non_Static_Context
(Op1
);
5314 -- If result is not static, then check non-static contexts on operands
5315 -- since one of them may be static and the other one may not be static.
5317 elsif not Rstat
then
5318 Check_Non_Static_Context
(Op1
);
5319 Check_Non_Static_Context
(Op2
);
5322 Fold
:= CRT_Safe_Compile_Time_Known_Value
(Op1
)
5323 and then CRT_Safe_Compile_Time_Known_Value
(Op2
);
5325 Fold
:= Compile_Time_Known_Value
(Op1
)
5326 and then Compile_Time_Known_Value
(Op2
);
5331 -- Else result is static and foldable. Both operands are static, and
5332 -- neither raises constraint error, so we can definitely fold.
5335 Set_Is_Static_Expression
(N
);
5340 end Test_Expression_Is_Foldable
;
5346 function Test_In_Range
5349 Assume_Valid
: Boolean;
5350 Fixed_Int
: Boolean;
5351 Int_Real
: Boolean) return Range_Membership
5356 pragma Warnings
(Off
, Assume_Valid
);
5357 -- For now Assume_Valid is unreferenced since the current implementation
5358 -- always returns Unknown if N is not a compile time known value, but we
5359 -- keep the parameter to allow for future enhancements in which we try
5360 -- to get the information in the variable case as well.
5363 -- Universal types have no range limits, so always in range
5365 if Typ
= Universal_Integer
or else Typ
= Universal_Real
then
5368 -- Never known if not scalar type. Don't know if this can actually
5369 -- happen, but our spec allows it, so we must check.
5371 elsif not Is_Scalar_Type
(Typ
) then
5374 -- Never known if this is a generic type, since the bounds of generic
5375 -- types are junk. Note that if we only checked for static expressions
5376 -- (instead of compile time known values) below, we would not need this
5377 -- check, because values of a generic type can never be static, but they
5378 -- can be known at compile time.
5380 elsif Is_Generic_Type
(Typ
) then
5383 -- Never known unless we have a compile time known value
5385 elsif not Compile_Time_Known_Value
(N
) then
5388 -- General processing with a known compile time value
5399 Lo
:= Type_Low_Bound
(Typ
);
5400 Hi
:= Type_High_Bound
(Typ
);
5402 LB_Known
:= Compile_Time_Known_Value
(Lo
);
5403 HB_Known
:= Compile_Time_Known_Value
(Hi
);
5405 -- Fixed point types should be considered as such only if flag
5406 -- Fixed_Int is set to False.
5408 if Is_Floating_Point_Type
(Typ
)
5409 or else (Is_Fixed_Point_Type
(Typ
) and then not Fixed_Int
)
5412 Valr
:= Expr_Value_R
(N
);
5414 if LB_Known
and HB_Known
then
5415 if Valr
>= Expr_Value_R
(Lo
)
5417 Valr
<= Expr_Value_R
(Hi
)
5421 return Out_Of_Range
;
5424 elsif (LB_Known
and then Valr
< Expr_Value_R
(Lo
))
5426 (HB_Known
and then Valr
> Expr_Value_R
(Hi
))
5428 return Out_Of_Range
;
5435 Val
:= Expr_Value
(N
);
5437 if LB_Known
and HB_Known
then
5438 if Val
>= Expr_Value
(Lo
)
5440 Val
<= Expr_Value
(Hi
)
5444 return Out_Of_Range
;
5447 elsif (LB_Known
and then Val
< Expr_Value
(Lo
))
5449 (HB_Known
and then Val
> Expr_Value
(Hi
))
5451 return Out_Of_Range
;
5465 procedure To_Bits
(U
: Uint
; B
: out Bits
) is
5467 for J
in 0 .. B
'Last loop
5468 B
(J
) := (U
/ (2 ** J
)) mod 2 /= 0;
5472 --------------------
5473 -- Why_Not_Static --
5474 --------------------
5476 procedure Why_Not_Static
(Expr
: Node_Id
) is
5477 N
: constant Node_Id
:= Original_Node
(Expr
);
5481 procedure Why_Not_Static_List
(L
: List_Id
);
5482 -- A version that can be called on a list of expressions. Finds all
5483 -- non-static violations in any element of the list.
5485 -------------------------
5486 -- Why_Not_Static_List --
5487 -------------------------
5489 procedure Why_Not_Static_List
(L
: List_Id
) is
5493 if Is_Non_Empty_List
(L
) then
5495 while Present
(N
) loop
5500 end Why_Not_Static_List
;
5502 -- Start of processing for Why_Not_Static
5505 -- If in ACATS mode (debug flag 2), then suppress all these messages,
5506 -- this avoids massive updates to the ACATS base line.
5508 if Debug_Flag_2
then
5512 -- Ignore call on error or empty node
5514 if No
(Expr
) or else Nkind
(Expr
) = N_Error
then
5518 -- Preprocessing for sub expressions
5520 if Nkind
(Expr
) in N_Subexpr
then
5522 -- Nothing to do if expression is static
5524 if Is_OK_Static_Expression
(Expr
) then
5528 -- Test for constraint error raised
5530 if Raises_Constraint_Error
(Expr
) then
5532 ("\expression raises exception, cannot be static " &
5537 -- If no type, then something is pretty wrong, so ignore
5539 Typ
:= Etype
(Expr
);
5545 -- Type must be scalar or string type (but allow Bignum, since this
5546 -- is really a scalar type from our point of view in this diagnosis).
5548 if not Is_Scalar_Type
(Typ
)
5549 and then not Is_String_Type
(Typ
)
5550 and then not Is_RTE
(Typ
, RE_Bignum
)
5553 ("\static expression must have scalar or string type " &
5559 -- If we got through those checks, test particular node kind
5565 when N_Expanded_Name | N_Identifier | N_Operator_Symbol
=>
5568 if Is_Named_Number
(E
) then
5571 elsif Ekind
(E
) = E_Constant
then
5573 -- One case we can give a metter message is when we have a
5574 -- string literal created by concatenating an aggregate with
5575 -- an others expression.
5577 Entity_Case
: declare
5578 CV
: constant Node_Id
:= Constant_Value
(E
);
5579 CO
: constant Node_Id
:= Original_Node
(CV
);
5581 function Is_Aggregate
(N
: Node_Id
) return Boolean;
5582 -- See if node N came from an others aggregate, if so
5583 -- return True and set Error_Msg_Sloc to aggregate.
5589 function Is_Aggregate
(N
: Node_Id
) return Boolean is
5591 if Nkind
(Original_Node
(N
)) = N_Aggregate
then
5592 Error_Msg_Sloc
:= Sloc
(Original_Node
(N
));
5594 elsif Is_Entity_Name
(N
)
5595 and then Ekind
(Entity
(N
)) = E_Constant
5597 Nkind
(Original_Node
(Constant_Value
(Entity
(N
)))) =
5601 Sloc
(Original_Node
(Constant_Value
(Entity
(N
))));
5608 -- Start of processing for Entity_Case
5611 if Is_Aggregate
(CV
)
5612 or else (Nkind
(CO
) = N_Op_Concat
5613 and then (Is_Aggregate
(Left_Opnd
(CO
))
5615 Is_Aggregate
(Right_Opnd
(CO
))))
5617 Error_Msg_N
("\aggregate (#) is never static", N
);
5619 elsif No
(CV
) or else not Is_Static_Expression
(CV
) then
5621 ("\& is not a static constant (RM 4.9(5))", N
, E
);
5627 ("\& is not static constant or named number "
5628 & "(RM 4.9(5))", N
, E
);
5633 when N_Binary_Op | N_Short_Circuit | N_Membership_Test
=>
5634 if Nkind
(N
) in N_Op_Shift
then
5636 ("\shift functions are never static (RM 4.9(6,18))", N
);
5639 Why_Not_Static
(Left_Opnd
(N
));
5640 Why_Not_Static
(Right_Opnd
(N
));
5646 Why_Not_Static
(Right_Opnd
(N
));
5648 -- Attribute reference
5650 when N_Attribute_Reference
=>
5651 Why_Not_Static_List
(Expressions
(N
));
5653 E
:= Etype
(Prefix
(N
));
5655 if E
= Standard_Void_Type
then
5659 -- Special case non-scalar'Size since this is a common error
5661 if Attribute_Name
(N
) = Name_Size
then
5663 ("\size attribute is only static for static scalar type "
5664 & "(RM 4.9(7,8))", N
);
5668 elsif Is_Array_Type
(E
) then
5669 if Attribute_Name
(N
) /= Name_First
5671 Attribute_Name
(N
) /= Name_Last
5673 Attribute_Name
(N
) /= Name_Length
5676 ("\static array attribute must be Length, First, or Last "
5677 & "(RM 4.9(8))", N
);
5679 -- Since we know the expression is not-static (we already
5680 -- tested for this, must mean array is not static).
5684 ("\prefix is non-static array (RM 4.9(8))", Prefix
(N
));
5689 -- Special case generic types, since again this is a common source
5692 elsif Is_Generic_Actual_Type
(E
)
5697 ("\attribute of generic type is never static "
5698 & "(RM 4.9(7,8))", N
);
5700 elsif Is_Static_Subtype
(E
) then
5703 elsif Is_Scalar_Type
(E
) then
5705 ("\prefix type for attribute is not static scalar subtype "
5706 & "(RM 4.9(7))", N
);
5710 ("\static attribute must apply to array/scalar type "
5711 & "(RM 4.9(7,8))", N
);
5716 when N_String_Literal
=>
5718 ("\subtype of string literal is non-static (RM 4.9(4))", N
);
5720 -- Explicit dereference
5722 when N_Explicit_Dereference
=>
5724 ("\explicit dereference is never static (RM 4.9)", N
);
5728 when N_Function_Call
=>
5729 Why_Not_Static_List
(Parameter_Associations
(N
));
5731 -- Complain about non-static function call unless we have Bignum
5732 -- which means that the underlying expression is really some
5733 -- scalar arithmetic operation.
5735 if not Is_RTE
(Typ
, RE_Bignum
) then
5736 Error_Msg_N
("\non-static function call (RM 4.9(6,18))", N
);
5739 -- Parameter assocation (test actual parameter)
5741 when N_Parameter_Association
=>
5742 Why_Not_Static
(Explicit_Actual_Parameter
(N
));
5744 -- Indexed component
5746 when N_Indexed_Component
=>
5747 Error_Msg_N
("\indexed component is never static (RM 4.9)", N
);
5751 when N_Procedure_Call_Statement
=>
5752 Error_Msg_N
("\procedure call is never static (RM 4.9)", N
);
5754 -- Qualified expression (test expression)
5756 when N_Qualified_Expression
=>
5757 Why_Not_Static
(Expression
(N
));
5761 when N_Aggregate | N_Extension_Aggregate
=>
5762 Error_Msg_N
("\an aggregate is never static (RM 4.9)", N
);
5767 Why_Not_Static
(Low_Bound
(N
));
5768 Why_Not_Static
(High_Bound
(N
));
5770 -- Range constraint, test range expression
5772 when N_Range_Constraint
=>
5773 Why_Not_Static
(Range_Expression
(N
));
5775 -- Subtype indication, test constraint
5777 when N_Subtype_Indication
=>
5778 Why_Not_Static
(Constraint
(N
));
5780 -- Selected component
5782 when N_Selected_Component
=>
5783 Error_Msg_N
("\selected component is never static (RM 4.9)", N
);
5788 Error_Msg_N
("\slice is never static (RM 4.9)", N
);
5790 when N_Type_Conversion
=>
5791 Why_Not_Static
(Expression
(N
));
5793 if not Is_Scalar_Type
(Entity
(Subtype_Mark
(N
)))
5794 or else not Is_Static_Subtype
(Entity
(Subtype_Mark
(N
)))
5797 ("\static conversion requires static scalar subtype result "
5798 & "(RM 4.9(9))", N
);
5801 -- Unchecked type conversion
5803 when N_Unchecked_Type_Conversion
=>
5805 ("\unchecked type conversion is never static (RM 4.9)", N
);
5807 -- All other cases, no reason to give