1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2003 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 2, 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 COPYING. If not, write --
19 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
20 -- MA 02111-1307, USA. --
22 -- GNAT was originally developed by the GNAT team at New York University. --
23 -- Extensive contributions were provided by Ada Core Technologies Inc. --
25 ------------------------------------------------------------------------------
27 with Atree
; use Atree
;
28 with Checks
; use Checks
;
29 with Debug
; use Debug
;
30 with Einfo
; use Einfo
;
31 with Elists
; use Elists
;
32 with Errout
; use Errout
;
33 with Eval_Fat
; use Eval_Fat
;
34 with Exp_Util
; use Exp_Util
;
35 with Nmake
; use Nmake
;
36 with Nlists
; use Nlists
;
39 with Sem_Cat
; use Sem_Cat
;
40 with Sem_Ch8
; use Sem_Ch8
;
41 with Sem_Res
; use Sem_Res
;
42 with Sem_Util
; use Sem_Util
;
43 with Sem_Type
; use Sem_Type
;
44 with Sem_Warn
; use Sem_Warn
;
45 with Sinfo
; use Sinfo
;
46 with Snames
; use Snames
;
47 with Stand
; use Stand
;
48 with Stringt
; use Stringt
;
49 with Tbuild
; use Tbuild
;
51 package body Sem_Eval
is
53 -----------------------------------------
54 -- Handling of Compile Time Evaluation --
55 -----------------------------------------
57 -- The compile time evaluation of expressions is distributed over several
58 -- Eval_xxx procedures. These procedures are called immediatedly after
59 -- a subexpression is resolved and is therefore accomplished in a bottom
60 -- up fashion. The flags are synthesized using the following approach.
62 -- Is_Static_Expression is determined by following the detailed rules
63 -- in RM 4.9(4-14). This involves testing the Is_Static_Expression
64 -- flag of the operands in many cases.
66 -- Raises_Constraint_Error is set if any of the operands have the flag
67 -- set or if an attempt to compute the value of the current expression
68 -- results in detection of a runtime constraint error.
70 -- As described in the spec, the requirement is that Is_Static_Expression
71 -- be accurately set, and in addition for nodes for which this flag is set,
72 -- Raises_Constraint_Error must also be set. Furthermore a node which has
73 -- Is_Static_Expression set, and Raises_Constraint_Error clear, then the
74 -- requirement is that the expression value must be precomputed, and the
75 -- node is either a literal, or the name of a constant entity whose value
76 -- is a static expression.
78 -- The general approach is as follows. First compute Is_Static_Expression.
79 -- If the node is not static, then the flag is left off in the node and
80 -- we are all done. Otherwise for a static node, we test if any of the
81 -- operands will raise constraint error, and if so, propagate the flag
82 -- Raises_Constraint_Error to the result node and we are done (since the
83 -- error was already posted at a lower level).
85 -- For the case of a static node whose operands do not raise constraint
86 -- error, we attempt to evaluate the node. If this evaluation succeeds,
87 -- then the node is replaced by the result of this computation. If the
88 -- evaluation raises constraint error, then we rewrite the node with
89 -- Apply_Compile_Time_Constraint_Error to raise the exception and also
90 -- to post appropriate error messages.
96 type Bits
is array (Nat
range <>) of Boolean;
97 -- Used to convert unsigned (modular) values for folding logical ops
99 -- The following definitions are used to maintain a cache of nodes that
100 -- have compile time known values. The cache is maintained only for
101 -- discrete types (the most common case), and is populated by calls to
102 -- Compile_Time_Known_Value and Expr_Value, but only used by Expr_Value
103 -- since it is possible for the status to change (in particular it is
104 -- possible for a node to get replaced by a constraint error node).
106 CV_Bits
: constant := 5;
107 -- Number of low order bits of Node_Id value used to reference entries
108 -- in the cache table.
110 CV_Cache_Size
: constant Nat
:= 2 ** CV_Bits
;
111 -- Size of cache for compile time values
113 subtype CV_Range
is Nat
range 0 .. CV_Cache_Size
;
115 type CV_Entry
is record
120 type CV_Cache_Array
is array (CV_Range
) of CV_Entry
;
122 CV_Cache
: CV_Cache_Array
:= (others => (Node_High_Bound
, Uint_0
));
123 -- This is the actual cache, with entries consisting of node/value pairs,
124 -- and the impossible value Node_High_Bound used for unset entries.
126 -----------------------
127 -- Local Subprograms --
128 -----------------------
130 function From_Bits
(B
: Bits
; T
: Entity_Id
) return Uint
;
131 -- Converts a bit string of length B'Length to a Uint value to be used
132 -- for a target of type T, which is a modular type. This procedure
133 -- includes the necessary reduction by the modulus in the case of a
134 -- non-binary modulus (for a binary modulus, the bit string is the
135 -- right length any way so all is well).
137 function Get_String_Val
(N
: Node_Id
) return Node_Id
;
138 -- Given a tree node for a folded string or character value, returns
139 -- the corresponding string literal or character literal (one of the
140 -- two must be available, or the operand would not have been marked
141 -- as foldable in the earlier analysis of the operation).
143 function OK_Bits
(N
: Node_Id
; Bits
: Uint
) return Boolean;
144 -- Bits represents the number of bits in an integer value to be computed
145 -- (but the value has not been computed yet). If this value in Bits is
146 -- reasonable, a result of True is returned, with the implication that
147 -- the caller should go ahead and complete the calculation. If the value
148 -- in Bits is unreasonably large, then an error is posted on node N, and
149 -- False is returned (and the caller skips the proposed calculation).
151 procedure Out_Of_Range
(N
: Node_Id
);
152 -- This procedure is called if it is determined that node N, which
153 -- appears in a non-static context, is a compile time known value
154 -- which is outside its range, i.e. the range of Etype. This is used
155 -- in contexts where this is an illegality if N is static, and should
156 -- generate a warning otherwise.
158 procedure Rewrite_In_Raise_CE
(N
: Node_Id
; Exp
: Node_Id
);
159 -- N and Exp are nodes representing an expression, Exp is known
160 -- to raise CE. N is rewritten in term of Exp in the optimal way.
162 function String_Type_Len
(Stype
: Entity_Id
) return Uint
;
163 -- Given a string type, determines the length of the index type, or,
164 -- if this index type is non-static, the length of the base type of
165 -- this index type. Note that if the string type is itself static,
166 -- then the index type is static, so the second case applies only
167 -- if the string type passed is non-static.
169 function Test
(Cond
: Boolean) return Uint
;
170 pragma Inline
(Test
);
171 -- This function simply returns the appropriate Boolean'Pos value
172 -- corresponding to the value of Cond as a universal integer. It is
173 -- used for producing the result of the static evaluation of the
176 procedure Test_Expression_Is_Foldable
181 -- Tests to see if expression N whose single operand is Op1 is foldable,
182 -- i.e. the operand value is known at compile time. If the operation is
183 -- foldable, then Fold is True on return, and Stat indicates whether
184 -- the result is static (i.e. both operands were static). Note that it
185 -- is quite possible for Fold to be True, and Stat to be False, since
186 -- there are cases in which we know the value of an operand even though
187 -- it is not technically static (e.g. the static lower bound of a range
188 -- whose upper bound is non-static).
190 -- If Stat is set False on return, then Expression_Is_Foldable makes a
191 -- call to Check_Non_Static_Context on the operand. If Fold is False on
192 -- return, then all processing is complete, and the caller should
193 -- return, since there is nothing else to do.
195 procedure Test_Expression_Is_Foldable
201 -- Same processing, except applies to an expression N with two operands
204 procedure To_Bits
(U
: Uint
; B
: out Bits
);
205 -- Converts a Uint value to a bit string of length B'Length
207 ------------------------------
208 -- Check_Non_Static_Context --
209 ------------------------------
211 procedure Check_Non_Static_Context
(N
: Node_Id
) is
212 T
: constant Entity_Id
:= Etype
(N
);
213 Checks_On
: constant Boolean :=
214 not Index_Checks_Suppressed
(T
)
215 and not Range_Checks_Suppressed
(T
);
218 -- Ignore cases of non-scalar types or error types
220 if T
= Any_Type
or else not Is_Scalar_Type
(T
) then
224 -- At this stage we have a scalar type. If we have an expression
225 -- that raises CE, then we already issued a warning or error msg
226 -- so there is nothing more to be done in this routine.
228 if Raises_Constraint_Error
(N
) then
232 -- Now we have a scalar type which is not marked as raising a
233 -- constraint error exception. The main purpose of this routine
234 -- is to deal with static expressions appearing in a non-static
235 -- context. That means that if we do not have a static expression
236 -- then there is not much to do. The one case that we deal with
237 -- here is that if we have a floating-point value that is out of
238 -- range, then we post a warning that an infinity will result.
240 if not Is_Static_Expression
(N
) then
241 if Is_Floating_Point_Type
(T
)
242 and then Is_Out_Of_Range
(N
, Base_Type
(T
))
245 ("?float value out of range, infinity will be generated", N
);
251 -- Here we have the case of outer level static expression of
252 -- scalar type, where the processing of this procedure is needed.
254 -- For real types, this is where we convert the value to a machine
255 -- number (see RM 4.9(38)). Also see ACVC test C490001. We should
256 -- only need to do this if the parent is a constant declaration,
257 -- since in other cases, gigi should do the necessary conversion
258 -- correctly, but experimentation shows that this is not the case
259 -- on all machines, in particular if we do not convert all literals
260 -- to machine values in non-static contexts, then ACVC test C490001
261 -- fails on Sparc/Solaris and SGI/Irix.
263 if Nkind
(N
) = N_Real_Literal
264 and then not Is_Machine_Number
(N
)
265 and then not Is_Generic_Type
(Etype
(N
))
266 and then Etype
(N
) /= Universal_Real
268 -- Check that value is in bounds before converting to machine
269 -- number, so as not to lose case where value overflows in the
270 -- least significant bit or less. See B490001.
272 if Is_Out_Of_Range
(N
, Base_Type
(T
)) then
277 -- Note: we have to copy the node, to avoid problems with conformance
278 -- of very similar numbers (see ACVC tests B4A010C and B63103A).
280 Rewrite
(N
, New_Copy
(N
));
282 if not Is_Floating_Point_Type
(T
) then
284 (N
, Corresponding_Integer_Value
(N
) * Small_Value
(T
));
286 elsif not UR_Is_Zero
(Realval
(N
)) then
288 -- Note: even though RM 4.9(38) specifies biased rounding,
289 -- this has been modified by AI-100 in order to prevent
290 -- confusing differences in rounding between static and
291 -- non-static expressions. AI-100 specifies that the effect
292 -- of such rounding is implementation dependent, and in GNAT
293 -- we round to nearest even to match the run-time behavior.
296 (N
, Machine
(Base_Type
(T
), Realval
(N
), Round_Even
, N
));
299 Set_Is_Machine_Number
(N
);
302 -- Check for out of range universal integer. This is a non-static
303 -- context, so the integer value must be in range of the runtime
304 -- representation of universal integers.
306 -- We do this only within an expression, because that is the only
307 -- case in which non-static universal integer values can occur, and
308 -- furthermore, Check_Non_Static_Context is currently (incorrectly???)
309 -- called in contexts like the expression of a number declaration where
310 -- we certainly want to allow out of range values.
312 if Etype
(N
) = Universal_Integer
313 and then Nkind
(N
) = N_Integer_Literal
314 and then Nkind
(Parent
(N
)) in N_Subexpr
316 (Intval
(N
) < Expr_Value
(Type_Low_Bound
(Universal_Integer
))
318 Intval
(N
) > Expr_Value
(Type_High_Bound
(Universal_Integer
)))
320 Apply_Compile_Time_Constraint_Error
321 (N
, "non-static universal integer value out of range?",
322 CE_Range_Check_Failed
);
324 -- Check out of range of base type
326 elsif Is_Out_Of_Range
(N
, Base_Type
(T
)) then
329 -- Give warning if outside subtype (where one or both of the
330 -- bounds of the subtype is static). This warning is omitted
331 -- if the expression appears in a range that could be null
332 -- (warnings are handled elsewhere for this case).
334 elsif T
/= Base_Type
(T
)
335 and then Nkind
(Parent
(N
)) /= N_Range
337 if Is_In_Range
(N
, T
) then
340 elsif Is_Out_Of_Range
(N
, T
) then
341 Apply_Compile_Time_Constraint_Error
342 (N
, "value not in range of}?", CE_Range_Check_Failed
);
345 Enable_Range_Check
(N
);
348 Set_Do_Range_Check
(N
, False);
351 end Check_Non_Static_Context
;
353 ---------------------------------
354 -- Check_String_Literal_Length --
355 ---------------------------------
357 procedure Check_String_Literal_Length
(N
: Node_Id
; Ttype
: Entity_Id
) is
359 if not Raises_Constraint_Error
(N
)
360 and then Is_Constrained
(Ttype
)
363 UI_From_Int
(String_Length
(Strval
(N
))) /= String_Type_Len
(Ttype
)
365 Apply_Compile_Time_Constraint_Error
366 (N
, "string length wrong for}?",
367 CE_Length_Check_Failed
,
372 end Check_String_Literal_Length
;
374 --------------------------
375 -- Compile_Time_Compare --
376 --------------------------
378 function Compile_Time_Compare
380 Rec
: Boolean := False)
381 return Compare_Result
383 Ltyp
: constant Entity_Id
:= Etype
(L
);
384 Rtyp
: constant Entity_Id
:= Etype
(R
);
386 procedure Compare_Decompose
390 -- This procedure decomposes the node N into an expression node
391 -- and a signed offset, so that the value of N is equal to the
392 -- value of R plus the value V (which may be negative). If no
393 -- such decomposition is possible, then on return R is a copy
394 -- 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
398 -- with their corresponding type bounds, which we then can compare.
399 -- The argument is the original node, the result is the identity,
400 -- unless we have a 'Last/'First reference in which case the value
401 -- returned is the 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
435 if Attribute_Name
(N
) = Name_Succ
then
436 R
:= First
(Expressions
(N
));
440 elsif Attribute_Name
(N
) = Name_Pred
then
441 R
:= First
(Expressions
(N
));
449 end Compare_Decompose
;
455 function Compare_Fixup
(N
: Node_Id
) return Node_Id
is
461 if Nkind
(N
) = N_Attribute_Reference
462 and then (Attribute_Name
(N
) = Name_First
464 Attribute_Name
(N
) = Name_Last
)
466 Xtyp
:= Etype
(Prefix
(N
));
468 -- If we have no type, then just abandon the attempt to do
469 -- a fixup, this is probably the result of some other error.
475 -- Dereference an access type
477 if Is_Access_Type
(Xtyp
) then
478 Xtyp
:= Designated_Type
(Xtyp
);
481 -- If we don't have an array type at this stage, something
482 -- is peculiar, e.g. another error, and we abandon the attempt
485 if not Is_Array_Type
(Xtyp
) then
489 -- Ignore unconstrained array, since bounds are not meaningful
491 if not Is_Constrained
(Xtyp
) then
495 if Ekind
(Xtyp
) = E_String_Literal_Subtype
then
496 if Attribute_Name
(N
) = Name_First
then
497 return String_Literal_Low_Bound
(Xtyp
);
499 else -- Attribute_Name (N) = Name_Last
500 return Make_Integer_Literal
(Sloc
(N
),
501 Intval
=> Intval
(String_Literal_Low_Bound
(Xtyp
))
502 + String_Literal_Length
(Xtyp
));
506 -- Find correct index type
508 Indx
:= First_Index
(Xtyp
);
510 if Present
(Expressions
(N
)) then
511 Subs
:= UI_To_Int
(Expr_Value
(First
(Expressions
(N
))));
513 for J
in 2 .. Subs
loop
514 Indx
:= Next_Index
(Indx
);
518 Xtyp
:= Etype
(Indx
);
520 if Attribute_Name
(N
) = Name_First
then
521 return Type_Low_Bound
(Xtyp
);
523 else -- Attribute_Name (N) = Name_Last
524 return Type_High_Bound
(Xtyp
);
535 function Is_Same_Value
(L
, R
: Node_Id
) return Boolean is
536 Lf
: constant Node_Id
:= Compare_Fixup
(L
);
537 Rf
: constant Node_Id
:= Compare_Fixup
(R
);
539 function Is_Same_Subscript
(L
, R
: List_Id
) return Boolean;
540 -- L, R are the Expressions values from two attribute nodes
541 -- for First or Last attributes. Either may be set to No_List
542 -- if no expressions are present (indicating subscript 1).
543 -- The result is True if both expressions represent the same
544 -- subscript (note that one case is where one subscript is
545 -- missing and the other is explicitly set to 1).
547 -----------------------
548 -- Is_Same_Subscript --
549 -----------------------
551 function Is_Same_Subscript
(L
, R
: List_Id
) return Boolean is
557 return Expr_Value
(First
(R
)) = Uint_1
;
562 return Expr_Value
(First
(L
)) = Uint_1
;
564 return Expr_Value
(First
(L
)) = Expr_Value
(First
(R
));
567 end Is_Same_Subscript
;
569 -- Start of processing for Is_Same_Value
572 -- Values are the same if they are the same identifier and the
573 -- identifier refers to a constant object (E_Constant). This
574 -- does not however apply to Float types, since we may have two
575 -- NaN values and they should never compare equal.
577 if Nkind
(Lf
) = N_Identifier
and then Nkind
(Rf
) = N_Identifier
578 and then Entity
(Lf
) = Entity
(Rf
)
579 and then not Is_Floating_Point_Type
(Etype
(L
))
580 and then (Ekind
(Entity
(Lf
)) = E_Constant
or else
581 Ekind
(Entity
(Lf
)) = E_In_Parameter
or else
582 Ekind
(Entity
(Lf
)) = E_Loop_Parameter
)
586 -- Or if they are compile time known and identical
588 elsif Compile_Time_Known_Value
(Lf
)
590 Compile_Time_Known_Value
(Rf
)
591 and then Expr_Value
(Lf
) = Expr_Value
(Rf
)
595 -- Or if they are both 'First or 'Last values applying to the
596 -- same entity (first and last don't change even if value does)
598 elsif Nkind
(Lf
) = N_Attribute_Reference
600 Nkind
(Rf
) = N_Attribute_Reference
601 and then Attribute_Name
(Lf
) = Attribute_Name
(Rf
)
602 and then (Attribute_Name
(Lf
) = Name_First
604 Attribute_Name
(Lf
) = Name_Last
)
605 and then Is_Entity_Name
(Prefix
(Lf
))
606 and then Is_Entity_Name
(Prefix
(Rf
))
607 and then Entity
(Prefix
(Lf
)) = Entity
(Prefix
(Rf
))
608 and then Is_Same_Subscript
(Expressions
(Lf
), Expressions
(Rf
))
612 -- All other cases, we can't tell
619 -- Start of processing for Compile_Time_Compare
622 -- If either operand could raise constraint error, then we cannot
623 -- know the result at compile time (since CE may be raised!)
625 if not (Cannot_Raise_Constraint_Error
(L
)
627 Cannot_Raise_Constraint_Error
(R
))
632 -- Identical operands are most certainly equal
637 -- If expressions have no types, then do not attempt to determine
638 -- if they are the same, since something funny is going on. One
639 -- case in which this happens is during generic template analysis,
640 -- when bounds are not fully analyzed.
642 elsif No
(Ltyp
) or else No
(Rtyp
) then
645 -- We only attempt compile time analysis for scalar values, and
646 -- not for packed arrays represented as modular types, where the
647 -- semantics of comparison is quite different.
649 elsif not Is_Scalar_Type
(Ltyp
)
650 or else Is_Packed_Array_Type
(Ltyp
)
654 -- Case where comparison involves two compile time known values
656 elsif Compile_Time_Known_Value
(L
)
657 and then Compile_Time_Known_Value
(R
)
659 -- For the floating-point case, we have to be a little careful, since
660 -- at compile time we are dealing with universal exact values, but at
661 -- runtime, these will be in non-exact target form. That's why the
662 -- returned results are LE and GE below instead of LT and GT.
664 if Is_Floating_Point_Type
(Ltyp
)
666 Is_Floating_Point_Type
(Rtyp
)
669 Lo
: constant Ureal
:= Expr_Value_R
(L
);
670 Hi
: constant Ureal
:= Expr_Value_R
(R
);
682 -- For the integer case we know exactly (note that this includes the
683 -- fixed-point case, where we know the run time integer values now)
687 Lo
: constant Uint
:= Expr_Value
(L
);
688 Hi
: constant Uint
:= Expr_Value
(R
);
701 -- Cases where at least one operand is not known at compile time
704 -- Here is where we check for comparisons against maximum bounds of
705 -- types, where we know that no value can be outside the bounds of
706 -- the subtype. Note that this routine is allowed to assume that all
707 -- expressions are within their subtype bounds. Callers wishing to
708 -- deal with possibly invalid values must in any case take special
709 -- steps (e.g. conversions to larger types) to avoid this kind of
710 -- optimization, which is always considered to be valid. We do not
711 -- attempt this optimization with generic types, since the type
712 -- bounds may not be meaningful in this case.
714 -- We are in danger of an infinite recursion here. It does not seem
715 -- useful to go more than one level deep, so the parameter Rec is
716 -- used to protect ourselves against this infinite recursion.
719 and then Is_Discrete_Type
(Ltyp
)
720 and then Is_Discrete_Type
(Rtyp
)
721 and then not Is_Generic_Type
(Ltyp
)
722 and then not Is_Generic_Type
(Rtyp
)
724 -- See if we can get a decisive check against one operand and
725 -- a bound of the other operand (four possible tests here).
727 case Compile_Time_Compare
(L
, Type_Low_Bound
(Rtyp
), True) is
728 when LT
=> return LT
;
729 when LE
=> return LE
;
730 when EQ
=> return LE
;
734 case Compile_Time_Compare
(L
, Type_High_Bound
(Rtyp
), True) is
735 when GT
=> return GT
;
736 when GE
=> return GE
;
737 when EQ
=> return GE
;
741 case Compile_Time_Compare
(Type_Low_Bound
(Ltyp
), R
, True) is
742 when GT
=> return GT
;
743 when GE
=> return GE
;
744 when EQ
=> return GE
;
748 case Compile_Time_Compare
(Type_High_Bound
(Ltyp
), R
, True) is
749 when LT
=> return LT
;
750 when LE
=> return LE
;
751 when EQ
=> return LE
;
756 -- Next attempt is to decompose the expressions to extract
757 -- a constant offset resulting from the use of any of the forms:
764 -- Then we see if the two expressions are the same value, and if so
765 -- the result is obtained by comparing the offsets.
774 Compare_Decompose
(L
, Lnode
, Loffs
);
775 Compare_Decompose
(R
, Rnode
, Roffs
);
777 if Is_Same_Value
(Lnode
, Rnode
) then
778 if Loffs
= Roffs
then
781 elsif Loffs
< Roffs
then
788 -- If the expressions are different, we cannot say at compile
789 -- time how they compare, so we return the Unknown indication.
796 end Compile_Time_Compare
;
798 ------------------------------
799 -- Compile_Time_Known_Value --
800 ------------------------------
802 function Compile_Time_Known_Value
(Op
: Node_Id
) return Boolean is
803 K
: constant Node_Kind
:= Nkind
(Op
);
804 CV_Ent
: CV_Entry
renames CV_Cache
(Nat
(Op
) mod CV_Cache_Size
);
807 -- Never known at compile time if bad type or raises constraint error
808 -- or empty (latter case occurs only as a result of a previous error)
812 or else Etype
(Op
) = Any_Type
813 or else Raises_Constraint_Error
(Op
)
818 -- If this is not a static expression and we are in configurable run
819 -- time mode, then we consider it not known at compile time. This
820 -- avoids anomalies where whether something is permitted with a given
821 -- configurable run-time library depends on how good the compiler is
822 -- at optimizing and knowing that things are constant when they
825 if Configurable_Run_Time_Mode
and then not Is_Static_Expression
(Op
) then
829 -- If we have an entity name, then see if it is the name of a constant
830 -- and if so, test the corresponding constant value, or the name of
831 -- an enumeration literal, which is always a constant.
833 if Present
(Etype
(Op
)) and then Is_Entity_Name
(Op
) then
835 E
: constant Entity_Id
:= Entity
(Op
);
839 -- Never known at compile time if it is a packed array value.
840 -- We might want to try to evaluate these at compile time one
841 -- day, but we do not make that attempt now.
843 if Is_Packed_Array_Type
(Etype
(Op
)) then
847 if Ekind
(E
) = E_Enumeration_Literal
then
850 elsif Ekind
(E
) = E_Constant
then
851 V
:= Constant_Value
(E
);
852 return Present
(V
) and then Compile_Time_Known_Value
(V
);
856 -- We have a value, see if it is compile time known
859 -- Integer literals are worth storing in the cache
861 if K
= N_Integer_Literal
then
863 CV_Ent
.V
:= Intval
(Op
);
866 -- Other literals and NULL are known at compile time
869 K
= N_Character_Literal
879 -- Any reference to Null_Parameter is known at compile time. No
880 -- other attribute references (that have not already been folded)
881 -- are known at compile time.
883 elsif K
= N_Attribute_Reference
then
884 return Attribute_Name
(Op
) = Name_Null_Parameter
;
888 -- If we fall through, not known at compile time
892 -- If we get an exception while trying to do this test, then some error
893 -- has occurred, and we simply say that the value is not known after all
898 end Compile_Time_Known_Value
;
900 --------------------------------------
901 -- Compile_Time_Known_Value_Or_Aggr --
902 --------------------------------------
904 function Compile_Time_Known_Value_Or_Aggr
(Op
: Node_Id
) return Boolean is
906 -- If we have an entity name, then see if it is the name of a constant
907 -- and if so, test the corresponding constant value, or the name of
908 -- an enumeration literal, which is always a constant.
910 if Is_Entity_Name
(Op
) then
912 E
: constant Entity_Id
:= Entity
(Op
);
916 if Ekind
(E
) = E_Enumeration_Literal
then
919 elsif Ekind
(E
) /= E_Constant
then
923 V
:= Constant_Value
(E
);
925 and then Compile_Time_Known_Value_Or_Aggr
(V
);
929 -- We have a value, see if it is compile time known
932 if Compile_Time_Known_Value
(Op
) then
935 elsif Nkind
(Op
) = N_Aggregate
then
937 if Present
(Expressions
(Op
)) then
942 Expr
:= First
(Expressions
(Op
));
943 while Present
(Expr
) loop
944 if not Compile_Time_Known_Value_Or_Aggr
(Expr
) then
953 if Present
(Component_Associations
(Op
)) then
958 Cass
:= First
(Component_Associations
(Op
));
959 while Present
(Cass
) loop
961 Compile_Time_Known_Value_Or_Aggr
(Expression
(Cass
))
973 -- All other types of values are not known at compile time
980 end Compile_Time_Known_Value_Or_Aggr
;
986 -- This is only called for actuals of functions that are not predefined
987 -- operators (which have already been rewritten as operators at this
988 -- stage), so the call can never be folded, and all that needs doing for
989 -- the actual is to do the check for a non-static context.
991 procedure Eval_Actual
(N
: Node_Id
) is
993 Check_Non_Static_Context
(N
);
1000 -- Allocators are never static, so all we have to do is to do the
1001 -- check for a non-static context if an expression is present.
1003 procedure Eval_Allocator
(N
: Node_Id
) is
1004 Expr
: constant Node_Id
:= Expression
(N
);
1007 if Nkind
(Expr
) = N_Qualified_Expression
then
1008 Check_Non_Static_Context
(Expression
(Expr
));
1012 ------------------------
1013 -- Eval_Arithmetic_Op --
1014 ------------------------
1016 -- Arithmetic operations are static functions, so the result is static
1017 -- if both operands are static (RM 4.9(7), 4.9(20)).
1019 procedure Eval_Arithmetic_Op
(N
: Node_Id
) is
1020 Left
: constant Node_Id
:= Left_Opnd
(N
);
1021 Right
: constant Node_Id
:= Right_Opnd
(N
);
1022 Ltype
: constant Entity_Id
:= Etype
(Left
);
1023 Rtype
: constant Entity_Id
:= Etype
(Right
);
1028 -- If not foldable we are done
1030 Test_Expression_Is_Foldable
(N
, Left
, Right
, Stat
, Fold
);
1036 -- Fold for cases where both operands are of integer type
1038 if Is_Integer_Type
(Ltype
) and then Is_Integer_Type
(Rtype
) then
1040 Left_Int
: constant Uint
:= Expr_Value
(Left
);
1041 Right_Int
: constant Uint
:= Expr_Value
(Right
);
1048 Result
:= Left_Int
+ Right_Int
;
1050 when N_Op_Subtract
=>
1051 Result
:= Left_Int
- Right_Int
;
1053 when N_Op_Multiply
=>
1056 (Num_Bits
(Left_Int
) + Num_Bits
(Right_Int
)))
1058 Result
:= Left_Int
* Right_Int
;
1065 -- The exception Constraint_Error is raised by integer
1066 -- division, rem and mod if the right operand is zero.
1068 if Right_Int
= 0 then
1069 Apply_Compile_Time_Constraint_Error
1070 (N
, "division by zero",
1076 Result
:= Left_Int
/ Right_Int
;
1081 -- The exception Constraint_Error is raised by integer
1082 -- division, rem and mod if the right operand is zero.
1084 if Right_Int
= 0 then
1085 Apply_Compile_Time_Constraint_Error
1086 (N
, "mod with zero divisor",
1091 Result
:= Left_Int
mod Right_Int
;
1096 -- The exception Constraint_Error is raised by integer
1097 -- division, rem and mod if the right operand is zero.
1099 if Right_Int
= 0 then
1100 Apply_Compile_Time_Constraint_Error
1101 (N
, "rem with zero divisor",
1107 Result
:= Left_Int
rem Right_Int
;
1111 raise Program_Error
;
1114 -- Adjust the result by the modulus if the type is a modular type
1116 if Is_Modular_Integer_Type
(Ltype
) then
1117 Result
:= Result
mod Modulus
(Ltype
);
1120 Fold_Uint
(N
, Result
, Stat
);
1123 -- Cases where at least one operand is a real. We handle the cases
1124 -- of both reals, or mixed/real integer cases (the latter happen
1125 -- only for divide and multiply, and the result is always real).
1127 elsif Is_Real_Type
(Ltype
) or else Is_Real_Type
(Rtype
) then
1134 if Is_Real_Type
(Ltype
) then
1135 Left_Real
:= Expr_Value_R
(Left
);
1137 Left_Real
:= UR_From_Uint
(Expr_Value
(Left
));
1140 if Is_Real_Type
(Rtype
) then
1141 Right_Real
:= Expr_Value_R
(Right
);
1143 Right_Real
:= UR_From_Uint
(Expr_Value
(Right
));
1146 if Nkind
(N
) = N_Op_Add
then
1147 Result
:= Left_Real
+ Right_Real
;
1149 elsif Nkind
(N
) = N_Op_Subtract
then
1150 Result
:= Left_Real
- Right_Real
;
1152 elsif Nkind
(N
) = N_Op_Multiply
then
1153 Result
:= Left_Real
* Right_Real
;
1155 else pragma Assert
(Nkind
(N
) = N_Op_Divide
);
1156 if UR_Is_Zero
(Right_Real
) then
1157 Apply_Compile_Time_Constraint_Error
1158 (N
, "division by zero", CE_Divide_By_Zero
);
1162 Result
:= Left_Real
/ Right_Real
;
1165 Fold_Ureal
(N
, Result
, Stat
);
1168 end Eval_Arithmetic_Op
;
1170 ----------------------------
1171 -- Eval_Character_Literal --
1172 ----------------------------
1174 -- Nothing to be done!
1176 procedure Eval_Character_Literal
(N
: Node_Id
) is
1177 pragma Warnings
(Off
, N
);
1181 end Eval_Character_Literal
;
1183 ------------------------
1184 -- Eval_Concatenation --
1185 ------------------------
1187 -- Concatenation is a static function, so the result is static if
1188 -- both operands are static (RM 4.9(7), 4.9(21)).
1190 procedure Eval_Concatenation
(N
: Node_Id
) is
1191 Left
: constant Node_Id
:= Left_Opnd
(N
);
1192 Right
: constant Node_Id
:= Right_Opnd
(N
);
1193 C_Typ
: constant Entity_Id
:= Root_Type
(Component_Type
(Etype
(N
)));
1198 -- Concatenation is never static in Ada 83, so if Ada 83
1199 -- check operand non-static context
1202 and then Comes_From_Source
(N
)
1204 Check_Non_Static_Context
(Left
);
1205 Check_Non_Static_Context
(Right
);
1209 -- If not foldable we are done. In principle concatenation that yields
1210 -- any string type is static (i.e. an array type of character types).
1211 -- However, character types can include enumeration literals, and
1212 -- concatenation in that case cannot be described by a literal, so we
1213 -- only consider the operation static if the result is an array of
1214 -- (a descendant of) a predefined character type.
1216 Test_Expression_Is_Foldable
(N
, Left
, Right
, Stat
, Fold
);
1218 if (C_Typ
= Standard_Character
1219 or else C_Typ
= Standard_Wide_Character
)
1224 Set_Is_Static_Expression
(N
, False);
1228 -- Compile time string concatenation.
1230 -- ??? Note that operands that are aggregates can be marked as
1231 -- static, so we should attempt at a later stage to fold
1232 -- concatenations with such aggregates.
1235 Left_Str
: constant Node_Id
:= Get_String_Val
(Left
);
1237 Right_Str
: constant Node_Id
:= Get_String_Val
(Right
);
1240 -- Establish new string literal, and store left operand. We make
1241 -- sure to use the special Start_String that takes an operand if
1242 -- the left operand is a string literal. Since this is optimized
1243 -- in the case where that is the most recently created string
1244 -- literal, we ensure efficient time/space behavior for the
1245 -- case of a concatenation of a series of string literals.
1247 if Nkind
(Left_Str
) = N_String_Literal
then
1248 Left_Len
:= String_Length
(Strval
(Left_Str
));
1249 Start_String
(Strval
(Left_Str
));
1252 Store_String_Char
(Char_Literal_Value
(Left_Str
));
1256 -- Now append the characters of the right operand
1258 if Nkind
(Right_Str
) = N_String_Literal
then
1260 S
: constant String_Id
:= Strval
(Right_Str
);
1263 for J
in 1 .. String_Length
(S
) loop
1264 Store_String_Char
(Get_String_Char
(S
, J
));
1268 Store_String_Char
(Char_Literal_Value
(Right_Str
));
1271 Set_Is_Static_Expression
(N
, Stat
);
1275 -- If left operand is the empty string, the result is the
1276 -- right operand, including its bounds if anomalous.
1279 and then Is_Array_Type
(Etype
(Right
))
1280 and then Etype
(Right
) /= Any_String
1282 Set_Etype
(N
, Etype
(Right
));
1285 Fold_Str
(N
, End_String
, True);
1288 end Eval_Concatenation
;
1290 ---------------------------------
1291 -- Eval_Conditional_Expression --
1292 ---------------------------------
1294 -- This GNAT internal construct can never be statically folded, so the
1295 -- only required processing is to do the check for non-static context
1296 -- for the two expression operands.
1298 procedure Eval_Conditional_Expression
(N
: Node_Id
) is
1299 Condition
: constant Node_Id
:= First
(Expressions
(N
));
1300 Then_Expr
: constant Node_Id
:= Next
(Condition
);
1301 Else_Expr
: constant Node_Id
:= Next
(Then_Expr
);
1304 Check_Non_Static_Context
(Then_Expr
);
1305 Check_Non_Static_Context
(Else_Expr
);
1306 end Eval_Conditional_Expression
;
1308 ----------------------
1309 -- Eval_Entity_Name --
1310 ----------------------
1312 -- This procedure is used for identifiers and expanded names other than
1313 -- named numbers (see Eval_Named_Integer, Eval_Named_Real. These are
1314 -- static if they denote a static constant (RM 4.9(6)) or if the name
1315 -- denotes an enumeration literal (RM 4.9(22)).
1317 procedure Eval_Entity_Name
(N
: Node_Id
) is
1318 Def_Id
: constant Entity_Id
:= Entity
(N
);
1322 -- Enumeration literals are always considered to be constants
1323 -- and cannot raise constraint error (RM 4.9(22)).
1325 if Ekind
(Def_Id
) = E_Enumeration_Literal
then
1326 Set_Is_Static_Expression
(N
);
1329 -- A name is static if it denotes a static constant (RM 4.9(5)), and
1330 -- we also copy Raise_Constraint_Error. Notice that even if non-static,
1331 -- it does not violate 10.2.1(8) here, since this is not a variable.
1333 elsif Ekind
(Def_Id
) = E_Constant
then
1335 -- Deferred constants must always be treated as nonstatic
1336 -- outside the scope of their full view.
1338 if Present
(Full_View
(Def_Id
))
1339 and then not In_Open_Scopes
(Scope
(Def_Id
))
1343 Val
:= Constant_Value
(Def_Id
);
1346 if Present
(Val
) then
1347 Set_Is_Static_Expression
1348 (N
, Is_Static_Expression
(Val
)
1349 and then Is_Static_Subtype
(Etype
(Def_Id
)));
1350 Set_Raises_Constraint_Error
(N
, Raises_Constraint_Error
(Val
));
1352 if not Is_Static_Expression
(N
)
1353 and then not Is_Generic_Type
(Etype
(N
))
1355 Validate_Static_Object_Name
(N
);
1362 -- Fall through if the name is not static.
1364 Validate_Static_Object_Name
(N
);
1365 end Eval_Entity_Name
;
1367 ----------------------------
1368 -- Eval_Indexed_Component --
1369 ----------------------------
1371 -- Indexed components are never static, so we need to perform the check
1372 -- for non-static context on the index values. Then, we check if the
1373 -- value can be obtained at compile time, even though it is non-static.
1375 procedure Eval_Indexed_Component
(N
: Node_Id
) is
1379 -- Check for non-static context on index values
1381 Expr
:= First
(Expressions
(N
));
1382 while Present
(Expr
) loop
1383 Check_Non_Static_Context
(Expr
);
1387 -- If the indexed component appears in an object renaming declaration
1388 -- then we do not want to try to evaluate it, since in this case we
1389 -- need the identity of the array element.
1391 if Nkind
(Parent
(N
)) = N_Object_Renaming_Declaration
then
1394 -- Similarly if the indexed component appears as the prefix of an
1395 -- attribute we don't want to evaluate it, because at least for
1396 -- some cases of attributes we need the identify (e.g. Access, Size)
1398 elsif Nkind
(Parent
(N
)) = N_Attribute_Reference
then
1402 -- Note: there are other cases, such as the left side of an assignment,
1403 -- or an OUT parameter for a call, where the replacement results in the
1404 -- illegal use of a constant, But these cases are illegal in the first
1405 -- place, so the replacement, though silly, is harmless.
1407 -- Now see if this is a constant array reference
1409 if List_Length
(Expressions
(N
)) = 1
1410 and then Is_Entity_Name
(Prefix
(N
))
1411 and then Ekind
(Entity
(Prefix
(N
))) = E_Constant
1412 and then Present
(Constant_Value
(Entity
(Prefix
(N
))))
1415 Loc
: constant Source_Ptr
:= Sloc
(N
);
1416 Arr
: constant Node_Id
:= Constant_Value
(Entity
(Prefix
(N
)));
1417 Sub
: constant Node_Id
:= First
(Expressions
(N
));
1423 -- Linear one's origin subscript value for array reference
1426 -- Lower bound of the first array index
1429 -- Value from constant array
1432 Atyp
:= Etype
(Arr
);
1434 if Is_Access_Type
(Atyp
) then
1435 Atyp
:= Designated_Type
(Atyp
);
1438 -- If we have an array type (we should have but perhaps there
1439 -- are error cases where this is not the case), then see if we
1440 -- can do a constant evaluation of the array reference.
1442 if Is_Array_Type
(Atyp
) then
1443 if Ekind
(Atyp
) = E_String_Literal_Subtype
then
1444 Lbd
:= String_Literal_Low_Bound
(Atyp
);
1446 Lbd
:= Type_Low_Bound
(Etype
(First_Index
(Atyp
)));
1449 if Compile_Time_Known_Value
(Sub
)
1450 and then Nkind
(Arr
) = N_Aggregate
1451 and then Compile_Time_Known_Value
(Lbd
)
1452 and then Is_Discrete_Type
(Component_Type
(Atyp
))
1454 Lin
:= UI_To_Int
(Expr_Value
(Sub
) - Expr_Value
(Lbd
)) + 1;
1456 if List_Length
(Expressions
(Arr
)) >= Lin
then
1457 Elm
:= Pick
(Expressions
(Arr
), Lin
);
1459 -- If the resulting expression is compile time known,
1460 -- then we can rewrite the indexed component with this
1461 -- value, being sure to mark the result as non-static.
1462 -- We also reset the Sloc, in case this generates an
1463 -- error later on (e.g. 136'Access).
1465 if Compile_Time_Known_Value
(Elm
) then
1466 Rewrite
(N
, Duplicate_Subexpr_No_Checks
(Elm
));
1467 Set_Is_Static_Expression
(N
, False);
1475 end Eval_Indexed_Component
;
1477 --------------------------
1478 -- Eval_Integer_Literal --
1479 --------------------------
1481 -- Numeric literals are static (RM 4.9(1)), and have already been marked
1482 -- as static by the analyzer. The reason we did it that early is to allow
1483 -- the possibility of turning off the Is_Static_Expression flag after
1484 -- analysis, but before resolution, when integer literals are generated
1485 -- in the expander that do not correspond to static expressions.
1487 procedure Eval_Integer_Literal
(N
: Node_Id
) is
1488 T
: constant Entity_Id
:= Etype
(N
);
1491 -- If the literal appears in a non-expression context, then it is
1492 -- certainly appearing in a non-static context, so check it. This
1493 -- is actually a redundant check, since Check_Non_Static_Context
1494 -- would check it, but it seems worth while avoiding the call.
1496 if Nkind
(Parent
(N
)) not in N_Subexpr
then
1497 Check_Non_Static_Context
(N
);
1500 -- Modular integer literals must be in their base range
1502 if Is_Modular_Integer_Type
(T
)
1503 and then Is_Out_Of_Range
(N
, Base_Type
(T
))
1507 end Eval_Integer_Literal
;
1509 ---------------------
1510 -- Eval_Logical_Op --
1511 ---------------------
1513 -- Logical operations are static functions, so the result is potentially
1514 -- static if both operands are potentially static (RM 4.9(7), 4.9(20)).
1516 procedure Eval_Logical_Op
(N
: Node_Id
) is
1517 Left
: constant Node_Id
:= Left_Opnd
(N
);
1518 Right
: constant Node_Id
:= Right_Opnd
(N
);
1523 -- If not foldable we are done
1525 Test_Expression_Is_Foldable
(N
, Left
, Right
, Stat
, Fold
);
1531 -- Compile time evaluation of logical operation
1534 Left_Int
: constant Uint
:= Expr_Value
(Left
);
1535 Right_Int
: constant Uint
:= Expr_Value
(Right
);
1538 if Is_Modular_Integer_Type
(Etype
(N
)) then
1540 Left_Bits
: Bits
(0 .. UI_To_Int
(Esize
(Etype
(N
))) - 1);
1541 Right_Bits
: Bits
(0 .. UI_To_Int
(Esize
(Etype
(N
))) - 1);
1544 To_Bits
(Left_Int
, Left_Bits
);
1545 To_Bits
(Right_Int
, Right_Bits
);
1547 -- Note: should really be able to use array ops instead of
1548 -- these loops, but they weren't working at the time ???
1550 if Nkind
(N
) = N_Op_And
then
1551 for J
in Left_Bits
'Range loop
1552 Left_Bits
(J
) := Left_Bits
(J
) and Right_Bits
(J
);
1555 elsif Nkind
(N
) = N_Op_Or
then
1556 for J
in Left_Bits
'Range loop
1557 Left_Bits
(J
) := Left_Bits
(J
) or Right_Bits
(J
);
1561 pragma Assert
(Nkind
(N
) = N_Op_Xor
);
1563 for J
in Left_Bits
'Range loop
1564 Left_Bits
(J
) := Left_Bits
(J
) xor Right_Bits
(J
);
1568 Fold_Uint
(N
, From_Bits
(Left_Bits
, Etype
(N
)), Stat
);
1572 pragma Assert
(Is_Boolean_Type
(Etype
(N
)));
1574 if Nkind
(N
) = N_Op_And
then
1576 Test
(Is_True
(Left_Int
) and then Is_True
(Right_Int
)), Stat
);
1578 elsif Nkind
(N
) = N_Op_Or
then
1580 Test
(Is_True
(Left_Int
) or else Is_True
(Right_Int
)), Stat
);
1583 pragma Assert
(Nkind
(N
) = N_Op_Xor
);
1585 Test
(Is_True
(Left_Int
) xor Is_True
(Right_Int
)), Stat
);
1589 end Eval_Logical_Op
;
1591 ------------------------
1592 -- Eval_Membership_Op --
1593 ------------------------
1595 -- A membership test is potentially static if the expression is static,
1596 -- and the range is a potentially static range, or is a subtype mark
1597 -- denoting a static subtype (RM 4.9(12)).
1599 procedure Eval_Membership_Op
(N
: Node_Id
) is
1600 Left
: constant Node_Id
:= Left_Opnd
(N
);
1601 Right
: constant Node_Id
:= Right_Opnd
(N
);
1610 -- Ignore if error in either operand, except to make sure that
1611 -- Any_Type is properly propagated to avoid junk cascaded errors.
1613 if Etype
(Left
) = Any_Type
1614 or else Etype
(Right
) = Any_Type
1616 Set_Etype
(N
, Any_Type
);
1620 -- Case of right operand is a subtype name
1622 if Is_Entity_Name
(Right
) then
1623 Def_Id
:= Entity
(Right
);
1625 if (Is_Scalar_Type
(Def_Id
) or else Is_String_Type
(Def_Id
))
1626 and then Is_OK_Static_Subtype
(Def_Id
)
1628 Test_Expression_Is_Foldable
(N
, Left
, Stat
, Fold
);
1630 if not Fold
or else not Stat
then
1634 Check_Non_Static_Context
(Left
);
1638 -- For string membership tests we will check the length
1641 if not Is_String_Type
(Def_Id
) then
1642 Lo
:= Type_Low_Bound
(Def_Id
);
1643 Hi
:= Type_High_Bound
(Def_Id
);
1650 -- Case of right operand is a range
1653 if Is_Static_Range
(Right
) then
1654 Test_Expression_Is_Foldable
(N
, Left
, Stat
, Fold
);
1656 if not Fold
or else not Stat
then
1659 -- If one bound of range raises CE, then don't try to fold
1661 elsif not Is_OK_Static_Range
(Right
) then
1662 Check_Non_Static_Context
(Left
);
1667 Check_Non_Static_Context
(Left
);
1671 -- Here we know range is an OK static range
1673 Lo
:= Low_Bound
(Right
);
1674 Hi
:= High_Bound
(Right
);
1677 -- For strings we check that the length of the string expression is
1678 -- compatible with the string subtype if the subtype is constrained,
1679 -- or if unconstrained then the test is always true.
1681 if Is_String_Type
(Etype
(Right
)) then
1682 if not Is_Constrained
(Etype
(Right
)) then
1687 Typlen
: constant Uint
:= String_Type_Len
(Etype
(Right
));
1688 Strlen
: constant Uint
:=
1689 UI_From_Int
(String_Length
(Strval
(Get_String_Val
(Left
))));
1691 Result
:= (Typlen
= Strlen
);
1695 -- Fold the membership test. We know we have a static range and Lo
1696 -- and Hi are set to the expressions for the end points of this range.
1698 elsif Is_Real_Type
(Etype
(Right
)) then
1700 Leftval
: constant Ureal
:= Expr_Value_R
(Left
);
1703 Result
:= Expr_Value_R
(Lo
) <= Leftval
1704 and then Leftval
<= Expr_Value_R
(Hi
);
1709 Leftval
: constant Uint
:= Expr_Value
(Left
);
1712 Result
:= Expr_Value
(Lo
) <= Leftval
1713 and then Leftval
<= Expr_Value
(Hi
);
1717 if Nkind
(N
) = N_Not_In
then
1718 Result
:= not Result
;
1721 Fold_Uint
(N
, Test
(Result
), True);
1722 Warn_On_Known_Condition
(N
);
1723 end Eval_Membership_Op
;
1725 ------------------------
1726 -- Eval_Named_Integer --
1727 ------------------------
1729 procedure Eval_Named_Integer
(N
: Node_Id
) is
1732 Expr_Value
(Expression
(Declaration_Node
(Entity
(N
)))), True);
1733 end Eval_Named_Integer
;
1735 ---------------------
1736 -- Eval_Named_Real --
1737 ---------------------
1739 procedure Eval_Named_Real
(N
: Node_Id
) is
1742 Expr_Value_R
(Expression
(Declaration_Node
(Entity
(N
)))), True);
1743 end Eval_Named_Real
;
1749 -- Exponentiation is a static functions, so the result is potentially
1750 -- static if both operands are potentially static (RM 4.9(7), 4.9(20)).
1752 procedure Eval_Op_Expon
(N
: Node_Id
) is
1753 Left
: constant Node_Id
:= Left_Opnd
(N
);
1754 Right
: constant Node_Id
:= Right_Opnd
(N
);
1759 -- If not foldable we are done
1761 Test_Expression_Is_Foldable
(N
, Left
, Right
, Stat
, Fold
);
1767 -- Fold exponentiation operation
1770 Right_Int
: constant Uint
:= Expr_Value
(Right
);
1775 if Is_Integer_Type
(Etype
(Left
)) then
1777 Left_Int
: constant Uint
:= Expr_Value
(Left
);
1781 -- Exponentiation of an integer raises the exception
1782 -- Constraint_Error for a negative exponent (RM 4.5.6)
1784 if Right_Int
< 0 then
1785 Apply_Compile_Time_Constraint_Error
1786 (N
, "integer exponent negative",
1787 CE_Range_Check_Failed
,
1792 if OK_Bits
(N
, Num_Bits
(Left_Int
) * Right_Int
) then
1793 Result
:= Left_Int
** Right_Int
;
1798 if Is_Modular_Integer_Type
(Etype
(N
)) then
1799 Result
:= Result
mod Modulus
(Etype
(N
));
1802 Fold_Uint
(N
, Result
, Stat
);
1810 Left_Real
: constant Ureal
:= Expr_Value_R
(Left
);
1813 -- Cannot have a zero base with a negative exponent
1815 if UR_Is_Zero
(Left_Real
) then
1817 if Right_Int
< 0 then
1818 Apply_Compile_Time_Constraint_Error
1819 (N
, "zero ** negative integer",
1820 CE_Range_Check_Failed
,
1824 Fold_Ureal
(N
, Ureal_0
, Stat
);
1828 Fold_Ureal
(N
, Left_Real
** Right_Int
, Stat
);
1839 -- The not operation is a static functions, so the result is potentially
1840 -- static if the operand is potentially static (RM 4.9(7), 4.9(20)).
1842 procedure Eval_Op_Not
(N
: Node_Id
) is
1843 Right
: constant Node_Id
:= Right_Opnd
(N
);
1848 -- If not foldable we are done
1850 Test_Expression_Is_Foldable
(N
, Right
, Stat
, Fold
);
1856 -- Fold not operation
1859 Rint
: constant Uint
:= Expr_Value
(Right
);
1860 Typ
: constant Entity_Id
:= Etype
(N
);
1863 -- Negation is equivalent to subtracting from the modulus minus
1864 -- one. For a binary modulus this is equivalent to the ones-
1865 -- component of the original value. For non-binary modulus this
1866 -- is an arbitrary but consistent definition.
1868 if Is_Modular_Integer_Type
(Typ
) then
1869 Fold_Uint
(N
, Modulus
(Typ
) - 1 - Rint
, Stat
);
1872 pragma Assert
(Is_Boolean_Type
(Typ
));
1873 Fold_Uint
(N
, Test
(not Is_True
(Rint
)), Stat
);
1876 Set_Is_Static_Expression
(N
, Stat
);
1880 -------------------------------
1881 -- Eval_Qualified_Expression --
1882 -------------------------------
1884 -- A qualified expression is potentially static if its subtype mark denotes
1885 -- a static subtype and its expression is potentially static (RM 4.9 (11)).
1887 procedure Eval_Qualified_Expression
(N
: Node_Id
) is
1888 Operand
: constant Node_Id
:= Expression
(N
);
1889 Target_Type
: constant Entity_Id
:= Entity
(Subtype_Mark
(N
));
1896 -- Can only fold if target is string or scalar and subtype is static
1897 -- Also, do not fold if our parent is an allocator (this is because
1898 -- the qualified expression is really part of the syntactic structure
1899 -- of an allocator, and we do not want to end up with something that
1900 -- corresponds to "new 1" where the 1 is the result of folding a
1901 -- qualified expression).
1903 if not Is_Static_Subtype
(Target_Type
)
1904 or else Nkind
(Parent
(N
)) = N_Allocator
1906 Check_Non_Static_Context
(Operand
);
1910 -- If not foldable we are done
1912 Test_Expression_Is_Foldable
(N
, Operand
, Stat
, Fold
);
1917 -- Don't try fold if target type has constraint error bounds
1919 elsif not Is_OK_Static_Subtype
(Target_Type
) then
1920 Set_Raises_Constraint_Error
(N
);
1924 -- Here we will fold, save Print_In_Hex indication
1926 Hex
:= Nkind
(Operand
) = N_Integer_Literal
1927 and then Print_In_Hex
(Operand
);
1929 -- Fold the result of qualification
1931 if Is_Discrete_Type
(Target_Type
) then
1932 Fold_Uint
(N
, Expr_Value
(Operand
), Stat
);
1934 -- Preserve Print_In_Hex indication
1936 if Hex
and then Nkind
(N
) = N_Integer_Literal
then
1937 Set_Print_In_Hex
(N
);
1940 elsif Is_Real_Type
(Target_Type
) then
1941 Fold_Ureal
(N
, Expr_Value_R
(Operand
), Stat
);
1944 Fold_Str
(N
, Strval
(Get_String_Val
(Operand
)), Stat
);
1947 Set_Is_Static_Expression
(N
, False);
1949 Check_String_Literal_Length
(N
, Target_Type
);
1955 -- The expression may be foldable but not static
1957 Set_Is_Static_Expression
(N
, Stat
);
1959 if Is_Out_Of_Range
(N
, Etype
(N
)) then
1962 end Eval_Qualified_Expression
;
1964 -----------------------
1965 -- Eval_Real_Literal --
1966 -----------------------
1968 -- Numeric literals are static (RM 4.9(1)), and have already been marked
1969 -- as static by the analyzer. The reason we did it that early is to allow
1970 -- the possibility of turning off the Is_Static_Expression flag after
1971 -- analysis, but before resolution, when integer literals are generated
1972 -- in the expander that do not correspond to static expressions.
1974 procedure Eval_Real_Literal
(N
: Node_Id
) is
1976 -- If the literal appears in a non-expression context, then it is
1977 -- certainly appearing in a non-static context, so check it.
1979 if Nkind
(Parent
(N
)) not in N_Subexpr
then
1980 Check_Non_Static_Context
(N
);
1983 end Eval_Real_Literal
;
1985 ------------------------
1986 -- Eval_Relational_Op --
1987 ------------------------
1989 -- Relational operations are static functions, so the result is static
1990 -- if both operands are static (RM 4.9(7), 4.9(20)).
1992 procedure Eval_Relational_Op
(N
: Node_Id
) is
1993 Left
: constant Node_Id
:= Left_Opnd
(N
);
1994 Right
: constant Node_Id
:= Right_Opnd
(N
);
1995 Typ
: constant Entity_Id
:= Etype
(Left
);
2001 -- One special case to deal with first. If we can tell that
2002 -- the result will be false because the lengths of one or
2003 -- more index subtypes are compile time known and different,
2004 -- then we can replace the entire result by False. We only
2005 -- do this for one dimensional arrays, because the case of
2006 -- multi-dimensional arrays is rare and too much trouble!
2008 if Is_Array_Type
(Typ
)
2009 and then Number_Dimensions
(Typ
) = 1
2010 and then (Nkind
(N
) = N_Op_Eq
2011 or else Nkind
(N
) = N_Op_Ne
)
2013 if Raises_Constraint_Error
(Left
)
2014 or else Raises_Constraint_Error
(Right
)
2020 procedure Get_Static_Length
(Op
: Node_Id
; Len
: out Uint
);
2021 -- If Op is an expression for a constrained array with a
2022 -- known at compile time length, then Len is set to this
2023 -- (non-negative length). Otherwise Len is set to minus 1.
2025 -----------------------
2026 -- Get_Static_Length --
2027 -----------------------
2029 procedure Get_Static_Length
(Op
: Node_Id
; Len
: out Uint
) is
2033 if Nkind
(Op
) = N_String_Literal
then
2034 Len
:= UI_From_Int
(String_Length
(Strval
(Op
)));
2036 elsif not Is_Constrained
(Etype
(Op
)) then
2037 Len
:= Uint_Minus_1
;
2040 T
:= Etype
(First_Index
(Etype
(Op
)));
2042 if Is_Discrete_Type
(T
)
2044 Compile_Time_Known_Value
(Type_Low_Bound
(T
))
2046 Compile_Time_Known_Value
(Type_High_Bound
(T
))
2048 Len
:= UI_Max
(Uint_0
,
2049 Expr_Value
(Type_High_Bound
(T
)) -
2050 Expr_Value
(Type_Low_Bound
(T
)) + 1);
2052 Len
:= Uint_Minus_1
;
2055 end Get_Static_Length
;
2061 Get_Static_Length
(Left
, Len_L
);
2062 Get_Static_Length
(Right
, Len_R
);
2064 if Len_L
/= Uint_Minus_1
2065 and then Len_R
/= Uint_Minus_1
2066 and then Len_L
/= Len_R
2068 Fold_Uint
(N
, Test
(Nkind
(N
) = N_Op_Ne
), False);
2069 Warn_On_Known_Condition
(N
);
2075 -- Can only fold if type is scalar (don't fold string ops)
2077 if not Is_Scalar_Type
(Typ
) then
2078 Check_Non_Static_Context
(Left
);
2079 Check_Non_Static_Context
(Right
);
2083 -- If not foldable we are done
2085 Test_Expression_Is_Foldable
(N
, Left
, Right
, Stat
, Fold
);
2091 -- Integer and Enumeration (discrete) type cases
2093 if Is_Discrete_Type
(Typ
) then
2095 Left_Int
: constant Uint
:= Expr_Value
(Left
);
2096 Right_Int
: constant Uint
:= Expr_Value
(Right
);
2100 when N_Op_Eq
=> Result
:= Left_Int
= Right_Int
;
2101 when N_Op_Ne
=> Result
:= Left_Int
/= Right_Int
;
2102 when N_Op_Lt
=> Result
:= Left_Int
< Right_Int
;
2103 when N_Op_Le
=> Result
:= Left_Int
<= Right_Int
;
2104 when N_Op_Gt
=> Result
:= Left_Int
> Right_Int
;
2105 when N_Op_Ge
=> Result
:= Left_Int
>= Right_Int
;
2108 raise Program_Error
;
2111 Fold_Uint
(N
, Test
(Result
), Stat
);
2117 pragma Assert
(Is_Real_Type
(Typ
));
2120 Left_Real
: constant Ureal
:= Expr_Value_R
(Left
);
2121 Right_Real
: constant Ureal
:= Expr_Value_R
(Right
);
2125 when N_Op_Eq
=> Result
:= (Left_Real
= Right_Real
);
2126 when N_Op_Ne
=> Result
:= (Left_Real
/= Right_Real
);
2127 when N_Op_Lt
=> Result
:= (Left_Real
< Right_Real
);
2128 when N_Op_Le
=> Result
:= (Left_Real
<= Right_Real
);
2129 when N_Op_Gt
=> Result
:= (Left_Real
> Right_Real
);
2130 when N_Op_Ge
=> Result
:= (Left_Real
>= Right_Real
);
2133 raise Program_Error
;
2136 Fold_Uint
(N
, Test
(Result
), Stat
);
2140 Warn_On_Known_Condition
(N
);
2141 end Eval_Relational_Op
;
2147 -- Shift operations are intrinsic operations that can never be static,
2148 -- so the only processing required is to perform the required check for
2149 -- a non static context for the two operands.
2151 -- Actually we could do some compile time evaluation here some time ???
2153 procedure Eval_Shift
(N
: Node_Id
) is
2155 Check_Non_Static_Context
(Left_Opnd
(N
));
2156 Check_Non_Static_Context
(Right_Opnd
(N
));
2159 ------------------------
2160 -- Eval_Short_Circuit --
2161 ------------------------
2163 -- A short circuit operation is potentially static if both operands
2164 -- are potentially static (RM 4.9 (13))
2166 procedure Eval_Short_Circuit
(N
: Node_Id
) is
2167 Kind
: constant Node_Kind
:= Nkind
(N
);
2168 Left
: constant Node_Id
:= Left_Opnd
(N
);
2169 Right
: constant Node_Id
:= Right_Opnd
(N
);
2171 Rstat
: constant Boolean :=
2172 Is_Static_Expression
(Left
)
2173 and then Is_Static_Expression
(Right
);
2176 -- Short circuit operations are never static in Ada 83
2179 and then Comes_From_Source
(N
)
2181 Check_Non_Static_Context
(Left
);
2182 Check_Non_Static_Context
(Right
);
2186 -- Now look at the operands, we can't quite use the normal call to
2187 -- Test_Expression_Is_Foldable here because short circuit operations
2188 -- are a special case, they can still be foldable, even if the right
2189 -- operand raises constraint error.
2191 -- If either operand is Any_Type, just propagate to result and
2192 -- do not try to fold, this prevents cascaded errors.
2194 if Etype
(Left
) = Any_Type
or else Etype
(Right
) = Any_Type
then
2195 Set_Etype
(N
, Any_Type
);
2198 -- If left operand raises constraint error, then replace node N with
2199 -- the raise constraint error node, and we are obviously not foldable.
2200 -- Is_Static_Expression is set from the two operands in the normal way,
2201 -- and we check the right operand if it is in a non-static context.
2203 elsif Raises_Constraint_Error
(Left
) then
2205 Check_Non_Static_Context
(Right
);
2208 Rewrite_In_Raise_CE
(N
, Left
);
2209 Set_Is_Static_Expression
(N
, Rstat
);
2212 -- If the result is not static, then we won't in any case fold
2214 elsif not Rstat
then
2215 Check_Non_Static_Context
(Left
);
2216 Check_Non_Static_Context
(Right
);
2220 -- Here the result is static, note that, unlike the normal processing
2221 -- in Test_Expression_Is_Foldable, we did *not* check above to see if
2222 -- the right operand raises constraint error, that's because it is not
2223 -- significant if the left operand is decisive.
2225 Set_Is_Static_Expression
(N
);
2227 -- It does not matter if the right operand raises constraint error if
2228 -- it will not be evaluated. So deal specially with the cases where
2229 -- the right operand is not evaluated. Note that we will fold these
2230 -- cases even if the right operand is non-static, which is fine, but
2231 -- of course in these cases the result is not potentially static.
2233 Left_Int
:= Expr_Value
(Left
);
2235 if (Kind
= N_And_Then
and then Is_False
(Left_Int
))
2236 or else (Kind
= N_Or_Else
and Is_True
(Left_Int
))
2238 Fold_Uint
(N
, Left_Int
, Rstat
);
2242 -- If first operand not decisive, then it does matter if the right
2243 -- operand raises constraint error, since it will be evaluated, so
2244 -- we simply replace the node with the right operand. Note that this
2245 -- properly propagates Is_Static_Expression and Raises_Constraint_Error
2246 -- (both are set to True in Right).
2248 if Raises_Constraint_Error
(Right
) then
2249 Rewrite_In_Raise_CE
(N
, Right
);
2250 Check_Non_Static_Context
(Left
);
2254 -- Otherwise the result depends on the right operand
2256 Fold_Uint
(N
, Expr_Value
(Right
), Rstat
);
2258 end Eval_Short_Circuit
;
2264 -- Slices can never be static, so the only processing required is to
2265 -- check for non-static context if an explicit range is given.
2267 procedure Eval_Slice
(N
: Node_Id
) is
2268 Drange
: constant Node_Id
:= Discrete_Range
(N
);
2271 if Nkind
(Drange
) = N_Range
then
2272 Check_Non_Static_Context
(Low_Bound
(Drange
));
2273 Check_Non_Static_Context
(High_Bound
(Drange
));
2277 -------------------------
2278 -- Eval_String_Literal --
2279 -------------------------
2281 procedure Eval_String_Literal
(N
: Node_Id
) is
2282 T
: constant Entity_Id
:= Etype
(N
);
2283 B
: constant Entity_Id
:= Base_Type
(T
);
2287 -- Nothing to do if error type (handles cases like default expressions
2288 -- or generics where we have not yet fully resolved the type)
2290 if B
= Any_Type
or else B
= Any_String
then
2293 -- String literals are static if the subtype is static (RM 4.9(2)), so
2294 -- reset the static expression flag (it was set unconditionally in
2295 -- Analyze_String_Literal) if the subtype is non-static. We tell if
2296 -- the subtype is static by looking at the lower bound.
2298 elsif not Is_OK_Static_Expression
(String_Literal_Low_Bound
(T
)) then
2299 Set_Is_Static_Expression
(N
, False);
2301 elsif Nkind
(Original_Node
(N
)) = N_Type_Conversion
then
2302 Set_Is_Static_Expression
(N
, False);
2304 -- Test for illegal Ada 95 cases. A string literal is illegal in
2305 -- Ada 95 if its bounds are outside the index base type and this
2306 -- index type is static. This can hapen in only two ways. Either
2307 -- the string literal is too long, or it is null, and the lower
2308 -- bound is type'First. In either case it is the upper bound that
2309 -- is out of range of the index type.
2312 if Root_Type
(B
) = Standard_String
2313 or else Root_Type
(B
) = Standard_Wide_String
2315 I
:= Standard_Positive
;
2317 I
:= Etype
(First_Index
(B
));
2320 if String_Literal_Length
(T
) > String_Type_Len
(B
) then
2321 Apply_Compile_Time_Constraint_Error
2322 (N
, "string literal too long for}", CE_Length_Check_Failed
,
2324 Typ
=> First_Subtype
(B
));
2326 elsif String_Literal_Length
(T
) = 0
2327 and then not Is_Generic_Type
(I
)
2328 and then Expr_Value
(String_Literal_Low_Bound
(T
)) =
2329 Expr_Value
(Type_Low_Bound
(Base_Type
(I
)))
2331 Apply_Compile_Time_Constraint_Error
2332 (N
, "null string literal not allowed for}",
2333 CE_Length_Check_Failed
,
2335 Typ
=> First_Subtype
(B
));
2339 end Eval_String_Literal
;
2341 --------------------------
2342 -- Eval_Type_Conversion --
2343 --------------------------
2345 -- A type conversion is potentially static if its subtype mark is for a
2346 -- static scalar subtype, and its operand expression is potentially static
2349 procedure Eval_Type_Conversion
(N
: Node_Id
) is
2350 Operand
: constant Node_Id
:= Expression
(N
);
2351 Source_Type
: constant Entity_Id
:= Etype
(Operand
);
2352 Target_Type
: constant Entity_Id
:= Etype
(N
);
2357 function To_Be_Treated_As_Integer
(T
: Entity_Id
) return Boolean;
2358 -- Returns true if type T is an integer type, or if it is a
2359 -- fixed-point type to be treated as an integer (i.e. the flag
2360 -- Conversion_OK is set on the conversion node).
2362 function To_Be_Treated_As_Real
(T
: Entity_Id
) return Boolean;
2363 -- Returns true if type T is a floating-point type, or if it is a
2364 -- fixed-point type that is not to be treated as an integer (i.e. the
2365 -- flag Conversion_OK is not set on the conversion node).
2367 ------------------------------
2368 -- To_Be_Treated_As_Integer --
2369 ------------------------------
2371 function To_Be_Treated_As_Integer
(T
: Entity_Id
) return Boolean is
2375 or else (Is_Fixed_Point_Type
(T
) and then Conversion_OK
(N
));
2376 end To_Be_Treated_As_Integer
;
2378 ---------------------------
2379 -- To_Be_Treated_As_Real --
2380 ---------------------------
2382 function To_Be_Treated_As_Real
(T
: Entity_Id
) return Boolean is
2385 Is_Floating_Point_Type
(T
)
2386 or else (Is_Fixed_Point_Type
(T
) and then not Conversion_OK
(N
));
2387 end To_Be_Treated_As_Real
;
2389 -- Start of processing for Eval_Type_Conversion
2392 -- Cannot fold if target type is non-static or if semantic error.
2394 if not Is_Static_Subtype
(Target_Type
) then
2395 Check_Non_Static_Context
(Operand
);
2398 elsif Error_Posted
(N
) then
2402 -- If not foldable we are done
2404 Test_Expression_Is_Foldable
(N
, Operand
, Stat
, Fold
);
2409 -- Don't try fold if target type has constraint error bounds
2411 elsif not Is_OK_Static_Subtype
(Target_Type
) then
2412 Set_Raises_Constraint_Error
(N
);
2416 -- Remaining processing depends on operand types. Note that in the
2417 -- following type test, fixed-point counts as real unless the flag
2418 -- Conversion_OK is set, in which case it counts as integer.
2420 -- Fold conversion, case of string type. The result is not static.
2422 if Is_String_Type
(Target_Type
) then
2423 Fold_Str
(N
, Strval
(Get_String_Val
(Operand
)), False);
2427 -- Fold conversion, case of integer target type
2429 elsif To_Be_Treated_As_Integer
(Target_Type
) then
2434 -- Integer to integer conversion
2436 if To_Be_Treated_As_Integer
(Source_Type
) then
2437 Result
:= Expr_Value
(Operand
);
2439 -- Real to integer conversion
2442 Result
:= UR_To_Uint
(Expr_Value_R
(Operand
));
2445 -- If fixed-point type (Conversion_OK must be set), then the
2446 -- result is logically an integer, but we must replace the
2447 -- conversion with the corresponding real literal, since the
2448 -- type from a semantic point of view is still fixed-point.
2450 if Is_Fixed_Point_Type
(Target_Type
) then
2452 (N
, UR_From_Uint
(Result
) * Small_Value
(Target_Type
), Stat
);
2454 -- Otherwise result is integer literal
2457 Fold_Uint
(N
, Result
, Stat
);
2461 -- Fold conversion, case of real target type
2463 elsif To_Be_Treated_As_Real
(Target_Type
) then
2468 if To_Be_Treated_As_Real
(Source_Type
) then
2469 Result
:= Expr_Value_R
(Operand
);
2471 Result
:= UR_From_Uint
(Expr_Value
(Operand
));
2474 Fold_Ureal
(N
, Result
, Stat
);
2477 -- Enumeration types
2480 Fold_Uint
(N
, Expr_Value
(Operand
), Stat
);
2483 if Is_Out_Of_Range
(N
, Etype
(N
)) then
2487 end Eval_Type_Conversion
;
2493 -- Predefined unary operators are static functions (RM 4.9(20)) and thus
2494 -- are potentially static if the operand is potentially static (RM 4.9(7))
2496 procedure Eval_Unary_Op
(N
: Node_Id
) is
2497 Right
: constant Node_Id
:= Right_Opnd
(N
);
2502 -- If not foldable we are done
2504 Test_Expression_Is_Foldable
(N
, Right
, Stat
, Fold
);
2510 -- Fold for integer case
2512 if Is_Integer_Type
(Etype
(N
)) then
2514 Rint
: constant Uint
:= Expr_Value
(Right
);
2518 -- In the case of modular unary plus and abs there is no need
2519 -- to adjust the result of the operation since if the original
2520 -- operand was in bounds the result will be in the bounds of the
2521 -- modular type. However, in the case of modular unary minus the
2522 -- result may go out of the bounds of the modular type and needs
2525 if Nkind
(N
) = N_Op_Plus
then
2528 elsif Nkind
(N
) = N_Op_Minus
then
2529 if Is_Modular_Integer_Type
(Etype
(N
)) then
2530 Result
:= (-Rint
) mod Modulus
(Etype
(N
));
2536 pragma Assert
(Nkind
(N
) = N_Op_Abs
);
2540 Fold_Uint
(N
, Result
, Stat
);
2543 -- Fold for real case
2545 elsif Is_Real_Type
(Etype
(N
)) then
2547 Rreal
: constant Ureal
:= Expr_Value_R
(Right
);
2551 if Nkind
(N
) = N_Op_Plus
then
2554 elsif Nkind
(N
) = N_Op_Minus
then
2555 Result
:= UR_Negate
(Rreal
);
2558 pragma Assert
(Nkind
(N
) = N_Op_Abs
);
2559 Result
:= abs Rreal
;
2562 Fold_Ureal
(N
, Result
, Stat
);
2567 -------------------------------
2568 -- Eval_Unchecked_Conversion --
2569 -------------------------------
2571 -- Unchecked conversions can never be static, so the only required
2572 -- processing is to check for a non-static context for the operand.
2574 procedure Eval_Unchecked_Conversion
(N
: Node_Id
) is
2576 Check_Non_Static_Context
(Expression
(N
));
2577 end Eval_Unchecked_Conversion
;
2579 --------------------
2580 -- Expr_Rep_Value --
2581 --------------------
2583 function Expr_Rep_Value
(N
: Node_Id
) return Uint
is
2584 Kind
: constant Node_Kind
:= Nkind
(N
);
2588 if Is_Entity_Name
(N
) then
2591 -- An enumeration literal that was either in the source or
2592 -- created as a result of static evaluation.
2594 if Ekind
(Ent
) = E_Enumeration_Literal
then
2595 return Enumeration_Rep
(Ent
);
2597 -- A user defined static constant
2600 pragma Assert
(Ekind
(Ent
) = E_Constant
);
2601 return Expr_Rep_Value
(Constant_Value
(Ent
));
2604 -- An integer literal that was either in the source or created
2605 -- as a result of static evaluation.
2607 elsif Kind
= N_Integer_Literal
then
2610 -- A real literal for a fixed-point type. This must be the fixed-point
2611 -- case, either the literal is of a fixed-point type, or it is a bound
2612 -- of a fixed-point type, with type universal real. In either case we
2613 -- obtain the desired value from Corresponding_Integer_Value.
2615 elsif Kind
= N_Real_Literal
then
2616 pragma Assert
(Is_Fixed_Point_Type
(Underlying_Type
(Etype
(N
))));
2617 return Corresponding_Integer_Value
(N
);
2619 -- Peculiar VMS case, if we have xxx'Null_Parameter, return zero
2621 elsif Kind
= N_Attribute_Reference
2622 and then Attribute_Name
(N
) = Name_Null_Parameter
2626 -- Otherwise must be character literal
2629 pragma Assert
(Kind
= N_Character_Literal
);
2632 -- Since Character literals of type Standard.Character don't
2633 -- have any defining character literals built for them, they
2634 -- do not have their Entity set, so just use their Char
2635 -- code. Otherwise for user-defined character literals use
2636 -- their Pos value as usual which is the same as the Rep value.
2639 return UI_From_Int
(Int
(Char_Literal_Value
(N
)));
2641 return Enumeration_Rep
(Ent
);
2650 function Expr_Value
(N
: Node_Id
) return Uint
is
2651 Kind
: constant Node_Kind
:= Nkind
(N
);
2652 CV_Ent
: CV_Entry
renames CV_Cache
(Nat
(N
) mod CV_Cache_Size
);
2657 -- If already in cache, then we know it's compile time known and
2658 -- we can return the value that was previously stored in the cache
2659 -- since compile time known values cannot change :-)
2661 if CV_Ent
.N
= N
then
2665 -- Otherwise proceed to test value
2667 if Is_Entity_Name
(N
) then
2670 -- An enumeration literal that was either in the source or
2671 -- created as a result of static evaluation.
2673 if Ekind
(Ent
) = E_Enumeration_Literal
then
2674 Val
:= Enumeration_Pos
(Ent
);
2676 -- A user defined static constant
2679 pragma Assert
(Ekind
(Ent
) = E_Constant
);
2680 Val
:= Expr_Value
(Constant_Value
(Ent
));
2683 -- An integer literal that was either in the source or created
2684 -- as a result of static evaluation.
2686 elsif Kind
= N_Integer_Literal
then
2689 -- A real literal for a fixed-point type. This must be the fixed-point
2690 -- case, either the literal is of a fixed-point type, or it is a bound
2691 -- of a fixed-point type, with type universal real. In either case we
2692 -- obtain the desired value from Corresponding_Integer_Value.
2694 elsif Kind
= N_Real_Literal
then
2696 pragma Assert
(Is_Fixed_Point_Type
(Underlying_Type
(Etype
(N
))));
2697 Val
:= Corresponding_Integer_Value
(N
);
2699 -- Peculiar VMS case, if we have xxx'Null_Parameter, return zero
2701 elsif Kind
= N_Attribute_Reference
2702 and then Attribute_Name
(N
) = Name_Null_Parameter
2706 -- Otherwise must be character literal
2709 pragma Assert
(Kind
= N_Character_Literal
);
2712 -- Since Character literals of type Standard.Character don't
2713 -- have any defining character literals built for them, they
2714 -- do not have their Entity set, so just use their Char
2715 -- code. Otherwise for user-defined character literals use
2716 -- their Pos value as usual.
2719 Val
:= UI_From_Int
(Int
(Char_Literal_Value
(N
)));
2721 Val
:= Enumeration_Pos
(Ent
);
2725 -- Come here with Val set to value to be returned, set cache
2736 function Expr_Value_E
(N
: Node_Id
) return Entity_Id
is
2737 Ent
: constant Entity_Id
:= Entity
(N
);
2740 if Ekind
(Ent
) = E_Enumeration_Literal
then
2743 pragma Assert
(Ekind
(Ent
) = E_Constant
);
2744 return Expr_Value_E
(Constant_Value
(Ent
));
2752 function Expr_Value_R
(N
: Node_Id
) return Ureal
is
2753 Kind
: constant Node_Kind
:= Nkind
(N
);
2758 if Kind
= N_Real_Literal
then
2761 elsif Kind
= N_Identifier
or else Kind
= N_Expanded_Name
then
2763 pragma Assert
(Ekind
(Ent
) = E_Constant
);
2764 return Expr_Value_R
(Constant_Value
(Ent
));
2766 elsif Kind
= N_Integer_Literal
then
2767 return UR_From_Uint
(Expr_Value
(N
));
2769 -- Strange case of VAX literals, which are at this stage transformed
2770 -- into Vax_Type!x_To_y(IEEE_Literal). See Expand_N_Real_Literal in
2771 -- Exp_Vfpt for further details.
2773 elsif Vax_Float
(Etype
(N
))
2774 and then Nkind
(N
) = N_Unchecked_Type_Conversion
2776 Expr
:= Expression
(N
);
2778 if Nkind
(Expr
) = N_Function_Call
2779 and then Present
(Parameter_Associations
(Expr
))
2781 Expr
:= First
(Parameter_Associations
(Expr
));
2783 if Nkind
(Expr
) = N_Real_Literal
then
2784 return Realval
(Expr
);
2788 -- Peculiar VMS case, if we have xxx'Null_Parameter, return 0.0
2790 elsif Kind
= N_Attribute_Reference
2791 and then Attribute_Name
(N
) = Name_Null_Parameter
2796 -- If we fall through, we have a node that cannot be interepreted
2797 -- as a compile time constant. That is definitely an error.
2799 raise Program_Error
;
2806 function Expr_Value_S
(N
: Node_Id
) return Node_Id
is
2808 if Nkind
(N
) = N_String_Literal
then
2811 pragma Assert
(Ekind
(Entity
(N
)) = E_Constant
);
2812 return Expr_Value_S
(Constant_Value
(Entity
(N
)));
2816 --------------------------
2817 -- Flag_Non_Static_Expr --
2818 --------------------------
2820 procedure Flag_Non_Static_Expr
(Msg
: String; Expr
: Node_Id
) is
2822 if Error_Posted
(Expr
) and then not All_Errors_Mode
then
2825 Error_Msg_F
(Msg
, Expr
);
2826 Why_Not_Static
(Expr
);
2828 end Flag_Non_Static_Expr
;
2834 procedure Fold_Str
(N
: Node_Id
; Val
: String_Id
; Static
: Boolean) is
2835 Loc
: constant Source_Ptr
:= Sloc
(N
);
2836 Typ
: constant Entity_Id
:= Etype
(N
);
2839 Rewrite
(N
, Make_String_Literal
(Loc
, Strval
=> Val
));
2841 -- We now have the literal with the right value, both the actual type
2842 -- and the expected type of this literal are taken from the expression
2843 -- that was evaluated.
2846 Set_Is_Static_Expression
(N
, Static
);
2855 procedure Fold_Uint
(N
: Node_Id
; Val
: Uint
; Static
: Boolean) is
2856 Loc
: constant Source_Ptr
:= Sloc
(N
);
2857 Typ
: Entity_Id
:= Etype
(N
);
2861 -- If we are folding a named number, retain the entity in the
2862 -- literal, for ASIS use.
2864 if Is_Entity_Name
(N
)
2865 and then Ekind
(Entity
(N
)) = E_Named_Integer
2872 if Is_Private_Type
(Typ
) then
2873 Typ
:= Full_View
(Typ
);
2876 -- For a result of type integer, subsitute an N_Integer_Literal node
2877 -- for the result of the compile time evaluation of the expression.
2879 if Is_Integer_Type
(Typ
) then
2880 Rewrite
(N
, Make_Integer_Literal
(Loc
, Val
));
2881 Set_Original_Entity
(N
, Ent
);
2883 -- Otherwise we have an enumeration type, and we substitute either
2884 -- an N_Identifier or N_Character_Literal to represent the enumeration
2885 -- literal corresponding to the given value, which must always be in
2886 -- range, because appropriate tests have already been made for this.
2888 else pragma Assert
(Is_Enumeration_Type
(Typ
));
2889 Rewrite
(N
, Get_Enum_Lit_From_Pos
(Etype
(N
), Val
, Loc
));
2892 -- We now have the literal with the right value, both the actual type
2893 -- and the expected type of this literal are taken from the expression
2894 -- that was evaluated.
2897 Set_Is_Static_Expression
(N
, Static
);
2906 procedure Fold_Ureal
(N
: Node_Id
; Val
: Ureal
; Static
: Boolean) is
2907 Loc
: constant Source_Ptr
:= Sloc
(N
);
2908 Typ
: constant Entity_Id
:= Etype
(N
);
2912 -- If we are folding a named number, retain the entity in the
2913 -- literal, for ASIS use.
2915 if Is_Entity_Name
(N
)
2916 and then Ekind
(Entity
(N
)) = E_Named_Real
2923 Rewrite
(N
, Make_Real_Literal
(Loc
, Realval
=> Val
));
2924 Set_Original_Entity
(N
, Ent
);
2926 -- Both the actual and expected type comes from the original expression
2929 Set_Is_Static_Expression
(N
, Static
);
2938 function From_Bits
(B
: Bits
; T
: Entity_Id
) return Uint
is
2942 for J
in 0 .. B
'Last loop
2948 if Non_Binary_Modulus
(T
) then
2949 V
:= V
mod Modulus
(T
);
2955 --------------------
2956 -- Get_String_Val --
2957 --------------------
2959 function Get_String_Val
(N
: Node_Id
) return Node_Id
is
2961 if Nkind
(N
) = N_String_Literal
then
2964 elsif Nkind
(N
) = N_Character_Literal
then
2968 pragma Assert
(Is_Entity_Name
(N
));
2969 return Get_String_Val
(Constant_Value
(Entity
(N
)));
2977 procedure Initialize
is
2979 CV_Cache
:= (others => (Node_High_Bound
, Uint_0
));
2982 --------------------
2983 -- In_Subrange_Of --
2984 --------------------
2986 function In_Subrange_Of
2989 Fixed_Int
: Boolean := False)
2999 if T1
= T2
or else Is_Subtype_Of
(T1
, T2
) then
3002 -- Never in range if both types are not scalar. Don't know if this can
3003 -- actually happen, but just in case.
3005 elsif not Is_Scalar_Type
(T1
) or else not Is_Scalar_Type
(T1
) then
3009 L1
:= Type_Low_Bound
(T1
);
3010 H1
:= Type_High_Bound
(T1
);
3012 L2
:= Type_Low_Bound
(T2
);
3013 H2
:= Type_High_Bound
(T2
);
3015 -- Check bounds to see if comparison possible at compile time
3017 if Compile_Time_Compare
(L1
, L2
) in Compare_GE
3019 Compile_Time_Compare
(H1
, H2
) in Compare_LE
3024 -- If bounds not comparable at compile time, then the bounds of T2
3025 -- must be compile time known or we cannot answer the query.
3027 if not Compile_Time_Known_Value
(L2
)
3028 or else not Compile_Time_Known_Value
(H2
)
3033 -- If the bounds of T1 are know at compile time then use these
3034 -- ones, otherwise use the bounds of the base type (which are of
3035 -- course always static).
3037 if not Compile_Time_Known_Value
(L1
) then
3038 L1
:= Type_Low_Bound
(Base_Type
(T1
));
3041 if not Compile_Time_Known_Value
(H1
) then
3042 H1
:= Type_High_Bound
(Base_Type
(T1
));
3045 -- Fixed point types should be considered as such only if
3046 -- flag Fixed_Int is set to False.
3048 if Is_Floating_Point_Type
(T1
) or else Is_Floating_Point_Type
(T2
)
3049 or else (Is_Fixed_Point_Type
(T1
) and then not Fixed_Int
)
3050 or else (Is_Fixed_Point_Type
(T2
) and then not Fixed_Int
)
3053 Expr_Value_R
(L2
) <= Expr_Value_R
(L1
)
3055 Expr_Value_R
(H2
) >= Expr_Value_R
(H1
);
3059 Expr_Value
(L2
) <= Expr_Value
(L1
)
3061 Expr_Value
(H2
) >= Expr_Value
(H1
);
3066 -- If any exception occurs, it means that we have some bug in the compiler
3067 -- possibly triggered by a previous error, or by some unforseen peculiar
3068 -- occurrence. However, this is only an optimization attempt, so there is
3069 -- really no point in crashing the compiler. Instead we just decide, too
3070 -- bad, we can't figure out the answer in this case after all.
3075 -- Debug flag K disables this behavior (useful for debugging)
3077 if Debug_Flag_K
then
3088 function Is_In_Range
3091 Fixed_Int
: Boolean := False;
3092 Int_Real
: Boolean := False)
3099 -- Universal types have no range limits, so always in range.
3101 if Typ
= Universal_Integer
or else Typ
= Universal_Real
then
3104 -- Never in range if not scalar type. Don't know if this can
3105 -- actually happen, but our spec allows it, so we must check!
3107 elsif not Is_Scalar_Type
(Typ
) then
3110 -- Never in range unless we have a compile time known value.
3112 elsif not Compile_Time_Known_Value
(N
) then
3117 Lo
: constant Node_Id
:= Type_Low_Bound
(Typ
);
3118 Hi
: constant Node_Id
:= Type_High_Bound
(Typ
);
3119 LB_Known
: constant Boolean := Compile_Time_Known_Value
(Lo
);
3120 UB_Known
: constant Boolean := Compile_Time_Known_Value
(Hi
);
3123 -- Fixed point types should be considered as such only in
3124 -- flag Fixed_Int is set to False.
3126 if Is_Floating_Point_Type
(Typ
)
3127 or else (Is_Fixed_Point_Type
(Typ
) and then not Fixed_Int
)
3130 Valr
:= Expr_Value_R
(N
);
3132 if LB_Known
and then Valr
>= Expr_Value_R
(Lo
)
3133 and then UB_Known
and then Valr
<= Expr_Value_R
(Hi
)
3141 Val
:= Expr_Value
(N
);
3143 if LB_Known
and then Val
>= Expr_Value
(Lo
)
3144 and then UB_Known
and then Val
<= Expr_Value
(Hi
)
3159 function Is_Null_Range
(Lo
: Node_Id
; Hi
: Node_Id
) return Boolean is
3160 Typ
: constant Entity_Id
:= Etype
(Lo
);
3163 if not Compile_Time_Known_Value
(Lo
)
3164 or else not Compile_Time_Known_Value
(Hi
)
3169 if Is_Discrete_Type
(Typ
) then
3170 return Expr_Value
(Lo
) > Expr_Value
(Hi
);
3173 pragma Assert
(Is_Real_Type
(Typ
));
3174 return Expr_Value_R
(Lo
) > Expr_Value_R
(Hi
);
3178 -----------------------------
3179 -- Is_OK_Static_Expression --
3180 -----------------------------
3182 function Is_OK_Static_Expression
(N
: Node_Id
) return Boolean is
3184 return Is_Static_Expression
(N
)
3185 and then not Raises_Constraint_Error
(N
);
3186 end Is_OK_Static_Expression
;
3188 ------------------------
3189 -- Is_OK_Static_Range --
3190 ------------------------
3192 -- A static range is a range whose bounds are static expressions, or a
3193 -- Range_Attribute_Reference equivalent to such a range (RM 4.9(26)).
3194 -- We have already converted range attribute references, so we get the
3195 -- "or" part of this rule without needing a special test.
3197 function Is_OK_Static_Range
(N
: Node_Id
) return Boolean is
3199 return Is_OK_Static_Expression
(Low_Bound
(N
))
3200 and then Is_OK_Static_Expression
(High_Bound
(N
));
3201 end Is_OK_Static_Range
;
3203 --------------------------
3204 -- Is_OK_Static_Subtype --
3205 --------------------------
3207 -- Determines if Typ is a static subtype as defined in (RM 4.9(26))
3208 -- where neither bound raises constraint error when evaluated.
3210 function Is_OK_Static_Subtype
(Typ
: Entity_Id
) return Boolean is
3211 Base_T
: constant Entity_Id
:= Base_Type
(Typ
);
3212 Anc_Subt
: Entity_Id
;
3215 -- First a quick check on the non static subtype flag. As described
3216 -- in further detail in Einfo, this flag is not decisive in all cases,
3217 -- but if it is set, then the subtype is definitely non-static.
3219 if Is_Non_Static_Subtype
(Typ
) then
3223 Anc_Subt
:= Ancestor_Subtype
(Typ
);
3225 if Anc_Subt
= Empty
then
3229 if Is_Generic_Type
(Root_Type
(Base_T
))
3230 or else Is_Generic_Actual_Type
(Base_T
)
3236 elsif Is_String_Type
(Typ
) then
3238 Ekind
(Typ
) = E_String_Literal_Subtype
3240 (Is_OK_Static_Subtype
(Component_Type
(Typ
))
3241 and then Is_OK_Static_Subtype
(Etype
(First_Index
(Typ
))));
3245 elsif Is_Scalar_Type
(Typ
) then
3246 if Base_T
= Typ
then
3250 -- Scalar_Range (Typ) might be an N_Subtype_Indication, so
3251 -- use Get_Type_Low,High_Bound.
3253 return Is_OK_Static_Subtype
(Anc_Subt
)
3254 and then Is_OK_Static_Expression
(Type_Low_Bound
(Typ
))
3255 and then Is_OK_Static_Expression
(Type_High_Bound
(Typ
));
3258 -- Types other than string and scalar types are never static
3263 end Is_OK_Static_Subtype
;
3265 ---------------------
3266 -- Is_Out_Of_Range --
3267 ---------------------
3269 function Is_Out_Of_Range
3272 Fixed_Int
: Boolean := False;
3273 Int_Real
: Boolean := False)
3280 -- Universal types have no range limits, so always in range.
3282 if Typ
= Universal_Integer
or else Typ
= Universal_Real
then
3285 -- Never out of range if not scalar type. Don't know if this can
3286 -- actually happen, but our spec allows it, so we must check!
3288 elsif not Is_Scalar_Type
(Typ
) then
3291 -- Never out of range if this is a generic type, since the bounds
3292 -- of generic types are junk. Note that if we only checked for
3293 -- static expressions (instead of compile time known values) below,
3294 -- we would not need this check, because values of a generic type
3295 -- can never be static, but they can be known at compile time.
3297 elsif Is_Generic_Type
(Typ
) then
3300 -- Never out of range unless we have a compile time known value
3302 elsif not Compile_Time_Known_Value
(N
) then
3307 Lo
: constant Node_Id
:= Type_Low_Bound
(Typ
);
3308 Hi
: constant Node_Id
:= Type_High_Bound
(Typ
);
3309 LB_Known
: constant Boolean := Compile_Time_Known_Value
(Lo
);
3310 UB_Known
: constant Boolean := Compile_Time_Known_Value
(Hi
);
3313 -- Real types (note that fixed-point types are not treated
3314 -- as being of a real type if the flag Fixed_Int is set,
3315 -- since in that case they are regarded as integer types).
3317 if Is_Floating_Point_Type
(Typ
)
3318 or else (Is_Fixed_Point_Type
(Typ
) and then not Fixed_Int
)
3321 Valr
:= Expr_Value_R
(N
);
3323 if LB_Known
and then Valr
< Expr_Value_R
(Lo
) then
3326 elsif UB_Known
and then Expr_Value_R
(Hi
) < Valr
then
3334 Val
:= Expr_Value
(N
);
3336 if LB_Known
and then Val
< Expr_Value
(Lo
) then
3339 elsif UB_Known
and then Expr_Value
(Hi
) < Val
then
3348 end Is_Out_Of_Range
;
3350 ---------------------
3351 -- Is_Static_Range --
3352 ---------------------
3354 -- A static range is a range whose bounds are static expressions, or a
3355 -- Range_Attribute_Reference equivalent to such a range (RM 4.9(26)).
3356 -- We have already converted range attribute references, so we get the
3357 -- "or" part of this rule without needing a special test.
3359 function Is_Static_Range
(N
: Node_Id
) return Boolean is
3361 return Is_Static_Expression
(Low_Bound
(N
))
3362 and then Is_Static_Expression
(High_Bound
(N
));
3363 end Is_Static_Range
;
3365 -----------------------
3366 -- Is_Static_Subtype --
3367 -----------------------
3369 -- Determines if Typ is a static subtype as defined in (RM 4.9(26)).
3371 function Is_Static_Subtype
(Typ
: Entity_Id
) return Boolean is
3372 Base_T
: constant Entity_Id
:= Base_Type
(Typ
);
3373 Anc_Subt
: Entity_Id
;
3376 -- First a quick check on the non static subtype flag. As described
3377 -- in further detail in Einfo, this flag is not decisive in all cases,
3378 -- but if it is set, then the subtype is definitely non-static.
3380 if Is_Non_Static_Subtype
(Typ
) then
3384 Anc_Subt
:= Ancestor_Subtype
(Typ
);
3386 if Anc_Subt
= Empty
then
3390 if Is_Generic_Type
(Root_Type
(Base_T
))
3391 or else Is_Generic_Actual_Type
(Base_T
)
3397 elsif Is_String_Type
(Typ
) then
3399 Ekind
(Typ
) = E_String_Literal_Subtype
3401 (Is_Static_Subtype
(Component_Type
(Typ
))
3402 and then Is_Static_Subtype
(Etype
(First_Index
(Typ
))));
3406 elsif Is_Scalar_Type
(Typ
) then
3407 if Base_T
= Typ
then
3411 return Is_Static_Subtype
(Anc_Subt
)
3412 and then Is_Static_Expression
(Type_Low_Bound
(Typ
))
3413 and then Is_Static_Expression
(Type_High_Bound
(Typ
));
3416 -- Types other than string and scalar types are never static
3421 end Is_Static_Subtype
;
3423 --------------------
3424 -- Not_Null_Range --
3425 --------------------
3427 function Not_Null_Range
(Lo
: Node_Id
; Hi
: Node_Id
) return Boolean is
3428 Typ
: constant Entity_Id
:= Etype
(Lo
);
3431 if not Compile_Time_Known_Value
(Lo
)
3432 or else not Compile_Time_Known_Value
(Hi
)
3437 if Is_Discrete_Type
(Typ
) then
3438 return Expr_Value
(Lo
) <= Expr_Value
(Hi
);
3441 pragma Assert
(Is_Real_Type
(Typ
));
3443 return Expr_Value_R
(Lo
) <= Expr_Value_R
(Hi
);
3451 function OK_Bits
(N
: Node_Id
; Bits
: Uint
) return Boolean is
3453 -- We allow a maximum of 500,000 bits which seems a reasonable limit
3455 if Bits
< 500_000
then
3459 Error_Msg_N
("static value too large, capacity exceeded", N
);
3468 procedure Out_Of_Range
(N
: Node_Id
) is
3470 -- If we have the static expression case, then this is an illegality
3471 -- in Ada 95 mode, except that in an instance, we never generate an
3472 -- error (if the error is legitimate, it was already diagnosed in
3473 -- the template). The expression to compute the length of a packed
3474 -- array is attached to the array type itself, and deserves a separate
3477 if Is_Static_Expression
(N
)
3478 and then not In_Instance
3479 and then not In_Inlined_Body
3482 if Nkind
(Parent
(N
)) = N_Defining_Identifier
3483 and then Is_Array_Type
(Parent
(N
))
3484 and then Present
(Packed_Array_Type
(Parent
(N
)))
3485 and then Present
(First_Rep_Item
(Parent
(N
)))
3488 ("length of packed array must not exceed Integer''Last",
3489 First_Rep_Item
(Parent
(N
)));
3490 Rewrite
(N
, Make_Integer_Literal
(Sloc
(N
), Uint_1
));
3493 Apply_Compile_Time_Constraint_Error
3494 (N
, "value not in range of}", CE_Range_Check_Failed
);
3497 -- Here we generate a warning for the Ada 83 case, or when we are
3498 -- in an instance, or when we have a non-static expression case.
3501 Apply_Compile_Time_Constraint_Error
3502 (N
, "value not in range of}?", CE_Range_Check_Failed
);
3506 -------------------------
3507 -- Rewrite_In_Raise_CE --
3508 -------------------------
3510 procedure Rewrite_In_Raise_CE
(N
: Node_Id
; Exp
: Node_Id
) is
3511 Typ
: constant Entity_Id
:= Etype
(N
);
3514 -- If we want to raise CE in the condition of a raise_CE node
3515 -- we may as well get rid of the condition
3517 if Present
(Parent
(N
))
3518 and then Nkind
(Parent
(N
)) = N_Raise_Constraint_Error
3520 Set_Condition
(Parent
(N
), Empty
);
3522 -- If the expression raising CE is a N_Raise_CE node, we can use
3523 -- that one. We just preserve the type of the context
3525 elsif Nkind
(Exp
) = N_Raise_Constraint_Error
then
3529 -- We have to build an explicit raise_ce node
3533 Make_Raise_Constraint_Error
(Sloc
(Exp
),
3534 Reason
=> CE_Range_Check_Failed
));
3535 Set_Raises_Constraint_Error
(N
);
3538 end Rewrite_In_Raise_CE
;
3540 ---------------------
3541 -- String_Type_Len --
3542 ---------------------
3544 function String_Type_Len
(Stype
: Entity_Id
) return Uint
is
3545 NT
: constant Entity_Id
:= Etype
(First_Index
(Stype
));
3549 if Is_OK_Static_Subtype
(NT
) then
3552 T
:= Base_Type
(NT
);
3555 return Expr_Value
(Type_High_Bound
(T
)) -
3556 Expr_Value
(Type_Low_Bound
(T
)) + 1;
3557 end String_Type_Len
;
3559 ------------------------------------
3560 -- Subtypes_Statically_Compatible --
3561 ------------------------------------
3563 function Subtypes_Statically_Compatible
3569 if Is_Scalar_Type
(T1
) then
3571 -- Definitely compatible if we match
3573 if Subtypes_Statically_Match
(T1
, T2
) then
3576 -- If either subtype is nonstatic then they're not compatible
3578 elsif not Is_Static_Subtype
(T1
)
3579 or else not Is_Static_Subtype
(T2
)
3583 -- If either type has constraint error bounds, then consider that
3584 -- they match to avoid junk cascaded errors here.
3586 elsif not Is_OK_Static_Subtype
(T1
)
3587 or else not Is_OK_Static_Subtype
(T2
)
3591 -- Base types must match, but we don't check that (should
3592 -- we???) but we do at least check that both types are
3593 -- real, or both types are not real.
3595 elsif Is_Real_Type
(T1
) /= Is_Real_Type
(T2
) then
3598 -- Here we check the bounds
3602 LB1
: constant Node_Id
:= Type_Low_Bound
(T1
);
3603 HB1
: constant Node_Id
:= Type_High_Bound
(T1
);
3604 LB2
: constant Node_Id
:= Type_Low_Bound
(T2
);
3605 HB2
: constant Node_Id
:= Type_High_Bound
(T2
);
3608 if Is_Real_Type
(T1
) then
3610 (Expr_Value_R
(LB1
) > Expr_Value_R
(HB1
))
3612 (Expr_Value_R
(LB2
) <= Expr_Value_R
(LB1
)
3614 Expr_Value_R
(HB1
) <= Expr_Value_R
(HB2
));
3618 (Expr_Value
(LB1
) > Expr_Value
(HB1
))
3620 (Expr_Value
(LB2
) <= Expr_Value
(LB1
)
3622 Expr_Value
(HB1
) <= Expr_Value
(HB2
));
3627 elsif Is_Access_Type
(T1
) then
3628 return not Is_Constrained
(T2
)
3629 or else Subtypes_Statically_Match
3630 (Designated_Type
(T1
), Designated_Type
(T2
));
3633 return (Is_Composite_Type
(T1
) and then not Is_Constrained
(T2
))
3634 or else Subtypes_Statically_Match
(T1
, T2
);
3636 end Subtypes_Statically_Compatible
;
3638 -------------------------------
3639 -- Subtypes_Statically_Match --
3640 -------------------------------
3642 -- Subtypes statically match if they have statically matching constraints
3643 -- (RM 4.9.1(2)). Constraints statically match if there are none, or if
3644 -- they are the same identical constraint, or if they are static and the
3645 -- values match (RM 4.9.1(1)).
3647 function Subtypes_Statically_Match
(T1
, T2
: Entity_Id
) return Boolean is
3649 -- A type always statically matches itself
3656 elsif Is_Scalar_Type
(T1
) then
3658 -- Base types must be the same
3660 if Base_Type
(T1
) /= Base_Type
(T2
) then
3664 -- A constrained numeric subtype never matches an unconstrained
3665 -- subtype, i.e. both types must be constrained or unconstrained.
3667 -- To understand the requirement for this test, see RM 4.9.1(1).
3668 -- As is made clear in RM 3.5.4(11), type Integer, for example
3669 -- is a constrained subtype with constraint bounds matching the
3670 -- bounds of its corresponding uncontrained base type. In this
3671 -- situation, Integer and Integer'Base do not statically match,
3672 -- even though they have the same bounds.
3674 -- We only apply this test to types in Standard and types that
3675 -- appear in user programs. That way, we do not have to be
3676 -- too careful about setting Is_Constrained right for itypes.
3678 if Is_Numeric_Type
(T1
)
3679 and then (Is_Constrained
(T1
) /= Is_Constrained
(T2
))
3680 and then (Scope
(T1
) = Standard_Standard
3681 or else Comes_From_Source
(T1
))
3682 and then (Scope
(T2
) = Standard_Standard
3683 or else Comes_From_Source
(T2
))
3688 -- If there was an error in either range, then just assume
3689 -- the types statically match to avoid further junk errors
3691 if Error_Posted
(Scalar_Range
(T1
))
3693 Error_Posted
(Scalar_Range
(T2
))
3698 -- Otherwise both types have bound that can be compared
3701 LB1
: constant Node_Id
:= Type_Low_Bound
(T1
);
3702 HB1
: constant Node_Id
:= Type_High_Bound
(T1
);
3703 LB2
: constant Node_Id
:= Type_Low_Bound
(T2
);
3704 HB2
: constant Node_Id
:= Type_High_Bound
(T2
);
3707 -- If the bounds are the same tree node, then match
3709 if LB1
= LB2
and then HB1
= HB2
then
3712 -- Otherwise bounds must be static and identical value
3715 if not Is_Static_Subtype
(T1
)
3716 or else not Is_Static_Subtype
(T2
)
3720 -- If either type has constraint error bounds, then say
3721 -- that they match to avoid junk cascaded errors here.
3723 elsif not Is_OK_Static_Subtype
(T1
)
3724 or else not Is_OK_Static_Subtype
(T2
)
3728 elsif Is_Real_Type
(T1
) then
3730 (Expr_Value_R
(LB1
) = Expr_Value_R
(LB2
))
3732 (Expr_Value_R
(HB1
) = Expr_Value_R
(HB2
));
3736 Expr_Value
(LB1
) = Expr_Value
(LB2
)
3738 Expr_Value
(HB1
) = Expr_Value
(HB2
);
3743 -- Type with discriminants
3745 elsif Has_Discriminants
(T1
) or else Has_Discriminants
(T2
) then
3746 if Has_Discriminants
(T1
) /= Has_Discriminants
(T2
) then
3751 DL1
: constant Elist_Id
:= Discriminant_Constraint
(T1
);
3752 DL2
: constant Elist_Id
:= Discriminant_Constraint
(T2
);
3754 DA1
: Elmt_Id
:= First_Elmt
(DL1
);
3755 DA2
: Elmt_Id
:= First_Elmt
(DL2
);
3761 elsif Is_Constrained
(T1
) /= Is_Constrained
(T2
) then
3765 while Present
(DA1
) loop
3767 Expr1
: constant Node_Id
:= Node
(DA1
);
3768 Expr2
: constant Node_Id
:= Node
(DA2
);
3771 if not Is_Static_Expression
(Expr1
)
3772 or else not Is_Static_Expression
(Expr2
)
3776 -- If either expression raised a constraint error,
3777 -- consider the expressions as matching, since this
3778 -- helps to prevent cascading errors.
3780 elsif Raises_Constraint_Error
(Expr1
)
3781 or else Raises_Constraint_Error
(Expr2
)
3785 elsif Expr_Value
(Expr1
) /= Expr_Value
(Expr2
) then
3797 -- A definite type does not match an indefinite or classwide type.
3800 Has_Unknown_Discriminants
(T1
) /= Has_Unknown_Discriminants
(T2
)
3806 elsif Is_Array_Type
(T1
) then
3808 -- If either subtype is unconstrained then both must be,
3809 -- and if both are unconstrained then no further checking
3812 if not Is_Constrained
(T1
) or else not Is_Constrained
(T2
) then
3813 return not (Is_Constrained
(T1
) or else Is_Constrained
(T2
));
3816 -- Both subtypes are constrained, so check that the index
3817 -- subtypes statically match.
3820 Index1
: Node_Id
:= First_Index
(T1
);
3821 Index2
: Node_Id
:= First_Index
(T2
);
3824 while Present
(Index1
) loop
3826 Subtypes_Statically_Match
(Etype
(Index1
), Etype
(Index2
))
3831 Next_Index
(Index1
);
3832 Next_Index
(Index2
);
3838 elsif Is_Access_Type
(T1
) then
3839 return Subtypes_Statically_Match
3840 (Designated_Type
(T1
),
3841 Designated_Type
(T2
));
3843 -- All other types definitely match
3848 end Subtypes_Statically_Match
;
3854 function Test
(Cond
: Boolean) return Uint
is
3863 ---------------------------------
3864 -- Test_Expression_Is_Foldable --
3865 ---------------------------------
3869 procedure Test_Expression_Is_Foldable
3878 -- If operand is Any_Type, just propagate to result and do not
3879 -- try to fold, this prevents cascaded errors.
3881 if Etype
(Op1
) = Any_Type
then
3882 Set_Etype
(N
, Any_Type
);
3886 -- If operand raises constraint error, then replace node N with the
3887 -- raise constraint error node, and we are obviously not foldable.
3888 -- Note that this replacement inherits the Is_Static_Expression flag
3889 -- from the operand.
3891 elsif Raises_Constraint_Error
(Op1
) then
3892 Rewrite_In_Raise_CE
(N
, Op1
);
3896 -- If the operand is not static, then the result is not static, and
3897 -- all we have to do is to check the operand since it is now known
3898 -- to appear in a non-static context.
3900 elsif not Is_Static_Expression
(Op1
) then
3901 Check_Non_Static_Context
(Op1
);
3902 Fold
:= Compile_Time_Known_Value
(Op1
);
3905 -- An expression of a formal modular type is not foldable because
3906 -- the modulus is unknown.
3908 elsif Is_Modular_Integer_Type
(Etype
(Op1
))
3909 and then Is_Generic_Type
(Etype
(Op1
))
3911 Check_Non_Static_Context
(Op1
);
3915 -- Here we have the case of an operand whose type is OK, which is
3916 -- static, and which does not raise constraint error, we can fold.
3919 Set_Is_Static_Expression
(N
);
3923 end Test_Expression_Is_Foldable
;
3927 procedure Test_Expression_Is_Foldable
3934 Rstat
: constant Boolean := Is_Static_Expression
(Op1
)
3935 and then Is_Static_Expression
(Op2
);
3940 -- If either operand is Any_Type, just propagate to result and
3941 -- do not try to fold, this prevents cascaded errors.
3943 if Etype
(Op1
) = Any_Type
or else Etype
(Op2
) = Any_Type
then
3944 Set_Etype
(N
, Any_Type
);
3948 -- If left operand raises constraint error, then replace node N with
3949 -- the raise constraint error node, and we are obviously not foldable.
3950 -- Is_Static_Expression is set from the two operands in the normal way,
3951 -- and we check the right operand if it is in a non-static context.
3953 elsif Raises_Constraint_Error
(Op1
) then
3955 Check_Non_Static_Context
(Op2
);
3958 Rewrite_In_Raise_CE
(N
, Op1
);
3959 Set_Is_Static_Expression
(N
, Rstat
);
3963 -- Similar processing for the case of the right operand. Note that
3964 -- we don't use this routine for the short-circuit case, so we do
3965 -- not have to worry about that special case here.
3967 elsif Raises_Constraint_Error
(Op2
) then
3969 Check_Non_Static_Context
(Op1
);
3972 Rewrite_In_Raise_CE
(N
, Op2
);
3973 Set_Is_Static_Expression
(N
, Rstat
);
3977 -- Exclude expressions of a generic modular type, as above.
3979 elsif Is_Modular_Integer_Type
(Etype
(Op1
))
3980 and then Is_Generic_Type
(Etype
(Op1
))
3982 Check_Non_Static_Context
(Op1
);
3986 -- If result is not static, then check non-static contexts on operands
3987 -- since one of them may be static and the other one may not be static
3989 elsif not Rstat
then
3990 Check_Non_Static_Context
(Op1
);
3991 Check_Non_Static_Context
(Op2
);
3992 Fold
:= Compile_Time_Known_Value
(Op1
)
3993 and then Compile_Time_Known_Value
(Op2
);
3996 -- Else result is static and foldable. Both operands are static,
3997 -- and neither raises constraint error, so we can definitely fold.
4000 Set_Is_Static_Expression
(N
);
4005 end Test_Expression_Is_Foldable
;
4011 procedure To_Bits
(U
: Uint
; B
: out Bits
) is
4013 for J
in 0 .. B
'Last loop
4014 B
(J
) := (U
/ (2 ** J
)) mod 2 /= 0;
4018 --------------------
4019 -- Why_Not_Static --
4020 --------------------
4022 procedure Why_Not_Static
(Expr
: Node_Id
) is
4023 N
: constant Node_Id
:= Original_Node
(Expr
);
4027 procedure Why_Not_Static_List
(L
: List_Id
);
4028 -- A version that can be called on a list of expressions. Finds
4029 -- all non-static violations in any element of the list.
4031 -------------------------
4032 -- Why_Not_Static_List --
4033 -------------------------
4035 procedure Why_Not_Static_List
(L
: List_Id
) is
4039 if Is_Non_Empty_List
(L
) then
4041 while Present
(N
) loop
4046 end Why_Not_Static_List
;
4048 -- Start of processing for Why_Not_Static
4051 -- If in ACATS mode (debug flag 2), then suppress all these
4052 -- messages, this avoids massive updates to the ACATS base line.
4054 if Debug_Flag_2
then
4058 -- Ignore call on error or empty node
4060 if No
(Expr
) or else Nkind
(Expr
) = N_Error
then
4064 -- Preprocessing for sub expressions
4066 if Nkind
(Expr
) in N_Subexpr
then
4068 -- Nothing to do if expression is static
4070 if Is_OK_Static_Expression
(Expr
) then
4074 -- Test for constraint error raised
4076 if Raises_Constraint_Error
(Expr
) then
4078 ("expression raises exception, cannot be static " &
4079 "('R'M 4.9(34))!", N
);
4083 -- If no type, then something is pretty wrong, so ignore
4085 Typ
:= Etype
(Expr
);
4091 -- Type must be scalar or string type
4093 if not Is_Scalar_Type
(Typ
)
4094 and then not Is_String_Type
(Typ
)
4097 ("static expression must have scalar or string type " &
4098 "('R'M 4.9(2))!", N
);
4103 -- If we got through those checks, test particular node kind
4106 when N_Expanded_Name | N_Identifier | N_Operator_Symbol
=>
4109 if Is_Named_Number
(E
) then
4112 elsif Ekind
(E
) = E_Constant
then
4113 if not Is_Static_Expression
(Constant_Value
(E
)) then
4115 ("& is not a static constant ('R'M 4.9(5))!", N
, E
);
4120 ("& is not static constant or named number " &
4121 "('R'M 4.9(5))!", N
, E
);
4124 when N_Binary_Op | N_And_Then | N_Or_Else | N_In | N_Not_In
=>
4125 if Nkind
(N
) in N_Op_Shift
then
4127 ("shift functions are never static ('R'M 4.9(6,18))!", N
);
4130 Why_Not_Static
(Left_Opnd
(N
));
4131 Why_Not_Static
(Right_Opnd
(N
));
4135 Why_Not_Static
(Right_Opnd
(N
));
4137 when N_Attribute_Reference
=>
4138 Why_Not_Static_List
(Expressions
(N
));
4140 E
:= Etype
(Prefix
(N
));
4142 if E
= Standard_Void_Type
then
4146 -- Special case non-scalar'Size since this is a common error
4148 if Attribute_Name
(N
) = Name_Size
then
4150 ("size attribute is only static for scalar type " &
4151 "('R'M 4.9(7,8))", N
);
4155 elsif Is_Array_Type
(E
) then
4156 if Attribute_Name
(N
) /= Name_First
4158 Attribute_Name
(N
) /= Name_Last
4160 Attribute_Name
(N
) /= Name_Length
4163 ("static array attribute must be Length, First, or Last " &
4164 "('R'M 4.9(8))!", N
);
4166 -- Since we know the expression is not-static (we already
4167 -- tested for this, must mean array is not static).
4171 ("prefix is non-static array ('R'M 4.9(8))!", Prefix
(N
));
4176 -- Special case generic types, since again this is a common
4177 -- source of confusion.
4179 elsif Is_Generic_Actual_Type
(E
)
4184 ("attribute of generic type is never static " &
4185 "('R'M 4.9(7,8))!", N
);
4187 elsif Is_Static_Subtype
(E
) then
4190 elsif Is_Scalar_Type
(E
) then
4192 ("prefix type for attribute is not static scalar subtype " &
4193 "('R'M 4.9(7))!", N
);
4197 ("static attribute must apply to array/scalar type " &
4198 "('R'M 4.9(7,8))!", N
);
4201 when N_String_Literal
=>
4203 ("subtype of string literal is non-static ('R'M 4.9(4))!", N
);
4205 when N_Explicit_Dereference
=>
4207 ("explicit dereference is never static ('R'M 4.9)!", N
);
4209 when N_Function_Call
=>
4210 Why_Not_Static_List
(Parameter_Associations
(N
));
4211 Error_Msg_N
("non-static function call ('R'M 4.9(6,18))!", N
);
4213 when N_Parameter_Association
=>
4214 Why_Not_Static
(Explicit_Actual_Parameter
(N
));
4216 when N_Indexed_Component
=>
4218 ("indexed component is never static ('R'M 4.9)!", N
);
4220 when N_Procedure_Call_Statement
=>
4222 ("procedure call is never static ('R'M 4.9)!", N
);
4224 when N_Qualified_Expression
=>
4225 Why_Not_Static
(Expression
(N
));
4227 when N_Aggregate | N_Extension_Aggregate
=>
4229 ("an aggregate is never static ('R'M 4.9)!", N
);
4232 Why_Not_Static
(Low_Bound
(N
));
4233 Why_Not_Static
(High_Bound
(N
));
4235 when N_Range_Constraint
=>
4236 Why_Not_Static
(Range_Expression
(N
));
4238 when N_Subtype_Indication
=>
4239 Why_Not_Static
(Constraint
(N
));
4241 when N_Selected_Component
=>
4243 ("selected component is never static ('R'M 4.9)!", N
);
4247 ("slice is never static ('R'M 4.9)!", N
);
4249 when N_Type_Conversion
=>
4250 Why_Not_Static
(Expression
(N
));
4252 if not Is_Scalar_Type
(Etype
(Prefix
(N
)))
4253 or else not Is_Static_Subtype
(Etype
(Prefix
(N
)))
4256 ("static conversion requires static scalar subtype result " &
4257 "('R'M 4.9(9))!", N
);
4260 when N_Unchecked_Type_Conversion
=>
4262 ("unchecked type conversion is never static ('R'M 4.9)!", N
);