1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2012, 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
;
41 with Sem_Aux
; use Sem_Aux
;
42 with Sem_Cat
; use Sem_Cat
;
43 with Sem_Ch6
; use Sem_Ch6
;
44 with Sem_Ch8
; use Sem_Ch8
;
45 with Sem_Res
; use Sem_Res
;
46 with Sem_Util
; use Sem_Util
;
47 with Sem_Type
; use Sem_Type
;
48 with Sem_Warn
; use Sem_Warn
;
49 with Sinfo
; use Sinfo
;
50 with Snames
; use Snames
;
51 with Stand
; use Stand
;
52 with Stringt
; use Stringt
;
53 with Tbuild
; use Tbuild
;
55 package body Sem_Eval
is
57 -----------------------------------------
58 -- Handling of Compile Time Evaluation --
59 -----------------------------------------
61 -- The compile time evaluation of expressions is distributed over several
62 -- Eval_xxx procedures. These procedures are called immediately after
63 -- a subexpression is resolved and is therefore accomplished in a bottom
64 -- up fashion. The flags are synthesized using the following approach.
66 -- Is_Static_Expression is determined by following the detailed rules
67 -- in RM 4.9(4-14). This involves testing the Is_Static_Expression
68 -- flag of the operands in many cases.
70 -- Raises_Constraint_Error is set if any of the operands have the flag
71 -- set or if an attempt to compute the value of the current expression
72 -- results in detection of a runtime constraint error.
74 -- As described in the spec, the requirement is that Is_Static_Expression
75 -- be accurately set, and in addition for nodes for which this flag is set,
76 -- Raises_Constraint_Error must also be set. Furthermore a node which has
77 -- Is_Static_Expression set, and Raises_Constraint_Error clear, then the
78 -- requirement is that the expression value must be precomputed, and the
79 -- node is either a literal, or the name of a constant entity whose value
80 -- is a static expression.
82 -- The general approach is as follows. First compute Is_Static_Expression.
83 -- If the node is not static, then the flag is left off in the node and
84 -- we are all done. Otherwise for a static node, we test if any of the
85 -- operands will raise constraint error, and if so, propagate the flag
86 -- Raises_Constraint_Error to the result node and we are done (since the
87 -- error was already posted at a lower level).
89 -- For the case of a static node whose operands do not raise constraint
90 -- error, we attempt to evaluate the node. If this evaluation succeeds,
91 -- then the node is replaced by the result of this computation. If the
92 -- evaluation raises constraint error, then we rewrite the node with
93 -- Apply_Compile_Time_Constraint_Error to raise the exception and also
94 -- to post appropriate error messages.
100 type Bits
is array (Nat
range <>) of Boolean;
101 -- Used to convert unsigned (modular) values for folding logical ops
103 -- The following definitions are used to maintain a cache of nodes that
104 -- have compile time known values. The cache is maintained only for
105 -- discrete types (the most common case), and is populated by calls to
106 -- Compile_Time_Known_Value and Expr_Value, but only used by Expr_Value
107 -- since it is possible for the status to change (in particular it is
108 -- possible for a node to get replaced by a constraint error node).
110 CV_Bits
: constant := 5;
111 -- Number of low order bits of Node_Id value used to reference entries
112 -- in the cache table.
114 CV_Cache_Size
: constant Nat
:= 2 ** CV_Bits
;
115 -- Size of cache for compile time values
117 subtype CV_Range
is Nat
range 0 .. CV_Cache_Size
;
119 type CV_Entry
is record
124 type CV_Cache_Array
is array (CV_Range
) of CV_Entry
;
126 CV_Cache
: CV_Cache_Array
:= (others => (Node_High_Bound
, Uint_0
));
127 -- This is the actual cache, with entries consisting of node/value pairs,
128 -- and the impossible value Node_High_Bound used for unset entries.
130 type Range_Membership
is (In_Range
, Out_Of_Range
, Unknown
);
131 -- Range membership may either be statically known to be in range or out
132 -- of range, or not statically known. Used for Test_In_Range below.
134 -----------------------
135 -- Local Subprograms --
136 -----------------------
138 function From_Bits
(B
: Bits
; T
: Entity_Id
) return Uint
;
139 -- Converts a bit string of length B'Length to a Uint value to be used
140 -- for a target of type T, which is a modular type. This procedure
141 -- includes the necessary reduction by the modulus in the case of a
142 -- non-binary modulus (for a binary modulus, the bit string is the
143 -- right length any way so all is well).
145 function Get_String_Val
(N
: Node_Id
) return Node_Id
;
146 -- Given a tree node for a folded string or character value, returns
147 -- the corresponding string literal or character literal (one of the
148 -- two must be available, or the operand would not have been marked
149 -- as foldable in the earlier analysis of the operation).
151 function OK_Bits
(N
: Node_Id
; Bits
: Uint
) return Boolean;
152 -- Bits represents the number of bits in an integer value to be computed
153 -- (but the value has not been computed yet). If this value in Bits is
154 -- reasonable, a result of True is returned, with the implication that
155 -- the caller should go ahead and complete the calculation. If the value
156 -- in Bits is unreasonably large, then an error is posted on node N, and
157 -- False is returned (and the caller skips the proposed calculation).
159 procedure Out_Of_Range
(N
: Node_Id
);
160 -- This procedure is called if it is determined that node N, which
161 -- appears in a non-static context, is a compile time known value
162 -- which is outside its range, i.e. the range of Etype. This is used
163 -- in contexts where this is an illegality if N is static, and should
164 -- generate a warning otherwise.
166 procedure Rewrite_In_Raise_CE
(N
: Node_Id
; Exp
: Node_Id
);
167 -- N and Exp are nodes representing an expression, Exp is known
168 -- to raise CE. N is rewritten in term of Exp in the optimal way.
170 function String_Type_Len
(Stype
: Entity_Id
) return Uint
;
171 -- Given a string type, determines the length of the index type, or,
172 -- if this index type is non-static, the length of the base type of
173 -- this index type. Note that if the string type is itself static,
174 -- then the index type is static, so the second case applies only
175 -- if the string type passed is non-static.
177 function Test
(Cond
: Boolean) return Uint
;
178 pragma Inline
(Test
);
179 -- This function simply returns the appropriate Boolean'Pos value
180 -- corresponding to the value of Cond as a universal integer. It is
181 -- used for producing the result of the static evaluation of the
184 function Find_Universal_Operator_Type
(N
: Node_Id
) return Entity_Id
;
185 -- Check whether an arithmetic operation with universal operands which
186 -- is a rewritten function call with an explicit scope indication is
187 -- ambiguous: P."+" (1, 2) will be ambiguous if there is more than one
188 -- visible numeric type declared in P and the context does not impose a
189 -- type on the result (e.g. in the expression of a type conversion).
190 -- If ambiguous, emit an error and return Empty, else return the result
191 -- type of the operator.
193 procedure Test_Expression_Is_Foldable
198 -- Tests to see if expression N whose single operand is Op1 is foldable,
199 -- i.e. the operand value is known at compile time. If the operation is
200 -- foldable, then Fold is True on return, and Stat indicates whether
201 -- the result is static (i.e. both operands were static). Note that it
202 -- is quite possible for Fold to be True, and Stat to be False, since
203 -- there are cases in which we know the value of an operand even though
204 -- it is not technically static (e.g. the static lower bound of a range
205 -- whose upper bound is non-static).
207 -- If Stat is set False on return, then Test_Expression_Is_Foldable makes a
208 -- call to Check_Non_Static_Context on the operand. If Fold is False on
209 -- return, then all processing is complete, and the caller should
210 -- return, since there is nothing else to do.
212 -- If Stat is set True on return, then Is_Static_Expression is also set
213 -- true in node N. There are some cases where this is over-enthusiastic,
214 -- e.g. in the two operand case below, for string comparison, the result
215 -- is not static even though the two operands are static. In such cases,
216 -- the caller must reset the Is_Static_Expression flag in N.
218 procedure Test_Expression_Is_Foldable
224 -- Same processing, except applies to an expression N with two operands
227 function Test_In_Range
230 Assume_Valid
: Boolean;
232 Int_Real
: Boolean) return Range_Membership
;
233 -- Common processing for Is_In_Range and Is_Out_Of_Range:
234 -- Returns In_Range or Out_Of_Range if it can be guaranteed at compile time
235 -- that expression N is known to be in or out of range of the subtype Typ.
236 -- If not compile time known, Unknown is returned.
237 -- See documentation of Is_In_Range for complete description of parameters.
239 procedure To_Bits
(U
: Uint
; B
: out Bits
);
240 -- Converts a Uint value to a bit string of length B'Length
242 ------------------------------
243 -- Check_Non_Static_Context --
244 ------------------------------
246 procedure Check_Non_Static_Context
(N
: Node_Id
) is
247 T
: constant Entity_Id
:= Etype
(N
);
248 Checks_On
: constant Boolean :=
249 not Index_Checks_Suppressed
(T
)
250 and not Range_Checks_Suppressed
(T
);
253 -- Ignore cases of non-scalar types, error types, or universal real
254 -- types that have no usable bounds.
257 or else not Is_Scalar_Type
(T
)
258 or else T
= Universal_Fixed
259 or else T
= Universal_Real
264 -- At this stage we have a scalar type. If we have an expression that
265 -- raises CE, then we already issued a warning or error msg so there
266 -- is nothing more to be done in this routine.
268 if Raises_Constraint_Error
(N
) then
272 -- Now we have a scalar type which is not marked as raising a constraint
273 -- error exception. The main purpose of this routine is to deal with
274 -- static expressions appearing in a non-static context. That means
275 -- that if we do not have a static expression then there is not much
276 -- to do. The one case that we deal with here is that if we have a
277 -- floating-point value that is out of range, then we post a warning
278 -- that an infinity will result.
280 if not Is_Static_Expression
(N
) then
281 if Is_Floating_Point_Type
(T
)
282 and then Is_Out_Of_Range
(N
, Base_Type
(T
), Assume_Valid
=> True)
285 ("?float value out of range, infinity will be generated", N
);
291 -- Here we have the case of outer level static expression of scalar
292 -- type, where the processing of this procedure is needed.
294 -- For real types, this is where we convert the value to a machine
295 -- number (see RM 4.9(38)). Also see ACVC test C490001. We should only
296 -- need to do this if the parent is a constant declaration, since in
297 -- other cases, gigi should do the necessary conversion correctly, but
298 -- experimentation shows that this is not the case on all machines, in
299 -- particular if we do not convert all literals to machine values in
300 -- non-static contexts, then ACVC test C490001 fails on Sparc/Solaris
303 if Nkind
(N
) = N_Real_Literal
304 and then not Is_Machine_Number
(N
)
305 and then not Is_Generic_Type
(Etype
(N
))
306 and then Etype
(N
) /= Universal_Real
308 -- Check that value is in bounds before converting to machine
309 -- number, so as not to lose case where value overflows in the
310 -- least significant bit or less. See B490001.
312 if Is_Out_Of_Range
(N
, Base_Type
(T
), Assume_Valid
=> True) then
317 -- Note: we have to copy the node, to avoid problems with conformance
318 -- of very similar numbers (see ACVC tests B4A010C and B63103A).
320 Rewrite
(N
, New_Copy
(N
));
322 if not Is_Floating_Point_Type
(T
) then
324 (N
, Corresponding_Integer_Value
(N
) * Small_Value
(T
));
326 elsif not UR_Is_Zero
(Realval
(N
)) then
328 -- Note: even though RM 4.9(38) specifies biased rounding, this
329 -- has been modified by AI-100 in order to prevent confusing
330 -- differences in rounding between static and non-static
331 -- expressions. AI-100 specifies that the effect of such rounding
332 -- is implementation dependent, and in GNAT we round to nearest
333 -- even to match the run-time behavior.
336 (N
, Machine
(Base_Type
(T
), Realval
(N
), Round_Even
, N
));
339 Set_Is_Machine_Number
(N
);
342 -- Check for out of range universal integer. This is a non-static
343 -- context, so the integer value must be in range of the runtime
344 -- representation of universal integers.
346 -- We do this only within an expression, because that is the only
347 -- case in which non-static universal integer values can occur, and
348 -- furthermore, Check_Non_Static_Context is currently (incorrectly???)
349 -- called in contexts like the expression of a number declaration where
350 -- we certainly want to allow out of range values.
352 if Etype
(N
) = Universal_Integer
353 and then Nkind
(N
) = N_Integer_Literal
354 and then Nkind
(Parent
(N
)) in N_Subexpr
356 (Intval
(N
) < Expr_Value
(Type_Low_Bound
(Universal_Integer
))
358 Intval
(N
) > Expr_Value
(Type_High_Bound
(Universal_Integer
)))
360 Apply_Compile_Time_Constraint_Error
361 (N
, "non-static universal integer value out of range?",
362 CE_Range_Check_Failed
);
364 -- Check out of range of base type
366 elsif Is_Out_Of_Range
(N
, Base_Type
(T
), Assume_Valid
=> True) then
369 -- Give warning if outside subtype (where one or both of the bounds of
370 -- the subtype is static). This warning is omitted if the expression
371 -- appears in a range that could be null (warnings are handled elsewhere
374 elsif T
/= Base_Type
(T
)
375 and then Nkind
(Parent
(N
)) /= N_Range
377 if Is_In_Range
(N
, T
, Assume_Valid
=> True) then
380 elsif Is_Out_Of_Range
(N
, T
, Assume_Valid
=> True) then
381 Apply_Compile_Time_Constraint_Error
382 (N
, "value not in range of}?", CE_Range_Check_Failed
);
385 Enable_Range_Check
(N
);
388 Set_Do_Range_Check
(N
, False);
391 end Check_Non_Static_Context
;
393 ---------------------------------
394 -- Check_String_Literal_Length --
395 ---------------------------------
397 procedure Check_String_Literal_Length
(N
: Node_Id
; Ttype
: Entity_Id
) is
399 if not Raises_Constraint_Error
(N
)
400 and then Is_Constrained
(Ttype
)
403 UI_From_Int
(String_Length
(Strval
(N
))) /= String_Type_Len
(Ttype
)
405 Apply_Compile_Time_Constraint_Error
406 (N
, "string length wrong for}?",
407 CE_Length_Check_Failed
,
412 end Check_String_Literal_Length
;
414 --------------------------
415 -- Compile_Time_Compare --
416 --------------------------
418 function Compile_Time_Compare
420 Assume_Valid
: Boolean) return Compare_Result
422 Discard
: aliased Uint
;
424 return Compile_Time_Compare
(L
, R
, Discard
'Access, Assume_Valid
);
425 end Compile_Time_Compare
;
427 function Compile_Time_Compare
430 Assume_Valid
: Boolean;
431 Rec
: Boolean := False) return Compare_Result
433 Ltyp
: Entity_Id
:= Underlying_Type
(Etype
(L
));
434 Rtyp
: Entity_Id
:= Underlying_Type
(Etype
(R
));
435 -- These get reset to the base type for the case of entities where
436 -- Is_Known_Valid is not set. This takes care of handling possible
437 -- invalid representations using the value of the base type, in
438 -- accordance with RM 13.9.1(10).
440 Discard
: aliased Uint
;
442 procedure Compare_Decompose
446 -- This procedure decomposes the node N into an expression node and a
447 -- signed offset, so that the value of N is equal to the value of R plus
448 -- the value V (which may be negative). If no such decomposition is
449 -- possible, then on return R is a copy of N, and V is set to zero.
451 function Compare_Fixup
(N
: Node_Id
) return Node_Id
;
452 -- This function deals with replacing 'Last and 'First references with
453 -- their corresponding type bounds, which we then can compare. The
454 -- argument is the original node, the result is the identity, unless we
455 -- have a 'Last/'First reference in which case the value returned is the
456 -- appropriate type bound.
458 function Is_Known_Valid_Operand
(Opnd
: Node_Id
) return Boolean;
459 -- Even if the context does not assume that values are valid, some
460 -- simple cases can be recognized.
462 function Is_Same_Value
(L
, R
: Node_Id
) return Boolean;
463 -- Returns True iff L and R represent expressions that definitely have
464 -- identical (but not necessarily compile time known) values Indeed the
465 -- caller is expected to have already dealt with the cases of compile
466 -- time known values, so these are not tested here.
468 -----------------------
469 -- Compare_Decompose --
470 -----------------------
472 procedure Compare_Decompose
478 if Nkind
(N
) = N_Op_Add
479 and then Nkind
(Right_Opnd
(N
)) = N_Integer_Literal
482 V
:= Intval
(Right_Opnd
(N
));
485 elsif Nkind
(N
) = N_Op_Subtract
486 and then Nkind
(Right_Opnd
(N
)) = N_Integer_Literal
489 V
:= UI_Negate
(Intval
(Right_Opnd
(N
)));
492 elsif Nkind
(N
) = N_Attribute_Reference
then
493 if Attribute_Name
(N
) = Name_Succ
then
494 R
:= First
(Expressions
(N
));
498 elsif Attribute_Name
(N
) = Name_Pred
then
499 R
:= First
(Expressions
(N
));
507 end Compare_Decompose
;
513 function Compare_Fixup
(N
: Node_Id
) return Node_Id
is
519 -- Fixup only required for First/Last attribute reference
521 if Nkind
(N
) = N_Attribute_Reference
522 and then (Attribute_Name
(N
) = Name_First
524 Attribute_Name
(N
) = Name_Last
)
526 Xtyp
:= Etype
(Prefix
(N
));
528 -- If we have no type, then just abandon the attempt to do
529 -- a fixup, this is probably the result of some other error.
535 -- Dereference an access type
537 if Is_Access_Type
(Xtyp
) then
538 Xtyp
:= Designated_Type
(Xtyp
);
541 -- If we don't have an array type at this stage, something
542 -- is peculiar, e.g. another error, and we abandon the attempt
545 if not Is_Array_Type
(Xtyp
) then
549 -- Ignore unconstrained array, since bounds are not meaningful
551 if not Is_Constrained
(Xtyp
) then
555 if Ekind
(Xtyp
) = E_String_Literal_Subtype
then
556 if Attribute_Name
(N
) = Name_First
then
557 return String_Literal_Low_Bound
(Xtyp
);
560 return Make_Integer_Literal
(Sloc
(N
),
561 Intval
=> Intval
(String_Literal_Low_Bound
(Xtyp
))
562 + String_Literal_Length
(Xtyp
));
566 -- Find correct index type
568 Indx
:= First_Index
(Xtyp
);
570 if Present
(Expressions
(N
)) then
571 Subs
:= UI_To_Int
(Expr_Value
(First
(Expressions
(N
))));
573 for J
in 2 .. Subs
loop
574 Indx
:= Next_Index
(Indx
);
578 Xtyp
:= Etype
(Indx
);
580 if Attribute_Name
(N
) = Name_First
then
581 return Type_Low_Bound
(Xtyp
);
583 return Type_High_Bound
(Xtyp
);
590 ----------------------------
591 -- Is_Known_Valid_Operand --
592 ----------------------------
594 function Is_Known_Valid_Operand
(Opnd
: Node_Id
) return Boolean is
596 return (Is_Entity_Name
(Opnd
)
598 (Is_Known_Valid
(Entity
(Opnd
))
599 or else Ekind
(Entity
(Opnd
)) = E_In_Parameter
601 (Ekind
(Entity
(Opnd
)) in Object_Kind
602 and then Present
(Current_Value
(Entity
(Opnd
))))))
603 or else Is_OK_Static_Expression
(Opnd
);
604 end Is_Known_Valid_Operand
;
610 function Is_Same_Value
(L
, R
: Node_Id
) return Boolean is
611 Lf
: constant Node_Id
:= Compare_Fixup
(L
);
612 Rf
: constant Node_Id
:= Compare_Fixup
(R
);
614 function Is_Same_Subscript
(L
, R
: List_Id
) return Boolean;
615 -- L, R are the Expressions values from two attribute nodes for First
616 -- or Last attributes. Either may be set to No_List if no expressions
617 -- are present (indicating subscript 1). The result is True if both
618 -- expressions represent the same subscript (note one case is where
619 -- one subscript is missing and the other is explicitly set to 1).
621 -----------------------
622 -- Is_Same_Subscript --
623 -----------------------
625 function Is_Same_Subscript
(L
, R
: List_Id
) return Boolean is
631 return Expr_Value
(First
(R
)) = Uint_1
;
636 return Expr_Value
(First
(L
)) = Uint_1
;
638 return Expr_Value
(First
(L
)) = Expr_Value
(First
(R
));
641 end Is_Same_Subscript
;
643 -- Start of processing for Is_Same_Value
646 -- Values are the same if they refer to the same entity and the
647 -- entity is non-volatile. This does not however apply to Float
648 -- types, since we may have two NaN values and they should never
651 -- If the entity is a discriminant, the two expressions may be bounds
652 -- of components of objects of the same discriminated type. The
653 -- values of the discriminants are not static, and therefore the
654 -- result is unknown.
656 -- It would be better to comment individual branches of this test ???
658 if Nkind_In
(Lf
, N_Identifier
, N_Expanded_Name
)
659 and then Nkind_In
(Rf
, N_Identifier
, N_Expanded_Name
)
660 and then Entity
(Lf
) = Entity
(Rf
)
661 and then Ekind
(Entity
(Lf
)) /= E_Discriminant
662 and then Present
(Entity
(Lf
))
663 and then not Is_Floating_Point_Type
(Etype
(L
))
664 and then not Is_Volatile_Reference
(L
)
665 and then not Is_Volatile_Reference
(R
)
669 -- Or if they are compile time known and identical
671 elsif Compile_Time_Known_Value
(Lf
)
673 Compile_Time_Known_Value
(Rf
)
674 and then Expr_Value
(Lf
) = Expr_Value
(Rf
)
678 -- False if Nkind of the two nodes is different for remaining cases
680 elsif Nkind
(Lf
) /= Nkind
(Rf
) then
683 -- True if both 'First or 'Last values applying to the same entity
684 -- (first and last don't change even if value does). Note that we
685 -- need this even with the calls to Compare_Fixup, to handle the
686 -- case of unconstrained array attributes where Compare_Fixup
687 -- cannot find useful bounds.
689 elsif Nkind
(Lf
) = N_Attribute_Reference
690 and then Attribute_Name
(Lf
) = Attribute_Name
(Rf
)
691 and then (Attribute_Name
(Lf
) = Name_First
693 Attribute_Name
(Lf
) = Name_Last
)
694 and then Nkind_In
(Prefix
(Lf
), N_Identifier
, N_Expanded_Name
)
695 and then Nkind_In
(Prefix
(Rf
), N_Identifier
, N_Expanded_Name
)
696 and then Entity
(Prefix
(Lf
)) = Entity
(Prefix
(Rf
))
697 and then Is_Same_Subscript
(Expressions
(Lf
), Expressions
(Rf
))
701 -- True if the same selected component from the same record
703 elsif Nkind
(Lf
) = N_Selected_Component
704 and then Selector_Name
(Lf
) = Selector_Name
(Rf
)
705 and then Is_Same_Value
(Prefix
(Lf
), Prefix
(Rf
))
709 -- True if the same unary operator applied to the same operand
711 elsif Nkind
(Lf
) in N_Unary_Op
712 and then Is_Same_Value
(Right_Opnd
(Lf
), Right_Opnd
(Rf
))
716 -- True if the same binary operator applied to the same operands
718 elsif Nkind
(Lf
) in N_Binary_Op
719 and then Is_Same_Value
(Left_Opnd
(Lf
), Left_Opnd
(Rf
))
720 and then Is_Same_Value
(Right_Opnd
(Lf
), Right_Opnd
(Rf
))
724 -- All other cases, we can't tell, so return False
731 -- Start of processing for Compile_Time_Compare
736 -- If either operand could raise constraint error, then we cannot
737 -- know the result at compile time (since CE may be raised!)
739 if not (Cannot_Raise_Constraint_Error
(L
)
741 Cannot_Raise_Constraint_Error
(R
))
746 -- Identical operands are most certainly equal
751 -- If expressions have no types, then do not attempt to determine if
752 -- they are the same, since something funny is going on. One case in
753 -- which this happens is during generic template analysis, when bounds
754 -- are not fully analyzed.
756 elsif No
(Ltyp
) or else No
(Rtyp
) then
759 -- We do not attempt comparisons for packed arrays arrays represented as
760 -- modular types, where the semantics of comparison is quite different.
762 elsif Is_Packed_Array_Type
(Ltyp
)
763 and then Is_Modular_Integer_Type
(Ltyp
)
767 -- For access types, the only time we know the result at compile time
768 -- (apart from identical operands, which we handled already) is if we
769 -- know one operand is null and the other is not, or both operands are
772 elsif Is_Access_Type
(Ltyp
) then
773 if Known_Null
(L
) then
774 if Known_Null
(R
) then
776 elsif Known_Non_Null
(R
) then
782 elsif Known_Non_Null
(L
) and then Known_Null
(R
) then
789 -- Case where comparison involves two compile time known values
791 elsif Compile_Time_Known_Value
(L
)
792 and then Compile_Time_Known_Value
(R
)
794 -- For the floating-point case, we have to be a little careful, since
795 -- at compile time we are dealing with universal exact values, but at
796 -- runtime, these will be in non-exact target form. That's why the
797 -- returned results are LE and GE below instead of LT and GT.
799 if Is_Floating_Point_Type
(Ltyp
)
801 Is_Floating_Point_Type
(Rtyp
)
804 Lo
: constant Ureal
:= Expr_Value_R
(L
);
805 Hi
: constant Ureal
:= Expr_Value_R
(R
);
817 -- For string types, we have two string literals and we proceed to
818 -- compare them using the Ada style dictionary string comparison.
820 elsif not Is_Scalar_Type
(Ltyp
) then
822 Lstring
: constant String_Id
:= Strval
(Expr_Value_S
(L
));
823 Rstring
: constant String_Id
:= Strval
(Expr_Value_S
(R
));
824 Llen
: constant Nat
:= String_Length
(Lstring
);
825 Rlen
: constant Nat
:= String_Length
(Rstring
);
828 for J
in 1 .. Nat
'Min (Llen
, Rlen
) loop
830 LC
: constant Char_Code
:= Get_String_Char
(Lstring
, J
);
831 RC
: constant Char_Code
:= Get_String_Char
(Rstring
, J
);
843 elsif Llen
> Rlen
then
850 -- For remaining scalar cases we know exactly (note that this does
851 -- include the fixed-point case, where we know the run time integer
856 Lo
: constant Uint
:= Expr_Value
(L
);
857 Hi
: constant Uint
:= Expr_Value
(R
);
874 -- Cases where at least one operand is not known at compile time
877 -- Remaining checks apply only for discrete types
879 if not Is_Discrete_Type
(Ltyp
)
880 or else not Is_Discrete_Type
(Rtyp
)
885 -- Defend against generic types, or actually any expressions that
886 -- contain a reference to a generic type from within a generic
887 -- template. We don't want to do any range analysis of such
888 -- expressions for two reasons. First, the bounds of a generic type
889 -- itself are junk and cannot be used for any kind of analysis.
890 -- Second, we may have a case where the range at run time is indeed
891 -- known, but we don't want to do compile time analysis in the
892 -- template based on that range since in an instance the value may be
893 -- static, and able to be elaborated without reference to the bounds
894 -- of types involved. As an example, consider:
896 -- (F'Pos (F'Last) + 1) > Integer'Last
898 -- The expression on the left side of > is Universal_Integer and thus
899 -- acquires the type Integer for evaluation at run time, and at run
900 -- time it is true that this condition is always False, but within
901 -- an instance F may be a type with a static range greater than the
902 -- range of Integer, and the expression statically evaluates to True.
904 if References_Generic_Formal_Type
(L
)
906 References_Generic_Formal_Type
(R
)
911 -- Replace types by base types for the case of entities which are
912 -- not known to have valid representations. This takes care of
913 -- properly dealing with invalid representations.
915 if not Assume_Valid
and then not Assume_No_Invalid_Values
then
916 if Is_Entity_Name
(L
) and then not Is_Known_Valid
(Entity
(L
)) then
917 Ltyp
:= Underlying_Type
(Base_Type
(Ltyp
));
920 if Is_Entity_Name
(R
) and then not Is_Known_Valid
(Entity
(R
)) then
921 Rtyp
:= Underlying_Type
(Base_Type
(Rtyp
));
925 -- Try range analysis on variables and see if ranges are disjoint
933 Determine_Range
(L
, LOK
, LLo
, LHi
, Assume_Valid
);
934 Determine_Range
(R
, ROK
, RLo
, RHi
, Assume_Valid
);
948 -- If the range includes a single literal and we can assume
949 -- validity then the result is known even if an operand is
964 elsif not Is_Known_Valid_Operand
(L
)
965 and then not Assume_Valid
967 if Is_Same_Value
(L
, R
) then
974 -- If the range of either operand cannot be determined, nothing
975 -- further can be inferred.
982 -- Here is where we check for comparisons against maximum bounds of
983 -- types, where we know that no value can be outside the bounds of
984 -- the subtype. Note that this routine is allowed to assume that all
985 -- expressions are within their subtype bounds. Callers wishing to
986 -- deal with possibly invalid values must in any case take special
987 -- steps (e.g. conversions to larger types) to avoid this kind of
988 -- optimization, which is always considered to be valid. We do not
989 -- attempt this optimization with generic types, since the type
990 -- bounds may not be meaningful in this case.
992 -- We are in danger of an infinite recursion here. It does not seem
993 -- useful to go more than one level deep, so the parameter Rec is
994 -- used to protect ourselves against this infinite recursion.
998 -- See if we can get a decisive check against one operand and
999 -- a bound of the other operand (four possible tests here).
1000 -- Note that we avoid testing junk bounds of a generic type.
1002 if not Is_Generic_Type
(Rtyp
) then
1003 case Compile_Time_Compare
(L
, Type_Low_Bound
(Rtyp
),
1005 Assume_Valid
, Rec
=> True)
1007 when LT
=> return LT
;
1008 when LE
=> return LE
;
1009 when EQ
=> return LE
;
1010 when others => null;
1013 case Compile_Time_Compare
(L
, Type_High_Bound
(Rtyp
),
1015 Assume_Valid
, Rec
=> True)
1017 when GT
=> return GT
;
1018 when GE
=> return GE
;
1019 when EQ
=> return GE
;
1020 when others => null;
1024 if not Is_Generic_Type
(Ltyp
) then
1025 case Compile_Time_Compare
(Type_Low_Bound
(Ltyp
), R
,
1027 Assume_Valid
, Rec
=> True)
1029 when GT
=> return GT
;
1030 when GE
=> return GE
;
1031 when EQ
=> return GE
;
1032 when others => null;
1035 case Compile_Time_Compare
(Type_High_Bound
(Ltyp
), R
,
1037 Assume_Valid
, Rec
=> True)
1039 when LT
=> return LT
;
1040 when LE
=> return LE
;
1041 when EQ
=> return LE
;
1042 when others => null;
1047 -- Next attempt is to decompose the expressions to extract
1048 -- a constant offset resulting from the use of any of the forms:
1055 -- Then we see if the two expressions are the same value, and if so
1056 -- the result is obtained by comparing the offsets.
1065 Compare_Decompose
(L
, Lnode
, Loffs
);
1066 Compare_Decompose
(R
, Rnode
, Roffs
);
1068 if Is_Same_Value
(Lnode
, Rnode
) then
1069 if Loffs
= Roffs
then
1072 elsif Loffs
< Roffs
then
1073 Diff
.all := Roffs
- Loffs
;
1077 Diff
.all := Loffs
- Roffs
;
1083 -- Next attempt is to see if we have an entity compared with a
1084 -- compile time known value, where there is a current value
1085 -- conditional for the entity which can tell us the result.
1089 -- Entity variable (left operand)
1092 -- Value (right operand)
1095 -- If False, we have reversed the operands
1098 -- Comparison operator kind from Get_Current_Value_Condition call
1101 -- Value from Get_Current_Value_Condition call
1106 Result
: Compare_Result
;
1107 -- Known result before inversion
1110 if Is_Entity_Name
(L
)
1111 and then Compile_Time_Known_Value
(R
)
1114 Val
:= Expr_Value
(R
);
1117 elsif Is_Entity_Name
(R
)
1118 and then Compile_Time_Known_Value
(L
)
1121 Val
:= Expr_Value
(L
);
1124 -- That was the last chance at finding a compile time result
1130 Get_Current_Value_Condition
(Var
, Op
, Opn
);
1132 -- That was the last chance, so if we got nothing return
1138 Opv
:= Expr_Value
(Opn
);
1140 -- We got a comparison, so we might have something interesting
1142 -- Convert LE to LT and GE to GT, just so we have fewer cases
1144 if Op
= N_Op_Le
then
1148 elsif Op
= N_Op_Ge
then
1153 -- Deal with equality case
1155 if Op
= N_Op_Eq
then
1158 elsif Opv
< Val
then
1164 -- Deal with inequality case
1166 elsif Op
= N_Op_Ne
then
1173 -- Deal with greater than case
1175 elsif Op
= N_Op_Gt
then
1178 elsif Opv
= Val
- 1 then
1184 -- Deal with less than case
1186 else pragma Assert
(Op
= N_Op_Lt
);
1189 elsif Opv
= Val
+ 1 then
1196 -- Deal with inverting result
1200 when GT
=> return LT
;
1201 when GE
=> return LE
;
1202 when LT
=> return GT
;
1203 when LE
=> return GE
;
1204 when others => return Result
;
1211 end Compile_Time_Compare
;
1213 -------------------------------
1214 -- Compile_Time_Known_Bounds --
1215 -------------------------------
1217 function Compile_Time_Known_Bounds
(T
: Entity_Id
) return Boolean is
1222 if not Is_Array_Type
(T
) then
1226 Indx
:= First_Index
(T
);
1227 while Present
(Indx
) loop
1228 Typ
:= Underlying_Type
(Etype
(Indx
));
1230 -- Never look at junk bounds of a generic type
1232 if Is_Generic_Type
(Typ
) then
1236 -- Otherwise check bounds for compile time known
1238 if not Compile_Time_Known_Value
(Type_Low_Bound
(Typ
)) then
1240 elsif not Compile_Time_Known_Value
(Type_High_Bound
(Typ
)) then
1248 end Compile_Time_Known_Bounds
;
1250 ------------------------------
1251 -- Compile_Time_Known_Value --
1252 ------------------------------
1254 function Compile_Time_Known_Value
(Op
: Node_Id
) return Boolean is
1255 K
: constant Node_Kind
:= Nkind
(Op
);
1256 CV_Ent
: CV_Entry
renames CV_Cache
(Nat
(Op
) mod CV_Cache_Size
);
1259 -- Never known at compile time if bad type or raises constraint error
1260 -- or empty (latter case occurs only as a result of a previous error)
1264 or else Etype
(Op
) = Any_Type
1265 or else Raises_Constraint_Error
(Op
)
1270 -- If this is not a static expression or a null literal, and we are in
1271 -- configurable run-time mode, then we consider it not known at compile
1272 -- time. This avoids anomalies where whether something is allowed with a
1273 -- given configurable run-time library depends on how good the compiler
1274 -- is at optimizing and knowing that things are constant when they are
1277 if Configurable_Run_Time_Mode
1278 and then K
/= N_Null
1279 and then not Is_Static_Expression
(Op
)
1284 -- If we have an entity name, then see if it is the name of a constant
1285 -- and if so, test the corresponding constant value, or the name of
1286 -- an enumeration literal, which is always a constant.
1288 if Present
(Etype
(Op
)) and then Is_Entity_Name
(Op
) then
1290 E
: constant Entity_Id
:= Entity
(Op
);
1294 -- Never known at compile time if it is a packed array value.
1295 -- We might want to try to evaluate these at compile time one
1296 -- day, but we do not make that attempt now.
1298 if Is_Packed_Array_Type
(Etype
(Op
)) then
1302 if Ekind
(E
) = E_Enumeration_Literal
then
1305 -- In Alfa mode, the value of deferred constants should be ignored
1306 -- outside the scope of their full view. This allows parameterized
1307 -- formal verification, in which a deferred constant value if not
1308 -- known from client units.
1310 elsif Ekind
(E
) = E_Constant
1311 and then not (Alfa_Mode
1312 and then Present
(Full_View
(E
))
1313 and then not In_Open_Scopes
(Scope
(E
)))
1315 V
:= Constant_Value
(E
);
1316 return Present
(V
) and then Compile_Time_Known_Value
(V
);
1320 -- We have a value, see if it is compile time known
1323 -- Integer literals are worth storing in the cache
1325 if K
= N_Integer_Literal
then
1327 CV_Ent
.V
:= Intval
(Op
);
1330 -- Other literals and NULL are known at compile time
1333 K
= N_Character_Literal
1337 K
= N_String_Literal
1343 -- Any reference to Null_Parameter is known at compile time. No
1344 -- other attribute references (that have not already been folded)
1345 -- are known at compile time.
1347 elsif K
= N_Attribute_Reference
then
1348 return Attribute_Name
(Op
) = Name_Null_Parameter
;
1352 -- If we fall through, not known at compile time
1356 -- If we get an exception while trying to do this test, then some error
1357 -- has occurred, and we simply say that the value is not known after all
1362 end Compile_Time_Known_Value
;
1364 --------------------------------------
1365 -- Compile_Time_Known_Value_Or_Aggr --
1366 --------------------------------------
1368 function Compile_Time_Known_Value_Or_Aggr
(Op
: Node_Id
) return Boolean is
1370 -- If we have an entity name, then see if it is the name of a constant
1371 -- and if so, test the corresponding constant value, or the name of
1372 -- an enumeration literal, which is always a constant.
1374 if Is_Entity_Name
(Op
) then
1376 E
: constant Entity_Id
:= Entity
(Op
);
1380 if Ekind
(E
) = E_Enumeration_Literal
then
1383 elsif Ekind
(E
) /= E_Constant
then
1387 V
:= Constant_Value
(E
);
1389 and then Compile_Time_Known_Value_Or_Aggr
(V
);
1393 -- We have a value, see if it is compile time known
1396 if Compile_Time_Known_Value
(Op
) then
1399 elsif Nkind
(Op
) = N_Aggregate
then
1401 if Present
(Expressions
(Op
)) then
1406 Expr
:= First
(Expressions
(Op
));
1407 while Present
(Expr
) loop
1408 if not Compile_Time_Known_Value_Or_Aggr
(Expr
) then
1417 if Present
(Component_Associations
(Op
)) then
1422 Cass
:= First
(Component_Associations
(Op
));
1423 while Present
(Cass
) loop
1425 Compile_Time_Known_Value_Or_Aggr
(Expression
(Cass
))
1437 -- All other types of values are not known at compile time
1444 end Compile_Time_Known_Value_Or_Aggr
;
1450 -- This is only called for actuals of functions that are not predefined
1451 -- operators (which have already been rewritten as operators at this
1452 -- stage), so the call can never be folded, and all that needs doing for
1453 -- the actual is to do the check for a non-static context.
1455 procedure Eval_Actual
(N
: Node_Id
) is
1457 Check_Non_Static_Context
(N
);
1460 --------------------
1461 -- Eval_Allocator --
1462 --------------------
1464 -- Allocators are never static, so all we have to do is to do the
1465 -- check for a non-static context if an expression is present.
1467 procedure Eval_Allocator
(N
: Node_Id
) is
1468 Expr
: constant Node_Id
:= Expression
(N
);
1471 if Nkind
(Expr
) = N_Qualified_Expression
then
1472 Check_Non_Static_Context
(Expression
(Expr
));
1476 ------------------------
1477 -- Eval_Arithmetic_Op --
1478 ------------------------
1480 -- Arithmetic operations are static functions, so the result is static
1481 -- if both operands are static (RM 4.9(7), 4.9(20)).
1483 procedure Eval_Arithmetic_Op
(N
: Node_Id
) is
1484 Left
: constant Node_Id
:= Left_Opnd
(N
);
1485 Right
: constant Node_Id
:= Right_Opnd
(N
);
1486 Ltype
: constant Entity_Id
:= Etype
(Left
);
1487 Rtype
: constant Entity_Id
:= Etype
(Right
);
1488 Otype
: Entity_Id
:= Empty
;
1493 -- If not foldable we are done
1495 Test_Expression_Is_Foldable
(N
, Left
, Right
, Stat
, Fold
);
1501 if Is_Universal_Numeric_Type
(Etype
(Left
))
1503 Is_Universal_Numeric_Type
(Etype
(Right
))
1505 Otype
:= Find_Universal_Operator_Type
(N
);
1508 -- Fold for cases where both operands are of integer type
1510 if Is_Integer_Type
(Ltype
) and then Is_Integer_Type
(Rtype
) then
1512 Left_Int
: constant Uint
:= Expr_Value
(Left
);
1513 Right_Int
: constant Uint
:= Expr_Value
(Right
);
1520 Result
:= Left_Int
+ Right_Int
;
1522 when N_Op_Subtract
=>
1523 Result
:= Left_Int
- Right_Int
;
1525 when N_Op_Multiply
=>
1528 (Num_Bits
(Left_Int
) + Num_Bits
(Right_Int
)))
1530 Result
:= Left_Int
* Right_Int
;
1537 -- The exception Constraint_Error is raised by integer
1538 -- division, rem and mod if the right operand is zero.
1540 if Right_Int
= 0 then
1541 Apply_Compile_Time_Constraint_Error
1542 (N
, "division by zero",
1548 Result
:= Left_Int
/ Right_Int
;
1553 -- The exception Constraint_Error is raised by integer
1554 -- division, rem and mod if the right operand is zero.
1556 if Right_Int
= 0 then
1557 Apply_Compile_Time_Constraint_Error
1558 (N
, "mod with zero divisor",
1563 Result
:= Left_Int
mod Right_Int
;
1568 -- The exception Constraint_Error is raised by integer
1569 -- division, rem and mod if the right operand is zero.
1571 if Right_Int
= 0 then
1572 Apply_Compile_Time_Constraint_Error
1573 (N
, "rem with zero divisor",
1579 Result
:= Left_Int
rem Right_Int
;
1583 raise Program_Error
;
1586 -- Adjust the result by the modulus if the type is a modular type
1588 if Is_Modular_Integer_Type
(Ltype
) then
1589 Result
:= Result
mod Modulus
(Ltype
);
1591 -- For a signed integer type, check non-static overflow
1593 elsif (not Stat
) and then Is_Signed_Integer_Type
(Ltype
) then
1595 BT
: constant Entity_Id
:= Base_Type
(Ltype
);
1596 Lo
: constant Uint
:= Expr_Value
(Type_Low_Bound
(BT
));
1597 Hi
: constant Uint
:= Expr_Value
(Type_High_Bound
(BT
));
1599 if Result
< Lo
or else Result
> Hi
then
1600 Apply_Compile_Time_Constraint_Error
1601 (N
, "value not in range of }?",
1602 CE_Overflow_Check_Failed
,
1609 -- If we get here we can fold the result
1611 Fold_Uint
(N
, Result
, Stat
);
1614 -- Cases where at least one operand is a real. We handle the cases of
1615 -- both reals, or mixed/real integer cases (the latter happen only for
1616 -- divide and multiply, and the result is always real).
1618 elsif Is_Real_Type
(Ltype
) or else Is_Real_Type
(Rtype
) then
1625 if Is_Real_Type
(Ltype
) then
1626 Left_Real
:= Expr_Value_R
(Left
);
1628 Left_Real
:= UR_From_Uint
(Expr_Value
(Left
));
1631 if Is_Real_Type
(Rtype
) then
1632 Right_Real
:= Expr_Value_R
(Right
);
1634 Right_Real
:= UR_From_Uint
(Expr_Value
(Right
));
1637 if Nkind
(N
) = N_Op_Add
then
1638 Result
:= Left_Real
+ Right_Real
;
1640 elsif Nkind
(N
) = N_Op_Subtract
then
1641 Result
:= Left_Real
- Right_Real
;
1643 elsif Nkind
(N
) = N_Op_Multiply
then
1644 Result
:= Left_Real
* Right_Real
;
1646 else pragma Assert
(Nkind
(N
) = N_Op_Divide
);
1647 if UR_Is_Zero
(Right_Real
) then
1648 Apply_Compile_Time_Constraint_Error
1649 (N
, "division by zero", CE_Divide_By_Zero
);
1653 Result
:= Left_Real
/ Right_Real
;
1656 Fold_Ureal
(N
, Result
, Stat
);
1660 -- If the operator was resolved to a specific type, make sure that type
1661 -- is frozen even if the expression is folded into a literal (which has
1662 -- a universal type).
1664 if Present
(Otype
) then
1665 Freeze_Before
(N
, Otype
);
1667 end Eval_Arithmetic_Op
;
1669 ----------------------------
1670 -- Eval_Character_Literal --
1671 ----------------------------
1673 -- Nothing to be done!
1675 procedure Eval_Character_Literal
(N
: Node_Id
) is
1676 pragma Warnings
(Off
, N
);
1679 end Eval_Character_Literal
;
1685 -- Static function calls are either calls to predefined operators
1686 -- with static arguments, or calls to functions that rename a literal.
1687 -- Only the latter case is handled here, predefined operators are
1688 -- constant-folded elsewhere.
1690 -- If the function is itself inherited (see 7423-001) the literal of
1691 -- the parent type must be explicitly converted to the return type
1694 procedure Eval_Call
(N
: Node_Id
) is
1695 Loc
: constant Source_Ptr
:= Sloc
(N
);
1696 Typ
: constant Entity_Id
:= Etype
(N
);
1700 if Nkind
(N
) = N_Function_Call
1701 and then No
(Parameter_Associations
(N
))
1702 and then Is_Entity_Name
(Name
(N
))
1703 and then Present
(Alias
(Entity
(Name
(N
))))
1704 and then Is_Enumeration_Type
(Base_Type
(Typ
))
1706 Lit
:= Ultimate_Alias
(Entity
(Name
(N
)));
1708 if Ekind
(Lit
) = E_Enumeration_Literal
then
1709 if Base_Type
(Etype
(Lit
)) /= Base_Type
(Typ
) then
1711 (N
, Convert_To
(Typ
, New_Occurrence_Of
(Lit
, Loc
)));
1713 Rewrite
(N
, New_Occurrence_Of
(Lit
, Loc
));
1721 --------------------------
1722 -- Eval_Case_Expression --
1723 --------------------------
1725 -- Right now we do not attempt folding of any case expressions, and the
1726 -- language does not require it, so the only required processing is to
1727 -- do the check for all expressions appearing in the case expression.
1729 procedure Eval_Case_Expression
(N
: Node_Id
) is
1733 Check_Non_Static_Context
(Expression
(N
));
1735 Alt
:= First
(Alternatives
(N
));
1736 while Present
(Alt
) loop
1737 Check_Non_Static_Context
(Expression
(Alt
));
1740 end Eval_Case_Expression
;
1742 ------------------------
1743 -- Eval_Concatenation --
1744 ------------------------
1746 -- Concatenation is a static function, so the result is static if both
1747 -- operands are static (RM 4.9(7), 4.9(21)).
1749 procedure Eval_Concatenation
(N
: Node_Id
) is
1750 Left
: constant Node_Id
:= Left_Opnd
(N
);
1751 Right
: constant Node_Id
:= Right_Opnd
(N
);
1752 C_Typ
: constant Entity_Id
:= Root_Type
(Component_Type
(Etype
(N
)));
1757 -- Concatenation is never static in Ada 83, so if Ada 83 check operand
1758 -- non-static context.
1760 if Ada_Version
= Ada_83
1761 and then Comes_From_Source
(N
)
1763 Check_Non_Static_Context
(Left
);
1764 Check_Non_Static_Context
(Right
);
1768 -- If not foldable we are done. In principle concatenation that yields
1769 -- any string type is static (i.e. an array type of character types).
1770 -- However, character types can include enumeration literals, and
1771 -- concatenation in that case cannot be described by a literal, so we
1772 -- only consider the operation static if the result is an array of
1773 -- (a descendant of) a predefined character type.
1775 Test_Expression_Is_Foldable
(N
, Left
, Right
, Stat
, Fold
);
1777 if not (Is_Standard_Character_Type
(C_Typ
) and then Fold
) then
1778 Set_Is_Static_Expression
(N
, False);
1782 -- Compile time string concatenation
1784 -- ??? Note that operands that are aggregates can be marked as static,
1785 -- so we should attempt at a later stage to fold concatenations with
1789 Left_Str
: constant Node_Id
:= Get_String_Val
(Left
);
1791 Right_Str
: constant Node_Id
:= Get_String_Val
(Right
);
1792 Folded_Val
: String_Id
;
1795 -- Establish new string literal, and store left operand. We make
1796 -- sure to use the special Start_String that takes an operand if
1797 -- the left operand is a string literal. Since this is optimized
1798 -- in the case where that is the most recently created string
1799 -- literal, we ensure efficient time/space behavior for the
1800 -- case of a concatenation of a series of string literals.
1802 if Nkind
(Left_Str
) = N_String_Literal
then
1803 Left_Len
:= String_Length
(Strval
(Left_Str
));
1805 -- If the left operand is the empty string, and the right operand
1806 -- is a string literal (the case of "" & "..."), the result is the
1807 -- value of the right operand. This optimization is important when
1808 -- Is_Folded_In_Parser, to avoid copying an enormous right
1811 if Left_Len
= 0 and then Nkind
(Right_Str
) = N_String_Literal
then
1812 Folded_Val
:= Strval
(Right_Str
);
1814 Start_String
(Strval
(Left_Str
));
1819 Store_String_Char
(UI_To_CC
(Char_Literal_Value
(Left_Str
)));
1823 -- Now append the characters of the right operand, unless we
1824 -- optimized the "" & "..." case above.
1826 if Nkind
(Right_Str
) = N_String_Literal
then
1827 if Left_Len
/= 0 then
1828 Store_String_Chars
(Strval
(Right_Str
));
1829 Folded_Val
:= End_String
;
1832 Store_String_Char
(UI_To_CC
(Char_Literal_Value
(Right_Str
)));
1833 Folded_Val
:= End_String
;
1836 Set_Is_Static_Expression
(N
, Stat
);
1840 -- If left operand is the empty string, the result is the
1841 -- right operand, including its bounds if anomalous.
1844 and then Is_Array_Type
(Etype
(Right
))
1845 and then Etype
(Right
) /= Any_String
1847 Set_Etype
(N
, Etype
(Right
));
1850 Fold_Str
(N
, Folded_Val
, Static
=> True);
1853 end Eval_Concatenation
;
1855 ---------------------------------
1856 -- Eval_Conditional_Expression --
1857 ---------------------------------
1859 -- We can fold to a static expression if the condition and both constituent
1860 -- expressions are static. Otherwise, the only required processing is to do
1861 -- the check for non-static context for the then and else expressions.
1863 procedure Eval_Conditional_Expression
(N
: Node_Id
) is
1864 Condition
: constant Node_Id
:= First
(Expressions
(N
));
1865 Then_Expr
: constant Node_Id
:= Next
(Condition
);
1866 Else_Expr
: constant Node_Id
:= Next
(Then_Expr
);
1868 Non_Result
: Node_Id
;
1870 Rstat
: constant Boolean :=
1871 Is_Static_Expression
(Condition
)
1873 Is_Static_Expression
(Then_Expr
)
1875 Is_Static_Expression
(Else_Expr
);
1878 -- If any operand is Any_Type, just propagate to result and do not try
1879 -- to fold, this prevents cascaded errors.
1881 if Etype
(Condition
) = Any_Type
or else
1882 Etype
(Then_Expr
) = Any_Type
or else
1883 Etype
(Else_Expr
) = Any_Type
1885 Set_Etype
(N
, Any_Type
);
1886 Set_Is_Static_Expression
(N
, False);
1889 -- Static case where we can fold. Note that we don't try to fold cases
1890 -- where the condition is known at compile time, but the result is
1891 -- non-static. This avoids possible cases of infinite recursion where
1892 -- the expander puts in a redundant test and we remove it. Instead we
1893 -- deal with these cases in the expander.
1897 -- Select result operand
1899 if Is_True
(Expr_Value
(Condition
)) then
1900 Result
:= Then_Expr
;
1901 Non_Result
:= Else_Expr
;
1903 Result
:= Else_Expr
;
1904 Non_Result
:= Then_Expr
;
1907 -- Note that it does not matter if the non-result operand raises a
1908 -- Constraint_Error, but if the result raises constraint error then
1909 -- we replace the node with a raise constraint error. This will
1910 -- properly propagate Raises_Constraint_Error since this flag is
1913 if Raises_Constraint_Error
(Result
) then
1914 Rewrite_In_Raise_CE
(N
, Result
);
1915 Check_Non_Static_Context
(Non_Result
);
1917 -- Otherwise the result operand replaces the original node
1920 Rewrite
(N
, Relocate_Node
(Result
));
1923 -- Case of condition not known at compile time
1926 Check_Non_Static_Context
(Condition
);
1927 Check_Non_Static_Context
(Then_Expr
);
1928 Check_Non_Static_Context
(Else_Expr
);
1931 Set_Is_Static_Expression
(N
, Rstat
);
1932 end Eval_Conditional_Expression
;
1934 ----------------------
1935 -- Eval_Entity_Name --
1936 ----------------------
1938 -- This procedure is used for identifiers and expanded names other than
1939 -- named numbers (see Eval_Named_Integer, Eval_Named_Real. These are
1940 -- static if they denote a static constant (RM 4.9(6)) or if the name
1941 -- denotes an enumeration literal (RM 4.9(22)).
1943 procedure Eval_Entity_Name
(N
: Node_Id
) is
1944 Def_Id
: constant Entity_Id
:= Entity
(N
);
1948 -- Enumeration literals are always considered to be constants
1949 -- and cannot raise constraint error (RM 4.9(22)).
1951 if Ekind
(Def_Id
) = E_Enumeration_Literal
then
1952 Set_Is_Static_Expression
(N
);
1955 -- A name is static if it denotes a static constant (RM 4.9(5)), and
1956 -- we also copy Raise_Constraint_Error. Notice that even if non-static,
1957 -- it does not violate 10.2.1(8) here, since this is not a variable.
1959 elsif Ekind
(Def_Id
) = E_Constant
then
1961 -- Deferred constants must always be treated as nonstatic
1962 -- outside the scope of their full view.
1964 if Present
(Full_View
(Def_Id
))
1965 and then not In_Open_Scopes
(Scope
(Def_Id
))
1969 Val
:= Constant_Value
(Def_Id
);
1972 if Present
(Val
) then
1973 Set_Is_Static_Expression
1974 (N
, Is_Static_Expression
(Val
)
1975 and then Is_Static_Subtype
(Etype
(Def_Id
)));
1976 Set_Raises_Constraint_Error
(N
, Raises_Constraint_Error
(Val
));
1978 if not Is_Static_Expression
(N
)
1979 and then not Is_Generic_Type
(Etype
(N
))
1981 Validate_Static_Object_Name
(N
);
1988 -- Fall through if the name is not static
1990 Validate_Static_Object_Name
(N
);
1991 end Eval_Entity_Name
;
1993 ----------------------------
1994 -- Eval_Indexed_Component --
1995 ----------------------------
1997 -- Indexed components are never static, so we need to perform the check
1998 -- for non-static context on the index values. Then, we check if the
1999 -- value can be obtained at compile time, even though it is non-static.
2001 procedure Eval_Indexed_Component
(N
: Node_Id
) is
2005 -- Check for non-static context on index values
2007 Expr
:= First
(Expressions
(N
));
2008 while Present
(Expr
) loop
2009 Check_Non_Static_Context
(Expr
);
2013 -- If the indexed component appears in an object renaming declaration
2014 -- then we do not want to try to evaluate it, since in this case we
2015 -- need the identity of the array element.
2017 if Nkind
(Parent
(N
)) = N_Object_Renaming_Declaration
then
2020 -- Similarly if the indexed component appears as the prefix of an
2021 -- attribute we don't want to evaluate it, because at least for
2022 -- some cases of attributes we need the identify (e.g. Access, Size)
2024 elsif Nkind
(Parent
(N
)) = N_Attribute_Reference
then
2028 -- Note: there are other cases, such as the left side of an assignment,
2029 -- or an OUT parameter for a call, where the replacement results in the
2030 -- illegal use of a constant, But these cases are illegal in the first
2031 -- place, so the replacement, though silly, is harmless.
2033 -- Now see if this is a constant array reference
2035 if List_Length
(Expressions
(N
)) = 1
2036 and then Is_Entity_Name
(Prefix
(N
))
2037 and then Ekind
(Entity
(Prefix
(N
))) = E_Constant
2038 and then Present
(Constant_Value
(Entity
(Prefix
(N
))))
2041 Loc
: constant Source_Ptr
:= Sloc
(N
);
2042 Arr
: constant Node_Id
:= Constant_Value
(Entity
(Prefix
(N
)));
2043 Sub
: constant Node_Id
:= First
(Expressions
(N
));
2049 -- Linear one's origin subscript value for array reference
2052 -- Lower bound of the first array index
2055 -- Value from constant array
2058 Atyp
:= Etype
(Arr
);
2060 if Is_Access_Type
(Atyp
) then
2061 Atyp
:= Designated_Type
(Atyp
);
2064 -- If we have an array type (we should have but perhaps there are
2065 -- error cases where this is not the case), then see if we can do
2066 -- a constant evaluation of the array reference.
2068 if Is_Array_Type
(Atyp
) and then Atyp
/= Any_Composite
then
2069 if Ekind
(Atyp
) = E_String_Literal_Subtype
then
2070 Lbd
:= String_Literal_Low_Bound
(Atyp
);
2072 Lbd
:= Type_Low_Bound
(Etype
(First_Index
(Atyp
)));
2075 if Compile_Time_Known_Value
(Sub
)
2076 and then Nkind
(Arr
) = N_Aggregate
2077 and then Compile_Time_Known_Value
(Lbd
)
2078 and then Is_Discrete_Type
(Component_Type
(Atyp
))
2080 Lin
:= UI_To_Int
(Expr_Value
(Sub
) - Expr_Value
(Lbd
)) + 1;
2082 if List_Length
(Expressions
(Arr
)) >= Lin
then
2083 Elm
:= Pick
(Expressions
(Arr
), Lin
);
2085 -- If the resulting expression is compile time known,
2086 -- then we can rewrite the indexed component with this
2087 -- value, being sure to mark the result as non-static.
2088 -- We also reset the Sloc, in case this generates an
2089 -- error later on (e.g. 136'Access).
2091 if Compile_Time_Known_Value
(Elm
) then
2092 Rewrite
(N
, Duplicate_Subexpr_No_Checks
(Elm
));
2093 Set_Is_Static_Expression
(N
, False);
2098 -- We can also constant-fold if the prefix is a string literal.
2099 -- This will be useful in an instantiation or an inlining.
2101 elsif Compile_Time_Known_Value
(Sub
)
2102 and then Nkind
(Arr
) = N_String_Literal
2103 and then Compile_Time_Known_Value
(Lbd
)
2104 and then Expr_Value
(Lbd
) = 1
2105 and then Expr_Value
(Sub
) <=
2106 String_Literal_Length
(Etype
(Arr
))
2109 C
: constant Char_Code
:=
2110 Get_String_Char
(Strval
(Arr
),
2111 UI_To_Int
(Expr_Value
(Sub
)));
2113 Set_Character_Literal_Name
(C
);
2116 Make_Character_Literal
(Loc
,
2118 Char_Literal_Value
=> UI_From_CC
(C
));
2119 Set_Etype
(Elm
, Component_Type
(Atyp
));
2120 Rewrite
(N
, Duplicate_Subexpr_No_Checks
(Elm
));
2121 Set_Is_Static_Expression
(N
, False);
2127 end Eval_Indexed_Component
;
2129 --------------------------
2130 -- Eval_Integer_Literal --
2131 --------------------------
2133 -- Numeric literals are static (RM 4.9(1)), and have already been marked
2134 -- as static by the analyzer. The reason we did it that early is to allow
2135 -- the possibility of turning off the Is_Static_Expression flag after
2136 -- analysis, but before resolution, when integer literals are generated in
2137 -- the expander that do not correspond to static expressions.
2139 procedure Eval_Integer_Literal
(N
: Node_Id
) is
2140 T
: constant Entity_Id
:= Etype
(N
);
2142 function In_Any_Integer_Context
return Boolean;
2143 -- If the literal is resolved with a specific type in a context where
2144 -- the expected type is Any_Integer, there are no range checks on the
2145 -- literal. By the time the literal is evaluated, it carries the type
2146 -- imposed by the enclosing expression, and we must recover the context
2147 -- to determine that Any_Integer is meant.
2149 ----------------------------
2150 -- In_Any_Integer_Context --
2151 ----------------------------
2153 function In_Any_Integer_Context
return Boolean is
2154 Par
: constant Node_Id
:= Parent
(N
);
2155 K
: constant Node_Kind
:= Nkind
(Par
);
2158 -- Any_Integer also appears in digits specifications for real types,
2159 -- but those have bounds smaller that those of any integer base type,
2160 -- so we can safely ignore these cases.
2162 return K
= N_Number_Declaration
2163 or else K
= N_Attribute_Reference
2164 or else K
= N_Attribute_Definition_Clause
2165 or else K
= N_Modular_Type_Definition
2166 or else K
= N_Signed_Integer_Type_Definition
;
2167 end In_Any_Integer_Context
;
2169 -- Start of processing for Eval_Integer_Literal
2173 -- If the literal appears in a non-expression context, then it is
2174 -- certainly appearing in a non-static context, so check it. This is
2175 -- actually a redundant check, since Check_Non_Static_Context would
2176 -- check it, but it seems worth while avoiding the call.
2178 if Nkind
(Parent
(N
)) not in N_Subexpr
2179 and then not In_Any_Integer_Context
2181 Check_Non_Static_Context
(N
);
2184 -- Modular integer literals must be in their base range
2186 if Is_Modular_Integer_Type
(T
)
2187 and then Is_Out_Of_Range
(N
, Base_Type
(T
), Assume_Valid
=> True)
2191 end Eval_Integer_Literal
;
2193 ---------------------
2194 -- Eval_Logical_Op --
2195 ---------------------
2197 -- Logical operations are static functions, so the result is potentially
2198 -- static if both operands are potentially static (RM 4.9(7), 4.9(20)).
2200 procedure Eval_Logical_Op
(N
: Node_Id
) is
2201 Left
: constant Node_Id
:= Left_Opnd
(N
);
2202 Right
: constant Node_Id
:= Right_Opnd
(N
);
2207 -- If not foldable we are done
2209 Test_Expression_Is_Foldable
(N
, Left
, Right
, Stat
, Fold
);
2215 -- Compile time evaluation of logical operation
2218 Left_Int
: constant Uint
:= Expr_Value
(Left
);
2219 Right_Int
: constant Uint
:= Expr_Value
(Right
);
2222 -- VMS includes bitwise operations on signed types
2224 if Is_Modular_Integer_Type
(Etype
(N
))
2225 or else Is_VMS_Operator
(Entity
(N
))
2228 Left_Bits
: Bits
(0 .. UI_To_Int
(Esize
(Etype
(N
))) - 1);
2229 Right_Bits
: Bits
(0 .. UI_To_Int
(Esize
(Etype
(N
))) - 1);
2232 To_Bits
(Left_Int
, Left_Bits
);
2233 To_Bits
(Right_Int
, Right_Bits
);
2235 -- Note: should really be able to use array ops instead of
2236 -- these loops, but they weren't working at the time ???
2238 if Nkind
(N
) = N_Op_And
then
2239 for J
in Left_Bits
'Range loop
2240 Left_Bits
(J
) := Left_Bits
(J
) and Right_Bits
(J
);
2243 elsif Nkind
(N
) = N_Op_Or
then
2244 for J
in Left_Bits
'Range loop
2245 Left_Bits
(J
) := Left_Bits
(J
) or Right_Bits
(J
);
2249 pragma Assert
(Nkind
(N
) = N_Op_Xor
);
2251 for J
in Left_Bits
'Range loop
2252 Left_Bits
(J
) := Left_Bits
(J
) xor Right_Bits
(J
);
2256 Fold_Uint
(N
, From_Bits
(Left_Bits
, Etype
(N
)), Stat
);
2260 pragma Assert
(Is_Boolean_Type
(Etype
(N
)));
2262 if Nkind
(N
) = N_Op_And
then
2264 Test
(Is_True
(Left_Int
) and then Is_True
(Right_Int
)), Stat
);
2266 elsif Nkind
(N
) = N_Op_Or
then
2268 Test
(Is_True
(Left_Int
) or else Is_True
(Right_Int
)), Stat
);
2271 pragma Assert
(Nkind
(N
) = N_Op_Xor
);
2273 Test
(Is_True
(Left_Int
) xor Is_True
(Right_Int
)), Stat
);
2277 end Eval_Logical_Op
;
2279 ------------------------
2280 -- Eval_Membership_Op --
2281 ------------------------
2283 -- A membership test is potentially static if the expression is static, and
2284 -- the range is a potentially static range, or is a subtype mark denoting a
2285 -- static subtype (RM 4.9(12)).
2287 procedure Eval_Membership_Op
(N
: Node_Id
) is
2288 Left
: constant Node_Id
:= Left_Opnd
(N
);
2289 Right
: constant Node_Id
:= Right_Opnd
(N
);
2298 -- Ignore if error in either operand, except to make sure that Any_Type
2299 -- is properly propagated to avoid junk cascaded errors.
2301 if Etype
(Left
) = Any_Type
or else Etype
(Right
) = Any_Type
then
2302 Set_Etype
(N
, Any_Type
);
2306 -- Ignore if types involved have predicates
2308 if Present
(Predicate_Function
(Etype
(Left
)))
2310 Present
(Predicate_Function
(Etype
(Right
)))
2315 -- Case of right operand is a subtype name
2317 if Is_Entity_Name
(Right
) then
2318 Def_Id
:= Entity
(Right
);
2320 if (Is_Scalar_Type
(Def_Id
) or else Is_String_Type
(Def_Id
))
2321 and then Is_OK_Static_Subtype
(Def_Id
)
2323 Test_Expression_Is_Foldable
(N
, Left
, Stat
, Fold
);
2325 if not Fold
or else not Stat
then
2329 Check_Non_Static_Context
(Left
);
2333 -- For string membership tests we will check the length further on
2335 if not Is_String_Type
(Def_Id
) then
2336 Lo
:= Type_Low_Bound
(Def_Id
);
2337 Hi
:= Type_High_Bound
(Def_Id
);
2344 -- Case of right operand is a range
2347 if Is_Static_Range
(Right
) then
2348 Test_Expression_Is_Foldable
(N
, Left
, Stat
, Fold
);
2350 if not Fold
or else not Stat
then
2353 -- If one bound of range raises CE, then don't try to fold
2355 elsif not Is_OK_Static_Range
(Right
) then
2356 Check_Non_Static_Context
(Left
);
2361 Check_Non_Static_Context
(Left
);
2365 -- Here we know range is an OK static range
2367 Lo
:= Low_Bound
(Right
);
2368 Hi
:= High_Bound
(Right
);
2371 -- For strings we check that the length of the string expression is
2372 -- compatible with the string subtype if the subtype is constrained,
2373 -- or if unconstrained then the test is always true.
2375 if Is_String_Type
(Etype
(Right
)) then
2376 if not Is_Constrained
(Etype
(Right
)) then
2381 Typlen
: constant Uint
:= String_Type_Len
(Etype
(Right
));
2382 Strlen
: constant Uint
:=
2384 (String_Length
(Strval
(Get_String_Val
(Left
))));
2386 Result
:= (Typlen
= Strlen
);
2390 -- Fold the membership test. We know we have a static range and Lo and
2391 -- Hi are set to the expressions for the end points of this range.
2393 elsif Is_Real_Type
(Etype
(Right
)) then
2395 Leftval
: constant Ureal
:= Expr_Value_R
(Left
);
2398 Result
:= Expr_Value_R
(Lo
) <= Leftval
2399 and then Leftval
<= Expr_Value_R
(Hi
);
2404 Leftval
: constant Uint
:= Expr_Value
(Left
);
2407 Result
:= Expr_Value
(Lo
) <= Leftval
2408 and then Leftval
<= Expr_Value
(Hi
);
2412 if Nkind
(N
) = N_Not_In
then
2413 Result
:= not Result
;
2416 Fold_Uint
(N
, Test
(Result
), True);
2418 Warn_On_Known_Condition
(N
);
2419 end Eval_Membership_Op
;
2421 ------------------------
2422 -- Eval_Named_Integer --
2423 ------------------------
2425 procedure Eval_Named_Integer
(N
: Node_Id
) is
2428 Expr_Value
(Expression
(Declaration_Node
(Entity
(N
)))), True);
2429 end Eval_Named_Integer
;
2431 ---------------------
2432 -- Eval_Named_Real --
2433 ---------------------
2435 procedure Eval_Named_Real
(N
: Node_Id
) is
2438 Expr_Value_R
(Expression
(Declaration_Node
(Entity
(N
)))), True);
2439 end Eval_Named_Real
;
2445 -- Exponentiation is a static functions, so the result is potentially
2446 -- static if both operands are potentially static (RM 4.9(7), 4.9(20)).
2448 procedure Eval_Op_Expon
(N
: Node_Id
) is
2449 Left
: constant Node_Id
:= Left_Opnd
(N
);
2450 Right
: constant Node_Id
:= Right_Opnd
(N
);
2455 -- If not foldable we are done
2457 Test_Expression_Is_Foldable
(N
, Left
, Right
, Stat
, Fold
);
2463 -- Fold exponentiation operation
2466 Right_Int
: constant Uint
:= Expr_Value
(Right
);
2471 if Is_Integer_Type
(Etype
(Left
)) then
2473 Left_Int
: constant Uint
:= Expr_Value
(Left
);
2477 -- Exponentiation of an integer raises Constraint_Error for a
2478 -- negative exponent (RM 4.5.6).
2480 if Right_Int
< 0 then
2481 Apply_Compile_Time_Constraint_Error
2482 (N
, "integer exponent negative",
2483 CE_Range_Check_Failed
,
2488 if OK_Bits
(N
, Num_Bits
(Left_Int
) * Right_Int
) then
2489 Result
:= Left_Int
** Right_Int
;
2494 if Is_Modular_Integer_Type
(Etype
(N
)) then
2495 Result
:= Result
mod Modulus
(Etype
(N
));
2498 Fold_Uint
(N
, Result
, Stat
);
2506 Left_Real
: constant Ureal
:= Expr_Value_R
(Left
);
2509 -- Cannot have a zero base with a negative exponent
2511 if UR_Is_Zero
(Left_Real
) then
2513 if Right_Int
< 0 then
2514 Apply_Compile_Time_Constraint_Error
2515 (N
, "zero ** negative integer",
2516 CE_Range_Check_Failed
,
2520 Fold_Ureal
(N
, Ureal_0
, Stat
);
2524 Fold_Ureal
(N
, Left_Real
** Right_Int
, Stat
);
2535 -- The not operation is a static functions, so the result is potentially
2536 -- static if the operand is potentially static (RM 4.9(7), 4.9(20)).
2538 procedure Eval_Op_Not
(N
: Node_Id
) is
2539 Right
: constant Node_Id
:= Right_Opnd
(N
);
2544 -- If not foldable we are done
2546 Test_Expression_Is_Foldable
(N
, Right
, Stat
, Fold
);
2552 -- Fold not operation
2555 Rint
: constant Uint
:= Expr_Value
(Right
);
2556 Typ
: constant Entity_Id
:= Etype
(N
);
2559 -- Negation is equivalent to subtracting from the modulus minus one.
2560 -- For a binary modulus this is equivalent to the ones-complement of
2561 -- the original value. For non-binary modulus this is an arbitrary
2562 -- but consistent definition.
2564 if Is_Modular_Integer_Type
(Typ
) then
2565 Fold_Uint
(N
, Modulus
(Typ
) - 1 - Rint
, Stat
);
2568 pragma Assert
(Is_Boolean_Type
(Typ
));
2569 Fold_Uint
(N
, Test
(not Is_True
(Rint
)), Stat
);
2572 Set_Is_Static_Expression
(N
, Stat
);
2576 -------------------------------
2577 -- Eval_Qualified_Expression --
2578 -------------------------------
2580 -- A qualified expression is potentially static if its subtype mark denotes
2581 -- a static subtype and its expression is potentially static (RM 4.9 (11)).
2583 procedure Eval_Qualified_Expression
(N
: Node_Id
) is
2584 Operand
: constant Node_Id
:= Expression
(N
);
2585 Target_Type
: constant Entity_Id
:= Entity
(Subtype_Mark
(N
));
2592 -- Can only fold if target is string or scalar and subtype is static.
2593 -- Also, do not fold if our parent is an allocator (this is because the
2594 -- qualified expression is really part of the syntactic structure of an
2595 -- allocator, and we do not want to end up with something that
2596 -- corresponds to "new 1" where the 1 is the result of folding a
2597 -- qualified expression).
2599 if not Is_Static_Subtype
(Target_Type
)
2600 or else Nkind
(Parent
(N
)) = N_Allocator
2602 Check_Non_Static_Context
(Operand
);
2604 -- If operand is known to raise constraint_error, set the flag on the
2605 -- expression so it does not get optimized away.
2607 if Nkind
(Operand
) = N_Raise_Constraint_Error
then
2608 Set_Raises_Constraint_Error
(N
);
2614 -- If not foldable we are done
2616 Test_Expression_Is_Foldable
(N
, Operand
, Stat
, Fold
);
2621 -- Don't try fold if target type has constraint error bounds
2623 elsif not Is_OK_Static_Subtype
(Target_Type
) then
2624 Set_Raises_Constraint_Error
(N
);
2628 -- Here we will fold, save Print_In_Hex indication
2630 Hex
:= Nkind
(Operand
) = N_Integer_Literal
2631 and then Print_In_Hex
(Operand
);
2633 -- Fold the result of qualification
2635 if Is_Discrete_Type
(Target_Type
) then
2636 Fold_Uint
(N
, Expr_Value
(Operand
), Stat
);
2638 -- Preserve Print_In_Hex indication
2640 if Hex
and then Nkind
(N
) = N_Integer_Literal
then
2641 Set_Print_In_Hex
(N
);
2644 elsif Is_Real_Type
(Target_Type
) then
2645 Fold_Ureal
(N
, Expr_Value_R
(Operand
), Stat
);
2648 Fold_Str
(N
, Strval
(Get_String_Val
(Operand
)), Stat
);
2651 Set_Is_Static_Expression
(N
, False);
2653 Check_String_Literal_Length
(N
, Target_Type
);
2659 -- The expression may be foldable but not static
2661 Set_Is_Static_Expression
(N
, Stat
);
2663 if Is_Out_Of_Range
(N
, Etype
(N
), Assume_Valid
=> True) then
2666 end Eval_Qualified_Expression
;
2668 -----------------------
2669 -- Eval_Real_Literal --
2670 -----------------------
2672 -- Numeric literals are static (RM 4.9(1)), and have already been marked
2673 -- as static by the analyzer. The reason we did it that early is to allow
2674 -- the possibility of turning off the Is_Static_Expression flag after
2675 -- analysis, but before resolution, when integer literals are generated
2676 -- in the expander that do not correspond to static expressions.
2678 procedure Eval_Real_Literal
(N
: Node_Id
) is
2679 PK
: constant Node_Kind
:= Nkind
(Parent
(N
));
2682 -- If the literal appears in a non-expression context and not as part of
2683 -- a number declaration, then it is appearing in a non-static context,
2686 if PK
not in N_Subexpr
and then PK
/= N_Number_Declaration
then
2687 Check_Non_Static_Context
(N
);
2689 end Eval_Real_Literal
;
2691 ------------------------
2692 -- Eval_Relational_Op --
2693 ------------------------
2695 -- Relational operations are static functions, so the result is static if
2696 -- both operands are static (RM 4.9(7), 4.9(20)), except that for strings,
2697 -- the result is never static, even if the operands are.
2699 procedure Eval_Relational_Op
(N
: Node_Id
) is
2700 Left
: constant Node_Id
:= Left_Opnd
(N
);
2701 Right
: constant Node_Id
:= Right_Opnd
(N
);
2702 Typ
: constant Entity_Id
:= Etype
(Left
);
2703 Otype
: Entity_Id
:= Empty
;
2709 -- One special case to deal with first. If we can tell that the result
2710 -- will be false because the lengths of one or more index subtypes are
2711 -- compile time known and different, then we can replace the entire
2712 -- result by False. We only do this for one dimensional arrays, because
2713 -- the case of multi-dimensional arrays is rare and too much trouble! If
2714 -- one of the operands is an illegal aggregate, its type might still be
2715 -- an arbitrary composite type, so nothing to do.
2717 if Is_Array_Type
(Typ
)
2718 and then Typ
/= Any_Composite
2719 and then Number_Dimensions
(Typ
) = 1
2720 and then (Nkind
(N
) = N_Op_Eq
or else Nkind
(N
) = N_Op_Ne
)
2722 if Raises_Constraint_Error
(Left
)
2723 or else Raises_Constraint_Error
(Right
)
2728 -- OK, we have the case where we may be able to do this fold
2730 Length_Mismatch
: declare
2731 procedure Get_Static_Length
(Op
: Node_Id
; Len
: out Uint
);
2732 -- If Op is an expression for a constrained array with a known at
2733 -- compile time length, then Len is set to this (non-negative
2734 -- length). Otherwise Len is set to minus 1.
2736 -----------------------
2737 -- Get_Static_Length --
2738 -----------------------
2740 procedure Get_Static_Length
(Op
: Node_Id
; Len
: out Uint
) is
2744 -- First easy case string literal
2746 if Nkind
(Op
) = N_String_Literal
then
2747 Len
:= UI_From_Int
(String_Length
(Strval
(Op
)));
2751 -- Second easy case, not constrained subtype, so no length
2753 if not Is_Constrained
(Etype
(Op
)) then
2754 Len
:= Uint_Minus_1
;
2760 T
:= Etype
(First_Index
(Etype
(Op
)));
2762 -- The simple case, both bounds are known at compile time
2764 if Is_Discrete_Type
(T
)
2766 Compile_Time_Known_Value
(Type_Low_Bound
(T
))
2768 Compile_Time_Known_Value
(Type_High_Bound
(T
))
2770 Len
:= UI_Max
(Uint_0
,
2771 Expr_Value
(Type_High_Bound
(T
)) -
2772 Expr_Value
(Type_Low_Bound
(T
)) + 1);
2776 -- A more complex case, where the bounds are of the form
2777 -- X [+/- K1] .. X [+/- K2]), where X is an expression that is
2778 -- either A'First or A'Last (with A an entity name), or X is an
2779 -- entity name, and the two X's are the same and K1 and K2 are
2780 -- known at compile time, in this case, the length can also be
2781 -- computed at compile time, even though the bounds are not
2782 -- known. A common case of this is e.g. (X'First .. X'First+5).
2784 Extract_Length
: declare
2785 procedure Decompose_Expr
2787 Ent
: out Entity_Id
;
2788 Kind
: out Character;
2790 -- Given an expression, see if is of the form above,
2791 -- X [+/- K]. If so Ent is set to the entity in X,
2792 -- Kind is 'F','L','E' for 'First/'Last/simple entity,
2793 -- and Cons is the value of K. If the expression is
2794 -- not of the required form, Ent is set to Empty.
2796 --------------------
2797 -- Decompose_Expr --
2798 --------------------
2800 procedure Decompose_Expr
2802 Ent
: out Entity_Id
;
2803 Kind
: out Character;
2809 if Nkind
(Expr
) = N_Op_Add
2810 and then Compile_Time_Known_Value
(Right_Opnd
(Expr
))
2812 Exp
:= Left_Opnd
(Expr
);
2813 Cons
:= Expr_Value
(Right_Opnd
(Expr
));
2815 elsif Nkind
(Expr
) = N_Op_Subtract
2816 and then Compile_Time_Known_Value
(Right_Opnd
(Expr
))
2818 Exp
:= Left_Opnd
(Expr
);
2819 Cons
:= -Expr_Value
(Right_Opnd
(Expr
));
2821 -- If the bound is a constant created to remove side
2822 -- effects, recover original expression to see if it has
2823 -- one of the recognizable forms.
2825 elsif Nkind
(Expr
) = N_Identifier
2826 and then not Comes_From_Source
(Entity
(Expr
))
2827 and then Ekind
(Entity
(Expr
)) = E_Constant
2829 Nkind
(Parent
(Entity
(Expr
))) = N_Object_Declaration
2831 Exp
:= Expression
(Parent
(Entity
(Expr
)));
2832 Decompose_Expr
(Exp
, Ent
, Kind
, Cons
);
2834 -- If original expression includes an entity, create a
2835 -- reference to it for use below.
2837 if Present
(Ent
) then
2838 Exp
:= New_Occurrence_Of
(Ent
, Sloc
(Ent
));
2846 -- At this stage Exp is set to the potential X
2848 if Nkind
(Exp
) = N_Attribute_Reference
then
2849 if Attribute_Name
(Exp
) = Name_First
then
2852 elsif Attribute_Name
(Exp
) = Name_Last
then
2860 Exp
:= Prefix
(Exp
);
2866 if Is_Entity_Name
(Exp
)
2867 and then Present
(Entity
(Exp
))
2869 Ent
:= Entity
(Exp
);
2877 Ent1
, Ent2
: Entity_Id
;
2878 Kind1
, Kind2
: Character;
2879 Cons1
, Cons2
: Uint
;
2881 -- Start of processing for Extract_Length
2885 (Original_Node
(Type_Low_Bound
(T
)), Ent1
, Kind1
, Cons1
);
2887 (Original_Node
(Type_High_Bound
(T
)), Ent2
, Kind2
, Cons2
);
2890 and then Kind1
= Kind2
2891 and then Ent1
= Ent2
2893 Len
:= Cons2
- Cons1
+ 1;
2895 Len
:= Uint_Minus_1
;
2898 end Get_Static_Length
;
2905 -- Start of processing for Length_Mismatch
2908 Get_Static_Length
(Left
, Len_L
);
2909 Get_Static_Length
(Right
, Len_R
);
2911 if Len_L
/= Uint_Minus_1
2912 and then Len_R
/= Uint_Minus_1
2913 and then Len_L
/= Len_R
2915 Fold_Uint
(N
, Test
(Nkind
(N
) = N_Op_Ne
), False);
2916 Warn_On_Known_Condition
(N
);
2919 end Length_Mismatch
;
2922 -- Test for expression being foldable
2924 Test_Expression_Is_Foldable
(N
, Left
, Right
, Stat
, Fold
);
2926 -- Only comparisons of scalars can give static results. In particular,
2927 -- comparisons of strings never yield a static result, even if both
2928 -- operands are static strings.
2930 if not Is_Scalar_Type
(Typ
) then
2932 Set_Is_Static_Expression
(N
, False);
2935 -- For operators on universal numeric types called as functions with
2936 -- an explicit scope, determine appropriate specific numeric type, and
2937 -- diagnose possible ambiguity.
2939 if Is_Universal_Numeric_Type
(Etype
(Left
))
2941 Is_Universal_Numeric_Type
(Etype
(Right
))
2943 Otype
:= Find_Universal_Operator_Type
(N
);
2946 -- For static real type expressions, we cannot use Compile_Time_Compare
2947 -- since it worries about run-time results which are not exact.
2949 if Stat
and then Is_Real_Type
(Typ
) then
2951 Left_Real
: constant Ureal
:= Expr_Value_R
(Left
);
2952 Right_Real
: constant Ureal
:= Expr_Value_R
(Right
);
2956 when N_Op_Eq
=> Result
:= (Left_Real
= Right_Real
);
2957 when N_Op_Ne
=> Result
:= (Left_Real
/= Right_Real
);
2958 when N_Op_Lt
=> Result
:= (Left_Real
< Right_Real
);
2959 when N_Op_Le
=> Result
:= (Left_Real
<= Right_Real
);
2960 when N_Op_Gt
=> Result
:= (Left_Real
> Right_Real
);
2961 when N_Op_Ge
=> Result
:= (Left_Real
>= Right_Real
);
2964 raise Program_Error
;
2967 Fold_Uint
(N
, Test
(Result
), True);
2970 -- For all other cases, we use Compile_Time_Compare to do the compare
2974 CR
: constant Compare_Result
:=
2975 Compile_Time_Compare
(Left
, Right
, Assume_Valid
=> False);
2978 if CR
= Unknown
then
2986 elsif CR
= NE
or else CR
= GT
or else CR
= LT
then
2993 if CR
= NE
or else CR
= GT
or else CR
= LT
then
3004 elsif CR
= EQ
or else CR
= GT
or else CR
= GE
then
3011 if CR
= LT
or else CR
= EQ
or else CR
= LE
then
3022 elsif CR
= EQ
or else CR
= LT
or else CR
= LE
then
3029 if CR
= GT
or else CR
= EQ
or else CR
= GE
then
3038 raise Program_Error
;
3042 Fold_Uint
(N
, Test
(Result
), Stat
);
3045 -- For the case of a folded relational operator on a specific numeric
3046 -- type, freeze operand type now.
3048 if Present
(Otype
) then
3049 Freeze_Before
(N
, Otype
);
3052 Warn_On_Known_Condition
(N
);
3053 end Eval_Relational_Op
;
3059 -- Shift operations are intrinsic operations that can never be static, so
3060 -- the only processing required is to perform the required check for a non
3061 -- static context for the two operands.
3063 -- Actually we could do some compile time evaluation here some time ???
3065 procedure Eval_Shift
(N
: Node_Id
) is
3067 Check_Non_Static_Context
(Left_Opnd
(N
));
3068 Check_Non_Static_Context
(Right_Opnd
(N
));
3071 ------------------------
3072 -- Eval_Short_Circuit --
3073 ------------------------
3075 -- A short circuit operation is potentially static if both operands are
3076 -- potentially static (RM 4.9 (13)).
3078 procedure Eval_Short_Circuit
(N
: Node_Id
) is
3079 Kind
: constant Node_Kind
:= Nkind
(N
);
3080 Left
: constant Node_Id
:= Left_Opnd
(N
);
3081 Right
: constant Node_Id
:= Right_Opnd
(N
);
3084 Rstat
: constant Boolean :=
3085 Is_Static_Expression
(Left
)
3087 Is_Static_Expression
(Right
);
3090 -- Short circuit operations are never static in Ada 83
3092 if Ada_Version
= Ada_83
and then Comes_From_Source
(N
) then
3093 Check_Non_Static_Context
(Left
);
3094 Check_Non_Static_Context
(Right
);
3098 -- Now look at the operands, we can't quite use the normal call to
3099 -- Test_Expression_Is_Foldable here because short circuit operations
3100 -- are a special case, they can still be foldable, even if the right
3101 -- operand raises constraint error.
3103 -- If either operand is Any_Type, just propagate to result and do not
3104 -- try to fold, this prevents cascaded errors.
3106 if Etype
(Left
) = Any_Type
or else Etype
(Right
) = Any_Type
then
3107 Set_Etype
(N
, Any_Type
);
3110 -- If left operand raises constraint error, then replace node N with
3111 -- the raise constraint error node, and we are obviously not foldable.
3112 -- Is_Static_Expression is set from the two operands in the normal way,
3113 -- and we check the right operand if it is in a non-static context.
3115 elsif Raises_Constraint_Error
(Left
) then
3117 Check_Non_Static_Context
(Right
);
3120 Rewrite_In_Raise_CE
(N
, Left
);
3121 Set_Is_Static_Expression
(N
, Rstat
);
3124 -- If the result is not static, then we won't in any case fold
3126 elsif not Rstat
then
3127 Check_Non_Static_Context
(Left
);
3128 Check_Non_Static_Context
(Right
);
3132 -- Here the result is static, note that, unlike the normal processing
3133 -- in Test_Expression_Is_Foldable, we did *not* check above to see if
3134 -- the right operand raises constraint error, that's because it is not
3135 -- significant if the left operand is decisive.
3137 Set_Is_Static_Expression
(N
);
3139 -- It does not matter if the right operand raises constraint error if
3140 -- it will not be evaluated. So deal specially with the cases where
3141 -- the right operand is not evaluated. Note that we will fold these
3142 -- cases even if the right operand is non-static, which is fine, but
3143 -- of course in these cases the result is not potentially static.
3145 Left_Int
:= Expr_Value
(Left
);
3147 if (Kind
= N_And_Then
and then Is_False
(Left_Int
))
3149 (Kind
= N_Or_Else
and then Is_True
(Left_Int
))
3151 Fold_Uint
(N
, Left_Int
, Rstat
);
3155 -- If first operand not decisive, then it does matter if the right
3156 -- operand raises constraint error, since it will be evaluated, so
3157 -- we simply replace the node with the right operand. Note that this
3158 -- properly propagates Is_Static_Expression and Raises_Constraint_Error
3159 -- (both are set to True in Right).
3161 if Raises_Constraint_Error
(Right
) then
3162 Rewrite_In_Raise_CE
(N
, Right
);
3163 Check_Non_Static_Context
(Left
);
3167 -- Otherwise the result depends on the right operand
3169 Fold_Uint
(N
, Expr_Value
(Right
), Rstat
);
3171 end Eval_Short_Circuit
;
3177 -- Slices can never be static, so the only processing required is to check
3178 -- for non-static context if an explicit range is given.
3180 procedure Eval_Slice
(N
: Node_Id
) is
3181 Drange
: constant Node_Id
:= Discrete_Range
(N
);
3183 if Nkind
(Drange
) = N_Range
then
3184 Check_Non_Static_Context
(Low_Bound
(Drange
));
3185 Check_Non_Static_Context
(High_Bound
(Drange
));
3188 -- A slice of the form A (subtype), when the subtype is the index of
3189 -- the type of A, is redundant, the slice can be replaced with A, and
3190 -- this is worth a warning.
3192 if Is_Entity_Name
(Prefix
(N
)) then
3194 E
: constant Entity_Id
:= Entity
(Prefix
(N
));
3195 T
: constant Entity_Id
:= Etype
(E
);
3197 if Ekind
(E
) = E_Constant
3198 and then Is_Array_Type
(T
)
3199 and then Is_Entity_Name
(Drange
)
3201 if Is_Entity_Name
(Original_Node
(First_Index
(T
)))
3202 and then Entity
(Original_Node
(First_Index
(T
)))
3205 if Warn_On_Redundant_Constructs
then
3206 Error_Msg_N
("redundant slice denotes whole array?", N
);
3209 -- The following might be a useful optimization????
3211 -- Rewrite (N, New_Occurrence_Of (E, Sloc (N)));
3218 -------------------------
3219 -- Eval_String_Literal --
3220 -------------------------
3222 procedure Eval_String_Literal
(N
: Node_Id
) is
3223 Typ
: constant Entity_Id
:= Etype
(N
);
3224 Bas
: constant Entity_Id
:= Base_Type
(Typ
);
3230 -- Nothing to do if error type (handles cases like default expressions
3231 -- or generics where we have not yet fully resolved the type).
3233 if Bas
= Any_Type
or else Bas
= Any_String
then
3237 -- String literals are static if the subtype is static (RM 4.9(2)), so
3238 -- reset the static expression flag (it was set unconditionally in
3239 -- Analyze_String_Literal) if the subtype is non-static. We tell if
3240 -- the subtype is static by looking at the lower bound.
3242 if Ekind
(Typ
) = E_String_Literal_Subtype
then
3243 if not Is_OK_Static_Expression
(String_Literal_Low_Bound
(Typ
)) then
3244 Set_Is_Static_Expression
(N
, False);
3248 -- Here if Etype of string literal is normal Etype (not yet possible,
3249 -- but may be possible in future).
3251 elsif not Is_OK_Static_Expression
3252 (Type_Low_Bound
(Etype
(First_Index
(Typ
))))
3254 Set_Is_Static_Expression
(N
, False);
3258 -- If original node was a type conversion, then result if non-static
3260 if Nkind
(Original_Node
(N
)) = N_Type_Conversion
then
3261 Set_Is_Static_Expression
(N
, False);
3265 -- Test for illegal Ada 95 cases. A string literal is illegal in Ada 95
3266 -- if its bounds are outside the index base type and this index type is
3267 -- static. This can happen in only two ways. Either the string literal
3268 -- is too long, or it is null, and the lower bound is type'First. In
3269 -- either case it is the upper bound that is out of range of the index
3272 if Ada_Version
>= Ada_95
then
3273 if Root_Type
(Bas
) = Standard_String
3275 Root_Type
(Bas
) = Standard_Wide_String
3277 Xtp
:= Standard_Positive
;
3279 Xtp
:= Etype
(First_Index
(Bas
));
3282 if Ekind
(Typ
) = E_String_Literal_Subtype
then
3283 Lo
:= String_Literal_Low_Bound
(Typ
);
3285 Lo
:= Type_Low_Bound
(Etype
(First_Index
(Typ
)));
3288 Len
:= String_Length
(Strval
(N
));
3290 if UI_From_Int
(Len
) > String_Type_Len
(Bas
) then
3291 Apply_Compile_Time_Constraint_Error
3292 (N
, "string literal too long for}", CE_Length_Check_Failed
,
3294 Typ
=> First_Subtype
(Bas
));
3297 and then not Is_Generic_Type
(Xtp
)
3299 Expr_Value
(Lo
) = Expr_Value
(Type_Low_Bound
(Base_Type
(Xtp
)))
3301 Apply_Compile_Time_Constraint_Error
3302 (N
, "null string literal not allowed for}",
3303 CE_Length_Check_Failed
,
3305 Typ
=> First_Subtype
(Bas
));
3308 end Eval_String_Literal
;
3310 --------------------------
3311 -- Eval_Type_Conversion --
3312 --------------------------
3314 -- A type conversion is potentially static if its subtype mark is for a
3315 -- static scalar subtype, and its operand expression is potentially static
3318 procedure Eval_Type_Conversion
(N
: Node_Id
) is
3319 Operand
: constant Node_Id
:= Expression
(N
);
3320 Source_Type
: constant Entity_Id
:= Etype
(Operand
);
3321 Target_Type
: constant Entity_Id
:= Etype
(N
);
3326 function To_Be_Treated_As_Integer
(T
: Entity_Id
) return Boolean;
3327 -- Returns true if type T is an integer type, or if it is a fixed-point
3328 -- type to be treated as an integer (i.e. the flag Conversion_OK is set
3329 -- on the conversion node).
3331 function To_Be_Treated_As_Real
(T
: Entity_Id
) return Boolean;
3332 -- Returns true if type T is a floating-point type, or if it is a
3333 -- fixed-point type that is not to be treated as an integer (i.e. the
3334 -- flag Conversion_OK is not set on the conversion node).
3336 ------------------------------
3337 -- To_Be_Treated_As_Integer --
3338 ------------------------------
3340 function To_Be_Treated_As_Integer
(T
: Entity_Id
) return Boolean is
3344 or else (Is_Fixed_Point_Type
(T
) and then Conversion_OK
(N
));
3345 end To_Be_Treated_As_Integer
;
3347 ---------------------------
3348 -- To_Be_Treated_As_Real --
3349 ---------------------------
3351 function To_Be_Treated_As_Real
(T
: Entity_Id
) return Boolean is
3354 Is_Floating_Point_Type
(T
)
3355 or else (Is_Fixed_Point_Type
(T
) and then not Conversion_OK
(N
));
3356 end To_Be_Treated_As_Real
;
3358 -- Start of processing for Eval_Type_Conversion
3361 -- Cannot fold if target type is non-static or if semantic error
3363 if not Is_Static_Subtype
(Target_Type
) then
3364 Check_Non_Static_Context
(Operand
);
3367 elsif Error_Posted
(N
) then
3371 -- If not foldable we are done
3373 Test_Expression_Is_Foldable
(N
, Operand
, Stat
, Fold
);
3378 -- Don't try fold if target type has constraint error bounds
3380 elsif not Is_OK_Static_Subtype
(Target_Type
) then
3381 Set_Raises_Constraint_Error
(N
);
3385 -- Remaining processing depends on operand types. Note that in the
3386 -- following type test, fixed-point counts as real unless the flag
3387 -- Conversion_OK is set, in which case it counts as integer.
3389 -- Fold conversion, case of string type. The result is not static
3391 if Is_String_Type
(Target_Type
) then
3392 Fold_Str
(N
, Strval
(Get_String_Val
(Operand
)), Static
=> False);
3396 -- Fold conversion, case of integer target type
3398 elsif To_Be_Treated_As_Integer
(Target_Type
) then
3403 -- Integer to integer conversion
3405 if To_Be_Treated_As_Integer
(Source_Type
) then
3406 Result
:= Expr_Value
(Operand
);
3408 -- Real to integer conversion
3411 Result
:= UR_To_Uint
(Expr_Value_R
(Operand
));
3414 -- If fixed-point type (Conversion_OK must be set), then the
3415 -- result is logically an integer, but we must replace the
3416 -- conversion with the corresponding real literal, since the
3417 -- type from a semantic point of view is still fixed-point.
3419 if Is_Fixed_Point_Type
(Target_Type
) then
3421 (N
, UR_From_Uint
(Result
) * Small_Value
(Target_Type
), Stat
);
3423 -- Otherwise result is integer literal
3426 Fold_Uint
(N
, Result
, Stat
);
3430 -- Fold conversion, case of real target type
3432 elsif To_Be_Treated_As_Real
(Target_Type
) then
3437 if To_Be_Treated_As_Real
(Source_Type
) then
3438 Result
:= Expr_Value_R
(Operand
);
3440 Result
:= UR_From_Uint
(Expr_Value
(Operand
));
3443 Fold_Ureal
(N
, Result
, Stat
);
3446 -- Enumeration types
3449 Fold_Uint
(N
, Expr_Value
(Operand
), Stat
);
3452 if Is_Out_Of_Range
(N
, Etype
(N
), Assume_Valid
=> True) then
3456 end Eval_Type_Conversion
;
3462 -- Predefined unary operators are static functions (RM 4.9(20)) and thus
3463 -- are potentially static if the operand is potentially static (RM 4.9(7)).
3465 procedure Eval_Unary_Op
(N
: Node_Id
) is
3466 Right
: constant Node_Id
:= Right_Opnd
(N
);
3467 Otype
: Entity_Id
:= Empty
;
3472 -- If not foldable we are done
3474 Test_Expression_Is_Foldable
(N
, Right
, Stat
, Fold
);
3480 if Etype
(Right
) = Universal_Integer
3482 Etype
(Right
) = Universal_Real
3484 Otype
:= Find_Universal_Operator_Type
(N
);
3487 -- Fold for integer case
3489 if Is_Integer_Type
(Etype
(N
)) then
3491 Rint
: constant Uint
:= Expr_Value
(Right
);
3495 -- In the case of modular unary plus and abs there is no need
3496 -- to adjust the result of the operation since if the original
3497 -- operand was in bounds the result will be in the bounds of the
3498 -- modular type. However, in the case of modular unary minus the
3499 -- result may go out of the bounds of the modular type and needs
3502 if Nkind
(N
) = N_Op_Plus
then
3505 elsif Nkind
(N
) = N_Op_Minus
then
3506 if Is_Modular_Integer_Type
(Etype
(N
)) then
3507 Result
:= (-Rint
) mod Modulus
(Etype
(N
));
3513 pragma Assert
(Nkind
(N
) = N_Op_Abs
);
3517 Fold_Uint
(N
, Result
, Stat
);
3520 -- Fold for real case
3522 elsif Is_Real_Type
(Etype
(N
)) then
3524 Rreal
: constant Ureal
:= Expr_Value_R
(Right
);
3528 if Nkind
(N
) = N_Op_Plus
then
3531 elsif Nkind
(N
) = N_Op_Minus
then
3532 Result
:= UR_Negate
(Rreal
);
3535 pragma Assert
(Nkind
(N
) = N_Op_Abs
);
3536 Result
:= abs Rreal
;
3539 Fold_Ureal
(N
, Result
, Stat
);
3543 -- If the operator was resolved to a specific type, make sure that type
3544 -- is frozen even if the expression is folded into a literal (which has
3545 -- a universal type).
3547 if Present
(Otype
) then
3548 Freeze_Before
(N
, Otype
);
3552 -------------------------------
3553 -- Eval_Unchecked_Conversion --
3554 -------------------------------
3556 -- Unchecked conversions can never be static, so the only required
3557 -- processing is to check for a non-static context for the operand.
3559 procedure Eval_Unchecked_Conversion
(N
: Node_Id
) is
3561 Check_Non_Static_Context
(Expression
(N
));
3562 end Eval_Unchecked_Conversion
;
3564 --------------------
3565 -- Expr_Rep_Value --
3566 --------------------
3568 function Expr_Rep_Value
(N
: Node_Id
) return Uint
is
3569 Kind
: constant Node_Kind
:= Nkind
(N
);
3573 if Is_Entity_Name
(N
) then
3576 -- An enumeration literal that was either in the source or created
3577 -- as a result of static evaluation.
3579 if Ekind
(Ent
) = E_Enumeration_Literal
then
3580 return Enumeration_Rep
(Ent
);
3582 -- A user defined static constant
3585 pragma Assert
(Ekind
(Ent
) = E_Constant
);
3586 return Expr_Rep_Value
(Constant_Value
(Ent
));
3589 -- An integer literal that was either in the source or created as a
3590 -- result of static evaluation.
3592 elsif Kind
= N_Integer_Literal
then
3595 -- A real literal for a fixed-point type. This must be the fixed-point
3596 -- case, either the literal is of a fixed-point type, or it is a bound
3597 -- of a fixed-point type, with type universal real. In either case we
3598 -- obtain the desired value from Corresponding_Integer_Value.
3600 elsif Kind
= N_Real_Literal
then
3601 pragma Assert
(Is_Fixed_Point_Type
(Underlying_Type
(Etype
(N
))));
3602 return Corresponding_Integer_Value
(N
);
3604 -- Peculiar VMS case, if we have xxx'Null_Parameter, return zero
3606 elsif Kind
= N_Attribute_Reference
3607 and then Attribute_Name
(N
) = Name_Null_Parameter
3611 -- Otherwise must be character literal
3614 pragma Assert
(Kind
= N_Character_Literal
);
3617 -- Since Character literals of type Standard.Character don't have any
3618 -- defining character literals built for them, they do not have their
3619 -- Entity set, so just use their Char code. Otherwise for user-
3620 -- defined character literals use their Pos value as usual which is
3621 -- the same as the Rep value.
3624 return Char_Literal_Value
(N
);
3626 return Enumeration_Rep
(Ent
);
3635 function Expr_Value
(N
: Node_Id
) return Uint
is
3636 Kind
: constant Node_Kind
:= Nkind
(N
);
3637 CV_Ent
: CV_Entry
renames CV_Cache
(Nat
(N
) mod CV_Cache_Size
);
3642 -- If already in cache, then we know it's compile time known and we can
3643 -- return the value that was previously stored in the cache since
3644 -- compile time known values cannot change.
3646 if CV_Ent
.N
= N
then
3650 -- Otherwise proceed to test value
3652 if Is_Entity_Name
(N
) then
3655 -- An enumeration literal that was either in the source or created as
3656 -- a result of static evaluation.
3658 if Ekind
(Ent
) = E_Enumeration_Literal
then
3659 Val
:= Enumeration_Pos
(Ent
);
3661 -- A user defined static constant
3664 pragma Assert
(Ekind
(Ent
) = E_Constant
);
3665 Val
:= Expr_Value
(Constant_Value
(Ent
));
3668 -- An integer literal that was either in the source or created as a
3669 -- result of static evaluation.
3671 elsif Kind
= N_Integer_Literal
then
3674 -- A real literal for a fixed-point type. This must be the fixed-point
3675 -- case, either the literal is of a fixed-point type, or it is a bound
3676 -- of a fixed-point type, with type universal real. In either case we
3677 -- obtain the desired value from Corresponding_Integer_Value.
3679 elsif Kind
= N_Real_Literal
then
3681 pragma Assert
(Is_Fixed_Point_Type
(Underlying_Type
(Etype
(N
))));
3682 Val
:= Corresponding_Integer_Value
(N
);
3684 -- Peculiar VMS case, if we have xxx'Null_Parameter, return zero
3686 elsif Kind
= N_Attribute_Reference
3687 and then Attribute_Name
(N
) = Name_Null_Parameter
3691 -- Otherwise must be character literal
3694 pragma Assert
(Kind
= N_Character_Literal
);
3697 -- Since Character literals of type Standard.Character don't
3698 -- have any defining character literals built for them, they
3699 -- do not have their Entity set, so just use their Char
3700 -- code. Otherwise for user-defined character literals use
3701 -- their Pos value as usual.
3704 Val
:= Char_Literal_Value
(N
);
3706 Val
:= Enumeration_Pos
(Ent
);
3710 -- Come here with Val set to value to be returned, set cache
3721 function Expr_Value_E
(N
: Node_Id
) return Entity_Id
is
3722 Ent
: constant Entity_Id
:= Entity
(N
);
3725 if Ekind
(Ent
) = E_Enumeration_Literal
then
3728 pragma Assert
(Ekind
(Ent
) = E_Constant
);
3729 return Expr_Value_E
(Constant_Value
(Ent
));
3737 function Expr_Value_R
(N
: Node_Id
) return Ureal
is
3738 Kind
: constant Node_Kind
:= Nkind
(N
);
3743 if Kind
= N_Real_Literal
then
3746 elsif Kind
= N_Identifier
or else Kind
= N_Expanded_Name
then
3748 pragma Assert
(Ekind
(Ent
) = E_Constant
);
3749 return Expr_Value_R
(Constant_Value
(Ent
));
3751 elsif Kind
= N_Integer_Literal
then
3752 return UR_From_Uint
(Expr_Value
(N
));
3754 -- Strange case of VAX literals, which are at this stage transformed
3755 -- into Vax_Type!x_To_y(IEEE_Literal). See Expand_N_Real_Literal in
3756 -- Exp_Vfpt for further details.
3758 elsif Vax_Float
(Etype
(N
))
3759 and then Nkind
(N
) = N_Unchecked_Type_Conversion
3761 Expr
:= Expression
(N
);
3763 if Nkind
(Expr
) = N_Function_Call
3764 and then Present
(Parameter_Associations
(Expr
))
3766 Expr
:= First
(Parameter_Associations
(Expr
));
3768 if Nkind
(Expr
) = N_Real_Literal
then
3769 return Realval
(Expr
);
3773 -- Peculiar VMS case, if we have xxx'Null_Parameter, return 0.0
3775 elsif Kind
= N_Attribute_Reference
3776 and then Attribute_Name
(N
) = Name_Null_Parameter
3781 -- If we fall through, we have a node that cannot be interpreted as a
3782 -- compile time constant. That is definitely an error.
3784 raise Program_Error
;
3791 function Expr_Value_S
(N
: Node_Id
) return Node_Id
is
3793 if Nkind
(N
) = N_String_Literal
then
3796 pragma Assert
(Ekind
(Entity
(N
)) = E_Constant
);
3797 return Expr_Value_S
(Constant_Value
(Entity
(N
)));
3801 ----------------------------------
3802 -- Find_Universal_Operator_Type --
3803 ----------------------------------
3805 function Find_Universal_Operator_Type
(N
: Node_Id
) return Entity_Id
is
3806 PN
: constant Node_Id
:= Parent
(N
);
3807 Call
: constant Node_Id
:= Original_Node
(N
);
3808 Is_Int
: constant Boolean := Is_Integer_Type
(Etype
(N
));
3810 Is_Fix
: constant Boolean :=
3811 Nkind
(N
) in N_Binary_Op
3812 and then Nkind
(Right_Opnd
(N
)) /= Nkind
(Left_Opnd
(N
));
3813 -- A mixed-mode operation in this context indicates the presence of
3814 -- fixed-point type in the designated package.
3816 Is_Relational
: constant Boolean := Etype
(N
) = Standard_Boolean
;
3817 -- Case where N is a relational (or membership) operator (else it is an
3820 In_Membership
: constant Boolean :=
3821 Nkind
(PN
) in N_Membership_Test
3823 Nkind
(Right_Opnd
(PN
)) = N_Range
3825 Is_Universal_Numeric_Type
(Etype
(Left_Opnd
(PN
)))
3827 Is_Universal_Numeric_Type
3828 (Etype
(Low_Bound
(Right_Opnd
(PN
))))
3830 Is_Universal_Numeric_Type
3831 (Etype
(High_Bound
(Right_Opnd
(PN
))));
3832 -- Case where N is part of a membership test with a universal range
3836 Typ1
: Entity_Id
:= Empty
;
3839 function Is_Mixed_Mode_Operand
(Op
: Node_Id
) return Boolean;
3840 -- Check whether one operand is a mixed-mode operation that requires the
3841 -- presence of a fixed-point type. Given that all operands are universal
3842 -- and have been constant-folded, retrieve the original function call.
3844 ---------------------------
3845 -- Is_Mixed_Mode_Operand --
3846 ---------------------------
3848 function Is_Mixed_Mode_Operand
(Op
: Node_Id
) return Boolean is
3849 Onod
: constant Node_Id
:= Original_Node
(Op
);
3851 return Nkind
(Onod
) = N_Function_Call
3852 and then Present
(Next_Actual
(First_Actual
(Onod
)))
3853 and then Etype
(First_Actual
(Onod
)) /=
3854 Etype
(Next_Actual
(First_Actual
(Onod
)));
3855 end Is_Mixed_Mode_Operand
;
3857 -- Start of processing for Find_Universal_Operator_Type
3860 if Nkind
(Call
) /= N_Function_Call
3861 or else Nkind
(Name
(Call
)) /= N_Expanded_Name
3865 -- There are several cases where the context does not imply the type of
3867 -- - the universal expression appears in a type conversion;
3868 -- - the expression is a relational operator applied to universal
3870 -- - the expression is a membership test with a universal operand
3871 -- and a range with universal bounds.
3873 elsif Nkind
(Parent
(N
)) = N_Type_Conversion
3874 or else Is_Relational
3875 or else In_Membership
3877 Pack
:= Entity
(Prefix
(Name
(Call
)));
3879 -- If the prefix is a package declared elsewhere, iterate over its
3880 -- visible entities, otherwise iterate over all declarations in the
3881 -- designated scope.
3883 if Ekind
(Pack
) = E_Package
3884 and then not In_Open_Scopes
(Pack
)
3886 Priv_E
:= First_Private_Entity
(Pack
);
3892 E
:= First_Entity
(Pack
);
3893 while Present
(E
) and then E
/= Priv_E
loop
3894 if Is_Numeric_Type
(E
)
3895 and then Nkind
(Parent
(E
)) /= N_Subtype_Declaration
3896 and then Comes_From_Source
(E
)
3897 and then Is_Integer_Type
(E
) = Is_Int
3899 (Nkind
(N
) in N_Unary_Op
3900 or else Is_Relational
3901 or else Is_Fixed_Point_Type
(E
) = Is_Fix
)
3906 -- Before emitting an error, check for the presence of a
3907 -- mixed-mode operation that specifies a fixed point type.
3911 (Is_Mixed_Mode_Operand
(Left_Opnd
(N
))
3912 or else Is_Mixed_Mode_Operand
(Right_Opnd
(N
)))
3913 and then Is_Fixed_Point_Type
(E
) /= Is_Fixed_Point_Type
(Typ1
)
3916 if Is_Fixed_Point_Type
(E
) then
3921 -- More than one type of the proper class declared in P
3923 Error_Msg_N
("ambiguous operation", N
);
3924 Error_Msg_Sloc
:= Sloc
(Typ1
);
3925 Error_Msg_N
("\possible interpretation (inherited)#", N
);
3926 Error_Msg_Sloc
:= Sloc
(E
);
3927 Error_Msg_N
("\possible interpretation (inherited)#", N
);
3937 end Find_Universal_Operator_Type
;
3939 --------------------------
3940 -- Flag_Non_Static_Expr --
3941 --------------------------
3943 procedure Flag_Non_Static_Expr
(Msg
: String; Expr
: Node_Id
) is
3945 if Error_Posted
(Expr
) and then not All_Errors_Mode
then
3948 Error_Msg_F
(Msg
, Expr
);
3949 Why_Not_Static
(Expr
);
3951 end Flag_Non_Static_Expr
;
3957 procedure Fold_Str
(N
: Node_Id
; Val
: String_Id
; Static
: Boolean) is
3958 Loc
: constant Source_Ptr
:= Sloc
(N
);
3959 Typ
: constant Entity_Id
:= Etype
(N
);
3962 Rewrite
(N
, Make_String_Literal
(Loc
, Strval
=> Val
));
3964 -- We now have the literal with the right value, both the actual type
3965 -- and the expected type of this literal are taken from the expression
3966 -- that was evaluated.
3969 Set_Is_Static_Expression
(N
, Static
);
3978 procedure Fold_Uint
(N
: Node_Id
; Val
: Uint
; Static
: Boolean) is
3979 Loc
: constant Source_Ptr
:= Sloc
(N
);
3980 Typ
: Entity_Id
:= Etype
(N
);
3984 -- If we are folding a named number, retain the entity in the literal,
3987 if Is_Entity_Name
(N
)
3988 and then Ekind
(Entity
(N
)) = E_Named_Integer
3995 if Is_Private_Type
(Typ
) then
3996 Typ
:= Full_View
(Typ
);
3999 -- For a result of type integer, substitute an N_Integer_Literal node
4000 -- for the result of the compile time evaluation of the expression.
4001 -- For ASIS use, set a link to the original named number when not in
4002 -- a generic context.
4004 if Is_Integer_Type
(Typ
) then
4005 Rewrite
(N
, Make_Integer_Literal
(Loc
, Val
));
4007 Set_Original_Entity
(N
, Ent
);
4009 -- Otherwise we have an enumeration type, and we substitute either
4010 -- an N_Identifier or N_Character_Literal to represent the enumeration
4011 -- literal corresponding to the given value, which must always be in
4012 -- range, because appropriate tests have already been made for this.
4014 else pragma Assert
(Is_Enumeration_Type
(Typ
));
4015 Rewrite
(N
, Get_Enum_Lit_From_Pos
(Etype
(N
), Val
, Loc
));
4018 -- We now have the literal with the right value, both the actual type
4019 -- and the expected type of this literal are taken from the expression
4020 -- that was evaluated.
4023 Set_Is_Static_Expression
(N
, Static
);
4032 procedure Fold_Ureal
(N
: Node_Id
; Val
: Ureal
; Static
: Boolean) is
4033 Loc
: constant Source_Ptr
:= Sloc
(N
);
4034 Typ
: constant Entity_Id
:= Etype
(N
);
4038 -- If we are folding a named number, retain the entity in the literal,
4041 if Is_Entity_Name
(N
)
4042 and then Ekind
(Entity
(N
)) = E_Named_Real
4049 Rewrite
(N
, Make_Real_Literal
(Loc
, Realval
=> Val
));
4051 -- Set link to original named number, for ASIS use
4053 Set_Original_Entity
(N
, Ent
);
4055 -- Both the actual and expected type comes from the original expression
4058 Set_Is_Static_Expression
(N
, Static
);
4067 function From_Bits
(B
: Bits
; T
: Entity_Id
) return Uint
is
4071 for J
in 0 .. B
'Last loop
4077 if Non_Binary_Modulus
(T
) then
4078 V
:= V
mod Modulus
(T
);
4084 --------------------
4085 -- Get_String_Val --
4086 --------------------
4088 function Get_String_Val
(N
: Node_Id
) return Node_Id
is
4090 if Nkind
(N
) = N_String_Literal
then
4093 elsif Nkind
(N
) = N_Character_Literal
then
4097 pragma Assert
(Is_Entity_Name
(N
));
4098 return Get_String_Val
(Constant_Value
(Entity
(N
)));
4106 procedure Initialize
is
4108 CV_Cache
:= (others => (Node_High_Bound
, Uint_0
));
4111 --------------------
4112 -- In_Subrange_Of --
4113 --------------------
4115 function In_Subrange_Of
4118 Fixed_Int
: Boolean := False) return Boolean
4127 if T1
= T2
or else Is_Subtype_Of
(T1
, T2
) then
4130 -- Never in range if both types are not scalar. Don't know if this can
4131 -- actually happen, but just in case.
4133 elsif not Is_Scalar_Type
(T1
) or else not Is_Scalar_Type
(T1
) then
4136 -- If T1 has infinities but T2 doesn't have infinities, then T1 is
4137 -- definitely not compatible with T2.
4139 elsif Is_Floating_Point_Type
(T1
)
4140 and then Has_Infinities
(T1
)
4141 and then Is_Floating_Point_Type
(T2
)
4142 and then not Has_Infinities
(T2
)
4147 L1
:= Type_Low_Bound
(T1
);
4148 H1
:= Type_High_Bound
(T1
);
4150 L2
:= Type_Low_Bound
(T2
);
4151 H2
:= Type_High_Bound
(T2
);
4153 -- Check bounds to see if comparison possible at compile time
4155 if Compile_Time_Compare
(L1
, L2
, Assume_Valid
=> True) in Compare_GE
4157 Compile_Time_Compare
(H1
, H2
, Assume_Valid
=> True) in Compare_LE
4162 -- If bounds not comparable at compile time, then the bounds of T2
4163 -- must be compile time known or we cannot answer the query.
4165 if not Compile_Time_Known_Value
(L2
)
4166 or else not Compile_Time_Known_Value
(H2
)
4171 -- If the bounds of T1 are know at compile time then use these
4172 -- ones, otherwise use the bounds of the base type (which are of
4173 -- course always static).
4175 if not Compile_Time_Known_Value
(L1
) then
4176 L1
:= Type_Low_Bound
(Base_Type
(T1
));
4179 if not Compile_Time_Known_Value
(H1
) then
4180 H1
:= Type_High_Bound
(Base_Type
(T1
));
4183 -- Fixed point types should be considered as such only if
4184 -- flag Fixed_Int is set to False.
4186 if Is_Floating_Point_Type
(T1
) or else Is_Floating_Point_Type
(T2
)
4187 or else (Is_Fixed_Point_Type
(T1
) and then not Fixed_Int
)
4188 or else (Is_Fixed_Point_Type
(T2
) and then not Fixed_Int
)
4191 Expr_Value_R
(L2
) <= Expr_Value_R
(L1
)
4193 Expr_Value_R
(H2
) >= Expr_Value_R
(H1
);
4197 Expr_Value
(L2
) <= Expr_Value
(L1
)
4199 Expr_Value
(H2
) >= Expr_Value
(H1
);
4204 -- If any exception occurs, it means that we have some bug in the compiler
4205 -- possibly triggered by a previous error, or by some unforeseen peculiar
4206 -- occurrence. However, this is only an optimization attempt, so there is
4207 -- really no point in crashing the compiler. Instead we just decide, too
4208 -- bad, we can't figure out the answer in this case after all.
4213 -- Debug flag K disables this behavior (useful for debugging)
4215 if Debug_Flag_K
then
4226 function Is_In_Range
4229 Assume_Valid
: Boolean := False;
4230 Fixed_Int
: Boolean := False;
4231 Int_Real
: Boolean := False) return Boolean
4234 return Test_In_Range
(N
, Typ
, Assume_Valid
, Fixed_Int
, Int_Real
)
4242 function Is_Null_Range
(Lo
: Node_Id
; Hi
: Node_Id
) return Boolean is
4243 Typ
: constant Entity_Id
:= Etype
(Lo
);
4246 if not Compile_Time_Known_Value
(Lo
)
4247 or else not Compile_Time_Known_Value
(Hi
)
4252 if Is_Discrete_Type
(Typ
) then
4253 return Expr_Value
(Lo
) > Expr_Value
(Hi
);
4256 pragma Assert
(Is_Real_Type
(Typ
));
4257 return Expr_Value_R
(Lo
) > Expr_Value_R
(Hi
);
4261 -----------------------------
4262 -- Is_OK_Static_Expression --
4263 -----------------------------
4265 function Is_OK_Static_Expression
(N
: Node_Id
) return Boolean is
4267 return Is_Static_Expression
(N
)
4268 and then not Raises_Constraint_Error
(N
);
4269 end Is_OK_Static_Expression
;
4271 ------------------------
4272 -- Is_OK_Static_Range --
4273 ------------------------
4275 -- A static range is a range whose bounds are static expressions, or a
4276 -- Range_Attribute_Reference equivalent to such a range (RM 4.9(26)).
4277 -- We have already converted range attribute references, so we get the
4278 -- "or" part of this rule without needing a special test.
4280 function Is_OK_Static_Range
(N
: Node_Id
) return Boolean is
4282 return Is_OK_Static_Expression
(Low_Bound
(N
))
4283 and then Is_OK_Static_Expression
(High_Bound
(N
));
4284 end Is_OK_Static_Range
;
4286 --------------------------
4287 -- Is_OK_Static_Subtype --
4288 --------------------------
4290 -- Determines if Typ is a static subtype as defined in (RM 4.9(26)) where
4291 -- neither bound raises constraint error when evaluated.
4293 function Is_OK_Static_Subtype
(Typ
: Entity_Id
) return Boolean is
4294 Base_T
: constant Entity_Id
:= Base_Type
(Typ
);
4295 Anc_Subt
: Entity_Id
;
4298 -- First a quick check on the non static subtype flag. As described
4299 -- in further detail in Einfo, this flag is not decisive in all cases,
4300 -- but if it is set, then the subtype is definitely non-static.
4302 if Is_Non_Static_Subtype
(Typ
) then
4306 Anc_Subt
:= Ancestor_Subtype
(Typ
);
4308 if Anc_Subt
= Empty
then
4312 if Is_Generic_Type
(Root_Type
(Base_T
))
4313 or else Is_Generic_Actual_Type
(Base_T
)
4319 elsif Is_String_Type
(Typ
) then
4321 Ekind
(Typ
) = E_String_Literal_Subtype
4323 (Is_OK_Static_Subtype
(Component_Type
(Typ
))
4324 and then Is_OK_Static_Subtype
(Etype
(First_Index
(Typ
))));
4328 elsif Is_Scalar_Type
(Typ
) then
4329 if Base_T
= Typ
then
4333 -- Scalar_Range (Typ) might be an N_Subtype_Indication, so use
4334 -- Get_Type_{Low,High}_Bound.
4336 return Is_OK_Static_Subtype
(Anc_Subt
)
4337 and then Is_OK_Static_Expression
(Type_Low_Bound
(Typ
))
4338 and then Is_OK_Static_Expression
(Type_High_Bound
(Typ
));
4341 -- Types other than string and scalar types are never static
4346 end Is_OK_Static_Subtype
;
4348 ---------------------
4349 -- Is_Out_Of_Range --
4350 ---------------------
4352 function Is_Out_Of_Range
4355 Assume_Valid
: Boolean := False;
4356 Fixed_Int
: Boolean := False;
4357 Int_Real
: Boolean := False) return Boolean
4360 return Test_In_Range
(N
, Typ
, Assume_Valid
, Fixed_Int
, Int_Real
)
4362 end Is_Out_Of_Range
;
4364 ---------------------
4365 -- Is_Static_Range --
4366 ---------------------
4368 -- A static range is a range whose bounds are static expressions, or a
4369 -- Range_Attribute_Reference equivalent to such a range (RM 4.9(26)).
4370 -- We have already converted range attribute references, so we get the
4371 -- "or" part of this rule without needing a special test.
4373 function Is_Static_Range
(N
: Node_Id
) return Boolean is
4375 return Is_Static_Expression
(Low_Bound
(N
))
4376 and then Is_Static_Expression
(High_Bound
(N
));
4377 end Is_Static_Range
;
4379 -----------------------
4380 -- Is_Static_Subtype --
4381 -----------------------
4383 -- Determines if Typ is a static subtype as defined in (RM 4.9(26))
4385 function Is_Static_Subtype
(Typ
: Entity_Id
) return Boolean is
4386 Base_T
: constant Entity_Id
:= Base_Type
(Typ
);
4387 Anc_Subt
: Entity_Id
;
4390 -- First a quick check on the non static subtype flag. As described
4391 -- in further detail in Einfo, this flag is not decisive in all cases,
4392 -- but if it is set, then the subtype is definitely non-static.
4394 if Is_Non_Static_Subtype
(Typ
) then
4398 Anc_Subt
:= Ancestor_Subtype
(Typ
);
4400 if Anc_Subt
= Empty
then
4404 if Is_Generic_Type
(Root_Type
(Base_T
))
4405 or else Is_Generic_Actual_Type
(Base_T
)
4411 elsif Is_String_Type
(Typ
) then
4413 Ekind
(Typ
) = E_String_Literal_Subtype
4414 or else (Is_Static_Subtype
(Component_Type
(Typ
))
4415 and then Is_Static_Subtype
(Etype
(First_Index
(Typ
))));
4419 elsif Is_Scalar_Type
(Typ
) then
4420 if Base_T
= Typ
then
4424 return Is_Static_Subtype
(Anc_Subt
)
4425 and then Is_Static_Expression
(Type_Low_Bound
(Typ
))
4426 and then Is_Static_Expression
(Type_High_Bound
(Typ
));
4429 -- Types other than string and scalar types are never static
4434 end Is_Static_Subtype
;
4436 --------------------
4437 -- Not_Null_Range --
4438 --------------------
4440 function Not_Null_Range
(Lo
: Node_Id
; Hi
: Node_Id
) return Boolean is
4441 Typ
: constant Entity_Id
:= Etype
(Lo
);
4444 if not Compile_Time_Known_Value
(Lo
)
4445 or else not Compile_Time_Known_Value
(Hi
)
4450 if Is_Discrete_Type
(Typ
) then
4451 return Expr_Value
(Lo
) <= Expr_Value
(Hi
);
4454 pragma Assert
(Is_Real_Type
(Typ
));
4456 return Expr_Value_R
(Lo
) <= Expr_Value_R
(Hi
);
4464 function OK_Bits
(N
: Node_Id
; Bits
: Uint
) return Boolean is
4466 -- We allow a maximum of 500,000 bits which seems a reasonable limit
4468 if Bits
< 500_000
then
4472 Error_Msg_N
("static value too large, capacity exceeded", N
);
4481 procedure Out_Of_Range
(N
: Node_Id
) is
4483 -- If we have the static expression case, then this is an illegality
4484 -- in Ada 95 mode, except that in an instance, we never generate an
4485 -- error (if the error is legitimate, it was already diagnosed in the
4486 -- template). The expression to compute the length of a packed array is
4487 -- attached to the array type itself, and deserves a separate message.
4489 if Is_Static_Expression
(N
)
4490 and then not In_Instance
4491 and then not In_Inlined_Body
4492 and then Ada_Version
>= Ada_95
4494 if Nkind
(Parent
(N
)) = N_Defining_Identifier
4495 and then Is_Array_Type
(Parent
(N
))
4496 and then Present
(Packed_Array_Type
(Parent
(N
)))
4497 and then Present
(First_Rep_Item
(Parent
(N
)))
4500 ("length of packed array must not exceed Integer''Last",
4501 First_Rep_Item
(Parent
(N
)));
4502 Rewrite
(N
, Make_Integer_Literal
(Sloc
(N
), Uint_1
));
4505 Apply_Compile_Time_Constraint_Error
4506 (N
, "value not in range of}", CE_Range_Check_Failed
);
4509 -- Here we generate a warning for the Ada 83 case, or when we are in an
4510 -- instance, or when we have a non-static expression case.
4513 Apply_Compile_Time_Constraint_Error
4514 (N
, "value not in range of}?", CE_Range_Check_Failed
);
4518 -------------------------
4519 -- Rewrite_In_Raise_CE --
4520 -------------------------
4522 procedure Rewrite_In_Raise_CE
(N
: Node_Id
; Exp
: Node_Id
) is
4523 Typ
: constant Entity_Id
:= Etype
(N
);
4526 -- If we want to raise CE in the condition of a N_Raise_CE node
4527 -- we may as well get rid of the condition.
4529 if Present
(Parent
(N
))
4530 and then Nkind
(Parent
(N
)) = N_Raise_Constraint_Error
4532 Set_Condition
(Parent
(N
), Empty
);
4534 -- If the expression raising CE is a N_Raise_CE node, we can use that
4535 -- one. We just preserve the type of the context.
4537 elsif Nkind
(Exp
) = N_Raise_Constraint_Error
then
4541 -- Else build an explcit N_Raise_CE
4545 Make_Raise_Constraint_Error
(Sloc
(Exp
),
4546 Reason
=> CE_Range_Check_Failed
));
4547 Set_Raises_Constraint_Error
(N
);
4550 end Rewrite_In_Raise_CE
;
4552 ---------------------
4553 -- String_Type_Len --
4554 ---------------------
4556 function String_Type_Len
(Stype
: Entity_Id
) return Uint
is
4557 NT
: constant Entity_Id
:= Etype
(First_Index
(Stype
));
4561 if Is_OK_Static_Subtype
(NT
) then
4564 T
:= Base_Type
(NT
);
4567 return Expr_Value
(Type_High_Bound
(T
)) -
4568 Expr_Value
(Type_Low_Bound
(T
)) + 1;
4569 end String_Type_Len
;
4571 ------------------------------------
4572 -- Subtypes_Statically_Compatible --
4573 ------------------------------------
4575 function Subtypes_Statically_Compatible
4577 T2
: Entity_Id
) return Boolean
4582 if Is_Scalar_Type
(T1
) then
4584 -- Definitely compatible if we match
4586 if Subtypes_Statically_Match
(T1
, T2
) then
4589 -- If either subtype is nonstatic then they're not compatible
4591 elsif not Is_Static_Subtype
(T1
)
4592 or else not Is_Static_Subtype
(T2
)
4596 -- If either type has constraint error bounds, then consider that
4597 -- they match to avoid junk cascaded errors here.
4599 elsif not Is_OK_Static_Subtype
(T1
)
4600 or else not Is_OK_Static_Subtype
(T2
)
4604 -- Base types must match, but we don't check that (should we???) but
4605 -- we do at least check that both types are real, or both types are
4608 elsif Is_Real_Type
(T1
) /= Is_Real_Type
(T2
) then
4611 -- Here we check the bounds
4615 LB1
: constant Node_Id
:= Type_Low_Bound
(T1
);
4616 HB1
: constant Node_Id
:= Type_High_Bound
(T1
);
4617 LB2
: constant Node_Id
:= Type_Low_Bound
(T2
);
4618 HB2
: constant Node_Id
:= Type_High_Bound
(T2
);
4621 if Is_Real_Type
(T1
) then
4623 (Expr_Value_R
(LB1
) > Expr_Value_R
(HB1
))
4625 (Expr_Value_R
(LB2
) <= Expr_Value_R
(LB1
)
4627 Expr_Value_R
(HB1
) <= Expr_Value_R
(HB2
));
4631 (Expr_Value
(LB1
) > Expr_Value
(HB1
))
4633 (Expr_Value
(LB2
) <= Expr_Value
(LB1
)
4635 Expr_Value
(HB1
) <= Expr_Value
(HB2
));
4642 elsif Is_Access_Type
(T1
) then
4643 return (not Is_Constrained
(T2
)
4644 or else (Subtypes_Statically_Match
4645 (Designated_Type
(T1
), Designated_Type
(T2
))))
4646 and then not (Can_Never_Be_Null
(T2
)
4647 and then not Can_Never_Be_Null
(T1
));
4652 return (Is_Composite_Type
(T1
) and then not Is_Constrained
(T2
))
4653 or else Subtypes_Statically_Match
(T1
, T2
);
4655 end Subtypes_Statically_Compatible
;
4657 -------------------------------
4658 -- Subtypes_Statically_Match --
4659 -------------------------------
4661 -- Subtypes statically match if they have statically matching constraints
4662 -- (RM 4.9.1(2)). Constraints statically match if there are none, or if
4663 -- they are the same identical constraint, or if they are static and the
4664 -- values match (RM 4.9.1(1)).
4666 function Subtypes_Statically_Match
(T1
, T2
: Entity_Id
) return Boolean is
4668 function Predicates_Match
return Boolean;
4669 -- In Ada 2012, subtypes statically match if their static predicates
4672 ----------------------
4673 -- Predicates_Match --
4674 ----------------------
4676 function Predicates_Match
return Boolean is
4681 if Ada_Version
< Ada_2012
then
4684 elsif Has_Predicates
(T1
) /= Has_Predicates
(T2
) then
4688 Pred1
:= Get_Rep_Item_For_Entity
(T1
, Name_Static_Predicate
);
4689 Pred2
:= Get_Rep_Item_For_Entity
(T2
, Name_Static_Predicate
);
4691 -- Subtypes statically match if the predicate comes from the
4692 -- same declaration, which can only happen if one is a subtype
4693 -- of the other and has no explicit predicate.
4695 -- Suppress warnings on order of actuals, which is otherwise
4696 -- triggered by one of the two calls below.
4698 pragma Warnings
(Off
);
4699 return Pred1
= Pred2
4700 or else (No
(Pred1
) and then Is_Subtype_Of
(T1
, T2
))
4701 or else (No
(Pred2
) and then Is_Subtype_Of
(T2
, T1
));
4702 pragma Warnings
(On
);
4704 end Predicates_Match
;
4706 -- Start of processing for Subtypes_Statically_Match
4709 -- A type always statically matches itself
4716 elsif Is_Scalar_Type
(T1
) then
4718 -- Base types must be the same
4720 if Base_Type
(T1
) /= Base_Type
(T2
) then
4724 -- A constrained numeric subtype never matches an unconstrained
4725 -- subtype, i.e. both types must be constrained or unconstrained.
4727 -- To understand the requirement for this test, see RM 4.9.1(1).
4728 -- As is made clear in RM 3.5.4(11), type Integer, for example is
4729 -- a constrained subtype with constraint bounds matching the bounds
4730 -- of its corresponding unconstrained base type. In this situation,
4731 -- Integer and Integer'Base do not statically match, even though
4732 -- they have the same bounds.
4734 -- We only apply this test to types in Standard and types that appear
4735 -- in user programs. That way, we do not have to be too careful about
4736 -- setting Is_Constrained right for Itypes.
4738 if Is_Numeric_Type
(T1
)
4739 and then (Is_Constrained
(T1
) /= Is_Constrained
(T2
))
4740 and then (Scope
(T1
) = Standard_Standard
4741 or else Comes_From_Source
(T1
))
4742 and then (Scope
(T2
) = Standard_Standard
4743 or else Comes_From_Source
(T2
))
4747 -- A generic scalar type does not statically match its base type
4748 -- (AI-311). In this case we make sure that the formals, which are
4749 -- first subtypes of their bases, are constrained.
4751 elsif Is_Generic_Type
(T1
)
4752 and then Is_Generic_Type
(T2
)
4753 and then (Is_Constrained
(T1
) /= Is_Constrained
(T2
))
4758 -- If there was an error in either range, then just assume the types
4759 -- statically match to avoid further junk errors.
4761 if No
(Scalar_Range
(T1
)) or else No
(Scalar_Range
(T2
))
4762 or else Error_Posted
(Scalar_Range
(T1
))
4763 or else Error_Posted
(Scalar_Range
(T2
))
4768 -- Otherwise both types have bound that can be compared
4771 LB1
: constant Node_Id
:= Type_Low_Bound
(T1
);
4772 HB1
: constant Node_Id
:= Type_High_Bound
(T1
);
4773 LB2
: constant Node_Id
:= Type_Low_Bound
(T2
);
4774 HB2
: constant Node_Id
:= Type_High_Bound
(T2
);
4777 -- If the bounds are the same tree node, then match if and only
4778 -- if any predicates present also match.
4780 if LB1
= LB2
and then HB1
= HB2
then
4781 return Predicates_Match
;
4783 -- Otherwise bounds must be static and identical value
4786 if not Is_Static_Subtype
(T1
)
4787 or else not Is_Static_Subtype
(T2
)
4791 -- If either type has constraint error bounds, then say that
4792 -- they match to avoid junk cascaded errors here.
4794 elsif not Is_OK_Static_Subtype
(T1
)
4795 or else not Is_OK_Static_Subtype
(T2
)
4799 elsif Is_Real_Type
(T1
) then
4801 (Expr_Value_R
(LB1
) = Expr_Value_R
(LB2
))
4803 (Expr_Value_R
(HB1
) = Expr_Value_R
(HB2
));
4807 Expr_Value
(LB1
) = Expr_Value
(LB2
)
4809 Expr_Value
(HB1
) = Expr_Value
(HB2
);
4814 -- Type with discriminants
4816 elsif Has_Discriminants
(T1
) or else Has_Discriminants
(T2
) then
4818 -- Because of view exchanges in multiple instantiations, conformance
4819 -- checking might try to match a partial view of a type with no
4820 -- discriminants with a full view that has defaulted discriminants.
4821 -- In such a case, use the discriminant constraint of the full view,
4822 -- which must exist because we know that the two subtypes have the
4825 if Has_Discriminants
(T1
) /= Has_Discriminants
(T2
) then
4827 if Is_Private_Type
(T2
)
4828 and then Present
(Full_View
(T2
))
4829 and then Has_Discriminants
(Full_View
(T2
))
4831 return Subtypes_Statically_Match
(T1
, Full_View
(T2
));
4833 elsif Is_Private_Type
(T1
)
4834 and then Present
(Full_View
(T1
))
4835 and then Has_Discriminants
(Full_View
(T1
))
4837 return Subtypes_Statically_Match
(Full_View
(T1
), T2
);
4848 DL1
: constant Elist_Id
:= Discriminant_Constraint
(T1
);
4849 DL2
: constant Elist_Id
:= Discriminant_Constraint
(T2
);
4857 elsif Is_Constrained
(T1
) /= Is_Constrained
(T2
) then
4861 -- Now loop through the discriminant constraints
4863 -- Note: the guard here seems necessary, since it is possible at
4864 -- least for DL1 to be No_Elist. Not clear this is reasonable ???
4866 if Present
(DL1
) and then Present
(DL2
) then
4867 DA1
:= First_Elmt
(DL1
);
4868 DA2
:= First_Elmt
(DL2
);
4869 while Present
(DA1
) loop
4871 Expr1
: constant Node_Id
:= Node
(DA1
);
4872 Expr2
: constant Node_Id
:= Node
(DA2
);
4875 if not Is_Static_Expression
(Expr1
)
4876 or else not Is_Static_Expression
(Expr2
)
4880 -- If either expression raised a constraint error,
4881 -- consider the expressions as matching, since this
4882 -- helps to prevent cascading errors.
4884 elsif Raises_Constraint_Error
(Expr1
)
4885 or else Raises_Constraint_Error
(Expr2
)
4889 elsif Expr_Value
(Expr1
) /= Expr_Value
(Expr2
) then
4902 -- A definite type does not match an indefinite or classwide type.
4903 -- However, a generic type with unknown discriminants may be
4904 -- instantiated with a type with no discriminants, and conformance
4905 -- checking on an inherited operation may compare the actual with the
4906 -- subtype that renames it in the instance.
4909 Has_Unknown_Discriminants
(T1
) /= Has_Unknown_Discriminants
(T2
)
4912 Is_Generic_Actual_Type
(T1
) or else Is_Generic_Actual_Type
(T2
);
4916 elsif Is_Array_Type
(T1
) then
4918 -- If either subtype is unconstrained then both must be, and if both
4919 -- are unconstrained then no further checking is needed.
4921 if not Is_Constrained
(T1
) or else not Is_Constrained
(T2
) then
4922 return not (Is_Constrained
(T1
) or else Is_Constrained
(T2
));
4925 -- Both subtypes are constrained, so check that the index subtypes
4926 -- statically match.
4929 Index1
: Node_Id
:= First_Index
(T1
);
4930 Index2
: Node_Id
:= First_Index
(T2
);
4933 while Present
(Index1
) loop
4935 Subtypes_Statically_Match
(Etype
(Index1
), Etype
(Index2
))
4940 Next_Index
(Index1
);
4941 Next_Index
(Index2
);
4947 elsif Is_Access_Type
(T1
) then
4948 if Can_Never_Be_Null
(T1
) /= Can_Never_Be_Null
(T2
) then
4951 elsif Ekind_In
(T1
, E_Access_Subprogram_Type
,
4952 E_Anonymous_Access_Subprogram_Type
)
4956 (Designated_Type
(T1
),
4957 Designated_Type
(T2
));
4960 Subtypes_Statically_Match
4961 (Designated_Type
(T1
),
4962 Designated_Type
(T2
))
4963 and then Is_Access_Constant
(T1
) = Is_Access_Constant
(T2
);
4966 -- All other types definitely match
4971 end Subtypes_Statically_Match
;
4977 function Test
(Cond
: Boolean) return Uint
is
4986 ---------------------------------
4987 -- Test_Expression_Is_Foldable --
4988 ---------------------------------
4992 procedure Test_Expression_Is_Foldable
5002 if Debug_Flag_Dot_F
and then In_Extended_Main_Source_Unit
(N
) then
5006 -- If operand is Any_Type, just propagate to result and do not
5007 -- try to fold, this prevents cascaded errors.
5009 if Etype
(Op1
) = Any_Type
then
5010 Set_Etype
(N
, Any_Type
);
5013 -- If operand raises constraint error, then replace node N with the
5014 -- raise constraint error node, and we are obviously not foldable.
5015 -- Note that this replacement inherits the Is_Static_Expression flag
5016 -- from the operand.
5018 elsif Raises_Constraint_Error
(Op1
) then
5019 Rewrite_In_Raise_CE
(N
, Op1
);
5022 -- If the operand is not static, then the result is not static, and
5023 -- all we have to do is to check the operand since it is now known
5024 -- to appear in a non-static context.
5026 elsif not Is_Static_Expression
(Op1
) then
5027 Check_Non_Static_Context
(Op1
);
5028 Fold
:= Compile_Time_Known_Value
(Op1
);
5031 -- An expression of a formal modular type is not foldable because
5032 -- the modulus is unknown.
5034 elsif Is_Modular_Integer_Type
(Etype
(Op1
))
5035 and then Is_Generic_Type
(Etype
(Op1
))
5037 Check_Non_Static_Context
(Op1
);
5040 -- Here we have the case of an operand whose type is OK, which is
5041 -- static, and which does not raise constraint error, we can fold.
5044 Set_Is_Static_Expression
(N
);
5048 end Test_Expression_Is_Foldable
;
5052 procedure Test_Expression_Is_Foldable
5059 Rstat
: constant Boolean := Is_Static_Expression
(Op1
)
5060 and then Is_Static_Expression
(Op2
);
5066 if Debug_Flag_Dot_F
and then In_Extended_Main_Source_Unit
(N
) then
5070 -- If either operand is Any_Type, just propagate to result and
5071 -- do not try to fold, this prevents cascaded errors.
5073 if Etype
(Op1
) = Any_Type
or else Etype
(Op2
) = Any_Type
then
5074 Set_Etype
(N
, Any_Type
);
5077 -- If left operand raises constraint error, then replace node N with the
5078 -- Raise_Constraint_Error node, and we are obviously not foldable.
5079 -- Is_Static_Expression is set from the two operands in the normal way,
5080 -- and we check the right operand if it is in a non-static context.
5082 elsif Raises_Constraint_Error
(Op1
) then
5084 Check_Non_Static_Context
(Op2
);
5087 Rewrite_In_Raise_CE
(N
, Op1
);
5088 Set_Is_Static_Expression
(N
, Rstat
);
5091 -- Similar processing for the case of the right operand. Note that we
5092 -- don't use this routine for the short-circuit case, so we do not have
5093 -- to worry about that special case here.
5095 elsif Raises_Constraint_Error
(Op2
) then
5097 Check_Non_Static_Context
(Op1
);
5100 Rewrite_In_Raise_CE
(N
, Op2
);
5101 Set_Is_Static_Expression
(N
, Rstat
);
5104 -- Exclude expressions of a generic modular type, as above
5106 elsif Is_Modular_Integer_Type
(Etype
(Op1
))
5107 and then Is_Generic_Type
(Etype
(Op1
))
5109 Check_Non_Static_Context
(Op1
);
5112 -- If result is not static, then check non-static contexts on operands
5113 -- since one of them may be static and the other one may not be static.
5115 elsif not Rstat
then
5116 Check_Non_Static_Context
(Op1
);
5117 Check_Non_Static_Context
(Op2
);
5118 Fold
:= Compile_Time_Known_Value
(Op1
)
5119 and then Compile_Time_Known_Value
(Op2
);
5122 -- Else result is static and foldable. Both operands are static, and
5123 -- neither raises constraint error, so we can definitely fold.
5126 Set_Is_Static_Expression
(N
);
5131 end Test_Expression_Is_Foldable
;
5137 function Test_In_Range
5140 Assume_Valid
: Boolean;
5141 Fixed_Int
: Boolean;
5142 Int_Real
: Boolean) return Range_Membership
5147 pragma Warnings
(Off
, Assume_Valid
);
5148 -- For now Assume_Valid is unreferenced since the current implementation
5149 -- always returns Unknown if N is not a compile time known value, but we
5150 -- keep the parameter to allow for future enhancements in which we try
5151 -- to get the information in the variable case as well.
5154 -- Universal types have no range limits, so always in range
5156 if Typ
= Universal_Integer
or else Typ
= Universal_Real
then
5159 -- Never known if not scalar type. Don't know if this can actually
5160 -- happen, but our spec allows it, so we must check!
5162 elsif not Is_Scalar_Type
(Typ
) then
5165 -- Never known if this is a generic type, since the bounds of generic
5166 -- types are junk. Note that if we only checked for static expressions
5167 -- (instead of compile time known values) below, we would not need this
5168 -- check, because values of a generic type can never be static, but they
5169 -- can be known at compile time.
5171 elsif Is_Generic_Type
(Typ
) then
5174 -- Never known unless we have a compile time known value
5176 elsif not Compile_Time_Known_Value
(N
) then
5179 -- General processing with a known compile time value
5190 Lo
:= Type_Low_Bound
(Typ
);
5191 Hi
:= Type_High_Bound
(Typ
);
5193 LB_Known
:= Compile_Time_Known_Value
(Lo
);
5194 HB_Known
:= Compile_Time_Known_Value
(Hi
);
5196 -- Fixed point types should be considered as such only if flag
5197 -- Fixed_Int is set to False.
5199 if Is_Floating_Point_Type
(Typ
)
5200 or else (Is_Fixed_Point_Type
(Typ
) and then not Fixed_Int
)
5203 Valr
:= Expr_Value_R
(N
);
5205 if LB_Known
and HB_Known
then
5206 if Valr
>= Expr_Value_R
(Lo
)
5208 Valr
<= Expr_Value_R
(Hi
)
5212 return Out_Of_Range
;
5215 elsif (LB_Known
and then Valr
< Expr_Value_R
(Lo
))
5217 (HB_Known
and then Valr
> Expr_Value_R
(Hi
))
5219 return Out_Of_Range
;
5226 Val
:= Expr_Value
(N
);
5228 if LB_Known
and HB_Known
then
5229 if Val
>= Expr_Value
(Lo
)
5231 Val
<= Expr_Value
(Hi
)
5235 return Out_Of_Range
;
5238 elsif (LB_Known
and then Val
< Expr_Value
(Lo
))
5240 (HB_Known
and then Val
> Expr_Value
(Hi
))
5242 return Out_Of_Range
;
5256 procedure To_Bits
(U
: Uint
; B
: out Bits
) is
5258 for J
in 0 .. B
'Last loop
5259 B
(J
) := (U
/ (2 ** J
)) mod 2 /= 0;
5263 --------------------
5264 -- Why_Not_Static --
5265 --------------------
5267 procedure Why_Not_Static
(Expr
: Node_Id
) is
5268 N
: constant Node_Id
:= Original_Node
(Expr
);
5272 procedure Why_Not_Static_List
(L
: List_Id
);
5273 -- A version that can be called on a list of expressions. Finds all
5274 -- non-static violations in any element of the list.
5276 -------------------------
5277 -- Why_Not_Static_List --
5278 -------------------------
5280 procedure Why_Not_Static_List
(L
: List_Id
) is
5284 if Is_Non_Empty_List
(L
) then
5286 while Present
(N
) loop
5291 end Why_Not_Static_List
;
5293 -- Start of processing for Why_Not_Static
5296 -- If in ACATS mode (debug flag 2), then suppress all these messages,
5297 -- this avoids massive updates to the ACATS base line.
5299 if Debug_Flag_2
then
5303 -- Ignore call on error or empty node
5305 if No
(Expr
) or else Nkind
(Expr
) = N_Error
then
5309 -- Preprocessing for sub expressions
5311 if Nkind
(Expr
) in N_Subexpr
then
5313 -- Nothing to do if expression is static
5315 if Is_OK_Static_Expression
(Expr
) then
5319 -- Test for constraint error raised
5321 if Raises_Constraint_Error
(Expr
) then
5323 ("expression raises exception, cannot be static " &
5324 "(RM 4.9(34))!", N
);
5328 -- If no type, then something is pretty wrong, so ignore
5330 Typ
:= Etype
(Expr
);
5336 -- Type must be scalar or string type
5338 if not Is_Scalar_Type
(Typ
)
5339 and then not Is_String_Type
(Typ
)
5342 ("static expression must have scalar or string type " &
5348 -- If we got through those checks, test particular node kind
5351 when N_Expanded_Name | N_Identifier | N_Operator_Symbol
=>
5354 if Is_Named_Number
(E
) then
5357 elsif Ekind
(E
) = E_Constant
then
5358 if not Is_Static_Expression
(Constant_Value
(E
)) then
5360 ("& is not a static constant (RM 4.9(5))!", N
, E
);
5365 ("& is not static constant or named number " &
5366 "(RM 4.9(5))!", N
, E
);
5369 when N_Binary_Op | N_Short_Circuit | N_Membership_Test
=>
5370 if Nkind
(N
) in N_Op_Shift
then
5372 ("shift functions are never static (RM 4.9(6,18))!", N
);
5375 Why_Not_Static
(Left_Opnd
(N
));
5376 Why_Not_Static
(Right_Opnd
(N
));
5380 Why_Not_Static
(Right_Opnd
(N
));
5382 when N_Attribute_Reference
=>
5383 Why_Not_Static_List
(Expressions
(N
));
5385 E
:= Etype
(Prefix
(N
));
5387 if E
= Standard_Void_Type
then
5391 -- Special case non-scalar'Size since this is a common error
5393 if Attribute_Name
(N
) = Name_Size
then
5395 ("size attribute is only static for static scalar type " &
5396 "(RM 4.9(7,8))", N
);
5400 elsif Is_Array_Type
(E
) then
5401 if Attribute_Name
(N
) /= Name_First
5403 Attribute_Name
(N
) /= Name_Last
5405 Attribute_Name
(N
) /= Name_Length
5408 ("static array attribute must be Length, First, or Last " &
5411 -- Since we know the expression is not-static (we already
5412 -- tested for this, must mean array is not static).
5416 ("prefix is non-static array (RM 4.9(8))!", Prefix
(N
));
5421 -- Special case generic types, since again this is a common source
5424 elsif Is_Generic_Actual_Type
(E
)
5429 ("attribute of generic type is never static " &
5430 "(RM 4.9(7,8))!", N
);
5432 elsif Is_Static_Subtype
(E
) then
5435 elsif Is_Scalar_Type
(E
) then
5437 ("prefix type for attribute is not static scalar subtype " &
5442 ("static attribute must apply to array/scalar type " &
5443 "(RM 4.9(7,8))!", N
);
5446 when N_String_Literal
=>
5448 ("subtype of string literal is non-static (RM 4.9(4))!", N
);
5450 when N_Explicit_Dereference
=>
5452 ("explicit dereference is never static (RM 4.9)!", N
);
5454 when N_Function_Call
=>
5455 Why_Not_Static_List
(Parameter_Associations
(N
));
5456 Error_Msg_N
("non-static function call (RM 4.9(6,18))!", N
);
5458 when N_Parameter_Association
=>
5459 Why_Not_Static
(Explicit_Actual_Parameter
(N
));
5461 when N_Indexed_Component
=>
5463 ("indexed component is never static (RM 4.9)!", N
);
5465 when N_Procedure_Call_Statement
=>
5467 ("procedure call is never static (RM 4.9)!", N
);
5469 when N_Qualified_Expression
=>
5470 Why_Not_Static
(Expression
(N
));
5472 when N_Aggregate | N_Extension_Aggregate
=>
5474 ("an aggregate is never static (RM 4.9)!", N
);
5477 Why_Not_Static
(Low_Bound
(N
));
5478 Why_Not_Static
(High_Bound
(N
));
5480 when N_Range_Constraint
=>
5481 Why_Not_Static
(Range_Expression
(N
));
5483 when N_Subtype_Indication
=>
5484 Why_Not_Static
(Constraint
(N
));
5486 when N_Selected_Component
=>
5488 ("selected component is never static (RM 4.9)!", N
);
5492 ("slice is never static (RM 4.9)!", N
);
5494 when N_Type_Conversion
=>
5495 Why_Not_Static
(Expression
(N
));
5497 if not Is_Scalar_Type
(Entity
(Subtype_Mark
(N
)))
5498 or else not Is_Static_Subtype
(Entity
(Subtype_Mark
(N
)))
5501 ("static conversion requires static scalar subtype result " &
5505 when N_Unchecked_Type_Conversion
=>
5507 ("unchecked type conversion is never static (RM 4.9)!", N
);