1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2008, 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
;
35 with Namet
; use Namet
;
36 with Nmake
; use Nmake
;
37 with Nlists
; use Nlists
;
40 with Sem_Cat
; use Sem_Cat
;
41 with Sem_Ch6
; use Sem_Ch6
;
42 with Sem_Ch8
; use Sem_Ch8
;
43 with Sem_Res
; use Sem_Res
;
44 with Sem_Util
; use Sem_Util
;
45 with Sem_Type
; use Sem_Type
;
46 with Sem_Warn
; use Sem_Warn
;
47 with Sinfo
; use Sinfo
;
48 with Snames
; use Snames
;
49 with Stand
; use Stand
;
50 with Stringt
; use Stringt
;
51 with Tbuild
; use Tbuild
;
53 package body Sem_Eval
is
55 -----------------------------------------
56 -- Handling of Compile Time Evaluation --
57 -----------------------------------------
59 -- The compile time evaluation of expressions is distributed over several
60 -- Eval_xxx procedures. These procedures are called immediately after
61 -- a subexpression is resolved and is therefore accomplished in a bottom
62 -- up fashion. The flags are synthesized using the following approach.
64 -- Is_Static_Expression is determined by following the detailed rules
65 -- in RM 4.9(4-14). This involves testing the Is_Static_Expression
66 -- flag of the operands in many cases.
68 -- Raises_Constraint_Error is set if any of the operands have the flag
69 -- set or if an attempt to compute the value of the current expression
70 -- results in detection of a runtime constraint error.
72 -- As described in the spec, the requirement is that Is_Static_Expression
73 -- be accurately set, and in addition for nodes for which this flag is set,
74 -- Raises_Constraint_Error must also be set. Furthermore a node which has
75 -- Is_Static_Expression set, and Raises_Constraint_Error clear, then the
76 -- requirement is that the expression value must be precomputed, and the
77 -- node is either a literal, or the name of a constant entity whose value
78 -- is a static expression.
80 -- The general approach is as follows. First compute Is_Static_Expression.
81 -- If the node is not static, then the flag is left off in the node and
82 -- we are all done. Otherwise for a static node, we test if any of the
83 -- operands will raise constraint error, and if so, propagate the flag
84 -- Raises_Constraint_Error to the result node and we are done (since the
85 -- error was already posted at a lower level).
87 -- For the case of a static node whose operands do not raise constraint
88 -- error, we attempt to evaluate the node. If this evaluation succeeds,
89 -- then the node is replaced by the result of this computation. If the
90 -- evaluation raises constraint error, then we rewrite the node with
91 -- Apply_Compile_Time_Constraint_Error to raise the exception and also
92 -- to post appropriate error messages.
98 type Bits
is array (Nat
range <>) of Boolean;
99 -- Used to convert unsigned (modular) values for folding logical ops
101 -- The following definitions are used to maintain a cache of nodes that
102 -- have compile time known values. The cache is maintained only for
103 -- discrete types (the most common case), and is populated by calls to
104 -- Compile_Time_Known_Value and Expr_Value, but only used by Expr_Value
105 -- since it is possible for the status to change (in particular it is
106 -- possible for a node to get replaced by a constraint error node).
108 CV_Bits
: constant := 5;
109 -- Number of low order bits of Node_Id value used to reference entries
110 -- in the cache table.
112 CV_Cache_Size
: constant Nat
:= 2 ** CV_Bits
;
113 -- Size of cache for compile time values
115 subtype CV_Range
is Nat
range 0 .. CV_Cache_Size
;
117 type CV_Entry
is record
122 type CV_Cache_Array
is array (CV_Range
) of CV_Entry
;
124 CV_Cache
: CV_Cache_Array
:= (others => (Node_High_Bound
, Uint_0
));
125 -- This is the actual cache, with entries consisting of node/value pairs,
126 -- and the impossible value Node_High_Bound used for unset entries.
128 -----------------------
129 -- Local Subprograms --
130 -----------------------
132 function From_Bits
(B
: Bits
; T
: Entity_Id
) return Uint
;
133 -- Converts a bit string of length B'Length to a Uint value to be used
134 -- for a target of type T, which is a modular type. This procedure
135 -- includes the necessary reduction by the modulus in the case of a
136 -- non-binary modulus (for a binary modulus, the bit string is the
137 -- right length any way so all is well).
139 function Get_String_Val
(N
: Node_Id
) return Node_Id
;
140 -- Given a tree node for a folded string or character value, returns
141 -- the corresponding string literal or character literal (one of the
142 -- two must be available, or the operand would not have been marked
143 -- as foldable in the earlier analysis of the operation).
145 function OK_Bits
(N
: Node_Id
; Bits
: Uint
) return Boolean;
146 -- Bits represents the number of bits in an integer value to be computed
147 -- (but the value has not been computed yet). If this value in Bits is
148 -- reasonable, a result of True is returned, with the implication that
149 -- the caller should go ahead and complete the calculation. If the value
150 -- in Bits is unreasonably large, then an error is posted on node N, and
151 -- False is returned (and the caller skips the proposed calculation).
153 procedure Out_Of_Range
(N
: Node_Id
);
154 -- This procedure is called if it is determined that node N, which
155 -- appears in a non-static context, is a compile time known value
156 -- which is outside its range, i.e. the range of Etype. This is used
157 -- in contexts where this is an illegality if N is static, and should
158 -- generate a warning otherwise.
160 procedure Rewrite_In_Raise_CE
(N
: Node_Id
; Exp
: Node_Id
);
161 -- N and Exp are nodes representing an expression, Exp is known
162 -- to raise CE. N is rewritten in term of Exp in the optimal way.
164 function String_Type_Len
(Stype
: Entity_Id
) return Uint
;
165 -- Given a string type, determines the length of the index type, or,
166 -- if this index type is non-static, the length of the base type of
167 -- this index type. Note that if the string type is itself static,
168 -- then the index type is static, so the second case applies only
169 -- if the string type passed is non-static.
171 function Test
(Cond
: Boolean) return Uint
;
172 pragma Inline
(Test
);
173 -- This function simply returns the appropriate Boolean'Pos value
174 -- corresponding to the value of Cond as a universal integer. It is
175 -- used for producing the result of the static evaluation of the
178 procedure Test_Expression_Is_Foldable
183 -- Tests to see if expression N whose single operand is Op1 is foldable,
184 -- i.e. the operand value is known at compile time. If the operation is
185 -- foldable, then Fold is True on return, and Stat indicates whether
186 -- the result is static (i.e. both operands were static). Note that it
187 -- is quite possible for Fold to be True, and Stat to be False, since
188 -- there are cases in which we know the value of an operand even though
189 -- it is not technically static (e.g. the static lower bound of a range
190 -- whose upper bound is non-static).
192 -- If Stat is set False on return, then Expression_Is_Foldable makes a
193 -- call to Check_Non_Static_Context on the operand. If Fold is False on
194 -- return, then all processing is complete, and the caller should
195 -- return, since there is nothing else to do.
197 procedure Test_Expression_Is_Foldable
203 -- Same processing, except applies to an expression N with two operands
206 procedure To_Bits
(U
: Uint
; B
: out Bits
);
207 -- Converts a Uint value to a bit string of length B'Length
209 ------------------------------
210 -- Check_Non_Static_Context --
211 ------------------------------
213 procedure Check_Non_Static_Context
(N
: Node_Id
) is
214 T
: constant Entity_Id
:= Etype
(N
);
215 Checks_On
: constant Boolean :=
216 not Index_Checks_Suppressed
(T
)
217 and not Range_Checks_Suppressed
(T
);
220 -- Ignore cases of non-scalar types or error types
222 if T
= Any_Type
or else not Is_Scalar_Type
(T
) then
226 -- At this stage we have a scalar type. If we have an expression
227 -- that raises CE, then we already issued a warning or error msg
228 -- so there is nothing more to be done in this routine.
230 if Raises_Constraint_Error
(N
) then
234 -- Now we have a scalar type which is not marked as raising a
235 -- constraint error exception. The main purpose of this routine
236 -- is to deal with static expressions appearing in a non-static
237 -- context. That means that if we do not have a static expression
238 -- then there is not much to do. The one case that we deal with
239 -- here is that if we have a floating-point value that is out of
240 -- range, then we post a warning that an infinity will result.
242 if not Is_Static_Expression
(N
) then
243 if Is_Floating_Point_Type
(T
)
244 and then Is_Out_Of_Range
(N
, Base_Type
(T
))
247 ("?float value out of range, infinity will be generated", N
);
253 -- Here we have the case of outer level static expression of
254 -- scalar type, where the processing of this procedure is needed.
256 -- For real types, this is where we convert the value to a machine
257 -- number (see RM 4.9(38)). Also see ACVC test C490001. We should
258 -- only need to do this if the parent is a constant declaration,
259 -- since in other cases, gigi should do the necessary conversion
260 -- correctly, but experimentation shows that this is not the case
261 -- on all machines, in particular if we do not convert all literals
262 -- to machine values in non-static contexts, then ACVC test C490001
263 -- fails on Sparc/Solaris and SGI/Irix.
265 if Nkind
(N
) = N_Real_Literal
266 and then not Is_Machine_Number
(N
)
267 and then not Is_Generic_Type
(Etype
(N
))
268 and then Etype
(N
) /= Universal_Real
270 -- Check that value is in bounds before converting to machine
271 -- number, so as not to lose case where value overflows in the
272 -- least significant bit or less. See B490001.
274 if Is_Out_Of_Range
(N
, Base_Type
(T
)) then
279 -- Note: we have to copy the node, to avoid problems with conformance
280 -- of very similar numbers (see ACVC tests B4A010C and B63103A).
282 Rewrite
(N
, New_Copy
(N
));
284 if not Is_Floating_Point_Type
(T
) then
286 (N
, Corresponding_Integer_Value
(N
) * Small_Value
(T
));
288 elsif not UR_Is_Zero
(Realval
(N
)) then
290 -- Note: even though RM 4.9(38) specifies biased rounding,
291 -- this has been modified by AI-100 in order to prevent
292 -- confusing differences in rounding between static and
293 -- non-static expressions. AI-100 specifies that the effect
294 -- of such rounding is implementation dependent, and in GNAT
295 -- we round to nearest even to match the run-time behavior.
298 (N
, Machine
(Base_Type
(T
), Realval
(N
), Round_Even
, N
));
301 Set_Is_Machine_Number
(N
);
304 -- Check for out of range universal integer. This is a non-static
305 -- context, so the integer value must be in range of the runtime
306 -- representation of universal integers.
308 -- We do this only within an expression, because that is the only
309 -- case in which non-static universal integer values can occur, and
310 -- furthermore, Check_Non_Static_Context is currently (incorrectly???)
311 -- called in contexts like the expression of a number declaration where
312 -- we certainly want to allow out of range values.
314 if Etype
(N
) = Universal_Integer
315 and then Nkind
(N
) = N_Integer_Literal
316 and then Nkind
(Parent
(N
)) in N_Subexpr
318 (Intval
(N
) < Expr_Value
(Type_Low_Bound
(Universal_Integer
))
320 Intval
(N
) > Expr_Value
(Type_High_Bound
(Universal_Integer
)))
322 Apply_Compile_Time_Constraint_Error
323 (N
, "non-static universal integer value out of range?",
324 CE_Range_Check_Failed
);
326 -- Check out of range of base type
328 elsif Is_Out_Of_Range
(N
, Base_Type
(T
)) then
331 -- Give warning if outside subtype (where one or both of the
332 -- bounds of the subtype is static). This warning is omitted
333 -- if the expression appears in a range that could be null
334 -- (warnings are handled elsewhere for this case).
336 elsif T
/= Base_Type
(T
)
337 and then Nkind
(Parent
(N
)) /= N_Range
339 if Is_In_Range
(N
, T
) then
342 elsif Is_Out_Of_Range
(N
, T
) then
343 Apply_Compile_Time_Constraint_Error
344 (N
, "value not in range of}?", CE_Range_Check_Failed
);
347 Enable_Range_Check
(N
);
350 Set_Do_Range_Check
(N
, False);
353 end Check_Non_Static_Context
;
355 ---------------------------------
356 -- Check_String_Literal_Length --
357 ---------------------------------
359 procedure Check_String_Literal_Length
(N
: Node_Id
; Ttype
: Entity_Id
) is
361 if not Raises_Constraint_Error
(N
)
362 and then Is_Constrained
(Ttype
)
365 UI_From_Int
(String_Length
(Strval
(N
))) /= String_Type_Len
(Ttype
)
367 Apply_Compile_Time_Constraint_Error
368 (N
, "string length wrong for}?",
369 CE_Length_Check_Failed
,
374 end Check_String_Literal_Length
;
376 --------------------------
377 -- Compile_Time_Compare --
378 --------------------------
380 function Compile_Time_Compare
382 Rec
: Boolean := False) return Compare_Result
384 Ltyp
: constant Entity_Id
:= Etype
(L
);
385 Rtyp
: constant Entity_Id
:= Etype
(R
);
387 procedure Compare_Decompose
391 -- This procedure decomposes the node N into an expression node and a
392 -- signed offset, so that the value of N is equal to the value of R plus
393 -- the value V (which may be negative). If no such decomposition is
394 -- possible, then on return R is a copy of N, and V is set to zero.
396 function Compare_Fixup
(N
: Node_Id
) return Node_Id
;
397 -- This function deals with replacing 'Last and 'First references with
398 -- their corresponding type bounds, which we then can compare. The
399 -- argument is the original node, the result is the identity, unless we
400 -- have a 'Last/'First reference in which case the value returned is the
401 -- appropriate type bound.
403 function Is_Same_Value
(L
, R
: Node_Id
) return Boolean;
404 -- Returns True iff L and R represent expressions that definitely
405 -- have identical (but not necessarily compile time known) values
406 -- Indeed the caller is expected to have already dealt with the
407 -- cases of compile time known values, so these are not tested here.
409 -----------------------
410 -- Compare_Decompose --
411 -----------------------
413 procedure Compare_Decompose
419 if Nkind
(N
) = N_Op_Add
420 and then Nkind
(Right_Opnd
(N
)) = N_Integer_Literal
423 V
:= Intval
(Right_Opnd
(N
));
426 elsif Nkind
(N
) = N_Op_Subtract
427 and then Nkind
(Right_Opnd
(N
)) = N_Integer_Literal
430 V
:= UI_Negate
(Intval
(Right_Opnd
(N
)));
433 elsif Nkind
(N
) = N_Attribute_Reference
then
434 if Attribute_Name
(N
) = Name_Succ
then
435 R
:= First
(Expressions
(N
));
439 elsif Attribute_Name
(N
) = Name_Pred
then
440 R
:= First
(Expressions
(N
));
448 end Compare_Decompose
;
454 function Compare_Fixup
(N
: Node_Id
) return Node_Id
is
460 if Nkind
(N
) = N_Attribute_Reference
461 and then (Attribute_Name
(N
) = Name_First
463 Attribute_Name
(N
) = Name_Last
)
465 Xtyp
:= Etype
(Prefix
(N
));
467 -- If we have no type, then just abandon the attempt to do
468 -- a fixup, this is probably the result of some other error.
474 -- Dereference an access type
476 if Is_Access_Type
(Xtyp
) then
477 Xtyp
:= Designated_Type
(Xtyp
);
480 -- If we don't have an array type at this stage, something
481 -- is peculiar, e.g. another error, and we abandon the attempt
484 if not Is_Array_Type
(Xtyp
) then
488 -- Ignore unconstrained array, since bounds are not meaningful
490 if not Is_Constrained
(Xtyp
) then
494 if Ekind
(Xtyp
) = E_String_Literal_Subtype
then
495 if Attribute_Name
(N
) = Name_First
then
496 return String_Literal_Low_Bound
(Xtyp
);
498 else -- Attribute_Name (N) = Name_Last
499 return Make_Integer_Literal
(Sloc
(N
),
500 Intval
=> Intval
(String_Literal_Low_Bound
(Xtyp
))
501 + String_Literal_Length
(Xtyp
));
505 -- Find correct index type
507 Indx
:= First_Index
(Xtyp
);
509 if Present
(Expressions
(N
)) then
510 Subs
:= UI_To_Int
(Expr_Value
(First
(Expressions
(N
))));
512 for J
in 2 .. Subs
loop
513 Indx
:= Next_Index
(Indx
);
517 Xtyp
:= Etype
(Indx
);
519 if Attribute_Name
(N
) = Name_First
then
520 return Type_Low_Bound
(Xtyp
);
522 else -- Attribute_Name (N) = Name_Last
523 return Type_High_Bound
(Xtyp
);
534 function Is_Same_Value
(L
, R
: Node_Id
) return Boolean is
535 Lf
: constant Node_Id
:= Compare_Fixup
(L
);
536 Rf
: constant Node_Id
:= Compare_Fixup
(R
);
538 function Is_Same_Subscript
(L
, R
: List_Id
) return Boolean;
539 -- L, R are the Expressions values from two attribute nodes
540 -- for First or Last attributes. Either may be set to No_List
541 -- if no expressions are present (indicating subscript 1).
542 -- The result is True if both expressions represent the same
543 -- subscript (note that one case is where one subscript is
544 -- missing and the other is explicitly set to 1).
546 -----------------------
547 -- Is_Same_Subscript --
548 -----------------------
550 function Is_Same_Subscript
(L
, R
: List_Id
) return Boolean is
556 return Expr_Value
(First
(R
)) = Uint_1
;
561 return Expr_Value
(First
(L
)) = Uint_1
;
563 return Expr_Value
(First
(L
)) = Expr_Value
(First
(R
));
566 end Is_Same_Subscript
;
568 -- Start of processing for Is_Same_Value
571 -- Values are the same if they refer to the same entity and the
572 -- entity is a constant object (E_Constant). This does not however
573 -- apply to Float types, since we may have two NaN values and they
574 -- should never compare equal.
576 if Nkind_In
(Lf
, N_Identifier
, N_Expanded_Name
)
577 and then Nkind_In
(Rf
, N_Identifier
, N_Expanded_Name
)
578 and then Entity
(Lf
) = Entity
(Rf
)
579 and then Present
(Entity
(Lf
))
580 and then not Is_Floating_Point_Type
(Etype
(L
))
581 and then Is_Constant_Object
(Entity
(Lf
))
585 -- Or if they are compile time known and identical
587 elsif Compile_Time_Known_Value
(Lf
)
589 Compile_Time_Known_Value
(Rf
)
590 and then Expr_Value
(Lf
) = Expr_Value
(Rf
)
594 -- False if Nkind of the two nodes is different for remaining cases
596 elsif Nkind
(Lf
) /= Nkind
(Rf
) then
599 -- True if both 'First or 'Last values applying to the same entity
600 -- (first and last don't change even if value does). Note that we
601 -- need this even with the calls to Compare_Fixup, to handle the
602 -- case of unconstrained array attributes where Compare_Fixup
603 -- cannot find useful bounds.
605 elsif Nkind
(Lf
) = N_Attribute_Reference
606 and then Attribute_Name
(Lf
) = Attribute_Name
(Rf
)
607 and then (Attribute_Name
(Lf
) = Name_First
609 Attribute_Name
(Lf
) = Name_Last
)
610 and then Nkind_In
(Prefix
(Lf
), N_Identifier
, N_Expanded_Name
)
611 and then Nkind_In
(Prefix
(Rf
), N_Identifier
, N_Expanded_Name
)
612 and then Entity
(Prefix
(Lf
)) = Entity
(Prefix
(Rf
))
613 and then Is_Same_Subscript
(Expressions
(Lf
), Expressions
(Rf
))
617 -- True if the same selected component from the same record
619 elsif Nkind
(Lf
) = N_Selected_Component
620 and then Selector_Name
(Lf
) = Selector_Name
(Rf
)
621 and then Is_Same_Value
(Prefix
(Lf
), Prefix
(Rf
))
625 -- True if the same unary operator applied to the same operand
627 elsif Nkind
(Lf
) in N_Unary_Op
628 and then Is_Same_Value
(Right_Opnd
(Lf
), Right_Opnd
(Rf
))
632 -- True if the same binary operator applied to the same operands
634 elsif Nkind
(Lf
) in N_Binary_Op
635 and then Is_Same_Value
(Left_Opnd
(Lf
), Left_Opnd
(Rf
))
636 and then Is_Same_Value
(Right_Opnd
(Lf
), Right_Opnd
(Rf
))
640 -- All other cases, we can't tell, so return False
647 -- Start of processing for Compile_Time_Compare
650 -- If either operand could raise constraint error, then we cannot
651 -- know the result at compile time (since CE may be raised!)
653 if not (Cannot_Raise_Constraint_Error
(L
)
655 Cannot_Raise_Constraint_Error
(R
))
660 -- Identical operands are most certainly equal
665 -- If expressions have no types, then do not attempt to determine
666 -- if they are the same, since something funny is going on. One
667 -- case in which this happens is during generic template analysis,
668 -- when bounds are not fully analyzed.
670 elsif No
(Ltyp
) or else No
(Rtyp
) then
673 -- We only attempt compile time analysis for scalar values, and
674 -- not for packed arrays represented as modular types, where the
675 -- semantics of comparison is quite different.
677 elsif not Is_Scalar_Type
(Ltyp
)
678 or else Is_Packed_Array_Type
(Ltyp
)
682 -- Case where comparison involves two compile time known values
684 elsif Compile_Time_Known_Value
(L
)
685 and then Compile_Time_Known_Value
(R
)
687 -- For the floating-point case, we have to be a little careful, since
688 -- at compile time we are dealing with universal exact values, but at
689 -- runtime, these will be in non-exact target form. That's why the
690 -- returned results are LE and GE below instead of LT and GT.
692 if Is_Floating_Point_Type
(Ltyp
)
694 Is_Floating_Point_Type
(Rtyp
)
697 Lo
: constant Ureal
:= Expr_Value_R
(L
);
698 Hi
: constant Ureal
:= Expr_Value_R
(R
);
710 -- For the integer case we know exactly (note that this includes the
711 -- fixed-point case, where we know the run time integer values now)
715 Lo
: constant Uint
:= Expr_Value
(L
);
716 Hi
: constant Uint
:= Expr_Value
(R
);
729 -- Cases where at least one operand is not known at compile time
732 -- Remaining checks apply only for non-generic discrete types
734 if not Is_Discrete_Type
(Ltyp
)
735 or else not Is_Discrete_Type
(Rtyp
)
736 or else Is_Generic_Type
(Ltyp
)
737 or else Is_Generic_Type
(Rtyp
)
742 -- Here is where we check for comparisons against maximum bounds of
743 -- types, where we know that no value can be outside the bounds of
744 -- the subtype. Note that this routine is allowed to assume that all
745 -- expressions are within their subtype bounds. Callers wishing to
746 -- deal with possibly invalid values must in any case take special
747 -- steps (e.g. conversions to larger types) to avoid this kind of
748 -- optimization, which is always considered to be valid. We do not
749 -- attempt this optimization with generic types, since the type
750 -- bounds may not be meaningful in this case.
752 -- We are in danger of an infinite recursion here. It does not seem
753 -- useful to go more than one level deep, so the parameter Rec is
754 -- used to protect ourselves against this infinite recursion.
758 -- See if we can get a decisive check against one operand and
759 -- a bound of the other operand (four possible tests here).
761 case Compile_Time_Compare
(L
, Type_Low_Bound
(Rtyp
), True) is
762 when LT
=> return LT
;
763 when LE
=> return LE
;
764 when EQ
=> return LE
;
768 case Compile_Time_Compare
(L
, Type_High_Bound
(Rtyp
), True) is
769 when GT
=> return GT
;
770 when GE
=> return GE
;
771 when EQ
=> return GE
;
775 case Compile_Time_Compare
(Type_Low_Bound
(Ltyp
), R
, True) is
776 when GT
=> return GT
;
777 when GE
=> return GE
;
778 when EQ
=> return GE
;
782 case Compile_Time_Compare
(Type_High_Bound
(Ltyp
), R
, True) is
783 when LT
=> return LT
;
784 when LE
=> return LE
;
785 when EQ
=> return LE
;
790 -- Next attempt is to decompose the expressions to extract
791 -- a constant offset resulting from the use of any of the forms:
798 -- Then we see if the two expressions are the same value, and if so
799 -- the result is obtained by comparing the offsets.
808 Compare_Decompose
(L
, Lnode
, Loffs
);
809 Compare_Decompose
(R
, Rnode
, Roffs
);
811 if Is_Same_Value
(Lnode
, Rnode
) then
812 if Loffs
= Roffs
then
815 elsif Loffs
< Roffs
then
824 -- Next attempt is to see if we have an entity compared with a
825 -- compile time known value, where there is a current value
826 -- conditional for the entity which can tell us the result.
830 -- Entity variable (left operand)
833 -- Value (right operand)
836 -- If False, we have reversed the operands
839 -- Comparison operator kind from Get_Current_Value_Condition call
842 -- Value from Get_Current_Value_Condition call
847 Result
: Compare_Result
;
848 -- Known result before inversion
851 if Is_Entity_Name
(L
)
852 and then Compile_Time_Known_Value
(R
)
855 Val
:= Expr_Value
(R
);
858 elsif Is_Entity_Name
(R
)
859 and then Compile_Time_Known_Value
(L
)
862 Val
:= Expr_Value
(L
);
865 -- That was the last chance at finding a compile time result
871 Get_Current_Value_Condition
(Var
, Op
, Opn
);
873 -- That was the last chance, so if we got nothing return
879 Opv
:= Expr_Value
(Opn
);
881 -- We got a comparison, so we might have something interesting
883 -- Convert LE to LT and GE to GT, just so we have fewer cases
888 elsif Op
= N_Op_Ge
then
893 -- Deal with equality case
904 -- Deal with inequality case
906 elsif Op
= N_Op_Ne
then
913 -- Deal with greater than case
915 elsif Op
= N_Op_Gt
then
918 elsif Opv
= Val
- 1 then
924 -- Deal with less than case
926 else pragma Assert
(Op
= N_Op_Lt
);
929 elsif Opv
= Val
+ 1 then
936 -- Deal with inverting result
940 when GT
=> return LT
;
941 when GE
=> return LE
;
942 when LT
=> return GT
;
943 when LE
=> return GE
;
944 when others => return Result
;
951 end Compile_Time_Compare
;
953 -------------------------------
954 -- Compile_Time_Known_Bounds --
955 -------------------------------
957 function Compile_Time_Known_Bounds
(T
: Entity_Id
) return Boolean is
962 if not Is_Array_Type
(T
) then
966 Indx
:= First_Index
(T
);
967 while Present
(Indx
) loop
968 Typ
:= Underlying_Type
(Etype
(Indx
));
969 if not Compile_Time_Known_Value
(Type_Low_Bound
(Typ
)) then
971 elsif not Compile_Time_Known_Value
(Type_High_Bound
(Typ
)) then
979 end Compile_Time_Known_Bounds
;
981 ------------------------------
982 -- Compile_Time_Known_Value --
983 ------------------------------
985 function Compile_Time_Known_Value
(Op
: Node_Id
) return Boolean is
986 K
: constant Node_Kind
:= Nkind
(Op
);
987 CV_Ent
: CV_Entry
renames CV_Cache
(Nat
(Op
) mod CV_Cache_Size
);
990 -- Never known at compile time if bad type or raises constraint error
991 -- or empty (latter case occurs only as a result of a previous error)
995 or else Etype
(Op
) = Any_Type
996 or else Raises_Constraint_Error
(Op
)
1001 -- If this is not a static expression and we are in configurable run
1002 -- time mode, then we consider it not known at compile time. This
1003 -- avoids anomalies where whether something is permitted with a given
1004 -- configurable run-time library depends on how good the compiler is
1005 -- at optimizing and knowing that things are constant when they
1008 if Configurable_Run_Time_Mode
and then not Is_Static_Expression
(Op
) then
1012 -- If we have an entity name, then see if it is the name of a constant
1013 -- and if so, test the corresponding constant value, or the name of
1014 -- an enumeration literal, which is always a constant.
1016 if Present
(Etype
(Op
)) and then Is_Entity_Name
(Op
) then
1018 E
: constant Entity_Id
:= Entity
(Op
);
1022 -- Never known at compile time if it is a packed array value.
1023 -- We might want to try to evaluate these at compile time one
1024 -- day, but we do not make that attempt now.
1026 if Is_Packed_Array_Type
(Etype
(Op
)) then
1030 if Ekind
(E
) = E_Enumeration_Literal
then
1033 elsif Ekind
(E
) = E_Constant
then
1034 V
:= Constant_Value
(E
);
1035 return Present
(V
) and then Compile_Time_Known_Value
(V
);
1039 -- We have a value, see if it is compile time known
1042 -- Integer literals are worth storing in the cache
1044 if K
= N_Integer_Literal
then
1046 CV_Ent
.V
:= Intval
(Op
);
1049 -- Other literals and NULL are known at compile time
1052 K
= N_Character_Literal
1056 K
= N_String_Literal
1062 -- Any reference to Null_Parameter is known at compile time. No
1063 -- other attribute references (that have not already been folded)
1064 -- are known at compile time.
1066 elsif K
= N_Attribute_Reference
then
1067 return Attribute_Name
(Op
) = Name_Null_Parameter
;
1071 -- If we fall through, not known at compile time
1075 -- If we get an exception while trying to do this test, then some error
1076 -- has occurred, and we simply say that the value is not known after all
1081 end Compile_Time_Known_Value
;
1083 --------------------------------------
1084 -- Compile_Time_Known_Value_Or_Aggr --
1085 --------------------------------------
1087 function Compile_Time_Known_Value_Or_Aggr
(Op
: Node_Id
) return Boolean is
1089 -- If we have an entity name, then see if it is the name of a constant
1090 -- and if so, test the corresponding constant value, or the name of
1091 -- an enumeration literal, which is always a constant.
1093 if Is_Entity_Name
(Op
) then
1095 E
: constant Entity_Id
:= Entity
(Op
);
1099 if Ekind
(E
) = E_Enumeration_Literal
then
1102 elsif Ekind
(E
) /= E_Constant
then
1106 V
:= Constant_Value
(E
);
1108 and then Compile_Time_Known_Value_Or_Aggr
(V
);
1112 -- We have a value, see if it is compile time known
1115 if Compile_Time_Known_Value
(Op
) then
1118 elsif Nkind
(Op
) = N_Aggregate
then
1120 if Present
(Expressions
(Op
)) then
1125 Expr
:= First
(Expressions
(Op
));
1126 while Present
(Expr
) loop
1127 if not Compile_Time_Known_Value_Or_Aggr
(Expr
) then
1136 if Present
(Component_Associations
(Op
)) then
1141 Cass
:= First
(Component_Associations
(Op
));
1142 while Present
(Cass
) loop
1144 Compile_Time_Known_Value_Or_Aggr
(Expression
(Cass
))
1156 -- All other types of values are not known at compile time
1163 end Compile_Time_Known_Value_Or_Aggr
;
1169 -- This is only called for actuals of functions that are not predefined
1170 -- operators (which have already been rewritten as operators at this
1171 -- stage), so the call can never be folded, and all that needs doing for
1172 -- the actual is to do the check for a non-static context.
1174 procedure Eval_Actual
(N
: Node_Id
) is
1176 Check_Non_Static_Context
(N
);
1179 --------------------
1180 -- Eval_Allocator --
1181 --------------------
1183 -- Allocators are never static, so all we have to do is to do the
1184 -- check for a non-static context if an expression is present.
1186 procedure Eval_Allocator
(N
: Node_Id
) is
1187 Expr
: constant Node_Id
:= Expression
(N
);
1190 if Nkind
(Expr
) = N_Qualified_Expression
then
1191 Check_Non_Static_Context
(Expression
(Expr
));
1195 ------------------------
1196 -- Eval_Arithmetic_Op --
1197 ------------------------
1199 -- Arithmetic operations are static functions, so the result is static
1200 -- if both operands are static (RM 4.9(7), 4.9(20)).
1202 procedure Eval_Arithmetic_Op
(N
: Node_Id
) is
1203 Left
: constant Node_Id
:= Left_Opnd
(N
);
1204 Right
: constant Node_Id
:= Right_Opnd
(N
);
1205 Ltype
: constant Entity_Id
:= Etype
(Left
);
1206 Rtype
: constant Entity_Id
:= Etype
(Right
);
1211 -- If not foldable we are done
1213 Test_Expression_Is_Foldable
(N
, Left
, Right
, Stat
, Fold
);
1219 -- Fold for cases where both operands are of integer type
1221 if Is_Integer_Type
(Ltype
) and then Is_Integer_Type
(Rtype
) then
1223 Left_Int
: constant Uint
:= Expr_Value
(Left
);
1224 Right_Int
: constant Uint
:= Expr_Value
(Right
);
1231 Result
:= Left_Int
+ Right_Int
;
1233 when N_Op_Subtract
=>
1234 Result
:= Left_Int
- Right_Int
;
1236 when N_Op_Multiply
=>
1239 (Num_Bits
(Left_Int
) + Num_Bits
(Right_Int
)))
1241 Result
:= Left_Int
* Right_Int
;
1248 -- The exception Constraint_Error is raised by integer
1249 -- division, rem and mod if the right operand is zero.
1251 if Right_Int
= 0 then
1252 Apply_Compile_Time_Constraint_Error
1253 (N
, "division by zero",
1259 Result
:= Left_Int
/ Right_Int
;
1264 -- The exception Constraint_Error is raised by integer
1265 -- division, rem and mod if the right operand is zero.
1267 if Right_Int
= 0 then
1268 Apply_Compile_Time_Constraint_Error
1269 (N
, "mod with zero divisor",
1274 Result
:= Left_Int
mod Right_Int
;
1279 -- The exception Constraint_Error is raised by integer
1280 -- division, rem and mod if the right operand is zero.
1282 if Right_Int
= 0 then
1283 Apply_Compile_Time_Constraint_Error
1284 (N
, "rem with zero divisor",
1290 Result
:= Left_Int
rem Right_Int
;
1294 raise Program_Error
;
1297 -- Adjust the result by the modulus if the type is a modular type
1299 if Is_Modular_Integer_Type
(Ltype
) then
1300 Result
:= Result
mod Modulus
(Ltype
);
1302 -- For a signed integer type, check non-static overflow
1304 elsif (not Stat
) and then Is_Signed_Integer_Type
(Ltype
) then
1306 BT
: constant Entity_Id
:= Base_Type
(Ltype
);
1307 Lo
: constant Uint
:= Expr_Value
(Type_Low_Bound
(BT
));
1308 Hi
: constant Uint
:= Expr_Value
(Type_High_Bound
(BT
));
1310 if Result
< Lo
or else Result
> Hi
then
1311 Apply_Compile_Time_Constraint_Error
1312 (N
, "value not in range of }?",
1313 CE_Overflow_Check_Failed
,
1320 -- If we get here we can fold the result
1322 Fold_Uint
(N
, Result
, Stat
);
1325 -- Cases where at least one operand is a real. We handle the cases
1326 -- of both reals, or mixed/real integer cases (the latter happen
1327 -- only for divide and multiply, and the result is always real).
1329 elsif Is_Real_Type
(Ltype
) or else Is_Real_Type
(Rtype
) then
1336 if Is_Real_Type
(Ltype
) then
1337 Left_Real
:= Expr_Value_R
(Left
);
1339 Left_Real
:= UR_From_Uint
(Expr_Value
(Left
));
1342 if Is_Real_Type
(Rtype
) then
1343 Right_Real
:= Expr_Value_R
(Right
);
1345 Right_Real
:= UR_From_Uint
(Expr_Value
(Right
));
1348 if Nkind
(N
) = N_Op_Add
then
1349 Result
:= Left_Real
+ Right_Real
;
1351 elsif Nkind
(N
) = N_Op_Subtract
then
1352 Result
:= Left_Real
- Right_Real
;
1354 elsif Nkind
(N
) = N_Op_Multiply
then
1355 Result
:= Left_Real
* Right_Real
;
1357 else pragma Assert
(Nkind
(N
) = N_Op_Divide
);
1358 if UR_Is_Zero
(Right_Real
) then
1359 Apply_Compile_Time_Constraint_Error
1360 (N
, "division by zero", CE_Divide_By_Zero
);
1364 Result
:= Left_Real
/ Right_Real
;
1367 Fold_Ureal
(N
, Result
, Stat
);
1370 end Eval_Arithmetic_Op
;
1372 ----------------------------
1373 -- Eval_Character_Literal --
1374 ----------------------------
1376 -- Nothing to be done!
1378 procedure Eval_Character_Literal
(N
: Node_Id
) is
1379 pragma Warnings
(Off
, N
);
1382 end Eval_Character_Literal
;
1388 -- Static function calls are either calls to predefined operators
1389 -- with static arguments, or calls to functions that rename a literal.
1390 -- Only the latter case is handled here, predefined operators are
1391 -- constant-folded elsewhere.
1393 -- If the function is itself inherited (see 7423-001) the literal of
1394 -- the parent type must be explicitly converted to the return type
1397 procedure Eval_Call
(N
: Node_Id
) is
1398 Loc
: constant Source_Ptr
:= Sloc
(N
);
1399 Typ
: constant Entity_Id
:= Etype
(N
);
1403 if Nkind
(N
) = N_Function_Call
1404 and then No
(Parameter_Associations
(N
))
1405 and then Is_Entity_Name
(Name
(N
))
1406 and then Present
(Alias
(Entity
(Name
(N
))))
1407 and then Is_Enumeration_Type
(Base_Type
(Typ
))
1409 Lit
:= Alias
(Entity
(Name
(N
)));
1410 while Present
(Alias
(Lit
)) loop
1414 if Ekind
(Lit
) = E_Enumeration_Literal
then
1415 if Base_Type
(Etype
(Lit
)) /= Base_Type
(Typ
) then
1417 (N
, Convert_To
(Typ
, New_Occurrence_Of
(Lit
, Loc
)));
1419 Rewrite
(N
, New_Occurrence_Of
(Lit
, Loc
));
1427 ------------------------
1428 -- Eval_Concatenation --
1429 ------------------------
1431 -- Concatenation is a static function, so the result is static if
1432 -- both operands are static (RM 4.9(7), 4.9(21)).
1434 procedure Eval_Concatenation
(N
: Node_Id
) is
1435 Left
: constant Node_Id
:= Left_Opnd
(N
);
1436 Right
: constant Node_Id
:= Right_Opnd
(N
);
1437 C_Typ
: constant Entity_Id
:= Root_Type
(Component_Type
(Etype
(N
)));
1442 -- Concatenation is never static in Ada 83, so if Ada 83
1443 -- check operand non-static context
1445 if Ada_Version
= Ada_83
1446 and then Comes_From_Source
(N
)
1448 Check_Non_Static_Context
(Left
);
1449 Check_Non_Static_Context
(Right
);
1453 -- If not foldable we are done. In principle concatenation that yields
1454 -- any string type is static (i.e. an array type of character types).
1455 -- However, character types can include enumeration literals, and
1456 -- concatenation in that case cannot be described by a literal, so we
1457 -- only consider the operation static if the result is an array of
1458 -- (a descendant of) a predefined character type.
1460 Test_Expression_Is_Foldable
(N
, Left
, Right
, Stat
, Fold
);
1462 if Is_Standard_Character_Type
(C_Typ
)
1467 Set_Is_Static_Expression
(N
, False);
1471 -- Compile time string concatenation
1473 -- ??? Note that operands that are aggregates can be marked as
1474 -- static, so we should attempt at a later stage to fold
1475 -- concatenations with such aggregates.
1478 Left_Str
: constant Node_Id
:= Get_String_Val
(Left
);
1480 Right_Str
: constant Node_Id
:= Get_String_Val
(Right
);
1481 Folded_Val
: String_Id
;
1484 -- Establish new string literal, and store left operand. We make
1485 -- sure to use the special Start_String that takes an operand if
1486 -- the left operand is a string literal. Since this is optimized
1487 -- in the case where that is the most recently created string
1488 -- literal, we ensure efficient time/space behavior for the
1489 -- case of a concatenation of a series of string literals.
1491 if Nkind
(Left_Str
) = N_String_Literal
then
1492 Left_Len
:= String_Length
(Strval
(Left_Str
));
1494 -- If the left operand is the empty string, and the right operand
1495 -- is a string literal (the case of "" & "..."), the result is the
1496 -- value of the right operand. This optimization is important when
1497 -- Is_Folded_In_Parser, to avoid copying an enormous right
1500 if Left_Len
= 0 and then Nkind
(Right_Str
) = N_String_Literal
then
1501 Folded_Val
:= Strval
(Right_Str
);
1503 Start_String
(Strval
(Left_Str
));
1508 Store_String_Char
(UI_To_CC
(Char_Literal_Value
(Left_Str
)));
1512 -- Now append the characters of the right operand, unless we
1513 -- optimized the "" & "..." case above.
1515 if Nkind
(Right_Str
) = N_String_Literal
then
1516 if Left_Len
/= 0 then
1517 Store_String_Chars
(Strval
(Right_Str
));
1518 Folded_Val
:= End_String
;
1521 Store_String_Char
(UI_To_CC
(Char_Literal_Value
(Right_Str
)));
1522 Folded_Val
:= End_String
;
1525 Set_Is_Static_Expression
(N
, Stat
);
1529 -- If left operand is the empty string, the result is the
1530 -- right operand, including its bounds if anomalous.
1533 and then Is_Array_Type
(Etype
(Right
))
1534 and then Etype
(Right
) /= Any_String
1536 Set_Etype
(N
, Etype
(Right
));
1539 Fold_Str
(N
, Folded_Val
, Static
=> True);
1542 end Eval_Concatenation
;
1544 ---------------------------------
1545 -- Eval_Conditional_Expression --
1546 ---------------------------------
1548 -- This GNAT internal construct can never be statically folded, so the
1549 -- only required processing is to do the check for non-static context
1550 -- for the two expression operands.
1552 procedure Eval_Conditional_Expression
(N
: Node_Id
) is
1553 Condition
: constant Node_Id
:= First
(Expressions
(N
));
1554 Then_Expr
: constant Node_Id
:= Next
(Condition
);
1555 Else_Expr
: constant Node_Id
:= Next
(Then_Expr
);
1558 Check_Non_Static_Context
(Then_Expr
);
1559 Check_Non_Static_Context
(Else_Expr
);
1560 end Eval_Conditional_Expression
;
1562 ----------------------
1563 -- Eval_Entity_Name --
1564 ----------------------
1566 -- This procedure is used for identifiers and expanded names other than
1567 -- named numbers (see Eval_Named_Integer, Eval_Named_Real. These are
1568 -- static if they denote a static constant (RM 4.9(6)) or if the name
1569 -- denotes an enumeration literal (RM 4.9(22)).
1571 procedure Eval_Entity_Name
(N
: Node_Id
) is
1572 Def_Id
: constant Entity_Id
:= Entity
(N
);
1576 -- Enumeration literals are always considered to be constants
1577 -- and cannot raise constraint error (RM 4.9(22)).
1579 if Ekind
(Def_Id
) = E_Enumeration_Literal
then
1580 Set_Is_Static_Expression
(N
);
1583 -- A name is static if it denotes a static constant (RM 4.9(5)), and
1584 -- we also copy Raise_Constraint_Error. Notice that even if non-static,
1585 -- it does not violate 10.2.1(8) here, since this is not a variable.
1587 elsif Ekind
(Def_Id
) = E_Constant
then
1589 -- Deferred constants must always be treated as nonstatic
1590 -- outside the scope of their full view.
1592 if Present
(Full_View
(Def_Id
))
1593 and then not In_Open_Scopes
(Scope
(Def_Id
))
1597 Val
:= Constant_Value
(Def_Id
);
1600 if Present
(Val
) then
1601 Set_Is_Static_Expression
1602 (N
, Is_Static_Expression
(Val
)
1603 and then Is_Static_Subtype
(Etype
(Def_Id
)));
1604 Set_Raises_Constraint_Error
(N
, Raises_Constraint_Error
(Val
));
1606 if not Is_Static_Expression
(N
)
1607 and then not Is_Generic_Type
(Etype
(N
))
1609 Validate_Static_Object_Name
(N
);
1616 -- Fall through if the name is not static
1618 Validate_Static_Object_Name
(N
);
1619 end Eval_Entity_Name
;
1621 ----------------------------
1622 -- Eval_Indexed_Component --
1623 ----------------------------
1625 -- Indexed components are never static, so we need to perform the check
1626 -- for non-static context on the index values. Then, we check if the
1627 -- value can be obtained at compile time, even though it is non-static.
1629 procedure Eval_Indexed_Component
(N
: Node_Id
) is
1633 -- Check for non-static context on index values
1635 Expr
:= First
(Expressions
(N
));
1636 while Present
(Expr
) loop
1637 Check_Non_Static_Context
(Expr
);
1641 -- If the indexed component appears in an object renaming declaration
1642 -- then we do not want to try to evaluate it, since in this case we
1643 -- need the identity of the array element.
1645 if Nkind
(Parent
(N
)) = N_Object_Renaming_Declaration
then
1648 -- Similarly if the indexed component appears as the prefix of an
1649 -- attribute we don't want to evaluate it, because at least for
1650 -- some cases of attributes we need the identify (e.g. Access, Size)
1652 elsif Nkind
(Parent
(N
)) = N_Attribute_Reference
then
1656 -- Note: there are other cases, such as the left side of an assignment,
1657 -- or an OUT parameter for a call, where the replacement results in the
1658 -- illegal use of a constant, But these cases are illegal in the first
1659 -- place, so the replacement, though silly, is harmless.
1661 -- Now see if this is a constant array reference
1663 if List_Length
(Expressions
(N
)) = 1
1664 and then Is_Entity_Name
(Prefix
(N
))
1665 and then Ekind
(Entity
(Prefix
(N
))) = E_Constant
1666 and then Present
(Constant_Value
(Entity
(Prefix
(N
))))
1669 Loc
: constant Source_Ptr
:= Sloc
(N
);
1670 Arr
: constant Node_Id
:= Constant_Value
(Entity
(Prefix
(N
)));
1671 Sub
: constant Node_Id
:= First
(Expressions
(N
));
1677 -- Linear one's origin subscript value for array reference
1680 -- Lower bound of the first array index
1683 -- Value from constant array
1686 Atyp
:= Etype
(Arr
);
1688 if Is_Access_Type
(Atyp
) then
1689 Atyp
:= Designated_Type
(Atyp
);
1692 -- If we have an array type (we should have but perhaps there
1693 -- are error cases where this is not the case), then see if we
1694 -- can do a constant evaluation of the array reference.
1696 if Is_Array_Type
(Atyp
) then
1697 if Ekind
(Atyp
) = E_String_Literal_Subtype
then
1698 Lbd
:= String_Literal_Low_Bound
(Atyp
);
1700 Lbd
:= Type_Low_Bound
(Etype
(First_Index
(Atyp
)));
1703 if Compile_Time_Known_Value
(Sub
)
1704 and then Nkind
(Arr
) = N_Aggregate
1705 and then Compile_Time_Known_Value
(Lbd
)
1706 and then Is_Discrete_Type
(Component_Type
(Atyp
))
1708 Lin
:= UI_To_Int
(Expr_Value
(Sub
) - Expr_Value
(Lbd
)) + 1;
1710 if List_Length
(Expressions
(Arr
)) >= Lin
then
1711 Elm
:= Pick
(Expressions
(Arr
), Lin
);
1713 -- If the resulting expression is compile time known,
1714 -- then we can rewrite the indexed component with this
1715 -- value, being sure to mark the result as non-static.
1716 -- We also reset the Sloc, in case this generates an
1717 -- error later on (e.g. 136'Access).
1719 if Compile_Time_Known_Value
(Elm
) then
1720 Rewrite
(N
, Duplicate_Subexpr_No_Checks
(Elm
));
1721 Set_Is_Static_Expression
(N
, False);
1729 end Eval_Indexed_Component
;
1731 --------------------------
1732 -- Eval_Integer_Literal --
1733 --------------------------
1735 -- Numeric literals are static (RM 4.9(1)), and have already been marked
1736 -- as static by the analyzer. The reason we did it that early is to allow
1737 -- the possibility of turning off the Is_Static_Expression flag after
1738 -- analysis, but before resolution, when integer literals are generated
1739 -- in the expander that do not correspond to static expressions.
1741 procedure Eval_Integer_Literal
(N
: Node_Id
) is
1742 T
: constant Entity_Id
:= Etype
(N
);
1744 function In_Any_Integer_Context
return Boolean;
1745 -- If the literal is resolved with a specific type in a context
1746 -- where the expected type is Any_Integer, there are no range checks
1747 -- on the literal. By the time the literal is evaluated, it carries
1748 -- the type imposed by the enclosing expression, and we must recover
1749 -- the context to determine that Any_Integer is meant.
1751 ----------------------------
1752 -- To_Any_Integer_Context --
1753 ----------------------------
1755 function In_Any_Integer_Context
return Boolean is
1756 Par
: constant Node_Id
:= Parent
(N
);
1757 K
: constant Node_Kind
:= Nkind
(Par
);
1760 -- Any_Integer also appears in digits specifications for real types,
1761 -- but those have bounds smaller that those of any integer base
1762 -- type, so we can safely ignore these cases.
1764 return K
= N_Number_Declaration
1765 or else K
= N_Attribute_Reference
1766 or else K
= N_Attribute_Definition_Clause
1767 or else K
= N_Modular_Type_Definition
1768 or else K
= N_Signed_Integer_Type_Definition
;
1769 end In_Any_Integer_Context
;
1771 -- Start of processing for Eval_Integer_Literal
1775 -- If the literal appears in a non-expression context, then it is
1776 -- certainly appearing in a non-static context, so check it. This
1777 -- is actually a redundant check, since Check_Non_Static_Context
1778 -- would check it, but it seems worth while avoiding the call.
1780 if Nkind
(Parent
(N
)) not in N_Subexpr
1781 and then not In_Any_Integer_Context
1783 Check_Non_Static_Context
(N
);
1786 -- Modular integer literals must be in their base range
1788 if Is_Modular_Integer_Type
(T
)
1789 and then Is_Out_Of_Range
(N
, Base_Type
(T
))
1793 end Eval_Integer_Literal
;
1795 ---------------------
1796 -- Eval_Logical_Op --
1797 ---------------------
1799 -- Logical operations are static functions, so the result is potentially
1800 -- static if both operands are potentially static (RM 4.9(7), 4.9(20)).
1802 procedure Eval_Logical_Op
(N
: Node_Id
) is
1803 Left
: constant Node_Id
:= Left_Opnd
(N
);
1804 Right
: constant Node_Id
:= Right_Opnd
(N
);
1809 -- If not foldable we are done
1811 Test_Expression_Is_Foldable
(N
, Left
, Right
, Stat
, Fold
);
1817 -- Compile time evaluation of logical operation
1820 Left_Int
: constant Uint
:= Expr_Value
(Left
);
1821 Right_Int
: constant Uint
:= Expr_Value
(Right
);
1824 if Is_Modular_Integer_Type
(Etype
(N
)) then
1826 Left_Bits
: Bits
(0 .. UI_To_Int
(Esize
(Etype
(N
))) - 1);
1827 Right_Bits
: Bits
(0 .. UI_To_Int
(Esize
(Etype
(N
))) - 1);
1830 To_Bits
(Left_Int
, Left_Bits
);
1831 To_Bits
(Right_Int
, Right_Bits
);
1833 -- Note: should really be able to use array ops instead of
1834 -- these loops, but they weren't working at the time ???
1836 if Nkind
(N
) = N_Op_And
then
1837 for J
in Left_Bits
'Range loop
1838 Left_Bits
(J
) := Left_Bits
(J
) and Right_Bits
(J
);
1841 elsif Nkind
(N
) = N_Op_Or
then
1842 for J
in Left_Bits
'Range loop
1843 Left_Bits
(J
) := Left_Bits
(J
) or Right_Bits
(J
);
1847 pragma Assert
(Nkind
(N
) = N_Op_Xor
);
1849 for J
in Left_Bits
'Range loop
1850 Left_Bits
(J
) := Left_Bits
(J
) xor Right_Bits
(J
);
1854 Fold_Uint
(N
, From_Bits
(Left_Bits
, Etype
(N
)), Stat
);
1858 pragma Assert
(Is_Boolean_Type
(Etype
(N
)));
1860 if Nkind
(N
) = N_Op_And
then
1862 Test
(Is_True
(Left_Int
) and then Is_True
(Right_Int
)), Stat
);
1864 elsif Nkind
(N
) = N_Op_Or
then
1866 Test
(Is_True
(Left_Int
) or else Is_True
(Right_Int
)), Stat
);
1869 pragma Assert
(Nkind
(N
) = N_Op_Xor
);
1871 Test
(Is_True
(Left_Int
) xor Is_True
(Right_Int
)), Stat
);
1875 end Eval_Logical_Op
;
1877 ------------------------
1878 -- Eval_Membership_Op --
1879 ------------------------
1881 -- A membership test is potentially static if the expression is static,
1882 -- and the range is a potentially static range, or is a subtype mark
1883 -- denoting a static subtype (RM 4.9(12)).
1885 procedure Eval_Membership_Op
(N
: Node_Id
) is
1886 Left
: constant Node_Id
:= Left_Opnd
(N
);
1887 Right
: constant Node_Id
:= Right_Opnd
(N
);
1896 -- Ignore if error in either operand, except to make sure that
1897 -- Any_Type is properly propagated to avoid junk cascaded errors.
1899 if Etype
(Left
) = Any_Type
1900 or else Etype
(Right
) = Any_Type
1902 Set_Etype
(N
, Any_Type
);
1906 -- Case of right operand is a subtype name
1908 if Is_Entity_Name
(Right
) then
1909 Def_Id
:= Entity
(Right
);
1911 if (Is_Scalar_Type
(Def_Id
) or else Is_String_Type
(Def_Id
))
1912 and then Is_OK_Static_Subtype
(Def_Id
)
1914 Test_Expression_Is_Foldable
(N
, Left
, Stat
, Fold
);
1916 if not Fold
or else not Stat
then
1920 Check_Non_Static_Context
(Left
);
1924 -- For string membership tests we will check the length
1927 if not Is_String_Type
(Def_Id
) then
1928 Lo
:= Type_Low_Bound
(Def_Id
);
1929 Hi
:= Type_High_Bound
(Def_Id
);
1936 -- Case of right operand is a range
1939 if Is_Static_Range
(Right
) then
1940 Test_Expression_Is_Foldable
(N
, Left
, Stat
, Fold
);
1942 if not Fold
or else not Stat
then
1945 -- If one bound of range raises CE, then don't try to fold
1947 elsif not Is_OK_Static_Range
(Right
) then
1948 Check_Non_Static_Context
(Left
);
1953 Check_Non_Static_Context
(Left
);
1957 -- Here we know range is an OK static range
1959 Lo
:= Low_Bound
(Right
);
1960 Hi
:= High_Bound
(Right
);
1963 -- For strings we check that the length of the string expression is
1964 -- compatible with the string subtype if the subtype is constrained,
1965 -- or if unconstrained then the test is always true.
1967 if Is_String_Type
(Etype
(Right
)) then
1968 if not Is_Constrained
(Etype
(Right
)) then
1973 Typlen
: constant Uint
:= String_Type_Len
(Etype
(Right
));
1974 Strlen
: constant Uint
:=
1975 UI_From_Int
(String_Length
(Strval
(Get_String_Val
(Left
))));
1977 Result
:= (Typlen
= Strlen
);
1981 -- Fold the membership test. We know we have a static range and Lo
1982 -- and Hi are set to the expressions for the end points of this range.
1984 elsif Is_Real_Type
(Etype
(Right
)) then
1986 Leftval
: constant Ureal
:= Expr_Value_R
(Left
);
1989 Result
:= Expr_Value_R
(Lo
) <= Leftval
1990 and then Leftval
<= Expr_Value_R
(Hi
);
1995 Leftval
: constant Uint
:= Expr_Value
(Left
);
1998 Result
:= Expr_Value
(Lo
) <= Leftval
1999 and then Leftval
<= Expr_Value
(Hi
);
2003 if Nkind
(N
) = N_Not_In
then
2004 Result
:= not Result
;
2007 Fold_Uint
(N
, Test
(Result
), True);
2008 Warn_On_Known_Condition
(N
);
2009 end Eval_Membership_Op
;
2011 ------------------------
2012 -- Eval_Named_Integer --
2013 ------------------------
2015 procedure Eval_Named_Integer
(N
: Node_Id
) is
2018 Expr_Value
(Expression
(Declaration_Node
(Entity
(N
)))), True);
2019 end Eval_Named_Integer
;
2021 ---------------------
2022 -- Eval_Named_Real --
2023 ---------------------
2025 procedure Eval_Named_Real
(N
: Node_Id
) is
2028 Expr_Value_R
(Expression
(Declaration_Node
(Entity
(N
)))), True);
2029 end Eval_Named_Real
;
2035 -- Exponentiation is a static functions, so the result is potentially
2036 -- static if both operands are potentially static (RM 4.9(7), 4.9(20)).
2038 procedure Eval_Op_Expon
(N
: Node_Id
) is
2039 Left
: constant Node_Id
:= Left_Opnd
(N
);
2040 Right
: constant Node_Id
:= Right_Opnd
(N
);
2045 -- If not foldable we are done
2047 Test_Expression_Is_Foldable
(N
, Left
, Right
, Stat
, Fold
);
2053 -- Fold exponentiation operation
2056 Right_Int
: constant Uint
:= Expr_Value
(Right
);
2061 if Is_Integer_Type
(Etype
(Left
)) then
2063 Left_Int
: constant Uint
:= Expr_Value
(Left
);
2067 -- Exponentiation of an integer raises the exception
2068 -- Constraint_Error for a negative exponent (RM 4.5.6)
2070 if Right_Int
< 0 then
2071 Apply_Compile_Time_Constraint_Error
2072 (N
, "integer exponent negative",
2073 CE_Range_Check_Failed
,
2078 if OK_Bits
(N
, Num_Bits
(Left_Int
) * Right_Int
) then
2079 Result
:= Left_Int
** Right_Int
;
2084 if Is_Modular_Integer_Type
(Etype
(N
)) then
2085 Result
:= Result
mod Modulus
(Etype
(N
));
2088 Fold_Uint
(N
, Result
, Stat
);
2096 Left_Real
: constant Ureal
:= Expr_Value_R
(Left
);
2099 -- Cannot have a zero base with a negative exponent
2101 if UR_Is_Zero
(Left_Real
) then
2103 if Right_Int
< 0 then
2104 Apply_Compile_Time_Constraint_Error
2105 (N
, "zero ** negative integer",
2106 CE_Range_Check_Failed
,
2110 Fold_Ureal
(N
, Ureal_0
, Stat
);
2114 Fold_Ureal
(N
, Left_Real
** Right_Int
, Stat
);
2125 -- The not operation is a static functions, so the result is potentially
2126 -- static if the operand is potentially static (RM 4.9(7), 4.9(20)).
2128 procedure Eval_Op_Not
(N
: Node_Id
) is
2129 Right
: constant Node_Id
:= Right_Opnd
(N
);
2134 -- If not foldable we are done
2136 Test_Expression_Is_Foldable
(N
, Right
, Stat
, Fold
);
2142 -- Fold not operation
2145 Rint
: constant Uint
:= Expr_Value
(Right
);
2146 Typ
: constant Entity_Id
:= Etype
(N
);
2149 -- Negation is equivalent to subtracting from the modulus minus
2150 -- one. For a binary modulus this is equivalent to the ones-
2151 -- component of the original value. For non-binary modulus this
2152 -- is an arbitrary but consistent definition.
2154 if Is_Modular_Integer_Type
(Typ
) then
2155 Fold_Uint
(N
, Modulus
(Typ
) - 1 - Rint
, Stat
);
2158 pragma Assert
(Is_Boolean_Type
(Typ
));
2159 Fold_Uint
(N
, Test
(not Is_True
(Rint
)), Stat
);
2162 Set_Is_Static_Expression
(N
, Stat
);
2166 -------------------------------
2167 -- Eval_Qualified_Expression --
2168 -------------------------------
2170 -- A qualified expression is potentially static if its subtype mark denotes
2171 -- a static subtype and its expression is potentially static (RM 4.9 (11)).
2173 procedure Eval_Qualified_Expression
(N
: Node_Id
) is
2174 Operand
: constant Node_Id
:= Expression
(N
);
2175 Target_Type
: constant Entity_Id
:= Entity
(Subtype_Mark
(N
));
2182 -- Can only fold if target is string or scalar and subtype is static
2183 -- Also, do not fold if our parent is an allocator (this is because
2184 -- the qualified expression is really part of the syntactic structure
2185 -- of an allocator, and we do not want to end up with something that
2186 -- corresponds to "new 1" where the 1 is the result of folding a
2187 -- qualified expression).
2189 if not Is_Static_Subtype
(Target_Type
)
2190 or else Nkind
(Parent
(N
)) = N_Allocator
2192 Check_Non_Static_Context
(Operand
);
2194 -- If operand is known to raise constraint_error, set the
2195 -- flag on the expression so it does not get optimized away.
2197 if Nkind
(Operand
) = N_Raise_Constraint_Error
then
2198 Set_Raises_Constraint_Error
(N
);
2204 -- If not foldable we are done
2206 Test_Expression_Is_Foldable
(N
, Operand
, Stat
, Fold
);
2211 -- Don't try fold if target type has constraint error bounds
2213 elsif not Is_OK_Static_Subtype
(Target_Type
) then
2214 Set_Raises_Constraint_Error
(N
);
2218 -- Here we will fold, save Print_In_Hex indication
2220 Hex
:= Nkind
(Operand
) = N_Integer_Literal
2221 and then Print_In_Hex
(Operand
);
2223 -- Fold the result of qualification
2225 if Is_Discrete_Type
(Target_Type
) then
2226 Fold_Uint
(N
, Expr_Value
(Operand
), Stat
);
2228 -- Preserve Print_In_Hex indication
2230 if Hex
and then Nkind
(N
) = N_Integer_Literal
then
2231 Set_Print_In_Hex
(N
);
2234 elsif Is_Real_Type
(Target_Type
) then
2235 Fold_Ureal
(N
, Expr_Value_R
(Operand
), Stat
);
2238 Fold_Str
(N
, Strval
(Get_String_Val
(Operand
)), Stat
);
2241 Set_Is_Static_Expression
(N
, False);
2243 Check_String_Literal_Length
(N
, Target_Type
);
2249 -- The expression may be foldable but not static
2251 Set_Is_Static_Expression
(N
, Stat
);
2253 if Is_Out_Of_Range
(N
, Etype
(N
)) then
2256 end Eval_Qualified_Expression
;
2258 -----------------------
2259 -- Eval_Real_Literal --
2260 -----------------------
2262 -- Numeric literals are static (RM 4.9(1)), and have already been marked
2263 -- as static by the analyzer. The reason we did it that early is to allow
2264 -- the possibility of turning off the Is_Static_Expression flag after
2265 -- analysis, but before resolution, when integer literals are generated
2266 -- in the expander that do not correspond to static expressions.
2268 procedure Eval_Real_Literal
(N
: Node_Id
) is
2269 PK
: constant Node_Kind
:= Nkind
(Parent
(N
));
2272 -- If the literal appears in a non-expression context
2273 -- and not as part of a number declaration, then it is
2274 -- appearing in a non-static context, so check it.
2276 if PK
not in N_Subexpr
and then PK
/= N_Number_Declaration
then
2277 Check_Non_Static_Context
(N
);
2279 end Eval_Real_Literal
;
2281 ------------------------
2282 -- Eval_Relational_Op --
2283 ------------------------
2285 -- Relational operations are static functions, so the result is static
2286 -- if both operands are static (RM 4.9(7), 4.9(20)).
2288 procedure Eval_Relational_Op
(N
: Node_Id
) is
2289 Left
: constant Node_Id
:= Left_Opnd
(N
);
2290 Right
: constant Node_Id
:= Right_Opnd
(N
);
2291 Typ
: constant Entity_Id
:= Etype
(Left
);
2297 -- One special case to deal with first. If we can tell that the result
2298 -- will be false because the lengths of one or more index subtypes are
2299 -- compile time known and different, then we can replace the entire
2300 -- result by False. We only do this for one dimensional arrays, because
2301 -- the case of multi-dimensional arrays is rare and too much trouble! If
2302 -- one of the operands is an illegal aggregate, its type might still be
2303 -- an arbitrary composite type, so nothing to do.
2305 if Is_Array_Type
(Typ
)
2306 and then Typ
/= Any_Composite
2307 and then Number_Dimensions
(Typ
) = 1
2308 and then (Nkind
(N
) = N_Op_Eq
or else Nkind
(N
) = N_Op_Ne
)
2310 if Raises_Constraint_Error
(Left
)
2311 or else Raises_Constraint_Error
(Right
)
2316 -- OK, we have the case where we may be able to do this fold
2318 Length_Mismatch
: declare
2319 procedure Get_Static_Length
(Op
: Node_Id
; Len
: out Uint
);
2320 -- If Op is an expression for a constrained array with a known
2321 -- at compile time length, then Len is set to this (non-negative
2322 -- length). Otherwise Len is set to minus 1.
2324 -----------------------
2325 -- Get_Static_Length --
2326 -----------------------
2328 procedure Get_Static_Length
(Op
: Node_Id
; Len
: out Uint
) is
2332 -- First easy case string literal
2334 if Nkind
(Op
) = N_String_Literal
then
2335 Len
:= UI_From_Int
(String_Length
(Strval
(Op
)));
2339 -- Second easy case, not constrained subtype, so no length
2341 if not Is_Constrained
(Etype
(Op
)) then
2342 Len
:= Uint_Minus_1
;
2348 T
:= Etype
(First_Index
(Etype
(Op
)));
2350 -- The simple case, both bounds are known at compile time
2352 if Is_Discrete_Type
(T
)
2354 Compile_Time_Known_Value
(Type_Low_Bound
(T
))
2356 Compile_Time_Known_Value
(Type_High_Bound
(T
))
2358 Len
:= UI_Max
(Uint_0
,
2359 Expr_Value
(Type_High_Bound
(T
)) -
2360 Expr_Value
(Type_Low_Bound
(T
)) + 1);
2364 -- A more complex case, where the bounds are of the form
2365 -- X [+/- K1] .. X [+/- K2]), where X is an expression that is
2366 -- either A'First or A'Last (with A an entity name), or X is an
2367 -- entity name, and the two X's are the same and K1 and K2 are
2368 -- known at compile time, in this case, the length can also be
2369 -- computed at compile time, even though the bounds are not
2370 -- known. A common case of this is e.g. (X'First..X'First+5).
2372 Extract_Length
: declare
2373 procedure Decompose_Expr
2375 Ent
: out Entity_Id
;
2376 Kind
: out Character;
2378 -- Given an expression, see if is of the form above,
2379 -- X [+/- K]. If so Ent is set to the entity in X,
2380 -- Kind is 'F','L','E' for 'First/'Last/simple entity,
2381 -- and Cons is the value of K. If the expression is
2382 -- not of the required form, Ent is set to Empty.
2384 --------------------
2385 -- Decompose_Expr --
2386 --------------------
2388 procedure Decompose_Expr
2390 Ent
: out Entity_Id
;
2391 Kind
: out Character;
2397 if Nkind
(Expr
) = N_Op_Add
2398 and then Compile_Time_Known_Value
(Right_Opnd
(Expr
))
2400 Exp
:= Left_Opnd
(Expr
);
2401 Cons
:= Expr_Value
(Right_Opnd
(Expr
));
2403 elsif Nkind
(Expr
) = N_Op_Subtract
2404 and then Compile_Time_Known_Value
(Right_Opnd
(Expr
))
2406 Exp
:= Left_Opnd
(Expr
);
2407 Cons
:= -Expr_Value
(Right_Opnd
(Expr
));
2414 -- At this stage Exp is set to the potential X
2416 if Nkind
(Exp
) = N_Attribute_Reference
then
2417 if Attribute_Name
(Exp
) = Name_First
then
2419 elsif Attribute_Name
(Exp
) = Name_Last
then
2426 Exp
:= Prefix
(Exp
);
2432 if Is_Entity_Name
(Exp
)
2433 and then Present
(Entity
(Exp
))
2435 Ent
:= Entity
(Exp
);
2443 Ent1
, Ent2
: Entity_Id
;
2444 Kind1
, Kind2
: Character;
2445 Cons1
, Cons2
: Uint
;
2447 -- Start of processing for Extract_Length
2450 Decompose_Expr
(Type_Low_Bound
(T
), Ent1
, Kind1
, Cons1
);
2451 Decompose_Expr
(Type_High_Bound
(T
), Ent2
, Kind2
, Cons2
);
2454 and then Kind1
= Kind2
2455 and then Ent1
= Ent2
2457 Len
:= Cons2
- Cons1
+ 1;
2459 Len
:= Uint_Minus_1
;
2462 end Get_Static_Length
;
2469 -- Start of processing for Length_Mismatch
2472 Get_Static_Length
(Left
, Len_L
);
2473 Get_Static_Length
(Right
, Len_R
);
2475 if Len_L
/= Uint_Minus_1
2476 and then Len_R
/= Uint_Minus_1
2477 and then Len_L
/= Len_R
2479 Fold_Uint
(N
, Test
(Nkind
(N
) = N_Op_Ne
), False);
2480 Warn_On_Known_Condition
(N
);
2483 end Length_Mismatch
;
2486 -- Another special case: comparisons of access types, where one or both
2487 -- operands are known to be null, so the result can be determined.
2489 if Is_Access_Type
(Typ
) then
2490 if Known_Null
(Left
) then
2491 if Known_Null
(Right
) then
2492 Fold_Uint
(N
, Test
(Nkind
(N
) = N_Op_Eq
), False);
2493 Warn_On_Known_Condition
(N
);
2496 elsif Known_Non_Null
(Right
) then
2497 Fold_Uint
(N
, Test
(Nkind
(N
) = N_Op_Ne
), False);
2498 Warn_On_Known_Condition
(N
);
2502 elsif Known_Non_Null
(Left
) then
2503 if Known_Null
(Right
) then
2504 Fold_Uint
(N
, Test
(Nkind
(N
) = N_Op_Ne
), False);
2505 Warn_On_Known_Condition
(N
);
2511 -- Can only fold if type is scalar (don't fold string ops)
2513 if not Is_Scalar_Type
(Typ
) then
2514 Check_Non_Static_Context
(Left
);
2515 Check_Non_Static_Context
(Right
);
2519 -- If not foldable we are done
2521 Test_Expression_Is_Foldable
(N
, Left
, Right
, Stat
, Fold
);
2527 -- Integer and Enumeration (discrete) type cases
2529 if Is_Discrete_Type
(Typ
) then
2531 Left_Int
: constant Uint
:= Expr_Value
(Left
);
2532 Right_Int
: constant Uint
:= Expr_Value
(Right
);
2536 when N_Op_Eq
=> Result
:= Left_Int
= Right_Int
;
2537 when N_Op_Ne
=> Result
:= Left_Int
/= Right_Int
;
2538 when N_Op_Lt
=> Result
:= Left_Int
< Right_Int
;
2539 when N_Op_Le
=> Result
:= Left_Int
<= Right_Int
;
2540 when N_Op_Gt
=> Result
:= Left_Int
> Right_Int
;
2541 when N_Op_Ge
=> Result
:= Left_Int
>= Right_Int
;
2544 raise Program_Error
;
2547 Fold_Uint
(N
, Test
(Result
), Stat
);
2553 pragma Assert
(Is_Real_Type
(Typ
));
2556 Left_Real
: constant Ureal
:= Expr_Value_R
(Left
);
2557 Right_Real
: constant Ureal
:= Expr_Value_R
(Right
);
2561 when N_Op_Eq
=> Result
:= (Left_Real
= Right_Real
);
2562 when N_Op_Ne
=> Result
:= (Left_Real
/= Right_Real
);
2563 when N_Op_Lt
=> Result
:= (Left_Real
< Right_Real
);
2564 when N_Op_Le
=> Result
:= (Left_Real
<= Right_Real
);
2565 when N_Op_Gt
=> Result
:= (Left_Real
> Right_Real
);
2566 when N_Op_Ge
=> Result
:= (Left_Real
>= Right_Real
);
2569 raise Program_Error
;
2572 Fold_Uint
(N
, Test
(Result
), Stat
);
2576 Warn_On_Known_Condition
(N
);
2577 end Eval_Relational_Op
;
2583 -- Shift operations are intrinsic operations that can never be static,
2584 -- so the only processing required is to perform the required check for
2585 -- a non static context for the two operands.
2587 -- Actually we could do some compile time evaluation here some time ???
2589 procedure Eval_Shift
(N
: Node_Id
) is
2591 Check_Non_Static_Context
(Left_Opnd
(N
));
2592 Check_Non_Static_Context
(Right_Opnd
(N
));
2595 ------------------------
2596 -- Eval_Short_Circuit --
2597 ------------------------
2599 -- A short circuit operation is potentially static if both operands
2600 -- are potentially static (RM 4.9 (13))
2602 procedure Eval_Short_Circuit
(N
: Node_Id
) is
2603 Kind
: constant Node_Kind
:= Nkind
(N
);
2604 Left
: constant Node_Id
:= Left_Opnd
(N
);
2605 Right
: constant Node_Id
:= Right_Opnd
(N
);
2607 Rstat
: constant Boolean :=
2608 Is_Static_Expression
(Left
)
2609 and then Is_Static_Expression
(Right
);
2612 -- Short circuit operations are never static in Ada 83
2614 if Ada_Version
= Ada_83
2615 and then Comes_From_Source
(N
)
2617 Check_Non_Static_Context
(Left
);
2618 Check_Non_Static_Context
(Right
);
2622 -- Now look at the operands, we can't quite use the normal call to
2623 -- Test_Expression_Is_Foldable here because short circuit operations
2624 -- are a special case, they can still be foldable, even if the right
2625 -- operand raises constraint error.
2627 -- If either operand is Any_Type, just propagate to result and
2628 -- do not try to fold, this prevents cascaded errors.
2630 if Etype
(Left
) = Any_Type
or else Etype
(Right
) = Any_Type
then
2631 Set_Etype
(N
, Any_Type
);
2634 -- If left operand raises constraint error, then replace node N with
2635 -- the raise constraint error node, and we are obviously not foldable.
2636 -- Is_Static_Expression is set from the two operands in the normal way,
2637 -- and we check the right operand if it is in a non-static context.
2639 elsif Raises_Constraint_Error
(Left
) then
2641 Check_Non_Static_Context
(Right
);
2644 Rewrite_In_Raise_CE
(N
, Left
);
2645 Set_Is_Static_Expression
(N
, Rstat
);
2648 -- If the result is not static, then we won't in any case fold
2650 elsif not Rstat
then
2651 Check_Non_Static_Context
(Left
);
2652 Check_Non_Static_Context
(Right
);
2656 -- Here the result is static, note that, unlike the normal processing
2657 -- in Test_Expression_Is_Foldable, we did *not* check above to see if
2658 -- the right operand raises constraint error, that's because it is not
2659 -- significant if the left operand is decisive.
2661 Set_Is_Static_Expression
(N
);
2663 -- It does not matter if the right operand raises constraint error if
2664 -- it will not be evaluated. So deal specially with the cases where
2665 -- the right operand is not evaluated. Note that we will fold these
2666 -- cases even if the right operand is non-static, which is fine, but
2667 -- of course in these cases the result is not potentially static.
2669 Left_Int
:= Expr_Value
(Left
);
2671 if (Kind
= N_And_Then
and then Is_False
(Left_Int
))
2672 or else (Kind
= N_Or_Else
and Is_True
(Left_Int
))
2674 Fold_Uint
(N
, Left_Int
, Rstat
);
2678 -- If first operand not decisive, then it does matter if the right
2679 -- operand raises constraint error, since it will be evaluated, so
2680 -- we simply replace the node with the right operand. Note that this
2681 -- properly propagates Is_Static_Expression and Raises_Constraint_Error
2682 -- (both are set to True in Right).
2684 if Raises_Constraint_Error
(Right
) then
2685 Rewrite_In_Raise_CE
(N
, Right
);
2686 Check_Non_Static_Context
(Left
);
2690 -- Otherwise the result depends on the right operand
2692 Fold_Uint
(N
, Expr_Value
(Right
), Rstat
);
2694 end Eval_Short_Circuit
;
2700 -- Slices can never be static, so the only processing required is to
2701 -- check for non-static context if an explicit range is given.
2703 procedure Eval_Slice
(N
: Node_Id
) is
2704 Drange
: constant Node_Id
:= Discrete_Range
(N
);
2706 if Nkind
(Drange
) = N_Range
then
2707 Check_Non_Static_Context
(Low_Bound
(Drange
));
2708 Check_Non_Static_Context
(High_Bound
(Drange
));
2711 -- A slice of the form A (subtype), when the subtype is the index of
2712 -- the type of A, is redundant, the slice can be replaced with A, and
2713 -- this is worth a warning.
2715 if Is_Entity_Name
(Prefix
(N
)) then
2717 E
: constant Entity_Id
:= Entity
(Prefix
(N
));
2718 T
: constant Entity_Id
:= Etype
(E
);
2720 if Ekind
(E
) = E_Constant
2721 and then Is_Array_Type
(T
)
2722 and then Is_Entity_Name
(Drange
)
2724 if Is_Entity_Name
(Original_Node
(First_Index
(T
)))
2725 and then Entity
(Original_Node
(First_Index
(T
)))
2728 if Warn_On_Redundant_Constructs
then
2729 Error_Msg_N
("redundant slice denotes whole array?", N
);
2732 -- The following might be a useful optimization ????
2734 -- Rewrite (N, New_Occurrence_Of (E, Sloc (N)));
2741 -------------------------
2742 -- Eval_String_Literal --
2743 -------------------------
2745 procedure Eval_String_Literal
(N
: Node_Id
) is
2746 Typ
: constant Entity_Id
:= Etype
(N
);
2747 Bas
: constant Entity_Id
:= Base_Type
(Typ
);
2753 -- Nothing to do if error type (handles cases like default expressions
2754 -- or generics where we have not yet fully resolved the type)
2756 if Bas
= Any_Type
or else Bas
= Any_String
then
2760 -- String literals are static if the subtype is static (RM 4.9(2)), so
2761 -- reset the static expression flag (it was set unconditionally in
2762 -- Analyze_String_Literal) if the subtype is non-static. We tell if
2763 -- the subtype is static by looking at the lower bound.
2765 if Ekind
(Typ
) = E_String_Literal_Subtype
then
2766 if not Is_OK_Static_Expression
(String_Literal_Low_Bound
(Typ
)) then
2767 Set_Is_Static_Expression
(N
, False);
2771 -- Here if Etype of string literal is normal Etype (not yet possible,
2772 -- but may be possible in future!)
2774 elsif not Is_OK_Static_Expression
2775 (Type_Low_Bound
(Etype
(First_Index
(Typ
))))
2777 Set_Is_Static_Expression
(N
, False);
2781 -- If original node was a type conversion, then result if non-static
2783 if Nkind
(Original_Node
(N
)) = N_Type_Conversion
then
2784 Set_Is_Static_Expression
(N
, False);
2788 -- Test for illegal Ada 95 cases. A string literal is illegal in
2789 -- Ada 95 if its bounds are outside the index base type and this
2790 -- index type is static. This can happen in only two ways. Either
2791 -- the string literal is too long, or it is null, and the lower
2792 -- bound is type'First. In either case it is the upper bound that
2793 -- is out of range of the index type.
2795 if Ada_Version
>= Ada_95
then
2796 if Root_Type
(Bas
) = Standard_String
2798 Root_Type
(Bas
) = Standard_Wide_String
2800 Xtp
:= Standard_Positive
;
2802 Xtp
:= Etype
(First_Index
(Bas
));
2805 if Ekind
(Typ
) = E_String_Literal_Subtype
then
2806 Lo
:= String_Literal_Low_Bound
(Typ
);
2808 Lo
:= Type_Low_Bound
(Etype
(First_Index
(Typ
)));
2811 Len
:= String_Length
(Strval
(N
));
2813 if UI_From_Int
(Len
) > String_Type_Len
(Bas
) then
2814 Apply_Compile_Time_Constraint_Error
2815 (N
, "string literal too long for}", CE_Length_Check_Failed
,
2817 Typ
=> First_Subtype
(Bas
));
2820 and then not Is_Generic_Type
(Xtp
)
2822 Expr_Value
(Lo
) = Expr_Value
(Type_Low_Bound
(Base_Type
(Xtp
)))
2824 Apply_Compile_Time_Constraint_Error
2825 (N
, "null string literal not allowed for}",
2826 CE_Length_Check_Failed
,
2828 Typ
=> First_Subtype
(Bas
));
2831 end Eval_String_Literal
;
2833 --------------------------
2834 -- Eval_Type_Conversion --
2835 --------------------------
2837 -- A type conversion is potentially static if its subtype mark is for a
2838 -- static scalar subtype, and its operand expression is potentially static
2841 procedure Eval_Type_Conversion
(N
: Node_Id
) is
2842 Operand
: constant Node_Id
:= Expression
(N
);
2843 Source_Type
: constant Entity_Id
:= Etype
(Operand
);
2844 Target_Type
: constant Entity_Id
:= Etype
(N
);
2849 function To_Be_Treated_As_Integer
(T
: Entity_Id
) return Boolean;
2850 -- Returns true if type T is an integer type, or if it is a
2851 -- fixed-point type to be treated as an integer (i.e. the flag
2852 -- Conversion_OK is set on the conversion node).
2854 function To_Be_Treated_As_Real
(T
: Entity_Id
) return Boolean;
2855 -- Returns true if type T is a floating-point type, or if it is a
2856 -- fixed-point type that is not to be treated as an integer (i.e. the
2857 -- flag Conversion_OK is not set on the conversion node).
2859 ------------------------------
2860 -- To_Be_Treated_As_Integer --
2861 ------------------------------
2863 function To_Be_Treated_As_Integer
(T
: Entity_Id
) return Boolean is
2867 or else (Is_Fixed_Point_Type
(T
) and then Conversion_OK
(N
));
2868 end To_Be_Treated_As_Integer
;
2870 ---------------------------
2871 -- To_Be_Treated_As_Real --
2872 ---------------------------
2874 function To_Be_Treated_As_Real
(T
: Entity_Id
) return Boolean is
2877 Is_Floating_Point_Type
(T
)
2878 or else (Is_Fixed_Point_Type
(T
) and then not Conversion_OK
(N
));
2879 end To_Be_Treated_As_Real
;
2881 -- Start of processing for Eval_Type_Conversion
2884 -- Cannot fold if target type is non-static or if semantic error
2886 if not Is_Static_Subtype
(Target_Type
) then
2887 Check_Non_Static_Context
(Operand
);
2890 elsif Error_Posted
(N
) then
2894 -- If not foldable we are done
2896 Test_Expression_Is_Foldable
(N
, Operand
, Stat
, Fold
);
2901 -- Don't try fold if target type has constraint error bounds
2903 elsif not Is_OK_Static_Subtype
(Target_Type
) then
2904 Set_Raises_Constraint_Error
(N
);
2908 -- Remaining processing depends on operand types. Note that in the
2909 -- following type test, fixed-point counts as real unless the flag
2910 -- Conversion_OK is set, in which case it counts as integer.
2912 -- Fold conversion, case of string type. The result is not static
2914 if Is_String_Type
(Target_Type
) then
2915 Fold_Str
(N
, Strval
(Get_String_Val
(Operand
)), Static
=> False);
2919 -- Fold conversion, case of integer target type
2921 elsif To_Be_Treated_As_Integer
(Target_Type
) then
2926 -- Integer to integer conversion
2928 if To_Be_Treated_As_Integer
(Source_Type
) then
2929 Result
:= Expr_Value
(Operand
);
2931 -- Real to integer conversion
2934 Result
:= UR_To_Uint
(Expr_Value_R
(Operand
));
2937 -- If fixed-point type (Conversion_OK must be set), then the
2938 -- result is logically an integer, but we must replace the
2939 -- conversion with the corresponding real literal, since the
2940 -- type from a semantic point of view is still fixed-point.
2942 if Is_Fixed_Point_Type
(Target_Type
) then
2944 (N
, UR_From_Uint
(Result
) * Small_Value
(Target_Type
), Stat
);
2946 -- Otherwise result is integer literal
2949 Fold_Uint
(N
, Result
, Stat
);
2953 -- Fold conversion, case of real target type
2955 elsif To_Be_Treated_As_Real
(Target_Type
) then
2960 if To_Be_Treated_As_Real
(Source_Type
) then
2961 Result
:= Expr_Value_R
(Operand
);
2963 Result
:= UR_From_Uint
(Expr_Value
(Operand
));
2966 Fold_Ureal
(N
, Result
, Stat
);
2969 -- Enumeration types
2972 Fold_Uint
(N
, Expr_Value
(Operand
), Stat
);
2975 if Is_Out_Of_Range
(N
, Etype
(N
)) then
2979 end Eval_Type_Conversion
;
2985 -- Predefined unary operators are static functions (RM 4.9(20)) and thus
2986 -- are potentially static if the operand is potentially static (RM 4.9(7))
2988 procedure Eval_Unary_Op
(N
: Node_Id
) is
2989 Right
: constant Node_Id
:= Right_Opnd
(N
);
2994 -- If not foldable we are done
2996 Test_Expression_Is_Foldable
(N
, Right
, Stat
, Fold
);
3002 -- Fold for integer case
3004 if Is_Integer_Type
(Etype
(N
)) then
3006 Rint
: constant Uint
:= Expr_Value
(Right
);
3010 -- In the case of modular unary plus and abs there is no need
3011 -- to adjust the result of the operation since if the original
3012 -- operand was in bounds the result will be in the bounds of the
3013 -- modular type. However, in the case of modular unary minus the
3014 -- result may go out of the bounds of the modular type and needs
3017 if Nkind
(N
) = N_Op_Plus
then
3020 elsif Nkind
(N
) = N_Op_Minus
then
3021 if Is_Modular_Integer_Type
(Etype
(N
)) then
3022 Result
:= (-Rint
) mod Modulus
(Etype
(N
));
3028 pragma Assert
(Nkind
(N
) = N_Op_Abs
);
3032 Fold_Uint
(N
, Result
, Stat
);
3035 -- Fold for real case
3037 elsif Is_Real_Type
(Etype
(N
)) then
3039 Rreal
: constant Ureal
:= Expr_Value_R
(Right
);
3043 if Nkind
(N
) = N_Op_Plus
then
3046 elsif Nkind
(N
) = N_Op_Minus
then
3047 Result
:= UR_Negate
(Rreal
);
3050 pragma Assert
(Nkind
(N
) = N_Op_Abs
);
3051 Result
:= abs Rreal
;
3054 Fold_Ureal
(N
, Result
, Stat
);
3059 -------------------------------
3060 -- Eval_Unchecked_Conversion --
3061 -------------------------------
3063 -- Unchecked conversions can never be static, so the only required
3064 -- processing is to check for a non-static context for the operand.
3066 procedure Eval_Unchecked_Conversion
(N
: Node_Id
) is
3068 Check_Non_Static_Context
(Expression
(N
));
3069 end Eval_Unchecked_Conversion
;
3071 --------------------
3072 -- Expr_Rep_Value --
3073 --------------------
3075 function Expr_Rep_Value
(N
: Node_Id
) return Uint
is
3076 Kind
: constant Node_Kind
:= Nkind
(N
);
3080 if Is_Entity_Name
(N
) then
3083 -- An enumeration literal that was either in the source or
3084 -- created as a result of static evaluation.
3086 if Ekind
(Ent
) = E_Enumeration_Literal
then
3087 return Enumeration_Rep
(Ent
);
3089 -- A user defined static constant
3092 pragma Assert
(Ekind
(Ent
) = E_Constant
);
3093 return Expr_Rep_Value
(Constant_Value
(Ent
));
3096 -- An integer literal that was either in the source or created
3097 -- as a result of static evaluation.
3099 elsif Kind
= N_Integer_Literal
then
3102 -- A real literal for a fixed-point type. This must be the fixed-point
3103 -- case, either the literal is of a fixed-point type, or it is a bound
3104 -- of a fixed-point type, with type universal real. In either case we
3105 -- obtain the desired value from Corresponding_Integer_Value.
3107 elsif Kind
= N_Real_Literal
then
3108 pragma Assert
(Is_Fixed_Point_Type
(Underlying_Type
(Etype
(N
))));
3109 return Corresponding_Integer_Value
(N
);
3111 -- Peculiar VMS case, if we have xxx'Null_Parameter, return zero
3113 elsif Kind
= N_Attribute_Reference
3114 and then Attribute_Name
(N
) = Name_Null_Parameter
3118 -- Otherwise must be character literal
3121 pragma Assert
(Kind
= N_Character_Literal
);
3124 -- Since Character literals of type Standard.Character don't
3125 -- have any defining character literals built for them, they
3126 -- do not have their Entity set, so just use their Char
3127 -- code. Otherwise for user-defined character literals use
3128 -- their Pos value as usual which is the same as the Rep value.
3131 return Char_Literal_Value
(N
);
3133 return Enumeration_Rep
(Ent
);
3142 function Expr_Value
(N
: Node_Id
) return Uint
is
3143 Kind
: constant Node_Kind
:= Nkind
(N
);
3144 CV_Ent
: CV_Entry
renames CV_Cache
(Nat
(N
) mod CV_Cache_Size
);
3149 -- If already in cache, then we know it's compile time known and we can
3150 -- return the value that was previously stored in the cache since
3151 -- compile time known values cannot change.
3153 if CV_Ent
.N
= N
then
3157 -- Otherwise proceed to test value
3159 if Is_Entity_Name
(N
) then
3162 -- An enumeration literal that was either in the source or
3163 -- created as a result of static evaluation.
3165 if Ekind
(Ent
) = E_Enumeration_Literal
then
3166 Val
:= Enumeration_Pos
(Ent
);
3168 -- A user defined static constant
3171 pragma Assert
(Ekind
(Ent
) = E_Constant
);
3172 Val
:= Expr_Value
(Constant_Value
(Ent
));
3175 -- An integer literal that was either in the source or created
3176 -- as a result of static evaluation.
3178 elsif Kind
= N_Integer_Literal
then
3181 -- A real literal for a fixed-point type. This must be the fixed-point
3182 -- case, either the literal is of a fixed-point type, or it is a bound
3183 -- of a fixed-point type, with type universal real. In either case we
3184 -- obtain the desired value from Corresponding_Integer_Value.
3186 elsif Kind
= N_Real_Literal
then
3188 pragma Assert
(Is_Fixed_Point_Type
(Underlying_Type
(Etype
(N
))));
3189 Val
:= Corresponding_Integer_Value
(N
);
3191 -- Peculiar VMS case, if we have xxx'Null_Parameter, return zero
3193 elsif Kind
= N_Attribute_Reference
3194 and then Attribute_Name
(N
) = Name_Null_Parameter
3198 -- Otherwise must be character literal
3201 pragma Assert
(Kind
= N_Character_Literal
);
3204 -- Since Character literals of type Standard.Character don't
3205 -- have any defining character literals built for them, they
3206 -- do not have their Entity set, so just use their Char
3207 -- code. Otherwise for user-defined character literals use
3208 -- their Pos value as usual.
3211 Val
:= Char_Literal_Value
(N
);
3213 Val
:= Enumeration_Pos
(Ent
);
3217 -- Come here with Val set to value to be returned, set cache
3228 function Expr_Value_E
(N
: Node_Id
) return Entity_Id
is
3229 Ent
: constant Entity_Id
:= Entity
(N
);
3232 if Ekind
(Ent
) = E_Enumeration_Literal
then
3235 pragma Assert
(Ekind
(Ent
) = E_Constant
);
3236 return Expr_Value_E
(Constant_Value
(Ent
));
3244 function Expr_Value_R
(N
: Node_Id
) return Ureal
is
3245 Kind
: constant Node_Kind
:= Nkind
(N
);
3250 if Kind
= N_Real_Literal
then
3253 elsif Kind
= N_Identifier
or else Kind
= N_Expanded_Name
then
3255 pragma Assert
(Ekind
(Ent
) = E_Constant
);
3256 return Expr_Value_R
(Constant_Value
(Ent
));
3258 elsif Kind
= N_Integer_Literal
then
3259 return UR_From_Uint
(Expr_Value
(N
));
3261 -- Strange case of VAX literals, which are at this stage transformed
3262 -- into Vax_Type!x_To_y(IEEE_Literal). See Expand_N_Real_Literal in
3263 -- Exp_Vfpt for further details.
3265 elsif Vax_Float
(Etype
(N
))
3266 and then Nkind
(N
) = N_Unchecked_Type_Conversion
3268 Expr
:= Expression
(N
);
3270 if Nkind
(Expr
) = N_Function_Call
3271 and then Present
(Parameter_Associations
(Expr
))
3273 Expr
:= First
(Parameter_Associations
(Expr
));
3275 if Nkind
(Expr
) = N_Real_Literal
then
3276 return Realval
(Expr
);
3280 -- Peculiar VMS case, if we have xxx'Null_Parameter, return 0.0
3282 elsif Kind
= N_Attribute_Reference
3283 and then Attribute_Name
(N
) = Name_Null_Parameter
3288 -- If we fall through, we have a node that cannot be interpreted
3289 -- as a compile time constant. That is definitely an error.
3291 raise Program_Error
;
3298 function Expr_Value_S
(N
: Node_Id
) return Node_Id
is
3300 if Nkind
(N
) = N_String_Literal
then
3303 pragma Assert
(Ekind
(Entity
(N
)) = E_Constant
);
3304 return Expr_Value_S
(Constant_Value
(Entity
(N
)));
3308 --------------------------
3309 -- Flag_Non_Static_Expr --
3310 --------------------------
3312 procedure Flag_Non_Static_Expr
(Msg
: String; Expr
: Node_Id
) is
3314 if Error_Posted
(Expr
) and then not All_Errors_Mode
then
3317 Error_Msg_F
(Msg
, Expr
);
3318 Why_Not_Static
(Expr
);
3320 end Flag_Non_Static_Expr
;
3326 procedure Fold_Str
(N
: Node_Id
; Val
: String_Id
; Static
: Boolean) is
3327 Loc
: constant Source_Ptr
:= Sloc
(N
);
3328 Typ
: constant Entity_Id
:= Etype
(N
);
3331 Rewrite
(N
, Make_String_Literal
(Loc
, Strval
=> Val
));
3333 -- We now have the literal with the right value, both the actual type
3334 -- and the expected type of this literal are taken from the expression
3335 -- that was evaluated.
3338 Set_Is_Static_Expression
(N
, Static
);
3347 procedure Fold_Uint
(N
: Node_Id
; Val
: Uint
; Static
: Boolean) is
3348 Loc
: constant Source_Ptr
:= Sloc
(N
);
3349 Typ
: Entity_Id
:= Etype
(N
);
3353 -- If we are folding a named number, retain the entity in the
3354 -- literal, for ASIS use.
3356 if Is_Entity_Name
(N
)
3357 and then Ekind
(Entity
(N
)) = E_Named_Integer
3364 if Is_Private_Type
(Typ
) then
3365 Typ
:= Full_View
(Typ
);
3368 -- For a result of type integer, substitute an N_Integer_Literal node
3369 -- for the result of the compile time evaluation of the expression.
3370 -- For ASIS use, set a link to the original named number when not in
3371 -- a generic context.
3373 if Is_Integer_Type
(Typ
) then
3374 Rewrite
(N
, Make_Integer_Literal
(Loc
, Val
));
3376 Set_Original_Entity
(N
, Ent
);
3378 -- Otherwise we have an enumeration type, and we substitute either
3379 -- an N_Identifier or N_Character_Literal to represent the enumeration
3380 -- literal corresponding to the given value, which must always be in
3381 -- range, because appropriate tests have already been made for this.
3383 else pragma Assert
(Is_Enumeration_Type
(Typ
));
3384 Rewrite
(N
, Get_Enum_Lit_From_Pos
(Etype
(N
), Val
, Loc
));
3387 -- We now have the literal with the right value, both the actual type
3388 -- and the expected type of this literal are taken from the expression
3389 -- that was evaluated.
3392 Set_Is_Static_Expression
(N
, Static
);
3401 procedure Fold_Ureal
(N
: Node_Id
; Val
: Ureal
; Static
: Boolean) is
3402 Loc
: constant Source_Ptr
:= Sloc
(N
);
3403 Typ
: constant Entity_Id
:= Etype
(N
);
3407 -- If we are folding a named number, retain the entity in the
3408 -- literal, for ASIS use.
3410 if Is_Entity_Name
(N
)
3411 and then Ekind
(Entity
(N
)) = E_Named_Real
3418 Rewrite
(N
, Make_Real_Literal
(Loc
, Realval
=> Val
));
3420 -- Set link to original named number, for ASIS use
3422 Set_Original_Entity
(N
, Ent
);
3424 -- Both the actual and expected type comes from the original expression
3427 Set_Is_Static_Expression
(N
, Static
);
3436 function From_Bits
(B
: Bits
; T
: Entity_Id
) return Uint
is
3440 for J
in 0 .. B
'Last loop
3446 if Non_Binary_Modulus
(T
) then
3447 V
:= V
mod Modulus
(T
);
3453 --------------------
3454 -- Get_String_Val --
3455 --------------------
3457 function Get_String_Val
(N
: Node_Id
) return Node_Id
is
3459 if Nkind
(N
) = N_String_Literal
then
3462 elsif Nkind
(N
) = N_Character_Literal
then
3466 pragma Assert
(Is_Entity_Name
(N
));
3467 return Get_String_Val
(Constant_Value
(Entity
(N
)));
3475 procedure Initialize
is
3477 CV_Cache
:= (others => (Node_High_Bound
, Uint_0
));
3480 --------------------
3481 -- In_Subrange_Of --
3482 --------------------
3484 function In_Subrange_Of
3487 Fixed_Int
: Boolean := False) return Boolean
3496 if T1
= T2
or else Is_Subtype_Of
(T1
, T2
) then
3499 -- Never in range if both types are not scalar. Don't know if this can
3500 -- actually happen, but just in case.
3502 elsif not Is_Scalar_Type
(T1
) or else not Is_Scalar_Type
(T1
) then
3506 L1
:= Type_Low_Bound
(T1
);
3507 H1
:= Type_High_Bound
(T1
);
3509 L2
:= Type_Low_Bound
(T2
);
3510 H2
:= Type_High_Bound
(T2
);
3512 -- Check bounds to see if comparison possible at compile time
3514 if Compile_Time_Compare
(L1
, L2
) in Compare_GE
3516 Compile_Time_Compare
(H1
, H2
) in Compare_LE
3521 -- If bounds not comparable at compile time, then the bounds of T2
3522 -- must be compile time known or we cannot answer the query.
3524 if not Compile_Time_Known_Value
(L2
)
3525 or else not Compile_Time_Known_Value
(H2
)
3530 -- If the bounds of T1 are know at compile time then use these
3531 -- ones, otherwise use the bounds of the base type (which are of
3532 -- course always static).
3534 if not Compile_Time_Known_Value
(L1
) then
3535 L1
:= Type_Low_Bound
(Base_Type
(T1
));
3538 if not Compile_Time_Known_Value
(H1
) then
3539 H1
:= Type_High_Bound
(Base_Type
(T1
));
3542 -- Fixed point types should be considered as such only if
3543 -- flag Fixed_Int is set to False.
3545 if Is_Floating_Point_Type
(T1
) or else Is_Floating_Point_Type
(T2
)
3546 or else (Is_Fixed_Point_Type
(T1
) and then not Fixed_Int
)
3547 or else (Is_Fixed_Point_Type
(T2
) and then not Fixed_Int
)
3550 Expr_Value_R
(L2
) <= Expr_Value_R
(L1
)
3552 Expr_Value_R
(H2
) >= Expr_Value_R
(H1
);
3556 Expr_Value
(L2
) <= Expr_Value
(L1
)
3558 Expr_Value
(H2
) >= Expr_Value
(H1
);
3563 -- If any exception occurs, it means that we have some bug in the compiler
3564 -- possibly triggered by a previous error, or by some unforeseen peculiar
3565 -- occurrence. However, this is only an optimization attempt, so there is
3566 -- really no point in crashing the compiler. Instead we just decide, too
3567 -- bad, we can't figure out the answer in this case after all.
3572 -- Debug flag K disables this behavior (useful for debugging)
3574 if Debug_Flag_K
then
3585 function Is_In_Range
3588 Fixed_Int
: Boolean := False;
3589 Int_Real
: Boolean := False) return Boolean
3595 -- Universal types have no range limits, so always in range
3597 if Typ
= Universal_Integer
or else Typ
= Universal_Real
then
3600 -- Never in range if not scalar type. Don't know if this can
3601 -- actually happen, but our spec allows it, so we must check!
3603 elsif not Is_Scalar_Type
(Typ
) then
3606 -- Never in range unless we have a compile time known value
3608 elsif not Compile_Time_Known_Value
(N
) then
3613 Lo
: constant Node_Id
:= Type_Low_Bound
(Typ
);
3614 Hi
: constant Node_Id
:= Type_High_Bound
(Typ
);
3615 LB_Known
: constant Boolean := Compile_Time_Known_Value
(Lo
);
3616 UB_Known
: constant Boolean := Compile_Time_Known_Value
(Hi
);
3619 -- Fixed point types should be considered as such only in
3620 -- flag Fixed_Int is set to False.
3622 if Is_Floating_Point_Type
(Typ
)
3623 or else (Is_Fixed_Point_Type
(Typ
) and then not Fixed_Int
)
3626 Valr
:= Expr_Value_R
(N
);
3628 if LB_Known
and then Valr
>= Expr_Value_R
(Lo
)
3629 and then UB_Known
and then Valr
<= Expr_Value_R
(Hi
)
3637 Val
:= Expr_Value
(N
);
3639 if LB_Known
and then Val
>= Expr_Value
(Lo
)
3640 and then UB_Known
and then Val
<= Expr_Value
(Hi
)
3655 function Is_Null_Range
(Lo
: Node_Id
; Hi
: Node_Id
) return Boolean is
3656 Typ
: constant Entity_Id
:= Etype
(Lo
);
3659 if not Compile_Time_Known_Value
(Lo
)
3660 or else not Compile_Time_Known_Value
(Hi
)
3665 if Is_Discrete_Type
(Typ
) then
3666 return Expr_Value
(Lo
) > Expr_Value
(Hi
);
3669 pragma Assert
(Is_Real_Type
(Typ
));
3670 return Expr_Value_R
(Lo
) > Expr_Value_R
(Hi
);
3674 -----------------------------
3675 -- Is_OK_Static_Expression --
3676 -----------------------------
3678 function Is_OK_Static_Expression
(N
: Node_Id
) return Boolean is
3680 return Is_Static_Expression
(N
)
3681 and then not Raises_Constraint_Error
(N
);
3682 end Is_OK_Static_Expression
;
3684 ------------------------
3685 -- Is_OK_Static_Range --
3686 ------------------------
3688 -- A static range is a range whose bounds are static expressions, or a
3689 -- Range_Attribute_Reference equivalent to such a range (RM 4.9(26)).
3690 -- We have already converted range attribute references, so we get the
3691 -- "or" part of this rule without needing a special test.
3693 function Is_OK_Static_Range
(N
: Node_Id
) return Boolean is
3695 return Is_OK_Static_Expression
(Low_Bound
(N
))
3696 and then Is_OK_Static_Expression
(High_Bound
(N
));
3697 end Is_OK_Static_Range
;
3699 --------------------------
3700 -- Is_OK_Static_Subtype --
3701 --------------------------
3703 -- Determines if Typ is a static subtype as defined in (RM 4.9(26))
3704 -- where neither bound raises constraint error when evaluated.
3706 function Is_OK_Static_Subtype
(Typ
: Entity_Id
) return Boolean is
3707 Base_T
: constant Entity_Id
:= Base_Type
(Typ
);
3708 Anc_Subt
: Entity_Id
;
3711 -- First a quick check on the non static subtype flag. As described
3712 -- in further detail in Einfo, this flag is not decisive in all cases,
3713 -- but if it is set, then the subtype is definitely non-static.
3715 if Is_Non_Static_Subtype
(Typ
) then
3719 Anc_Subt
:= Ancestor_Subtype
(Typ
);
3721 if Anc_Subt
= Empty
then
3725 if Is_Generic_Type
(Root_Type
(Base_T
))
3726 or else Is_Generic_Actual_Type
(Base_T
)
3732 elsif Is_String_Type
(Typ
) then
3734 Ekind
(Typ
) = E_String_Literal_Subtype
3736 (Is_OK_Static_Subtype
(Component_Type
(Typ
))
3737 and then Is_OK_Static_Subtype
(Etype
(First_Index
(Typ
))));
3741 elsif Is_Scalar_Type
(Typ
) then
3742 if Base_T
= Typ
then
3746 -- Scalar_Range (Typ) might be an N_Subtype_Indication, so
3747 -- use Get_Type_Low,High_Bound.
3749 return Is_OK_Static_Subtype
(Anc_Subt
)
3750 and then Is_OK_Static_Expression
(Type_Low_Bound
(Typ
))
3751 and then Is_OK_Static_Expression
(Type_High_Bound
(Typ
));
3754 -- Types other than string and scalar types are never static
3759 end Is_OK_Static_Subtype
;
3761 ---------------------
3762 -- Is_Out_Of_Range --
3763 ---------------------
3765 function Is_Out_Of_Range
3768 Fixed_Int
: Boolean := False;
3769 Int_Real
: Boolean := False) return Boolean
3775 -- Universal types have no range limits, so always in range
3777 if Typ
= Universal_Integer
or else Typ
= Universal_Real
then
3780 -- Never out of range if not scalar type. Don't know if this can
3781 -- actually happen, but our spec allows it, so we must check!
3783 elsif not Is_Scalar_Type
(Typ
) then
3786 -- Never out of range if this is a generic type, since the bounds
3787 -- of generic types are junk. Note that if we only checked for
3788 -- static expressions (instead of compile time known values) below,
3789 -- we would not need this check, because values of a generic type
3790 -- can never be static, but they can be known at compile time.
3792 elsif Is_Generic_Type
(Typ
) then
3795 -- Never out of range unless we have a compile time known value
3797 elsif not Compile_Time_Known_Value
(N
) then
3802 Lo
: constant Node_Id
:= Type_Low_Bound
(Typ
);
3803 Hi
: constant Node_Id
:= Type_High_Bound
(Typ
);
3804 LB_Known
: constant Boolean := Compile_Time_Known_Value
(Lo
);
3805 UB_Known
: constant Boolean := Compile_Time_Known_Value
(Hi
);
3808 -- Real types (note that fixed-point types are not treated
3809 -- as being of a real type if the flag Fixed_Int is set,
3810 -- since in that case they are regarded as integer types).
3812 if Is_Floating_Point_Type
(Typ
)
3813 or else (Is_Fixed_Point_Type
(Typ
) and then not Fixed_Int
)
3816 Valr
:= Expr_Value_R
(N
);
3818 if LB_Known
and then Valr
< Expr_Value_R
(Lo
) then
3821 elsif UB_Known
and then Expr_Value_R
(Hi
) < Valr
then
3829 Val
:= Expr_Value
(N
);
3831 if LB_Known
and then Val
< Expr_Value
(Lo
) then
3834 elsif UB_Known
and then Expr_Value
(Hi
) < Val
then
3843 end Is_Out_Of_Range
;
3845 ---------------------
3846 -- Is_Static_Range --
3847 ---------------------
3849 -- A static range is a range whose bounds are static expressions, or a
3850 -- Range_Attribute_Reference equivalent to such a range (RM 4.9(26)).
3851 -- We have already converted range attribute references, so we get the
3852 -- "or" part of this rule without needing a special test.
3854 function Is_Static_Range
(N
: Node_Id
) return Boolean is
3856 return Is_Static_Expression
(Low_Bound
(N
))
3857 and then Is_Static_Expression
(High_Bound
(N
));
3858 end Is_Static_Range
;
3860 -----------------------
3861 -- Is_Static_Subtype --
3862 -----------------------
3864 -- Determines if Typ is a static subtype as defined in (RM 4.9(26))
3866 function Is_Static_Subtype
(Typ
: Entity_Id
) return Boolean is
3867 Base_T
: constant Entity_Id
:= Base_Type
(Typ
);
3868 Anc_Subt
: Entity_Id
;
3871 -- First a quick check on the non static subtype flag. As described
3872 -- in further detail in Einfo, this flag is not decisive in all cases,
3873 -- but if it is set, then the subtype is definitely non-static.
3875 if Is_Non_Static_Subtype
(Typ
) then
3879 Anc_Subt
:= Ancestor_Subtype
(Typ
);
3881 if Anc_Subt
= Empty
then
3885 if Is_Generic_Type
(Root_Type
(Base_T
))
3886 or else Is_Generic_Actual_Type
(Base_T
)
3892 elsif Is_String_Type
(Typ
) then
3894 Ekind
(Typ
) = E_String_Literal_Subtype
3896 (Is_Static_Subtype
(Component_Type
(Typ
))
3897 and then Is_Static_Subtype
(Etype
(First_Index
(Typ
))));
3901 elsif Is_Scalar_Type
(Typ
) then
3902 if Base_T
= Typ
then
3906 return Is_Static_Subtype
(Anc_Subt
)
3907 and then Is_Static_Expression
(Type_Low_Bound
(Typ
))
3908 and then Is_Static_Expression
(Type_High_Bound
(Typ
));
3911 -- Types other than string and scalar types are never static
3916 end Is_Static_Subtype
;
3918 --------------------
3919 -- Not_Null_Range --
3920 --------------------
3922 function Not_Null_Range
(Lo
: Node_Id
; Hi
: Node_Id
) return Boolean is
3923 Typ
: constant Entity_Id
:= Etype
(Lo
);
3926 if not Compile_Time_Known_Value
(Lo
)
3927 or else not Compile_Time_Known_Value
(Hi
)
3932 if Is_Discrete_Type
(Typ
) then
3933 return Expr_Value
(Lo
) <= Expr_Value
(Hi
);
3936 pragma Assert
(Is_Real_Type
(Typ
));
3938 return Expr_Value_R
(Lo
) <= Expr_Value_R
(Hi
);
3946 function OK_Bits
(N
: Node_Id
; Bits
: Uint
) return Boolean is
3948 -- We allow a maximum of 500,000 bits which seems a reasonable limit
3950 if Bits
< 500_000
then
3954 Error_Msg_N
("static value too large, capacity exceeded", N
);
3963 procedure Out_Of_Range
(N
: Node_Id
) is
3965 -- If we have the static expression case, then this is an illegality
3966 -- in Ada 95 mode, except that in an instance, we never generate an
3967 -- error (if the error is legitimate, it was already diagnosed in
3968 -- the template). The expression to compute the length of a packed
3969 -- array is attached to the array type itself, and deserves a separate
3972 if Is_Static_Expression
(N
)
3973 and then not In_Instance
3974 and then not In_Inlined_Body
3975 and then Ada_Version
>= Ada_95
3977 if Nkind
(Parent
(N
)) = N_Defining_Identifier
3978 and then Is_Array_Type
(Parent
(N
))
3979 and then Present
(Packed_Array_Type
(Parent
(N
)))
3980 and then Present
(First_Rep_Item
(Parent
(N
)))
3983 ("length of packed array must not exceed Integer''Last",
3984 First_Rep_Item
(Parent
(N
)));
3985 Rewrite
(N
, Make_Integer_Literal
(Sloc
(N
), Uint_1
));
3988 Apply_Compile_Time_Constraint_Error
3989 (N
, "value not in range of}", CE_Range_Check_Failed
);
3992 -- Here we generate a warning for the Ada 83 case, or when we are
3993 -- in an instance, or when we have a non-static expression case.
3996 Apply_Compile_Time_Constraint_Error
3997 (N
, "value not in range of}?", CE_Range_Check_Failed
);
4001 -------------------------
4002 -- Rewrite_In_Raise_CE --
4003 -------------------------
4005 procedure Rewrite_In_Raise_CE
(N
: Node_Id
; Exp
: Node_Id
) is
4006 Typ
: constant Entity_Id
:= Etype
(N
);
4009 -- If we want to raise CE in the condition of a raise_CE node
4010 -- we may as well get rid of the condition
4012 if Present
(Parent
(N
))
4013 and then Nkind
(Parent
(N
)) = N_Raise_Constraint_Error
4015 Set_Condition
(Parent
(N
), Empty
);
4017 -- If the expression raising CE is a N_Raise_CE node, we can use
4018 -- that one. We just preserve the type of the context
4020 elsif Nkind
(Exp
) = N_Raise_Constraint_Error
then
4024 -- We have to build an explicit raise_ce node
4028 Make_Raise_Constraint_Error
(Sloc
(Exp
),
4029 Reason
=> CE_Range_Check_Failed
));
4030 Set_Raises_Constraint_Error
(N
);
4033 end Rewrite_In_Raise_CE
;
4035 ---------------------
4036 -- String_Type_Len --
4037 ---------------------
4039 function String_Type_Len
(Stype
: Entity_Id
) return Uint
is
4040 NT
: constant Entity_Id
:= Etype
(First_Index
(Stype
));
4044 if Is_OK_Static_Subtype
(NT
) then
4047 T
:= Base_Type
(NT
);
4050 return Expr_Value
(Type_High_Bound
(T
)) -
4051 Expr_Value
(Type_Low_Bound
(T
)) + 1;
4052 end String_Type_Len
;
4054 ------------------------------------
4055 -- Subtypes_Statically_Compatible --
4056 ------------------------------------
4058 function Subtypes_Statically_Compatible
4060 T2
: Entity_Id
) return Boolean
4063 if Is_Scalar_Type
(T1
) then
4065 -- Definitely compatible if we match
4067 if Subtypes_Statically_Match
(T1
, T2
) then
4070 -- If either subtype is nonstatic then they're not compatible
4072 elsif not Is_Static_Subtype
(T1
)
4073 or else not Is_Static_Subtype
(T2
)
4077 -- If either type has constraint error bounds, then consider that
4078 -- they match to avoid junk cascaded errors here.
4080 elsif not Is_OK_Static_Subtype
(T1
)
4081 or else not Is_OK_Static_Subtype
(T2
)
4085 -- Base types must match, but we don't check that (should
4086 -- we???) but we do at least check that both types are
4087 -- real, or both types are not real.
4089 elsif Is_Real_Type
(T1
) /= Is_Real_Type
(T2
) then
4092 -- Here we check the bounds
4096 LB1
: constant Node_Id
:= Type_Low_Bound
(T1
);
4097 HB1
: constant Node_Id
:= Type_High_Bound
(T1
);
4098 LB2
: constant Node_Id
:= Type_Low_Bound
(T2
);
4099 HB2
: constant Node_Id
:= Type_High_Bound
(T2
);
4102 if Is_Real_Type
(T1
) then
4104 (Expr_Value_R
(LB1
) > Expr_Value_R
(HB1
))
4106 (Expr_Value_R
(LB2
) <= Expr_Value_R
(LB1
)
4108 Expr_Value_R
(HB1
) <= Expr_Value_R
(HB2
));
4112 (Expr_Value
(LB1
) > Expr_Value
(HB1
))
4114 (Expr_Value
(LB2
) <= Expr_Value
(LB1
)
4116 Expr_Value
(HB1
) <= Expr_Value
(HB2
));
4121 elsif Is_Access_Type
(T1
) then
4122 return not Is_Constrained
(T2
)
4123 or else Subtypes_Statically_Match
4124 (Designated_Type
(T1
), Designated_Type
(T2
));
4127 return (Is_Composite_Type
(T1
) and then not Is_Constrained
(T2
))
4128 or else Subtypes_Statically_Match
(T1
, T2
);
4130 end Subtypes_Statically_Compatible
;
4132 -------------------------------
4133 -- Subtypes_Statically_Match --
4134 -------------------------------
4136 -- Subtypes statically match if they have statically matching constraints
4137 -- (RM 4.9.1(2)). Constraints statically match if there are none, or if
4138 -- they are the same identical constraint, or if they are static and the
4139 -- values match (RM 4.9.1(1)).
4141 function Subtypes_Statically_Match
(T1
, T2
: Entity_Id
) return Boolean is
4143 -- A type always statically matches itself
4150 elsif Is_Scalar_Type
(T1
) then
4152 -- Base types must be the same
4154 if Base_Type
(T1
) /= Base_Type
(T2
) then
4158 -- A constrained numeric subtype never matches an unconstrained
4159 -- subtype, i.e. both types must be constrained or unconstrained.
4161 -- To understand the requirement for this test, see RM 4.9.1(1).
4162 -- As is made clear in RM 3.5.4(11), type Integer, for example
4163 -- is a constrained subtype with constraint bounds matching the
4164 -- bounds of its corresponding unconstrained base type. In this
4165 -- situation, Integer and Integer'Base do not statically match,
4166 -- even though they have the same bounds.
4168 -- We only apply this test to types in Standard and types that
4169 -- appear in user programs. That way, we do not have to be
4170 -- too careful about setting Is_Constrained right for itypes.
4172 if Is_Numeric_Type
(T1
)
4173 and then (Is_Constrained
(T1
) /= Is_Constrained
(T2
))
4174 and then (Scope
(T1
) = Standard_Standard
4175 or else Comes_From_Source
(T1
))
4176 and then (Scope
(T2
) = Standard_Standard
4177 or else Comes_From_Source
(T2
))
4181 -- A generic scalar type does not statically match its base
4182 -- type (AI-311). In this case we make sure that the formals,
4183 -- which are first subtypes of their bases, are constrained.
4185 elsif Is_Generic_Type
(T1
)
4186 and then Is_Generic_Type
(T2
)
4187 and then (Is_Constrained
(T1
) /= Is_Constrained
(T2
))
4192 -- If there was an error in either range, then just assume
4193 -- the types statically match to avoid further junk errors
4195 if Error_Posted
(Scalar_Range
(T1
))
4197 Error_Posted
(Scalar_Range
(T2
))
4202 -- Otherwise both types have bound that can be compared
4205 LB1
: constant Node_Id
:= Type_Low_Bound
(T1
);
4206 HB1
: constant Node_Id
:= Type_High_Bound
(T1
);
4207 LB2
: constant Node_Id
:= Type_Low_Bound
(T2
);
4208 HB2
: constant Node_Id
:= Type_High_Bound
(T2
);
4211 -- If the bounds are the same tree node, then match
4213 if LB1
= LB2
and then HB1
= HB2
then
4216 -- Otherwise bounds must be static and identical value
4219 if not Is_Static_Subtype
(T1
)
4220 or else not Is_Static_Subtype
(T2
)
4224 -- If either type has constraint error bounds, then say
4225 -- that they match to avoid junk cascaded errors here.
4227 elsif not Is_OK_Static_Subtype
(T1
)
4228 or else not Is_OK_Static_Subtype
(T2
)
4232 elsif Is_Real_Type
(T1
) then
4234 (Expr_Value_R
(LB1
) = Expr_Value_R
(LB2
))
4236 (Expr_Value_R
(HB1
) = Expr_Value_R
(HB2
));
4240 Expr_Value
(LB1
) = Expr_Value
(LB2
)
4242 Expr_Value
(HB1
) = Expr_Value
(HB2
);
4247 -- Type with discriminants
4249 elsif Has_Discriminants
(T1
) or else Has_Discriminants
(T2
) then
4251 -- Because of view exchanges in multiple instantiations, conformance
4252 -- checking might try to match a partial view of a type with no
4253 -- discriminants with a full view that has defaulted discriminants.
4254 -- In such a case, use the discriminant constraint of the full view,
4255 -- which must exist because we know that the two subtypes have the
4258 if Has_Discriminants
(T1
) /= Has_Discriminants
(T2
) then
4260 if Is_Private_Type
(T2
)
4261 and then Present
(Full_View
(T2
))
4262 and then Has_Discriminants
(Full_View
(T2
))
4264 return Subtypes_Statically_Match
(T1
, Full_View
(T2
));
4266 elsif Is_Private_Type
(T1
)
4267 and then Present
(Full_View
(T1
))
4268 and then Has_Discriminants
(Full_View
(T1
))
4270 return Subtypes_Statically_Match
(Full_View
(T1
), T2
);
4281 DL1
: constant Elist_Id
:= Discriminant_Constraint
(T1
);
4282 DL2
: constant Elist_Id
:= Discriminant_Constraint
(T2
);
4290 elsif Is_Constrained
(T1
) /= Is_Constrained
(T2
) then
4294 -- Now loop through the discriminant constraints
4296 -- Note: the guard here seems necessary, since it is possible at
4297 -- least for DL1 to be No_Elist. Not clear this is reasonable ???
4299 if Present
(DL1
) and then Present
(DL2
) then
4300 DA1
:= First_Elmt
(DL1
);
4301 DA2
:= First_Elmt
(DL2
);
4302 while Present
(DA1
) loop
4304 Expr1
: constant Node_Id
:= Node
(DA1
);
4305 Expr2
: constant Node_Id
:= Node
(DA2
);
4308 if not Is_Static_Expression
(Expr1
)
4309 or else not Is_Static_Expression
(Expr2
)
4313 -- If either expression raised a constraint error,
4314 -- consider the expressions as matching, since this
4315 -- helps to prevent cascading errors.
4317 elsif Raises_Constraint_Error
(Expr1
)
4318 or else Raises_Constraint_Error
(Expr2
)
4322 elsif Expr_Value
(Expr1
) /= Expr_Value
(Expr2
) then
4335 -- A definite type does not match an indefinite or classwide type
4336 -- However, a generic type with unknown discriminants may be
4337 -- instantiated with a type with no discriminants, and conformance
4338 -- checking on an inherited operation may compare the actual with
4339 -- the subtype that renames it in the instance.
4342 Has_Unknown_Discriminants
(T1
) /= Has_Unknown_Discriminants
(T2
)
4345 Is_Generic_Actual_Type
(T1
) or else Is_Generic_Actual_Type
(T2
);
4349 elsif Is_Array_Type
(T1
) then
4351 -- If either subtype is unconstrained then both must be,
4352 -- and if both are unconstrained then no further checking
4355 if not Is_Constrained
(T1
) or else not Is_Constrained
(T2
) then
4356 return not (Is_Constrained
(T1
) or else Is_Constrained
(T2
));
4359 -- Both subtypes are constrained, so check that the index
4360 -- subtypes statically match.
4363 Index1
: Node_Id
:= First_Index
(T1
);
4364 Index2
: Node_Id
:= First_Index
(T2
);
4367 while Present
(Index1
) loop
4369 Subtypes_Statically_Match
(Etype
(Index1
), Etype
(Index2
))
4374 Next_Index
(Index1
);
4375 Next_Index
(Index2
);
4381 elsif Is_Access_Type
(T1
) then
4382 if Can_Never_Be_Null
(T1
) /= Can_Never_Be_Null
(T2
) then
4385 elsif Ekind
(T1
) = E_Access_Subprogram_Type
4386 or else Ekind
(T1
) = E_Anonymous_Access_Subprogram_Type
4390 (Designated_Type
(T1
),
4391 Designated_Type
(T2
));
4394 Subtypes_Statically_Match
4395 (Designated_Type
(T1
),
4396 Designated_Type
(T2
))
4397 and then Is_Access_Constant
(T1
) = Is_Access_Constant
(T2
);
4400 -- All other types definitely match
4405 end Subtypes_Statically_Match
;
4411 function Test
(Cond
: Boolean) return Uint
is
4420 ---------------------------------
4421 -- Test_Expression_Is_Foldable --
4422 ---------------------------------
4426 procedure Test_Expression_Is_Foldable
4436 if Debug_Flag_Dot_F
and then In_Extended_Main_Source_Unit
(N
) then
4440 -- If operand is Any_Type, just propagate to result and do not
4441 -- try to fold, this prevents cascaded errors.
4443 if Etype
(Op1
) = Any_Type
then
4444 Set_Etype
(N
, Any_Type
);
4447 -- If operand raises constraint error, then replace node N with the
4448 -- raise constraint error node, and we are obviously not foldable.
4449 -- Note that this replacement inherits the Is_Static_Expression flag
4450 -- from the operand.
4452 elsif Raises_Constraint_Error
(Op1
) then
4453 Rewrite_In_Raise_CE
(N
, Op1
);
4456 -- If the operand is not static, then the result is not static, and
4457 -- all we have to do is to check the operand since it is now known
4458 -- to appear in a non-static context.
4460 elsif not Is_Static_Expression
(Op1
) then
4461 Check_Non_Static_Context
(Op1
);
4462 Fold
:= Compile_Time_Known_Value
(Op1
);
4465 -- An expression of a formal modular type is not foldable because
4466 -- the modulus is unknown.
4468 elsif Is_Modular_Integer_Type
(Etype
(Op1
))
4469 and then Is_Generic_Type
(Etype
(Op1
))
4471 Check_Non_Static_Context
(Op1
);
4474 -- Here we have the case of an operand whose type is OK, which is
4475 -- static, and which does not raise constraint error, we can fold.
4478 Set_Is_Static_Expression
(N
);
4482 end Test_Expression_Is_Foldable
;
4486 procedure Test_Expression_Is_Foldable
4493 Rstat
: constant Boolean := Is_Static_Expression
(Op1
)
4494 and then Is_Static_Expression
(Op2
);
4500 if Debug_Flag_Dot_F
and then In_Extended_Main_Source_Unit
(N
) then
4504 -- If either operand is Any_Type, just propagate to result and
4505 -- do not try to fold, this prevents cascaded errors.
4507 if Etype
(Op1
) = Any_Type
or else Etype
(Op2
) = Any_Type
then
4508 Set_Etype
(N
, Any_Type
);
4511 -- If left operand raises constraint error, then replace node N with
4512 -- the raise constraint error node, and we are obviously not foldable.
4513 -- Is_Static_Expression is set from the two operands in the normal way,
4514 -- and we check the right operand if it is in a non-static context.
4516 elsif Raises_Constraint_Error
(Op1
) then
4518 Check_Non_Static_Context
(Op2
);
4521 Rewrite_In_Raise_CE
(N
, Op1
);
4522 Set_Is_Static_Expression
(N
, Rstat
);
4525 -- Similar processing for the case of the right operand. Note that
4526 -- we don't use this routine for the short-circuit case, so we do
4527 -- not have to worry about that special case here.
4529 elsif Raises_Constraint_Error
(Op2
) then
4531 Check_Non_Static_Context
(Op1
);
4534 Rewrite_In_Raise_CE
(N
, Op2
);
4535 Set_Is_Static_Expression
(N
, Rstat
);
4538 -- Exclude expressions of a generic modular type, as above
4540 elsif Is_Modular_Integer_Type
(Etype
(Op1
))
4541 and then Is_Generic_Type
(Etype
(Op1
))
4543 Check_Non_Static_Context
(Op1
);
4546 -- If result is not static, then check non-static contexts on operands
4547 -- since one of them may be static and the other one may not be static
4549 elsif not Rstat
then
4550 Check_Non_Static_Context
(Op1
);
4551 Check_Non_Static_Context
(Op2
);
4552 Fold
:= Compile_Time_Known_Value
(Op1
)
4553 and then Compile_Time_Known_Value
(Op2
);
4556 -- Else result is static and foldable. Both operands are static,
4557 -- and neither raises constraint error, so we can definitely fold.
4560 Set_Is_Static_Expression
(N
);
4565 end Test_Expression_Is_Foldable
;
4571 procedure To_Bits
(U
: Uint
; B
: out Bits
) is
4573 for J
in 0 .. B
'Last loop
4574 B
(J
) := (U
/ (2 ** J
)) mod 2 /= 0;
4578 --------------------
4579 -- Why_Not_Static --
4580 --------------------
4582 procedure Why_Not_Static
(Expr
: Node_Id
) is
4583 N
: constant Node_Id
:= Original_Node
(Expr
);
4587 procedure Why_Not_Static_List
(L
: List_Id
);
4588 -- A version that can be called on a list of expressions. Finds
4589 -- all non-static violations in any element of the list.
4591 -------------------------
4592 -- Why_Not_Static_List --
4593 -------------------------
4595 procedure Why_Not_Static_List
(L
: List_Id
) is
4599 if Is_Non_Empty_List
(L
) then
4601 while Present
(N
) loop
4606 end Why_Not_Static_List
;
4608 -- Start of processing for Why_Not_Static
4611 -- If in ACATS mode (debug flag 2), then suppress all these
4612 -- messages, this avoids massive updates to the ACATS base line.
4614 if Debug_Flag_2
then
4618 -- Ignore call on error or empty node
4620 if No
(Expr
) or else Nkind
(Expr
) = N_Error
then
4624 -- Preprocessing for sub expressions
4626 if Nkind
(Expr
) in N_Subexpr
then
4628 -- Nothing to do if expression is static
4630 if Is_OK_Static_Expression
(Expr
) then
4634 -- Test for constraint error raised
4636 if Raises_Constraint_Error
(Expr
) then
4638 ("expression raises exception, cannot be static " &
4639 "(RM 4.9(34))!", N
);
4643 -- If no type, then something is pretty wrong, so ignore
4645 Typ
:= Etype
(Expr
);
4651 -- Type must be scalar or string type
4653 if not Is_Scalar_Type
(Typ
)
4654 and then not Is_String_Type
(Typ
)
4657 ("static expression must have scalar or string type " &
4663 -- If we got through those checks, test particular node kind
4666 when N_Expanded_Name | N_Identifier | N_Operator_Symbol
=>
4669 if Is_Named_Number
(E
) then
4672 elsif Ekind
(E
) = E_Constant
then
4673 if not Is_Static_Expression
(Constant_Value
(E
)) then
4675 ("& is not a static constant (RM 4.9(5))!", N
, E
);
4680 ("& is not static constant or named number " &
4681 "(RM 4.9(5))!", N
, E
);
4684 when N_Binary_Op | N_And_Then | N_Or_Else | N_Membership_Test
=>
4685 if Nkind
(N
) in N_Op_Shift
then
4687 ("shift functions are never static (RM 4.9(6,18))!", N
);
4690 Why_Not_Static
(Left_Opnd
(N
));
4691 Why_Not_Static
(Right_Opnd
(N
));
4695 Why_Not_Static
(Right_Opnd
(N
));
4697 when N_Attribute_Reference
=>
4698 Why_Not_Static_List
(Expressions
(N
));
4700 E
:= Etype
(Prefix
(N
));
4702 if E
= Standard_Void_Type
then
4706 -- Special case non-scalar'Size since this is a common error
4708 if Attribute_Name
(N
) = Name_Size
then
4710 ("size attribute is only static for scalar type " &
4711 "(RM 4.9(7,8))", N
);
4715 elsif Is_Array_Type
(E
) then
4716 if Attribute_Name
(N
) /= Name_First
4718 Attribute_Name
(N
) /= Name_Last
4720 Attribute_Name
(N
) /= Name_Length
4723 ("static array attribute must be Length, First, or Last " &
4726 -- Since we know the expression is not-static (we already
4727 -- tested for this, must mean array is not static).
4731 ("prefix is non-static array (RM 4.9(8))!", Prefix
(N
));
4736 -- Special case generic types, since again this is a common
4737 -- source of confusion.
4739 elsif Is_Generic_Actual_Type
(E
)
4744 ("attribute of generic type is never static " &
4745 "(RM 4.9(7,8))!", N
);
4747 elsif Is_Static_Subtype
(E
) then
4750 elsif Is_Scalar_Type
(E
) then
4752 ("prefix type for attribute is not static scalar subtype " &
4757 ("static attribute must apply to array/scalar type " &
4758 "(RM 4.9(7,8))!", N
);
4761 when N_String_Literal
=>
4763 ("subtype of string literal is non-static (RM 4.9(4))!", N
);
4765 when N_Explicit_Dereference
=>
4767 ("explicit dereference is never static (RM 4.9)!", N
);
4769 when N_Function_Call
=>
4770 Why_Not_Static_List
(Parameter_Associations
(N
));
4771 Error_Msg_N
("non-static function call (RM 4.9(6,18))!", N
);
4773 when N_Parameter_Association
=>
4774 Why_Not_Static
(Explicit_Actual_Parameter
(N
));
4776 when N_Indexed_Component
=>
4778 ("indexed component is never static (RM 4.9)!", N
);
4780 when N_Procedure_Call_Statement
=>
4782 ("procedure call is never static (RM 4.9)!", N
);
4784 when N_Qualified_Expression
=>
4785 Why_Not_Static
(Expression
(N
));
4787 when N_Aggregate | N_Extension_Aggregate
=>
4789 ("an aggregate is never static (RM 4.9)!", N
);
4792 Why_Not_Static
(Low_Bound
(N
));
4793 Why_Not_Static
(High_Bound
(N
));
4795 when N_Range_Constraint
=>
4796 Why_Not_Static
(Range_Expression
(N
));
4798 when N_Subtype_Indication
=>
4799 Why_Not_Static
(Constraint
(N
));
4801 when N_Selected_Component
=>
4803 ("selected component is never static (RM 4.9)!", N
);
4807 ("slice is never static (RM 4.9)!", N
);
4809 when N_Type_Conversion
=>
4810 Why_Not_Static
(Expression
(N
));
4812 if not Is_Scalar_Type
(Etype
(Prefix
(N
)))
4813 or else not Is_Static_Subtype
(Etype
(Prefix
(N
)))
4816 ("static conversion requires static scalar subtype result " &
4820 when N_Unchecked_Type_Conversion
=>
4822 ("unchecked type conversion is never static (RM 4.9)!", N
);